Fresh Fish 10/Fresh_Fish_10_2352.bin/new/biz/dbase/genealogist/scionarexx.lha/PrintPedigree.rexx

OS/2 REXX Batch file | 1995-06-02 | 20.1 KB | 724 lines

/****************************************************************************
 *                                                                          *
 * $VER: PrintPedigree 2.00 (2 Feb 1995)
 *                                                                          *
 *                      Written by Freddy Ariës                             *
 *                                                                          *
 * Output options:                                                          *
 *  1. Pedigree Chart - male ancestor line only [Dutch: stamreeks]          *
 *  2. Pedigree Chart - all ancestors, no siblings [Dutch: kwartierstaat]   *
 *  3. Pedigree Chart - all ancestors, only siblings of last generation     *
 *  4. Pedigree Chart - all ancestors, all siblings                         *
 *                                                                          *
 * 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):           *
 *  - count the number of lines output and give a formfeed 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, ....                                     *
 *  - option: include empty fields                                          *
 *  - find a good way to handle sex-fields with value '?'                   *
 *                                                                          *
 * Known Bugs/Problems:                                                     *
 *  - This script is dog slow for large databases (ie. more than, say, 10   *
 *    generations), even on Amigas with a Turboboard!                       *
 *  - Incorrect results may be returned when there are persons in the       *
 *    database whose sex-field has value '?'                                *
 *                                                                          *
 ****************************************************************************/

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 */

numpers = 1

DbtGen = 12; /* Suggested value for 68000: 10, with Turbo-boards: 12 */
/* From this generation onwards, every generation needs a confirm */
/* Note: 12 generations means (at most) 4096 persons!!! */

signal on IOERR

/* parse command line options, to allow calling the script automatically,
 * eg. from a function key
 */

