Amiga MA Magazine 1998 #3/amigamamagazinepolishissue1998.iso/bazy/scion407/scionarexx.lha/PrintDescendant.rexx

OS/2 REXX Batch file | 1995-06-01 | 19KB | 691 lines

/****************************************************************************
 *                                                                          *
 * $VER: PrintDescendant 2.00 (2 Feb 1995)
 *                                                                          *
 *                      Written by Freddy Ariës                             *
 *                                                                          *
 * Output options:                                                          *
 *  1. Descendant Chart - all descendants [Dutch: parenteel]                *
 *  2. Descendant Chart - male descendants (mention daughters, no children) *
 *     [Dutch: genealogie - nageslacht van zonen, maar vermelding dochters] *
 *  3. Descendant Chart - male descendants (leave out daughters)            *
 *     [Dutch: stamboom - nageslacht van zonen, geen vermelding dochters]   *
 *                                                                          *
 * This version uses (by default) the rexxreqtools.library (which requires  *
 * a version of reqtools larger than 2.0 and rexxsyslib.library)            *
 * If you do not have these, you need to supply the NOREQ argument (for     *
 * Shell output), or the QUIET argument (for no output at all).             *
 *                                                                          *
 * As of v2 of this script, and Scion V4, the current person on Scion's     *
 * Personal Window will be used to determine where the search starts.       *
 * Scion 3.13 can still be used, though, in which case the user will be     *
 * asked at which IRN he wants to start.                                    *
 *                                                                          *
 * TO DO (mostly low priority, unless someone really wants this):           *
 *  - find a good way to handle the people with sex '?'                     *
 *  - count the number of lines output and give a linefeed after a certain  *
 *    number (ie. skip page breaks)                                         *
 *  - add a menu option for the maximum number of generations to print      *
 *  - allow user to specify if he wants burial data printed, occupation,    *
 *    comments, references fields, ....                                     *
 *  - If the person has multiple marriages, output a list to the            *
 *    screen and let the user select one (1..x), or all (0).                *
 *                                                                          *
 ****************************************************************************/

options results
arg prtin outname noirn mgen outval

versionstr = "2.00"
usereq = 1; /* change this to 0 if you don't want to use reqtools */
outp = 1; useirn = 1; prtdev = stdout; prtopt = 0
plwidth = 78;  /* linewidth of the printer */
NL = '0A'x
PSCR = 'SCIONGEN'; /* public screen to open the requesters on */

signal on IOERR

do while prtin = '?'
  Tell("NUMOPT/A/N,OUTFILE/A,NOIRN/S,MAXGEN/N,NOREQ/S,QUIET/S: ")
  pull prtin outname noirn mgen outval
end

ParseArguments()

if usereq & ~show('l','rexxreqtools.library') then do
  if exists('libs:rexxreqtools.library') then
    call addlib('rexxreqtools.library',0,-30,0)
  else do
    usereq = 0; outp = 1
    Tell("Unable to open rexxreqtools.library - using text output")
  end
end

/* These few lines were stolen from Peter Billings - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
  TermError('I am sorry to say that the SCION Genealogist' || NL ||,
    'database is not available. Please start the' || NL ||,
    'SCION program BEFORE using this script!')
end

myport = "SCIONGEN"
address value myport
GETDBNAME
dbname = upper(RESULT)
fill = 7;        /* number of spaces at the beginning of lines */
malesex = 'M';   /* as of V4, sexes are always 'M', 'F' or '?' */
femalesex = 'F'
GETPROGVERSION
progvers = RESULT

if progvers >= 4 then do
  GETCURRENTIRN
  irn = RESULT
end

if outp & ~usereq then do
  Tell("*** PrintDescendant version "||versionstr||" ***")
  Tell("***        by Freddy Ariës       ***")
  Tell("Current database: "||dbname||NL)