do while prtin = '?'
  Tell("NUMOPT/A/N,OUTFILE/A,NOIRN/S,MAXGEN/N,QUIET/S,NOREQ/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 first 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)
GETPROGVERSION
progvers = RESULT

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

if outp & ~usereq then do
  Tell("*** PrintPedigree version "||versionstr||" ***")
  Tell("***       by Freddy Ariës      ***")
  Tell("Current database: "||dbname||NL)
end
if prtopt = 0 then do
  /* No use in asking for input if we're not allowed to output anything */
  if usereq then do
    prtopt = rtezrequest('Current Scion database: '||dbname||NL||,
      NL||'Please make your choice: '||,
      NL||'1. Pedigree Chart - male ancestor line only'||,
      NL||'2. Pedigree Chart - all ancestors, no siblings'||,
      NL||'3. Pedigree Chart - all ancestors, only last generation siblings'||,
      NL||'4. Pedigree Chart - all ancestors, all siblings'||,
      '',' _1 | _2 | _3 | _4 |E_xit','PrintPedigree 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||'ancestors 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
    Tell("1. Pedigree Chart - male ancestor line only")
    Tell("2. Pedigree Chart - all ancestors, no siblings")
    Tell("3. Pedigree Chart - all ancestors, only siblings of last generation")
    Tell("4. Pedigree Chart - all ancestors, all siblings")
    TellNN("Your choice: ")
    pull prtopt
    prtopt = CheckAnswer(prtopt)

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

    TellNN("Do you want to output the IRN (numbers) as well (y/n)? ")
    pull instr
    Tell("")
    if left(instr, 1) = "Y" | left(inp, 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 determine current person in the database.")
  else
    TermError("No person with IRN "||irn||" in the current database.")
end

if outp then do
  pname = GetNameStr(irn, 0)
  if usereq then do
    valcont = rtezrequest('The selected person is: '||NL||pname||'.'||,
      NL||'Continue?','_Continue| _Abort','PrintPedigree 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

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','PrintPedigree 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||'.PED','Output filename',,'rtfi_buffer = true   rt_pubscrname = '||PSCR||'   rtfi_initialpath = RAM:',)
        if outname = '' then
          outname = dbname||'.PED'
      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"

/* 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("Building ancestor table...")

currgen = 1
GENTREE.1 = irn

/* Build the ancestor table */
do until ~foundone
  foundone = 0
  currgen = currgen + 1
  numpers = 2 * numpers
  /* = 2 ** (currgen - 1) */
  if currgen <= MaxGens then
  do
    if currgen > DbtGen then
    do
      if usereq then
      do
        docont = rtezrequest('Also parse generation '||currgen||' ?'||,
              NL||'(this may take *very* long!)'||,
              '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
      end
      else
      do
        Tell("Also parse generation '||currgen||' ?' (this may take *very* long!)")
        pull inp
        Tell("")
        if left(inp, 1) = "Y" | left(inp, 1) = "y" then docont = 1
        else docont = 0

      end
    end
    else docont = 1

    if docont then
    do
      if prtopt = 1 then
        endnum = numpers+1
        /* no use to build the entire table, if we need only this little */
      else
        endnum = 2*numpers-1
      /*
       * TO DO: at the moment, all the numbers are parsed, even if there
       *          is only one family group with ancestors in this generation
       *        This means that thousands of fields may be checked, to find
       *        two persons. This also makes the program dog slow!
       *        I must make a better method to do this.
       */
      do ct = numpers to endnum by 2
        ct1 = ct % 2
        irn = GENTREE.ct1
        ct1 = ct + 1
        GENTREE.ct = 0
        GENTREE.ct1 = 0
        if irn ~= 0 then do
          GETPARENTS irn
          fgrn = RESULT
          EXISTFAMILY fgrn
          if RESULT = 'YES' then do
            foundone = 1
            GetParentsIRN(fgrn, ct, ct1)
          end
        end
      end
    end
  end
  else do
    if usereq then
      rtezrequest('Maximum number of'||NL||'generations reached.'||NL||,
    NL||'Output truncated','_Continue','PrintPedigree Message:','rt_pubscrname = '||PSCR)
    else
     Tell("Maximum number of generations reached. Output may be truncated.")
  end
end
numgens = currgen - 1

/* Now print all the ancestors */
if ~usereq then
  Tell("Printing data...")

OpenPrinter()

if prtopt = 1 then do
  /* print only male ancestors */
  fill = 7
  np = numpers%2
  currgen = 1
  do while np > 1
    g1 = GetGenStr(currgen, fill)
    ct1 = np + 1
    ct2 = ct % 2
    /* get the husband's data */
    g1 = g1||GetPersonStr(GENTREE.np)
    m1 = GetMarriageStr(GENTREE.ct2)
    if m1 ~= "" then
      m1 = g1||", m: "||m1
    else m1 = g1
    g1 = copies(' ',fill)
    PrintLines(m1, fill)
    /* get the wife's data */
    m1 = g1||GetPersonStr(GENTREE.ct1)
    PrintLines(m1, fill)
    PrintLF()
    currgen = currgen + 1
    np = np % 2
  end
  g1 = GetGenStr(currgen, fill)||GetPersonStr(GENTREE.np)
  g1 = g1||GetMarriages(GENTREE.np)
  PrintLines(g1, fill)
  PrintLF()
end
else do
  /* print all */
  currgen = currgen - 1
  fill = 6

  g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth-1)
  PrintLines(g1, fill)
  g1 = "1.    "||GetPersonStr(GENTREE.1)
  g1 = g1||GetMarriages(GENTREE.1)
  PrintLines(g1, fill)
  if prtopt > 2 then
    PrintSiblings(GENTREE.1, 1)
  PrintLF()

  np = 2
  currgen = currgen - 1
  do while np < numpers
    g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth)
    PrintLines(g1, fill)
    endnum = 2*np-1
    do ct = np to endnum by 2
      ct1 = ct + 1
      ct2 = ct % 2
      /* print the principal data */
      if GENTREE.ct ~= 0 then do
        g1 = left(ct||".    ",fill)||GetPersonStr(GENTREE.ct)
        m1 = GetMarriageStr(GENTREE.ct2)
        if m1 ~= "" then
          m1 = g1||", m: "||m1
        else m1 = g1
        g1 = copies(' ',fill)
        PrintLines(m1, fill)
        if prtopt = 4 then
          PrintSiblings(GENTREE.ct, ct)
      end
      /* print the spouse data */
      if GENTREE.ct1 ~= 0 then do
        m1 = left(ct1||".    ",fill)||GetPersonStr(GENTREE.ct1)
        PrintLines(m1, fill)
        if prtopt = 4 then
          PrintSiblings(GENTREE.ct1, ct1)
      end
    end
    PrintLF()
    currgen = currgen - 1
    np = np * 2
  end
end
if numgens = 1 then
  PrintLines("No ancestors are recorded for this person.", 0)

if usereq then
  rtezrequest('Output ready.','_Continue','PrintPedigree Message:','rt_pubscrname = '||PSCR)
else
  Tell("Done.")

writeln(prtdev, prtnlqoff); /* ESC[1"z NLQ off */
close(prtdev)
EXIT

/* Parse command line arguments and set the appropriate global variables */
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 = 20
/* due to the Roman numbers, we can't handle more than 40 */
/* but due to speed limitations, I don't advise using more than 20 */
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 outname = "" then */
/*  outname = "STDOUT"  */

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 = "PEDIGREE CHART - MALE ANCESTOR LINE ONLY"
else if prtopt = 2 then
  prtstr = "PEDIGREE CHART - ALL ANCESTORS, NO SIBLINGS"
else if prtopt = 3 then
  prtstr = "PEDIGREE CHART - ALL ANCESTORS, ONLY SIBLINGS OF LAST GENERATION"
else
  prtstr = "PEDIGREE CHART - ALL ANCESTORS, ALL SIBLINGS"
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 0

PrintSiblings: PROCEDURE EXPOSE prtdev plwidth prtopt useirn
parse arg inum, prenum
GETPARENTS inum
famfgrn = RESULT
EXISTFAMILY famfgrn
if RESULT ~= 'YES' then return 0; /* no parents, then no siblings */
ix = 0; chnum = 0
do until ischld ~= 'YES'
  GETCHILD famfgrn ix
  prsn = RESULT
  EXISTPERSON prsn
  ischld = RESULT
  if ischld = 'YES' & prsn ~= inum then do
    chnum = chnum + 1
    ostr = copies(' ',7)||prenum||D2C(chnum+96)". "||GetPersonStr(prsn)
    PrintLines(ostr, 11)
    if chnum = 26 then return 0; /* 'z': can't handle more than 26 children */
  end
  ix = ix + 1
end
return 0

GetGenStr: PROCEDURE EXPOSE prtopt 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 prtopt = 1 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

GetNameStr: PROCEDURE EXPOSE useirn
parse arg gnum
/* prtdson = '1B'x||"[1m";    * ESC[1m boldface on    */
/* prtdsoff = '1B'x||"[22m";  * ESC[22m boldface off  */
GETFIRSTNAME gnum
name = RESULT
if name ~= "" then name = name||" "
GETLASTNAME gnum
lname = RESULT
if lname = "" then lname = "UNKNOWN"
name = name||lname
/* another option: name = name||prtdson||lname||prtdsoff
 * Problem: see PrintLines
 */
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

GetParentsIRN: PROCEDURE EXPOSE GENTREE.
parse arg fnum, ct, ct1
fath = 0; moth = 0
GETSPOUSE fnum
sps = RESULT
EXISTPERSON sps
if RESULT = 'YES' then do
  GETSEX sps
  if RESULT = 'M' then
    fath = sps
  else moth = sps
end
GETPRINCIPAL fnum
prn = RESULT
/* If there are two mothers, or two fathers, then name the principal
 * as 'father' and the spouse as 'mother'
 */
EXISTPERSON prn
if RESULT = 'YES' then do
  GETSEX prn
  if RESULT = 'M' then do
    if fath ~= 0 then
      moth = sps
    fath = prn
  end
  else if moth ~= 0 then
    fath = prn
  else
    moth = prn
end
GENTREE.ct = fath
GENTREE.ct1 = moth
return 0

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
return pnum

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

CheckIRN: PROCEDURE EXPOSE outp prtdev usereq
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
/* Tell, No Newline */
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