end
if prtopt = 0 then do
  if usereq then do
    prtopt = rtezrequest('Current Scion database: '||dbname||NL||,
      NL||'Please make your choice: '||,
      NL||' 1. Descendant Chart - all descendants'||,
      NL||' 2. Descendant Chart - male descendants'||,
      NL||'    (mention daughters, without children)'||,
      NL||' 3. Descendant Chart - male descendants'||,
      NL||'    (leave out daughters)'||,
      '',' _1 | _2 | _3 |E_xit','PrintDescendant v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
    if prtopt = 0 then
      EXIT

    if progvers < 4 then do
      irn = rtgetlong(,'Enter the IRN of the person whose'||,
            NL||'descendants you want to print: '||,
            NL,'Input Request:','_Continue','rt_pubscrname = '||PSCR)
      if irn = '' then
        EXIT
      irn = abs(irn)
    end

    useirn = rtezrequest('Do you want to output the IRNs'||,
              NL||'(the record numbers) as well?'||,
              '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
  end
  else do
    /* No use in asking for input if we're not allowed to output anything */
    Tell("1. Descendant Chart - all descendants")
    Tell("2. Descendant Chart - male descendants (mention daughters, without children)")
    Tell("3. Descendant Chart - male descendants (leave out daughters)")
    TellNN("Your choice: ")
    pull prtopt
    prtopt = CheckAnswer(prtopt)

    if progvers < 4 then do
      TellNN("Enter the IRN of the person whose descendants you want to print: ")
      pull irn
    end

    TellNN("Do you want to output the IRNs (numbers) as well (y/n)? ")
    pull instr
    Tell("")
    if left(instr, 1) = "Y" then useirn = 1
    else useirn = 0
  end
end

if progvers < 4 then do
  irn = CheckIRN(irn)
end

EXISTPERSON irn
if RESULT ~= 'YES' then
do
  if progvers >= 4 then
    TermError("Unable to locate current person in the current database.")
  else
    TermError("No person with IRN "||irn||" in the current database.")
end

if prtopt > 1 then do
  GETSEX irn
  parsex = RESULT
  if prtopt = 3 & parsex = femalesex then
    TermError("Person isn't male - nothing to print.")
end

if outp then do
  /* No use trying to get input if we're not allowed to ask anything */
  pname = GetNameStr(irn, 0)
  if prtopt = 1 | parsex = malesex then do
    if usereq then do
      valcont = rtezrequest('The selected person is: '||NL||pname||'.'||,
        NL||'Continue?','_Continue| _Abort','PrintDescendant Request:','rt_pubscrname = '||PSCR)
      if valcont = 0 then
        EXIT
    end
    else do
      TellNN("Current person is "||pname||". Continue? (y/n) ")
      pull valcont
      if left(valcont, 1) ~= 'Y' then
        TermError("Ok.")
    end
  end
  else do
    /* with prtopt = 2, we would only print the (generation I) female and
     * her husbands, but no children!
     */
    if usereq then do
      valcont = rtezrequest("WARNING!!! Person "||NL||pname||,
        NL||"is not male! Continue anyway?",'_Continue| _Abort','PrintDescendant Request:','rt_pubscrname = '||PSCR)
      if valcont = 0 then
        EXIT
    end
    else do
      Tell("WARNING! Person "||pname||" isn't male!")
      TellNN("Continue anyway? (y/n) ")
      pull valcont
      if left(valcont, 1) ~= 'Y' then
        TermError("Ok.")
    end
  end
end

/* TO DO: (at this location:)
 * If the person has multiple marriages, output the spouse name, IRN
 * and FGRN to screen, and let the user select one (1..x), or all (0)
 */

if outp & outname = "" then do
  if usereq then do
    odev = rtezrequest('Current Scion database: '||dbname||,
      NL||'Where should the output be sent to?'||,
      NL,' _File |_Printer|_Screen|_Nowhere','PrintDescendant v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
    select
      when odev = 1 then do
        /* We need a file requester for further data */
        dblen = length(dbname)
        if dblen>6 & right(dbname, 6)=".SCION" then
          dbname=left(dbname, dblen - 6)
        outname = rtfilerequest(,dbname||'.DSC','Output filename',,'rtfi_buffer = true   rt_pubscrname = '||PSCR||'   rtfi_initialpath = RAM:',)
        if outname = '' then
          outname = dbname||'.DSC'
      end
      when odev = 2 then
        outname = 'PRT:'
      when odev = 3 then
        outname = 'STDOUT'
      otherwise
        EXIT
        /* You selected 'Nowhere' */
    end
  end
  else do
    Tell("Enter output file (filename with complete path, or PRT: for printer,")
    TellNN("or STDOUT for screen): ")
    pull outname
    if outname = "" then
      outname = "STDOUT"
  end
end

/* Anyone know a better way to translate numbers into Roman? */
GenerationS.1 = "I II III IV V VI VII VIII IX X XI XII XIII XIV XV XVI XVII XVIII XIX XX"
GenerationS.2 = "XXI XXII XXIII XXIV XXV XXVI XXVII XXVIII XXIX XXX XXXI XXXII XXXIII XXXIV XXXV XXXVI XXXVII XXXVIII IXL XL"
MaxChild = 26

/* Printer Codes, some of which are currently unused: */
ESC = '1B'x
prtinit = ESC||"#1";     /* ESC#1 initialize      */
prtundon = ESC||"[4m";   /* ESC[4m underline on   */
prtundoff = ESC||"[24m"; /* ESC[24m underline off */
prtdson = ESC||"[1m";    /* ESC[1m boldface on    */
prtdsoff = ESC||"[22m";  /* ESC[22m boldface off  */
prtnlqon = ESC||"[2"||'22'x||"z"; /* ESC[2"z NLQ on */
prtnlqoff = ESC||"[1"||'22'x||"z"; /* ESC[1"z NLQ off */

if ~usereq then
  Tell("Printing...")

OpenPrinter()

childnums = irn; childgens = "1"
alcount = 0; chcount = 0

do while childnums ~= ""
  irn = word(childnums, 1)
  cgen = word(childgens, 1)
  if cgen ~= currgen then do
    alcount = 0
    /* New generation: reset alfabet counter */
    currgen = cgen
    genchild = 0
  end
  childnums = delstr(childnums, 1, length(irn)+1)
  childgens = delstr(childgens, 1, length(currgen)+1)

  ccnt = 1
  /* Sex to use with options 2 and 3 */
  GETSEX irn
  parsex = RESULT

  g1 = GetPersonStr(irn)
  mnum = 0
  GETMARRIAGE irn mnum
  fgrn = RESULT
  EXISTFAMILY fgrn
  ftrue = RESULT

  do while ftrue = 'YES'
    m1 = GetMarriageStr(fgrn)
    ptn = GetPartnerIRN(fgrn, irn)
    if ptn ~= 0 then do
      if m1 ~= "" then m1 = m1||' '
      m1 = m1||GetPersonStr(ptn)
    end
    if m1 ~= "" then m1 = ", m: "||m1
    if ccnt = 1 then do
      ggs = GetGenStr(currgen, 0)
      if currgen > 1 then do
        alcount = alcount + 1
    /* TO DO: only if this person has any siblings who have children,
     *      or if there are other persons (with children) on this
     *      generation
     */
        ggs = ggs||D2C(alcount+96)
      end
      ggs = left(ggs||".       ", fill)
      m1 = ggs||g1||m1||'.'
      ccnt = 0
    end
    else
      m1 = copies(' ',fill)||g1||m1||'.'
    PrintLines(m1, fill)
    if prtopt ~= 3 | parsex = malesex then
      chcount = chcount + PrintChildren(fgrn, parsex)
    PrintLF()
    mnum = mnum + 1
    GETMARRIAGE irn mnum
    fgrn = RESULT
    EXISTFAMILY fgrn
    ftrue = RESULT
  end
  if mnum = 0 then do
    m1 = GetGenStr(currgen,fill)||g1
    PrintLines(m1, fill)
    if currgen = 1 then
      PrintLines("No marriages are recorded for this person.", 0)
    PrintLF()
  end
end
if currgen = 1 & chcount = 0 then do
  if prtopt = 1 then
    PrintLines("No descendants are recorded for person.")
  else
    PrintLines("No male descendants are recorded for person.")
end

writeln(prtdev, prtnlqoff);
close(prtdev)
if usereq then
  rtezrequest('Output ready.','E_xit','PrintDescendant Message:','rt_pubscrname = '||PSCR)
else
  Tell("Done.")
EXIT

ParseArguments:
if noirn = "NOIRN" then useirn = 0
else if noirn = "QUIET" || noirn = "NOREQ" then do
  outval = noirn
  noirn = ""
end
else do
  outval = mgen
  mgen = noirn
  noirn = ""
end
if mgen = "QUIET" || mgen = "NOREQ" then do
  outval = mgen
  mgen = ""
end

MaxGens = 40; /* due to the Roman numbers, we can't handle more */
if mgen ~= "" then do
  if DATATYPE(mgen, 'w') & mgen > 0 & mgen < MaxGens then
    MaxGens = mgen
end

if outval = "QUIET" then do
  usereq = 0
  outp = 0
end
else if outval = "NOREQ" then
  usereq = 0

if prtin = "" then do
  prtopt = 0
  if ~outp then TermError("Requires argument is missing.")
    /* actually, with outp = 0, all it does is EXIT */
end
else do
  prtopt = CheckAnswer(prtin)
  /* Note that it was important to establish outp before calling these */
end
return 0

OpenPrinter:
/* Open the printer device and print out a nice header */
if outname = "STDOUT" then
  prtdev = stdout
else do
  prtdev = 'PRINTER'
  if ~open(prtdev, outname, 'w') then
    TermError("ERROR: Failed to open output file!")
end
writeln(prtdev, prtinit||prtnlqon)
if prtopt = 1 then
  prtstr = "DESCENDANT CHART - ALL DESCENDANTS"
else if prtopt = 2 then
  prtstr = "DESCENDANT CHART - ONLY MALE DESCENDANTS (TYPE I)"
else
  prtstr = "DESCENDANT CHART - ONLY MALE DESCENDANTS (TYPE II)"
prtstr = prtundon||prtdson||prtstr||prtdsoff||prtundoff
writeln(prtdev, prtstr)
prtstr = prtdson||"Report printed on: "||date()||prtdsoff
writeln(prtdev, prtstr)
prtstr = copies('=', plwidth)
writeln(prtdev, prtstr)
return 0

PrintLines: PROCEDURE EXPOSE prtdev plwidth prtopt
parse arg ostr, fill
/* TO DO:
 * if there are control strings within ostr (like prtdson or prtdsoff)
 * don't include them in the length count
 */
do while ostr ~= ""
  nnl = plwidth+1
  if length(ostr) > plwidth then do
    do until pc = ' ' | nnl = 1
      pc = substr(ostr, nnl, 1)
      nnl = nnl - 1
    end
    if nnl = 1 then do
      prtstr = left(ostr, plwidth)
      ostr = delstr(ostr, 1, nnl)
    end
    else do
      prtstr = left(ostr, nnl)
      ostr = delstr(ostr, 1, nnl+1)
    end
  end
  else do
    prtstr = ostr
    ostr = ""
  end
  writeln(prtdev, prtstr)
  if ostr ~= "" then
    ostr = copies(' ',fill)||ostr
end
return 0

PrintLF:
writeln(prtdev, "")
return 1

PrintChildren:
parse arg ffnum, parsx
/* If we turn this into a PROCEDURE, we'll have to EXPOSE a lot!
 * The disadvantage now is that we have to be extremely careful
 * not to overwrite any global variables by accident!
 */
cidx = 0; cham = 0
GETCHILD ffnum cidx
chld = RESULT
EXISTPERSON chld
ctrue = RESULT
nextgen = currgen + 1
if nextgen > MaxGens then return cham
  /* Maximum number of generations reached! */
do while ctrue = 'YES'
  cidx = cidx + 1
  if prtopt > 1 then do
    GETSEX chld
    csx = RESULT
  end
  if prtopt ~= 3 | csx = malesex then do
    cham = cham + 1
    m1 = copies(' ',8)||cham||". "||GetChildStr(chld)
    if (prtopt = 1 | csx = malesex) & HasChild(chld) then do
      childnums = childnums||chld||' '
      childgens = childgens||nextgen||' '
      genchild = genchild + 1
      if genchild > MaxChild then return 1
      /* Maximum number of children reached! */
      /* TO DO: if genchild = 1 and the current person has no siblings,
       *    or none of his siblings have any children of their own,
       *    and if there are no other persons with children on this
       *    generation, then leave off the D2C part
       */
      m1 = m1||", see "||GetGenStr(nextgen, 0)||D2C(genchild+96)
    end
    else
      m1 = m1||GetDeathStr(chld)||GetMarriages(chld)
    PrintLines(m1||'.', 11)
  end
  GETCHILD ffnum cidx
  chld = RESULT
  EXISTPERSON chld
  ctrue = RESULT
end
return cham

GetGenStr: PROCEDURE EXPOSE GenerationS.
parse arg gnum, fill
if gnum <= 20 then
  gstr = word(GenerationS.1, gnum)
else if gnum <= 40 then
  gstr = word(GenerationS.2, gnum)
else
  return ""
if fill > 0 then
  gstr = left(gstr||".       ",fill)
return gstr

GetPersonStr: PROCEDURE EXPOSE useirn
parse arg irn
if irn ~= 0 then do
  nstr = GetNameStr(irn)
  nstr = nstr||GetBirthStr(irn)
  nstr = nstr||GetDeathStr(irn)
end
else
  nstr = "UNKNOWN"
return nstr

GetChildStr: PROCEDURE EXPOSE useirn
parse arg irn
if irn ~= 0 then do
  nstr = GetNameStr(irn)
  nstr = nstr||GetBirthStr(irn)
end
else
  nstr = "UNKNOWN"
return nstr

HasChild: PROCEDURE EXPOSE prtopt malesex
parse arg irn
mnum = 0
GETMARRIAGE irn mnum
marr = RESULT
EXISTFAMILY marr
mtrue = RESULT
do while mtrue = 'YES'
  chnxt = 0
  GETCHILD marr chnxt
  ch = RESULT
  EXISTPERSON ch
  ct = RESULT
  if prtopt < 3 then do
    if ct = 'YES' then return 1
  end
  else do
    /* For option 3: search for male children */
    do while ct = 'YES'
      GETSEX ch
      csx = RESULT
      if csx = malesex then return 1
      chnxt = chnxt + 1
      GETCHILD marr chnxt
      ch = RESULT
      EXISTPERSON ch
      ct = RESULT
    end
  end
  mnum = mnum + 1
  GETMARRIAGE irn mnum
  marr = RESULT
  EXISTFAMILY marr
  mtrue = RESULT
end
return 0

GetNameStr: PROCEDURE EXPOSE useirn
parse arg gnum
GETFIRSTNAME gnum
name = RESULT
if name ~= "" then name = name||" "
GETLASTNAME gnum
lname = RESULT
if lname = "" then lname = "UNKNOWN"
name = name||lname
if useirn then name = name||" ["gnum"]"
return name

GetBirthStr: PROCEDURE
parse arg gnum
GETBIRTHPLACE gnum
bstr = RESULT
GETBIRTHDATE gnum
bdat = RESULT
if bdat ~= "" & bstr ~= "" then bstr = bstr||" "
bstr = bstr||bdat
if bstr ~= "" then bstr = ", b: "||bstr
return bstr

GetDeathStr: PROCEDURE
parse arg gnum
GETDEATHPLACE gnum
dstr = RESULT
GETDEATHDATE gnum
ddat = RESULT
if ddat ~= "" & dstr ~= "" then dstr = dstr||" "
dstr = dstr||ddat
if dstr ~= "" then dstr = ", d: "||dstr
return dstr

GetMarriages: PROCEDURE EXPOSE useirn
parse arg irn
mstr = ""
GETMARRIAGE irn 0
mf = RESULT
EXISTFAMILY mf
if RESULT = 'YES' then do
  mtrue = 1
  GETMARRIAGE irn 1
  m2 = RESULT
  EXISTFAMILY m2
  if RESULT = 'YES' then mset = 1
  else mset = 0
end
else
  mtrue = 0
mnum = 0
do while mtrue
  m1 = GetMarriageStr(mf)
  if m1 ~= "" then m1  = m1||' '
  ptn = GetPartnerIRN(mf, irn)
  m1 = m1||GetPersonStr(ptn)

  if mset then mstr = ", m("||mnum||"): "||m1
  else mstr = ", m: "||m1

  mnum = mnum + 1
  GETMARRIAGE irn mnum
  mf = RESULT
  EXISTFAMILY mf
  if RESULT ~= 'YES' then mtrue = 0
end
return mstr

GetMarriageStr: PROCEDURE
parse arg mf
GETMARRYPLACE mf
mstr = RESULT
GETMARRYDATE mf
mdat = RESULT
if mdat ~= "" & mstr ~= "" then mstr = mstr||" "
mstr = mstr||mdat
return mstr

GetPartnerIRN: PROCEDURE
parse arg fnum, inum
GETPRINCIPAL fnum
prn = RESULT
GETSPOUSE fnum
sps = RESULT
if inum = prn then pnum = sps
else if inum = sps then pnum = prn
else pnum = 0
EXISTPERSON pnum
if RESULT ~= 'YES' then pnum = 0
return pnum

CheckAnswer: PROCEDURE EXPOSE outp prtdev
parse arg str
str = left(str, 1)
if ~DATATYPE(str, 'w') then
  TermError("Arg(1): not a valid option number.")
if str < 1 | str > 3 then
  TermError("Arg(1): not a valid option number.")
return str

CheckIRN: PROCEDURE EXPOSE outp prtdev
parse arg str
if ~DATATYPE(str, 'w') then
  TermError("Arg(2): not a valid IRN.")
return str

Tell: PROCEDURE EXPOSE outp
parse arg str
if outp then
  writeln(stdout, str)
return 0

TellNN: PROCEDURE EXPOSE outp
parse arg str
if outp then
  writech(stdout, str)
return 0

TermError: PROCEDURE EXPOSE outp prtdev usereq PSCR
parse arg str
/* If you turned off stdout, no error messages will be shown! */
if usereq then
  rtezrequest(str,'E_xit','PrintDescendant Message:','rt_pubscrname = '||PSCR)
else do
  Tell(str || '0A'x)
end
close(prtdev)
EXIT

/* Let's make sure you get a nice message when you turn off the printer :-) */

IOERR:
bline = SIGL
say "I/O error #"||RC||" detected in line "||bline||":"
say sourceline(bline)
EXIT