diff --git a/reports/2ppage.ll b/reports/2ppage.ll new file mode 100644 index 0000000..f8f7947 --- /dev/null +++ b/reports/2ppage.ll @@ -0,0 +1,191 @@ +/* + * @progname 2ppage.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output Text, 80 cols + * @description + * + * It will produce a report of all INDI's in the database, with + * two records printed per page. Record 1 and 2 will be on the + * first page. + * + * 2ppage (2 INDI's per page) + * + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * Modifications by Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1991, + * and it has been modified many times since. + * + * It will produce a report of all INDI's in the database, with + * two records printed per page. Record 1 and 2 will be on the + * first page. + * + * It will produce ASCII file output. + +This short report show how many different things may be done with +the report language. + +These next two paragraphs were by Tom, when he sent me the following +report - which we had been discussing via email. At the time I wanted +this format for a book I was writing for a Mother-in-Law. + + This report is using the `pagemode' feature. This allows use +use of the `pos' command to go to any row and column coordinate on a page. +The routine `pageout' dumps the current page to the output file, and +prepares for the program to compose another page. + + Notice how the `gettoday' function is used to get today's date to +print out. Also note that the `mod' function is used to put every other +person on the top half, and the other every other person on the bottom +half. Also note that the variable `page' counts the page numbers. + +*/ + +proc main () +{ + pagemode(66,80) + monthformat(4) + + set(tday, save(stddate(gettoday()))) + + set(page, 1) + forindi(i, n) { + if (mod(n,2)) { + pos(2,1) +" = = = = MANES / MANIS Family History & Genealogy = = = " tday nl() + pos(65,1) +" = = = Cliff Manis, PO Box 33937, San Antonio, TX 78265 = = " d(page) +nl () + set(page, add(page,1)) + pos(4,1) + call oneout(i) + } else { + pos(34,1) + call oneout(i) + pageout() + } + } + if (mod(n,2)) { + pageout() + } +} +proc oneout (i) +{ + set(f, father(i)) + set(m, mother(i)) + + " FULL NAME: " name(i) col(46) "(" key(i) ")" nl() nl() + " FATHER: " name(f) col(46) "(" key(f) ")" nl() + " MOTHER: " name(m) col(46) "(" key(m) ")" nl() nl() + " Born: " stddate(birth(i)) " at " place(birth(i)) nl() + call outmarriages(i) nl() + " Died: " stddate(death(i)) " at " place(death(i)) nl() nl() + call outchildren(i) +} +proc outmarriages (i) +{ + spouses(i, s, f, n) { + if (eq(1, n)) { + " Married: " stddate(marriage(f)) nl() + " Married to: " name(s) col(46) "("key(s)")" nl() + } else { + " Remarried: " stddate(marriage(f)) nl() + " Remarried to:" name(s) col(46) "("key(s)")" nl() + } + } +} +proc outchildren (i) +{ + set(j, 0) + families(i, f, s, n) { + set(j, add(j, nchildren(f))) + } + " Number of Children: " d(j) nl() + set(j, 1) + families(i, f, s, n) { + children(f, c, m) { + " " d(j) ". " name(c) col(46) "("key(c)")" + col(57) "Born: " stddate(birth(c)) nl() + set(j, add(j,1)) + } + } +} + + +/* + * Sample output + + + = = = = MANES / MANIS Family History & Genealogy = = = 15 Jan 1993 + + FULL NAME: Wilee "Wyley" WORWICK (3) + + FATHER: Wyley WORWICK (1) + MOTHER: Wife of Wyley WORWICK (2) + + Born: 1824 at + Married: 31 Oct 1844 + Married to: Martha D. JOHNSON (4) + + Died: Nov 1874 at Union Co, TN + + Number of Children: 10 + 1. Tempia Catherine WARWICK (5) Born: 1846 + 2. Louisa Mahayla WARWICK (6) Born: 1848 + 3. Margarett WARWICK (7) Born: 1850 + 4. Mary WARWICK (8) Born: 1852 + 5. Matilda WARWICK (9) Born: 1854 + 6. Calaway WARWICK (10) Born: 29 Jul 1855 + 7. Jamima WARWICK (11) Born: 1858 + 8. Nancy Elizabeth WARWICK (12) Born: 1860 + 9. Rebecca WARWICK (13) Born: 1864 + 10. Martha WARWICK (14) Born: Sep 1869 + + + + + + + + + FULL NAME: Martha D. JOHNSON (4) + + FATHER: () + MOTHER: () + + Born: 1825 at NC + Married: 31 Oct 1844 + Married to: Wilee "Wyley" WORWICK (3) + Remarried: + Remarried to:William PETREE (22) + + Died: at + + Number of Children: 10 + 1. Tempia Catherine WARWICK (5) Born: 1846 + 2. Louisa Mahayla WARWICK (6) Born: 1848 + 3. Margarett WARWICK (7) Born: 1850 + 4. Mary WARWICK (8) Born: 1852 + 5. Matilda WARWICK (9) Born: 1854 + 6. Calaway WARWICK (10) Born: 29 Jul 1855 + 7. Jamima WARWICK (11) Born: 1858 + 8. Nancy Elizabeth WARWICK (12) Born: 1860 + 9. Rebecca WARWICK (13) Born: 1864 + 10. Martha WARWICK (14) Born: Sep 1869 + + + + + + + + = = = Cliff Manis, PO Box 33937, San Antonio, TX 78265 = = 2 + + - end of report - + + */ diff --git a/reports/4gen1.ll b/reports/4gen1.ll new file mode 100644 index 0000000..bc17a4b --- /dev/null +++ b/reports/4gen1.ll @@ -0,0 +1,139 @@ +/* + * @progname 4gen1.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output Text, 80 cols + * @description + * + * select and produce a ancestor report for the person selected. + * Output is an ASCII file, and will probably need to be printed + * using 10 or 12 pitch. + * + * 4gen1 + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * With modifications by: Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * + * select and produce a ancestor report for the person selected. + * + * Output is an ASCII file, and will probably need to be printed + * using 10 or 12 pitch. + * + * An example of the output may be seen at end of this report. + */ + + +proc main () +{ + getindi(indi) + pagemode(64,80) + call pedout(indi,1,4,1,64) + pageout() + print(nl()) +} + +proc pedout (indi, gen, max, top, bot) +{ + if (and(indi,le(gen,max))) { + set(gen,add(1,gen)) + set(fath,father(indi)) + set(moth,mother(indi)) + set(height,add(1,sub(bot,top))) + set(offset,div(sub(height,8),2)) + call block(indi,add(top,offset),mul(10,sub(gen,2))) + set(half,div(height,2)) + call pedout(fath,gen,max,top,sub(add(top,half),1)) + call pedout(moth,gen,max,add(top,half),bot) + } +} + +proc block (indi, row, col) +{ + print(".") + set(row,add(3,row)) + set(col,add(3,col)) + pos(row,col) + name(indi) + set(row,add(row,1)) + pos(row,col) + set(e,birth(indi)) + " b. " + if (and(e,date(e))) { date(e) } + set(row,add(row,1)) + pos(row,col) + " bp. " + if (and(e,place(e))) { place(e) } +} + +/* Sample output of the 4gen1 report: + Person requested was: a c /manis + + + William Thomas MANES + b. 26 Nov 1828 + bp. Hamblen, Tennessee + + William Bowers MANES + b. 6 Jan 1868 + bp. Hamblen Co, TN ? + + Martha A. BOWERS + b. 14 APR 1829 + bp. TN + + Fuller Ruben MANES + b. 19 Nov 1902 + bp. Union Valley, Sevier Co, TN + + James H. CANTER + b. ca 1847 + bp. Claiborne Co, TN + + Cordelia "Corda" F. CANTER + b. 7 Dec 1869 + bp. Jonesboro, Washington Co, TN + + Martha Marie WHITEHORN + b. 22 DEC 1846 + bp. Washington Co, TN ? + + Alda Clifford MANIS + b. 11 MAR 1939 + bp. Knoxville, Knox Co, TN + + Thomas D.A.F.S. MANIS + b. 1 Feb 1839 + bp. Fair Garden, TN or Cocke Co, TN ? + + William Loyd MANIS + b. 5 Sep 1872 + bp. Sevier Co, TN + + Frances Amanda BIRD + b. 8 FEB 1845 + bp. Sevier Co, TN + + Edith Alberta MANIS + b. 8 APR 1914 + bp. Dandridge, Jefferson Co, TN + + John Franklin NEWMAN + b. 4 MAY 1830 + bp. Jefferson Co, TN + + Lillie Caroline "Carolyn" NEWMAN + b. 13 JUN 1881 + bp. Jefferson Co, TN + + Mary Jean CORBETT + b. 9 OCT 1843 + bp. Jefferson Co, TN + +*/ + +/* End of Report */ diff --git a/reports/6gen1.ll b/reports/6gen1.ll new file mode 100644 index 0000000..07c6dc5 --- /dev/null +++ b/reports/6gen1.ll @@ -0,0 +1,142 @@ +/* + * @progname 6gen1.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output Text, 80 cols + * @description + * + * select and produce a 6 generation ancestor report for + * the person selected. + * Output is an ASCII file, and will probably need to be printed + * using 10 or 12 pitch. + * + * 6gen1 + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * With modifications by: Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * + * select and produce a 6 generation ancestor report for + * the person selected. + * + * Output is an ASCII file, and will probably need to be printed + * using 10 or 12 pitch. + * + * An example of the output may be seen at end of this report. + */ + +proc main () +{ + getindi(indi) + set (nl,nl()) + pagemode(70,80) + call pedout(indi,1,6,1,64) + pageout() + print(nl()) +} + +proc pedout (indi, gen, max, top, bot) +{ + if (le(gen,max)) { + set(gen,add(1,gen)) + set(fath,father(indi)) + set(moth,mother(indi)) + set(height,add(1,sub(bot,top))) + set(offset,div(sub(height,1),2)) + call block(indi,add(top,offset),mul(8,sub(gen,2))) + set(half,div(height,2)) + call pedout(fath,gen,max,top,sub(add(top,half),1)) + call pedout(moth,gen,max,add(top,half),bot) + } +} + +proc block (indi, row, col) +{ + print(".") + set(row,add(3,row)) + set(col,add(3,col)) + pos(row,col) + if (indi) { name(indi) } + else { "_______________" } +} + +/* Sample output of the 6gen1 report for: a c /manis + + + John MANESS + Samuel P. MANES + _______________ + William Thomas MANES + _______________ + Fanny (MANES) + _______________ + William Bowers MANES + James BOWERS + Anderson BOWERS + Martha + Martha A. BOWERS + Christopher Columbus COWAN + Lurina Viney "Vina" COWAN + Mary BOYD + Fuller Ruben MANES + _______________ + Henry B. CANTER + _______________ + James H. CANTER + _______________ + Polina (CANTER) + _______________ + Cordelia "Corda" F. CANTER + _______________ + James WHITEHORN + _______________ + Martha Marie WHITEHORN + Kennedy "Kan" Powell FOSTER + Martha "Patsy" FOSTER + Rebecca KERSAWN + Alda Clifford MANIS + _______________ + Amos MANIS + _______________ + Thomas D.A.F.S. MANIS + David FRANCIS + Mary Elizabeth FRANCIS + Mary CROCKETT + William Loyd MANIS + Jacob BIRD + John BIRD + Mrs. (BIRD) + Frances Amanda BIRD + G. Christopher SHRADER + Elizabeth SHRADER + Mary WEBB + Edith Alberta MANIS + John NEWMAN + Aaron NEWMAN + Nancy FRANKLIN + John Franklin NEWMAN + Thomas B. RANKIN + Sinea RANKIN + Jennet BRADSHAW + Lillie Caroline "Carolyn" NEWMAN + James CORBETT + John Williams CORBETT + Polly GRESHAMS + Mary Jean CORBETT + _______________ + Betsy EUDAILY + _______________ + +*/ + +/* End of Report */ + + + + + + diff --git a/reports/8gen1.ll b/reports/8gen1.ll new file mode 100644 index 0000000..06636eb --- /dev/null +++ b/reports/8gen1.ll @@ -0,0 +1,74 @@ +/* + * @progname 8gen1.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output Text, 132 cols + * @description + * + * Produce an 8 generation descendant report for the person selected. + * Output is an ASCII file, and will probably need to be printed + * using 132 column format. + * + * 8gen1 + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * With modifications by: Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * + * Produce an 8 generation descendant report for the person selected. + * + * Output is an ASCII file, and will probably need to be printed + * using 132 column format. + * + * An example of the output, is not included because it would add + * 20k to this report. + */ + +proc main () +{ + getindi(indi) + set (nl, nl()) + pagemode(260,132) + call pedout(indi,1,8,1,256) + pageout() + print(nl()) +} + +proc pedout (indi, gen, max, top, bot) +{ + if (le(gen,max)) { + set(gen,add(1,gen)) + set(fath,father(indi)) + set(moth,mother(indi)) + set(height,add(1,sub(bot,top))) + set(offset,div(sub(height,1),2)) + call block(indi,add(top,offset),mul(10,sub(gen,2))) + set(half,div(height,2)) + call pedout(fath,gen,max,top,sub(add(top,half),1)) + call pedout(moth,gen,max,add(top,half),bot) + } +} + +proc block (indi, row, col) +{ + print(".") + set(row,add(3,row)) + set(col,add(3,col)) + set(e,birth(indi)) + pos(row,col) + if (indi) { name(indi) + ", " + if (and(e,date(e))) { date(e) } + ", " + if (and(e,place(e))) { place(e) } + } + + else { " |--------" } +} + +/* End of Report */ + diff --git a/reports/BW_descendants.ll b/reports/BW_descendants.ll new file mode 100644 index 0000000..4805547 --- /dev/null +++ b/reports/BW_descendants.ll @@ -0,0 +1,472 @@ +/* + * @progname BW_descendants.ll + * @version 1.00 + * @author Birger Wathne + * @category + * @output Text + * @description + * List successors with notes + +BW_descendants - a LifeLines report by Birger Wathne (Birger.Wathne@sdata.no) + +Version 1.00 +This program partially based on code by Brad Frecker and Dick Knowles. +Suggestions and comments welcome. + + +Output sample at bottom of this source file. + +This report generates a list of successors of the given person. For each +successor and its spouse(s), all level 1 notes are listed. + +The report asks for some parameters: +- Number of generations to include (0 gives all) +- Amount of output for spouse's other families + 0 - Only list the main person's marriages. Don't even mention + the fact that the spouse(s) have had other relationships. + 1 - Print a one-line summary for each of the spouse's other + relationships (number of children, spouses name, etc) + 2 - Print the one-liner from option 1, plus a full listing of + all stepchildren (not recursive) +- Output type + 0 - Text. Plain ascii output (like the sample) + 1 - roff. Not finished, as I don't have an 8-bit clean roff. + If someone wants this, please finish it, and send me the code. + 2 - HTML. This output uses tags, so you need HTML 3.0 support. + Uses bold fonts, etc. Nice.... +- Language for generated text. The header, and all those small words + used in the output can be generated in the language you have your + data. Makes it look more natural. If you add new languages, please tell me. +*/ + +global(strings) +global(outputtype) +global(true) +global(false) + +func init_strings(language) { + if ( eq( language, 0)) { + insert(strings, "Header", "Successors of") + insert(strings, "Headerdate", "Date") + insert(strings, "Born", "Born") + insert(strings, "Dead", "Dead") + insert(strings, "Married", "Married") + insert(strings, "Relationship", "Relationship") + insert(strings, "with", "with") + insert(strings, "unknownspouse", "unknown spouse") + insert(strings, "descendants", "descendants") + insert(strings, "generations", "generations") + insert(strings, "children", "children") + insert(strings, "had", "had") + insert(strings, "all", "all") + insert(strings, "Notesfor", "Notes for") + + return(0) + } + + if ( eq( language, 1)) { + insert(strings, "Header", "Etterkommere etter") + insert(strings, "Headerdate", "Dato") + insert(strings, "Born", "F輐t") + insert(strings, "Dead", "D輐") + insert(strings, "Married", "Gift") + insert(strings, "Relationship", "Forhold") + insert(strings, "with", "med") + insert(strings, "unknownspouse", "ukjent ektefelle") + insert(strings, "descendants", "etterkommere") + insert(strings, "generations", "generasjoner") + insert(strings, "children", "barn") + insert(strings, "had", "hadde") + insert(strings, "all", "alle") + insert(strings, "Notesfor", "Notater for") + + return(0) + } + + return(1) +} + + +proc main () { + table(strings) + + set(true, 1) + set(false, 0) + + dayformat(0) + monthformat(4) + dateformat(0) + + getindi(indi) + + getintmsg (generation_count, "How many generations (0 for all)?") + if ( lt( generation_count, 0)) { + print("Illegal number of generations") + return() + } + + getintmsg ( + spousefamilies, + "How much output for spouse's other families (0=none, 1=summary, 2=list children)?" + ) + if ( or( lt( spousefamilies, 0), gt( spousefamilies, 2))) { + print("Illegal answer") + return() + } + + getintmsg(outputtype, "Output type (0=TEXT, 1=ROFF, 2=HTML)?") + if ( or( lt( outputtype, 0), gt( outputtype, 2))) { + print("Illegal output type") + return() + } + + + getintmsg( + language, + "Language for generated text (0=English, 1=Norwegian)?" + ) + if ( ne( init_strings(language), 0)) { + print("Couldn't initialize string table to selected language") + return() + } + + output_init() + /* Headers */ + if ( eq( generation_count, 0)) { + output_header1 ( + concat( + lookup( strings, "Header")," ", + name(indi), " ", + lookup( strings, "with"), " ", + lookup( strings, "all"), " ", + lookup( strings, "descendants") + ) + ) + } else { + if ( eq( generation_count, 1)) { + output_header1 ( + concat( + lookup( strings, "Header"), " ", + name(indi), " " + ) + ) + } else { + output_header1 ( + concat( + lookup( strings, "Header"), " ", + name(indi), " ", + lookup( strings, "with"), " ", + d(sub(generation_count,1)), " ", + lookup( strings, "generations"), " ", + lookup( strings, "descendants") + ) + ) + } + } + nl() nl() + + output_header2( + concat( + lookup( strings, "Headerdate"), ": ", + stddate(gettoday()) + ) + ) + nl() nl() + + call descendants(indi, "1", generation_count, spousefamilies) + output_terminate() +} + + + +proc descendants (indi, number, generation_count, spousefamilies) { + output_startpara() + number output_linebreak() + call print_person(indi, 1) + + call write_notes(indi) + + set(childnumber, 0) + + families(indi, family, spouse, i) { + if(e, marriage(family)) { + lookup( strings, "Married") " " stddate(e) + } else { + lookup( strings, "Relationship") + } + + if ( ne( spouse, null)) { + " " lookup( strings, "with") " " + call print_person(spouse, 1) + } else { + " " lookup( strings, "with") " " + lookup( strings, "unknownspouse") + } + + if ( ne(spousefamilies, 0)) { + families(spouse, spfamily, spspouse, j) { + if (ne(family, spfamily)) { + name(spouse) " " + lookup( strings, "had") " " + d(nchildren(spfamily)) " " + lookup( strings, "children") + if ( ne( spspouse, null)) { + " " lookup( strings, "with") " " + call print_person(spspouse, 0) + } else { + " " lookup( strings, "with") " " + lookup( strings, "unknownspouse") + } + if( eq(spousefamilies, 2)) { + output_leftin() + children(spfamily, child, k) { + "\t" + call print_person(child, 0) + } + output_leftout() + } + } + } + } + + call write_notes(spouse) + + output_leftin() + children(family, child, j) { + "\t" number "." d(add(j, childnumber)) nl() "\t" + call print_person(child, 1) + } + output_leftout() + set(childnumber, add(childnumber, j)) + } + + output_endpara() + + set(childnumber, 0) + + families(indi, family, spouse, i) { + if (ne(1, generation_count)) { + if ( gt(generation_count, 1)) { + decr(generation_count) + } + children(family, child, j) { + call descendants ( + child, + strconcat( + number, ".", + d(add(j, childnumber)) + ), + generation_count, spousefamilies) + } + set(childnumber, add(childnumber, j)) + } + } + +} + + + +proc write_notes(indi) { + set(done_header, 0) + fornodes(inode(indi), node) { + if (eq(0,strcmp("FILE", tag(node)))) { + if ( eq(done_header, 0) ) { + lookup( strings, "Notesfor") " " + name(indi) ":" output_linebreak() + incr(done_header) + } + copyfile(value(node)) + } elsif (eq(0,strcmp("NOTE", tag(node)))) { + if ( eq(done_header, 0) ) { + lookup( strings, "Notesfor") " " + name(indi) ":" output_linebreak() + incr(done_header) + } + value(node) + fornodes(node, subnode) { + if (eq(0,strcmp("CONT", tag(subnode)))) { + nl() value(subnode) + } + } + output_linebreak() + } + } +} + + +proc print_person (indi, bold) { + if(bold) { + output_bold( name(indi)) + } else { + name(indi) + } + if (e, stddate(birth(indi))) { + ", " lookup( strings, "Born") " " e + } + if(e, stddate(death(indi))) { + ", " lookup( strings, "Dead") " " e + } + "." output_linebreak() +} + + +func output_header1 (string) { + if ( eq( outputtype, 1)) { + return(concat( ".(b C", nl(), ".ps 16", nl(), "\\fB", + split(string), "\\fP", nl(), + ".ps 8", nl(), ".)b", nl())) + } + if ( eq( outputtype, 2)) { + return(concat( "

", string, "

")) + } + return(string) +} + +func output_header2 (string) { + if ( eq( outputtype, 1)) { + return(concat( ".(b C", nl(), ".ps 12", nl(), "\\fB", + string, "\\fP", nl(), + ".ps 8", nl(), ".)b", nl())) + } + if ( eq( outputtype, 2)) { + return(concat( "

", string, "

")) + } + return(string) +} + + +func output_init () { + if ( eq( outputtype, 1)) { + return(concat( ".po 0.8i", nl(), ".ll 6.8i", nl(), + ".pl +1.5i", nl(), ".nf", nl(), ".ps 8", nl())) + } + if ( eq( outputtype, 2)) { + return(concat("Descendant chart", nl() )) + } +} + + +func output_terminate () { + if ( eq( outputtype, 2)) { + return("") + } +} + + +func output_linebreak () { + if ( eq( outputtype, 1)) { + return(nl()) + } + if ( eq( outputtype, 2)) { + return("
") + } + return(nl()) +} + + +func output_startpara () { + if ( eq( outputtype, 2)) { + return("

") + } +} + + +func output_endpara () { + if ( eq( outputtype, 2)) { + return("

") + } + return(concat( output_linebreak(), output_linebreak())) +} + +func output_bold (string) { + if ( eq( outputtype, 1)) { + return(concat( "\\fB", string, "\\fP")) + } + if ( eq( outputtype, 2)) { + return(concat( "", string, "")) + } + return(string) +} + + +func output_leftin () { + if ( eq( outputtype, 2)) { + return(concat( "
")) + } +} + + +func output_leftout () { + if ( eq( outputtype, 2)) { + return(concat( "
")) + } +} + + +func split(string) { + set(i, 1) + set(tmpstr, "") + while( ne( i, strlen(string))) { + if ( nestr( substring( string, i, i), " ")) { + set(tmpstr, concat(tmpstr, substring( string, i, i))) + } else { + set(tmpstr, concat(tmpstr, "\\0")) + } + incr(i) + } + return (tmpstr) +} + + +/* Sample output: + + +Successors of N.N. Helgesdtr. 又E with 2 generations descendants + +Date: 14 Jun 1995 + +1 +N.N. Helgesdtr. 又E. +Relationship with Tjeran Hallvardson (Halldors.) VASSHUS, Born 1610. +Notes for Tjeran Hallvardson (Halldors.) VASSHUS: +Er nevnt som leilending i 1635 sammen med Helge 山e som sannsynligvis var +hans svigerfar. +Tjeran og broren Rasmus stevnet stefaren Laurits Asserson for odelsgods i +Kluge, Gjesdal som deres mor eide. + 1.1 + Lars Tjeranson 又E, Born 1643, Dead 9 Jun 1702. + 1.2 + Marite Tjerandsdtr. 又E, Dead 1691. + 1.3 + Hallvard TJERANSON, Born 1651. + 1.4 + Helge TJERANSON, Born 1654. + + +1.1 +Lars Tjeranson 又E, Born 1643, Dead 9 Jun 1702. +Notes for Lars Tjeranson 又E: +Gift I med Kirsti Olsdtr. Malmeim (f.1665 d.12.04.1695). +II med Johanna Gunnarsdtr. Sveinsvoll (d.1741). +Lars hadde v喣t soldat i 10 繢. 2 barn kjent. + + +1.2 +Marite Tjerandsdtr. 又E, Dead 1691. +Relationship with Ola Olson KJOSAVIK, Born 1623, Dead 9 1702. +Ola Olson KJOSAVIK had 7 children with KariI Pedersdtr., Born 16 , Dead 1674. +Ola Olson KJOSAVIK had 1 children with KariII Torkellsdtr. ALSNES, Born 1661, Dead 30 Mar 1705. +Notes for Ola Olson KJOSAVIK: +7 barn av f酺ste ekteskap, 3 av andre og 1 av tredje ekteskap. + 1.2.1 + Berit Olsdtr. KJOSAVIK, Born 1674, Dead 1746. + 1.2.2 + Kristoffer Olson KJOSAVIK, Born 1677. + 1.2.3 + Ola O. KJOSAVIK, Born 1681, Dead 23 1695. + +. +. +. + +*/ diff --git a/reports/CREDIT b/reports/CREDIT new file mode 100644 index 0000000..81b31f4 --- /dev/null +++ b/reports/CREDIT @@ -0,0 +1,44 @@ + +Thanks to all the lifelines report writers. IMHO this is the real +power of lifelines! + +-marc + +------------------------------------------------------------------------ +Bill Alford +Kurt Baudendistel +Paul Buckely +Vincent Broman +John F. Chandler +Dave Close +Andrew Deacon +Stephen Dum +Chris Eagle +Jim Eggert +Wes Groleau +James Kirby +Dick Knowles +Eric Majani +Cliff Manis +Paul B. McBride +Doug McCallum +Scott McGee +Dennis Nicklaus +Marc Nozell +David Olsen +Alexander Ottl +James Patton Jones +Rafal Prinke +Perry Rapp +Denis Roegel +Henry Sikkema +Robert Simms +Hume Smith +Larry Soule +Kris Stanton +Phil Stringer +Arthur Teschler +Birger Wathne +Tom Wetmore +Fred Wheeler +Stephen Woodbridge diff --git a/reports/Makefile.am b/reports/Makefile.am new file mode 100644 index 0000000..84674e7 --- /dev/null +++ b/reports/Makefile.am @@ -0,0 +1,85 @@ +# This makefile is for the lifelines reports + +AUTOMAKE_OPTIONS = no-dependencies + +SUBDIRS = desc-tex2 novel pedtex ps-fan st + +# LL_REPORTS is to hold the actual report files +# (included files go in a different target below) +LL_REPORTS = \ + 2ppage.ll 4gen1.ll 6gen1.ll 8gen1.ll afg.ll \ + addsour.ll af-import.ll afn_match.ll ahnenliste.ll ahnentafel.ll\ + alive.ll all_anc_lines.ll allfam10c.ll alllines.ll \ + altern.ll anc2_ged.ll ancestors2.ll anniver.ll \ + bday_cover.ll bias.ll bkdes16-1.ll book-latex.ll \ + browser.ll burial_index.ll BW_descendants.ll cid.ll connect2.ll \ + cgi_html.li common.ll cons.ll cont.ll count_dup.ll \ + count_anc.ll count_desc.ll count_paternal_desc.ll cousins.ll \ + coverage.ll cron.ll dates.ll db_summary.ll desc-henry.ll \ + desc_ged.ll descged.ll desc_html.ll desc-tree.ll divorce.li \ + drep2.ll d-rtf.ll dump-ances.ll dump_html.ll dump_html_sd.ll \ + eol.ll est_life_span.ll extract_gedcom.ll extract_html.ll \ + extract_set.li fam10c.ll fam16rn1.ll fam_ged.ll famgroup.ll \ + fami-grps.ll \ + familycheck.ll familyisfm1.ll famrep.ll famtree1.ll \ + fileindex.ll \ + fdesc.ll find.ll findmissing.ll fix_nameplac.ll \ + formatted_gedcom.ll gedall.ll gedlist.ll gedlod.ll gedn.ll \ + gedtags.ll ged_write.li genancc.ll \ + genancc1.ll gender_order.ll gendex.ll \ + genetics.ll genetics2.ll getbaptism.li givens_gender.ll \ + givens_gender_finder.ll grand.ll \ + hasnotes1.ll hp-anc.ll htmlahnen.ll \ + html.dn.ll htmlfam.ll html.ll igi-filter.ll igi-import.ll \ + igi-merge.ll igi-search.ll index1.ll index_html.ll index_mm.ll \ + interestset.li indiv.ll infant_mortality.ll ldsgedcom.li \ + line.ll listsour.ll ll2html.ll ll2visio.ll lldb.ll \ + longlines.ll maritalinfo.ll marriages.ll marriages1.ll menu.ll \ + name2html.ll \ + namefreq.ll names_freq.ll namesformat1.ll net-ped.ll \ + nonpatronymics.ll outsources.li paf-export.ll \ + pafcompat.ll partition.ll pdesc.ll paf-import.ll ped.ll \ + pedigreel.ll pedigree_html.ll pedigreelhs.ll pedigree.ll \ + places.ll pointers.ll prompt.li ps-anc.ll \ + ps-circle.ll ps-pedigree.ll refn.ll reg_html.ll \ + register-rtf.ll register-tex.ll register1.ll register1-dot.ll \ + regvital.ll relate.ll related_spouses.ll relation.ll relink.ll \ + rfc.ll rllgen.ll rootset.ll rslgen.ll rtflib.li sealing_line.ll \ + search_source.ll \ + select.ll sgsgen.ll shorten.li showlines1.ll simpleged.ll \ + soundex1.ll soundex-isfm.ll sour.li \ + sour2.li sources.ll sources_bib.ll \ + span.ll src.ll src-rtf.ll ssdi_aid.ll ssdi-import.ll \ + ssdi-search-list.ll stats.ll surname1.ll \ + tinytafel1.ll tools.li \ + tree_density.ll ttable.ll upl2.li verify.ll wife.ll \ + xml-dtd.ll xmlize.ll zombies.ll + +# OTHER_REPORTS is to hold included files besides actual report files +# (eg, supporting files, graphics, included files) +OTHER_REPORTS = boc.gif ll.png gen_index bib2html.c bury.c \ + ps-pedigree.ps tree.tex + +# LL_SUBREPORTS is to hold reports that live in subdirectories. +# They are built and installed by the makefiles in their respective +# directories, but are included here as a separate target so that they +# can be included in the generated directory. +LL_SUBREPORTS = \ + desc-tex2/desc-tex.ll desc-tex2/desc-tex2.ll \ + novel/novel.ll \ + pedtex/pedtex.ll ps-fan/ps-fan.ll \ + st/st_all.ll + +pkg_REPORTS = $(LL_REPORTS) $(OTHER_REPORTS) +pkg_REPORTS_MISC = index.html CREDIT README + +EXTRA_DIST = $(pkg_REPORTS) \ + $(pkg_REPORTS_MISC) + +dist_pkgdata_DATA = $(EXTRA_DIST) + +CLEANFILES = index.html + +PERL = perl +index.html: $(LL_REPORTS) $(LL_SUBREPORTS) + -$(PERL) $(top_srcdir)/reports/gen_index $^ diff --git a/reports/README b/reports/README new file mode 100644 index 0000000..b923bfc --- /dev/null +++ b/reports/README @@ -0,0 +1,5 @@ +This Directory contains sample report programs submitted by +lifelines users from all over the globe. + +View the file index.html with a browser for quick summaries of +what the programs do. diff --git a/reports/addsour.ll b/reports/addsour.ll new file mode 100644 index 0000000..d027c68 --- /dev/null +++ b/reports/addsour.ll @@ -0,0 +1,78 @@ +/* + * @progname addsour + * @version 1.0 + * @author Stephen Dum + * @category + * @output Modifies Database + * @description + +This script prompts for a message and adds the message along with todays date +as a Source record on each individual and Family in the database. It checks +to see if the source already exists, and allows you to skip or replace an +existing source record. Warning, this script modifies your database, making a +backup of your data before running this script is advised. +*/ + +option("explicitvars") + +proc main() +{ + print("\n") + print("This script will add a SOUR record to each indi and fam in your database\n") + print("The value will be the message you supply with todays date appended.\n") + print("Warning: This script modifies your database - backup your data\n", + "before running it -- enter abort to abort\n\n") + getstr(msg,"Enter Message to add to SOUR") + if (index(lower(msg),"abort",1)) { + return() + } + + /* iterate thru each individual adding sources to end of each */ + forindi(indiv,cnt) { + set(ok,"ok") + fornodes(indiv,n) { + if (eqstr(tag(n),"SOUR")) { + if (index(value(n),msg,1)) { + print("Warning, ",key(indiv),": SOUR ",value(n),nl()) + print("Message already exists in level 1 SOUR record",nl()) + getstr(ok,"Press return to skip add, rep to replace, else ok") + if (index(lower(ok),"rep",1)) { + /* replace node */ + detachnode(n) + set(n,nn) + } + } + } + set(nn,n) + } + if (strlen(ok)) { + print("adding msg for ",key(indiv),nl()) + set(s,createnode("SOUR",concat(msg," ",date(gettoday())))) + addnode(s,indiv,nn) + writeindi(indiv) + } + } + forfam(fam,cnt) { + fornodes(fam,n) { + if (eqstr(tag(n),"SOUR")) { + if (index(value(n),msg,1)) { + print("Warning, ",key(fam),": SOUR ",value(n),nl()) + print("Message already exists in level 1 SOUR record",nl()) + getstr(ok,"Press return to skip add, rep to replace, else ok") + if (index(lower(ok),"rep",1)) { + /* replace node */ + detachnode(n) + set(n,nn) + } + } + } + set(nn,n) + } + if (strlen(ok)) { + print("adding msg for ",key(fam),nl()) + set(s,createnode("SOUR",concat(msg," ",date(gettoday())))) + addnode(s,fam,nn) + writefam(fam) + } + } +} diff --git a/reports/af-import.ll b/reports/af-import.ll new file mode 100644 index 0000000..b2c817c --- /dev/null +++ b/reports/af-import.ll @@ -0,0 +1,419 @@ +/* + * @progname af-import.ll + * @version 4.12 + * @author baud@research.att.com + * @category + * @output GedCom + * @description + * + * convert ancestral-file gedcom to lifelines-standard gedcom + * + * AF gedcom has the following defects that must be corrected: + * + * NAME - Delete name LIVING (Actually, 3.0.1 requires some kind + * of name, so use "/"). + * - Convert UPPERCASE surnames to upper- and lowercase. Try to + * figure out von's and such, but otherwise simply capitalize + * the first letters. + * - Remove periods used for abbreviations. + * - Delete given name "Stillborn". + * - Alternate surnames (given in parentheses) are converted + * to subsequent NAME records. + * DATE - LIVING -- delete associated event. + * - Convert "" to "ABT X". + * - Marriage date with trailing (DIV) indicates divorce -- + * strip string and convert to DIV record. + * PLAC - Burial place "Cremated" converted to NOTE record. + * - Strip leading commas. + * events - Add SOUR cross-reference to "Ancestral File" to all. + * + * 12 NOV 1994 (3.0.1) baud@research.att.com + */ + +proc main () +{ + getstrmsg (msg, "AF Version [default 4.12/1992]?") + if (streq (msg, "")) { + set (afversion, "4.12") + set (afdate, "1992") + } else { + if (i, index (msg, "/", 1)) { + set (afversion, save (trim (msg, sub (i, 1)))) + set (afdate, save (cut (msg, add(i, 1)))) + } else { + set (afversion, save (msg)) + set (afdate, "") + } + } + + "0 HEAD \n" + "1 SOUR LIFELINES\n" + "2 VER " version() "\n" + "2 NAME AF-IMPORT REPORT\n" + "1 DEST LIFELINES\n" + "2 VER 3.0.1\n" + "1 DATE " date (gettoday ()) "\n" + "1 COPR Copyright " date (gettoday ()) ". Permission is granted to repro" + "duce any subset\n2 CONT of the data contained herein under the condit" + "ion that this copyright\n2 CONT notice is preserved, that the origina" + "l source citations referenced\n2 CONT in the subset are included, and" + " that the submitter of this file is\n2 CONT credited with original au" + "thorship as appropriate.\n" + "1 CHAR ASCII\n" + + "0 @S1@ SOUR\n" + "1 NAME Ancestral File\n" + "1 PUBR The Church of Jesus Christ of Latter-day Saints\n" + if (strlen (afversion)) { + "1 VER " afversion "\n" + } + if (strlen (afdate)) { + "1 DATE " afdate "\n" + } + + print ("Processing nodes ...\n") + forindi (indi, in) { + print ("i") + afimportindi (indi) + } + forfam (fam, fn) { + print ("f") + afimportfam (fam) + } + + "0 TRLR \n" +} + +func afimportindi (indi) +{ + set (root, inode (indi)) + + if (streq (name (indi), "LIVING")) { + replacenode (createnode ("NAME", "/"), subnode (root, "NAME")) + } elsif (index (name (indi), "Stillborn ", 1)) { + set (namenode, subnode (root, "NAME")) + replacenode (createnode ("NAME", save (cut (value (namenode), 11))), + namenode) + } + reformatnames (root, "@S1@") + + if (streq (date (birth (indi)), "LIVING")) { + deletenode (birth (indi)) + } + if (streq (date (baptism (indi)), "LIVING")) { + deletenode (baptism (indi)) + } + reformatdates (root) + + fornodes (root, node) { + if (eventP (node)) { + if (place (node)) { + if (streq (place (node), "Cremated")) { + replacenode (createnode ("NOTE", "Cremated."), subnode (node, "PLAC")) + } else { + list (placelist) + extractplaces (node, placelist, placenumber) + replacenode (createnode ("PLAC", strjoin (denull (placelist), ",")), + subnode (node, "PLAC")) + } + } + catnode (node, createnode ("SOUR", "@S1@")) + } + } + + gedcomnode (root) + return (0) +} + +func eventP (root) { + if (root) { + if (streq (tag (root), "BIRT")) { return (1) } + if (streq (tag (root), "CHR")) { return (1) } + if (streq (tag (root), "DEAT")) { return (1) } + if (streq (tag (root), "BURI")) { return (1) } + } + return (0) +} + +func afimportfam (fam) +{ + set (root, fnode (fam)) + + reformatdates (root) + + if (node, marriage (fam)) { + if (i, index (date (node), " (DIV)", 1)) { + replacenode (createnode ("DATE", save (trim (date (node), sub (i, 1)))), + subnode (node, "DATE")) + set (divorcenode, createnode ("DIV", "")) + catnode (divorcenode, createnode ("SOUR", "@S1@")) + catnode (root, divorcenode) + } + if (place (node)) { + list (placelist) + extractplaces (node, placelist, placenumber) + replacenode (createnode ("PLAC", strjoin (denull (placelist), ",")), + subnode (node, "PLAC")) + } + catnode (node, createnode ("SOUR", "@S1@")) + } + + gedcomnode (root) + return (0) +} + +/* common import/export functions */ + +func cond (x, a, b) { + if (x) { + return (a) + } else { + return (b) + } +} + +func gedcomnode (root) { + traverse (root, node, level) { + d (level) + if (x, xref (node)) { " " x } + if (x, tag (node)) { " " x } + if (x, value (node)) { " " x } + "\n" + } + return (0) +} + +func denull (alist) { + list (blist) + forlist (alist, a, an) { + if (a) { enqueue (blist, a) } + } + return (blist) +} + +func reformatdates (root) { + traverse (root, node, level) { + if (streq (tag (node), "DATE")) { + if (v, value (node)) { + if (and (eq (index (v, "<", 1), 1), + eq (index (v, ">", 1), strlen (v)))) { + replacenode + (createnode ("DATE", save (substring (v, 2, sub (strlen (v), 1)))), + subnode (node, "DATE")) + } + } + } + } + return (0) +} + +func reformatnames (root, sourcetext) { + list (namelist) + list (surnamelist) + list (choppedsurnamelist) + list (newchoppedsurnamelist) + if (namenode, subnode (root, "NAME")) { + extractnames (namenode, namelist, nameN, surnameN) + set (lastnamenode, namenode) + forlist (namelist, s, sn) { + set (s, strremove (s, ".")) + set (s, strremove (s, "_")) + setel (namelist, sn, s) + } + enqueue (surnamelist, getel (namelist, surnameN)) + while (surname, dequeue (surnamelist)) { + set (choppedsurnamelist, strchop (surname, " ")) + forlist (choppedsurnamelist, s, sn) { + if (streq ("VON", s)) { + enqueue (newchoppedsurnamelist, s) + } elsif (streq ("DER", s)) { + enqueue (newchoppedsurnamelist, s) + } elsif (and (eq (index (s, "(", 1), 1), + eq (index (s, ")", 1), strlen (s)))) { + enqueue (surnamelist, save (substring (s, 2, sub (strlen (s), 1)))) + } else { + enqueue (newchoppedsurnamelist, save (capitalize (lower (s)))) + } + } + set (newsurname, strjoin (newchoppedsurnamelist, " ")) + if (strlen (newsurname)) { + if (i, index (newsurname, "Mc ", 1)) { + set (newsurname, save (concat (trim (newsurname, add (i, 1)), + cut (newsurname, add (i, 3))))) + } + set (newsurname, save (concat3 ("/", newsurname, "/"))) + } + setel (namelist, surnameN, newsurname) + set (newnamenode, createnode ("NAME", strjoin (namelist, " "))) + addnode (newnamenode, parent (lastnamenode), lastnamenode) + if (sourcetext) { + catnode (newnamenode, createnode ("SOUR", sourcetext)) + } + set (lastnamenode, newnamenode) + } + deletenode (namenode) + } + return (0) +} + +func streq (x, y) { + return (not (strcmp (x, y))) +} + +func createnodes (tag, text) { + set (text, trimspaces (text)) + if (le (strlen (text), 72)) { + return (createnode (tag, text)) + } else { + list (textlist) + while (gt (strlen (text), 72)) { + set (n, 1) + if (i, index (text, " ", n)) { + set (j, i) + } else { + set (j, add (strlen (text), 1)) + } + while (and (i, lt (i, 73))) { + incr (n) + set (j, i) + set (i, index (text, " ", n)) + } + enqueue (textlist, save (trim (text, sub (j, 1)))) + set (text, save (cut (text, add (j, 1)))) + } + if (gt (strlen (text), 0)) { + enqueue (textlist, text) + } + set (root, createnode (tag, dequeue (textlist))) + set (lastnode, 0) + forlist (textlist, text, tn) { + set (node, createnode ("CONT", text)) + addnode (node, root, lastnode) + set (lastnode, node) + } + return (root) + } +} + +func trimspaces (text) { + set (ss, 0) + set (s0, 1) + set (sn, strlen (text)) + while (and (le (s0, sn), streq (substring (text, s0, s0), " "))) { + set (ss, 1) + incr (s0) + } + while (and (le (s0, sn), streq (substring (text, sn, sn), " "))) { + set (ss, 1) + decr (sn) + } + if (ss) { + return (save (substring (text, s0, sn))) + } else { + return (text) + } +} + +func catnode (root, newnode) { + if (root) { + set (lastnode, 0) + fornodes (root, node) { + set (lastnode, node) + } + addnode (newnode, root, lastnode) + } + return (0) +} + +func strchop (s, d) { + list (slist) + set (dn, strlen (d)) + if (strlen (s)) { + set (n, 1) + set (s0, 1) + while (sn, index (s, d, n)) { + enqueue (slist, save (substring (s, s0, sub (sn, 1)))) + set (s0, add (sn, dn)) + incr (n) + } + enqueue (slist, save (cut (s, s0))) + } + return (slist) +} + +func strjoin (slist, d) { + forlist (slist, s, sn) { + if (not (strlen (str))) { + set (str, s) + } elsif (strlen (s)) { + set (str, save (concat3 (str, d, s))) + } + } + return (str) +} + +func subnode (root, tag) { + if (root) { + fornodes (root, node) { + if (streq (tag (node), tag)) { + return (node) + } + } + } + return (0) +} + +func subnodes (root, tag) { + list (nodelist) + if (root) { + fornodes (root, node) { + if (streq (tag (node), tag)) { + enqueue (nodelist, node) + } + } + } + return (nodelist) +} + +func replacenode (newnode, oldnode) { + if (newnode) { + if (root, parent (oldnode)) { + addnode (newnode, root, oldnode) + deletenode (oldnode) + } + } + return (0) +} + +func concat3 (x, y, z) { + return (concat (x, concat (y, z))) +} + +func cut (s, n) { + return (substring (s, n, strlen (s))) +} + +func values (root) { + if (root) { + set (str, value (root)) + fornodes (root, node) { + if (not (str)) { + set (str, value (node)) + } elsif (strlen (value (node))) { + set (str, save (concat3 (str, " ", value (node)))) + } + } + return (str) + } else { + return (0) + } +} + +func strremove (s, d) { + if (strlen (s)) { + while (i, index (s, d, 1)) { + set (s, save (concat (trim (s, sub (i, 1)), cut (s, add (i, 1))))) + } + } + return (s) +} diff --git a/reports/afg.ll b/reports/afg.ll new file mode 100644 index 0000000..aac9afe --- /dev/null +++ b/reports/afg.ll @@ -0,0 +1,80 @@ +/* + * @progname afg.ll + * @version 1.0 + * @author Tom Wetmore + * @category + * @output Text + * @description + + Shows simple family groups starting at a person and extending + out in ancestry. + + * Tom Wetmore -- 1 March 2008 + */ +global(iset) + +proc main () +{ + list(fams) /* families queued for possible processing */ + table(fset) /* families that have been processed */ + table(iset) /* table of ancestors that have been given numbers */ + set(n, 1) /* counter that assigns numbers to ancestors */ + + getindi(p, "enter person to build the family groups for") + if (not(p)) { return() } + set(k, save(key(p))) + insert(iset, k, rjustify(d(n), 3)) + incr(n) + set(f, parents(p)) + if (not(f)) { return() } + + enqueue(fams, f) + while (f, dequeue(fams)) { + set(k, key(f)) + if (lookup(fset, k)) { continue() } + insert(fset, save(k), 1) + if (h, husband(f)) { + if (g, parents(h)) { enqueue(fams, g) } + insert(iset, save(key(h)), rjustify(d(n), 3)) + incr(n) + } + if (w, wife(f)) { + if (g, parents(w)) { enqueue(fams, g) } + insert(iset, save(key(w)), rjustify(d(n), 3)) + incr(n) + } + call showfamily(f) + } +} + +proc showfamily (f) +{ + if (p, husband(f)) { call showperson(p, 0) } + if (p, wife(f)) { call showperson(p, 0) } + if (e, marriage(f)) { + if (long(e)) { " m. " long(e) nl() } + } + children (f, c, i) { call showperson(c, 1) } + + "----------------------------------------" nl() +} + +proc showperson (p, child) +{ + if (child) { " " } + set(i, lookup(iset, key(p))) + if (i) { i " " } else { " " } + name(p) nl() + if (e, birth(p)) { + if (child) { " " } + " b. " long(e) nl() + } + if (e, death(p)) { + if (child) { " " } + " d. " long(e) nl() + } + fornotes (root(p), n) { + if (child) { " " } + " n: " n nl() + } +} diff --git a/reports/afn_match.ll b/reports/afn_match.ll new file mode 100644 index 0000000..26dbb29 --- /dev/null +++ b/reports/afn_match.ll @@ -0,0 +1,75 @@ +/* + * @progname afn_match.ll + * @version 1.0 of 1995-08-25 + * @author Scott McGee + * @category + * @output Text + * @description + * + * Find individuals with matching Ancestral File numbers, report matches. + * + +This program is designed to search a database and find individuals with +the same AFN's. The output is a report of such matching individuals. + +Last updated 25 Aug, 1995 by Scott McGee (smcgee@microware.com) +*/ + +global(first) + +proc main (){ + table(t) + + set(first, 1) + print("Processing database ") + set(cnt, 0) + forindi(indi, n){ + if(afn, get_afn(indi)){ + if(match, lookup(t, afn)){ + call found_match(indi, save(afn), match) + }else{ + insert(t, save(afn), indi) + } + } + incr(cnt) + if(eq(cnt, 100)){ + set(cnt, 0) + print(".") + } + } +} + +func get_afn(indi){ + if(indi){ + fornodes(inode(indi), subnode){ + if(eqstr(tag(subnode), "AFN")){ + return(value(subnode)) + } + } + } + return(0) +} + +proc found_match(i2, afn, i1){ + if(first){ + set(first, 0) + "Ancestral File Number match report\n\n" + "produced by afn_match.ll version 1.0\n" + "by Scott McGee (smcgee@microware.com)\n\n" + "Database: " + database() + "\nDate: " + long(gettoday()) + "\n\n" + "AFN Key1 Key2 Name1\n" + "_________________________________________________________________________\n" + } + afn + col(10) + key(i1) + col(20) + key(i2) + col(30) + name(i1, 0) + "\n" +} diff --git a/reports/ahnenliste.ll b/reports/ahnenliste.ll new file mode 100644 index 0000000..817a226 --- /dev/null +++ b/reports/ahnenliste.ll @@ -0,0 +1,721 @@ +/* + * @progname ahnenliste.ll + * @version 6 + * @author Jim Eggert + * @category + * @output Text + * @description + * + * Generate an Ahnenliste, an ancestral report for an individual + * +ahnenliste - a LifeLines report program to aid in the generation of +an Ahnenliste (German ancestral report). + +Given a person, this generates an Ahnenliste for that person and +his/her ancestors. + +BEFORE YOU RUN THE PROGRAM: + +Change the routine write_header() to use your submitter tag, name, +and address. + +Version 1, 14 July 1994, by Jim Eggert, EggertJ@verizon.net +Version 2, 18 Aug 1998, added HTML +Version 3, 17 Feb 1999, added surnames to location list +Version 4, 15 Jan 2000, fixed quicksort bug +Version 5, 26 Jan 2000, added sorting translation +Version 6, 22 Jun 2000, improved handling of intersecting lines + +*/ + +global(locationsurname_list) +global(locationsurname_table) +global(i_list) +global(i_table) +global(a_list) +global(g_list) +global(ahn_table) + +global(html) +global(sep) +global(par) +global(br) +global(bold) +global(unbold) +global(gt) +global(lt) +global(born) +global(bapt) +global(died) +global(burd) +global(marr) + +global(sort_xlat) +global(html_xlat) +global(ISO8859_xlat) + +/* write_header writes a little header */ + +proc write_header(person) { + sep + if (html) { "

" } + "Ahnenliste " autohtml(mysurname(person)) "\n" + if (html) { "

" } + sep "\n" + bold "Proband:" unbold " " autohtml(fullname(person,0,1,80)) br + bold "Autor:" unbold " James R. Eggert" par + bold "Inhalt:" unbold br + if (html) { " Erläuterungen," } + else { " Erl\"auterungen," } + br " Landschaften," br + " Orte," br + " Namen" par "\n" + if (html) { "Ergänzungen" } else { "Erg\"anzungen" } + ", Berichtigungen, Anfragen oder Kommentare werden als\n" + "eMail erbeten an:" br + if (html) { + "Jim Eggert" + "(EggertJ@verizon.net)" + } else { + "Jim Eggert (EggertJ@verizon.net)" + } + par + dayformat(1) + monthformat(4) + dateformat(0) + bold "Stand:" unbold " " stddate(gettoday()) par + + if (html) { call section("Erläuterungen") } + else { call section("Erl\"auterungen") } + + "Die genealogischen Zeichen wurden durch folgende Satzzeichen ersetzt:" br + + " " born " -- geboren" br + " " bapt " -- getauft" br + " " died " -- gestorben" br + " " burd " -- begraben" br + " " marr " -- verheiratet" br br + + "Die zweiteilige Nummer vor jeder Zahl setzt sich zusammen auf die\n" + "Generation (bezogen auf den Probanden) und der Ordnungszahl im\n" + "Kekule'schen System. Nach diesem System ist die Ahnenzahl des Vaters\n" + "einer Person immer doppelt so gross wie deren Zahl, die der Mutter\n" + if (html) { + "um einen Wert höher als die des Vaters. Daraus ergibt sich, +daß\n" + "(mit Ausnahme eines männlichen Probanden) gerade Ordnungszahlen\n" + "immer zu Männern, ungerade immer zu Frauen gehören." par + } else { + "um einen Wert h\"oher als die des Vaters. Daraus ergibt sich, dass\n" + "(mit Ausnahme eines m\"annlichen Probanden) gerade Ordnungszahlen\n" + "immer zu M\"annern, ungerade immer zu Frauen geh\"oren." par + } + "---" gt " Bezugsperson = n, Vater = 2n, Mutter = 2n+1" par + + call section("Landschaften") + + "deutsche Gebiete: Hannover (Amt Dannenberg), Schaumburg-Lippe,\n" + " Provinz Posen, Westpreussen, Pfalz" br + "US-amerikanische Bundesstaate: Illinois, Kansas, Massachusetts,\n" + " Minnesota, Nebraska, New Jersey" br + "Syrien" par +} + + +proc main() { + table(sort_xlat) + table(html_xlat) + table(ISO8859_xlat) + call init_xlat() + + getintmsg(html,"Enter 0 for text, 1 for HTML output:") + set(born,"*") + set(bapt,"=") + set(died,"+") + set(marr,"oo") + if (html) { + set(sep,"
") + set(par,"

\n") + set(br,"
\n") + set(bold,"") + set(unbold,"") + set(gt,">") + set(lt,"<") + set(burd,"±") + } else { + set(sep, + "_________________________________________________________________\n") + set(par,"\n") + set(br,"\n") + set(bold,"") + set(unbold,"") + set(gt,">") + set(lt,"<") + set(burd,"") + } + + getindi(person) + + call write_header(person) + + table(locationsurname_table) + list(i_list) /* holds all root ancestors, just once */ + table(i_table) /* lookup mechanism for i_list */ + list(a_list) /* ahnentafel numbers for i_list */ + list(g_list) /* generation numbers for i_list */ + list(s_list) /* child one down in ancestry */ + list(work_i_list) + list(work_a_list) + list(work_g_list) + list(work_c_list) + list(locationsurname_list) + table(ahn_table) /* holds all ancestors once, with ahnentafel numbers */ + + enqueue(work_i_list, person) + enqueue(work_a_list, 1) + enqueue(work_g_list, 1) + enqueue(work_c_list, 0) + +/* Traverse ancestry twice, first pass to collect places, surnames, + and keys, second pass to produce ancestral lines. + */ + set(curgen,0) + set(done,0) + while(person,dequeue(work_i_list)) { + set(ahnen,dequeue(work_a_list)) + set(gen,dequeue(work_g_list)) + set(child,dequeue(work_c_list)) + + if (not(lookup(ahn_table,key(person)))) { /* only do a person once */ + insert(ahn_table,key(person),ahnen) + call locations(person) +/* test for inclusion of this individual as a root */ + set(include,0) + if (child) { + if (strcmp(soundex(person),soundex(child))) { + set(include,1) + } elsif (and(female(person),father(child))) { + set(include,1) + } + } else { set(include,1) } + if (include) { + enqueue(i_list,person) + insert(i_table,save(key(person)),ahnen) + enqueue(a_list,ahnen) + enqueue(g_list,gen) + enqueue(s_list,save(mysurname(person))) + } + +/* iterate into working lists */ + incr(gen) + set(ahnen,mul(ahnen,2)) + if (f,father(person)) { + enqueue(work_i_list,f) + enqueue(work_a_list,ahnen) + enqueue(work_g_list,gen) + enqueue(work_c_list,person) + } + if (m,mother(person)) { + enqueue(work_i_list,m) + enqueue(work_a_list,add(ahnen,1)) + enqueue(work_g_list,gen) + enqueue(work_c_list,person) + } + } + } + + call section("Orte") + list(index_list) + list(trans_locsur_list) + call translate(locationsurname_list,trans_locsur_list) + call quicksort(trans_locsur_list,index_list) + set(prevplace,"zzznowhere") + set(prevsurname,"zzznoone") + set(prevfirstplace,"zzznothere") + set(yearfrom,9999) + set(yearto,0) + forlist(index_list,index,i) { + set(locationsurname,getel(locationsurname_list,index)) + list(ls) + extracttokens(locationsurname,ls,nls,":") + set(location,getel(ls,1)) + set(surname,getel(ls,2)) + set(years,lookup(locationsurname_table,locationsurname)) + if (strcmp(location,prevplace)) { + if (strcmp(prevplace,"zzznowhere")) { + if (yearto) { + " (" + if (ne(yearfrom,yearto)) { + d(yearfrom) "-" + } + d(yearto) ")" + } + br + } + set(yearfrom,getel(years,1)) + set(yearto,getel(years,2)) + list(placenamelist) + extracttokens(location,placenamelist,nplaces,",") + set(name,getel(placenamelist,1)) + if (not(strcmp(name,prevfirstplace))) { + print("Warning: ambiguous placename initial element: ", + name,"\n") + } + set(prevfirstplace,save(name)) + forlist(placenamelist,placename,np) { + autohtml(placename) + if (lt(np,nplaces)) { + if (eq(np,1)) { " - " } else { ", " } + } + } ": " autohtml(surname) + set(prevplace,save(location)) + set(prevsurname,save(surname)) + } else { + if (strcmp(surname,prevsurname)) { + ", " autohtml(surname) + set(prevsurname,save(surname)) + } + if (thisyearfrom,getel(years,1)) { + if (or(lt(thisyearfrom,yearfrom),eq(yearfrom,0))) { + set(yearfrom,thisyearfrom) + } + } + if (gt(getel(years,2),yearto)) { + set(yearto,getel(years,2)) + } + } + } + if (yearto) { + " (" + if (ne(yearfrom,yearto)) { + d(yearfrom) "-" + } + d(yearto) ")" + } + br + + call section("Namen") + list(index_list) + list(trans_s_list) + call translate(s_list,trans_s_list) + call quicksort(trans_s_list,index_list) + set(ni,length(index_list)) + set(prevname,"zzxxyyzz") + set(comma,0) + forlist(index_list,index,i) { + set(name,getel(s_list,index)) + if (strcmp(name,prevname)) { + if (comma) { ", " } autohtml(name) + set(comma,1) + set(prevname,save(name)) + } + } + par + +/* Second traversal of ancestry, in surname order, but proband first. */ + + call doline(1) + + forlist(index_list,index,i) { + if (ne(index,1)) { + call doline(index) + } + } +} + +proc section(header) { + sep + if (html) { "

" } else { "\n" } + header + if (html) { "

" } + par par +} + +proc doline(person_index) { + set(person,getel(i_list,person_index)) + sep + if (html) { "

" } else { "\n" } +/* First pass to print out appropriate surnames */ + table(prev_surname_table) + autohtml(mysurname(person)) + insert(prev_surname_table,save(mysurname(person)),1) + while (person,father(person)) { + if (lookup(i_table,key(person))) { + set(person,0) + } else { + set(s,save(mysurname(person))) + if (not(lookup(prev_surname_table,s))) { + ", " autohtml(s) + insert(prev_surname_table,s,1) + } + } + } + if (html) { "

" } + "\n\n" + +/* Second pass to print out detailed information */ + set(person,getel(i_list,person_index)) + set(gen,getel(g_list,person_index)) + set(ahn,getel(a_list,person_index)) + call doperson(person,gen,ahn) + while (person,father(person)) { + incr(gen) + set(ahn,add(ahn,ahn)) + set(prev_ahn,lookup(i_table,key(person))) /* stop if person is a key... */ + if (not(prev_ahn)) { + set(prev_ahn,lookup(ahn_table,key(person))) + if (eq(prev_ahn,ahn)) { set(prev_ahn,0) } /* or if we did them already */ + } + if (prev_ahn) { + bold if (lt(gen,10)) { "0" } d(gen) " " d(ahn) unbold " " + autohtml(fullname(person,0,1,80)) " siehe " + set(gen2,ahn2gen(prev_ahn)) + if (lt(gen2,10)) { "0" } d(gen2) " " d(prev_ahn) "." br + set(person,0) + } else { + call doperson(person,gen,ahn) + } + } +} + +/* ahn2gen converts ahnentafel number to generation number */ +func ahn2gen(ahn) { + set(gen,1) + while (gt(ahn,1)) { + incr(gen) + set(ahn,div(ahn,2)) + } + return(gen) +} + +proc doperson(person,gen,ahn) { + bold if (lt(gen,10)) { "0" } d(gen) " " d(ahn) unbold " " + autohtml(mygivens(person)) set(comma,0) + + if (b,birth(person)) { + " " born call doevent(b) + set(comma,1) + } + if (b,baptism(person)) { + if (comma) { "," } + " " bapt call doevent(b) + set(comma,1) + } + set(nfam,nfamilies(person)) + families(person,fam,spouse,fnum) { + set(m,marriage(fam)) + if (or(m,spouse,gt(nfamilies,1))) { + if (comma) { "," } + " " marr if (gt(nfamilies,1)) { d(fnum) } + if (m) { call doevent(m) } + if (spouse) { + " " autohtml(mygivens(spouse)) + " " bold autohtml(mysurname(spouse)) unbold + } + set(comma,1) + } + } + if (b,death(person)) { + if (comma) { "," } + " " died call doevent(b) + set(comma,1) + } + if (b,burial(person)) { + if (comma) { "," } + " " burd call doevent(b) + set(comma,1) + } + "." br +} + +func mygivens(person) { + set(g,givens(person)) + if (strlen(g)) { return(g) } + return("____") +} + +func mysurname(person) { + set(s,surname(person)) + if (strcmp(s,"")) { return(s) } + return ("____") +} + +proc doevent(event) { + list(placelist) + extractplaces(event,placelist,nplaces) + if (nplaces) { + set(place,dequeue(placelist)) + if (strlen(place)) { " " } autohtml(place) + } + set(d,date(event)) + if (strlen(d)) { " " } + set(lopoff,4) + if (eq (index (d, "AFT", 1), 1)) { gt } + elsif (eq (index (d, "Aft", 1), 1)) { gt } + elsif (eq (index (d, "BEF", 1), 1)) { lt } + elsif (eq (index (d, "Bef", 1), 1)) { lt } + elsif (eq (index (d, "ABT", 1), 1)) { "c" } + elsif (eq (index (d, "Abt", 1), 1)) { "c" } + else { set(lopoff,1) } + set(d,substring(d,lopoff,strlen(d))) + while (eq (index (d, " ", 1), 1)) { + set(d,substring(d,2,strlen(d))) + } + if (m, index (d, "JAN", 1)) { "" } + elsif (m, index (d, "FEB", 1)) { "" } + elsif (m, index (d, "MAR", 1)) { "" } + elsif (m, index (d, "APR", 1)) { "" } + elsif (m, index (d, "MAY", 1)) { "" } + elsif (m, index (d, "JUN", 1)) { "" } + elsif (m, index (d, "JUL", 1)) { "" } + elsif (m, index (d, "AUG", 1)) { "" } + elsif (m, index (d, "SEP", 1)) { "" } + elsif (m, index (d, "OCT", 1)) { "" } + elsif (m, index (d, "NOV", 1)) { "" } + elsif (m, index (d, "DEC", 1)) { "" } + if (gt(m,1)) { + trim(d,sub(m,1)) + } + if (m) { capitalize(lower(substring(d,m,strlen(d)))) } + else { d } +} + +proc locations(person) { + call one_location(burial(person),mysurname(person),death(person)) + call one_location(death(person),mysurname(person),burial(person)) + if (female(person)) { + families(person,family,husband,fnum) { set(lasthusband,husband) } /* find last husband */ + call one_location(burial(person),mysurname(lasthusband),death(person)) + call one_location(death(person),mysurname(lasthusband),burial(person)) + } + families(person,family,spouse,fnum) { + call one_location(marriage(family),mysurname(person),0) + call one_location(marriage(family),mysurname(spouse),0) + } + call one_location(baptism(person),mysurname(person),birth(person)) + call one_location(birth(person),mysurname(person),baptism(person)) +} + +proc one_location(event,surname,event2) { + if (event) { + set(loc,place(event)) + set(yr,atoi(year(event))) + if (not(yr)) { set(yr,atoi(year(event2))) } + if (not(yr)) { set(yr,0) } + if (strlen(loc)) { + set(loc,locfilter(loc)) + set(locsur,concat(loc,":",surname)) + if (not(lookup(locationsurname_table,locsur))) { + list(locsuryears) + setel(locsuryears,1,yr) + setel(locsuryears,2,yr) + insert(locationsurname_table,save(locsur),locsuryears) + enqueue(locationsurname_list,save(locsur)) + } elsif (yr) { + set(locsuryears,lookup(locationsurname_table,locsur)) + if (lt(yr,getel(locsuryears,1))) { + setel(locsuryears,1,yr) + } elsif (gt(yr,getel(locsuryears,2))) { + setel(locsuryears,2,yr) + } + if (eq(getel(locsuryears,1),0)) { + setel(locsuryears,1,yr) + } + } + } + } +} + +/* remove unneeded location info from location name */ +func locfilter(string) { + set(string,strfilterstart(string,"near ")) + set(string,strfilter(string,"?")) + return(string) +} + +/* remove a string at the start of another string, if present */ +func strfilterstart(string,start) { + if (strcmp(substring(string,1,strlen(start)),start)) { + return(string) + } + return(substring(string,add(strlen(start),1),strlen(string))) +} + +/* remove a string from another string, multiple times if needed */ +func strfilter(string,sub) { + while (m,index(string,sub,1)) { + set(string,concat(substring(string,1,sub(m,1)), + substring(string,add(m,strlen(sub)),strlen(string)))) + } + return(string) +} + +/* translate a string but only if html global is set */ +func autohtml(string) { + if (html) { return(strxlat(html_xlat,string)) } + return(string) +} + +/* translate a whole list via sort_xlat to a sortable list */ +proc translate(listin,listout) { + forlist(listin,element,i) { + enqueue(listout,strxlat(sort_xlat,element)) + } +} + +/* translate string according to xlat table */ +func strxlat(xlat,string) { + set(fixstring,"") + set(pos,strlen(string)) + while(pos) { + set(char,substring(string,pos,pos)) + if (special,lookup(xlat,char)) { + set(fixstring,concat(special,fixstring)) + } + else { set(fixstring,concat(char,fixstring)) } + decr(pos) + } + return(fixstring) +} + +proc init_xlat() { +/* This initializes the various translation tables. + Note that these use the Macintosh encoding scheme! +*/ + +/* Translation table for sorting purposes. + Note that this is mostly to handle German characters. +*/ + insert(sort_xlat,"","oe") + insert(sort_xlat,"","oe") + insert(sort_xlat,"","ue") + insert(sort_xlat,"","ue") + insert(sort_xlat,"","ae") + insert(sort_xlat,"","ae") + insert(sort_xlat,"","ss") + insert(sort_xlat,"","ss") + insert(sort_xlat,"","Ae") + insert(sort_xlat,"","Ae") + insert(sort_xlat,"","Oe") + insert(sort_xlat,"","Oe") + insert(sort_xlat,"","Ue") + insert(sort_xlat,"","Ue") + insert(sort_xlat,"","e") + insert(sort_xlat,"","e") + insert(sort_xlat,"","y") + insert(sort_xlat,"","y") + insert(sort_xlat,"","e") + insert(sort_xlat,"","e") + insert(sort_xlat,"","n~") + insert(sort_xlat,"","n~") + insert(sort_xlat,"","oe") + insert(sort_xlat,"","oe") + +/* For the full list of HTML encodings for special characters, see + http://info.cern.ch/hypertext/WWW/MarkUp/ISOlat1.html +*/ + insert(html_xlat,"","ö") + insert(html_xlat,"","ö") + insert(html_xlat,"","ü") + insert(html_xlat,"","ü") + insert(html_xlat,"","ä") + insert(html_xlat,"","ä") + insert(html_xlat,"","ß") + insert(html_xlat,"","ß") + insert(html_xlat,"","Ä") + insert(html_xlat,"","Ä") + insert(html_xlat,"","Ö") + insert(html_xlat,"","Ö") + insert(html_xlat,"","Ü") + insert(html_xlat,"","Ü") + insert(html_xlat,"","ë") + insert(html_xlat,"","ë") + insert(html_xlat,"","ÿ") + insert(html_xlat,"","ÿ") + insert(html_xlat,"","é") + insert(html_xlat,"","é") + insert(html_xlat,"&","&") + insert(html_xlat,"","ñ") + insert(html_xlat,"","ñ") + insert(html_xlat,"","œ") + insert(html_xlat,"","œ") + +/* ISO 8859 translation for the GENDEX.txt file +*/ + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") +} + +/* + quicksort: Sort an input list by generating a permuted index list + Input: alist - list to be sorted + Output: ilist - list of index pointers into "alist" in sorted order + Needed: compare- external function of two arguments to return -1,0,+1 + according to relative order of the two arguments +*/ +proc quicksort(alist,ilist) { + set(len,length(alist)) + set(index,len) + while(index) { + setel(ilist,index,index) + decr(index) + } + if (ge(len,2)) { call qsort(alist,ilist,1,len) } +} + +/* recursive core of quicksort */ +proc qsort(alist,ilist,left,right) { + if(pcur,getpivot(alist,ilist,left,right)) { + set(pivot,getel(alist,getel(ilist,pcur))) + set(mid,partition(alist,ilist,left,right,pivot)) + call qsort(alist,ilist,left,sub(mid,1)) + call qsort(alist,ilist,mid,right) + } +} + +/* partition around pivot */ +func partition(alist,ilist,left,right,pivot) { + while(1) { + set(tmp,getel(ilist,left)) + setel(ilist,left,getel(ilist,right)) + setel(ilist,right,tmp) + while(lt(compare(getel(alist,getel(ilist,left)),pivot),0)) { + incr(left) + } + while(ge(compare(getel(alist,getel(ilist,right)),pivot),0)) { + decr(right) + } + if(gt(left,right)) { break() } + } + return(left) +} + +/* choose pivot */ +func getpivot(alist,ilist,left,right) { + set(pivot,getel(alist,getel(ilist,left))) + set(left0,left) + incr(left) + while(le(left,right)) { + set(rel,compare(getel(alist,getel(ilist,left)),pivot)) + if (gt(rel,0)) { return(left) } + if (lt(rel,0)) { return(left0) } + incr(left) + } + return(0) +} + +/* compare strings */ +func compare(string1,string2) { + return(strcmp(string1,string2)) +} + diff --git a/reports/ahnentafel.ll b/reports/ahnentafel.ll new file mode 100644 index 0000000..b091756 --- /dev/null +++ b/reports/ahnentafel.ll @@ -0,0 +1,60 @@ +/* + * @progname ahnentafel.ll + * @version 1 + * @author Wetmore + * @category + * @output Text + * @description + * + * Generate an ahnentafel chart for the selected person. + * + * ahnentafel -- Generate an ahnentafel chart */ +/* Tom Wetmore */ +/* Version 1, 4/27/95 */ + +proc main () +{ + getindimsg(indi, "Whose Ahnentafel do you want?") + if (not(indi)) { return() } + "Ahnentafel of " name(indi) "\n\n" + print("Computing ahnentafel of ", name(indi), "\n", + " Dots show persons per generation\n\n") + list(ilist) + list(alist) + list(glist) + table(ktab) + enqueue(ilist,indi) + enqueue(alist,1) + enqueue(glist,1) + set(gen, 0) + while(indi,dequeue(ilist)) { + set(ahnen, dequeue(alist)) + set (newgen, dequeue(glist)) + if (ne(gen, newgen)) { + "Generation " upper(roman(newgen)) ".\n\n" + print("\n", roman(newgen), " ") + set(gen, newgen) + } + set(before, lookup(ktab, key(indi))) + if (before) { + d(ahnen) ". Same as " d(before) ".\n" + } else { + print(".") + insert(ktab, save(key(indi)), ahnen) + d(ahnen) ". " name(indi) "\n" + if (e, birth(indi)) { " b. " long(e) "\n" } + if (e, death(indi)) { " d. " long(e) "\n" } + } + "\n" + if (par,father(indi)) { + enqueue(ilist, par) + enqueue(alist, mul(2,ahnen)) + enqueue(glist, add(gen, 1)) + } + if (par,mother(indi)) { + enqueue(ilist, par) + enqueue(alist, add(1,mul(2,ahnen))) + enqueue(glist, add(gen, 1)) + } + } +} diff --git a/reports/alive.ll b/reports/alive.ll new file mode 100644 index 0000000..7b50e54 --- /dev/null +++ b/reports/alive.ll @@ -0,0 +1,292 @@ +/* + * @progname alive.ll + * @version 6 + * @author Jim Eggert + * @category + * @output Text + * @description + +This report program is for finding people living in a given year. +This finds who in the database, or among ancestors or descendants of +an individual, was likely alive in a certain year. Good for looking at +population snapshots like censuses, tax rolls, etc. + +Version 1, 13 July 1994, by Jim Eggert, eggertj@ll.mit.edu +Version 2, 14 July 1994, by Jim Eggert, fixed bug in estimate_byear +Version 3, 22 July 1994, by Jim Eggert, fixed another bug in estimate_byear, + minor format improvement +Version 4, 15 March 1995, by Frank Flaesland, added support for listing places +Version 5, 17 March 1995, J.F.Chandler, modified to prune place list +Version 6, 27 Aug 1997, by Jim Eggert, fixed bug in print_header() + +** SourceForge Versions: +** +** Revision 1.6 2004/07/19 05:54:54 dr_doom +** Merge Vincent Broman Changes to reports +** +** Revision 1.4 2000/11/29 12:17:11 nozell +** Fix typo. +** +** Revision 1.3 2000/11/28 21:39:45 nozell +** Add keyword tags to all reports +** Extend the report script menu to display script output format +** +** Revision 1.2 2000/11/11 17:48:13 pere +** Get this report working. Fixed type problems and handle empty +** place tags without crashing. Add meta information. +** +** +*/ + +global(byear) +global(byear_delta) +global(byear_est) +global(byear_est_delta) +global(dyear_est) +global(dyear_est_delta) +global(old_age) +global(maximum_age) +global(mother_age) +global(father_age) +global(years_between_kids) +global(first_person) +global(who) +global(of) +global(places) + +proc main() { + /* Assumptions for guessing year of birth */ + set(old_age,60) /* assumed age at death */ + set(maximum_age,120)/* maximum possible age */ + set(mother_age,23) /* assumed age of first motherhood */ + set(father_age,25) /* assumed age of first fatherhood */ + set(years_between_kids,2) /* assumed years between children */ + + indiset(people) + set(first_person,1) + + getintmsg(who, + "Find live persons (0=all, 1=desc, 2=desc and spouses, 3=anc) ") + if (who) { getindimsg(of,"of ") } + getintmsg(when,"alive in which year?") + set(places, 1) + getstrmsg(yesno,"List possible places? (y/n) ") + if (strlen(yesno)) { + if (strcmp(upper(trim(yesno,1)),"Y")) { set(places,0) } + } + + if (eq(who,0)) { + forindi(person,pnum) { + call alive(person,when) + } + } + else { + addtoset(people,of,0) + if (or(eq(who,1),eq(who,2))) { set(people,descendentset(people)) } + elsif (eq(who,3)) { set(people,ancestorset(people)) } + addtoset(people,of,0) + if (eq(who,2)) { set(people,union(people,spouseset(people))) } + forindiset(people,person,pval,pnum) { + call alive(person,when) + } + } +} + +proc print_person(person) { + key(person) + col(9) fullname(person,0,1,50) + col(61) "(" + if (gt(byear_est_delta,1)) { "c" } + d(byear_est) + "-" + if (gt(dyear_est_delta,1)) { "c" } + d(dyear_est) + ")\n" + if (eq(places,1)) { call print_places(person) } +} + +proc print_places(person) { + list(place_names) + table(places_seen) + traverse (inode(person), node, level) { + if (eq(strcmp(tag(node), "PLAC"), 0)) { + set(p, value(node)) + if(lookup(places_seen,p)) { continue() } + insert(places_seen, p, 1) + extractplaces(node, place_names, num_places) + if (gt (num_places,0)) { + " " pop(place_names) + while (p, pop(place_names)) { ", " p } + "\n" + } + } + } +} + +proc print_header(year) { + set(current_year,strtoint(year(gettoday()))) + if (ge(year,current_year)) { set(future,1) } else { set(future,0) } + + "________________________________________________________________________\n" + "List of " + if (eq(who,0)) { "all persons" } + elsif (or(eq(who,1),eq(who,2))) { "descendants" } + elsif (eq(who,3)) { "ancestors" } + if (ge(who,1)) { " of\n" key(of) " " fullname(of,0,1,70) "\n" } + else { " " } + if (eq(who,2)) { "and their spouses" } + if (future) { "who are likely to be" } + else { "who are likely to have been" } + " alive in " d(year) "\n\n" + "________________________________________________________________________\n" + "Key" col(9) "Name" col(61) "(born-died)\n" + "________________________________________________________________________\n" +} + +proc alive(person,year) { + set(dyear_est,0) + call estimate_byear(person) + if (byear_est) { + if (and(le(byear_est,add(year,byear_est_delta)), + gt(byear_est,sub(year,maximum_age)))) { + set(dyear_est,atoi(year(death(person)))) + if (not(dyear_est)) { + set(dyear_est,atoi(year(burial(person)))) + } + else { set(dyear_est_delta,0) } + if (not(dyear_est)) { + set(dyear_est,add(byear_est,old_age)) + set(dyear_est_delta,20) + } + else { set(dyear_est_delta,1) } + if (ge(dyear_est,year)) { + if (first_person) { + call print_header(year) + set(first_person,0) + } + call print_person(person) + } + } + } +} + +proc estimate_byear(person) { + set(byear_est,0) + set(byear_est_delta,neg(1)) + call get_byear(person) + if (byear) { + set(byear_est,byear) + set(byear_est_delta,byear_delta) + } + else { /* estimate from siblings */ + set(older,person) + set(younger,person) + set(yeardiff,0) + set(border,0) + set(this_uncertainty,1) + while (and(not(byear_est),or(older,younger))) { + set(older,prevsib(older)) + set(younger,nextsib(younger)) + set(yeardiff,add(yeardiff,years_between_kids)) + set(this_uncertainty,add(this_uncertainty,1)) + if (older) { + set(border,add(border,1)) + call get_byear(older) + if (byear) { + set(byear_est,add(byear,yeardiff)) + set(byear_est_delta,this_uncertainty) + } + } + if (and(not(byear_est),younger)) { + call get_byear(younger) + if (byear) { + set(byear_est,sub(byear,yeardiff)) + set(byear_est_delta,this_uncertainty) + } + } + } + } + if (not(byear_est)) { /* estimate from parents' marriage */ + if (m,marriage(parents(person))) { extractdate(m,bd,bm,my) } + if (my) { + set(byear_est,add(add(my,mul(years_between_kids,border)),1)) + set(byear_est_delta,add(border,1)) + } + } + if (not(byear_est)) { /* estimate from first marriage */ + families(person,fam,spouse,fnum) { + if (eq(fnum,1)) { + if (m,marriage(fam)) { extractdate(m,bd,bm,my) } + if (my) { + if (female(person)) { set(byear_est,sub(my,mother_age)) } + else { set(byear_est,sub(my,father_age)) } + set(byear_est_delta,5) + } + else { + children(fam,child,cnum) { + if (not(byear_est)) { + call get_byear(child) + if (byear) { + if (female(person)) { + set(byear_est,sub(sub(byear, + mul(sub(cnum,1),years_between_kids)), + mother_age)) + } + else { + set(byear_est,sub(sub(byear, + mul(sub(cnum,1),years_between_kids)), + father_age)) + } + set(byear_est_delta,add(5,cnum)) + } + } + } + } + } + } + } + if (not(byear_est)) { /* estimate from parents' birthyear */ + call get_byear(mother(person)) + if (byear) { + set(byear_est,add(byear,mother_age)) + } + else { + call get_byear(father(person)) + if (byear) { + set(byear_est,add(byear,father_age)) + } + } + if (byear) { + set(byear_est_delta,5) + set(older,person) + while(older,prevsib(older)) { + set(byear_est,add(byear_est,years_between_kids)) + set(byear_est_delta,add(byear_est_delta,1)) + } + } + } +} + +proc get_byear(person) { + set(byear,0) + if (person) { + if (b,birth(person)) { extractdate(b,day,month,byear) } + if (byear) { + set(byear_delta,0) + set(dstring,trim(date(b),3)) + if (not(strcmp(dstring,"BEF"))) { set(byear_delta,3) } + elsif (not(strcmp(dstring,"AFT"))) { set(byear_delta,3) } + elsif (not(strcmp(dstring,"ABT"))) { set(byear_delta,2) } + } + else { + if (b,baptism(person)) { extractdate(b,day,month,byear) } + if (byear) { + set(byear_delta,1) + set(dstring,trim(date(b),3)) + if (not(strcmp(dstring,"BEF"))) { set(byear_delta,3) } + elsif (not(strcmp(dstring,"AFT"))) { set(byear_delta,3) } + elsif (not(strcmp(dstring,"ABT"))) { set(byear_delta,2) } + } + } + } +} diff --git a/reports/all_anc_lines.ll b/reports/all_anc_lines.ll new file mode 100644 index 0000000..c0fdebc --- /dev/null +++ b/reports/all_anc_lines.ll @@ -0,0 +1,410 @@ +/* + * @progname all_anc_lines.ll + * @version 2 + * @author Tom Wetmore + * @category + * @output Text + * @description + * + * report all ancestral lines in a Register-like format + * + + all_anc_lines -- Shows all ancestral lines of a specified person using + a pseudo-Register format. The paternal line of the person is shown + first; then the paternal line of his/her mother; then the paternal line + of his/her paternal grandmother; and so on, in a depth-first manner. + + A new feature was added to follow maternal lines also. + + Future option -- breadth first versus depth first coverage -- easy to + implement by changing the algorithm that builds dlist from a stack to a + queue. + + by Tom Wetmore, ttw@beltway.att.com + version 1, 14 Nov 1995 + version 2, 23 Nov 1995 +*/ + +global(mlist) /* list of pending key persons */ +global(glist) /* generations of pending key persons */ +global(stable) /* table of seen key persons */ +global(dlist) /* list of final key persons */ +global(hlist) /* list of final generations */ +global(ilist) /* list of isolated persons */ +global(pat) +global(depth) +global(ftable) /* list of shown families */ +global(ptable) /* table of printed persons */ + +proc main () +{ + getindi(i, "Enter person whose full registry ancestry is wanted.") + if (i) { + list(menu) + enqueue(menu, "Follow paternal lines; or") + enqueue(menu, "Follow maternal lines.") + set(m, menuchoose(menu, "Select whether to:")) + if (eq(1, m)) { set(pat, 1) } + else { set(pat, 0) } + list(menu) +/* + enqueue(menu, "Output lines depth-first; or") + enqueue(menu, "Output lines breadth-first.") + set(m, menuchoose(menu, "Select whether to:")) + if (eq(1, m)) { set(depth, 1) } + else { set(depth, 0) } +*/ + list(mlist) + list(glist) + table(stable) + list(dlist) + list(hlist) + list(ilist) + table(ftable) + table(ptable) + call doit(i) + } else { + print("Program not run.") + } +} + +proc doit (i) +{ + call makedlist(i) + call genreport() +} + +proc makedlist (i) +{ + enqueue(mlist, i) + enqueue(glist, 1) + while (p, dequeue(mlist)) { + set(g, dequeue(glist)) + enqueue(dlist, p) + enqueue(hlist, g) + while (p) { + set(g, add(g, 1)) + if (pat) { + if (m, mother(p)) { + if (not(lookup(stable, key(m)))) { + insert(stable, save(key(m)), 1) + enqueue(mlist, m) + enqueue(glist, g) + } + } + set(p, father(p)) + } else { + if (f, father(p)) { + if (not(lookup(stable, key(f)))) { + insert(stable, save(key(f)), 1) + enqueue(mlist, f) + enqueue(glist, g) + } + } + set(p, mother(p)) + } + } + } +} + +proc genreport () +{ + call nroffhead() + forlist (dlist, p, n) { + set(g, dequeue(hlist)) + if (not(lookup(ptable, key(p)))) { + if (pat) { set(q, father(p)) } + else { set(q, mother(p)) } + if (q) { + call showline(p, g) + } else { + insert (ptable, save(key(p)), 1) + enqueue(ilist, p) + } + } + } + forlist (ilist, p, n) { + "ISOLATED PERSON " name(p) "\n" + } +} + +proc showline (p, g) +{ + if (pat) { + call showsurnames(p) + /*".NL\nPATERNAL LINE OF " upper(name(p)) "\n\n"*/ + print(surname(p), " ") + } else { + ".NL\nMATERNAL LINE OF " upper(name(p)) "\n\n" + } + list(alist) + if (pat) { + while (f, father(p)) { + push(alist, p) + set(p, f) + set(g, add(g, 1)) + } + } else { + while (m, mother(p)) { + push(alist, p) + set(p, m) + set(g, add(g, 1)) + } + } + push(alist, p) + set(a, pop(alist)) + while (a) { + set(b, pop(alist)) + call dotwo(a, b, g) + set(a, b) + set(g, sub(g, 1)) + } +} + +proc dotwo (a, b, g) +{ + /*".GN\nGENERATION " d(g) "\n\n"*/ + ".IN\n" d(g) ". " + call longvitals(a) /* show main line person */ + insert(ptable, save(key(a)), 1) + + if (pat) { set(c, mother(b)) } + else { set(c, father(b)) } + if (pat) { set(d, father(c)) } + else { set(d, mother(c)) } + + if (and(c, not(d))) { + call gammavitals(c, a) + insert(ptable, save(key(c)), 1) + } + + call dochildren(a, b) + if (and(c, not(d))) { + call gammachildren(c) + } +} + +proc nroffhead () +{ + ".de hd\n'sp .8i\n..\n" + ".de fo\n'bp\n..\n" + ".wh 0 hd\n.wh -.8i fo\n" + ".de CH\n" + ".sp\n" + ".in 11n\n" + ".ti 0\n" + "\\h'3n'\\h'-\\w'\\\\$1'u'\\\\$1\\h'6n'\\h'-\\w'\\\\$2'u'\\\\$2\\h'1n'\n" + "..\n" + + ".de IN\n.sp\n.in 0\n..\n" + ".de NL\n.br\n.ne 2i\n.sp 2\n.in 0\n.ce\n..\n" + ".de GN\n.br\n.ne 2i\n.sp 2\n.in 0\n.ce\n..\n" + ".de P\n.sp\n.in 0\n.ti 5\n..\n" + ".po 5\n" + ".ll 7i\n" + ".ls 1\n" + ".na\n" +} + +proc dochildren (i, c) +{ + if (c) { set(ckey, save(key(c))) } + else { set(ckey, "JUNK") } + families (i, f, s, n) { + ".P\n" + if (s) { set(sname, save(name(s))) } + else { set(sname, "(_____)") } + if (eq(0, nchildren(f))) { + name(i) " and " sname + " had no children.\n" + } elsif (lookup(ftable, key(f))) { + "Children of " name(i) " and " sname + " listed under " sname ".\n" +/* + children(f, k, m) { + if (not(strcmp(key(k), ckey))) { + ".CH (+) " roman(m) "\n" + call shortvitals(k) + } else { + ".CH \"\" " roman(m) "\n" + call shortvitals(k) + } + + } +*/ + } else { + "Children of " name(i) " and " sname ":\n" + children(f, k, m) { + if (not(strcmp(key(k), ckey))) { + /*print(name(k), "\n")*/ + ".CH (+) " roman(m) "\n" + call shortvitals(k) + } else { + ".CH \"\" " roman(m) "\n" + call middlevitals(k) + } + } + insert(ftable, save(key(f)), 1) + } + } +} + +proc shortvitals (i) +{ + name(i) + set(b, birth(i)) + set(d, death(i)) + if (and(b, short(b))) { ", b. " short(b) } + if (and(d, short(d))) { ", d. " short(d) } + ".\n" +} + +proc middlevitals (i) +{ + name(i) ".\n" + set(e, birth(i)) + if(and(e,long(e))) { "Born " long(e) ".\n" } + if (eq(1, nspouses(i))) { + spouses(i, s, f, n) { + "Married" + call spousevitals(s, f) + } + } else { + spouses(i, s, f, n) { + "Married " ord(n) "," + call spousevitals(s, f) + } + } + set(e, death(i)) + if(and(e, long(e))) { "Died " long(e) ".\n" } + set(p, 0) +} + +proc longvitals (i) +{ + name(i) ".\n" + set(e, birth(i)) + if(and(e,long(e))) { "Born " long(e) ".\n" } + if (eq(1, nspouses(i))) { + spouses(i, s, f, n) { + "Married" + call spousevitals(s, f) + } + } else { + spouses(i, s, f, n) { + "Married " ord(n) "," + call spousevitals(s, f) + } + } + set(e, death(i)) + if(and(e, long(e))) { "Died " long(e) ".\n" } + set(p, 0) + fornotes(inode(i), n) { + if (not(p)) { ".P\n" set(p, 1) } + n "\n" + } +} + +proc spousevitals (s, f) +{ + set(e, marriage(f)) + if (and(e, long(e))) { "\n" long(e) "," } + "\n" name(s) + set(e, birth(s)) + if (and(e, long(e))) { ",\nborn " long(e) } + set(e, death(s)) + if (and(e, long(e))) { ",\ndied " long(e) } + set(d, father(s)) + set(m, mother(s)) + if (or(d, m)) { + ",\n" + if (male(s)) { "son of " } + elsif (female(s)) { "daughter of " } + else { "child of " } + } + if (d) { name(d) } + if (and(d, m)) { "\nand " } + if (m) { name(m) } + ".\n" +} + +proc gammavitals(a, c) +{ + set(n, nfamilies(a)) + set(m, mother(a)) + set(d, father(a)) + if (or(gt(n, 1), or(m, d))) { + ".P\n" name(a) ", " + if (or(d, m)) { + if (male(a)) { "son of " } + elsif (female(a)) { "daughter of " } + else { "child of " } + } + if (d) { name(d) } + if (and(d, m)) { "\nand " } + if (m) { name(m) } + if (or(d, m)) { ",\n" } + if (gt(n, 1)) { + if (eq(1, nspouses(a))) { + spouses(a, s, f, n) { + "Married " + if (eqstr(key(c), key(s))) { + name(s) ".\n" + } else { + call spousevitals(s, f) + } + } + } else { + spouses(a, s, f, n) { + "Married " ord(n) "," + if (eqstr(key(c), key(s))) { + name(s) ".\n" + } else { + call spousevitals(s, f) + } + } + } + ".\n" + } + } +} +proc gammachildren (p) +{ + families (p, f, s, n) { + if (not(lookup(ftable, key(f)))) { + ".P\n" + if (s) { set(sname, save(name(s))) } + else { set(sname, "(_____)") } + if (eq(0, nchildren(f))) { + name(p) " and " sname " had no children.\n" + } else { + "Children of " name(p) " and " sname ":\n" + children(f, k, m) { + ".CH \"\" " roman(m) "\n" + call middlevitals(k) + } + } + } + } +} + +proc showsurnames(p) +{ + /*".NL\nPATERNAL LINE OF " upper(name(p)) "\n\n"*/ + ".NL\n" + list(snames) + table(stable) + while (p) { + if (not(lookup(stable, surname(p)))) { + enqueue(snames, save(surname(p))) + insert(stable, save(surname(p)), 1) + } + set(p, father(p)) + } + set(c, "") + forlist (snames, s, n) { + c upper(s) + set(c, ", ") + } + "\n" +} diff --git a/reports/allfam10c.ll b/reports/allfam10c.ll new file mode 100644 index 0000000..a8be4ba --- /dev/null +++ b/reports/allfam10c.ll @@ -0,0 +1,99 @@ +/* + * @progname allfam10c.ll + * @version 1.1 + * @author Cliff Manis, Jim Eggert + * @category + * @output Text + * @description + * + * Display all families in the DB, 1 per page. + * + * allfam10c + * by: Cliff Manis , modified by Jim Eggert + * Family Report for LifeLines + */ + +proc main() +{ + forfam(fam,fnum) { + call fam10c(fam) + " " /* this is the form-feed character, octal 014 hex 0C*/ + /* You may have to change it for your needs */ + } +} + +proc fam10c (fam) +{ +/* getfam(fam) */ + dayformat(0) + monthformat(4) + dateformat(0) + set(tday, gettoday()) + set (nl,nl()) + set(h,husband(fam)) + set(w,wife(fam)) + col(55) "Date: " stddate(tday) nl + col(0) "Family Report (fam10)" + nl nl + col(0) "HUSBAND: " fullname(h,1,1,50) + col(63) "(RN=" key(h) ")" + nl nl + set(evt, birth(h)) + col(0) "Born: " stddate(evt) col(25) "Place: " place(evt) + set(evt, marriage(fam)) + col(0) "Marr: " stddate(evt) col (25) "Place: " place(evt) + set(evt, death(h)) + col(0) "Died: " stddate(evt) col(25) "Place: " place(evt) + nl nl + col(0) "HUSBAND'S FATHER: " name(father(h)) + col(63) "(RN=" key(father(h)) ")" + nl + col(0) "HUSBAND'S MOTHER: " name(mother(h)) + col(63) "(RN=" key(mother(h)) ")" + nl nl + col(0) "WIFE: " fullname(w,1,1,50) + col(63) "(RN=" key(w) ")" + nl nl + set(evt, birth(w)) + col(0) "Born: " stddate(evt) col(25) "Place: " place(evt) + set(evt, death(w)) + col(0) "Died: " stddate(evt) col(25) "Place: " place(evt) + nl nl + col(0) " WIFE'S FATHER: " name(father(w)) + col(63) "(RN=" key(father(w)) ")" + col(0) " WIFE'S MOTHER: " name(mother(w)) + col(63) "(RN=" key(mother(w)) ")" + nl nl + col(0) "========================================================================" + nl + col(0) "# M/F" col(12) "Childrens Names" col(63) "RECORD NUM" + nl + col(0) "========================================================================" + nl + children(fam, child, num) { + col(0) d(num) + col(4) sex(child) + col(12) name(child) col(63) "(RN=" key(child) ")" + col(4) "Born:" col(13) stddate(birth(child)) + col(26) place(birth(child)) + nl + + col(4) "Died:" col(13) stddate(death(child)) + col(26) place(death(child)) + nl + + families(child, fvar, svar, num) { + if (eq(num,1)) { + col(4) "Marr:" col(13) stddate(marriage(fvar)) + col(26) if (svar) { name(svar) + col(63) "(RN=" key(svar) ")" } + else { " " } + nl + } + } + if (eq(nfamilies(child),0)) { " " nl } + col(4) "---------------------------------------------------------" + } +} + +/* End of Report */ diff --git a/reports/alllines.ll b/reports/alllines.ll new file mode 100644 index 0000000..412f816 --- /dev/null +++ b/reports/alllines.ll @@ -0,0 +1,784 @@ +/* + * @progname allines.sgml.ll + * @version 1.1 + * @author Wetmore, Nozell + * @category + * @output SGML, NROFF + * @description + * + * This program shows all ancestral lines of a specified person + * using a pseudo-Register format. + * + * Output is in nroff or sgml format. This may change to something + * more generic. + * + * Tom Wetmore, ttw@shore.net + * beta version, 27 February 1997 + * + * Marc Nozell, nozell@rootsweb.com + * Added sgmldoc (formerly known as linuxdoc), 3 March 1997 + */ + +global(format_type) /* what format? nroff or sgml? */ +global(CurID) /* ID values assigned to ancestors */ +global(BOLK) /* list of keys of persons who begin lines */ +global(BOLG) /* generations of begin line persons */ +global(BOLR) /* relationships of begin line persons */ +global(CurK) /* current line being processed */ +global(CurG) /* generations in current line */ +global(CurR) /* relations in current line */ +global(AncT) /* table of all ancestors */ +global(AncL) /* list of all ancestors */ +global(KeyT) /* table of all saved keys */ +global(TOLT) /* table of top of line persons */ +global(TOLL) /* list of top of line persons */ +global(FamT) /* NEED COMMENT TO DESCRIBE THIS!! */ + +/* User Options */ + +global(OPat) /* follow paternal lines */ +global(ORel) /* show relationships */ + +/* LineParent -- Return parent in line direction. */ + +func LineParent (p) +{ + if (OPat) { return(father(p)) } + else { return(mother(p)) } +} + +/* OthrParent -- Return parent in non-line direction. */ + +func OthrParent (p) +{ + if (OPat) { return(mother(p)) } + else { return(father(p)) } +} + +/* + * main - This is the main routine; it asks the user to identify a person + * and then calls the DoIt routine. + */ + +proc main () +{ + getindi(i, "Enter person whose full registry ancestry is wanted.") + if (i) { call DoIt(i) } + else { print("Program not run.") } +} + +/* + * DoIt - This is the top routine of the program; it calls routines to + * perform the main algorithmic jobs and then calls a routine to write the + * report. + */ + +proc DoIt (i) +{ + set(CurID, 1) + table(KeyT) + call GetUserOptions() + +/* + * The first step in this program is to compute the list of "bottom of + * line" persons. These persons are those that on first sight seem to + * require an ancestral line generated in the program's output. Because + * multiple bottom of line persons may have the same top of line ancestor + * (due to pedigree collapse) it may turn out that there is not a separate + * line computed for each bottom of line person. This complication is + * dealt with later. The first bottom of line person is always the + * starting person, and the first ancestral line shown in the output will + * be the parental line of this person. Normally this parental line will + * be the paternal line. + */ + print("Finding all bottom of line persons.\n") + call BFirstCreateBOLLists(i)/**/ + /* call ShowBOLLists() /*DEBUG*/ + +/* + * The second step is to build an ancestor table that contains all the + * information about the ancestors of the key person that is needed in + * generating the program's output. The table accumulates the information + * needed to deal with pedigree collapse. + */ + + print("Creating table of all ancestors.\n") + call CreateAncStructures() /* call ShowAncTable() /**/ + +/* + * The third step is to number the ancestors in the ancestor table in such + * a way that on output each numbered ancestor magically has the right + * sequential number. + */ + + print("Numbering all ancestors in table.\n") + call NumberAncestors() /* call ShowAncTable() /**/ + +/* + * The fourth step is to compute the list of top of line ancestors. Due + * to pedigree collapse there may be fewer top of line ancestors than + * there are bottom of line persons. Whenever this is the case, there + * will be an ancestor somewhere in the line who has more than one child + * who are also ancestors (the essence of pedigree collapse). This program + * collapses all lines that begin with the same person but lead to + * different descendants (who are still all ancestors of the starting + * person) + */ + + print("Computing top of line ancestors.\n") + call CreateTOLList() /* call ShowTOLList() /**/ + +/* + * The last step is to write the report. + */ + + print("Printing final report.\n") + call WriteReport() +} + +/* + * GetUserOptions - As you can see, users can't actually select them yet! + */ + +proc GetUserOptions () +{ + getintmsg(format_type, "Enter 0 for nroff, 1 for sgml") + + set(OPat, 1) /* this version only follows paternal lines */ + set(ORel, 1) /* this version shows relationships */ +} + +/* + * BFirstCreateBOLLists - This routine creates the beginning of lines lists. + * This is the breadth first version of this routine. Following is the + * moving front version. I don't know which order is the best. Try them + * both and see which you prefer. + */ + +proc BFirstCreateBOLLists (i) +{ + list(BOLK) list(BOLG) list(BOLR) + list(TmpK) list(TmpG) list(TmpR) + enqueue(TmpK, savekey(key(i))) + enqueue(TmpG, 1) enqueue(TmpR, 1) + + while (k, dequeue(TmpK)) { + set(p, indi(k)) + set(g, dequeue(TmpG)) set(r, dequeue(TmpR)) + if (eq(1, mod(r, 2))) { + enqueue(BOLK, k) enqueue(BOLG, g) enqueue(BOLR, r) + } + set(g, add(1, g)) set(r, mul(2, r)) + if (f, LineParent(p)) { + enqueue(TmpK, savekey(key(f))) + enqueue(TmpG, g) enqueue(TmpR, r) + } + set(r, add(1, r)) + if (m, OthrParent(p)) { + enqueue(TmpK, savekey(key(m))) + enqueue(TmpG, g) enqueue(TmpR, r) + } + } +} + +/* + * MFrontCreateBOLLists - This routine also creates the beginning of line + * lists. This is the moving front version, and is not used in this beta + * version. + */ + +proc MFrontCreateBOLLists (i) +{ + list(BOLK) list(BOLG) list(BOLR) + list(TmpK) list(TmpG) list(TmpR) + enqueue(TmpK, savekey(key(i))) + enqueue(TmpG, 1) enqueue(TmpR, 1) + + while (k, dequeue(TmpK)) { + set(g, dequeue(TmpG)) set(r, dequeue(TmpR)) + set(p, indi(k)) + enqueue(BOLK, k) enqueue(BOLG, g) enqueue(BOLR, r) + while (p) { + set(g, add(g, 1)) set(r, mul(r, 2)) + if (m, OthrParent(p)) { + enqueue(TmpK, savekey(key(m))) + enqueue(TmpG, g) enqueue(TmpR, add(r, 1)) + } + set(p, LineParent(p)) + } + } +} + +/* + * CreateAncStructures - This routine creates the AncT table and AncL list. + * These are data structures that hold information about all ancestors of + * the starting person. This routine operates by considering each bottom + * of line person in turn. For each bottom of line person his or her + * ancestral line is computed and then the ProcessCurLine routine is + * called. It is the ProcessCurLine routine that actually updates the + * data structures. + * + * Note that the only use of the AncL list is in the debugging routine + * ShowAncTable. + */ + +proc CreateAncStructures () +{ + table(AncT) list(AncL) + + forlist(BOLK, k, n) { /* for each bottom of line person ... */ + set(g, getel(BOLG, n)) set(r, getel(BOLR, n)) + set(p, indi(k)) + + list(CurK) list(CurG) list(CurR) /* make them empty */ + while (p) { /* start with BOL person and follow line back */ + push(CurK, savekey(key(p))) + push(CurG, g) push(CurR, r) + set(g, add(1, g)) + set(r, mul(2, r)) + set(p, LineParent(p)) + } + call ProcessCurLine() + } +} + +/* + * ProcessCurLine - This routine updates the ancestor table and list based + * on an ancestral line just computed for a bottom of line person by the + * CreateAncStructures routine. This line is stored in the three global + * lists CurK, CurG, and CurR, which form the interface between this + * routine and CreateAncStructures. This routine processes the line from + * the last line ancestor of the bottom of line person to the bottom of + * line person. + */ + +proc ProcessCurLine () +{ + set(f, 0) /* f holds the line parent of the current person */ + set(k, pop(CurK)) + while (k) { + set(p, indi(k)) + set(g, pop(CurG)) + set(r, pop(CurR)) + call AddToAncTable(k, g, r, f) + /*name(p) " (" d(g) ", " d(r) ") "/*DEBUG*/ + set(f, k) + set(k, pop(CurK)) + } +} + +/* + * AddToAncTable - This routine adds information to the ancestor table. + * Each table entry is a list with six elements: + * 1 Key of person + * 2 ID of person + * 3 Number of appearances in pedigree + * 4 List of generations relative to key person by appearance + * 5 List of relationships to key person by appearance + * 6 List of children of this person who are also ancestors of key person + */ + +proc AddToAncTable (k, g, r, f) +{ + if (e, lookup(AncT, k)) { /* if person is already in table ... */ + + setel(e, 3, add(1, getel(e, 3))) /* incr num of appearances */ + set(l, getel(e, 4)) + enqueue(l, g) /* update list of generations */ + set(l, getel(e, 5)) + enqueue(l, r) /* update list of relationships */ + + } else { /* this is the first time this ancestor has been seen */ + + list(e) /* create new, empty table entry for person */ + enqueue(e, k) /* add person's key */ + enqueue(e, 0) /* init id to zero */ + enqueue(e, 1) /* init num of appearences to one */ + list(l) /* create sub-list to hold generations */ + enqueue(l, g) /* init sub-list to current generation */ + enqueue(e, l) /* add sub-list to table entry */ + list(l) /* create sub-list to hold relationships */ + enqueue(l, r) /* init sub-list to current relationship */ + enqueue(e, l) /* add sub-list to table entry */ + list(l) /* create sub-list to hold line descendants */ + enqueue(e, l) /* add (empty) sub-list to table entry */ + insert(AncT, k, e) /* add new entry to ancestor table */ + enqueue(AncL, k) /* add key of person to ancestor list */ + } + if (f) { /* if not top of line make a child of line parent */ + set(d, lookup(AncT, f)) + set(l, getel(d, 6)) + if (not(inlist(l, k))) { + enqueue (l, k) + } + } +} + +/* + * NumberAncestors - This routine numbers the ancestors in the ancestor + * table. + */ + +proc NumberAncestors () +{ + forlist(BOLK, k, n) { + set(p, indi(k)) + while (f, LineParent(p)) { set(p, f) } + call NumberLine(key(p)) + } +} + +proc NumberLine (k) +{ + set(e, lookup(AncT, k)) + if (ne(0, getel(e, 2))) { return() } + list(TmpQ) + enqueue(TmpQ, k) + while (k, dequeue(TmpQ)) { + set(p, indi(k)) + set(e, lookup(AncT, k)) + setel(e, 2, CurID) + set(CurID, add(1, CurID)) + set(cl, getel(e, 6)) + families (p, f, s, n) { + children (f, o, m) { + if (inlist(cl, key(o))) { + enqueue(TmpQ, savekey(key(o))) + } + } + } + } +} + +proc CreateTOLList () +{ + table(TOLT) list(TOLL) + forlist (BOLK, k, n) { + set(p, indi(k)) + while (f, LineParent(p)) { set(p, f) } + set(s, savekey(key(p))) + if (and(nestr(k, s), not(lookup(TOLT, s)))) { + enqueue(TOLL, s) + insert(TOLT, s, s) + } + } +} + +proc ShowTOLList () +{ + "START OF LINE LIST --\n" + forlist (TOLL, k, n) { + name(indi(k)) "\n" + } +} + +/* + * WriteReport - This routine controls writing a report. Right now this + * program has built in knowledge that the report is being generated in + * nroff format. This should be changed so that only generic routines + * are called out of this routine, making substitution for different report + * formats (e.g., LaTeX, HTML) easier in the future. + */ + +proc WriteReport () +{ + call WriteHeading() + table(FamT) + forlist (TOLL, k, n) { + call WriteLine(k) + } + call WriteTail() +} + +/* + * WriteLine - This routine is responsible writing a single line to the + * report file. + */ + +proc WriteLine (k) /* k -- key of a line's top of line person */ +{ + call LineTitle(k) + set(e, lookup(AncT, k)) + list(TmpQ) + enqueue(TmpQ, k) + while (k, dequeue(TmpQ)) { + set(e, lookup(AncT, k)) + call WriteLinePerson(e) + call WriteChildren(e) + forlist(getel(e, 6), c, n) { + enqueue(TmpQ, c) + } + } +} + +proc EmitPara () { + if (eq(format_type, 0)) { call nroffPara() } + else { call sgmlPara() } +} + +proc EmitLeftSquareBracket () { + if (eq(format_type, 0)) { call nroffLeftSquareBracket() } + else { call sgmlLeftSquareBracket() } +} + +proc EmitRightSquareBracket () { + if (eq(format_type, 0)) { call nroffRightSquareBracket() } + else { call sgmlRightSquareBracket() } +} + +proc EmitStartList () { + if (eq(format_type, 0)) { call nroffStartList() } + else { call sgmlStartList() } +} + +proc EmitEndList () { + if (eq(format_type, 0)) { call nroffEndList() } + else { call sgmlEndList() } +} + +proc EmitChildItem () { + if (eq(format_type, 0)) { call nroffChildItem() } + else { call sgmlChildItem() } +} + +proc WriteHeading () { + if (eq(format_type, 0)) { call nroffhead() } + else { call sgmlhead() } +} + +proc WriteTail () { + if (eq(format_type, 0)) { call nrofftail() } + else { call sgmltail() } +} + +proc LineTitle (k) +{ + if (eq(format_type, 0)) { call nroffLineTitle(k) } + else { call sgmlLineTitle(k) } +} + +proc nroffhead () +{ + ".de CH\n" + ".sp\n" + ".in 11n\n" + ".ti 1\n" + "\\h'3n'\\h'-\\w'\\\\$1'u'\\\\$1\\h'5n'\\h'-\\w'\\\\$2'u'\\\\$2\\h'1n'\n" + "..\n" + + ".de P\n.sp\n.in 0\n..\n" + /*".po 5\n"*/ + ".ll 72\n" + ".ls 1\n" + ".na\n" +} + +proc sgmlhead () +{ + + "" nl() + "
" nl() + "All Lines" nl() + "by Marc Nozell" + " " nl() + "This shows all ancestral lines of a specified person using a pseudo-Register format." + "" nl() + "" nl() +} + +proc nrofftail () +{ + " " nl() /* pretty boring... */ +} + +proc sgmltail () +{ + "
" nl() +} + +proc nroffLineTitle (k) { + ".P\n.sp 2\nANCESTRAL LINE FROM " upper(name(indi(k))) "\n" + ".br\n-----------------------------------------------------\n" +} + +proc sgmlLineTitle (k) { + nl()"Ancestral line from " upper(name(indi(k))) "\n" +} + +proc nroffPara () { + ".P\n" +} + +proc sgmlPara () { + "

\n" +} + +proc nroffLeftSquareBracket () { + "[" +} +proc sgmlLeftSquareBracket () { + "[" +} + +proc nroffRightSquareBracket () { + "]" +} +proc sgmlRightSquareBracket () { + "]" +} + +proc nroffStartList () { + "\n" +} + +proc sgmlStartList () { + "\n" +} + +proc nroffEndList () { + "\n" +} + +proc sgmlEndList () { + "\n" +} + +proc nroffChildItem () { + " " +} + +proc sgmlChildItem () { + "\n" +} + + +/* + * WriteChildren - This routine writes out the children for a person in an + * ancestral line. + */ + +proc WriteChildren (e) +{ + set(p, indi(getel(e, 1))) + set(cl, getel(e, 6)) /* list of child keys also in this line */ + families (p, f, s, n) { + if (s) { set(u, save(name(s))) } + else { set(u, "(_____)") } + if (lookup(FamT, key(f))) { + call EmitPara() + "Children of " name(p) " and " u + " listed under " u ".\n" + } elsif (gt(nchildren(f), 0)) { + call EmitPara() + "Children of " name(p) " and " u ":\n" + call EmitStartList() + children(f, c, m) { + if (inlist(cl, key(c))) { + set(ce, lookup(AncT, key(c))) + call EmitChildItem() + d(getel(ce, 2)) " " + roman(m) "\n" + call shortvitals(c) + } else { + call EmitChildItem() + roman(m) "\n" + call middlevitals(c) + } + } + insert(FamT, savekey(key(f)), 1) + call EmitEndList() + } + } +} + +proc shortvitals (i) +{ + name(i) + set(b, birth(i)) set(d, death(i)) + if (and(b, short(b))) { ", b. " short(b) } + if (and(d, short(d))) { ", d. " short(d) } + ".\n" + call EmitPara() +} + +proc middlevitals (i) +{ + name(i) ".\n" + set(e, birth(i)) + if(and(e,long(e))) { + call EmitPara() + "Born " long(e) ".\n" } + if (eq(1, nspouses(i))) { + spouses(i, s, f, n) { + call EmitPara() + "Married" + call spousevitals(s, f) + } + } else { + spouses(i, s, f, n) { + call EmitPara() + "Married " ord(n) "," + call spousevitals(s, f) + } + } + set(e, death(i)) + if(and(e, long(e))) { + call EmitPara() + "Died " long(e) ".\n" } + set(p, 0) +} + +/* + * WriteLinePerson - This routine generates the report output for one + * person in one of the ancestral lines. This version of the routine + * generates output in nroff format. It prints boiler plate vitals + * information about the person followed by all notes in the person's + * record in the database. This routine does not print the person's + * children (see routine >>>>> for this). + */ + +proc WriteLinePerson (e) +{ + set(p, indi(getel(e, 1))) + call EmitPara() + d(getel(e, 2)) " " + name(p) + if (ORel) { + call EmitLeftSquareBracket() + set(c, "") + forlist (getel(e, 5), r, n) { + c call ShowRel(r) set(c, ", ") + } + call EmitRightSquareBracket() + } + ".\n" + call EmitPara() + set(o, birth(p)) + if(and(o, long(o))) { "Born " long(o) ".\n" } + if (eq(1, nspouses(p))) { + spouses(p, s, f, n) { + "Married" + call spousevitals(s, f) + } + } else { + spouses(p, s, f, n) { + "Married " ord(n) "," + call spousevitals(s, f) + } + } + set(o, death(p)) + if(and(o, long(o))) { "Died " long(o) ".\n" } + set(b, 0) + fornotes(root(p), n) { + if (not(b)) { + call EmitPara() + set(b, 1) } + n "\n" + } +} + +proc spousevitals (s, f) +{ + set(e, marriage(f)) + if (and(e, long(e))) { "\n" long(e) "," } + "\n" name(s) + set(e, birth(s)) + if (and(e, long(e))) { ",\nborn " long(e) } + set(e, death(s)) + if (and(e, long(e))) { ",\ndied " long(e) } + set(d, LineParent(s)) + set(m, OthrParent(s)) + if (or(d, m)) { + ",\n" + if (male(s)) { "son of " } + elsif (female(s)) { "daughter of " } + else { "child of " } + } + if (d) { name(d) } + if (and(d, m)) { "\nand " } + if (m) { name(m) } + ".\n" +} + +/* + * ShowBOLLists - This debug routine shows the bottom of line persons as + * recorded in the BOLK, BOLG, and BOLR lists + */ + +proc ShowBOLLists () +{ + forlist(BOLK, k, n) { + set(g, getel(BOLG, n)) set(r, getel(BOLR, n)) + name(indi(k)) " " d(g) " " + d(r) " (" call ShowRel(r) ")\n" + } +} + +proc ShowCurLine () +{ + set(k, pop(CurK)) + set(p, indi(k)) + while (p) { + set(g, pop(CurG)) set(r, pop(CurR)) + name(p) " (" d(g) "," d(r) ") " + set(k, pop(CurK)) set(p, indi(k)) + } + "\n" +} + +/* ShowAncTable -- Debug routine which shows contents of AncT. */ + +proc ShowAncTable () +{ + forlist(AncL, k, n) { + set(e, lookup(AncT, k)) + set(p, indi(k)) + set(i, getel(e, 2)) + set(g, getel(e, 4)) + set(r, getel(e, 5)) + set(d, getel(e, 6)) + k " " name(p) " " d(i) " " + forlist (g, j, l) { d(getel(g, l)) " " } + forlist (r, j, l) { call ShowRel(getel(r, l)) " " } + forlist (d, c, l) { name(indi(c)) " " } + "\n" + } +} + +proc ShowRel (r) +{ + if (eq(r, 1)) { "s" } + if (gt(r, 1)) { + list(RelStack) + push(RelStack, neg(1)) + while (gt(r, 1)) { + set(m, mod(r, 2)) + set(r, div(r, 2)) + push(RelStack, m) + } + set(r, pop(RelStack)) + while (ne(r, neg(1))) { + if (r) { "m" } + else { "f" } + set(r, pop(RelStack)) + } + } +} + +/* inlist -- See if a string is in a list of strings */ + +func inlist (l, s) +{ + forlist(l, e, n) { + if (eqstr(e, s)) { return(1) } + } + return(0) +} + +func savekey (k) +{ + if (e, lookup(KeyT, k)) { return(e) } + set(k, save(k)) + insert(KeyT, k, k) + return(k) +} diff --git a/reports/altern.ll b/reports/altern.ll new file mode 100644 index 0000000..2a37b41 --- /dev/null +++ b/reports/altern.ll @@ -0,0 +1,78 @@ +/* + * @progname altern.ll + * @version 2.0 + * @author Rafal T. Prinke + * @category + * @output Text + * @description + * find the longest line of alternating male/female links + * + v.1.0 Rafal T. Prinke - 14 APR 1997 + v.2.0 Rafal T. Prinke - 16 NOV 1999 +*/ + +global(who) +global(was) +global(final) + +proc main() + +{ + set(final,0) + list(who) + table(was) + forfam(f, y) { + if(eq(nchildren,0)) { + if(husband(f)) { + call line(husband(f)) + insert(was, key(husband(f)), 1) + } + if(wife(f)) { + call line(wife(f)) + insert(was, key(wife(f)), 1) + } + } + } + +"The longest alternating ancestral lines are: \n\n" + + while(not(empty(who))) { + set(n, dequeue(who)) + set(count, 1) + d(count) ". " name(n, 0) "\n" + while(parents(n)) { + set(count, add(count, 1)) + if (eqstr(sex(n),"M")) { + set(n, mother(n)) + } + else { set(n, father(n)) } + d(count) ". " name(n, 0) "\n" + } + "\n" + } +} + + + +proc line (x) { + if(not(lookup(was,key(x)))) { + set(p, x) + set(count,1) + while(parents(x)) { + if (eqstr(sex(x),"M")) { + set(x, mother(x)) + } + else { set(x, father(x)) + } + set(count,add(count,1)) + } + if (eq(count, final)) { + enqueue(who, p) + } + if (gt(count, final)) { + list(who) + enqueue(who, p) + set(final, count) + } + } +} diff --git a/reports/anc2_ged.ll b/reports/anc2_ged.ll new file mode 100644 index 0000000..73c9ed6 --- /dev/null +++ b/reports/anc2_ged.ll @@ -0,0 +1,117 @@ +/* + * @progname anc2_ged.ll + * @version 1.0 + * @author Dennis Nicklaus + * @category + * @output GedCom + * @description + * make a gedcom file of the ancestors of a set of individuals + * + */ +proc main () +{ + indiset(a) + monthformat(4) + indiset(b) + getindi(i) + + while (i){ + addtoset(a, i, 0) + set(i,0) + getindimsg(i,"Enter next person to output GEDCOM ancestors of") + } + set(b,ancestorset(a)) + set(b,union(b,a)) + + call print_header() + gengedcom(b) + call sour_init() + call sour_addset(b) + call sour_ged() + + "0 TRLR\n" + +} + +proc print_header() +{ + "0 HEAD\n" + "1 SOUR Lifelines\n" + "1 DATE " stddate(gettoday()) nl() + "0 @SM1@ SUBM\n" + "1 NAME " getproperty("user.fullname") "\n" + "1 ADDR " getproperty("user.address") "\n" + "2 CONT " getproperty("user.email") "\n" +} +global(sour_list) +global(sour_table) + +proc sour_init() +{ + table(sour_table) + list(sour_list) +} +/* sour_addind() adds the sources referenced for this individual */ + +proc sour_addind(i) +{ + traverse(root(i), m, l) { + if (nestr("SOUR", tag(m))) { continue() } + set(v, value(m)) + if (eqstr("", v)) { continue() } + if(reference(v)) { + if (ne(0, lookup(sour_table, v))) { continue() } + set(v, save(v)) + insert(sour_table, v, 1) + enqueue(sour_list, v) + } + } +} + +proc sour_addset(s) +{ + forindiset (s, i, a, n) { + call sour_addind(i) + families(i, f, sp, m) { + call sour_addind(f) + } + } +} + +/* sour_ged() outputs the current source list in GEDCOM format */ + +proc sour_ged() +{ + table(other_table) + list(other_list) + + forlist(sour_list, k, n) { + set(r, dereference(k)) + traverse(r, s, l) { + d(l) + if (xref(s)) { " " xref(s) } + " " tag(s) + if (v, value(s)) { + " " v + if(reference(v)) { + if (ne(0, lookup(other_table, v))) { continue() } + if (ne(0, lookup(sour_table, v))) { continue() } + set(v, save(v)) + insert(other_table, v, 1) + enqueue(other_list, v) + } + } + "\n" + } + } + forlist(other_list, k, n) { + set(r, dereference(k)) + traverse(r, s, l) { + d(l) + if (xref(s)) { " " xref(s) } + " " tag(s) + if (v, value(s)) { " " v } + "\n" + } + } +} diff --git a/reports/ancestors2.ll b/reports/ancestors2.ll new file mode 100644 index 0000000..16497f5 --- /dev/null +++ b/reports/ancestors2.ll @@ -0,0 +1,123 @@ +/* + * @progname ancestors2.ll + * @version 2.0 + * @author Wetmore, Cliff Manis + * @category + * @output Text + * @description + * + * It will produce a report of all ancestors of a person, with + * sorted names as output, birth and death dates. + * + * ancestors2 + * + * Initial Code by Tom Wetmore, ttw@cbnewsl.att.com + * Modifications by Cliff Manis, this is a modification of the + * report "ancestors1". + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * and it has been modified many times since. + * + * It will produce a report of all ancestors of a person, with + * sorted names as output, birth and death dates. + * + * It will produce ASCII file output. + * + */ + +proc main () +{ + indiset(a) + monthformat(4) + indiset(b) + getindi(i) + addtoset(a, i, 0) + set(b,ancestorset(a)) + namesort(b) + "ANCESTORS OF -- " upper(name(i)) " (" key(i) ") " nl() nl() + forindiset(b, i, x, n) { + col(1) fullname(i,1,0,36) + col(38) key(i) + col(49) stddate(birth(i)) + col(64) stddate(death(i)) nl() + } +} + +/* Sample output of report + +ANCESTORS OF -- ALDA CLIFFORD MANIS (107) + +BARTH, Johann Ludwig 2243 1730 23 Jun 1770 +BIRD, Frances Amanda 377 8 Feb 1845 26 Dec 1898 +BIRD, Jacob 783 1760 +BIRD, John 551 11 Oct 1795 3 Jul 1889 +BIRD, Wife of Jacob 784 +BOWERS, Anderson 20 1803 +BOWERS, James 52 +BOWERS, Martha A. 9 14 Apr 1829 22 Jul 1899 +BOYD, Mary 55 1772 +BRADSHAW, Jennet 9723 21 May 1772 24 Jan 1824 +BRADSHAW, John F. 10033 Mar 1743 30 Sep 1818 +CANTER, Cordelia "Corda" F. 39 7 Dec 1869 18 Apr 1960 +CANTER, Henry B. 162 1820 +CANTER, James H. 80 1847 27 Dec 1937 +CARROLL, Joseph 12109 +CARROLL, Sarah 9967 +CLENDENIN, Agnes "Annie" 10034 May 1748 Aug 1823 +CLENDENIN, Isabella 10021 +CLENDENIN, John 10133 1704 1797 +CORBETT, James 896 +CORBETT, John 1122 +CORBETT, John Williams 607 +CORBETT, Mary Jane 386 9 Oct 1843 2 Nov 1918 +COWAN, Christopher Columbus 54 1765 +COWAN, Lurina Viney "Vina" 21 1808 +COWAN, Samuel 699 +COWAN, William 2250 +CROCKETT, Mary 771 1780 +EUDAILY, Betsy 608 +FOSTER, Martha "Patsy" 6906 1810 1870 +FOSTER, Thomas 6902 1780 +FOSTER, Wife of Thomas 6903 +FRANCIS, David 770 1769 1850 +FRANCIS, Edward 965 1745 1800 +FRANCIS, Mary Elizabeth 549 15 1810 +FRANKLIN, Nancy 9703 +GRESHAMS, Polly 897 +HOUSTON, Janet "Jean" 10134 1797 +HOUSTON, John 13239 6 Dec 1769 +MANES, Fuller Ruben 45 19 Nov 1902 20 Jun 1980 +MANES, Samuel P. 1 1780 Jan 1831 +MANES, William Bowers 16 6 Jan 1868 5 May 1933 +MANES, William Thomas 8 26 Nov 1828 2 Mar 1907 +MANESS, John 3643 1770 +MANIS, Amos 548 1805 1840 +MANIS, Edith Alberta 105 8 Apr 1914 18 Jun 1992 +MANIS, Thomas D.A.F.S. 376 1 Feb 1839 25 Sep 1919 +MANIS, William Loyd 220 5 Sep 1872 15 Mar 1946 +MCELWEE, Jane 10123 +MCMURTRY, Anna 2240 9 Feb 1849 +NEWMAN, Aaron 9632 18 Jan 1802 24 Jul 1884 +NEWMAN, John 9702 11 Dec 1782 8 Oct 1865 +NEWMAN, John Franklin 9617 4 May 1830 18 Sep 1921 +NEWMAN, Jonathan 9966 25 Dec 1730 17 May 1817 +NEWMAN, Lillie Caroline "Carolyn" 221 13 Jun 1881 29 Sep 1949 +RANKIN, Alexander 10178 +RANKIN, John 10122 1690 1749 +RANKIN, Sinea 9633 7 May 1806 23 Mar 1833 +RANKIN, Thomas 10020 1724 1812 +RANKIN, Thomas B. 9722 3 Mar 1764 3 Aug 1821 +RANKIN, William 10165 +REED, Elizabeth 1123 +SHRADER, Elizabeth 552 1799 19 Feb 1885 +SHRADER, G. Christopher 786 1776 +STEWART, George 13237 +STEWART, Martha 13238 +WEBB, Jesse 2239 1766 25 Mar 1848 +WEBB, Mary 787 1789 +WHITEHORN, James 2824 1860 +WHITEHORN, Martha Marie 81 22 Dec 1846 + + end of report sample */ diff --git a/reports/anniver.ll b/reports/anniver.ll new file mode 100644 index 0000000..472cbb9 --- /dev/null +++ b/reports/anniver.ll @@ -0,0 +1,642 @@ +/* + * @progname anniver.ll + * @version 4.0 + * @author Stephen Dum + * @category + * @output HTML + * @description + +Generate calendar of birth, death, marriage events arranged by the month +and day that they occurred. Generates a top level index calendar, with actual +events stored in a separate html file for each month. +Some properties must be set in your lifelines configuration file for this +report to run, see comments at beginning of the report for details. + +Warning, this report requires lifelines version 3.0.50 or later. + + by Stephen Dum (stephen.dum@verizon.net) + Version 1 March 2003 + Version 2 November 2005 Support privitizing data + Version 3 December 2005 Do html char set encoding + Version 4 June 2006 incorporated mods by Dave Eaton (dwe@arde.com) May 2006 + +This program was inspired by similar efforts by Mitch Blank (mitch@ctrpnt.com) +but without ever seeing the code he used to do a similar thing. + +Originally this program used getel and setel to access the dates and events +lists and to sort them. It ran about 400 seconds on 11850 element lists. +Conversations between myself and Perry Rapp about sorting the large lists +created by this program led to the sort and rsort functions being added to +the report language. This program uses them. Also care was taken to avoid +using getel or setel functions on the dates and events lists as random access +to very large lists is very slow. With these changes run time dropped to 10 +seconds. + +Before using, there are a few properties that need to be customized for your +own environment so add them to your .linesrc ( or for windows lines.cfg) file. +You can also set them on the command line (like -Ianniver.htmldir=/tmp/foo) +The properties that are looked up are: + user.fullname -- name of the database owner + user.email -- email address of the db owner + anniver.htmldir -- path to the directory to store results in + e.g. /home/joe/genealogy/html + (program expects a subdir in this directory with the name + of the database in it.) + anniver.backgroundimage -- path to the background image, + no image if not defined. + e.g. ../../image/crink.jpg + this places image at the same level as /home/joe/genealogy/html + privatization: This report respects 2 levels of privatization + 1. if a record "RESN confidential" exists on an individual they are + skipped (as this report is designed to be shared, this seems + like a reasonable default) + 2. skip anyone estimated to be living + + History. + Version 2 Add code to allow respecting privatized data. + Version 3 switch from baptism() to get_baptism() for wider coverage + use translation tables to convert data to properly + escaped html. This is very codeset dependent. + Version 4 added changes by Dave Eaton (dwe@arde.com) + Added "firstyear" that events may be on the calendar + Added "includedeath" check to drop deaths if those are not desired + Added ability to generate report for descendants of more than one + individual + Added ability to generate report only for living people + (omitting confidential if desired) +*/ + +/* customization globals */ +char_encoding("ASCII") +option("explicitvars") + +global(base_filename) /* where to store the results */ +global(background) /* path of background image relative to final html + * location, or "" */ +global(hi_bg_color) /* highlighted year background color */ +global(lo_bg_color) /* non-highlighted year background color */ + +global(db_owner) /* name of database owner - from config file */ +global(owner_email) /* email of database owner - from config file */ +global(justliving) /* should we generate a report only for living people? */ +global(privatize) /* should we privatize the data + * 0 = display all data + * 1 = skip confidential records + * 2 = skip confidential and living + */ +global(withkey) /* should we include key's in the output */ +global(cutoff_year) /* 100 years before today */ + /* birth >= cutoff_year is about 101 years, + * and we consider person living */ + +global(firstyear) /* earliest year for which entries should be included */ +global(includedeath) /* if set, then include the death events on the calendar */ + +global(month_name) /* names of the months */ +global(events) /* list of events to print */ +global(dates) /* list of dates of the events */ +global(keynames) /* name(s) of the key individuals for this report */ + +proc main () +{ + /* initialization of globals */ + + set(hi_bg_color,"\"#ddb99f\"") + set(lo_bg_color,"\"#e5d3c5\"") + + set(db_owner, getproperty("user.fullname")) + set(owner_email, concat("mailto:",getproperty("user.email"))) + set(background,getproperty("anniver.backgroundimage")) + set(base_filename,concat(getproperty("anniver.htmldir"),"/",database(),"/")) + if (not(test("d",base_filename))) { + print("Error, property anniver.htmldir=",base_filename, + ", is not a directory,aborting\n") + print("Please read comments at beginning of report about setting properties\n") + return() + } + + /* other globals*/ + list(month_name) + enqueue(month_name,"January") + enqueue(month_name,"February") + enqueue(month_name,"March") + enqueue(month_name,"April") + enqueue(month_name,"May") + enqueue(month_name,"June") + enqueue(month_name,"July") + enqueue(month_name,"August") + enqueue(month_name,"September") + enqueue(month_name,"October") + enqueue(month_name,"November") + enqueue(month_name,"December") + + extractdate(gettoday(),day,mon,cutoff_year) + decr(cutoff_year,100) + set(cs,getproperty("codeset")) + if (eqstr(cs,"UTF-8")) { + set(srccs,"UTF-8") + set(dstcs,"UTF-8//html") + } elsif (eqstr(cs,"ISO-8859-15")) { + set(srccs,"ISO-8859-15//html") + set(dstcs,"UTF-8") + } else { + print("\nDatabase codeset ",cs," not supported, exiting\n") + } + + /* end of initialization of globals */ + + getint(justliving,"Enter 1 to include only living people, 0 otherwise") + if (justliving) { + /* Default the choices which conflict with "justliving" */ + set(includedeath,0) + /* We want living people, so see if we also want confidental */ + getint(noconfidential,"Enter 1 to omit confidential living people, 0 otherwise") + if (noconfidential) { + set(privatize,1) + } else { + set(privatize,0) + } + } else { + getint(privatize,"\nPrivatization: 0 print all data; 1 skip confidential records; 2 skip confidential and living") + getint(includedeath,"Enter 1 to include deaths on calendar, 0 otherwise") + } + getint(withkey,"Enter 1 to include keys, 0 otherwise") + getint(firstyear,"Enter oldest year to be on calendar, 0 for no limit") + getindi(person,"Enter person for whom to find descendants (return for all)") + indiset(thisgen) + indiset(allgen) + list(events) + list(dates) + list(keynames) + set(firstpass,1) + /* if a person is entered, the generated list of people include + * person and spouse, and all the children of either + * and then recursively the people, their spouses and all the children + * thereof + */ + if (person) { + while (person) { + addtoset(thisgen, person, 0) + addtoset(allgen, person, 0) + print("Computing descendants of ", name(person), " ") + enqueue(keynames,concat(name(person))) + set(thisgensize,1) + set(gen,neg(1)) + while(thisgensize) { + set(gen,add(gen,1)) + print("adding ",d(thisgensize)," individuals for generation ",d(gen),"\n") + indiset(spouse) + set(spouse,spouseset(thisgen)) + set(thisgen,childset(union(thisgen,spouse))) + set(allgen,union(allgen,spouse)) + set(allgen,union(allgen,thisgen)) + set(thisgensize,length(thisgen)) + /* the following check prevents looping if the + * database has been corrupted and a parent is listed + * as a child of that parent, and diagnoses the fault + */ + if (eq(length(intersect(allgen,thisgen)),thisgensize)) { + set(thisgensize,0) + print("Warning child is listed as its own parent\n") + forindiset(thisgen,indi,val,i) { + print (name(indi)," ") + } + print("\n") + } + } + if (firstpass) { + print ("Total of ") + set(firstpass,0) + } else { + print ("New total of ") + } + print (d(length(allgen))," individuals",nl()) + getindi(person,"Enter next person for whom to find descendants") + } + /* now generate list of events */ + forindiset(allgen,indi,val,i) { + if (not(mod(i,100))) { + print(".") + } + call add_indi(indi) + } + print("\n") + } else { + print("Traversing all individuals ") + forindi (indi, val) { + if (not(mod(val,100))) { + print(".") + } + call add_indi(indi) + set(max,val) + } + print (nl(), "Total of ",d(max)," individuals",nl()) + } + print( d(length(dates))," events generated",nl()) + + print("sorting data") + rsort(events,dates) + + /* Now print out all the data for each month + */ + print(nl()) + + list(daymask) + set(dm_day,1) /* last day dealt with */ + set(mask,1) /* mask for this day */ + set(lastday,-1) + set(lastmonth,-1) + set(in_day,0) + while(length(dates)) { + set(val,pop(dates)) + set(event,pop(events)) + set(month,div(val,1000000)) + set(year,mod(val,1000000)) + set(day,div(year,10000)) + set(year,mod(val,10000)) + + if (ne(lastmonth,month)) { + if (ne(lastmonth,-1)) { + if (in_day) { + "\n" + } + call write_tail() + setel(daymask,lastmonth,dm) + } + set(lastday,-1) + set(dm,0) + set(dm_day,1) + set(mask,1) + set(m_name, getel(month_name,month)) + call openfile(lower(m_name),concat(m_name," Anniversary Dates")) + set(lastmonth,month) + } + if (ne(lastday,day)) { + if (ne(lastday,-1)) { + if (in_day) { + "\n" + } + } + if (lastday,day) { + while(lt(dm_day,day)) { + incr(dm_day) + set(mask,add(mask,mask)) + } + set(dm,add(dm,mask)) + "

" m_name " " d(day) "\n" + "\n" + } else { + /* don't know day, so just generic month */ + "

" m_name "\n" + "

\n" + } + set(in_day,1) + } + "\n" nl() + } + if (ne(lastmonth,-1)) { + if (in_day) { + "
" + if (year) { + d(year) + } else { + " " + } + "" nl() + "" + if (srccs) { + convertcode(event,srccs,dstcs) + } else { + event + } + "
\n" + } + call write_tail() + setel(daymask,lastmonth,dm) + } + + /* Now print out the calendar page indexing the individual month files */ + + /* debug print out month masks + set(i,1) + while(le(i,12)) { + set(dm,getel(daymask,i)) + print( "Month ",d(i)," ") + while(dm) { + print( d(mod(dm,2))) + set(dm,div(dm,2)) + } + print(nl()) + incr(i) + } + */ + + call openfile("annver","Calendar of Anniversary Dates") + "

This calendar of anniversary dates lists events" nl() + if (firstyear) { + "since " d(firstyear) nl() + } + if (justliving) { + "of living people" nl() + } + "arranged by the" nl() + "month and day that they occurred." nl() + if (not(includedeath)) { + "" nl() + } + if (length(keynames)) { + "
Events listed are for descendants of:" nl() + while(length(keynames)) { + set(nxtname,pop(keynames)) + set(nameout,length(keynames)) + nxtname + if (nameout) { + "," + } else { + "." + } + nl() + } + } + "

" nl() + "

Click on the month name or any highlighted day to see the events" nl() + "for that time.

" nl() + "
" nl() + "" nl() + + /* The calendar is arranged with 4 months across + * so we need to process 4 months at a time */ + list(month_len) + enqueue(month_len,31) + enqueue(month_len,29) + enqueue(month_len,31) + enqueue(month_len,30) + enqueue(month_len,31) + enqueue(month_len,30) + enqueue(month_len,31) + enqueue(month_len,31) + enqueue(month_len,30) + enqueue(month_len,31) + enqueue(month_len,30) + enqueue(month_len,31) + list(inds) + set(i,0) /* i iterates over 3 chunks of 4 months */ + while(le(i,2)) { + /* generate the headings */ + "" nl() + set(j,1) + while(le(j,4)) { + "" nl() + "" nl() + incr(j) + } + "" nl() + + /* now compute the starting indexes for each month */ + + set(wk,0) + while(le(wk,4)) { /* for each of the 5 weeks in the months */ + + "" nl() /* start a row in the table */ + set(k,0) + while(le(k,3)) { /* for each of the 4 months in this line */ + set(mon,add(mul(i,4),k,1)) + set(m_name,getel(month_name,mon)) + set(m_len,getel(month_len,mon)) + set(ind,getel(daymask,mon)) + set(day,add(mul(wk,7),1)) + + set(l,1) + while(le(l,7)) { /* for each of the 7 days in a week */ + + /* do a day */ + if (gt(day,m_len)) { + /* empty square */ + "" nl() + } elsif(mod(ind,2)) { + /* linked square */ + "" nl() + } else { + /* output transparent number */ + "" nl() + } + incr(day) + incr(l) + set(ind,div(ind,2)) + } + if (ne(k,3)) { /* add separator between months */ + "" nl() + } + setel(daymask,mon,ind) /* save away latest day mask */ + incr(k) + } + "" nl() + incr(wk) + } + "" nl() + incr(i) + } + "
" nl() + set(m_name,getel(month_name,add(mul(i,4),j))) + "" m_name "" nl() + "
" + d(day) "" nl() + "" + d(day) "
\n" + call write_tail() +} + +/* openfile(filename, title_to_use) + * open output file and write out header information + */ +proc openfile(name,title) { + set(filename, concat(base_filename,name,".html")) + print("Writing ", filename, "\n") + newfile(filename, 0) + + "\n" + "\n" + "\n\n" + "\n" + " " title " \n" + "\n" + "\n" + if (eqstr(background,"")) { + "\n" + } else { + "\n" + } + "

" title "

\n
\n" +} + +/* write_tail() + * write out common footer information for file. + */ +proc write_tail() { + "
\n" + monthformat(6) + "This page was created " stddate(gettoday()) + "
\n" + "Database maintained by " + "\n" + db_owner + "
\n" + "" nl() + + "\n" +} + +/* add_indi(individual) + * check a given individual and see if there are any events to add + * at the moment we do birth, death and marriage events. + * Additional events can be added here + */ +proc add_indi(indi) { + set(birth_type,0) + if (birth,birth(indi)) { + set(birth,get_date(birth)) + set(birth_type," born") + } elsif (birth, get_baptism(indi)) { + set(birth,get_date(birth)) + set(birth_type," baptized") + } + set(death_type,0) + if (death,death(indi)) { + set(death,get_date(death)) + set(death_type," died") + } elsif (death, burial(indi)) { + set(death,get_date(death)) + set(death_type," buried") + } + /* skip confidential records and living people */ + if (privatize) { + if (confidential(indi)) { return() } + + /* living - birth, no death, and birth < 101 years ago */ + if (and(ge(privatize,2),birth,not(death))) { + if (ge(mod(birth,10000),cutoff_year)) { return()} + } + } + if (birth) { + /* Make certain that if we only want living people that this is + (or at least may be) */ + if (not(or(and(justliving,death),and(justliving,lt(mod(birth,10000),cutoff_year))))) { + if (withkey) { + enqueue(events,concat(name(indi),"(",key(indi),")",birth_type)) + } else { + enqueue(events,concat(name(indi),birth_type)) + } + enqueue(dates,birth) + } + } + if (and(includedeath,death)) { + if (withkey) { + enqueue(events,concat(name(indi),"(",key(indi),")",death_type)) + } else { + enqueue(events,concat(name(indi),death_type)) + } + enqueue(dates,death) + } + + families(indi,famly, spouse, cnt) { + /* skip confidential families */ + if (confidential(famly)) { continue() } + if (and(privatize,spouse)) { + if (confidential(spouse)) { continue() } + } + if (justliving) { + /* make sure the person is living: no death, birth and + birth < 101 years ago */ + /* Nope, we know they have died */ + if (death) { return() } + if (birth) { + /* Nope, estimated they would be too old now */ + if (lt(mod(birth,10000),cutoff_year)) { return() } + } + } + /* living - birth, no death, and birth < 101 years ago */ + if (ge(privatize,2)) { + if (and(birth(spouse),not(death(spouse)))) { + if (ge(mod(get_date(birth(spouse)),10000),cutoff_year)) { continue()} + } + } + /* to avoid duplication, only enter data + * if indi is male, or there is no spouse + */ + if (or(male(indi),not(spouse))) { + fornodes(fnode(famly), node) { + if(eqstr(tag(node),"MARR")) { + if (spouse) { + set(names,concat(name(indi)," and ",name(spouse))) + set(keys,concat("(",key(indi),",",key(spouse),")")) + } else { + set(names,name(indi)) + set(keys,concat("(",key(indi),")")) + } + set(marr,get_date(node)) + if (marr) { + /* Make sure date is plausible for living or that we don't care */ + if (or(not(justliving),ge(mod(marr,10000),cutoff_year))) { + if (withkey) { + enqueue(events,concat(names,keys," married")) + } else { + enqueue(events,concat(names," married")) + } + enqueue(dates,marr) + } + } + } + } + } + } +} + +/* get_date(node) + * if event node has a date associated with it return it encoded as + * (mon * 100 + day) * 10000 + yr + * These values facilitate sorting. + */ +func get_date(node) +{ + extractdate(node,day,mon,yr) + if (mon) { + if (ge(yr,firstyear)) { + return(add(mul(add(mul(mon,100),day),10000),yr)) + } else { + /* Nope, this one should not be on the calendar */ + return(0) + } + } + return(0) +} + +func confidential(n) +{ + fornodes(n,node) { + if (eqstr(tag(node),"RESN")) { + if (eqstr(value(node),"confidential")) { + return(1) + } + } + } + return(0) +} +func get_baptism(ind) +{ + fornodes(ind,node) { + if (index(" BAPM BAPL CHR CHRA ",concat(" ",upper(tag(node))," "),1)) { + return(node) + } + } + return(0) +} diff --git a/reports/bday_cover.ll b/reports/bday_cover.ll new file mode 100644 index 0000000..548d9a5 --- /dev/null +++ b/reports/bday_cover.ll @@ -0,0 +1,211 @@ +/* + * @progname bday_cover.ll + * @version 1 of 1994-11-02 + * @author Andrew Deacon + * @category + * @output Text + * @description + +A novelty report that lists on which days of the year people were born +and how many people share the same birthday. All valid birthdays +are considered. A valid birthday is one where the extracted birthday, +performed using extractdate(), has a month in the range 1-12 and a day +within that month. + +This program works only with LifeLines. + +The output is not sorted. The following are examples of +how to sort the output using UNIX sort: +# sort by frequency +sort +2n +0M bday.out +sort +2nr +0M bday.out +# sort by month +sort -M bday.out + +*/ + + global(julian) + global(daysinmonth) + +proc main () +{ + table(day_counts) + list(day_list) + + /* Formats/modes for date functions */ + monthformat(3) dayformat(1) dateformat(1) + set(julian, 0) /* change to use Julian dates */ + + /* Initialize counters */ + set(totaldays, 0) set(totalmonths, 0) set(totalbirths, 0) + + /* Iterate over whole database */ + forindi (indi, num) { + + /* if birthday recorded for individual */ + if (bth, birth(indi)) { + + /* Extract birthday for individual */ + extractdate(bth, birthday, birthmonth, birthyear) + call get_days_in_month(birthday, birthmonth, birthyear) + + /* if valid birthday */ + if (and(gt(birthday, 0), le(birthday, daysinmonth))) { + + /* Extract the month name and day */ + set(bday, concat(substring(stddate(birth(indi)),1,6)," ")) + + /* if existing birthday found - just increment */ + if(nmatch, lookup(day_counts, bday)) { + set(nmatch, add(nmatch, 1)) + } + /* else new birthday - insert */ + else { + set(totaldays, add(totaldays,1)) + enqueue(day_list, bday) + set(nmatch, 1) + } + insert(day_counts, bday, nmatch) + set(totalbirths, add(totalbirths,1)) + + /* Extract the month name */ + set(bmon, concat(substring(stddate(birth(indi)),1,4),"**")) + + /* if existing birth month found - just increment */ + if(nmatch, lookup(day_counts, bmon)) { + set(nmatch, add(nmatch, 1)) + } + /* else new birth month - insert */ + else { + set(totalmonths, add(totalmonths,1)) + enqueue(day_list, bmon) + set(nmatch, 1) + } + insert(day_counts, bmon, nmatch) + } + } + } + + /* Write report to file - use Unix sort to sort output! */ + "Distribution of birth days\n\n" + "Month & day Frequency\n\n" + forlist(day_list, bday, num) { + bday + set(nmatch, lookup(day_counts, bday)) + col(sub(25, strlen(d(nmatch)))) + d(nmatch) "\n" + } + "Total birthdays in database: " d(totalbirths) "\n" + "Total days (out of 366) : " d(totaldays) "\n" + "Total months (out of 12) : " d(totalmonths) "\n" +} + +proc get_days_in_month(birthday, birthmonth, birthyear) +{ + /* code from a routine in "dates" by Jim Eggert */ + /* procedure sets global variable daysinmonth */ + set(daysinmonth, 31) + if (or(le(birthmonth, 0), gt(birthmonth, 12))) + { set(daysinmonth, 0) } + elsif (or(or(eq(birthmonth, 9), eq(birthmonth, 4)), + or(eq(birthmonth, 6), eq(birthmonth, 11)))) + { set(daysinmonth, 30) } + elsif (eq(birthmonth, 2)) { + if (and(eq(mod(birthyear, 4), 0), + or(julian, or(ne(mod(birthyear, 100), 0), + eq(mod(birthyear, 400), 0))))) + { set(daysinmonth, 29) } + else + { set(daysinmonth, 28) } + } + else + { set(daysinmonth, 31) } +} + +/* + +Sample output: + +sorted by sort +2nr +0M sample.output and then edited + +Distribution of birthdays + +Total birthdays in database: 374 +Total days (out of 366) : 236 +Total months (out of 12) : 12 + +Month & day Frequency + +AUG 12 6 +SEP 12 5 +FEB 10 4 +MAR 03 4 +APR 12 4 +JUN 17 4 +JAN 06 3 +JAN 18 3 +JAN 29 3 +........ +*/ + +/* +Below is a simple C program hack to check if your values +are similar to those generated randomly by the program. +Extract the program from these comment to compile and execute. +Change the RSEED to do different tests; change the ITERATIONS +to vary accuracy. Can also change the NUM_DAYS_REQUIRED +to the value obtained for your database and check if the people +required is similar. + +#define RSEED 1576 +#define NUM_DAYS 365 +#define NUM_DAYS_REQUIRED NUM_DAYS +#define ITERATIONS 2000 + +#define FALSE 0 +#define TRUE 1 + +static int days[NUM_DAYS]; +static int num_got; +static int running_total; + + +int get_day() { + return rand() % NUM_DAYS; +} + +do_it() { + int i; + int j; + int r; + + for (i = 0; i < NUM_DAYS; i++) { + days[i] = FALSE; + } + num_got = 0; + i = 0; + + while (num_got < NUM_DAYS_REQUIRED) { + i++; + r = get_day(); + if (!days[r]) { + days[r] = TRUE; + num_got++; + } + } + printf("Required %d people to cover %d days.\n",i, NUM_DAYS_REQUIRED); + running_total = running_total + i; +} + +main() { + int i; + + running_total = 0; + srand(RSEED); + for (i = 0; i < ITERATIONS; i++) { + do_it(); + } + printf("Average was %d.\n",(int)(running_total/ITERATIONS)); +} + +*/ diff --git a/reports/bias.ll b/reports/bias.ll new file mode 100644 index 0000000..87d7540 --- /dev/null +++ b/reports/bias.ll @@ -0,0 +1,247 @@ +/* + * @progname bias.ll + * @version 1.4 + * @author Chandler + * @category + * @output Text + * @description + +Ever notice that certain families seem to have all boys or all girls? +Sometimes five or six in a row of all the same sex? Is this a mere +statistical fluctuation, or is something special happening? +This program gives statistics for male vs female births. + +Compute sex bias based on previous births + +Version 1.3 - 1993 Aug 23 - John F. Chandler +Version 1.4 - 1994 Jul 19 (requires LL 3.0 or higher) + +Ever notice that certain families seem to have all boys or all girls? +Sometimes five or six in a row of all the same sex? Is this a mere +statistical fluctuation, or is something special happening? + +This program gives statistics for male vs female births. First, it +tabulates the number of males and females next born after each possible +proportion of previous births in the same family. In particular, it +gives the sex tally of first-borns (where the proportion of previous +births is 0 males and 0 females), then the tally for second-borns where +the first child was a female (0+1), and so on. Any combination that +doesn't actually occur in the database is skipped in the report (for +example, if no family is found with more than 3 sons, the tallies for +3+0, 3+1, and so on would all show a total of 0 males, and there would +be no tallies listed for 4+0, 4+1, and so on). + +Children of unknown sex are not included in these statistics. + +The program next prints out the relative excess of male births +(typically a positive value) over the nominally expected 50%. For many +files, there is a tendency to include incomplete families with only one +known child; for this reason, "only" children are excluded from these +statistics. Also, the male excess is computed for two different subsets +of the children: (A) the set of all children not born last, and (B) the +set of all children not born first. For both of these, there is also a +measure of the variability of the sex ratio to put the percentages in +perspective. In addition, the program prints out the correlation +between the sex ratio for children already born into a family and the +likelihood of getting a male (or female) as the *next* child. If the +sample is unbiased, and if the sex of each child is truly random, this +correlation should be 0. + +It also tallies the fraction of births matching the sex of the previous +birth in the same family (again, excluding any children of unknown sex). +These results are printed out for a succession of increasingly restricted +cases: first, for all births of non-first-borns; then, for births preceded +by two-in-a-row of the same sex; then, for three-in-a-row; and so on. + +Bug: combinations with more than 9 sons or more than 9 daughters are not +listed properly. + +This program works only with LifeLines. + +*/ + +global(maxcount) /* maximum attained runcount */ +global(nextsex) /* sex of next offspring in family */ +global(prevsex) /* sex of previous offspring in family */ +global(runcount) /* number of offspring so far in family */ + +/* Square Root function. */ +func sqrt(x) { + set(sqrtval,0) + if(gt(x,0)) { + set(sqrtval,1) + set(approx,1) + set(y,4096) + while(le(y,x)) { /* coarse grid */ + set(approx,y) + set(sqrtval,mul(sqrtval,64)) + set(y,mul(y,4096)) + } + set(y,mul(approx,4)) + while(le(y,x)) { /* fine grid */ + set(approx,y) + set(sqrtval,mul(sqrtval,2)) + set(y,mul(y,4)) + } + set(count,0) + while(and(ne(y,sqrtval),lt(count,9))) { + set(y,div(x,sqrtval)) + set(sqrtval,div(add(y,sqrtval),2)) + set(count,add(1,count)) + } + } + return(sqrtval) +} + +proc accstep(list) { + set(x,1) + while(le(x,runcount)) { + setel(list,x,add(1,getel(list,x))) + set(x,add(1,x)) + } +} + +proc accum(samsex,difsex) { + if(gt(runcount,0)) { + if(strcmp(nextsex,prevsex)) { + call accstep(difsex) + set(runcount,0) + } else { call accstep(samsex) } + } + set(prevsex,nextsex) + set(runcount,add(1,runcount)) + if(gt(runcount,maxcount)) {set(maxcount,runcount)} +} + +proc main () +{ + +list(males) +list(fems) +list(samsex) +list(difsex) + +set(totmales,0) +set(totfems,0) +set(onlymales,0) +set(onlyfems,0) + +forfam (family, num) { + set(count,0) + set(runcount,0) + children(family,child,fnum) { + set(nextsex,sex(child)) + if(not(strcmp(nextsex,"M"))) { + call accum(samsex,difsex) + if(gt(count,0)) { + set(totmales,add(1,totmales)) + setel(males,count,add(1,getel(males,count))) + } else {set(onlymales,add(1,onlymales))} + set(count,add(count,10)) + } + elsif(not(strcmp(nextsex,"F"))) { + call accum(samsex,difsex) + if(gt(count,0)) { + set(totfems,add(1,totfems)) + setel(fems,count,add(1,getel(fems,count))) + } else {set(onlyfems,add(1,onlyfems))} + if(gt(9,mod(count,10))) {set(count,add(count,1))} + else { print("More than 9 daughters\n") } + } + } +} + +/* Initialize statistics */ +set(tot,add(totmales,totfems)) +set(count,1) +set(nsample,0) +set(sumnfract,0) +set(sumpfract,0) +set(sumsqnfract,0) +set(sumsqpfract,0) +set(prodfract,0) +set(nrecs,0) + +"Previous\nbirth Next\nrecord birth\nMF M F\n" +"00" col(sub(13,strlen(d(onlymales)))) d(onlymales) +col(sub(20,strlen(d(onlyfems)))) d(onlyfems) " (excluded from statistics)\n\n" + +while(lt(count,100)) { + set(nmales,getel(males,count)) + set(nfems,getel(fems,count)) + if(or(nmales,nfems)) { + set(nrecs,add(1,nrecs)) + if(lt(count,10)) { "0" } + d(count) col(sub(13,strlen(d(nmales)))) d(nmales) + col(sub(20,strlen(d(nfems)))) d(nfems) "\n" + set(nsample,add(nsample,1)) + set(pboys,div(count,10)) + set(pgirls,mod(count,10)) + set(weight,add(nmales,nfems)) + set(p,add(pboys,pgirls)) + +/* scales: pf-100, sqpf-10000, nf-100, sqnf-10000, prod-10000 + i.e., express fractions as percent + This makes integer arithmetic acceptable. + Note that pfract is too small, on average, by 0.5, etc. */ + + set(pfract,div(mul(100,sub(pboys,pgirls)),p)) + set(wtpfr,mul(weight,pfract)) + set(sumpfract,add(sumpfract,wtpfr)) + set(sumsqpfract,add(sumsqpfract,mul(pfract,wtpfr))) + set(wtnfr,mul(100,sub(nmales,nfems))) + set(nfract,div(wtnfr,weight)) +/* set(sumnfract,add(sumnfract,wtnfr)) -- use grand difference */ + set(sumsqnfract,add(sumsqnfract,mul(nfract,wtnfr))) + set(prodfract,add(prodfract,mul(wtnfr,pfract))) + } + set(count, add(count,1)) +} + +"Total:" col(sub(13,strlen(d(totmales)))) d(totmales) +col(sub(20,strlen(d(totfems)))) d(totfems) "\n" +d(nrecs) " birth combinations found\n" +d(tot) " 'next' individuals (excluding firstborns)\n\n" + +/* Make approximate corrections for roundoff errors */ +set(sqcorr,mul(50,sub(totmales,totfems))) +set(sumnfract,mul(100,sub(totmales,totfems))) +set(sumsqnfract,add(sumsqnfract,sqcorr)) +set(procfract,add(prodfract,sqcorr)) +set(sumpfract,add(sumpfract,div(tot,2))) +set(sumsqpfract,sub(add(sumsqpfract,sumpfract),div(tot,3))) + +set(sumsqpfract,sub(sumsqpfract,div(mul(sumpfract,sumpfract),tot))) +set(sumsqnfract,sub(sumsqnfract,div(mul(sumnfract,sumnfract),tot))) +set(prodfract,sub(prodfract,div(mul(sumpfract,sumnfract),tot))) +set(rssp,sqrt(sumsqpfract)) +set(rssn,sqrt(sumsqnfract)) +set(correl,div(mul(div(prodfract,rssp),100),rssn)) +set(rmsp,sqrt(div(sumsqpfract,tot))) +set(rmsn,sqrt(div(sumsqnfract,tot))) + +"Male excess of previous births= " d(div(sumpfract,tot)) "% +/- " d(rmsp) "%\n" +"Male excess of next births = " d(div(sumnfract,tot)) "% +/- " d(rmsn) "%\n" +"Correlation between previous and next = " d(correl) "%\n" + +set(count,1) +"\nFraction of births that match (in sex) a run of previous births in the" +"\nsame family. Children of unknown sex ignored in this tabulation.\n" +"\nRun" col(sub(13,5)) "Total" col(sub(25,9)) "Matching" +"\nLength" col(sub(13,5)) "Cases" col(sub(23,5)) "Cases" col(sub(29,1)) "%\n" + +while(le(count,maxcount)) { + set(samesex,getel(samsex,count)) + set(diffsex,getel(difsex,count)) + set(allsex,add(diffsex,samesex)) + if(gt(allsex,0)) { + d(count) col(sub(13,strlen(d(allsex)))) d(allsex) + col(sub(23,strlen(d(samesex)))) d(samesex) + set(percent,d(div(mul(100,samesex),allsex))) + col(sub(29,strlen(percent))) percent "\n" + } + set(count,add(1,count)) + set(birth,"births") +} + +} diff --git a/reports/bib2html.c b/reports/bib2html.c new file mode 100644 index 0000000..a25f6ec --- /dev/null +++ b/reports/bib2html.c @@ -0,0 +1,57 @@ +#include +/* bib2html.c. By Dennis Nicklaus nicklaus@fnal.gov, July 1998. + Converts the bib.tex bibliography file output by the book-latex lifelines report + into an HTML file, which is suitable for use as the bibliography file + referenced by the HTML output of the html.dn report. + + Compile this simply as + cc -o bib2html bib2html.c + Then run it as a filter (assuming your file/database name is "dad"): + bib2html < dad-bib.tex > dadbib.html + + + Things will be a lot nicer if you first sort your bib.tex file by source + number, something like: + sort -n -t S -k 2 < dad-bib.tex > bibsort + and then run it (bibsort) through bib2html + + This simple filter is by no means completely robust. You might have things + in your bibliography that will confuse it. (Other LaTex commands, e.g.) + It can handle {\em text} constructs, but that is about all. + Ya' get what ya' pay for, I guess. +*/ + + +main() +{ + char c,word[80],*cptr; + + printf("\n
\n"); + while ((c=getchar()) != EOF){ + if (c== '\\'){ + c=getchar(); + if (c== 'b'){ /* then it is a new bibitem */ + while ((c=getchar()) != '{'); /* go to bracket opening bibnumber */ + cptr = word; + while ((c=getchar()) != '}'){ + *cptr =c; + cptr++; + } + *cptr = '\0';/* end of bibitem name/number */ + printf("\n
%s ",word,word); + } + else{ + if (c== 'e'){ /* then it had better be \em */ + c=getchar(); + printf(" "); + } + } + } + else if (c == '}') printf(""); + else if (c == '{'); /* ignore it */ + else putchar(c); + } + printf("
\n"); +} + + diff --git a/reports/bkdes16-1.ll b/reports/bkdes16-1.ll new file mode 100644 index 0000000..02f8243 --- /dev/null +++ b/reports/bkdes16-1.ll @@ -0,0 +1,62 @@ +/* + * @progname bkdes16-1.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output Text + * @description + * + * It will produce a report of all descendents of a person, + * and is presently designed for 16 pitch, HP laserjet III. + * This report produces an ASCII file, in output format. + * + * bkdes16-1 + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * Modifications by Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * and it has been modified many times since. + * + */ + +proc main () +{ + set (nl,nl()) + getindi(indi) + col(10) "Report by: Cliff Manis MANIS / MANES Family History P. O. Box 33937 San Antonio, TX 78265-3937 " + nl() + col(10) "Phone: 1-512-654-9912" + nl() + col(10) "Date: 27 Jun 1992" + nl() nl() + col(10)"DESCENDANTS OF: " name(indi) nl() nl() + call pout(0, indi) +} +proc pout(gen, indi) +{ + col(10) print(name(indi)) print(nl()) + set(ndots, 0) + while (lt(ndots, gen)) {". " set(ndots, add(1,ndots))} + "* " name(indi) + if (e, birth(indi)) {", b. " long(e) } + nl() + col(10) spouses(indi,sp,fam,num) { + set(ndots, 0) + col(10) while (lt(ndots, gen)) {" " set(ndots,add(1,ndots))} + " m. " name(sp) nl() + } + set(next, add(1,gen)) + if (lt(next,15)) { + families(indi,fam,sp,num) { + children(fam, child, no) { + call pout(next, child) + } + } + } +} + +/* end of report */ + diff --git a/reports/boc.gif b/reports/boc.gif new file mode 100644 index 0000000..839de0e Binary files /dev/null and b/reports/boc.gif differ diff --git a/reports/book-latex.ll b/reports/book-latex.ll new file mode 100644 index 0000000..11c3de0 --- /dev/null +++ b/reports/book-latex.ll @@ -0,0 +1,3317 @@ +/* +** @progname book-latex.ll +** @author Nicklaus +** @version 3.1 +** @category +** @output LaTeX +** @description +** +** Generates really spiffy register reports for formatting with LaTex. Reports +** read like a book. Includes source citation, footnotes, etc. Register +** reports are either descendant or ancestor/ahnentafel style. + +** SourceForge Versions: +** +** Revision 1.14 2005/11/19 05:30:30 memmerto +** - Add missing tags, as per SF Patch 551968. +** - Add "usepackage{isolatin1}" to register-tex.ll, as per SF Patch # 402021. +** - Add comments about how to change between A4/Letter paper. +** - Add -v (version) option; clean up -h/-? (usage) options, as per SF Feature Request # 1310390. +** - Add "temp" and "random" hints to more file operations. +** +** Revision 1.13 2005/10/26 04:40:45 dr_doom +** make user property usage more consistent +** +** Revision 1.12 2005/06/18 00:29:39 dr_doom +** Update formatted docs, minor cleanup in merge families +** +** Revision 1.11 2004/09/02 23:11:04 rsimms +** Enhanced book-latex.ll to filter text to render harmless those +** characters meaningful to the LaTeX system. Also added an option +** to suppress e-mail addresses of source authors when they're specified +** as EMAI subnodes of AUTH nodes. Also indented all of the code with +** spaces (instead of tabs/spaces mix) to make the code easier to follow. +** +** Revision 1.10 2004/07/19 05:54:54 dr_doom +** Merge Vincent Broman Changes to reports +** +** Revision 1.9 2003/01/19 02:50:23 dr_doom +** +** Revision 1.8 2001/10/03 02:58:55 dabright +** Restored some previous additions to this report. +** The update from Dennis Nicklaus on 12 Aug 2001 +** had deleted them and he asked me to re-add them. So: +** Add CREM (cremated) tag processing; +** modified OCCU tag processing so that it can recognize date ranges +** (and so avoid saying "xx is a yy and a zz and a ..."); modified +** OCCU tag processing to recognize a subordinate AGNC tag indicating +** employer; modified onDate to recognize date ranges (FROM dd mmm +** yyyy TO dd mmm yyyy) - this still has some rough edges. +** +** Revision 1.7 2001/08/12 20:53:59 nozell +** Update by Dennis Nicklaus to his book-latex.ll +** +** Revision 1.5 2000/11/28 21:39:45 nozell +** Add keyword tags to all reports +** Extend the report script menu to display script output format +** +** Revision 1.4 2000/11/11 07:52:06 pere +** Use ISO 8859/1 charset in LaTeX. Add meta-information in header. +** +** Revision 1.3 2000/11/11 07:46:47 pere +** Include index even when there is no bibliography. +** +** Revision 1.2 2000/11/11 04:07:37 dabright +** +** reports/book-latex.ll: Added processing for BAPM tag, corrected +** error in referencing "spouse" rather than "s" in longvitals, +** added processing for the TYPE tag (modifier for EVENT), corrected +** setDayNumber so that it only uses text phrases (e.g., "on the same +** day") when both previous date and current date are fully +** specified, preserve line breaks represented by blank CONT/CONC +** tags, ensure "cn" variable in sourceIt is initialized before +** referenced, and miscellaneous typographical corrections. +** +** +** Revision 1.1 2000/11/10 dabright +** Initial revision - copy of Version 2.5 from Dennis Nicklaus +** +** Pre-SourceForge history: +** +## Dennis Nicklaus (dnicklaus at yahoo.com) +** Version 2.5 Feb. 2000 +** +** Requires LifeLines version 2.3.3 or later +** Requires tree.tex (for formatting) (tex macros for tree drawing). +** (found in TUGboat, vol. 6 (1985) and online in various places, +** including with the desc-tex lifelines report) +** +** based on work by David Olsen (dko@cs.wisc.edu) which in turn was +** based on work originally done by Tom Wetmore (ttw@cbnews1.att.com). +** also work by Kurt Baudendistel (baud@research.att.com). +** A few others, such as Ed Sternin (edik@brocku.ca) made other suggestions. +** and corrections. +** +** This report prints, in register/book format, information about all +** descendants of a person (or persons) and all of their spouses. +** It tries to understand as many different +** GEDCOM tags as possible. All source information (SOUR lines) is in the +** bibliography and footnotes. +** +** An alternate usage (new in version 2) lets you print out sort of a +** combination ahnentafel and register report going through the ancestors of +** the persons chosen. +** +** The output is in LaTeX format. Therefore, the name of the output file +** should end in ".tex". To print (assuming the name of the output file is +** "out.tex"): +** latex out < ignore lots of warnings about underfull \hboxes > +** makeindex out < not all systems have makeindex available +** if yours is one, just remove the \input{file.ind} line +** from the LaTeX output and skip the 'makeindex'> +** latex out < repeat latex-ing to get cross-references resolved> +** latex out < needed to get the index into the TOC> +** < you may need to repeat more if Latex +** says so, e.g. if page refs change. > +** dvips -o out < without the -o, dvips will likely print to your +** < default printer instead of creating a .ps file. +** lpr out.ps +** < the last three commands here may be replaced by > +** pdflatex out -- if you have 'pdflatex' and a PDF is +** the desired final product > +** +** I admit that this is lot of post-processing, but the results are worth it. +** +** NOTE ON PAPER SIZES: +** Paper sizes (A4 or letter) can be specified within the LaTeX output, +** but this requires editing by folks who don't like the default. +** +** Since dvips (a neccessary processing step) can take a paper-size +** argument on the command line, it's much simpler to let the user +** specify the desired page size when running dvips (outlined above) +** instead of editing the report/LaTeX output. +** +** Example: +** dvips -t letter out [ for US Letter-sized paper, 8.5x11" ] +** dvips -t a4 out [ for ISO/European A4-sized paper, 8.3x11.7" ] +** +** A special note about indexing. If you have names with double quotes in +** them, e.g. Forrest "Foggy" Morrison, not the nice Latex quotes style: +** Forrest ``Foggy'' Morrison, then the " marks will screw up the index. + + If you'd like to credit me & this program in your + introduction if it's something you're really going to publish + that'd be nice (but not required). + Something like this could be used: + "This document was prepared using LifeLines v." version() " genealogical database program\n" + "by Thomas T.~Wetmore~IV, {\\tt ttw@beltway.att.com}. The script {\\tt book-latex}\n" + "by Dennis Nicklaus {\\tt dnicklaus at yahoo.com} was used to generate the \\LaTeX\\ code.\n" + +*/ +/* WHAT DENNIS NICKLAUS DID: + I expanded this program greatly, mostly based on a "book" report + done by Kurt Baudendistel (baud@research.att.com). + I combined what I liked best about register-tex and the book report. + + numbering: + Register-tex had modified register numbering, where book + had no numbering, and just always referred to people by + page number, so I took the mod. reg. numbering. + sources/bibliography: + book had really nice SOUR support, so I took that + and modified it a little bit, so that it supports + a more std. gedcom usage of the SOUR definitions + (according to my reading of the std). + nothing needed in database: + book required that you have various things like CHAP + and PART additions to your lifelines gedcom database + in order to find who to include in the book. + I didn't include that + multiple-person selection: + On the other hand, maybe you want to include the + descendants of more than one person. I included the + ability (which was sort of there in book) of specifying + multiple people. For Instance, you might specify your + maternal grandfather and your paternal grandfather to + get all your first cousins on both sides into the same + book. This report asks you to keep selecting as many + people as you want. It does the complete descendancy + for each person selected. Each person so selected + starts a new chapter in the book. I make up a title + of the book based on the surnames of indi's chosen. + When you don't want to select any more people, just + hit return at the "select indi" prompt. + english sentences: + The book report was very good at automatically making + real sentences instead of just fragments. I used that. + I try to make compound sentences using "and" whenever + possible, and this makes for a lot of rules in the + code to try to handle a lot of cases. I probably missed a + few where the English will still come out poorly. + placename smarts: + Also from book is the ability to recognize a place which + is used multiple times. For instance, the first time + it sees Keswick,Keokuk Co.,Iowa, it'll print the whole + thing. But then every subsequent time, it'll just print + Keswick. Makes things VERY readable, but it can leave + some ambiguous things, like if you have two Keswick's, + it might be hard to figure out which is meant. + Likewise, I picked up ADDR support from book. + if you have: + 2 PLAC thattown + 3 ADDR thisplace + It'll say "at thisplace in thattown". Simply having + 2 PLAC results in "in thattown". + One thing I did change from book was making sure + it always says "in thattown" after saying "at thisplace". + Book was happy just saying "at thisplace" and assuming + you know what it meant. + But if you have several of + 2 PLAC Town,County,State + 3 ADDR his home + Then just saying "at his home" doesn't do much, so I made + sure it always says at least "at his home in Town". + (the first time, it'd say, "at his home in Town,County, State".) + (also useful if you have lots of different St. Mary's, e.g.) + I also made it watch for words like "near, north,..." + for the "town" part of the place, so that it doesn't say + something icky like "in near Mytown". + many events: + register-tex supported a lot more GEDCOM fields, so + I tried to include all of them. + But I personally don't use all of them, so some may look ugly. + charts: I added a feature that makes it draw 3 gen desc. tree charts + for any indi who heads up a chapter. I took code + from desc-tex to do this. (and modified it slightly + because it didn't work for some cases). + So you need the tree.tex macros, which this will + try to include. + Note: I modified the tree.tex macro a little bit + to scrunch things up because I have some ancestors + with huge families, and all their 10 kids had big families, + so I had to scrunch the spacing to fit 3 gen. onto one page. + + I dropped most of the pedigree chart capabilities in book, + but I did add one thing to look for the something like: + 1 NOTE BOOKPEDIGREE + on each indi. If a note like that is found for an indi, + that indi's pedigree (8 gen, I think) will be printed + as a latex figure in the book. I find this useful, + for instance, when I do a book of all the desc. of + all the grandparents of my grandmother. I have + a BOOKPEDIGREE note on my grandmother so you can see + how all these lines fit together. + + If you have + 1 NOTE BOOKDESCENDENT + on an individual, it'll draw a 3-gen desc. chart for that person. + + + excursions: These are for when you are following one family + down, say SMITH, and one of the SMITHs marries a JONES. + If you want to include the JONES ancestry in this book, + but don't really want to follow every JONES descendant, + then if you put a note on the JONES person: + 1 NOTE BOOKEXCURSION + That causes this report to wait until the end of the + chapter, then make a subsection which goes to the + farthest male JONES ancestor, and document + the direct line between that JONES ancestor and the + JONES who married the SMITH. It doesn't follow + every JONES line down, but includes info about each + child of each direct JONES ancestor. + + intro + I include the possibility that you might want to put + your own introduction before most of the book. + You can input your own intro file if you want. + It should contain all the Latex directives you want + also, such as \chapter{Introduction}. + + grandchild divisions + Starting with the 4th generation down from each chapter head, + I group together sets of grandchildren with over and + under braces. (It doesn't make any sense to do it for + generations 1-3 because they'd all be in the same group.) + The idea is that if patriarch has kids A,B,C... + Then by generation 4, you'll get a grouping of A's grandkids + followed by B's grandkids, followed by C's grandkids. + Lots of intermarrying might occasionally confuse the + code which does this. + + Chapter splits + If you put a + 1 NOTE BOOKCHAPSPLIT + on the person who is a chapter head, + then each of his children will head up their own chapters with + the children of that head as Generation 1 in their respective chapters. + You should be careful not to have a BOOKCHAPSPLIT on anyone who + is not the head of a line, or it'll probably come out ugly. + + Okay, now that you know how to produce a report, here are the formatting + conventions you must follow to get a good one. All records shown here are + optional, and all other records are okay -- they'll just be ignored by + the book report: + + 1 NAME - Multiple name records allowed. First is ``true name.'' + - Later ones, with given but no surname, are ``nicknames'' + or familiars. + - Later ones, with surname but no given, are aliases or + alternate spellings. + - Later ones, with both surname and given, are aliases. + - Post-titles, such as MD, should be included in this name. + 2 SOUR ... - Source for name. + 1 TITL ... - Pre-titles, such as Reverend. (but I don't call people + by their titl much. I mean after all, a person + isn't Captain John yet when they are born. + So I currently ignore this.) + 1 SEX ... + 1 SOUR ... - Source for parentage if no BIRT or CHR is given. This + produces better output than BIRT-SOUR records with no + DATE or PLAC given. + I also use this when I have a general source + which tells me everything about the person and + I don't want to mess things up by citing it + separately 8 times for birth, death, marr,... + 1 evnt ... - BIRT, CHR, DEAT, BURI, CREM, MARR, DIV, DIVF, or ANUL,... + 2 DATE ... - Date should be of format + [ABT|BEF|AFT|BET] [day] [JAN|...|DEC] [year] [-year for BET] + 2 PLAC ... - Comma separated list of localities appropriate for the + expression ``in ...''. + 3 ADDR ... - Location appropriate for the expression ``at ... in ...''. + 3 CEME ... - Location appropriate for the expression ``at ... in ...''. + 2 AGE ... - Age appropriate for the expression ``at age ...''. + 2 CAUS ... - Cause of death appropriate for the expression + ``died of ...''. + 2 SOUR ... - Source for event. + 2 NOTE ... - Text to be inserted in book following technical details + of the event. (I use this instead of TEXT) + 3 SOUR ... - Source for text. + 1 OCCU ... - Description (title) of an occupation (job). + 2 AGNC ... - Employer (produces "worked [or became] a with "). + 1 TEXT ... - Text to be inserted in book about the person. + I toyed with putting this before the death info, + but decided I like having all the vital stuff first, + then the more interesting text stuff. + 2 SOUR ... - Source for text. + 1 NCHI ... - Number of children (family records only). + + n CONT ... - Appropriate for TEXT and SOUR. + + You have the option of selecting either 1 TEXT, 1 NOTE or (not and) + only those 1 NOTE records which start with an ! (exclamation) + to include as the main body of text for each individual. + + From the GEDCOM std, TEXT "contains information from the source document." + One might argue that I'm misusing it here. But it depends on what + kinds of things you use 1 TEXT for. It might be nicely readable and + technically appropriate if, for example, you copy a bio. of someone from + an old book and want it included in your printout. Also, in sort of + a self-referential way, you're including text from the book you + publish with this. :-) + + I personally don't print out the "1 NOTE" records because I personally + (and feel it is common that most people) have a lot of garbage in their + notes, either general reminders to themselves, or PAF-style source notes + (e.g. 1 NOTE BIRTH-DEATH: whatever source) + However, with version 2.2, I give the option to print out either + all 1 TEXT, all 1 NOTE, or all 1 NOTE !-tagged notes. (where if the + 1st char of the note is !, then the 1 NOTE gets included). + + Something that I consider a typical 2 NOTE usage might be: + 1 BURI + 2 DATE when + 2 PLAC somewhere + 2 NOTE (with her parents) + But you do have to be a little aware of what this report is going + to generate if you want to make it a grammatically correct sentence + + + + SOURCE records are complicated, but they produce great output. + + To document a fact with a simple footnote, use + + n SOUR ... + +1 CONT ... + + This can get more complicated (all records optional): + (actually, I'm not sure what all is supported for footnotes + any more, I mostly use bibliography entries.) + + n SOUR ... + +1 CONT ... + +1 PAGE ... + +1 VOLU ... + +1 NOTE ... + +2 CONT ... + +1 SOUR @id@ + + The +1 SOUR @id@ produces a citation to an entry in the bibliography, + not a footnote, that is attached to the text of the footnote. To get + a citation in the text itself, use + + n SOUR + +1 SOUR @id@ + + or the more simple + + n SOUR @id@ + + To create a bibliographic entry that can be referenced as a citation, + include a cross-reference definition. This can be included at the point + where a citation is wanted. However, since you will like re-use the + same citation many times and you'll want to be consist, define the + cross-reference definition separately. + + A cross-reference definition takes this form (start at level 0) + + n @id@ SOUR - no text allowed here + +1 AUTH ... - author of source + +2 EMAI ... - e-mail address of author (useful for fellow genealogists) + there is now an option to block e-mail addresses from + showing in the output (in their place is a mention that + one is on file) + +2 ADDR ... - postal address of author + +1 TITL ... - title of article or book + +1 PUBL - publishing info record + note that all these +2 things have to be under it for a bib. entry. + (rules are diff. for footnotes). + This is the way I read the 5.3 GEDCOM std. + +2 NAME ... - name of publication,e.g. journal + +2 PUBR ... - publisher name + +2 ADDR ... - address + +2 PHON ... - phone number + +2 DATE ... - date of pub. + +2 VOLU ... - volume or list or range + +2 NUM ... - number or list or range + + +1 FILM ... - LDS film number + +1 FICH ... - LDS fiche number + +1 PAGE ... - page or list or range + +1 REPO ... - library name + +1 NOTE ... - free form text + +2 CONT ... + +1 SOUR @id@ - cite another source from bibliographic entry + +1 TEXT ... - free form text to print + +2 CONT ... + + Note that the id can be most text that begins with an alphanumeric + character -- check your gedcom spec! Using a descriptive name of + the source that it represents, such as kurts-death-record or 0996198 + (for film numbers) is a good idea. + (but Lifelines eats the nice names when it reads them in) + +SEMI-BROKEN STUFF + + A few problems you might notice: + I'm not really happy with the desc. trees in several other cases, + such as multiple spouses, and had to fix desctex a little bit + to make it work better. It still isn't perfect, I don't think. + + The sentence structure may come out badly in some odd cases I haven't + encountered/tested yet. It's been a real pain to get it as + far as it is, and I'm still not happy with it. (It gets complicated + because I try to make compound sentences and use pronouns so + it isn't so choppy.) + + The "test for common grandparents" thing was just the simplest + way of doing it I could think of. Not perfect, but works 99%. + + I really want to put some smarts in so placename ambiguity is + less of a problem. For instance to distinguish the town of + Washington, Iowa from the state of Washington. + + My LaTex is sort of rusty, and some things aren't really properly + done, possibly. (Like the spacing on the overbraces designed to + fill one column.) Also, it's line-filling is pretty weird sometimes, + such as just putting one or two words in the first line of a + person's description. I don't understand why it does that. + +FOR VERSION 2: + I also now support a book which goes through an individual's + ancestors in ascending order. Numbering is ahnentafel style. + A new chapter for each generation. + +FOR VERSION 2.2 + (Several of these were suggested by Ed Sternin (edik@brocku.ca) + + a. Fixed problem where in the descendant trees if a spouse's + last name isn't known. It now puts in escaped underscores. + (Also fixed printfirstname [now printablefirstname] to print + underscores when no given name is known.) + + b. Added the BOOKCHAPSPLIT option + If you put a + 1 NOTE BOOKCHAPSPLIT on the person who is a chapter head, + then each of his children will head up their own chapters with + the children of that head as Generation 1 in their respective chapters. + I added this because I have a family where the father had 3 sons. + I want to include the info on the father, but I also want each + of the three sons to have their own chapter. So I put a + BOOKCHAPSPLIT note on the father, and it all comes out automatically. + You should be careful not to have a BOOKCHAPSPLIT on anyone who + is not the head of a line, or it'll probably come out ugly. + (It causes subsequently members of the generation of the noted + person to have separate chapters, as well as the children of + the noted person.) + + c. I give the option to print out either all 1 TEXT, all 1 NOTE, or all + 1 NOTE !-tagged notes (where if the 1st char of the note is !, then the + 1 NOTE gets included). + + d. Fixed mistake with running headers in ancestor format books so the + running header is now " Ancestors", not "Descendents". + + e. Added option (query turned off by default to match old way since it is + confusing to a beginner) to reset the placenametable at each generation. + If this option is selected, then the effect is that any placename + will have the fully specified (long) name printed out once in each + generation. I find this useful sometimes, just to remind people + where you're talking about since it might have been a long time + since the place was introduced. + + f. if there is a 1 Event, 2 DATE or 2 PLAC record where there is + no value on the 2 DATE or 2 PLAC (but the record is present), + it'll no fill in an underscore where the date/place would be, e.g., + Joe was born in ____ in ____ . + Previously if the 2 DATE or 2 PLAC were present and empty, it + would have said "born in in ." which isn't so nice. + + g. Changed from supporting 3 SITE records to 3 ADDR records because + SITE isn't supposed to be part of std. GEDCOM anymore, ADDR is. + I hope this is as easy of a global replace for you as + it was for me. (of a gedcom file in a text editor). + + h. Fixed A back-reference number (explaining that children were shown + earlier) in ancestor mode. + + i. Fixed problem in ancestor mode that would print out the long text for + some individuals more than once. + + New For Version 2.3 + Not much is new: + Don't do excursions in ancestor mode + Added a couple LaTex macros that I use for pictures. + + New For Version 2.4 + Some contributions by Dave Steiner (steiner@bakerst.rutgers.edu) + Some very minor typesetting fixups to make some spacing more + consistent. Some spaces added in certain parts, spaces taken + out of other places. + Says a couple "have no children" instead of "had no children" if + it looks like the couple are still married and living. + The bibliography filename will now be -bib.tex + instead of -bib.tex. + + Supports CONC as well as CONT continuation lines in most places. + + I've made a couple other similarly minor cosmetic changes, + one of which forces a new paragraph during excursions in an oddball case. + + Made a change in ancestor mode so that if cousins marry, it won't + print the information about the common ancestors twice. + + Also an ancestor mode change so that ref. numbers for a person's + parents appear in the text in the longvitals() description. + + New For Version 2.5. + Fixed a mistake in check_print_divinfo which made it not work at all. + + New For Version 3.0 + Several miscellaneous fixes. + Now part of lifelines sourceforge distribution. See sourceforge history. + Uses documentclass instead of documentstyle + Added ability to print a limited number of generations in + descendant-style books. At the terminal generation, if a person + is not dead, it will only print the birth year, not full date. + Fixed the titlepage generation. + Some fixes to support latest version of lifelines (or maybe its + just differences for lifelines under solaris): + Intersect() can't be used inside an if() call. + It has to call intersect separately and use the result in a set() + The childnum argument of children() is now only valid + within the scope of the children() loop. +*/ + +/* Stuff I haven't implemented: + adler@math.toronto.edu (Jeffrey D. Adler) + One suggestion came from "Denis B. Roegel" + regarding the over/under braces. + He suggested using something like: + \begin{minipage}{\columnwidth} + $\overbrace{\hspace*{3in}}$ + \vspace{3ex} + \begin{center}{\large\bf 24\ Henry REGLE}\end{center} + \end{minipage} + \nobreak + Henry {\sc REGLE}\index{REGLE, Henry|bfit}, ... + and For \underbrace, try to put a \nobreak before: + \nobreak + $\underbrace{\hspace*{3in}}$ + + I haven't tried this out to see if I like it better. + But I did include some of the \nobreaks before the underbrace + and after the big center-ed person's name. +*/ + +global(maxgenprint) /* number of generations to print full info for.*/ +global(atmax_generation) /* used so we don't print full birthdates of living + individuals at the MAX-th generation */ +global(ancestormode) +global(notes_text_mode) +global(eventPlaceTable) +global(atAddrValue) +global(eventNameTable) +global(in) +global(out) +global(idex) +global(stab) +global(powValue) +global(namereturn) +global(excurlist) +global(sourceList) +global(bibList) +global(bibTable) +global(figureCiteList) +global(figureNodeList) +global(gotValue) +global(gottenNode) +global(gottenValue) +global(dayNumber) +global(previousDayNumber) +global(daysToMonthList) +global(not_married_flag) +global(dumpplacetable_each_gen) +global(hadsplitnote) +global(force_desc_chart) +global(pedigreeFigureLabel) +global(global_dead)/* used at the MAX-th generation so we know if indi is dead*/ +global(tex_xlat) /* table used to escape characters meaningful to TeX */ +global(opt_xlat) +global(opt_email) /* flag indicating whether source author's + e-mail should be shown */ + +proc main() { + list(headlist) + table(stab) /* Table of numbers for each individual */ + list(bibList) + list(excurlist) + table(bibTable) + list(figureCiteList) + list(figureNodeList) + + list (sourceList) + + set(opt_xlat, 1) + table(tex_xlat) + insert(tex_xlat, "$", "\\$") + insert(tex_xlat, "&", "\\&") + insert(tex_xlat, "%", "\\%") + insert(tex_xlat, "#", "\\#") + insert(tex_xlat, "_", "\\_") + insert(tex_xlat, "{", "\\{") + insert(tex_xlat, "}", "\\}") + insert(tex_xlat, "~", "\\verb|~|") + insert(tex_xlat, "^", "\\verb|^|") + insert(tex_xlat, "\\", "\\verb|\\|") + insert(tex_xlat, "<", "$<$") /* out of math mode, < and > produce */ + insert(tex_xlat, ">", "$>$") /* upsidedown ! and ? marks */ + + list(daysToMonthList) + setel(daysToMonthList, 1, 0) + setel(daysToMonthList, 2, 31) + setel(daysToMonthList, 3, 59) + setel(daysToMonthList, 4, 90) + setel(daysToMonthList, 5, 120) + setel(daysToMonthList, 6, 151) + setel(daysToMonthList, 7, 181) + setel(daysToMonthList, 8, 212) + setel(daysToMonthList, 9, 243) + setel(daysToMonthList, 10, 273) + setel(daysToMonthList, 11, 304) + setel(daysToMonthList, 12, 334) + set(force_desc_chart, 0) + + getindimsg(indi, "Enter the first person for the report") + if(not(indi)) { + return(0) /* assume the user wants to quit */ + } + set(familycount, 0) + while(indi) { + set(familycount, add(familycount, 1)) + enqueue(headlist, indi) + set(indi, 0) + getindimsg(indi, "Enter another root person or none to proceed") + } + + if(1) { + getintmsg(ancestormode, "Enter 0 for descendant, 1 for ancestor report") + } else { + set(ancestormode, 0) + } + + set(maxgenprint, 999) + if(eq(0, ancestormode)) { + if(1) { + getintmsg(maxgenprint, "Max generations for descendancy books") + } else { + set(maxgenprint, 999) + } + } + + if(1) { + getintmsg(notes_text_mode, + "Book Text:1='1 TEXT'; 2= all '1 NOTE'; 3= !-tag '1 NOTE's") + } else { + set(notes_text_mode, 1) + } + + if(0) { /* change this to "if (1)" to turn this query on. */ + getintmsg(dumpplacetable_each_gen, + "Enter 1 to reset place name table each generation, 0 to not") + } else { + set(dumpplacetable_each_gen, 0) + } + + if(1) { + getintmsg(opt_email, + "Enter 1 to show source authors' e-mail addresses, 0 to not") + } else { + set(opt_email, 0) + } + + /* Print preamble. Feel free to change this to suit your tastes. */ + "\\documentclass[twocolumn,twoside,titlepage]{book}\n" /* LaTeX 2e */ + /*"\\documentstyle[twocolumn,makeidx]{book}\n"*/ + "\\pagestyle{myheadings}\n\n" + "% Enable ISO 8859/1 charset" nl() + "\\usepackage{isolatin1}" nl() + "% Shrink the margins to use more of the page.\n" + "% This is taken from fullpage.sty, which is on some systems.\n" + "\\topmargin 0pt\n" + "\\advance \\topmargin by -\\headheight\n" + "\\advance \\topmargin by -\\headsep\n" + "\\textheight 8.9in\n" + "\\oddsidemargin 0pt\n" + "\\evensidemargin \\oddsidemargin\n" + "\\textwidth 6.5in\n\n" + "\\newcounter{childnumber}\n\n" + "% The \\noname command is needed because TeX doesnt like underscores.\n" + "\\newcommand{\\noname}{\\underline{\\ \\ \\ \\ \\ }}\n\n" + "\\newcommand{\\nodate}{\\underline{\\ \\ \\ \\ }}\n\n" + "% Environment for printing the list of children.\n" + "\\newenvironment{childrenlist}" + "{\\begin{small}\\begin{list}{\\sc\\roman{childnumber}.}" + "{\\usecounter{childnumber}\\setlength{\\leftmargin}{0.5in}" + "\\setlength{\\labelsep}{0.07in}\\setlength{\\labelwidth}{0.43in}}}" + "{\\end{list}\\end{small}}\n\n" + "% The following commands are used to create the index.\n" + "\\newcommand{\\bold}[1]{{\\bf #1}}\n" + "\\newcommand{\\bfit}[1]{{\\bf\\it #1}}\n" + "%%\\newcommand{\\see}[2]{{\\it see #1}} %not needed with makeidx.sty\n\n" + "% Command to use at the beginning of each new generation.\n" + if(ancestormode) { + "\\newcommand{\\generation}[2]" + "{\\newpage\\begin{center}{\\huge\\bf Generation #1}\\end{center}" + "\\vspace{3ex}\\setcounter{footnote}{0}" + "\\markright{#2 Ancestors" "\\hfill Generation #1\\hfill\\ }" + "}\n\n" + } else { + "\\newcommand{\\generation}[2]" + "{\\newpage\\begin{center}{\\huge\\bf Generation #1}\\end{center}" + "\\vspace{3ex}\\setcounter{footnote}{0}" + "\\markright{#2 Descendants" "\\hfill Generation #1\\hfill\\ }" + "}\n\n" + } + "\\newcommand{\\image}[4]" + "{\\begin{figure}\n\\centerline{\\psfig{figure=#1,height=#4}}\n" + "\\label{#3}\n" + "\\caption{#2}\n\\end{figure}}\n" + "\\newcommand{\\imwide}[4]" + "{\\begin{figure*}\n\\centerline{\\psfig{figure=#1,height=#4}}\n" + "\\label{#3}\n" + "\\caption{#2}\n\\end{figure*}}\n" + + "\\makeindex\n\n" + "\n\\input{tree}\n" /* needed for making descendant trees */ + "\\begin{document}\n\n" + + /*******************************************/ + /* Make the title */ + /*******************************************/ + "\\title{ The " + forlist(headlist,head,localcount) { + if(gt(localcount,1)) { + if(gt(familycount,2)) { /* don't say "a, and b." */ + ", " + } + if(eq(localcount,familycount)) { " and " } + } + strxlat(tex_xlat, surname(head)) + } + if(eq(1,familycount)) { + " Family}\n" + } else { + " Families}\n" + } + + getstrmsg(author, "Enter the author(s) of this document:") + "\\author{" strxlat(tex_xlat, author) "}\n" + "\\date{\\today}\n" + "\\maketitle\n" + + "\\clearpage\n" + "\\onecolumn\n" + "\\pagestyle{empty}\n" + "\\mbox{ }\n" + "\\vfill\n" + "\\begin{center}\n" + "Copyright \\copyright \\ \\today \\ " strxlat(tex_xlat, author) "\\\\" + getstrmsg(copyplace, "Enter the place for the copyright notice:") + strxlat(tex_xlat, copyplace) "\n" + + "\\end{center}\n" + "\\clearpage\n" + "\\pagestyle{myheadings}\n" + "\\twocolumn\n" + + "\\setcounter{page}{1}\n" + "\\tableofcontents" + + getstrmsg(intro, "File that contains introduction (if any):") + if(ne(strcmp(intro, ""), 0)) { + "\\input{" intro "}\n" + } + + + + table(eventNameTable) + table(eventPlaceTable) + table(eventNameTable) + insert(eventNameTable, "BIRT", "was born") + insert(eventNameTable, "ADOP", "was adopted") + insert(eventNameTable, "BAPM", "was baptized") + insert(eventNameTable, "CHR", "was baptized") + insert(eventNameTable, "DEAT", "died") + insert(eventNameTable, "BURI", "was buried") + insert(eventNameTable, "CREM", "was cremated") + /* GRAD left blank since it is done as a separate case */ + insert(eventNameTable, "GRAD", "") + insert(eventNameTable, "NATU", "was naturalized") + insert(eventNameTable, "CHRA", "was christened (as an adult)") + insert(eventNameTable, "CENS", "was listed in the census") + insert(eventNameTable, "ORDN", "was ordained") + insert(eventNameTable, "RELI", "") + insert(eventNameTable, "RESI", "lived") + insert(eventNameTable, "CONL", "was confirmed") + insert(eventNameTable, "CONF", "was confirmed") + insert(eventNameTable, "BLES", "was blessed") + insert(eventNameTable, "BASM", "was bat mitzvah-ed") + insert(eventNameTable, "BARM", "was bar mitzvah-ed") + /* these two Will related things come out kind of icky because + I just always use plain pronouns like he, she, not + possessive ones, so I have to say "he wrote a will" + instead of "his will was dated" + */ + insert(eventNameTable, "PROB", "had a will probated") + insert(eventNameTable, "WILL", "wrote a will") + insert(eventNameTable, "RETI", "retired") + + + indiset(idex) + + + set(out, 1) + set(in, 1) + + dayformat(2) + monthformat(6) + dateformat(1) + while(indi, dequeue(headlist)) { + if(ancestormode) { + call ancestor_chapterproc(indi) + } else { + call chapterproc(indi) + } + } + + set(basename, + save(substring(outfile(), 1, sub(index(outfile(), ".", 1), 1)))) + + /* Output bibliography commands */ + if(not(empty(bibList))) { + "\n\n\\onecolumn" + "\n\\cleardoublepage" + "\n\\label{Bibliography}" + "\n\\addcontentsline{toc}{chapter}{Bibliography}" + "\n\\begin{thebibliography}{9.99}" + "\n\\input{" basename "-bib.tex}" + "\n\\end{thebibliography}" + } + "\n\n\\cleardoublepage" + "\n\\label{Index}" + "\n\\addcontentsline{toc}{chapter}{Index}" + "\n\\input{" basename ".ind}" + + "\n\n\\end{document}\n" + + /* Output bibliography file */ + print("\n\nCreating support files ...") + if( not(empty(bibList)) ) { + newfile(concat(basename, "-bib.tex"), 0) + print("writing to : ") + print("\n") + print(concat(basename, "-bib.tex")) + print("\n") + while(b, dequeue(bibList)) { b } + } +} + +proc chapterproc(topguy) { + list(ilist) /* List of individuals */ + list(glist) /* List of generation for each individual */ + set(last_grandparents,0) + indiset(grandparentset) + indiset(hisset) + indiset(last_grandparentset) + set(chapterTitle, + save(concat("The ", + concat(fullname(topguy, 0, 1, 99), "\ Family")))) + + "\n\\chapter{" chapterTitle "}" "\n" + + enqueue(ilist, topguy) + enqueue(glist, 1) + set(curgen, 0) + set(printed_brace,0) + set(just_printed_brace,0) + + /* we have to do this add1 once for the topguy of each chapter + We used to start out with "in" initialized to 2, but that made + the numberings bad when there were multiple chapters, so now + we init to 1 and do this +1 here + */ + set(in, add(in, 1)) + + set(hadsplitnote,0) + set(this_level_hadsplitnote,0) + + while(indi, dequeue(ilist)) { + /* This is where we implement the "Chapter Split". The idea is, + that if you put a BOOKCHAPSPLIT note on the head of a line, then + each of his children will head up their own chapters with + the children of that line as Generation 1 in their respective chapters. + */ + if(eq(1,this_level_hadsplitnote)) { + call chapterproc(indi) + } else { + set(thisgen, dequeue(glist)) + if(ne(curgen, thisgen)) { + /* If we are starting a new generation, close off brace + from previous gen. if necessary + */ + if(printed_brace) { + "\n\\nobreak" + "\n" "$\\underbrace{\\hspace*{3in}}$" "\n\n" + set(printed_brace,0) + } + + if(dumpplacetable_each_gen) { + table(eventPlaceTable) + } + print("Generation ") print(d(thisgen)) print("\n") + "\n\n\\generation{" d(thisgen) "}" "{" + strxlat(tex_xlat, surname(topguy)) "}" "\n" + "\n\\addcontentsline{toc}{section}{Generation " d(thisgen) "}\n" + set(curgen, thisgen) + set(last_grandparents,0) + indiset(last_grandparentset) + set(printed_brace,0) + if(eq(curgen,maxgenprint)) { + set(atmax_generation,1) + } else { + set(atmax_generation,0) + } + } + /* decide if we have the same grandparents or not */ + /* I try to group people together with over/under braces + for people descended from the same grandparent in this descendancy */ + /* rather than remember who belongs to what line, I just look + at all their grandparents and if they overlap with the grandparents + of the previous person, then I assume I'm on the same line. + This isn't always true, but it is a start, at least. + */ + if(gt(curgen,3)) { + if(eq(0,last_grandparents)) { + "\n" "$\\overbrace{\\hspace*{3in}}$" "\n" + set(printed_brace,1) + set(just_printed_brace,1) + indiset(hisset) + addtoset(hisset,indi,1) + set(grandparentset,parentset(parentset(hisset))) + set(last_grandparentset,grandparentset) + set(last_grandparents,1) + } else { + indiset(hisset) + addtoset(hisset,indi,1) + set(grandparentset,parentset(parentset(hisset))) + set(doit,1) + indiset(extraSet) + set(extraSet,intersect(grandparentset,last_grandparentset)) + forindiset(extraSet, joe, a, b) { + set(doit,0) + } + if(doit) { + if(printed_brace) { + "\n\\nobreak" + "\n" "$\\underbrace{\\hspace*{3in}}$" "\n\n" + } + "\n" "$\\overbrace{\\hspace*{3in}}$" "\n\n" + set(printed_brace,1) + set(just_printed_brace,1) + /* also reset the place table after each set of grandchildren. + This makes it repeat the whole location name the next time + it sees any location. Otherwise, it can get too far from the + introduction of the place for my liking. + */ + if(dumpplacetable_each_gen) { + table(eventPlaceTable) + } + } + set(last_grandparentset,grandparentset) + set(last_grandparents,1) + } + } + + print(d(out)) print(" ") print(name(indi)) print("\n") + + /* only do the vspace between people if there was no overbrace printed. + Otherwise there is too much white space and it looks icky. + */ + if(eq(0,just_printed_brace)) { + "\n\\vspace{3ex}\\ \\\\" + } + set(just_printed_brace,0) + + "\\begin{center}{\\large\\bf " d(out) "\\ " + strxlat(tex_xlat, name(indi)) "}\\end{center}\n" + "\\nobreak\n" + insert(stab, save(key(indi)), out) + + call longvitals(indi, 1, 2) + if(hadsplitnote) { + set(this_level_hadsplitnote,1) + } + + addtoset(idex, indi, 0) + set(out, add(out, 1)) + /* check whether the children we are about to print are at the + Max generation + */ + set(save_atmax_generation,atmax_generation) + if(eq(add(curgen,1),maxgenprint)) { + set(atmax_generation,1) + } + + families(indi, fam, spouse, nfam) { + "\n\n" + if(eq(0, nchildren(fam))) { + call texname(inode(indi), 0) "\\ and " + if(spouse) { + call texname(inode(spouse), 0) + } else { + "\\noname" + } + call havehadchildren(indi, spouse) + } elsif(and(spouse, lookup(stab, key(spouse)))) { + "Children of " call texname(inode(indi), 0) "\\ and " + call texname(inode(spouse), 0) "\\ are shown under " + call texname(inode(spouse), 0) + "(" d(lookup(stab, key(spouse))) ").\n" + } else { + "Children of " call texname(inode(indi), 0) "\\ and " + if(spouse) { + call texname(inode(spouse), 0) + } else { + "\\noname" + } + ":\n\\begin{childrenlist}\n" + children(fam, child, nchl) { + set(haschild, 0) + families(child, cfam, cspou, ncf) { + if(ne(0, nchildren(cfam))) { + set(haschild, 1) + } + } + if(and(haschild,lt(curgen,maxgenprint))) { + if(not(lookup(stab, key(child)))) { + enqueue(ilist, child) + enqueue(glist, add(1, curgen)) + "\n\\item[{\\bf " d(in) "}\\ \\hfill" + "\\addtocounter{childnumber}{1}" + "{\\sc\\roman{childnumber}}.]" + set(in, add(in, 1)) + call shortvitals(child) + } else { + "\n\\item[{\\bf " d(lookup(stab, key(child))) "}\\ \\hfill" + "\\addtocounter{childnumber}{1}" + "{\\sc\\roman{childnumber}}.]" + call shortvitals(child) + " Details of " pn(child, 3) " family were shown earlier." + } + } else { + if(haschild) { + set(force_desc_chart, 1) + } + "\n\\item " + call longvitals(child, 0, 1) + set(force_desc_chart,0) + addtoset(idex, child, 0) + } + } + "\\end{childrenlist}\n" + } + } + set(atmax_generation, save_atmax_generation) + + if(eq(indi,topguy)) { + set(descFigureLabel, save(concat(key(indi), "-figure-desc"))) + "\nA brief chart of the descendants of this line is contained in " + "Figure~\\ref{" descFigureLabel "}." + "\n\\begin{figure*}\n" + "\\centering\n" + call desc_chart_main3(indi) + "\n\\caption{Descendents of " fullname(indi,0,1,99) "({\\bf " + d(lookup(stab, key(indi))) "})}" nl() + "\\label{" descFigureLabel "}" + "\\end{figure*}\n" + } + } + } + + /* Close off the last braces if necessary */ + if(printed_brace) { + "\n\\nobreak" + "\n" "$\\underbrace{\\hspace*{3in}}$" "\n\n" + } + set(printed_brace,0) + + + while(indi, dequeue(excurlist)) { + call excursion(indi) + } +} + + +/* Run this routine if you want an ahnentafel style report for the + individuals named +*/ +proc ancestor_chapterproc(topguy) { + list(ilist) /* List of individuals */ + list(glist) /* List of generation for each individual */ + list(alist) + set(chapterTitle, + save(concat(fullname(topguy, 0, 1, 99), "\ Ancestors"))) + "\n\\chapter{" chapterTitle "}" "\n" + + enqueue(ilist, topguy) + enqueue(alist,1) + enqueue(glist, 1) + set(curgen, 0) + insert(stab, save(key(topguy)), 1) + + while(indi, dequeue(ilist)) { + set(ahnen, dequeue(alist)) + set(thisgen, dequeue(glist)) + if(ne(curgen, thisgen)) { + print("Generation ") print(d(thisgen)) print("\n") + "\n\n\\generation{" d(thisgen) "}" "{" + strxlat(tex_xlat, surname(topguy)) "}" "\n" + "\n\\addcontentsline{toc}{section}{Generation " d(thisgen) "}\n" + set(curgen, thisgen) + /* reset the place table at each generation if asked to. */ + if(dumpplacetable_each_gen) { + table(eventPlaceTable) + } + } + print(d(ahnen)) print(" ") print(name(indi)) print("\n") + + "\n\\vspace{3ex}\\ \\\\" + + "\\begin{center}{\\large\\bf " d(ahnen) "\\ " + strxlat(tex_xlat, name(indi)) "}\\end{center}\n" + + /****************************************************************/ + /* first, enqueue his parents onto the lists so their numbers + will be printed out in the description of "indi" */ + /* also includes a check to see if indi's parents are already + there such as will happen when cousins marry. + */ + set(print_dad_note,0) + set(print_mom_note,0) + + if(par,father(indi)) { + if(not(lookup(stab,key(par)))) { + enqueue(ilist, par) + enqueue(alist, mul(2,ahnen)) + enqueue(glist, add(curgen, 1)) + insert(stab, save(key(par)), mul(2,ahnen)) + } else { + set(print_dad_note,key(par)) + } + } + if(par, mother(indi)) { + if(not(lookup(stab,key(par)))) { + enqueue(ilist, par) + enqueue(alist, add(1,mul(2,ahnen))) + enqueue(glist, add(curgen, 1)) + insert(stab, save(key(par)), add(1,mul(2,ahnen))) + } else { + set(print_mom_note,key(par)) + } + } + + /****************************************************************/ + /* now to print out info about this person */ + + call longvitals(indi, 1, 2) + + addtoset(idex, indi, 0) + families(indi, fam, spouse, nfam) { + "\n\n" + if(eq(0, nchildren(fam))) { + call texname(inode(indi), 0) "\\ and " + if(spouse) { + call texname(inode(spouse), 0) + } else { + "\\noname" + } + call havehadchildren(indi, spouse) + } elsif( and(female(indi), spouse, lookup(stab, key(spouse))) ) { + /* note that the form of that if is different here than in + descendant reports. It is different because we explicitly + form the queue by adding the father before the mother. + Thus, for the parent-set, the children will be printed + under the father. We don't check to see if the father's + spouse had them previously printed because that would + only happen if a different (non-ancestor) wife also + happened to be an ancestor from a different branch, which + could happen, but has to be pretty rare. (E.g. your + dad's dad marries your mom's mom for the 2nd marriage for both + of them, something like that. Ick.) + */ + "Children of " call texname(inode(indi), 0) "\\ and " + call texname(inode(spouse), 0) "\\ are shown under " + call texname(inode(spouse), 0) + "(" d(lookup(stab, key(spouse))) ").\n" + } else { + "Children of " call texname(inode(indi), 0) "\\ and " + if(spouse) { + call texname(inode(spouse), 0) + } else { + "\\noname" + } + ":\n\\begin{childrenlist}\n" + children(fam, child, nchl) { + set(haschild, 0) + families(child, cfam, cspou, ncf) { + if(ne(0, nchildren(cfam))) { + set(haschild, 1) + } + } + "\n\\item " + if(not(lookup(stab, key(child)))) { + call longvitals(child, 0, 1) + addtoset(idex, child, 0) + } else { + call shortvitals(child) + " Details of " pn(child,3) " family were shown earlier " + "({\\bf " + d(lookup(stab, key(child))) "})" "." + } + } + "\\end{childrenlist}\n" + } + } /* END families loop */ + + /* if his parents are not numbered as expected, tell 'em so. */ + if(ne(0,print_dad_note)) { + "\n Note that " pn(indi,3) " father " + "({\\bf " + d(lookup(stab, print_dad_note)) "})" + " is not found in the usual " + "ahnentafel-style numbering place due to intermarriages.\n" + } + if(ne(0,print_mom_note)) { + "Note that " pn(indi,3) " mother " + "({\\bf " + d(lookup(stab, print_mom_note)) "})" + " is not found in the usual " + "ahnentafel-style numbering place due to intermarriages.\n" + "\n" + } + + if(eq(indi,topguy)) { + call pedigreeFigure(indi) + if(strcmp(pedigreeFigureLabel, "")) { + pn(indi, 2) + " pedigree is illustrated in Figure \\protect\\ref{" + pedigreeFigureLabel "}." + } + } + } +} + +/* shortvitals(indi): Displays the short form of the vital statistics (birth + and death only) of an individual. +*/ +proc shortvitals(indi) { + call resetdayplace() + call texname(inode(indi), 1) + set(b, birth(indi)) + set(d, death(indi)) + + set(local_dead,global_dead) /* save for restore */ + set(global_dead,d) + + if(and(b, long(b))) { + call process_event(b) + if(and(d, long(d))) { + " and " pn(indi,1) + call process_event(d) + } + } else { /* know death info, not birth*/ + if(and(d, long(d))) { + call process_event(d) + } + } + "." + set(global_dead,local_dead) /* restore */ +} + + +/* longvitals(i, name_parents, name_type) + Prints out the complete vital statistics of the individual (i). If + name_parents is not 0, then the names of the parents of the individual will + be printed. The parameter name_type is passed to texname. The GEDCOM tags + are divided into ones that would likely occur before getting married and + ones that would likely occur after getting married. Within the two sets + they are printed in the order in which they appear in the database. I + haven't yet figured out a convenient way of indicating the sex. +*/ +proc longvitals(i, name_parents, name_type) { + call resetdayplace() + + set(local_dead,global_dead) /* save for restore */ + set(global_dead,death(i)) + + call texname(inode(i), name_type) call print_sources(inode(i)) + call getValue(inode(i),"NAME") + if(gotValue) { + call print_sources(gottenNode) + } + + /* remember the value so it doesn't affect spousevitals */ + set(save_force_chart,force_desc_chart) + set(force_desc_chart,0) + + set(dad, father(i)) + set(mom, mother(i)) + if(and(name_parents, or(dad, mom))) { + ", " + if(male(i)) { "the son of " } + elsif(female(i)) { "the daughter of " } + else { "the child of " } + if(dad) { + call texname(inode(dad), 0) + if(lookup(stab, key(dad))) { + "({\\bf " + d(lookup(stab, key(dad))) + "})" + } + } + if(and(dad, mom)) { + "\nand " + } + if(mom) { + call texname(inode(mom), 0) + if(lookup(stab, key(mom))) { + "({\\bf " + d(lookup(stab, key(mom))) + "})" + } + } + ",\n" + } + + set(name_found, 0) + set(needname,0) + set(canUseAnd,1) + set(printedOne,1) /* at the start, we have just printed his fullname*/ + set(pronoun," ") + set(anythingprinted,0) + set(putPeriod,0) + /* there is a mistake in this for right now, if we don't have any + pre-marriage info, it'll be ugly for the death. + */ + fornodes(inode(i), n) { + if(not(printedOne)) { + if(needname) { + set(pronoun, printablefirstname(i)) + set(needname,0) + set(canUseAnd,1) + set(printedOne,1) + set(putPeriod,0) + set(pronoun," ") + } else { + if(canUseAnd) { + set(pronoun," and ") + set(canUseAnd,0) + set(printedOne,1) + set(putPeriod,1) + } else { /* set up for "He" this time, "and" next time. */ + /* put the period in for the first time */ + if(not(anythingprinted)) { + set(putPeriod,1) + } else { + set(putPeriod,0) + } + set(pronoun,pn(i,0)) + set(canUseAnd,1) + set(printedOne,1) + } + } + set(anythingprinted,1) + }/* end if not printedone */ + + if( + or(eq(strcmp(tag(n), "ADOP"), 0), + eq(strcmp(tag(n), "BAPL"), 0), + eq(strcmp(tag(n), "BAPM"), 0), + eq(strcmp(tag(n), "BARM"), 0), + eq(strcmp(tag(n), "BASM"), 0), + eq(strcmp(tag(n), "BIRT"), 0), + eq(strcmp(tag(n), "BLES"), 0), + eq(strcmp(tag(n), "CONF"), 0), + eq(strcmp(tag(n), "CONL"), 0), + eq(strcmp(tag(n), "ORDN"), 0), + eq(strcmp(tag(n), "CHR" ), 0) + )) { + pronoun set(printedOne,0) + call process_event(n) + if(putPeriod) {". "} + } + if(eq(strcmp(tag(n), "GRAD"), 0)) { + pronoun set(printedOne,0) + " graduated from " + call valuec(n) + call process_event(n) + if(putPeriod) {". "} + } + + if(eq(strcmp(tag(n), "CAST"), 0)) { + pronoun set(printedOne,0) + " was a member of Caste: " call valuec(n) + call process_event(n) + if(putPeriod) {". "} + } + if(eq(strcmp(tag(n), "NAME"), 0)) { + if(eq(name_found, 0)) { + set(name_found, 1) + } else { + pronoun set(printedOne,0) + " was also known as " call texname(n, 3) + call print_notes(n, " ") + call print_sources(n) + if(putPeriod) {". "} + "\n" + } + } + if(eq(strcmp(tag(n), "NAMR"), 0)) { + pronoun set(printedOne,0) + " had the religious name of: " call valuec(n) + call process_event(n) + if(putPeriod) {". "} + } + if(eq(strcmp(tag(n), "RELI"), 0)) { + pronoun set(printedOne,0) + " was a " call valuec(n) + call process_event(n) + if(putPeriod) {". "} + } +/* + if(eq(strcmp(tag(n), "TITL"), 0)) { + pronoun set(printedOne,0) + " held the title of " value(n) + call print_sources(n) + if(putPeriod) {". "} "\n" + } +*/ + } /* END fornodes(inode(i), n) */ + + if(and(putPeriod,anythingprinted)) { ". " } + set(inhibit_text_charts,0) + if(eq(1, nfamilies(i))) { + families(i, f, s, n) { + if(s) { + if(anythingprinted) { pn(i,0) } + set(anythingprinted,1) + call illegit_check(f) + if(not_married_flag) { + " had a child with" + } else { + " married" + } + /* it is OK to assume they had children if the + Not married flag is raised. Cuz if they + weren't married and didn't have kids, there + isn't much point in the family existing + (as far as this program is concerned). + */ + call print_sources(fnode(f)) + call spousevitals(s, f) + } + } /* END families(i, f, s, n) */ + + } else { /* individual 'i' had more than one family */ + families(i, f, s, n) { + if(anythingprinted) { + /* print "he" (or "she") for first marriage, and his + first name for all later marriages + */ + if(gt(n,1)) { + printablefirstname(i) + } else { + pn(i,0) + } + } + set(anythingprinted, 1) + if(s) { + call illegit_check(f) + if(not_married_flag) { + " had child(ren) with " + } else { + " married " + } + ord(n) "," call print_sources(fnode(f)) + call spousevitals(s, f) + /* make sure we don't print this (i) persons + text and charts a second time. The theory here + being that if the spouse is in the stab, + then this person (i) has already had their + notes/charts done as part of their spouse. + We don't want to print a 2nd time + */ + if(not(ancestormode)) { + if(lookup(stab, key(s))) { + set(inhibit_text_charts,1) + } + } + } else { + " " ord(n) " had a child with an unknown spouse. " + } + } /* END families(i, f, s, n) */ + } + " " +/* + if(anythingprinted) { + call getText(inode(i),0) + } +*/ + /* otherwise hold off on getText until after the death info & all */ + /* I changed my mind. I like getText at the end. */ + set(needname,1) + set(canUseAnd,0) + set(putPeriod,0) + if(anythingprinted) { + set(printedOne,0) /* haven't printed a name here after the spouse info */ + /* this works because pronoun is still a blank */ + } else { + set(printedOne,1) /* we still have his name from way at the start */ + set(putPeriod,1) /* JUST ADDED THIS LINE 5/24/96. Don't know if works */ + /* test it on Galbraith kids where know only death.*/ + } + + fornodes(inode(i), n) { /* process DEATH related gedcom nodes */ + if(not(printedOne)) { + if(needname) { + set(pronoun, printablefirstname(i)) + set(needname,0) + set(canUseAnd,1) + set(printedOne,1) + set(putPeriod,0) + } else { + if(canUseAnd) { + set(pronoun," and ") + set(canUseAnd,0) + set(printedOne,1) + set(putPeriod,1) + } else { + set(pronoun,pn(i,0)) + set(canUseAnd,1) + set(printedOne,1) + set(putPeriod,0) + } + } + } + if( + or( + eq(strcmp(tag(n), "BURI"), 0), + eq(strcmp(tag(n), "CREM"), 0), + eq(strcmp(tag(n), "CENS"), 0), + eq(strcmp(tag(n), "CHRA"), 0), + eq(strcmp(tag(n), "DEAT"), 0), + eq(strcmp(tag(n), "NATU"), 0), + eq(strcmp(tag(n), "RETI"), 0), + eq(strcmp(tag(n), "RESI"), 0), + eq(strcmp(tag(n), "PROB"), 0), + eq(strcmp(tag(n), "WILL"), 0) + )) { + pronoun set(printedOne,0) + call process_event(n) + if(putPeriod) {". "} + } + + /* One part of the GEDCOM standard says the tag should be DSCR, + another part says DESR. + */ + if(eq(strcmp(tag(n), "DESR"), 0)) { + pronoun set(printedOne,0) + "Description: " call valuec(n) + call print_sources(n) + if(putPeriod) {". "} + } + if(eq(strcmp(tag(n), "EVEN"), 0)) { + pronoun set(printedOne,0) + value(n) + call process_event(n) + if(putPeriod) {". "} + } + if(eq(strcmp(tag(n), "OCCU"), 0)) { + pronoun set(printedOne,0) + /* should also check for a RETIred node + and always say WAS if it exists + */ +/* DAB - replace with do_occu; delete this when do_occu accepted + call getValue(inode(i),"RETI") + if(gotValue) { + " was" + } else { + call iswas(i) + } + " " + call aAn(value(n)) " " + call valuec(n) + call process_event(n) +*/ + call do_occu(n, i) + if(putPeriod) {". "} + } + if(eq(strcmp(tag(n), "PROP"), 0)) { + pronoun set(printedOne,0) + "had possessions: " call valuec(n) "." + call print_sources(n) + if(putPeriod) {". "} + } + } + if(putPeriod) {". "} + /* restore forcing of desc. charts */ + set(force_desc_chart,save_force_chart) + if(not(inhibit_text_charts)) { + call getText(inode(i),0) + call process_book_notes(i) + } + set(global_dead,local_dead) /* restore */ +} + + +/* isRange(d) - Indicate if a date node is a range + * + * d - DATE node(could be NIL) + * + * Returns: 1 if is of the form "[BET] date1-date2"; 0 otherwise + * + */ +func isRange(d) { + set(r, 0) + if(d) { + if(i, index(d, "-", 1)) { + set(r, 1) + } elsif(i, index(d, "FROM", 1)) { + set(r, 1) + } + } + return(r) +} + + +/* do_occu(n, i) - Process an OCCU node + * + * n - OCCU node + * i - INDI containing + * + * An OCCU node will produce text saying " is/was a with ...." + * It is assumed that the was printed before this routine was called. + * If the person is (likely) deceased, if the OCCU node has a subordinate RETI node, + * or if the DATE tag subordinate to the OCCU node is a range, then "was" is used in + * the sentence; otherwise, "is" is used. The "with " clause is added if a + * AGNC node is subordinate to the OCCU node; it is taken to be the name of the + * employer. + * + */ + +proc do_occu(n, i) { + /* Check for date range or RETI node and use "was" if either present. */ + set(d, date(n)) + call getValue(inode(i), "RETI") + if(or(gotValue, isRange(d))) { + " was" + } else { + call iswas(i) + } + " " + call aAn(value(n)) " " + call valuec(n) + call getValue(n, "AGNC") + if(gotValue) { + " with " gottenValue + } + call process_event(n) + /* + if(putPeriod) {". "} + */ +} + + +/* spousevitals(spouse, fam) + Prints out information about a marriage (fam) and about a spouse in the + marriage (spouse). +*/ + +proc spousevitals(spouse, fam) { + call texname(inode(spouse), 3) + if(spouse) { + call print_sources(inode(spouse)) + call getValue(inode(spouse),"NAME") + if(gotValue) { + call print_sources(gottenNode) + } + } + + if(e, marriage(fam)) { + call process_event(e) + } + ". " + call check_print_divinfo(fam) + + if(spouse) { + set(bir, birth(spouse)) + set(chr, baptism(spouse)) + set(dea, death(spouse)) + set(bur, burial(spouse)) + set(dad, father(spouse)) + set(mom, mother(spouse)) + + set(local_dead,global_dead) /* save for restore */ + set(global_dead,dea) + + + if(or(bir, chr, dea, bur, mom, dad)) { + printablefirstname(spouse) + if(or(mom, dad)) { + ", " + if(male(spouse)) { + "the son of " + } elsif(female(spouse)) { + "the daughter of " + } else { + "the child of " + } + if(dad) { + call texname(inode(dad), 3) + if(lookup(stab, key(dad))) { + "({\\bf " + d(lookup(stab, key(dad))) + "})" + } + } + if(and(mom, dad)) { + " and " + } + if(mom) { + call texname(inode(mom), 3) + if(lookup(stab, key(mom))) { + "({\\bf " d(lookup(stab, key(mom))) "})" + } + ", " + } + } + + if(or(or(or(bir, chr), dea), bur)) { + if(bir) { + call vitalEvent(bir,1) + call print_sources(bir) + if(chr) { + " and" + call vitalEvent(chr,0) + call print_sources(chr) + ". " + } + if(dea) { + if(chr) { + pn(spouse,0) + } else { + " and" + } + call vitalEvent(dea,1) + call print_sources(dea) + ". " + } else { + if(not(chr)) { + ". " + } + } /* born, but nothing more */ + } + if(and(chr, not(bir))) { + call vitalEvent(chr,1) + call print_sources(chr) + ". " + } + if(and(dea,not(bir))) { /* if bir, then dea is already handled */ + if(chr) { /* then need to print pronoun, otherwise don't + since we still have the name standing there, + not finishing a sentence + */ + pn(spouse,0) + } + call vitalEvent(dea,1) + call print_sources(dea) + ". " + } + if(bur) { + if(or(or(bir,dea),chr)) { + pn(spouse,0) + } + call vitalEvent(bur,0) + call print_sources(bur) + ".\n" + } + } + } + if(gt(nfamilies(spouse), 1)) { + set(beforefam,1) + families(spouse, newfam, newspouse, n) { + if(ne(newfam, fam)) { + printablefirstname(spouse) + if(beforefam) { + " had " + if(gt(n, 1)) { + "also " + } + "previously married " + } else { + " later remarried " + } + if(newspouse) { + call texname(inode(newspouse), 3) + } + set(e,marriage(newfam)) + if(e) { call process_event(e) } + if(gt(nchildren(newfam), 0)) { + ", and had " + d(nchildren(newfam)) + if(gt(nchildren(newfam), 1)) { + " children " + } else { + " child" + } + " by that marriage: " + children(newfam, stepchild, numerical) { + if(gt(numerical,1)) { + ", " + } + printablefirstname(stepchild) + } + } + ". " + } else { /* newfam = fam */ + set(beforefam,0) /* we see the current family */ + } + } /* END families(spouse, newfam, newspouse, n) */ + } /* END if(gt(nfamilies(spouse), 1)) */ + + if(not(lookup(stab, key(spouse)))) { /* don't print a 2nd time */ + call getValue(inode(spouse),"OCCU") + if(gotValue) { + set(savenode,gottenNode) + printablefirstname(spouse) + /* should also check for a RETIred node and always say WAS if it exists */ +/* DAB - replace with do_occu; delete this when do_occu is accepted + call getValue(inode(spouse),"RETI") + if(gotValue) { + " was" + } else { + call iswas(spouse) + } + " " + call aAn(value(savenode)) " " + call valuec(savenode) + call process_event(savenode) + ". " +*/ + call do_occu(savenode, spouse) ". " + } + call getText(inode(spouse),0) + call process_book_notes(spouse) + } + set(global_dead,local_dead) /* restore */ + } else { + "\\noname" ".\n" + } /* END if(spouse) block */ +} + + +/* texname(i, type) + Prints an individual's name in LaTeX format, with the surname in small caps. + For example, "David Kenneth /Olsen/ Jr." would be printed as + "David Kenneth {\sc Olsen} Jr.". The type argument determines how the name + will appear in the index. + type = 0: no index + type = 1: page number appears in bold + type = 2: page number appears in bold-italics + type = 3: page number appears in normal text + The parameter i can be either an INDI node (NOT an individual) or a + NAME node. +*/ +proc texname(i, type) { + list(name_list) + set(sname, "") + extractnames(i, name_list, num_names, surname_no) + forlist(name_list, nm, num) { + if(eq(num, surname_no)) { + if(eq(strcmp(nm, ""), 0)) { + " \\noname" + set(sname, "\\noname") + } else { + if(eq(strcmp(nm, "____"), 0)) { + set(sname, "\\noname") + } else { + " {\\sc " + strxlat(tex_xlat, save(nm)) + "}" + set(sname, nm) + } + } + } else { + " " strxlat(tex_xlat, nm) + } + } + if(gt(type, 0)) { + "\\index{" + strxlat(tex_xlat, sname) + if(gt(num_names, 1)) { + "," + } + forlist(name_list, nm, num) { + if(ne(num, surname_no)) { + " " + strxlat(tex_xlat, nm) + } + } + if(eq(type, 1)) { + "|bold" + } elsif(eq(type, 2)) { + "|bfit" + } + "}" + } +} + + +/* process_event(event_node, event_name) + Prints information about a particular event (event_node, which is a GEDCOM + node). event_name is verb form of the text describing the event (such as + "Born", "Died", etc.). +*/ +proc process_event(event_node) { + call vitalEvent(event_node,0) + call print_sources(event_node) + call print_notes(event_node, " ") +} + + +proc inPlace(event) { + if(place(event)) { + if(eq(strcmp(place(event),""),0)) { + " in \\noname" + } else { + call atAddr(event) + if(not(strcmp(atAddrValue,""))) { + set(fullSpecCompare,1) + } else { + set(fullSpecCompare,2) + } /* there was an ADDR. We want to + say at X in Y + */ + list(placeList) + list(placeTextList) + list(placeTagList) + extractplaces(event, placeList, nPlaces) + requeue(placeList, atAddrValue) + while(placeText, dequeue(placeList)) { + enqueue(placeTextList, placeText) + set(placeTag, placeText) + forlist(placeList, place, placeN) { + set(placeTag, save(concat(placeTag, concat("-", place)))) + } + enqueue(placeTagList, placeTag) + } + + set(there, getel(placeTagList, 1)) + if(not(strcmp(there, lookup(eventPlaceTable, "@there@")))) { + "\nthere" + } else { + insert(eventPlaceTable, "@there@", there) + set(fullySpecified, 0) + forlist(placeTextList, place, placeN) { + set(placeTag, dequeue(placeTagList)) + if(not(eq(fullySpecified,fullSpecCompare))) { + if(eq(placeN, 2)) { + /* if the name of the place doesn't start with "near", say "in" */ + if(and( + strcmp(substring(place,1,4), "near"), + strcmp(substring(place,1,2), "in"), + strcmp(substring(place,1,5), "south"), + strcmp(substring(place,1,5), "north"), + strcmp(substring(place,1,4), "west"), + strcmp(substring(place,1,4), "from"), + strcmp(substring(place,1,4), "east"))) { + /* note that case matters a lot in that comparison */ + /* a town might be named North English, but one should + always have written, "north of English" if + you just want to say it is outside of town + */ + "\nin " + } else { + if(not(strcmp(substring(place,1,4), "from"))) { + " and was\n" + /* Actually, that isn't quite what I want because if + it has someone b. PLAC from there but no date, it'll wind + up outputting "He was born and was from there". + But oh well. + */ + } else { + "\n" /* put nothing there if it says "near" */ + } + } + } elsif(gt(placeN, 2)) { + ", " + } + place + if(strlen(place)) { + if(not(lookup(eventPlaceTable, placeTag))) { + insert(eventPlaceTable, placeTag, 1) + /* this next fiddling with fullSpecCompare is because + the FIRST time we see an "at ADDR in a,b,c" + since ADDR-a-b-c isn't in the table, it would + try to print "at ADDR in a,b". We just want it to + print "at ADDR in a" if a,b,c was previously defined. + */ + set(fullSpecCompare,1) + } else { + set(fullySpecified, add(fullySpecified,1)) + } + if(gt(index(place,"Twp",1),0)) { + /* then it is just the name + of a township, which I don't think is much + use without the county name, so I'm always + going to force it to print the county name + if it gives a township + */ + set(fullSpecCompare,add(1,fullSpecCompare)) + } + } + }/* end if not fullySpecified */ + } + } + }/* matches the else for place being non-null */ + } +} + +/* Possible customization I have chosen not to implement: + Suggested by: "John F. Chandler" + if(gt(nPlaces,1)) { set(inWord,"at") } + else { set(inWord,"in") } + if(not(strcmp(tag(event),"IMMI"))) { set(inWord,"to") } + if(not(strcmp(tag(event),"GRAD"))) { + if(eq(nPlaces,1)) { set(inWord,"from") } + else { set(inWord,"-") } + } + inWord " " + instead of the original "in ". This assumes that the institution is + recorded in the PLAC + I (DN) Think there is a little more to it than that because of the way + I currently use atAddr, but I'm sure you can figure all that out. + I currently assume that the institution name is the value of the + 1 GRAD line, e.g. 1 GRAD Univ. of Iowa and I handle it as a special case. +*/ + + +proc atAddr(root) { + set(atAddrValue, "") + if(root) { + fornodes(root, node) { + if(not(strcmp(tag(node), "PLAC"))) { + fornodes(node, subnode) { + if(and(not(strcmp(atAddrValue, "")), + or(not(strcmp(tag(subnode), "ADDR")), + not(strcmp(tag(subnode), "CEME"))))) { + if(val, value(subnode)) { + set(atAddrValue, save(concat("\nat ", val))) + } + } + } + } + } + } +} + + +proc check_print_divinfo(fam) { + call getValue(fnode(fam), "DIV") + if(gotValue) { + " They divorced" + call process_event(gottenNode) + ". " + } +} + + +/* print_notes(root, sep): Prints all the notes (NOTE nodes) associated with + the GEDCOM line root, separated by the given separator. +*/ +proc print_notes(root, sep) { + fornotes(root, note) { + sep + strxlat(tex_xlat, note) + /* " "*/ + } +} + + +proc process_book_notes(indi) { + set(hadpednote,0) + set(haddescnote,0) + set(doexcursion,0) + + fornotes(inode(indi), note) { + set(i, index(note, "BOOKPEDIGREE", 1)) + if(gt(i, 0)) { + set(hadpednote, 1) + } + set(i, index(note, "BOOKDESCENDENT", 1)) + if(gt(i, 0)) { + set(haddescnote, 1) + } + set(i, index(note, "BOOKEXCURSION", 1)) + if(gt(i, 0)) { + set(doexcursion, 1) + } + set(i, index(note, "BOOKCHAPSPLIT", 1)) + if(gt(i, 0)) { + set(hadsplitnote, 1) + } + } + if(eq(hadpednote,1)) { + call pedigreeFigure(indi) + if(strcmp(pedigreeFigureLabel, "")) { + pn(indi, 2) + " pedigree is illustrated in Figure \\protect\\ref{" + pedigreeFigureLabel "}." + } + } + if(force_desc_chart) { + set(haddescnote,1) + } + if(eq(haddescnote,1)) { + set(descFigureLabel, save(concat(key(indi), "-figure-desc"))) + "\nA brief chart of the descendants of " + call texname(inode(indi), 3) + " is contained in " + "Figure~\\ref{" descFigureLabel "}." + "\n\\begin{figure*}\n" + "\\centering\n" + call desc_chart_main3(indi) + "\n\\caption{Descendents of " strxlat(tex_xlat, fullname(indi,0,1,99)) "({\\bf " + d(lookup(stab, key(indi))) "})}" nl() + "\\label{" descFigureLabel "}" + "\\end{figure*}\n" + } + if(eq(0, ancestormode)) { + if(eq(doexcursion, 1)) { + pn(indi, 2) " ancestors will be discussed in depth on page~\\pageref{" + key(indi) "-excur-ref}" + " in this chapter.\n\n" + enqueue(excurlist, indi) + } + } +} + +proc pedigreeFigure(i) { + indiset(iSet) + addtoset(iSet, i, 1) + set(max, 0) + indiset(extraSet) + set(extraSet,ancestorset(iSet)) + forindiset(extraSet, indi, val, num) { + if(gt(val, max)) { + set(max, val) + } + } + if(gt(max, 1)) { + set(pedigreeFigureLabel, save(concat(key(i), "-figure-pedigree"))) + if(gt(max, 5)) { + set(max, 5) + } + call figPed(max, i) + } else { + set(pedigreeFigureLabel, "") + } +} + +proc figPed(n, indi) { + "\n\\begin{figure*}" + "\n\\centering" + "\n\\small" + "\n\\setlength{\\unitlength}{" + if(eq(n, 5)) { ".8" } else { ".9" } + "\n\\baselineskip}" + + call pow(2, n) + "\n\\begin{picture}(" + d(add(mul(6, n), 12)) + "," + d(sub(mul(powValue, 2), 1)) + ")(0,.5)" + + call ped6(indi, 0, powValue, powValue) + + "\n\\end{picture}" + "\n\\caption{Pedigree of " call scname(indi) "}" + "\n\\label{" pedigreeFigureLabel "}" + "\n\\end{figure*}" +} + +proc ped6(indi, x, y, z) { + "\n\\put(" d(mul(x, 6)) "," d(y) "){\\makebox(0,0)[l]{" + call scname(indi) + "}}" + if(x) { + "\n\\put(" d(sub(mul(x, 6), 3)) "," d(y) "){\\line(1,0){" d(3) "}}" + "\n\\put(" d(sub(mul(x, 6), 3)) "," d(y) "){\\line(0," + if(female(indi)) { "1" } else { "-1" } + "){" d(sub(z, 1)) ".4}}" + } + if(z2, div(z, 2)) { + if(f, father(indi)) { call ped6(f, add(x, 1), add(y, z2), z2) } + if(m, mother(indi)) { call ped6(m, add(x, 1), sub(y, z2), z2) } + } +} + +proc scname(indi) { + strxlat(tex_xlat, fullname(indi, 0, 1, 99)) + if(lookup(stab, key(indi))) { + "({\\bf " + d( lookup(stab, key(indi))) + "})" + } +} + +proc pow(x, i) { + set(powValue, 1) + call powIt(x, i) +} + +proc powIt(x, i) { + if(i) { + set(powValue, mul(powValue, x)) + call powIt(x, sub(i, 1)) + } +} + + +/* print_sources(root) + Prints all sources (SOUR lines) associated with the given GEDCOM line. The + sources are formatted as LaTeX footnotes. This routine prints each SOUR line + as a separate footnote, which is not correct. This should be corrected so + that all sources are combined into a single footnote. +*/ +proc print_sources(root) { + enqueue(sourceList,root) + call sourceIt(sourceList) +} + + +/* valuec(n): Prints the value of a GEDCOM node and the values of any CONT + lines associated with it. +*/ +proc valuec(n) { + value(n) + fornodes(n, n1) { + if(eq(strcmp(tag(n1), "CONT"), 0)) { + "\n" value(n1) + } elsif(eq(strcmp(tag(n1), "CONC"), 0)) { + value(n1) + } + } +} + + +proc resetdayplace() { + call setDayNumber(0) + insert(eventPlaceTable, "@there@", "") +} + +proc vitalEvent(event, reset) { + if(reset) { + call setDayNumber(0) + insert(eventPlaceTable, "@there@", "") + } + if(event) { + if(eventName, lookup(eventNameTable, tag(event))) { + " " eventName + if( + or( + not(strcmp(tag(event), "ADOP")), + not(strcmp(tag(event), "CHR")), + not(strcmp(tag(event), "CREM")), + not(strcmp(tag(event), "BURI")) + )) { + set(previousDayNumber, dayNumber) + } else { + set(previousDayNumber, 0) + } + } + if(not(eventName)) { + call getValue(event, "TYPE") + if(gotValue) { + " " strxlat(tex_xlat, gottenValue) + } + } + if(not(strcmp(tag(event), "DEAT"))) { + call ofCause(event) + } + call onDate(event) + call atAge(event) + call inPlace(event) + } +} + + +proc setDayNumber(event) { + set(dayNumber, 0) + if(date(event)) { + extractdate(event, day, month, year) + /* DAB - Have to check day month and year, otherwise two events for which + only the year is known + are said to have occurred on "the same day" + */ + if(and(and(year, month), day)) { + set(yearNumber, + add(mul(year, 365), div(year, 4), + neg(div(year, 100)), div(year, 400))) + set(monthNumber, getel(daysToMonthList, month)) + set(leapYear, and(eq(mod(year, 4), 0), + not(and(eq(mod(year, 100), 0), ne(mod(year, 400), 0))))) + if(and(leapYear, le(month, 2))) { + decr(monthNumber) + } + set(dayNumber, add(yearNumber, monthNumber, day)) + } + } +} + + +/* This was the old way, replaced by the above by Jim Eggert */ +/* +proc setDayNumber(event) { + set(dayNumber, 0) + if(date(event)) { + extractdate(event, day, month, year) + if(year) { + set(yearNumber, sub(add(mul(year, 365), div(year, 4)), div(year, 400))) + set(monthNumber, getel(daysToMonthList, month)) + set(leapYear, and(eq(mod(year, 4), 0), + not(and(eq(mod(year, 100), 0), ne(mod(year, 400), 0))))) + if(and(leapYear, gt(month, 2))) { + incr(monthNumber) + } + set(dayNumber, add(yearNumber, monthNumber, day)) + } + } +} +*/ + + +proc atAge(event) { + call getValueCont(event, "AGE") + if(gotValue) { + if(not(strcmp(gottenValue, "young"))) { + "\nyoung" + } elsif(not(strcmp(gottenValue, "0"))) { + "\nas an infant" + } elsif(not(strcmp(gottenValue, "infancy"))) { + "\nas an infant" + } else { + "\nat age " + strxlat(tex_xlat, gottenValue) + } + } +} + + +proc ofCause(event) { + call getValueCont(event, "CAUS") + if(gotValue) { + "\nof " + strxlat(tex_xlat, gottenValue) + } +} + + +proc onDate(event) { + if(atmax_generation) { + if(global_dead) { + set(year_only,0) + } else { + set(year_only,1) + } + } else { + set(year_only,0) + } + call setDayNumber(event) + if(d, date(event)) { + if(strcmp(d, "Not married")) { + if(eq(strcmp(d, ""),0)) { "\nin \\nodate\\ " } + elsif(eq(index(d, "AFT", 1), 1)) { "\nsome time after " } + elsif(eq(index(d, "Aft", 1), 1)) { "\nsome time after " } + elsif(eq(index(d, "BEF", 1), 1)) { "\nsome time before " } + elsif(eq(index(d, "Bef", 1), 1)) { "\nsome time before " } + elsif(eq(index(d, "ABT", 1), 1)) { "\ncirca " } + elsif(eq(index(d, "Abt", 1), 1)) { "\ncirca " } + elsif(eq(index(d, "FROM", 1), 1)) { + set(t, index(d, "TO", 1)) +/* +DAB - experimental (and not working) + set(fromDateEvent, createnode("EVEN", "")) + set(fromDateNode, createnode("DATE", substring(d, add(1, strlen("FROM")), sub(t, 1)) )) + addnode(fromDateNode, fromDateEvent, 0) + set(toDateEvent, createnode("EVEN", "")) + set(toDateNode, createnode("DATE", substring(d, add(t, strlen("TO")), strlen(d)) )) + addnode(toDateNode, toDateEvent, 0) +DEBUG: + "\n from date nodes: " + traverse(fromDateEvent, xx, yy) { + d(yy) ": " tag(xx) " " value(xx) + } + "\n to date nodes: " + traverse(toDateEvent, xx, yy) { + d(yy) ": " tag(xx) " " value(xx) + } + + "\nfrom " stddate(fromDateEvent) + " to " stddate(toDateEvent) + deletenode(toDateNode) + deletenode(toDateEvent) + deletenode(fromDateNode) + deletenode(fromDateEvent) +DAB - end of experimental +*/ + +/* DAB - This way work, but doesn't necessarily produce dates in the same + format as stddate +*/ + "\nfrom " substring(d, add(1, strlen("FROM")), sub(t, 1)) + " to " substring(d, add(t, strlen("TO")), strlen(d)) + set(event, 0) + } elsif(i, index(d, "-", 1)) { + "\nbetween " substring(d, 1, sub(i, 1)) + " and " substring(d, add(i, 1), strlen(d)) + set(event, 0) + } elsif(and(dayNumber, eq(dayNumber, previousDayNumber))) { + "\non the same day" + set(event, 0) + } elsif(and(dayNumber, eq(dayNumber, add(previousDayNumber, 1)))) { + "\non the next day" + set(event, 0) + } elsif(and(dayNumber, eq(dayNumber, add(previousDayNumber, 2)))) { + "\ntwo days later" + set(event, 0) + } elsif(and(dayNumber, eq(dayNumber, add(previousDayNumber, 7)))) { + "\none week later" + set(event, 0) + } else { + if(year_only) { "\nin " + } else { + extractdate(event, d, m, y) + if(d) { "\non " } else { "\nin " } + } + } + if(event) { + if(and(dayNumber, eq(dayNumber, previousDayNumber))) { + "that day" + } else { + if(year_only) { + year(event) + } else { + stddate(event) + } + } + } + } + } +} + +proc getValue(root, t) { + set(gotValue, 0) + if(root) { + fornodes(root, node) { + if(and(not(gotValue), not(strcmp(tag(node), t)))) { + set(gotValue, 1) + set(gottenNode, node) + set(gottenValue, save(value(node))) + } + } + } +} + + +proc getValueCont(root, t) { + set(gotValue, 0) + if(root) { + fornodes(root, node) { + if(and(not(gotValue), not(strcmp(tag(node), t)))) { + set(gotValue, 1) + set(gottenNode, node) + set(gottenValue, save(value(node))) + fornodes(node, subnode) { + if(not(strcmp("CONT", tag(subnode)))) { + /* If you want empty CONT tags to not leave a blank line, uncomment the following "if". + * However, a blank line can be very useful (or even necessary) for some TeX formatting. + */ + /*if(strlen(value(subnode))) {*/ + set(gottenValue, + save(concat(gottenValue, "\n", value(subnode)))) + /*}*/ + } elsif(not(strcmp("CONC", tag(subnode)))) { + /* Same comment as above, this time for CONC tags */ + /*if(strlen(value(subnode))) {*/ + set(gottenValue, + save(concat(gottenValue, value(subnode)))) + /*}*/ + } + } + } + } + } +} + + +proc getValueCommaCont(root, t) { + set(gotValue, 0) + if(root) { + fornodes(root, node) { + if(and(not(gotValue), not(strcmp(tag(node), t)))) { + set(gotValue, 1) + set(gottenNode, node) + set(gottenValue, save(value(node))) + fornodes(node, subnode) { + if(not(strcmp("CONT", tag(subnode)))) { + if(strlen(value(subnode))) { + set(gottenValue, + save(concat(gottenValue, ",\n", value(subnode)))) + } + } elsif(not(strcmp("CONC", tag(subnode)))) { + if(strlen(value(subnode))) { + set(gottenValue, + save(concat(gottenValue, value(subnode)))) + } + } + } + } + } + } +} + + +proc aAn(s) { + set(s, save(trim(lower(s), 1))) + if(not(strcmp(s, "a"))) { "an" } + elsif(not(strcmp(s, "e"))) { "an" } + elsif(not(strcmp(s, "i"))) { "an" } + elsif(not(strcmp(s, "o"))) { "an" } + elsif(not(strcmp(s, "u"))) { "an" } + elsif(not(strcmp(s, "x"))) { "an" } + else { "a" } +} + + +func printablefirstname(i) { + set(firstname, givens(i)) + if(eq(strcmp(firstname, ""), 0)) { + set(namereturn, save("\\noname")) + } else { + set(where, index(firstname, " ", 1)) + /* don't print out middle names */ + if(gt(where, 0)) { + set(namereturn, save(substring(firstname, 1, sub(where, 1)))) + } else { + set(namereturn, save(firstname)) + } /* if no middle names */ + set(namereturn, strxlat(tex_xlat, namereturn)) + } + return(namereturn) +} + +proc iswas(indi) { + call setDayNumber(birth(indi)) + if(or(death(indi), or(not(dayNumber), lt(dayNumber, 693971)))) { + "\nwas" + } else { + "\nis" + } +} + + +/* Check to see if this family might still have children at some point: + If one spouse is dead, too old, or they are divorced; then they won't. +*/ +proc havehadchildren(indi, spouse) { + call setDayNumber(birth(indi)) + set(indiDayNumber, dayNumber) + call setDayNumber(birth(spouse)) + set(divp, 0) + spouses(indi, s, f, n) { + if(eq(s, spouse)) { + call getValue(fnode(f), "DIV") + set(divp, gotValue) + break() + } + } + if( + or( + death(indi), + or(not(indiDayNumber), lt(indiDayNumber, 693971)), death(spouse), + or(not(dayNumber), lt(dayNumber, 693971)), + divp + )) { + "\\ had no children.\n" + } else { + "\\ have no children.\n" + } +} + +/* illegit_check gives people a break. If we have no marriage record, + the assumption still is that the couple were married and that + is the word we stick in the text. + Only if it specifically says they were not married, do we + state that they weren't +*/ +proc illegit_check(fam) { + set(not_married_flag, 0) + if(e,marriage(fam)) { + if(d, date(e)) { + if(not(strcmp(d, "Not married"))) { + set(not_married_flag, 1) + } + } + } +} + + +proc sourceIt(sourceList) { + list(cList) + list(fList) + set(cn, 0) + while(root, dequeue(sourceList)) { + fornodes(root, node) { + if(not(strcmp( tag(node), "SOUR"))) { + set(footnote, 1) + set(val, value(node)) + if(val) { + if(reference(val)) { + call bibliographize(dereference(val)) + } + } + if(xref(node)) { + call bibliographize(node) + set(val, xref(node)) + } + if(val) { + set(a1, index(val, "@", 1)) + set(a2, index(val, "@", 2)) + if(and(eq(a1, 1), eq(a2, strlen(val)))) { + set(c, save(substring(val, 2, sub(strlen(val), 1)))) + enqueue(cList, c) + incr(cn) + set(footnote, 0) + } + } else { + set(subnodecount, 0) + fornodes(node, subnode) { + if(strcmp(tag(subnode), "SOUR")) { + incr(subnodecount) + } + } + if(eq(subnodecount, 0)) { + fornodes(node, subnode) { + set(val, value(subnode)) + /* With loadsources, this is needed here. It is technically + illegal gedcom. + */ + if(xref(subnode)) { + call bibliographize(subnode) + set(val, xref(subnode)) + } + if(val) { + set(a1, index(val, "@", 1)) + set(a2, index(val, "@", 2)) + if(and(eq(a1, 1), eq(a2, strlen(val)))) { + set(c, save(substring(val, 2, sub(strlen(val), 1)))) + enqueue(cList, c) + incr(cn) + } + } + } + set(footnote, 0) + } + } + if(footnote) { + enqueue(fList, node) + } + } + } + } + while(cn) { + forlist(cList, c, n) { + if(and(ne(n, cn), not(strcmp(c, getel(cList, cn))))) { + setel(cList, cn, "") + } + } + decr(cn) + } + if(not(empty(fList))) { + "\n\\footnote{" + while(f, dequeue(fList)) { + set(first, 1) + call getValueCont(f, "TITL") + if(gotValue) { + if(not(first)) { ", " } else { set(first, 0) } + "\n" + strxlat(tex_xlat, gottenValue) + } + call getValueCont(f, "DATE") + if(gotValue) { + if(not(first)) { ", " } else { set(first, 0) } + "\n" + strxlat(tex_xlat, gottenValue) + } + call getValueCont(f, "PLAC") + if(gotValue) { + if(not(first)) { ", " } else { set(first, 0) } + "\n" + strxlat(tex_xlat, gottenValue) + } + call getValueCont(f, "VOLU") + if(gotValue) { + if(not(first)) { ", " } else { set(first, 0) } + if( + or(index(gottenValue, "-", 1), + index(gottenValue, ",", 1), + index(gottenValue, "and ", 1) + )) { + "\nVolumes " + } else { + "\nVolume " + } + strxlat(tex_xlat, gottenValue) + } + call getValueCont(f, "PAGE") + if(gotValue) { + if(not(first)) { ", " } else { set(first, 0) } + if( + or(index(gottenValue, "-", 1), + index(gottenValue, ",", 1), + index(gottenValue, "and ", 1) + )) { + "\nPages " + } else { + "\nPage " + } + strxlat(tex_xlat, gottenValue) + } + call getValueCont(f, "FILM") + if(gotValue) { + if(not(first)) { ", " } else { set(first, 0) } + "on Latter Day Saints Microfilm Number " + strxlat(tex_xlat, gottenValue) + } + + call getValueCont(f, "TEXT") + if(gotValue) { + set(first, 0) + "\n" + strxlat(tex_xlat, gottenValue) + } + if(not(first)) { "\\@." } + call getValueCont(f, "NOTE") + if(gotValue) { + set(first, 0) + "\n" + strxlat(tex_xlat, gottenValue) + } + if(and(first, not(value(f)))) { "\n" } + call values(f) + } + "}" + } + if(not(empty(cList))) { + "\\cite{" + while(c, dequeue(cList)) { + if(strlen(c)) { + if(cn) { "," } + c + incr(cn) + } + } + "}" + } +} + +proc bibliographize(root) { + set(val, xref(root)) + set(c, save(substring(val, 2, sub(strlen(val), 1)))) + + if(not(lookup(bibTable, c))) { + insert(bibTable, c, 1) + +/* + call getValueCont(root, "TEXT") + if(figureFlag, gotValue) { + enqueue(figureCiteList, c) + enqueue(figureNodeList, gottenNode) + } +*/ + set(cref, save(concat("\\protect\\ref{", c, "}"))) + set(pref, save(concat("\\protect\\pageref{", c, "}"))) + + set(b, "\\bibitem") + if(figureFlag) { + set(b, save(concat(b, "[", cref, "]"))) + } + set(b, save(concat(b, "{", c, "} "))) + call getValueCont(root, "TITL") + if(gotValue) { + set(b, save(concat(b, "{\\em ", strxlat(tex_xlat, gottenValue), "}, "))) + } + call getValueCont(root, "AUTH") + if(gotValue) { + set(b, save(concat(b, " ", strxlat(tex_xlat, gottenValue), ", "))) + set(authnode, gottenNode) + call getValueCont(authnode, "EMAI") + if(gotValue) { + if(opt_email) { + set(b, save(concat(b, strxlat(tex_xlat, gottenValue), ", "))) + } else { + set(b, save(concat(b, "e-mail address on file, "))) + } + } + } + call getValueCont(root, "PUBL") + if(gotValue) { + set(pubnode,gottenNode) + call getValueCont(pubnode, "NAME") + if(gotValue) { + set(b, save( + concat(b, "in {\\em ", strxlat(tex_xlat, gottenValue), "}, "))) + } + call getValueCommaCont(pubnode, "ADDR") + if(gotValue) { + set(b, save( + concat(b, strxlat(tex_xlat, gottenValue), ": "))) + } + call getValueCont(pubnode, "PUBR") + if(gotValue) { + set(b, save( + concat(b, strxlat(tex_xlat, gottenValue), ", "))) + } + call getValueCont(pubnode, "PHON") + if(gotValue) { + set(b, save(concat(b, strxlat(tex_xlat, gottenValue), ", "))) + } + call getValueCont(pubnode, "DATE") + if(gotValue) { + set(b, save( + concat(b, strxlat(tex_xlat, gottenValue), ", "))) + } + call getValueCont(pubnode, "VOLU") + if(gotValue) { + set(word, "Volume ") + if( + or(index(gottenValue, "-", 1), + index(gottenValue, ",", 1), + index(gottenValue, "and ", 1) + )) { + set(word, "Volumes ") + } + set(b, save(concat(b, word, strxlat(tex_xlat, gottenValue), ", "))) + } + call getValueCont(pubnode, "NUM") + if(gotValue) { + set(word, "Number ") + if( + or(index(gottenValue, "-", 1), + index(gottenValue, ",", 1), + index(gottenValue, "and ", 1) + )) { + set(word, "Numbers ") + } + set(b, save(concat(b, word, strxlat(tex_xlat, gottenValue), ", "))) + } + call getValueCont(root, "LCCN") + if(gotValue) { + set(b, save( + concat(b, "Call Number ", strxlat(tex_xlat, gottenValue), ", "))) + } + } + call getValueCont(root, "PAGE") + if(gotValue) { + set(word, "page ") + if( + or(index(gottenValue, "-", 1), + index(gottenValue, ",", 1), + index(gottenValue, "and ", 1) + )) { + set(word, "pages ") + } + set(b, save(concat(b, word, strxlat(tex_xlat, gottenValue), ", "))) + } + call getValueCont(root, "FILM") + if(gotValue) { + set(b, save(concat(b, + "Filmed by the Church of Jesus Christ of Latter Day Saints, ", + "Microfilm Number ", + strxlat(tex_xlat, gottenValue), ", "))) + } + call getValueCont(root, "FICH") + if(gotValue) { + set(b, save(concat(b, + "Filmed by the Church of Jesus Christ of Latter Day Saints, ", + "Microfiche Number ", + strxlat(tex_xlat, gottenValue), ", "))) + } + call getValueCont(root, "REPO") + if(gotValue) { + set(b, save(concat(b, "at ", strxlat(tex_xlat, gottenValue), ", "))) + } + + if(index(b, ", ", 1)) { + set(b, save(concat(save(substring(b, 1, sub(strlen(b), 2))), "."))) + } + + call getValueCont(root, "NOTE") + if(gotValue) { set(b, save(concat(b, " ", strxlat(tex_xlat, gottenValue)))) } + + call getValueCont(root, "TEXT") + if(gotValue) { set(b, save(concat(b, " ", strxlat(tex_xlat, gottenValue)))) } + + call getValueCont(root, "HIDE") + if(gotValue) { set(b, save(concat(b, " ", strxlat(tex_xlat, gottenValue)))) } + + call getValueCont(root, "SOUR") + if(gotValue) { + set(bb, "?") + if(gottenValue) { + set(a1, index(gottenValue, "@", 1)) + set(a2, index(gottenValue, "@", 2)) + if(and(eq(a1, 1), eq(a2, strlen(gottenValue)))) { + set(bb, save(substring(gottenValue, 2, sub(strlen(gottenValue), 1)))) + } + } + set(b, save(concat(b, "\\cite{", strxlat(tex_xlat, bb), "}"))) + } + + if(figureFlag) { + set(b, save(concat(b, " See figure on page~", pref, "."))) + } + + /* This while loop undoes the line breaking in a CONT/CONC. + Since those line breaks can be + significant, it is commented out. + */ +/* + while(i, index(b, "\n", 1)) { + set(b, save( + concat( + substring(b, 1, sub(i, 1)), + " ", + substring(b, add(i, 1), strlen(b)) + ) )) + } +*/ + enqueue(bibList, save(concat(b, "\n"))) + } +} + + +proc getText(root, paragraph) { + set(pronounOkay, 1) + if(root) { + if(eq(1,notes_text_mode)) { /* only 1 TEXT records */ + fornodes(root, node) { + if(not(strcmp("TEXT", tag(node)))) { + set(pronounOkay, 0) + if(paragraph) { + "\n\n" set(paragraph, 0) + } + call values(node) + "\n\n" + } + } + } else { + if(eq(2,notes_text_mode)) { /* all 1 NOTE records */ + fornotes(root, note) { + if(paragraph) { + "\n\n" set(paragraph, 0) + } + strxlat(tex_xlat, note) + "\n\n" + set(pronounOkay, 0) + } + } else { /* only !-tagged 1 NOTE records (1st char must be !) */ + fornotes(root, note) { + set(i, index(note,"!",1)) + if(eq(1,i)) { + set(pronounOkay, 0) + if(paragraph) { + "\n\n" set(paragraph, 0) + } + strxlat(tex_xlat, substring(note, 2, strlen(note))) + "\n\n" + } + } + } + } + } + /* if we printed any notes, then reset things so we don't use + "there" in place names right after the notes. + */ + if(not(pronounOkay)) { + insert(eventPlaceTable, "@there@", "") + } +} + +proc values(root) { + if(root) { + if(strlen(value(root))) { "\n" strxlat(tex_xlat, value(root)) } + fornodes(root, node) { + if(not(strcmp("CONT", tag(node)))) { + if(strlen(value(node))) { + "\n" strxlat(tex_xlat, value(node)) + } + } elsif(not(strcmp("CONC", tag(node)))) { + if(strlen(value(node))) { + strxlat(tex_xlat, value(node)) + } + } + } + if(root) { + enqueue(sourceList, root) + } + call sourceIt(sourceList) + } +} + + +/********************************************************************/ +/* below here are routines for printing descendant charts */ +/* + * These are adapted from desc-tex + * By Eric Majani (eric@elroy.jpl.nasa.gov) + */ + +proc desc_chart_main3(indi) { + "\\tree\n" + call desc_chart_out(indi,3,1) + "\\endtree\n" +} + + +proc descch_indi(indi) { + "{\\bf " call desc_chart_name(indi) "}" + if(or(birth(indi),death(indi))) { + " " + if(e, birth(indi)) { + year(e) + } + "-" + if(e, death(indi)) { + year(e) + } + } + nl() + families(indi,fam,sp,num) { + if(e,marriage(fam)) { + " m. " short(e) nl() + } + } +} + + +proc desc_chart_name(i) { + set(whole, givens(i)) + set(space,index(whole, " ", 1)) + if(gt(space, 0)) { + strxlat(tex_xlat, substring(whole, 1, space)) + } else { + strxlat(tex_xlat, whole) " " + } + if(eq(strcmp(surname(i), "____"), 0)) { + " \\noname" + } else { + strxlat(tex_xlat, surname(i)) + } +} + + +proc descch_indinomar(indi) { + "{\\bf " call desc_chart_name(indi) "}" + if(or(birth(indi),death(indi))) { + " " + if(e, birth(indi)) { + year(e) + } + "-" + if(e, death(indi)) { + year(e) + } + } + nl() +} + + +proc descch_prcouple(indi,fam,num) { + if(eq(num,1)) { + "{\\bf " + call desc_chart_name(indi) + "}" + if(e, birth(indi)) { + " " year(e)"-" + } + if(e, death(indi)) { + if(not(birth(indi))) { + " -" + } + year(e) + } + } + nl() + +/* I can't remember why I put this IF in here. I guess I'll take it out + and see what breaks! +*/ +/* + if(eq(num,nfamilies(indi))) { +*/ + if(e,marriage(fam)) { + " m. " year(e) " " + } else { + "m.\\ \\ \\ \\ \\ \\ " + } /* space over without date */ + /*}*/ +} + + +proc descch_printfam(indi,fam,sp) { + "\\spouse{ " call desc_chart_name(sp) "}" nl() +} + + +proc desc_chart_out(indi,depth,level) { + if(or(eq(0,nfamilies(indi)),eq(depth,level))) { + call descch_indinomar(indi) + } + if(lt(level,depth)) { + families(indi,fam,sp,num) { + call descch_prcouple(indi,fam,num) + call descch_printfam(indi,fam,sp) + set(level,add(level,1)) + set(num2,0) + if(le(level,depth)) { + children(fam,child,num2) { + "\\subtree " nl() + call desc_chart_out(child,depth,level) + "\\endsubtree " nl() + } + } + set(num2,nchildren(fam)) + set(level,sub(level,1)) + set(temp1,ne(num,nfamilies(indi))) + set(temp2,gt(num2,0)) + if(and(temp1,temp2)) +/* + if(ne(num,nfamilies(indi))) +*/ + { + if(eq(level,1)) { + "\\endtree " nl() + "\\tree " nl() + } else { + "\\endsubtree " nl() + "\\subtree " nl() + } + } + } + } +} + +proc excursion(indi) { + list(anclist) + indiset(ancset) + + "\n\\section{" strxlat(tex_xlat, surname(indi)) " Ancestors" "}" "\n" + "\\label{" key(indi) "-excur-ref}" "\n" + + /* get us to the patriarch of the line.*/ + set(thisguy,indi) + addtoset(ancset,thisguy,0) + while(father(thisguy)) { + set(thisguy,father(thisguy)) + push(anclist,thisguy) + addtoset(ancset,thisguy,0) + } + "The " strxlat(tex_xlat, surname(indi)) " line has been traced back to " + call texname(inode(thisguy), 0) "." + + while(indi,pop(anclist)) { + print("Excursion: ") print(name(indi)) print("\n") + call longvitals(indi,1,2) + families(indi, fam, spouse, nfam) { + "\n\n" + if(eq(0, nchildren(fam))) { + call texname(inode(indi), 0) "\\ and " + if(spouse) { + call texname(inode(spouse), 0) + } else { + "\\noname" + } + call havehadchildren(indi, spouse) + } elsif(and(spouse, lookup(stab, key(spouse)))) { + "Children of " call texname(inode(indi), 0) "\\ and " + call texname(inode(spouse), 0) "\\ are shown under " + call texname(inode(spouse), 0) + "(" d(lookup(stab, key(spouse))) ").\n\n" + } else { + "Children of " call texname(inode(indi), 0) "\\ and " + if(spouse) { + call texname(inode(spouse), 0) + } else { + "\\noname" + } + ":\n\\begin{childrenlist}\n" + children(fam, child, nchl) { + "\n\\item " + set(personIsAnc,0) + forindiset(ancset,them,val,num) { + if(eq(them, child)) { + set(personIsAnc,1) + } + } + if(personIsAnc) { + "**" call shortvitals(child) + } else { + call longvitals(child, 0,2) + } + addtoset(idex, child, 0) + } + "\\end{childrenlist}\n" + } + } + } + "\n\n\n" +} + +/* +** function: strxlat +** +** This idea was copied and/or adapted from Jim Eggert's modification +** to the ps-circ(le) program for LifeLines. +** A typical call would look like: +** set(str, strxlat(tex_xlat, name(person))) +** which would translate characters in person's name according to the +** table called tex_xlat -- which escapes the special characters being +** displayed as text via LaTeX. The output is assigned to str. +** The output of strxlat() can also be sent directly to output. +** +*/ + +func strxlat(xlat, string) { + if(opt_xlat) { + set(fixstring, "") + set(pos, 1) + while(le(pos, strlen(string))) { + set(char, substring(string, pos, pos)) + if(special, lookup(xlat, char)) { + set(fixstring, concat(fixstring, special)) + } else { + set(fixstring, concat(fixstring, char)) + } + incr(pos) + } + } else { + set(fixstring, string) + } + return(save(fixstring)) /* save() is used for compatibilty with older LL */ +} + diff --git a/reports/browser.ll b/reports/browser.ll new file mode 100644 index 0000000..ecacb6d --- /dev/null +++ b/reports/browser.ll @@ -0,0 +1,76 @@ +/* + * @progname browser.ll + * @version 1.0 + * @author Prinke + * @category + * @output onscreen + * @description + + browsing via all kinds of links, especially in non-standard + or experimental GEDCOM structures + + browser.ll v.1.0 Rafal T. Prinke -- 19 APR 1997 -- rafalp@hum.amu.edu.pl + +*/ + + +proc main() +{ + list(back) + list(backhdr) + getindi(p, "Person to start with: ") + if(not(p)) { break() } + set(i, savenode(root(p))) + set(hdr, concat("*** INDI: ", name(p,0)," ***")) + set(bh, "----- BACK") + while(i) { + list(mnu) + list(gto) + enqueue(gto,0) + enqueue(gto,0) + enqueue(mnu,"----- STOP") + enqueue(mnu,bh) + + traverse (i, node, x) { + if (reference(value(node))) { + set (n, dereference(value(node))) + enqueue(gto, savenode(n)) + +if(eq(substring(value(node),1,2),"@I")) { + set(show,concat("INDI: ", name(indi(value(node)),0))) } +elsif(eq(substring(value(node),1,2),"@S")) { + set(show,concat("SOUR: ", value(child(n)) )) } +elsif(eq(substring(value(node),1,2),"@E")) { + set(show,concat("EVEN: ", value(child(n)) )) } +elsif(eq(substring(value(node),1,2),"@F")) { + set(show,concat("FAM: ", name(husband(fam(value(node))),0), + " & ", name(wife(fam(value(node))),0))) } +else { set(show, concat("OTHER:",value(child(node)))) } + + enqueue(mnu, show) + } + } + set(why, menuchoose(mnu, hdr)) + + if(eq(why, 1)) { break() } + + elsif(eq(why, 2)) { + if(empty(back)) { + set(bh, "-- THIS IS THE FIRST RECORD - CAN'T GO BACK --") + push(back, savenode(i)) + push(backhdr, hdr) + } + set(i, pop(back)) + set(hdr, pop(backhdr)) + } + else { + push(back, savenode(i)) + push(backhdr, hdr) + set(nd, getel(gto, why)) + set(hdr, concat("*** ",getel(mnu, why)," ***")) + set(i, nd) + set(bh, "----- BACK") + + } + } +} diff --git a/reports/burial_index.ll b/reports/burial_index.ll new file mode 100644 index 0000000..6023758 --- /dev/null +++ b/reports/burial_index.ll @@ -0,0 +1,226 @@ +/* + * @progname burial_index.ll + * @version 1.0 + * @author Nicklaus + * @category + * @output Text + * @description + + Write an (unsorted) list of every person in the database + whose burial place contains a requested string + (which is the "town" that this report asks for). + It matches for the town anywhere in the place field. + so town can also be a state or county. + Personally, many of my relatives are from Iowa, so I like to make + a file of everyone buried in Iowa by entering Iowa to the prompt. + + + For MY typical record, which looks like + 1 NAME First /Last/ + 1 BIRT + 2 DATE 31 Dec 1900 + 1 DEAT + 2 DATE 1 Jan 2000 + 1 BURI + 2 PLAC town,county,state + 3 ADDR cemeteryname (technically should be 2 ADDR acc. to new GEDCOM std.) + + burial_index produces a line which looks like: + + town,cemeteryname : Last, First (1900-2000) + + If your database looks like: + 1 BURI + 2 PLAC cemeteryname,town,county,state + Then you'll probably want to change this report around a bit. Where + I do: "getel(parts,1)", you'll want: "getel(parts,2) getel(parts,1)". + + For married women, it attempts to make their name what it may + be on their tombstone, that is, the surname of their first + husband, but includes a "nee" (= "born", but without the accent mark) + and the maiden name. This generally works great for the standard + once-married person. If a woman was married multiple times, + it puts all the husbands' surnames on there, starting with the first + husband, ending with the maiden surname. So my ancestor, Ruth, + maiden surname Matthews, who first married E. Scott, 2nd J. Alkire, + and 3rd married N. Bates, gets an entry like this: + Scott, a.k.a. Alkire, a.k.a. Bates, nee Matthews, Ruth (1831-1917) + where a.k.a. stands for "also known as". In doing all this, + it'll (possibly wrongly) assume both that a woman was married and took + on the father's surname for any family she was a parent in. + It's pretty tough to cover every case automatically, so you just + have to examine and edit the output when it's done if you care. + + It is probably useful to run the output of this through Unix sort. + There is also a companion program, bury.c, which reformats the sorted + output to make it prettier. + + An example is at: http://www.geocities.com/grandmashannon/iowa_burials.txt + + Written 1999, Dennis Nicklaus, nicklaus@fnal.gov + +*/ + +proc main () +{ + list(parts) + getstrmsg(town, "Enter town for burial index") + set (town,save(town)) + + print("Looking for ") print(town) + + " Burials in " town "\n" + forindi(person, number) { + set(e,burial(person)) + + if (and(e,place(e))) { + if (index(place(e),town,1)) { + extractplaces(e,parts,np) + getel(parts,1) + call doSite(e) " : " + if (female(person)) { + /* print out married surnames of women */ + set(nffam,nfamilies(person)) + families(person,fam,sp,spi) { + surname(sp) + if (eq(spi,nffam)) { + /* the next IF is designed to catch a + case where a woman + had one child where the father wasn't + known and she didn't otherwise marry. + In that case, just her maiden + surname will appear, no "nee". + Odd cases will still circumvent this, + and make things look odd, such as + multiple kids by different unknown + fathers, ... I don't care. */ + + if (or(sp,gt(nffam,1))) { + ", nee " + } + } + else { + /* cover the case where the father's + name isn't known at all. Don't + print an extra "a.k.a". + odd cases will still look bad, + such as married, then mother with + unknown father. */ + if (sp) { + ", a.k.a. " + } + } + } + } + fullname(person,0,0,80) + " (" year(birth(person)) "-" year(death(person)) ")" + "\n" + } + } + } +} +proc doSite(event) +{ + fornodes(event, subnode) { + if (eq(0,strcmp("PLAC", tag(subnode)))) { + fornodes(subnode, subnode2) { + if (eq(0,strcmp("ADDR", tag(subnode2)))) { + ", " value(subnode2) + }}}} +} + + + +/* bury.c. + Written 1999, Dennis Nicklaus, nicklaus@fnal.gov + This program is used as a filter to help format the output of the + Lifelines report called "burial_index". + This program makes it so each cemetery name only appears once, with + the list of people buried in that cemetery listed below it. + You can compile this simply with: + cc -o bury bury.c + To use this, first run the burial index program, then run the + output of that through Unix's sort (just default arguments to sort), + then run it through this program. Suppose your output from burial + index is called "iowa.txt". + What I typically do is: + sort iowa.txt | bury > iowa.sort + + How it works: It just compares each "cemetery name" with the previous one + in the file. If the cemetery name is different, it begins a new heading + for that cemetery, and lists under it each name that follows with the + same cemetery name. That's why it's important to run through sort, first. + For MY typical record, which looks like + 1 NAME First /Last/ + 1 BIRT + 2 DATE 31 Dec 1900 + 1 DEAT + 2 DATE 1 Jan 2000 + 1 BURI + 2 PLAC town,county,state + 3 ADDR cemeteryname + The lifelines report burial_index produces a line which looks like: + + town,cemetery : Last, First (1900-2000) + + Since I generally make a index for a town, county, or state, running + sort with default (no) parameters works for me. + These sorted lines are the input to this program. +*/ +/* Start C code. +#include +char getline (char *line) +{ + char c; + int in=0; + c=getchar(); + while ((c != '\n') && (c != EOF)){ + line[in++] = c; + c=getchar(); + } + line[in]=0; + return c; +} +main() +{ + char line[200],last[200],*name; + int colon,in,maxcompare; + while(getline(line) != EOF){ + colon = strcspn(line,":"); + maxcompare = strlen(last); + if (colon > maxcompare) maxcompare = colon; + if (strncmp(line,last,maxcompare)){ + strncpy(last,line,colon); + last[colon] = '\0'; + printf("\n\t\t\t%s\n",last); + } + name = line+colon+1; + printf("%s\n",name); + } +} + end of C code */ +/* Sample output after going through bury.c: + Carlisle, Carlisle Cemetery + Morgan, Chester Howell (1889-1900) + Morgan, Elmer Eugene (1861-1931) + Morgan, nee Dressler, Mary Alice (1861-1950) + + Carroll + Walden, nee Lucey, Kathleen J. ``Kay'' (1918-1996) + + Carroll, Mt. Olivet Cemetery + Foley, George (1878-1948) + Foley, nee Cuddy, Mary Cornelia (1885-1972) + Hamill, Robert J. (1872-1953) + Hamill, nee Lucey, Jennie Frances (1874-1940) + Lucey, Edward J. (1849-1922) + Lucey, George Raymond (1884-1971) + Lucey, Rosemary (1920-1951) + Lucey, nee Kemp, Clara Catherine (1887-1969) + Lucey, Jeremiah ``Jerry'' (1886-1914) + Lucey, John (1883-1914) + Lucey, Julia (-1914) + Lucey, Margaret (-1914) + Lucey, nee Grace, Mary Elizabeth (1856-1914) + +*/ diff --git a/reports/bury.c b/reports/bury.c new file mode 100644 index 0000000..35faa97 --- /dev/null +++ b/reports/bury.c @@ -0,0 +1,92 @@ +/* bury.c. + Written 1999, Dennis Nicklaus, nicklaus@fnal.gov + This program is used as a filter to help format the output of the + Lifelines report called "burial_index". + This program makes it so each cemetery name only appears once, with + the list of people buried in that cemetery listed below it. + You can compile this simply with: + cc -o bury bury.c + To use this, first run the burial index program, then run the + output of that through Unix's sort (just default arguments to sort), + then run it through this program. Suppose your output from burial + index is called "iowa.txt". + What I typically do is: + sort iowa.txt | bury > iowa.sort + + How it works: It just compares each "cemetery name" with the previous one + in the file. If the cemetery name is different, it begins a new heading + for that cemetery, and lists under it each name that follows with the + same cemetery name. That's why it's important to run through sort, first. + For MY typical record, which looks like + 1 NAME First /Last/ + 1 BIRT + 2 DATE 31 Dec 1900 + 1 DEAT + 2 DATE 1 Jan 2000 + 1 BURI + 2 PLAC town,county,state + 3 ADDR cemeteryname + The lifelines report burial_index produces a line which looks like: + + town,cemetery : Last, First (1900-2000) + + Since I generally make a index for a town, county, or state, running + sort with default (no) parameters works for me. + These sorted lines are the input to this program. +*/ + +#include +char getline (char *line) +{ + char c; + int in=0; + c=getchar(); + while ((c != '\n') && (c != EOF)){ + line[in++] = c; + c=getchar(); + } + line[in]=0; + return c; +} +main() +{ + char line[200],last[200],*name; + int colon,in,maxcompare; + while(getline(line) != EOF){ + colon = strcspn(line,":"); + maxcompare = strlen(last); + if (colon > maxcompare) maxcompare = colon; + if (strncmp(line,last,maxcompare)){ /* then they are different */ + strncpy(last,line,colon); + last[colon] = '\0'; + printf("\n\t\t\t%s\n",last); + } + name = line+colon+1; + printf("%s\n",name); + } +} +/* Sample output after going through bury.c: + Carlisle, Carlisle Cemetery + Morgan, Chester Howell (1889-1900) + Morgan, Elmer Eugene (1861-1931) + Morgan, nee Dressler, Mary Alice (1861-1950) + + Carroll + Walden, nee Lucey, Kathleen J. ``Kay'' (1918-1996) + + Carroll, Mt. Olivet Cemetery + Foley, George (1878-1948) + Foley, nee Cuddy, Mary Cornelia (1885-1972) + Hamill, Robert J. (1872-1953) + Hamill, nee Lucey, Jennie Frances (1874-1940) + Lucey, Edward J. (1849-1922) + Lucey, George Raymond (1884-1971) + Lucey, Rosemary (1920-1951) + Lucey, nee Kemp, Clara Catherine (1887-1969) + Lucey, Jeremiah ``Jerry'' (1886-1914) + Lucey, John (1883-1914) + Lucey, Julia (-1914) + Lucey, Margaret (-1914) + Lucey, nee Grace, Mary Elizabeth (1856-1914) + +*/ diff --git a/reports/cgi_html.li b/reports/cgi_html.li new file mode 100644 index 0000000..c514f51 --- /dev/null +++ b/reports/cgi_html.li @@ -0,0 +1,174 @@ +/* + * @progname cgi_html.li + * @version 1.4 + * @author Scott McGee (smcgee@microware.com) + * @category + * @output HTML + * @description + +This is a library of CGI based functions and data used by a variety of +CGI GenWeb programs. It also provides all needed customizing data in one +file to allow easy customization of the genweb CGI system to a new site. + +The proc set_cgi_globals() should be called early in programs using this +library, before any other calls to its code are made. This proc sets the +customization globals. + +The do_head() proc will output the header info for the html files. The +input parameters are the individual for whom the file is generated, and the +title string which would usually be Pedigree, Descendant, or Individual to +indicate the type of file produced. + +The do_tail() proc is similar but writes the trailer info or the html file. +It too requires you to pass the indi for whom the file is generated. + +The href() function will return a string containing an anchor linking to +the indi specified as an input parameter and (via CGI) returning the type +of report specified in the second (type) parameter. This type must be one +of Pedigree, Descendant, or Lookup (for individual page). + +@(#)cgi_html.li 1.4 10/13/95 +*/ + +/* customization globals */ +global(db_owner) /* name of database owner */ +global(owner_addr) /* URL of database owner (mailto or homepage) */ +global(use_image) /* flag to indicate whether to use GenWeb image */ +global(genweb_image) /* name of GenWeb image to place on each page */ +global(use_page) /* flag to add link to GenWeb page or homepage */ +global(genweb_page) /* URL of base GenWeb (or homepage) web page */ +global(page_name) /* name of base GenWeb (or homepage) web page */ +global(cgi_script) /* URL of base CGI script */ +global(index_url) /* base URL of database index files */ +global(localhost) /* base URL for locally hosted files */ + +/* other globals */ +global(is_indi_html) /* signals if report generates an indi HTML file */ + + +/*************************************************************************** + * This function is used to initialize all the site specific customization * + * globals. This should be the only part of the entire GenWeb CGI system * + * that needed editing to install on a new site. * + **************************************************************************/ +proc set_cgi_html_globals(){ +/* customize these globals to customize the output to your site */ + set(db_owner, getproperty("user.fullname")) + set(owner_addr, getproperty("user.email")) + set(use_image, 1) /* 1 to use image, 0 to not use image */ + set(genweb_image, "http://www.emcee.com/~smcgee/pics/genweb.gif") + set(use_page, 1) /* 1 to use link to page, 0 if not */ + set(genweb_page, "http://www.emcee.com/~smcgee/genweb/genweb.html") + set(page_name, "GenWeb page") /* might change to "my homepage" */ + set(cgi_script, "http://www.emcee.com/~smcgee/cgi-bin/genweb.cgi") + set(index_url, concat("http://www.emcee.com/~smcgee/genweb/", + save(database()), "_idx.html")) + set(localhost, "http://www.emcee.com/") + + set(is_indi_html, 0) /* default to non-indi HTML report */ +} + + +/************************************************************************** + * do_chart_head() - this function writes the common header portion of an * + * HTML file. It specifies the chart type in both the and in a * + * header (<H3>) line along with the name of the individual. * + *************************************************************************/ +proc do_chart_head(indi, title){ + "<HTML><HEAD>\n" + "<TITLE>" + name(indi,0) + " : " + title + " Chart" + "\n" + "\n" + if(use_image){ + "\"\"

\n" + } + "

" + givens(indi) + " " + surname(indi) + " - " + title + " Chart

\n" +} + + +/*************************************************************************** + * do_tail() - this function writes the common trailer portion of the HTML * + * file. * + **************************************************************************/ +proc do_tail(indi){ + "
\n" + "
\n" + if(eq(is_indi_html, 0)){ /* do this stuff only for non-indi HTML reports */ + "[" + "Back to Individual Page]
" + } + "[" + "Index to database]
\n" + if(use_page){ + "[" + "Return to GenWeb page]
\n" + } + "

\n" + "HTML files created on demand by \n" + "\n" + "LifeLines, a genealogical database program by \n" + "\n" + "Thomas Wetmore!\n" + "
\n" + "Database maintained by \n" + "\n" + db_owner + "" + "
\n" + "Report generated " + date(gettoday()) + "
\n" + "\n" +} + + +/*********************************************************************** + * href() - this function will return a string with an anchor of the * + * specified type. Currently supported types are "Lookup", "Pedigree", * + * and "Descendant". * + **********************************************************************/ +func href(indi, type){ + "" + if(is_indi_html){ + if(t, title(indi)){ + t + " " + } + fullname(indi,0,1,50) + }else{ + fullname(indi,1,1,30) + } + "" +} diff --git a/reports/cid.ll b/reports/cid.ll new file mode 100644 index 0000000..04c6c61 --- /dev/null +++ b/reports/cid.ll @@ -0,0 +1,130 @@ +/* + * @progname cid.ll + * @version 1.0 + * @author Wetmore, Chandler + * @category + * @output Text + * @description + + Generates Pete Cook's CID (Chronological Identifier) for a person + in a LifeLines database. + + The program first computes the C-Vector, a + seven element array of the birth years of a person and his/her parents + and grandparents in ahnentafel order. The program then subtracts the + base person's birth year from those of the others. Those differences + are converted to the follow letters: + + Char Parent Age Grandparent Age + 0 0-15 0-30 + 1-9 16-24 31-39 + A-Z 25-50 40-65 + a-y 51-75 66-90 + z over 75 over 90 + - unknown unknown + + Version 1, 15 Mar 1995, Tom Wetmore, modified by J.F.Chandler +*/ + +proc main () +{ + getindi(i, "Compute CID for what person?") + if (eq(0, i)) { return() } + set(b, getyear(birth(i))) + if (lt(b, 1000)) { + print("Base person has no birth year") + return() + } + set(f, father(i)) + set(m, mother(i)) + set(ff, father(f)) + set(fm, mother(f)) + set(mf, father(m)) + set(mm, mother(m)) + + set(bf, getyear(birth(f))) + set(bm, getyear(birth(m))) + set(bff, getyear(birth(ff))) + set(bfm, getyear(birth(fm))) + set(bmf, getyear(birth(mf))) + set(bmm, getyear(birth(mm))) + + set(bf, sub(sub(b, bf), 15)) + set(bm, sub(sub(b, bm), 15)) + set(bff, sub(sub(b, bff), 30)) + set(bfm, sub(sub(b, bfm), 30)) + set(bmf, sub(sub(b, bmf), 30)) + set(bmm, sub(sub(b, bmm), 30)) + + print("The CID for ", name(i), " is: ", d(b), letter(bf), + letter(bm), letter(bff), letter(bfm), letter(bmf), + letter(bmm), "\n") +} + +func getyear(event) +{ + set(mod, trim(date(event),3)) + if (and( strcmp(mod,"BEF"), + strcmp(mod,"AFT"), + strcmp(mod,"ABT") )) { return(atoi(year(event))) } + return(0) +} + +func letter (yr) +{ + if (gt(yr, 500)) { return("-") } + if (lt(yr, 0)) { return("0") } + if (le(yr, 9)) { return(d(yr)) } + if (eq(yr, 10)) { return("A") } + if (eq(yr, 11)) { return("B") } + if (eq(yr, 12)) { return("C") } + if (eq(yr, 13)) { return("D") } + if (eq(yr, 14)) { return("E") } + if (eq(yr, 15)) { return("F") } + if (eq(yr, 16)) { return("G") } + if (eq(yr, 17)) { return("H") } + if (eq(yr, 18)) { return("I") } + if (eq(yr, 19)) { return("J") } + if (eq(yr, 20)) { return("K") } + if (eq(yr, 21)) { return("L") } + if (eq(yr, 22)) { return("M") } + if (eq(yr, 23)) { return("N") } + if (eq(yr, 24)) { return("O") } + if (eq(yr, 25)) { return("P") } + if (eq(yr, 26)) { return("Q") } + if (eq(yr, 27)) { return("R") } + if (eq(yr, 28)) { return("S") } + if (eq(yr, 29)) { return("T") } + if (eq(yr, 30)) { return("U") } + if (eq(yr, 31)) { return("V") } + if (eq(yr, 32)) { return("W") } + if (eq(yr, 33)) { return("X") } + if (eq(yr, 34)) { return("Y") } + if (eq(yr, 35)) { return("Z") } + if (eq(yr, 36)) { return("a") } + if (eq(yr, 37)) { return("b") } + if (eq(yr, 38)) { return("c") } + if (eq(yr, 39)) { return("d") } + if (eq(yr, 40)) { return("e") } + if (eq(yr, 41)) { return("f") } + if (eq(yr, 42)) { return("g") } + if (eq(yr, 43)) { return("h") } + if (eq(yr, 44)) { return("i") } + if (eq(yr, 45)) { return("j") } + if (eq(yr, 46)) { return("k") } + if (eq(yr, 47)) { return("l") } + if (eq(yr, 48)) { return("m") } + if (eq(yr, 49)) { return("n") } + if (eq(yr, 50)) { return("o") } + if (eq(yr, 51)) { return("p") } + if (eq(yr, 52)) { return("q") } + if (eq(yr, 53)) { return("r") } + if (eq(yr, 54)) { return("s") } + if (eq(yr, 55)) { return("t") } + if (eq(yr, 56)) { return("u") } + if (eq(yr, 57)) { return("v") } + if (eq(yr, 58)) { return("w") } + if (eq(yr, 59)) { return("x") } + if (eq(yr, 60)) { return("y") } + return("z") +} diff --git a/reports/common.ll b/reports/common.ll new file mode 100644 index 0000000..6ab8c79 --- /dev/null +++ b/reports/common.ll @@ -0,0 +1,157 @@ +/* + * @progname common.ll + * @version 0 of 1996-06-11 + * @author H. Väisänen + * @category + * @output Text + * @description + Show common ancestors of a person. + + Pedigree collapse means that someone is descended from some persons + in two or more ways. If person's father and mother are related, + this program lists the common ancestors and the people between them + and the person. + + The program probably does not work if person is descended from + common ancestors in more than two ways or if there is different + number of generations in those two ways. + + by H. Visnen + Version 0, 11 June 1996 +*/ + +proc main() +{ + getindi (person) + "Common ancestors of " name (person) "\n\n\n" + + + /* Father and his ancestors. */ + indiset (father_set) + if (f, father(person)) { + addtoset (father_set, f, 0) + set (father_set, union (father_set, ancestorset (father_set))) + } + + /* Mother and her ancestors. */ + indiset (mother_set) + if (m, mother(person)) { + addtoset (mother_set, m, 0) + set (mother_set, union (mother_set, ancestorset (mother_set))) + } + + /* Their intersection. */ + indiset (intersection_set) + set (intersection_set, intersect (father_set, mother_set)) + valuesort (intersection_set) + + /* Is minimum of v always zero? I'm not sure... */ + set (min, 10000) + forindiset (intersection_set, indi, v, n) { + if (lt(v, min)) {set (min, v)} + } + + /* First common ancestors. */ + indiset (common_ancestor_set) + forindiset (intersection_set, indi, v, n) { + if (eq(min, v)) { + addtoset (common_ancestor_set, indi, 0) + } + } + + if (eq(lengthset(common_ancestor_set), 0)) { + print ("Person's father and mother are not related.") + "Person's father and mother are not related.\n" + return() + } + + set (max_name_length, max_length (common_ancestor_set)) + + /* Print first common ancestors. */ + forindiset (common_ancestor_set, indi, v, n) { + col (20) + call print_indi (indi, v, add(max_name_length, 20)) "\n" + } + "\n" + + + /* Descendants of first common ancestors. */ + indiset (descendant_set) + set (descendant_set, descendantset(common_ancestor_set)) + + + /* Links from the father's side. */ + indiset (set1) + set (set1, intersect (descendant_set, father_set)) + valuesort (set1) + + /* Links from the mother's side. */ + indiset (set2) + set (set2, intersect (descendant_set, mother_set)) + valuesort (set2) + + + set (max_name_length, max_length(set1)) + set (length2, max_length(set2)) + + if (gt(length2, max_name_length)) {set (max_name_length, length2)} + + + + /* Print father's line on the left, mother's line on the right. */ + table (mom) + forindiset (set2, indi, v, n) { + insert (mom, d(v), indi) + } + forindiset (set1, indi, v, n) { + call print_indi (indi, v, add(max_name_length,1)) col(40) + call print_indi (lookup(mom, d(v)), v, add(max_name_length,40)) "\n" + } + + "\n" + col (20) + call print_indi (person, add(v,1), add(max_name_length, 20)) "\n" +} + + +proc print_indi (indi, v, length) +{ + name (indi) col(length) " (" + if (p, birth(indi)) {year(p)} else {" "} + " - " + if (p, death(indi)) {year(p)} else {" "} + ") (" d(v) ")" +} + + +/* Maximum length of a name of a person in person_set. + */ +func max_length (person_set) +{ + set (max_name_length, 0) + forindiset (person_set, indi, v, n) { + if (lt(max_name_length, strlen(name(indi)))) { + set (max_name_length, strlen(name(indi))) + } + } + return (max_name_length) +} +/* +----------------------------------------------------------------------- + +This is an example of the output. I have deleted the surnames because +they contain 8 bit letters. + +Common ancestors of Juho XXXXXXXX + + + Maria AAAAAAAAAAA (1606 - 1661) (0) + Heikki XXXXXXXX (1603 - 1670) (0) + +Heikki XXXXXXXX (1628 - 1705) (1) Lauri XXXXXXXX (1637 - 1701) (1) +Heikki XXXXXXXX (1666 - 1731) (2) Eeva XXXXXXXX (1659 - 1724) (2) +Aatami XXXXXXXX (1687 - 1733) (3) Anna BBBBBBBB (1691 - 1746) (3) +Juho XXXXXXXX (1721 - 1775) (4) Ulla CCCCCCCC (1724 - 1789) (4) + + Juho XXXXXXXX (1761 - 1848) (5) +*/ diff --git a/reports/connect2.ll b/reports/connect2.ll new file mode 100644 index 0000000..52b69d3 --- /dev/null +++ b/reports/connect2.ll @@ -0,0 +1,219 @@ +/* + * @progname connect2.ll + * @version 2.1 + * @author Simms + * @category + * @output Text + * @description + * Describes the family line connecting an ancestor/descendant + + Written by: Robert Simms, 19 Sep 1997 + rsimms@math.clemson.edu, http://www.math.clemson.edu/~rsimms + + Asks for a descendant and an ancestor then produces, for the line + connecting the two persons, + an indented report on an individual and all families associated + with that individual. Details on individuals include NOTE lines. + Line wrapping is done with indenting maintained. + + This program does not check to make sure that the descendant given is really + a descendant of the ancestor. An error will result if not. + + At the beginning of main() is provided the means to easily change page width, + tab size, left margin, and whether or not to include notes in output. + + Revisions: 2: Robert Simms, 17 Feb 2000, made line-wrapping code more + consistent in its use of the parameters page_width, + and left_margin. + 2.1: Robert Simms, 30 May 2001, fixed the concatenation of + multiple notes so that two spaces are inserted before + every note after the first note. + Thanks to M.W. Poirier for pointing this out. + +*/ + +global(page_width) +global(tab_size) +global(left_margin) +global(note_flag) +global(plist) + +proc main() { + set(page_width, 80) + set(tab_size, 3) + set(left_margin, 0) + set(note_flag, 1) /*set equal to 1 to include notes, 0 NOT to include notes*/ + list(plist) + + + getindi(indi1, "Descendant") + getindi(indi2, "Ancestor") + set(connects, 0) + if(connect(indi1, indi2)) { + + forlist(plist, person, pnum) { + if(ne(pnum, 1)) { + nl() nl() + } + set(x, 0) + set(skip, left_margin) + set(x, outfam(person, skip, x)) + } + nl() + " -------------------------------------" + nl() + } +} + +func connect(person, target) { + set(connects, 0) + if(eq(person, target)) { + set(connects, 1) + } else { + if(dad, father(person)) { + if(connect(dad, target)) { + set(connects, 1) + } else { + if(mom, mother(person)) { + if(connect(mom, target)) { + set(connects, 1) + } + } + } + } + } + if(connects) { + enqueue(plist, person) + } + return(connects) +} + + +func outfam(indi, skip, x) { + set(x, outpers(indi, skip, x)) + if(gt(nfamilies(indi), 0)) { + set(skip, add(skip, tab_size)) + families(indi, fam, sp, num) { + set(x, 0) + set(x, outline(concat("Family #", d(num)), skip, x)) + if(date(marriage(fam))) { + set(x, outline(concat(", ", date(marriage(fam))), skip, x)) + } + set(x, 0) + set(skip, add(skip, tab_size)) + set(x, outpers(sp, skip, x)) + if(gt(nchildren(fam), 0)) { + set(x, outline("Children", skip, x)) + set(x, 0) + set(skip, add(skip, tab_size)) + children(fam, child, no) { + set(x, outpers(child, skip, x)) + } + set(skip, sub(skip, tab_size)) + } + set(skip, sub(skip, tab_size)) + } + } + return(x) +} + +func outpers(indi, skip, x) { + if(indi) { + print(name(indi), nl()) + set(x, 0) + set(x, outline(name(indi), skip, x)) + set(skip, add(skip, tab_size)) + set(s, "") + if(birth(indi)) { + set(s, concat(", b. ", long(birth(indi)))) + } + if(death(indi)) { + set(s, concat(s, ", d. ", long(death(indi)))) + } + if(burial(indi)) { + set(s, concat(s, ", buried at ", place(burial(indi)))) + } + set(s, concat(s, ". ")) + set(x, outline(s, skip, x)) + if(note_flag) { + set(s, "") + set(note_separator, "") + fornotes(inode(indi), note) { + set(s, concat(s, note_separator, note)) + set(note_separator, " ") + } + set(x, outtxt(s, skip, x)) + set(skip, sub(skip, tab_size)) + } + } else { + print("_____ _____", nl()) + set(x, 0) + set(x, outline("_____ _____", skip, x)) + } + set(x, 0) + return(x) +} + +func outtxt(txt, skip, x) { + set(cr, index(txt, nl(), 1)) + while(ne(cr, 0)) { + set(txt, save(txt)) + set(txt2, concat(substring(txt, 1, sub(cr, 1)), " ")) + set(x, outline(txt2, skip, x)) + set(txt, substring(txt, add(cr, 1), strlen(txt))) + set(cr, index(txt, nl(), 1)) + } + if(gt(strlen(txt), 0)) { + set(x, outline(txt, skip, x)) + } + return(x) +} + +func outline(text, skip, x) { + if(eq(x, 0)) { + col(add(skip, 1)) + set(x, skip) + } + set(max, sub(page_width, x)) + if(gt(strlen(text), max)) { + set(space, breakpoint(text, max)) + if(eq(space, 0)) { + if(eq(x, skip)) { + set(text, strsave(text)) + substring(text, 1, sub(max, 1)) "-" + set(x, 0) + set(text, substring(text, max, strlen(text))) + set(x, outline(text, skip, x)) + } else { + set(x, 0) + set(x, outline(text, skip, x)) + } + } else { /* space gt 0 -- good break point found*/ + set(text, strsave(text)) + substring(text, 1, sub(space, 1)) + set(x, 0) + set(text, strsave(substring(text, add(space, 1), strlen(text)))) + while(eqstr(" ", substring(text, 1, 1))) { /* strip leading spaces */ + set(text, strsave(substring(text, 2, strlen(text)))) + } + set(x, outline(text, skip, x)) + } + } else { + text + set(x, add(x, strlen(text))) + } + return(x) +} + +func breakpoint(text, max) { + set(space, 0) + set(occ, 1) + set(next, index(text, " ", occ)) + incr(occ) + while ( and(le(next, add(max, 1)), ne (next, 0))) { + set(space, next) + set(next, index(text, " ", occ)) + incr(occ) + } + return(space) +} diff --git a/reports/cons.ll b/reports/cons.ll new file mode 100644 index 0000000..6227cb8 --- /dev/null +++ b/reports/cons.ll @@ -0,0 +1,289 @@ +/* + * @progname cons.ll + * @version 1.0 + * @author Teschler + * @category + * @output Text + * @description + +Calculates coefficient of inbreeding F(A,B) for the offspring +of two individuals A and B. + +The consanguity (blood in common) C(A,B) is 2*F(A,B) +F(A,B) = sum(0.5^(n(i)+p(i)) * (1+F(J(i))/2) +The sum extends over the number of distinct chains of relationship +connecting A and B. The ith chain has n(i)+p(i) links ascending +from A and B to the common ancestor J(i), whose coefficient of +inbreeding is f(J(i)). +A chain of relationship consists of all links leading from A and +B to a common ancestor J, and has no other point in common except +J. Two chains are considered distinct if they differ in at least +one link. + +Result goes to file /tmp/t1 +This is one of my first LL programs so please do not look +for elegance ;-) + +Arthur.Teschler@uni-giessen.de +*/ + +global(anc_line) /* holds the current way from A towards B */ +global(to_anc) /* B's ancestors */ +global(from_anc) /* A's ancestors */ +global(common_anc) /* A's and B's common ancestors */ +global(common_stack) /* holds J(i) for later inbreed check */ +global(anc_line_stack) /* holds lines for later output */ +global(coefftab) /* holds inbreed coefficients for J(i) */ + +func coanc(A,B) + { + indiset(from_anc) + addtoset(from_anc,A,0) + set(from_anc,ancestorset(from_anc)) + addtoset(from_anc,A,0) + + indiset(to_anc) + addtoset(to_anc,B,0) + set(to_anc,ancestorset(to_anc)) + addtoset(to_anc,B,0) + + indiset(common_anc) + set(common_anc,intersect(from_anc,to_anc)) + + list(anc_line) + if (lengthset(common_anc)) + { + push(anc_line_stack,"--") /*Marker*/ + if (gt(lengthset(from_anc),lengthset(to_anc))) + { + call swap(from_anc,to_anc) + call swap(A,B) + } + call iter(A,0,B) + /* + At this point we have collected all paths + leading from A to B on anc_line_stack + Now we have to calculate f(J(i)) for all + common ancestors that are in our list of + paths (saved on common_stack), then we + can sum up things. + */ + while(pers,dequeue(common_stack)) { + if (not(lookup(coefftab,key(pers,0)))) { + set(pc,coanc(father(pers),mother(pers))) + insert(coefftab,key(pers),pc) + } + } + print "Results for :" + print fullname(A,0,0,50) sp() + print fullname(B,0,0,50) nl() + set(result,sum_up()) + } + else + { + set(result,"0 1") + } + return(result) + } + +proc iter(current,common,target) + /* Recursively traverses the tree (better hedge) + to find all paths leading from current to + target. Makes use of precalculated sets + common_anc and to_anc. + Fills up a list of paths + */ + { + print (".") + push(anc_line,current) + if (eq(current,target)) { + call found(common) + pop(anc_line) + return() + } + if (not(common)) { + /* We are ascending */ + if (father(current)) { + call iter(father(current),0,target) + } + if (mother(current)) { + call iter(mother(current),0,target) + } + if (iselement(current,common_anc)) { + set(common,current) + } + } + if (common) { + /* We have found a common ancestor + now we check for descendants */ + families(current,curfam,spouse,cnt) { + children(curfam,curchild,cnt) { + if (notchecked(curchild)) { + if(iselement(curchild,to_anc)) { /* <- speeds up! */ + call iter(curchild,common,target) + } /* iselement */ + } /* notchecked */ + } /* children */ + } /* families */ + } /* common */ + pop(anc_line) + } + +proc found(common) { + /* Unfortunately LL pushes references. + I had liked to push values. + Now I have to do my own special stack handling. + Not very elegant, though :( + */ + print("!") + push(anc_line_stack,"-") /*Marker*/ + forlist(anc_line,pers,cnt) { + push(anc_line_stack,key(pers)) + } + push(anc_line_stack,key(common)) + push(common_stack,common) +} + +func sum_up() + { + /* + pops anc_lines from anc_line_stack and sums + up their values. + prints them as a side effect, otherwise there would + be no need to save all those steps, the length would + have been enough + */ + set(sum,"0 1") + set(lcnt,0) + set(element,pop(anc_line_stack)) + while(strcmp(element,"--")) { + incr(lcnt) + set(common,element) + print "Common ancestor: " fullname(indi(common),0,0,50) nl() + set(factor,lookup(coefftab,common)) + if (strcmp(factor,"0 1")) { + print "(Inbreeding coefficient: " showfrac(factor) ")" nl() + } + set(length,0) + set(pers,pop(anc_line_stack)) + while(strcmp(pers,"-")) { + incr(length) + print " " d(length) " " fullname(indi(pers),0,0,50) nl() + set(pers,pop(anc_line_stack)) + } + set(element,pop(anc_line_stack)) + set(factor,addfrac("1 0",factor)) + set(factor, mulfrac( factor,concat("1 ",d(length)))) + print "------------" nl() + print showfrac(factor) nl() nl() + set(sum,addfrac(sum,factor)) + } + print "============" nl() + print "Sum: " showfrac(sum) " (" d(lcnt) " different lines)" nl() + print nl() + return(sum) + } + +/* + Some functions to handle fractions follow here. + Lifelines has no type fraction let's put nominator denominator + as space separated strings. As the denominator is always 2^x, + we put just x +*/ + +func addfrac(A,B) + { + set(nomA,atoi(A)) + set(denA,atoi(substring(A,index(A," ",1),strlen(A)))) + set(nomB,atoi(B)) + set(denB,atoi(substring(B,index(B," ",1),strlen(B)))) + + while (lt(denA,denB)) { + incr(denA) + set(nomA,mul(nomA,2)) + } + while (lt(denB,denA)) { + incr(denB) + set(nomB,mul(nomB,2)) + } + + set(nomA,add(nomA,nomB)) + while (eq(0,mod(nomA,2))) { + decr(denA) + set(nomA,div(nomA,2)) + } + + set(result,concat(d(nomA)," ")) + return(concat(result,d(denA))) + } + +func mulfrac(A,B) + { + /* Multiply my funny fractions */ + set(nomA,atoi(A)) + set(denA,atoi(substring(A,index(A," ",1),strlen(A)))) + set(nomB,atoi(B)) + set(denB,atoi(substring(B,index(B," ",1),strlen(B)))) + set(nomA,mul(nomA,nomB)) + set(denA,add(denA,denB)) + while (eq(0,mod(nomA,2))) { + decr(denA) + set(nomA,div(nomA,2)) + } + + set(result,concat(d(nomA)," ")) + return(concat(result,d(denA))) + } + +func showfrac(A) + { + /* show my funny fractions */ + set(nomA,atoi(A)) + set(denA,atoi(substring(A,index(A," ",1),strlen(A)))) + return(concat(d(nomA),concat("/",d(exp(2,denA))))) + } + + +proc swap(V1,V2) + { + set(help,V1) + set(V1,V2) + set(V2,help) + } + +/* I'm sure there are better ways to handle the following two ... */ + +func iselement(E,S) + { + indiset(test) + addtoset(test,E,0) + return (lengthset(intersect(test,S))) + } + +func notchecked(i) + { + forlist(anc_line,pers,cnt) { + if (eq(key(pers,0),key(i,0))) { return (0) } + } + return (1) + } + +proc show_stack() + { + /* for debugging purposes */ + print "Current:" nl() + forlist(anc_line,pers,cnt) { + print " " d(cnt) fullname(pers,0,0,50) nl() + } + } + +proc main() { + getindimsg(from,"1st :") + getindimsg(to,"2nd :") + list(common_stack) + list(anc_line_stack) + table(coefftab) + newfile("/tmp/t1",0) + set(cf,mulfrac("2 0",coanc(from,to))) + print "Consanguity factor: " showfrac(cf) nl() +} diff --git a/reports/cont.ll b/reports/cont.ll new file mode 100644 index 0000000..c3a5c75 --- /dev/null +++ b/reports/cont.ll @@ -0,0 +1,77 @@ +/* + * @progname cont.ll + * @version 1.0 + * @author Väisänen + * @category + * @output Text + * @description + +This program iterates over all persons and families in a database +and reports all records that have erroneous CONT lines. + +It finds errors like + +2 TAG blah 2 CONT blah 2 CONT blah +2 CONT blah 3 CONT blah 2 TAG blah + +If the output is + + These individuals may have problems with CONT lines + These families may have problems with CONT lines + +then the program found no errors. + + +Written by Hannu V瓣is瓣nen 22 September 1999. +*/ + +proc main() +{ + "These individuals may have problems with CONT lines\n" + + forindi (person, m) { + print ("i") + call check (person, 0) + } + + "These families may have problems with CONT lines\n" + forfam (family, m) { + print ("f") + call check (family, 1) + } +} + +proc check (person, isfam) +{ + set (prev_level, 0) + set (prev_tag, "xxxx") + + traverse (root(person), node, n) { + if (eqstr(tag(node), "CONT")) { + if (eqstr(prev_tag, "CONT")) { + if (ne(prev_level, n)) { + if (eq(isfam,1)) { + "Husband " key(husband(person)) " " name(husband(person)) "\n" + "Wife " key(wife(person)) " " name(wife(person)) "\n\n" + } + else { + key(person) " " name(person) "\n" + } + } + } + else { + if (ne(add(prev_level,1), n)) { + if (eq(isfam,1)) { + "Husband " key(husband(person)) " " name(husband(person)) "\n" + "Wife " key(wife(person)) " " name(wife(person)) "\n\n" + } + else { + name(person) " " key(person) "\n" + } + } + } + } + set (prev_level, n) + set (prev_tag, tag(node)) + } +} diff --git a/reports/count_anc.ll b/reports/count_anc.ll new file mode 100644 index 0000000..004f493 --- /dev/null +++ b/reports/count_anc.ll @@ -0,0 +1,45 @@ +/* + * @progname count_anc.ll + * @version 2.0 + * @author Eggert + * @category + * @output Text + * @description + +This program counts ancestors of a person by generation. +Only unique individuals in each generation are counted. +A person counts in all the generations he/she is in, +but only counts once in the grand total. + +count_anc - a LifeLines ancestors counting program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 19 November 1992 + Version 2, 16 February 1995, use lengthset(), print(,) +*/ + +proc main () +{ + getindimsg(person,"Enter person to count ancestors of") + indiset(thisgen) + indiset(allgen) + addtoset(thisgen, person, 0) + print("Counting generation ") + "Number of ancestors of " key(person) " " name(person) + " by generation:\n" + set(thisgensize,1) + set(gen,1) + while(thisgensize) { + set(thisgensize,0) + if (thisgensize,lengthset(thisgen)) { + set(gen,sub(gen,1)) + print(d(gen)," ") + "Generation " d(gen) " has " d(thisgensize) " individual" + if (gt(thisgensize,1)) { "s" } + ".\n" + set(thisgen,parentset(thisgen)) + set(allgen,union(allgen,thisgen)) + } + } + "Total unique ancestors in generations " d(gen) " to -1 is " + d(lengthset(allgen)) ".\n" +} diff --git a/reports/count_desc.ll b/reports/count_desc.ll new file mode 100644 index 0000000..0dfb931 --- /dev/null +++ b/reports/count_desc.ll @@ -0,0 +1,45 @@ +/* + * @progname count_desc.ll + * @version 2.0 + * @author Eggert + * @category + * @output Text + * @description + +This program counts descendants of a person by generation. +Only unique individuals in each generation are counted. +A person counts in all the generations he/she is in, +but only counts once in the grand total. + +count_desc - a LifeLines descendants counting program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 19 November 1992 + Version 2, 16 February 1995, use lengthset(), print(,) +*/ + +proc main () +{ + getindimsg(person,"Enter person to count descendants of") + indiset(thisgen) + indiset(allgen) + addtoset(thisgen, person, 0) + print("Counting generation ") + "Number of descendants of " key(person) " " name(person) + " by generation:\n" + set(thisgensize,1) + set(gen,neg(1)) + while(thisgensize) { + set(thisgensize,0) + if (thisgensize,lengthset(thisgen)) { + set(gen,add(gen,1)) + print(d(gen)," ") + "Generation " d(gen) " has " d(thisgensize) " individual" + if (gt(thisgensize,1)) { "s" } + ".\n" + set(thisgen,childset(thisgen)) + set(allgen,union(allgen,thisgen)) + } + } + "Total unique descendants in generations 1-" d(gen) + " is " d(lengthset(allgen)) ".\n" +} diff --git a/reports/count_dup.ll b/reports/count_dup.ll new file mode 100644 index 0000000..4105cea --- /dev/null +++ b/reports/count_dup.ll @@ -0,0 +1,63 @@ +/* + * @progname count_dup.ll + * @version 1.0 + * @author anon + * @category + * @output Text + * @description + * Count dups among ancestors? + */ + +global(cnttab) +global(indtab) +global(undone) +global(allind) +global(maxcount) +global(maxindi) + +proc main() { + + list(undone) + list(allind) + table(cnttab) + table(indtab) + + getindi(person) + set(maxcount,0) + set(maxindi,person) + call addaperson(person) + set(c,0) + + while (person,dequeue(undone)) { + incr(c) + /* print(d(c)," ",key(person),"\n") */ + if(eq(mod(c,1000), 0)) { + print(d(c)," ",d(maxcount)," ",key(maxindi)," ",name(maxindi),"\n") + } + if (p,father(person)) { call addaperson(p) } + if (p,mother(person)) { call addaperson(p) } + } + + while(p,dequeue(allind)) { + set(count,lookup(cnttab,key(p))) + d(count) " " key(p) " " name(p) " " title(p) "\n" + } +} + +proc addaperson(p) +{ + enqueue(undone,p) + set(count,lookup(cnttab,key(p))) + if(ne(count,0)) { + set(count, add(count,1)) + if(gt(count, maxcount)) { + set(maxcount, count) + set(maxindi, p) + } + } else { + set(count,1) + insert(indtab, key(p), p) + enqueue(allind,p) + } + insert(cnttab, key(p), count) +} diff --git a/reports/count_paternal_desc.ll b/reports/count_paternal_desc.ll new file mode 100644 index 0000000..07bc53e --- /dev/null +++ b/reports/count_paternal_desc.ll @@ -0,0 +1,54 @@ +/* + * @progname count_paternal_desc.ll + * @version 2.0 + * @author Eggert + * @category + * @output Text + * @description + +This program counts paternal descendants of a person by generation. +Only unique individuals in each generation are counted. +A person counts in all the generations he/she is in, +but only counts once in the grand total. +Male paternal descendants are also counted separately. + +count_paternal_desc - a LifeLines descendants counting program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 1 August 1994 + Version 2, 16 February 1995, use lengthset(), print(,) +*/ + +proc main () +{ + getindimsg(person,"Enter person to count paternal descendants of") + indiset(thisgen) + indiset(allgen) + indiset(allmalegen) + addtoset(thisgen, person, 0) + if (male(person)) { addtoset(allmalegen, person, 0) } + print("Counting generation ") + "Number of paternal descendants of " key(person) " " name(person) + " by generation:\n" + set(gen,neg(1)) + while(lengthset(thisgen)) { + indiset(thismalegen) + forindiset(thisgen,person,val,count) { + if (male(person)) { + addtoset(thismalegen,person,0) + } + } + incr(gen) + print(d(gen)," ") + "Generation " d(gen) " has " d(lengthset(thisgen)) + " paternal descendant" + if (gt(lengthset(thisgen),1)) { "s" } + " of which " d(lengthset(thismalegen)) " are male.\n" + set(thisgen,childset(thismalegen)) + set(allgen,union(allgen,thisgen)) + set(allmalegen,union(allmalegen,thismalegen)) + } + "Total unique paternal descendants in generations 1-" d(gen) + " is " d(lengthset(allgen)) + " of which " d(lengthset(allmalegen)) + " are male paternal descendants.\n" +} diff --git a/reports/cousins.ll b/reports/cousins.ll new file mode 100644 index 0000000..e8c4223 --- /dev/null +++ b/reports/cousins.ll @@ -0,0 +1,442 @@ +/* + * @progname cousins.ll + * @version 6.0 + * @author Wetmore + * @category + * @output Text + * @description + + Finds the relationship between two persons in a + LifeLines database. If there is no common ancestor, the program + will attempt to find a sequence of genetic relations that link the two + persons. + + In the cases where the two persons are + genetically related (have a common ancestor), the program will + find and display the relationship. If the two persons are not + genetically related, the program will attempt to discover a + sequence of genetic relationships that link the two persons. + For example, the program will display the relationship between + your two grandmothers as a sequence of two genetic relations with + a grandchild as the link between. Note that two persons may be + related to each other in many ways; this program finds only the + shortest one (or ones if there are different, equally short paths). + + This program requires version 3 of LifeLines. + +author -- Tom Wetmore, ttw@beltway.att.com + +version history + 1 - 08 Sep 1993 -- modified from the relate program + 2 - 08 Sep 1993 -- fixed niece/nephew bug + 3 - 09 Sep 1993 -- extensive modification + 4 - 13 Aug 1994 -- more modifications + 5 - 2 Mar 1995 -- check for direct descendants first. Chris Bone + 6 - 2 Mar 1995 -- Neater cousin removes, find all short paths. J.F. Chandler +*/ + +global(links) /* table of links back one person */ +global(rels) /* table showing direction of the links */ +global(klist) /* list of found persons not linked back to yet */ +global(numb) /* number of persons considered so far */ + +/*====================================================================== + * notes on global data structures -- + * o links -- implements the function link(key1) --> key2, where key1 + * is the key of a person, and key2 is the key of the person that + * person key1 links back to + * o rels -- implements the function rels(key1) --> dir, where key1 is + * the key of a person, and dir is the relationship direction (up or + * down) between this person and person link(key1) + *=====================================================================*/ + +/*===================================================================== + * main -- Get the user to identify two persons; if all goes well, call + * relate to do the hard stuff. + *===================================================================*/ +proc main () +{ + print("This program finds the relationship between two persons.\n\n") + getindimsg(from, "Please identify the first person.") + set(to, 0) + if (from) { + getindimsg(to, "Please identify the second person.") + } + if (and(from, to)) { + print("Searching for relationships between:\n\t") + print(name(from), " and ", name(to)) + print(".\n\nThis may take a while -- ") + print("each dot is 25 persons considered.\n") + set(fkey, save(key(from))) + set(tkey, save(key(to))) + call relate(tkey, fkey) + } else { + print("Please call again.\n") + } +} + +/*====================================================================== + * relate -- Attempt to find a relationship between two persons by + * constructing a path of parent and/or child links between them; if a + * path is found, call foundpath to display the results; else report + * that there is no relation between the persons. + *====================================================================*/ +proc relate (fkey, tkey) +{ + table(links) /* table of links back one person */ + table(rels) + list(klist) /* keys of persons not linked back to yet */ + + set(up, 1) + set(down, neg(1)) + set(numb, 0) + set(pathlength, 0) + set(toolong, 0) + set(found, 0) + +/* Link the first person to him/herself with no direction, and make + him/her the first entry in the list of unlinked back to persons. + A "zero" person in the list marks the start of next-longer paths. */ + + insert(links, fkey, fkey) + insert(rels, fkey, 0) + enqueue(klist, fkey) + enqueue(klist, 0) + +/* Iterate through the list of unlinked back to persons; remove them one by + one; link their parents and children back to them; add their parents and + children to the unlinked back to list; check each iteration to see if + one of the new parents or children is the searched for person; if so + quit the iteration and call foundpath; else continue iterating. */ + + while ( gt(length(klist),1) ) { + set(key, dequeue(klist)) + if(not(key)) { + set(pathlength, add(1,pathlength)) + if(eq(pathlength,toolong)) { break() } + enqueue(klist, 0) + continue() + } + set(indi, indi(key)) + set(dir, lookup(rels, key)) + call include(key, father(indi), down) + call include(key, mother(indi), down) + families(indi, fam, spouse, num1) { + children(fam, child, num2) { + call include(key, child, up) + } + } + if (key, lookup(links, tkey)) { + if(found) { + "\n\nAlternate relationship" + } else { + "Relationship from " name(indi(tkey)) + " to " name(indi(fkey)) + } + ":\n" + set(found, 1) + call foundpath(tkey) + call fullpath(tkey) + set(toolong, add(1,pathlength)) + insert(links, tkey, 0) + } + } + +/* Check to see if there is no relation between the persons, and if there + is none let the user know and quit. */ + + if (not(found)) { + print("\nThey are not blood-related to one another.") + "They are not blood-related to one another." + } +} + +/*========================================================================= + * include -- Links a newly discovered person (indi) back to another person + * (key), with a specified direction (rel); the new person is then put on + * the list of unlinked back to persons. + *=======================================================================*/ +proc include (key, indi, rel) +{ +/* Only include the person if he/she has not been found before. */ + + if (and(indi, not(lookup(links, key(indi))))) { + +/* Keep user happy watching those dots! */ + + set(numb, add(numb, 1)) + if (eq(0, mod(numb, 25))) { + print(".") + } + +/* Update the data structures. */ + + set(new, save(key(indi))) + insert(links, new, key) + insert(rels, new, rel) + enqueue(klist, new) + } +} + +/*================================================================= + * foundpath -- Show the relationship path between the two persons. + *===============================================================*/ +proc foundpath (key) +{ + print("\n") "\n" + list(nexkeys) + list(nexlens) + +/* Init the nexus person from the first (to) person. */ + + set(nexus, key) + set(dir, lookup(rels, key)) + set(len, dir) + set(again, 1) + +/* Create the nexus list, the list of persons where relationships change + direction; a nexus person is either the first person, the last person, + or the common ancestor or descendent of two other nexus persons. */ + + while (again) { + +/* Get the next person from the path. */ + + set(key, lookup(links, key)) + set(rel, lookup(rels, key)) + +/* If the new person's direction is 0 this is the last person in the path + (the from person) so add the current nexus person and the last person + to the nexus list and quit the loop */ + + if (eq(0, rel)) { + enqueue(nexkeys, nexus) + enqueue(nexlens, len) + enqueue(nexkeys, key) + enqueue(nexlens, 0) + set(again, 0) + +/* if new person changes direction, add the current nexus person to the + nexus list, and make the new person the new current nexus person */ + + } elsif (ne(rel, dir)) { + enqueue(nexkeys, nexus) + enqueue(nexlens, len) + set(nexus, key) + set(dir, rel) + set(len, rel) + +/* if the new person continues in the same direction, record the step */ + + } else { + set(len, add(len, rel)) + } + } + + set(one, dequeue(nexkeys)) + set(len, dequeue(nexlens)) + set(again, 1) + +/* step down the nexus list, computing and displaying the relationships + between either two nexus persons (where it is appropriate to show pure + ancestry or descendency) or three nexus persons (where it is appropriate + to show two nexus persons as cousins with their common ancestor) */ + + while (and(again, length(nexkeys))) { + set(llen, length(nexkeys)) + +/* If the initial direction is down, show first nexus person as a simple + ancestor of the second nexus person; this condition can only be true + in the first iteration */ + + if (lt(len, 0)) { + set(two, dequeue(nexkeys)) + set(new, dequeue(nexlens)) + call showancs(one, two, neg(len)) + set(one, two) + set(len, new) + +/* If the direction is up, there are two subcases: */ + + } elsif (gt(len, 0)) { + +/* If the nexus list has only one remaining entry then show the (last-1)th + nexus person as a simple descendent of the last nexus person */ + + if (eq(1, llen)) { + set(two, dequeue(nexkeys)) + set(new, dequeue(nexlens)) + call showdesc(one, two, len) + set(again, 0) + +/* If the nexus list has more than one remaining entry then show the + current nexus person and the next two as two "cousins" with an + intervening common ancestor, and make the last of the three persons the + current nexus person for the next loop iteration */ + + } else { + set(two, dequeue(nexkeys)) + set(tmp, dequeue(nexlens)) + set(three, dequeue(nexkeys)) + set(new, dequeue(nexlens)) + call showcous(one, two, three, len, neg(tmp)) + set(one, three) + set(len, new) + } + +/* This is the special case where a person is related to him/herself. */ + + } else { + print("They're the same person.\n") + "They're the same person.\n" + set(again, 0) + } + } +} + +/*================================================= + * showancs -- Show a direct ancestry relationship. + *==============================================*/ +proc showancs (one, two, len) +{ + set(indi, indi(one)) + if (male(indi)) { set(pword, "father ") } + elsif (female(indi)) { set(pword, "mother ") } + else { set(pword, "parent ") } + if (eq(1, len)) { set(aword, "the ") } + else { set(aword, "a ") } + + print(name(indi), " is ", aword) + name(indi) " is " aword + if (eq(2, len)) { print("grand") "grand" } + elsif (eq(3, len)) { print("great grand") "great grand" } + elsif (lt(3, len)) { + print("great(", d(sub(len, 2)), ") grand") + "great(" d(sub(len, 2)) ") grand" + } + print(pword, "of\n ", name(indi(two)), ".\n") + pword "of\n " name(indi(two)) ".\n" +} + +/*==================================================== + * showdesc -- Show a direct descendency relationship. + *==================================================*/ +proc showdesc (one, two, len) +{ + set(indi, indi(one)) + if (male(indi)) { set(pword, "son ") } + elsif (female(indi)) { set(pword, "daughter ") } + else { set(pword, "child ") } + + print(name(indi), " is a ") + name(indi) " is a " + if (eq(2, len)) { print("grand") "grand" } + elsif (eq(3, len)) { print("great grand") "great grand" } + elsif (lt(3, len)) { + print("great(", d(sub(len, 2)), ") grand") + "great(" d(sub(len, 2)) ") grand" + } + print(pword, "of\n ", name(indi(two)), ".\n") + pword "of\n " name(indi(two)) ".\n" +} + +/*========================================================================= + * showcous -- Show a cousin relationship; for the purposes of this + * program, siblings, uncles, aunts, nieces and nephews are considered to + * be special cases of cousins. + *=======================================================================*/ +proc showcous (one, two, three, up, down) +{ + set(indi, indi(one)) + if (male(indi)) { + set(sword, " brother ") + set(nword, " nephew ") + set(uword, " uncle ") + } elsif (female(indi)) { + set(sword, " sister ") + set(nword, " niece ") + set(uword, " aunt ") + } else { + set(sword, " sibling ") + set(nword, " niece or nephew ") + set(uword, " uncle or aunt ") + } + print(name(indi(one)), " is a") + name(indi(one)) " is a" + if (and(eq(up,1), eq(down, 1))) { /* sibling cases */ + print(sword, "of") + sword "of" + } elsif (eq(up, 1)) { /* uncle/aunt cases */ + if (eq(down, 2)) { + print("n", uword, "of") + "n" uword "of" + } elsif (eq(down, 3)) { + print(" great", uword, "of") + " great" uword "of" + } else { + print(" great(", d(sub(down, 2)), ")", uword, "of") + " great(" d(sub(down, 2)) ")" uword "of" + } + } elsif (eq(down, 1)) { /* niece/nephew cases */ + if (eq(up, 2)) { + print(nword, "of") + nword "of" + } elsif (eq(up, 3)) { + print(" great", nword, "of") + " great" nword "of" + } else { + print(" great(", d(sub(up, 2)), ")", nword, "of") + " great(" d(sub(up, 2)) ")" nword "of" + } + } else { /* cousin cases */ + if (gt(up, down)) { + set(gen, down) + set(rem, sub(up, down)) + } else { + set(gen, up) + set(rem, sub(down, up)) + } + print(" ", ord(sub(gen,1)), " cousin ") + " " ord(sub(gen,1)) " cousin " + if (ne(rem, 0)) { + if (eq(rem,1)) {print("once") "once"} + elsif (eq(rem,2)) {print("twice") "twice"} + elsif (eq(rem,3)) {print("thrice") "thrice"} + else { + print(card(rem), " times") + card(rem) " times" } + print(" removed ") " removed " + } + print("of") "of" + } + print("\n ", name(indi(three))) + "\n " name(indi(three)) + print(", through their ancestor,\n ", name(indi(two)), ".\n") + ", through their ancestor,\n " name(indi(two)) ".\n" +} + +/*======================================================================= + * fullpath -- Show full path between the two persons. + *======================================================================*/ +proc fullpath (key) +{ + "\nThe full relationship path between them is:\n\n" + set(again, 1) + while (again) { + name(indi(key)) + set(new, lookup(links, key)) + set(dir, lookup(rels, key)) + if (gt(dir, 0)) { + " is the child of" + } + if (lt(dir, 0)) { + " is the parent of" + } + "\n" + if (eq(0, strcmp(key, new))) { + set(again, 0) + } else { + set(key, new) + } + } +} diff --git a/reports/coverage.ll b/reports/coverage.ll new file mode 100644 index 0000000..0ce9a6f --- /dev/null +++ b/reports/coverage.ll @@ -0,0 +1,87 @@ +/* + * @progname coverage.ll + * @version 4 + * @author Wetmore, Woodbridge, Eggert + * @category + * @output Text + * @description + * + * Display percentage of ancestors of each generation discovered + + coverage -- Displays "ancestor coverage," that is, what percentage of + ancestors have been discovered for each generation back in time. + + First version by T. Wetmore, 21 February 1994 + 2nd version by S. Woodbridge, 6 March 1994 + 3rd version by J. Eggert, 7 March 1994 + 4th version by J. Eggert, 9 November 1998 +*/ + +proc main () +{ + getindi(person0, "Enter person to compute ancestor coverage for.") + print("Collecting data .... \n") + + "Ancestor Coverage Table for " name(person0) "\n\n" + col(1) "Gen" col(9) "Total" col(19) "Found" + col(30) "(Diff)" col(38) "Percentage\n\n" + + list(ilist) + list(glist) + table(dtable) + enqueue(ilist, person0) + enqueue(glist, 1) + set(g,0) set(d,0) set(gsum,0) set(dsum,0) set(totpos,1) + set(oldgen,1) + while(person, dequeue(ilist)) { + set(gen, dequeue(glist)) + if (ne(gen,oldgen)) { + call printgen(oldgen,g,d,totpos) + set(gsum,add(gsum,g)) + set(dsum,add(dsum,d)) + set(g,0) + set(d,0) + set(totpos,mul(totpos,2)) + set(oldgen,gen) + } + incr(g) + if (not(lookup(dtable, key(person)))) { + insert(dtable, key(person), gen) + incr(d) + } +/* print(name(person), "\n") */ + incr(gen) + if (par,father(person)) { + enqueue(ilist, par) + enqueue(glist, gen) + } + if (par,mother(person)) { + enqueue(ilist, par) + enqueue(glist, gen) + } + } + set(gsum,add(gsum,g)) + set(dsum,add(dsum,d)) + call printgen(oldgen,g,d,totpos) + "\n" + call printgen(0,gsum,dsum,0) +} + +proc printgen(gen,g,d,tot) { + if (tot) { + col(1) rjustify(d(sub(gen,1)),3) + col(6) if (lt(gen,31)) { rjustify(d(tot),8) } + } + else { col(1) "all" } + col(16) rjustify(d(g),8) + if (ne(g,d)) { col(26) rjustify(concat("(",d(d),")"),10) } + if (and(tot,lt(gen,31))) { col(38) + set(u, mul(g, 100)) + set(q, div(u, tot)) + set(m, mod(u, tot)) + set(m, mul(m, 100)) + set(m, div(m, tot)) + rjustify(d(q),3) "." if (lt(m, 10)) {"0"} d(m) " %" + } + "\n" +} diff --git a/reports/cron.ll b/reports/cron.ll new file mode 100644 index 0000000..0d74315 --- /dev/null +++ b/reports/cron.ll @@ -0,0 +1,540 @@ +/* + * @progname cron.ll + * @version 4.0 + * @author Stephen Dum + * @category + * @output HTML + * @description + +Generate calendar of birth, death, marriage events arranged by the year, month +and day that they occurred. Generates a top level index by year, with actual +events stored in a separate html file for each decade. +Some properties must be set in your lifelines configuration file for this +report to run, see comments at beginning of the report for details. + +Warning, this report requires lifelines version 3.0.50 or later. + + by Stephen Dum (stephen.dum@verizon.net) + Version 1 March 2003 + Version 2 November 2005 Support privitizing data + Version 3 December 2005 Do html char set encoding + Version 4 June 2006 incorporated mods by Dave Eaton (dwe@arde.com) May 2006 + +This program was inspired by similar efforts by Mitch Blank (mitch@ctrpnt.com) +but without ever seeing the code he used to do a similar thing. + +The code used in cron.ll is very similar to anniver.ll. Other than the +sort order and print out details, the two programs share about 3/4 of their +code. + +Before using, there are a few properties that need to be customized for your +own environment so add them to your .linesrc ( or for windows lines.cfg) file. +You can also set them on the command line (like -Ianniver.htmldir=/tmp/foo) +The properties that are looked up are: + user.fullname -- name of the database owner + user.email -- email address of the db owner + cron.htmldir -- path to the directory to store results in + e.g. /home/joe/genealogy/html + (program expects a subdir in this directory with the name + of the database in it.) + cron.backgroundimage -- path to the background image, + no image if not defined. + e.g. ../../image/crink.jpg + this places image at the same level as /home/joe/genealogy/html + privatization: This report respects 2 levels of privatization + 1. if a record "RESN confidential" exists on an individual they are + skipped (as this report is designed to be shared, this seems + like a reasonable default) + 2. skip anyone estimated to be living + + History. + Version 2 Add code to allow respecting privatized data. + Version 3 switch from baptism() to get_baptism() for wider coverage + use translation tables to convert data to properly + escaped html. This is very codeset dependent. + Version 4 added changes by Dave Eaton (dwe@arde.com) + These were actually changes to anniver4, but merged here too. + Added "firstyear" that events may be on the calendar + Added "includedeath" check to drop deaths if those are not desired + Added ability to generate report for descendants of more than one + individual + Added ability to generate report only for living people + (omitting confidential if desired) +*/ + +/* customization globals */ +char_encoding("ASCII") +option("explicitvars") + +global(base_filename) /* where to store the results */ +global(background) /* path of background image relative to final html + * location, or "" */ +global(hi_bg_color) /* highlighted year background color */ +global(lo_bg_color) /* non-highlighted year background color */ + +global(db_owner) /* name of database owner - from config file */ +global(owner_email) /* email of database owner - from config file */ +global(justliving) /* should we generate a report only for living people? */ +global(privatize) /* should we privatize the data + * 0 = display all data + * 1 = skip confidential records + * 2 = skip confidential and living + */ +global(withkey) /* should we include key's in the output */ +global(cutoff_year) /* 100 years before today */ + /* birth >= cutoff_year is about 101 years, + * and we consider person living */ + +global(firstyear) /* earliest year for which entries should be included */ +global(includedeath) /* if set, then include the death events on the calendar */ + +global(month_name) /* names of the months */ +global(events) /* list of events to print */ +global(dates) /* list of dates of the events */ +global(keynames) /* name(s) of the key individuals for this report */ + +proc main () +{ + /* initialization of globals */ + + set(hi_bg_color,"\"#ddb99f\"") + set(lo_bg_color,"\"#e5d3c5\"") + + set(db_owner, getproperty("user.fullname")) + set(owner_email, concat("mailto:",getproperty("user.email"))) + set(background,getproperty("cron.backgroundimage")) + set(base_filename,concat(getproperty("cron.htmldir"),"/",database(),"/")) + if (not(test("d",base_filename))) { + print("Error, property cron.htmldir=",base_filename, + ", is not a directory,aborting\n") + print("Please read comments at beginning of report about setting properties\n") + return() + } + + /* other globals*/ + list(month_name) + enqueue(month_name,"January") + enqueue(month_name,"February") + enqueue(month_name,"March") + enqueue(month_name,"April") + enqueue(month_name,"May") + enqueue(month_name,"June") + enqueue(month_name,"July") + enqueue(month_name,"August") + enqueue(month_name,"September") + enqueue(month_name,"October") + enqueue(month_name,"November") + enqueue(month_name,"December") + + extractdate(gettoday(),day,mon,cutoff_year) + decr(cutoff_year,100) + set(cs,getproperty("codeset")) + if (eqstr(cs,"UTF-8")) { + set(srccs,"UTF-8") + set(dstcs,"UTF-8//html") + } elsif (eqstr(cs,"ISO-8859-15")) { + set(srccs,"ISO-8859-15//html") + set(dstcs,"UTF-8") + } else { + print("\nDatabase codeset ",cs," not supported, exiting\n") + } + + /* end of initialization of globals */ + + getint(justliving,"Enter 1 to include only living people, 0 otherwise") + if (justliving) { + /* Default the choices which conflict with "justliving" */ + set(includedeath,0) + /* We want living people, so see if we also want confidental */ + getint(noconfidential,"Enter 1 to omit confidential living people, 0 otherwise") + if (noconfidential) { + set(privatize,1) + } else { + set(privatize,0) + } + } else { + getint(privatize,"\nPrivatization: 0 print all data; 1 skip confidential records; 2 skip confidential and living") + getint(includedeath,"Enter 1 to include deaths on calendar, 0 otherwise") + } + getint(withkey,"Enter 1 to include keys, 0 otherwise") + getint(firstyear,"Enter oldest year to be on calendar, 0 for no limit") + getindi(person,"Enter person for whom to find descendants (return for all)") + indiset(thisgen) + indiset(allgen) + list(events) + list(dates) + list(keynames) + set(firstpass,1) + /* if a person is entered, the generated list of people include + * person and spouse, and all the children of either + * and then recursively the people, their spouses and all the children + * thereof + */ + if (person) { + while (person) { + addtoset(thisgen, person, 0) + addtoset(allgen, person, 0) + print("Computing descendants of ", name(person), " ") + enqueue(keynames,concat(name(person))) + set(thisgensize,1) + set(gen,neg(1)) + while(thisgensize) { + set(gen,add(gen,1)) + print("adding ",d(thisgensize)," individuals for generation ",d(gen),"\n") + indiset(spouse) + set(spouse,spouseset(thisgen)) + set(thisgen,childset(union(thisgen,spouse))) + set(allgen,union(allgen,spouse)) + set(allgen,union(allgen,thisgen)) + set(thisgensize,length(thisgen)) + /* the following check prevents looping if the + * database has been corrupted and a parent is listed + * as a child of that parent, and diagnoses the fault + */ + if (eq(length(intersect(allgen,thisgen)),thisgensize)) { + set(thisgensize,0) + print("Warning child is listed as its own parent\n") + forindiset(thisgen,indi,val,i) { + print (name(indi)," ") + } + print("\n") + } + } + if (firstpass) { + print ("Total of ") + set(firstpass,0) + } else { + print ("New total of ") + } + print (d(length(allgen))," individuals",nl()) + getindi(person,"Enter next person for whom to find descendants") + } + /* now generate list of events */ + forindiset(allgen,indi,val,i) { + if (not(mod(i,100))) { + print(".") + } + call add_indi(indi) + } + print("\n") + } else { + print("Traversing all individuals ") + forindi (indi, val) { + if (not(mod(val,100))) { + print(".") + } + call add_indi(indi) + set(max,val) + } + print (nl(), "Total of ",d(max)," individuals",nl()) + } + print( d(length(dates))," events generated",nl()) + + print("sorting data") + rsort(events,dates) + + /* Now print out all the data for each year + */ + print(nl()) + + list(yearmask) + set(lastyear,-1) + set(lastmonth,-1) + set(lastdecade,-1) + set(in_year,0) + print( d(length(dates))," events",nl()) + while(length(dates)) { + set(val,pop(dates)) + set(event,pop(events)) + set(year,div(val,10000)) + set(mon, mod(val,10000)) + set(day, mod(mon,100)) + set(mon, div(mon,100)) + set(decade, div(year,10)) + /* print(d(mon),"/",d(day),"/",d(year)," ", event, nl()) debug */ + + if (ne(lastdecade,decade)) { + if (ne(lastdecade,-1)) { + if (in_year) { + "\n" + set(in_year,0) + } + call write_tail() + } + call openfile(concat("dec",d(decade)),concat(d(mul(decade,10)), + " - ",d(add(mul(decade,10),9))," Events")) + set(lastdecade,decade) + } + if (ne(lastyear,year)) { + if (in_year) { + "\n" + } + "

" d(year) "

" nl() + push(yearmask,year) + "" nl() + set(in_year,1) + set(lastyear,year) + } + if (mon) { + if (day) { + set(title,concat(getel(month_name,mon)," ",d(day))) + } else { + set(title,getel(month_name,mon)) + } + } else { + if (day) { + set(title,d(day)) + } else { + set(title,"") + } + } + "\n\n" + } + if (in_year) { + "
" + "" title "\n" + "" + if (srccs) { + convertcode(event,srccs,dstcs) + } else { + event + } + "
\n" + } + call write_tail() + + /* Now print out the index page */ + + call openfile("cron","Chronological Event Calendar") + "This calendar indexes events by the year in which they occurred.\n" + "

Click on the year to see the events that occurred in that year.\n" + "

\n" + "\n" + + /* The calendar is arranged with 10 years across. */ + + set(decade,div(getel(yearmask,1),10)) + set(cur_year,mul(decade,10)) + set(lastdecade,div(getel(yearmask,0),10)) + set(minyear,getel(yearmask,1)) + set(maxyear,getel(yearmask,0)) + forlist(yearmask,this_year,cnt) { + while(le(cur_year,this_year)) { + if (eq(mod(cur_year,10),0)) { + /* print("processing decade ",d(decade),nl()) / * debug */ + "" nl() + } + if (eq(cur_year,this_year)) { + /* print year with a link to year page */ + "\n" + } else { + if (or(lt(cur_year,minyear),gt(cur_year,maxyear))) { + /* blank out year */ + "" nl() + } else { + /* print year without a link to year page */ + "" nl() + } + } + incr(cur_year) + if (eq(mod(cur_year,10),0)) { + "" nl() + incr(decade) + } + } + } + + "
" + d(cur_year) "\n" d(cur_year) "
\n" + call write_tail() +} + +/* openfile(filename, title_to_use) + * open output file and write out header information + */ +proc openfile(name,title) { + set(filename, concat(base_filename,name,".html")) + print("Writing ", filename, "\n") + newfile(filename, 0) + + "\n" + "\n" + "\n\n" + "\n" + " " title " \n" + "\n" + "\n" + if (eqstr(background,"")) { + "\n" + } else { + "\n" + } + "

" title "

\n
\n" +} + +/* write_tail() + * write out common footer information for file. + */ +proc write_tail() { + "
\n" + monthformat(6) + "This page was created " stddate(gettoday()) + "
\n" + "Database maintained by " + "\n" + db_owner + "
\n" + "" nl() + + "\n" +} + +/* add_indi(individual) + * check a given individual and see if there are any events to add + * at the moment we do birth, death and marriage events. + * Additional events can be added here + */ +proc add_indi(indi) { + set(birth_type,0) + if (birth,birth(indi)) { + set(birth,get_date(birth)) + set(birth_type," born") + } elsif (birth, get_baptism(indi)) { + set(birth,get_date(birth)) + set(birth_type," baptized") + } + set(death_type,0) + if (death,death(indi)) { + set(death,get_date(death)) + set(death_type," died") + } elsif (death, burial(indi)) { + set(death,get_date(death)) + set(death_type," buried") + } + /* skip confidential records and living people */ + if (privatize) { + if (confidential(indi)) { return() } + + /* living - birth, no death, and birth < 101 years ago */ + if (and(ge(privatize,2),birth,not(death))) { + if (ge(div(birth,10000),cutoff_year)) { return()} + } + } + if (birth) { + /* Make certain that if we only want living people that this is + (or at least may be) */ + if (not(or(and(justliving,death),and(justliving,lt(mod(birth,10000),cutoff_year))))) { + if (withkey) { + enqueue(events,concat(name(indi),"(",key(indi),")",birth_type)) + } else { + enqueue(events,concat(name(indi),birth_type)) + } + enqueue(dates,birth) + } + } + if (and(includedeath,death)) { + if (withkey) { + enqueue(events,concat(name(indi),"(",key(indi),")",death_type)) + } else { + enqueue(events,concat(name(indi),death_type)) + } + enqueue(dates,death) + } + + families(indi,famly, spouse, cnt) { + /* skip confidential families */ + if (confidential(famly)) { continue() } + if (and(privatize,spouse)) { + if (confidential(spouse)) { continue() } + } + if (justliving) { + /* make sure the person is living: no death, birth and + birth < 101 years ago */ + /* Nope, we know they have died */ + if (death) { return() } + if (birth) { + /* Nope, estimated they would be too old now */ + if (lt(mod(birth,10000),cutoff_year)) { return() } + } + } + /* living - birth, no death, and birth < 101 years ago */ + if (ge(privatize,2)) { + if (and(birth(spouse),not(death(spouse)))) { + if (ge(mod(get_date(birth(spouse)),10000),cutoff_year)) { continue()} + } + } + /* to avoid duplication, only enter data + * if indi is male, or there is no spouse + */ + if (or(male(indi),not(spouse))) { + fornodes(fnode(famly), node) { + if(eqstr(tag(node),"MARR")) { + if (spouse) { + set(names,concat(name(indi)," and ",name(spouse))) + set(keys,concat("(",key(indi),",",key(spouse),")")) + } else { + set(names,name(indi)) + set(keys,concat("(",key(indi),")")) + } + set(marr,get_date(node)) + if (marr) { + /* Make sure date is plausible for living or that we don't care */ + if (or(not(justliving),ge(mod(marr,10000),cutoff_year))) { + if (withkey) { + enqueue(events,concat(names,keys," married")) + } else { + enqueue(events,concat(names," married")) + } + enqueue(dates,marr) + } + } + } + } + } + } +} + +/* get_date(node) + * if event node has a date associated with it return it encoded as + * (year * 100 + month) * 100 + day + * These values facilitate sorting. + */ +func get_date(node) +{ + extractdate(node,day,mon,yr) + if (yr) { + return(add(mul(add(mul(yr,100),mon),100),day)) + } + return(0) +} + +func confidential(n) +{ + fornodes(n,node) { + if (eqstr(tag(node),"RESN")) { + if (eqstr(value(node),"confidential")) { + return(1) + } + } + } + return(0) +} +func get_baptism(ind) +{ + fornodes(ind,node) { + if (index(" BAPM BAPL CHR CHRA ",concat(" ",upper(tag(node))," "),1)) { + return(node) + } + } + return(0) +} diff --git a/reports/d-rtf.ll b/reports/d-rtf.ll new file mode 100644 index 0000000..f04dd9d --- /dev/null +++ b/reports/d-rtf.ll @@ -0,0 +1,319 @@ +/* + * @progname d-rtf.ll + * @version 1.1 of 2000-06-11 + * @author Paul Buckley + * @category + * @output RTF + * @description + * + * This report will produce a document in Rich Text Format modeled after some + * typewritten and typeset Henry format genealogies I've seen. + * All descendants of a selected person, their spouses and their spouses + * parents, event dates, and NOTEs are included. I generally reserve TEXT + * items for comments I would prefer not to export. + * + * This version requires shorten.li, a library with a lookup table + * to abbreviate the elements of the long placenames I tend to use + * (town, county, state, country). + * If you remove the calls to "shorten()" and just use the output of + * long() it should work fine without the library. + * + * Added support for printing reference numbers after data. + * Set "refs" to 0 to omit references. + * + * Written by: Paul Buckley, 11 Jun 2000, contact via LifeLines mail list + * (with a lot of help from the archives) + */ + +global(rtfH) /* string, RTF header and font info */ +global(rulI) /* string, index person ruler */ +global(rulS) /* string, spouse ruler */ +global(rulC) /* string, children list ruler*/ +global(rulN) /* string, notes ruler (same as spouse)*/ +global(font_name) /* string, name of font */ +global(font_size) /* int, font size in RTF values (2 x points) */ +global(big_font) /* int, ~1.3 times font_size */ +global(sml_font) /* int, ~2/3 times font_size */ + +include("shorten.li") + +proc main () +{ + set(refs,1) /*set this to have reference numbers printed*/ + indiset(sibs) + indiset(nextgen) + table(abbvtab) + call setupabbvtab() + + getindi(p) + newfile(concat(database(), ".", key(p), "-d.rtf"),0) + + call GetUserOptions() + set(genN,1) + set(Icnt,1) + addtoset(sibs,p,Icnt) + set(l,1) +/* set(mark,concat("\\fs", d(div(font_size,2)), "\\up4 +\\up0\\fs", d(font_size))) */ + set(mark,"*") + rtfH + "\\pard\\fs" + d(big_font) + "The Descendants of " upper(name(p)) "." + "\\ql\\ulnone\\\n\\fs" + d(font_size) + "\\\n" + + while(l) { + "\\pard\\qc\\i1\\fs" + d(big_font) " " capitalize(ord(genN))" Generation \\i0\\ql\\fs" + d(font_size) + "\\\n\\\n" + forindiset(sibs,person,var,i) { + rulI + upper(alpha(genN)) "-" d(var) "\t" name(person) + if(or(date(birth(person)),place(birth(person)))) { + ", b. " shorten(long(birth(person))) + if(refs) {call refRTF(birth(person)) } + } + if(or(date(baptism(person)),place(baptism(person)))) { + ", bt. " shorten(long(baptism(person))) + if(ifwitn(root(person))) {". "} + if(refs) {call refRTF(baptism(person)) } + } + if(or(place(death(person)),date(death(person)))) { + ", d. " shorten(long(death(person))) + if(refs) {call refRTF(death(person)) } + } + ".\\\n" + traverse(root(person),node,cnt) { + if (not(strcmp(tag(node),"NOTE"))) { + rulN value(node) call refRTF(node) " \n" + } + } + families(person,family,spouse,j) { + rulS + if(spouse) { + givens(person) " married " name(spouse) + if(date(marriage(family))) { + " " shorten(long(marriage(family))) + } + ". " + /*if(refs) {call refRTF(marriage(family))}*/ + "\n" + if(ifwitn(root(family))) {". "} + set(comma,0) + if(or(place(birth(spouse)),date(birth(spouse)))) { + set(comma,1) + pn(spouse,0) " was born " shorten(long(birth(spouse))) + }elsif(parents(spouse)) { + pn(spouse,0) " was born" shorten(long(birth(spouse))) + } + if(parents(spouse)) { + " to " + if(father(spouse)) { + set(comma,1) + name(father(spouse)) + if(mother(spouse)) { + set(comma,1) + " and " name(mother(spouse)) + } + }elsif(mother(spouse)) { + set(comma,1) + name(mother(spouse)) + } + } + if(or(date(death(spouse)),place(death(spouse)))) { + if(comma) {", "} + else { pn(spouse,0) " "} + "died " shorten(long(death(spouse))) + } + if(comma) {". "} + traverse(root(spouse),node,cnt) { + if (not(strcmp(tag(node),"NOTE"))) { + "\\\n" rulN value(node) call refRTF(node) + } + } + "\\\n" + } + else {"Spouse unknown.\\\n"} + children(family,kid,k) { + if(kid) { + set(genNx,add(genN,1)) + rulC + if(nfamilies(kid)) { + addtoset(nextgen,kid,Icnt) + upper(alpha(genNx)) "-" d(Icnt) mark "\t" name(kid) + if(date(birth(kid))) { + ", b. " shorten(date(birth(kid))) + } + if(date(baptism(kid))) { + ", bt. " shorten(date(baptism(kid))) + } + if(date(death(kid))) { + ", d. " shorten(date(death(kid))) + } + ".\\\n" + }else { + upper(alpha(genNx)) "-" d(Icnt) "\t" name(kid) + if(or(date(birth(kid)),place(birth(kid)))) { + ", b. " shorten(long(birth(kid))) + if(refs) {call refRTF(birth(kid)) } + } + if(or(date(baptism(kid)),place(baptism(kid)))) { + ", bt. " shorten(long(baptism(kid))) + if(ifwitn(root(kid))) {""} + if(refs) {call refRTF(baptism(kid)) } + } + if(or(date(death(kid)),place(death(kid)))) { + ", d. " shorten(long(death(kid))) + if(refs) {call refRTF(death(kid)) } + } + ".\\\n" + traverse(root(kid),node,cnt) { + if (not(strcmp(tag(node),"NOTE"))) { + "\t" value(node) call refRTF(node) "\\\n" + } + } + } + set(Icnt,add(Icnt,1)) + } + } + traverse(root(family),node,cnt) { + if (not(strcmp(tag(node),"NOTE"))) { + rulN value(node) call refRTF(node) " " + } + } + } + "\\\n" + } + set(l, lengthset(nextgen)) + indiset(sibs) + set(sibs,nextgen) + + indiset(nextgen) + set(genN,add(genN,1)) + set(Icnt,1) + } + rulI + "\\\n Generated " + date(gettoday()) + " from " + concat(database(),".gedcom") +/* " by YOU " */ + " using LifeLines genealogy software" + ". \\\n } " +} + +proc GetUserOptions () +{ +/* +** QUESTION: What font should be used? +** +** Because it is such a pain to enter a font name, and a spelling mistake +** will get you an ugly default font, this should be set to a default. I +** suggest one of: Times-Roman, NewCenturySchlbk-Roman, or ZapfChancery. +** This is a modification of code from the original psanc uing NeXT fonts +** -PB +** +*/ + + if (0) { + list(options) + setel(options, 1, "Roman") + setel(options, 2, "Italic") + set(ff, menuchoose(options, "Select font face: ")) + if (eq(1,ff)) { + list(options) + setel(options,1,"Times") + setel(options,2,"New Century Schoolbook") + setel(options,3,"Garamond") + set(mc, menuchoose(options, "Select font family: ")) + if (eq(3,mc)) { + set (font_name, "AGaramond-Regular") + } elsif (eq(2,mc)) { + set (font_name, "NewCenturySchlbk-Roman") + } else { + set (font_name, "Times-Roman") + } + }else { + setel(options,1,"Times") + setel(options,2,"New Century Schoolbook") + setel(options,3,"Garamond") + setel(options,4,"ZapfChancery") + set(mc, menuchoose(options, "Select font: ")) + if (eq(1,mc)) { + set (font_name, "Times-Italic") + } elsif (eq(2,mc)) { + set (font_name, "NewCenturySchlbk-Italic") + } elsif (eq(3,mc)) { + set (font_name, "AGaramond-Italic") + } elsif (eq(4,mc)) { + set (font_name, "ZapfChancery-MediumItalic") + } + } + } else { set (font_name, "Times-Roman") } + +/* +** QUESTION: What font size should be used? +** +** I set this to 20 by default, which is about 10pt. +** A title font is generated about 1/3 bigger (dividing integers here) +** -PB +** +*/ + if(0) { + getintmsg (font_size, "Enter the font size in points.") + set(font_size, mul(font_size,2)) + } else { + set(font_size, 20) + } + set(big_font,add(font_size,div(font_size,3))) + set(sml_font,sub(font_size,div(font_size,3))) + +/* +* Set RTF defaults. Modifed for Mac OS X TextEdit.app. +* Don't forget the terminal space character. +*/ + + set(rtfH, concat("{\\rtf1\\ansicpg1000{\\fonttbl\\f0\\fnil ", concat(font_name, ";}"))) + set(rtfH, concat(rtfH, "\n\\margl720\\margr720\\margt720\\margb720\\viewkind1")) + set(rtfH, concat(rtfH, "\n\\f0\\b0\\i0\\ulnone\\ql\\fs")) + set(rtfH, concat(rtfH, d(font_size))) + set(rtfH, concat(rtfH, "\\fi0\\li0")) + set(rulI, "\\pard\\tx720\\fi-720\\li720 ") + set(rulS, "\\pard\\fi-180\\li1080 ") + set(rulC, "\\pard\\tx1800\\fi-720\\li1800 ") + set(rulN, "\\pard\\fi-180\\li1080 ") +} + +func ifwitn (thisnode) +{ + set(needand,0) + set(amdone,0) + traverse(thisnode,x,y) { + if (not(strcmp(tag(x),"WITN"))) { + if(needand) {" and"} + " " value(x) + set(needand,1) + set(amdone,1) + } else {set(needand,0)} + } + if(amdone) {" witnessed"} + else {""} + return(amdone) +} + +proc refRTF (i) { + fornodes(i,node) { + if (not(strcmp(tag(node),"SOUR"))) { + set(text,strsave(value(node))) + if (index(text,"@",2)) { + set(text,substring(value(node),3,sub(strlen(text),1))) + } + "\\fs" d(sml_font) + "\\up" d(div(font_size,4)) + "(" text ")" + "\\fs" d(font_size) "\\up0" + } + } +} diff --git a/reports/dates.ll b/reports/dates.ll new file mode 100644 index 0000000..1bfd768 --- /dev/null +++ b/reports/dates.ll @@ -0,0 +1,184 @@ +/* + * @progname dates.ll + * @version 4 + * @author Eggert + * @category + * @output Text + * @description + +Prints out the value of all the lines in your database with the DATE +tag, along with enough information so you can find the line easily. +The purpose of this report is so you can sort all the dates in the +database, so you can look for illegal dates, make birthday lists, etc. +The dates are printed in the order that they appear in the database, +Output can then be sorted if this is more useful than the native form. + +dates - a LifeLines dates extraction program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 3 December 1992 + Version 2, 8 December 1992 (minor bug fix, report in columns) + Version 3, 5 February 1993 (speedup of tag handling) + Version 4, 1 September 1993 (bug fix for families with no parents) + +This code borrows heavily from the excellent program places, written +by David Olsen (dko@cs.wisc.edu), and contains improvements by Steve +Woodbridge (sew@pcbu.prime.com). + +Prints out the value of all the lines in your database with the DATE +tag, along with enough information so you can find the line easily. +The purpose of this report is so you can sort all the dates in the +database, so you can look for illegal dates, make birthday lists, etc. +The dates are printed in the order that they appear in the database, +so the report is not very useful in its native form. To make it more +useful, run the output file through the program 'sort', and perhaps +'grep' if you want to get only birthdates etc. To make sorting +easier, each date is preceded by a eight-digit number of the form +yyyymmdd. Then a simple ASCII line-by-line sort puts the dates in the +right order. Days and months are checked for validity (thirty days +hath September and all that) and futurity. It asks you if you want to +use the Gregorian calendar or the Julian calendar. This only affects +the validity of Feb 29ths, so don't fret too much. Any invalid or +future date is marked with a * as the first character of the line. +These will appear first in the sorted output. + +If the date is part of an individual record, it is followed by the key +and name of the individual and by the hierarchy of tags between it and +the INDI tag. (This is usually just a single tag, such as BIRT, CHR, +or DEAT.) If the date is part of a family record, it is followed by +the key and name of the husband (or the wife is there is no husband, +or first child if there is no parent), the relationship in the family +of that person, and by the hierarchy of tags between it and the FAM +tag. (This is usually just the single tag MARR.) Some sample output +(selected lines that have been sorted): + +15800000 ABT 1580 | BIRT | I4403 Valentin BISMARCK +15810000 1581 | DEAT | I41 Catherina +15821221 21 DEC 1582 | BIRT | I4404 Berta ASSEBURG +15850000 ABT 1585 | BIRT | I2595 Henrich SPANUTH +15850529 29 MAY 1585 | DEAT | I4418 Brigitte BISMARCK +15860000 1586 | BIRT | I2596 Johan SPANUTH +15860301 1 MAR 1586 | BIRT | I2675 Catharine SPANUTH +15870000 1587/1589 | BIRT | I2597 Caspar SPANUTH +15880201 1 FEB 1588 | BIRT | I2676 Johan SPANUTH +15890226 26 FEB 1589 | BIRT | I2677 Johan SPANUTH +15960000 1596 | MARR | F883 I2679 Arend KOLLE, husb +16421009 9 OCT 1642 | BURI | I4404 Berta ASSEBURG +19800108 8 JAN 1980 | ENDL | I3635 Maria Catharina KINDLER +19800124 24 JAN 1980 | CHIL SLGC | F948 I2336 Anselm KINDLER, husb + +*/ + +global(today) +global(tomonth) +global(toyear) +global(julian) + +proc do_date(datenode) +{ + extractdate(datenode,day,month,year) + if (or(le(month,0),gt(month,12))) { set(daysinmonth,0) } + elsif (or(or(eq(month,9),eq(month,4)), + or(eq(month,6),eq(month,11)))) { set(daysinmonth,30) } + elsif (eq(month,2)) { + if (and(eq(mod(year,4),0), + or(julian,or(ne(mod(year,100),0),eq(mod(year,400),0))))) { + set(daysinmonth,29) } + else { set(daysinmonth,28) } + } + else { set(daysinmonth,31) } + set(future,0) + if (gt(year,toyear)) { set(future,1) } + elsif (eq(year,toyear)) { + if (gt(month,tomonth)) { set(future,1) } + elsif (and(eq(month,tomonth),gt(day,today))) { set(future,1) } + } + if (or(gt(day,daysinmonth),future)) { "*" } + if (lt(year,0)) { d(year) } + else { + if (lt(year,10)) { "0" } + if (lt(year,100)) { "0" } + if (lt(year,1000)) { "0" } + d(year) + } + if (lt(month,10)) { "0" } + d(month) + if (lt(day,10)) { "0" } + d(day) " " +} + + +proc main() +{ + getintmsg(julian, + "Enter 0 for Gregorian (normal) or 1 for Julian (old) calendar") + extractdate(gettoday(),today,tomonth,toyear) + + list(tag_stack) + + print("Printing all dates.\n") + print("Be patient. This may take a while.\n") + + forindi (person, pnum) { + + traverse (inode(person), node, level) { + + setel(tag_stack, add(level, 1), tag(node)) + + if (eq(strcmp(tag(node), "DATE"), 0)) { + call do_date(node) + value(node) col(31) "| " + set(tlength,0) + set(tcount,0) + forlist (tag_stack, a_tag, tnum) { + if (and(gt(tnum, 1), le(tnum, level))) { + a_tag " " + set(tlength,add(tlength,strlen(a_tag))) + set(tcount,add(tcount,1)) + } + } + set(tlength,add(tlength,tcount)) + if (lt(tlength,5)) { col(38) } + "| " key(person) + col(add(41,mul(5,tcount))) name(person) "\n" + } + } + } + forfam (fam, fnum) { + traverse (fnode(fam), node, level) { + + setel(tag_stack, add(level, 1), tag(node)) + + if (eq(strcmp(tag(node), "DATE"), 0)) { + call do_date(node) + value(node) col(31) "| " + set(tlength,0) + set(tcount,0) + forlist (tag_stack, a_tag, tnum) { + if (and(gt(tnum, 1), le(tnum, level))) { + a_tag " " + set(tlength,add(tlength,strlen(a_tag))) + set(tcount,add(tcount,1)) + } + } + set(tlength,add(tlength,tcount)) + if (lt(tlength,5)) { col(38) } + "| " key(fam) + if (person,husband(fam)) { set(relation,", husb") } + elsif (person,wife(fam)) { set(relation,", wife") } + else { + children(fam,child,cnum) { + if (eq(cnum,1)) { + set(person,child) + set(relation,", chil") + } + } + } + if (person) { + col(add(41,mul(5,tcount))) key(person) " " + col(add(47,mul(5,tcount))) name(person) relation + } + "\n" + } + } + } +} diff --git a/reports/db_summary.ll b/reports/db_summary.ll new file mode 100644 index 0000000..06dd4df --- /dev/null +++ b/reports/db_summary.ll @@ -0,0 +1,147 @@ +/* + * @progname db_summary.ll + * @version 1 + * @author Eggert + * @category + * @output Text + * @description + +This program gives you summary statistics on your database. It +calculates the number of birth, baptism, marriage, death, and burial +events, and gives the distribution over centuries of birth/baptisms, +death/burials, and marriages. It tells you how many different names +(given names and surnames separately) there are in the database, and +how many persons have no surname in the database. + +db_summary - a LifeLines database summary program + by Jim Eggert (eggertj@ll.mit.edu) + Version 1, 29 March 1995 Initial release +*/ + +proc main() { + table(surnames) + table(givens) + list(bcents) + list(dcents) + list(mcents) + + list(namelist) + + set(nsurnames,0) + set(ngivens,0) + set(nnosurnames,0) + set(nnogivens,0) + set(nemptysurnames,0) + set(nbirths,0) + set(nbaptisms,0) + set(nmarrs,0) + set(ndeaths,0) + set(nburials,0) + + print("Collecting individual statistics...") + forindi(person,pnum) { +/* Do individual event statistics */ + set(by,0) + if (b,birth(person)) { + incr(nbirths) + extractdate(b,bd,bm,by) + } + if (b,baptism(person)) { + incr(nbaptisms) + if (not(by)) { extractdate(b,bd,bm,by) } + } + call increment_century(bcents,by) + + set(dy,0) + if (d,death(person)) { + incr(ndeaths) + extractdate(d,dd,dm,dy) + } + if (d,burial(person)) { + incr(nburials) + if (not(dy)) { extractdate(d,dd,dm,dy) } + } + call increment_century(dcents,dy) + +/* Do name statistics */ + extractnames(inode(person),namelist,nnames,isurname) + if (not(isurname)) { incr(nnosurnames) } + forlist(namelist,name,nnum) { + if (eq(nnum,isurname)) { + if (not(lookup(surnames,name))) { + incr(nsurnames) + insert(surnames,save(name),save(key(person))) + } + if (not(strcmp(name,""))) { + incr(nemptysurnames) + } + if (not(name)) { incr(nnosurnames) } + } + else { + if (not(lookup(givens,name))) { + incr(ngivens) + insert(givens,save(name),save(key(person))) + } + } + } + } + + print("done.\nCollecting family statistics...") + forfam(family,fnum) { + set(by,0) + if (m,marriage(family)) { + incr(nmarrs) + extractdate(m,md,mm,my) + call increment_century(mcents,my) + } + } + + print("done.\nGenerating report...") + "The database " database() " contains:\n" + d(pnum) " individuals\n" + d(nsurnames) " unique surnames\n" + d(ngivens) " unique given names\n" + d(nemptysurnames) " individuals with empty surnames\n" + d(nnosurnames) " individuals with no surname\n" + d(nbirths) " birth events\n" + d(nbaptisms) " baptism events\n" + "Birth/baptism events distributed by century as\n" + call list_centuries(bcents) + d(ndeaths) " death events\n" + d(nburials) " burial events\n" + "Death/burial events distributed by century as\n" + call list_centuries(dcents) + "\n" + d(fnum) " families\n" + d(nmarrs) " marriage events distributed by century as\n" + call list_centuries(mcents) + print("done.\n") +} + +proc increment_century(centuries,year) { + if (year) { + set(century,div(year,100)) + if (not(length(centuries))) { + enqueue(centuries,century) + enqueue(centuries,1) + } + else { + set(first_century,dequeue(centuries)) + while (lt(century,first_century)) { + requeue(centuries,0) + set(first_century,sub(first_century,1)) + } + set(index,add(1,sub(century,first_century))) + setel(centuries,index,add(getel(centuries,index),1)) + requeue(centuries,first_century) + } + } +} + +proc list_centuries(centuries) { + set(century,dequeue(centuries)) + while (count,dequeue(centuries)) { + " " d(century) "00s " d(count) "\n" + incr(century) + } +} diff --git a/reports/desc-henry.ll b/reports/desc-henry.ll new file mode 100644 index 0000000..6e19fab --- /dev/null +++ b/reports/desc-henry.ll @@ -0,0 +1,289 @@ +/* + * @progname desc-henry.ll + * @version 8 + * @author Eggert + * @category + * @output Text + * @description + +This program prints out a descendants report, assigning a d'Aboville, +Henry, modified Henry, or modern Henry code to the individuals. The +chosen ancestor, and all of his/her spouses, descendants, and +descendants' spouses are included in the report. + +desc-henry - a LifeLines descendants listing program using Henry codes + by Jim Eggert (eggertj@atc.ll.mit.edu) + Versions 1-3 1992 + Version 4, 7 Jan 1993 (added generation limit) + Version 5, 22 Dec 1993 (added header, trailer, and optional keys) + Version 6, ??????????? + Version 7, 17 Mar 1995 (added grouped code option) + Version 8, 6 Jun 1995 (added numbering options) + +Some sample codes are: + d'Aboville Henry modified Henry modern Henry +root 1 1 1 1 +child 1 1.1 11 11 11 +child 10 1.10 1X 1(10) 1A +child 11 1.11 1A 1(11) 1B +child 20 1.20 1J 1(20) 1K +g-child 1.20.1 1J1 1(20)1 1K1 +gg-child 1.20.1.4 1J14 1(20)14 1K14 +ggg-child 1.20.1.4.15 1J14E 1(20)14(15) 1K14F +gggg-child 1.20.1.4.15.3 1J14E3 1(20)14(15)3 1K14F3 + +Spouses codes, if requested, are indicated by appending .sn, where n +indicates which spouse is meant, and is omitted if there is only one +spouse. The root code is user selectable so that you can have +arbitrary code prefixes. + +I use the latter feature when my database indicates that person X was +not a descendant of Y, but I want to rig up a report which indicates X +is to be included in Y's descendancy. I make two reports, one of Y's +real descendancy, and the second of X's giving X the number he would +have in Y's descendancy. Then I need merely edit the two files to +achieve the desired result. + +The program can also generate grouped codes, where the generation +separator (if any) is replace by a comma every three generations. The +choice of arbitrary roots indicates that an additional parameter, the +initial comma location, be selectable. The grouped format is +sometimes used in published genealogies, using a single capital letter +for the root symbol. + +The user can elect to include only male descendance lines. This is +useful for single-name studies. In this case, spouses are not printed +as separate entries, but are indicated with the descendant. For +female descendants, an indication of the number of children is also +printed. + +The user can select whether no dates, simple dates (birth - death), or +dates and places (birth, baptism, death, burial, one per line) are to +be printed. Also top-level notes can be optionally printed. The +program only understands PAF-like events and notes. Printing simple +dates and no notes gives a useful one-line-per-person outline. + +The user can also elect to limit the number of generations to be printed +out. Selecting 0 means all generations will be printed out. + +The user can also elect to include keys for each individual in the report. + +The user can also elect to exclude, with annotation, repeated individuals. + +The report will include a header and a trailer. You may easily modify the +do_header() and do_trailer() procedures to alter or eliminate these if +you wish. + +*/ + +global(do_notes) +global(do_dates) +global(do_keys) +global(generations) +global(written_people) +global(this_indi_already_done) +global(notation) +global(grouped) +global(code_sep) +global(group_sep) +global(comma_separation) +global(first_comma) +global(malesonly) + +proc main () +{ + table(written_people) + dayformat(1) + monthformat(4) + getindimsg(indi_root, + "Enter root individual for report generation") + getstrmsg(root, + "Enter Henry code string for root individual (usually 1)") + list(henry_list) + push(henry_list,save(root)) + + list(choices) + enqueue(choices,save(concat("d'Aboville ",root,".5.12.10"))) + enqueue(choices,save(concat("Henry ",root,"5BX"))) + enqueue(choices,save(concat("modified Henry ",root,"5(12)(10)"))) + enqueue(choices,save(concat("modern Henry ",root,"5CA"))) + set(notation,menuchoose(choices,"Select notation:")) + + if (eq(notation,1)) { set(code_sep,".") } else { set(code_sep,"") } + getintmsg(grouped, + "Enter 0 for ungrouped notation, 1 for grouped notation") + if (grouped) { + getintmsg(comma_separation, + "Enter comma separation, usually 3") + getintmsg(first_comma, + "Enter comma offset (0-2, default=0)") + set(group_sep,",") + } else { + set(group_sep,"") + set(comma_separation,999) + set(first_comma,0) + } + getintmsg(do_dates, + "Enter 0 for no dates, 1 for dates, 2 for dates+places") + getintmsg(do_notes,"Enter 0 for no notes, 1 for notes") + getintmsg(do_keys,"Enter 0 for no keys, 1 for keys") + getintmsg(malesonly, + "Enter 0 for all descendants, 1 for male lines only") + getintmsg(generations,"Enter number of generations (0=all)") + call do_header(indi_root) + call desc_sub(indi_root,henry_list) + call do_trailer(indi_root) +} + +proc do_header(indi_root) +{ + "desc-henry: Descendant report for " fullname(indi_root,0,1,80) + if (do_keys) { " (" key(indi_root) ")" } + "\nGenerated by the LifeLines Genealogical System on " + stddate(gettoday()) ".\n\n" +} + +proc do_trailer(indi_root) +{ + "\nEnd of Report\n" +} + +proc do_name(person,henry_list,marr) +{ + set(h,"") + set(c,sub(first_comma,1)) + /* less one for the root symbol */ + forlist(henry_list,l,li) { + if (not(strcmp(trim(l,1),"s"))) { + set(h,save(concat(h,".",l))) + } + else { + if (eq(li,1)) { set(h,concat(h,l)) } + elsif (and(grouped,eq(c,0))) { set(h,concat(h,group_sep,l)) } + else { set(h,concat(h,code_sep,l)) } + incr(c) + set(c,mod(c,comma_separation)) + } + } + h ". " + if (person) { fullname(person,0,1,80) } else { "" } + if (and(person,eq(do_keys,1))) { " (" key(person) ")" } + if (l,lookup(written_people,key(person))) { + " appears above as " l "\n" + } + else { + if (person) { insert(written_people,save(key(person)),h) } + if (and(person,eq(do_dates,1))) { + " (" + set(e,birth(person)) + if (and(e,date(e))) { date(e) } + else { + set(e,baptism(person)) + if (and(e,date(e))) { "bap." date(e) } + } + " - " + set(e,death(person)) + if (and(e,date(e))) { date(e) } + else { + set(e,burial(person)) + if (and(e,date(e))) { "bur." date(e) } + } + ")" + } + "\n" + if (eq(do_dates,2)) { + if (person) { + if (e,birth(person)) { " b: " long(e) "\n" } + if (e,baptism(person)) { " bap: " long(e) "\n" } + } + if (marr) { " m: " long(marr) "\n"} + if (malesonly) { + set(nfam,nfamilies(person)) + families(person,fam,sp,spi) { + if (gt(nfam,1)) { " m" d(spi) } + else { " m" } + ": " long(marriage(fam)) + " to " if (sp) { fullname(sp,0,1,80) } else { "" } + if (female(person)) { + ", " + set(nc,nchildren(fam)) + if (not(nc)) { "no children" } + else { + card(nc) " child" if (gt(nc,1)) { "ren" } + } + } + "\n" + } + } + if (person) { + if (e,death(person)) { " d: " long(e) "\n" } + if (e,burial(person)) { " bur: " long(e) "\n" } + } + } + if (and(person,eq(do_notes,1))) { + fornodes(inode(person), node) { + if (eq(0,strcmp("FILE", tag(node)))) { + copyfile(value(node)) } + elsif (eq(0,strcmp("NOTE", tag(node)))) { + " " value(node) "\n" + fornodes(node, subnode) { + if (eq(0,strcmp("CONT", tag(subnode)))) { + " " value(subnode) "\n" } + } + } + } + fornodes(inode(person), node) { + if (eq(0,strcmp("REFN", tag(node)))) { + " SOURCE: " value(node) "\n" + } + } + } + if (or(eq(do_dates,2),eq(do_notes,1))) { "\n" } + } +} + +func desc_code(number) +{ + if (eq(notation,1)) { return(d(number)) } + if (eq(notation,2)) { + if (lt(number,10)) { return(d(number)) } + if (eq(number,10)) { return("X") } + return(upper(alpha(sub(number,10)))) + } + if (eq(notation,3)) { + if (lt(number,10)) { return(d(number)) } + return(concat("(",d(number),")")) + } + if (eq(notation,4)) { + if (lt(number,10)) { return(d(number)) } + return(upper(alpha(sub(number,9)))) + } + return("?") +} + + +proc desc_sub(person,henry_list) +{ + call do_name(person,henry_list,0) + set(nfam,nfamilies(person)) + set(chi,0) + families(person,fam,sp,spi) { + if (not(malesonly)) { + if (gt(nfam,1)) { push(henry_list,save(concat("s",d(spi)))) } + else { push(henry_list,"s") } + call do_name(sp,henry_list,marriage(fam)) + set(junk,pop(henry_list)) + } + if (or(eq(generations,0), + lt(length(henry_list),generations))) { + if (or(not(malesonly),male(person))) { + children (fam,ch,famchi) { + incr(chi) + push(henry_list,save(desc_code(chi))) + call desc_sub(ch,henry_list) + set(junk,pop(henry_list)) + } + } + } + } +} diff --git a/reports/desc-tex2/Makefile.am b/reports/desc-tex2/Makefile.am new file mode 100644 index 0000000..875d627 --- /dev/null +++ b/reports/desc-tex2/Makefile.am @@ -0,0 +1,25 @@ +# This makefile is for the lifelines reports + +AUTOMAKE_OPTIONS = no-dependencies + +# LL_REPORTS is to hold the actual report files +# (included files go in a different target below) +LL_REPORTS = desc-tex.ll desc-tex2.ll + +# OTHER_REPORTS is to hold included files besides actual report files +# (eg, supporting files, graphics, included files) +OTHER_REPORTS = \ + drtree.tex extree2.tex \ + poster2.tex \ + pstricks.con README \ + ex1.tex mysetup.tex poster.doc \ + pstricks.pro setup.tex \ + drsetup.tex extree1.tex \ + poster1.tex \ + poster.tex pstricks.tex tree.tex + +pkg_REPORTS = $(LL_REPORTS) $(OTHER_REPORTS) + +subreportdir = $(pkgdatadir)/desc-tex2 +subreport_DATA = $(pkg_REPORTS) +dist_subreport_DATA = $(pkg_REPORTS) diff --git a/reports/desc-tex2/README b/reports/desc-tex2/README new file mode 100644 index 0000000..d400eb6 --- /dev/null +++ b/reports/desc-tex2/README @@ -0,0 +1,41 @@ +desc-txt is a program to generate Descendent tree's in TeX. +Written by Eric Majani, modified by Pete Glassernbury, Jim Eggert +and D. Roegel. + +Here is a short description of the files contained in this directory: + +README -> this file +desc-tex.ll -> version 1 of desc-tex +desc-tex2.ll -> version 2 of desc-tex +drsetup.tex -> general personnalisation TeX macros + (don't change this file; change mysetup.tex) +drtree.tex -> modified tree macros for desc-tex2 +ex1.tex -> an example showing how to merge two or more + trees ``by hand'' and using invisible nodes. +extree1.tex -> Source of previous file. +extree2.tex -> Source of previous file. +mysetup.tex -> Personal setup: feel free to modify this file. +poster.doc -> source documentation of the poster macros +poster.tex -> Tim Van Zandt's poster macros +poster1.tex -> other poster macros +poster2.tex -> other poster macros +pstricks.con -> pstricks configuration file (you normally + don't need to change it) +pstricks.pro -> prologue file for dvips + (needs to be put where dvips can find it) +pstricks.tex -> Tim Van Zandt's pstricks macros. +setup.tex -> some TeX macros used by version 1 of desc-tex +tree.tex -> original tree macros for version 1 of desc-tex + +-------------------------------------------------------------------------- +How to make it work ? + + - call the desc-tex2 report from Lifelines + - answer the questions + - generate a file .tex + - apply TeX (not LaTeX) to this file + - preview it with xdvi or an other previewer + - generate PostScript with dvips + +-------------------------------------------------------------------------- + diff --git a/reports/desc-tex2/desc-tex.ll b/reports/desc-tex2/desc-tex.ll new file mode 100644 index 0000000..f6e5efa --- /dev/null +++ b/reports/desc-tex2/desc-tex.ll @@ -0,0 +1,97 @@ +/* + * @progname desc-tex.ll + * @version 1995-01-01 + * @author Eric Majani (eric@elroy.jpl.nasa.gov) + * @category + * @output TeX + * @description + * + * Descendent tree in TeX. + * This has been modified to add the suggested poster support by + * Pete Glassenbury and Jim Eggert. This is not an official copy from + * Eric nor have I tried it. + * + * Slight changes by D. Roegel (roegel@loria.fr), 1/1/1995 + */ + +global(depth) +global(level) + +proc main () +{ + getindi(indi) + set(prompt,"Enter number of generations desired") + getintmsg(depth,prompt) + "\\input setup\n" + "\\input poster\n" + /* next line corrected by D. Roegel, 1/1/1995 */ + "\\Poster[hcenter=true,vcenter=true,paperwidth=210mm,paperheight=297mm]\n" + "\\vbox{% Because \\Poster processes in horizontal mode,\n" + "% but your tree macros are in vertical mode.\n" + "\\tree\n" + set(level,1) + call descout(indi) + "\\endtree\n" + "}% End of \\vbox\n" + "\\endPoster\n" + "\\end\n" + +} + +proc printindi(indi) +{ + "{\\bf " name(indi) "}" nl() + if (e, birth(indi)) { " b. " short(e) nl() } + spouses(indi,sp,fam,num) { if(e,marriage(fam)) { " m. " short(e) nl() } + } + if (e, death(indi)) { " d. " short(e) nl() } +} + +proc printcouple(indi,fam,num) +{ + if(eq(num,1)) + { + "{\\bf " name(indi) "}" nl() + if (e, birth(indi)) { " b. " short(e) nl() } + } + if (e,marriage(fam)) { " m. " short(e) nl() } + if(eq(num,nspouses(indi))) + { + if (e, death(indi)) { " d. " short(e) nl() } + } +} + +proc printfam(indi,fam,sp) +{ + "\\spouse{ " name(sp) "}" nl() +} + +proc descout(indi) +{ + if(eq(0,nspouses(indi))) + { + call printindi(indi) + } + spouses(indi,sp,fam,num) + { + call printcouple(indi,fam,num) + call printfam(indi,fam,sp) + set(level,add(level,1)) + if(le(level,depth)) + { + children(fam,child,no) + { + "\\subtree " nl() + call descout(child) + "\\endsubtree " nl() + } + } + set(level,sub(level,1)) + if(ne(num,nspouses(indi))) + { + "\\endsubtree " nl() + "\\subtree " nl() + } + } +} + diff --git a/reports/desc-tex2/desc-tex2.ll b/reports/desc-tex2/desc-tex2.ll new file mode 100644 index 0000000..abbe066 --- /dev/null +++ b/reports/desc-tex2/desc-tex2.ll @@ -0,0 +1,383 @@ +/* + * @progname desc-tex2.ll + * @version 2 of 1995-01-16 + * @author Majani and Roegel + * @category + * @output TeX + * @description + * + * DESC-TEX2 report for Lifelines genealogical system + * prints a descendent chart in TeX format, with credits + * + * Version 1 by Eric Majani (eric@elroy.jpl.nasa.gov) end 1992 + * ------------------------ + * + * This has been modified to add the suggested poster support by + * Pete Glassenbury and Jim Eggert. + * + * Version 2 by Denis Roegel (roegel@loria.fr) 31 december 1994 + * ------------------------- -- 16 january 1995 + * + * Various modifications including: better multilingual support; + * More information on the tree; + * nodes are framed + * except those corresponding + * to 2nd, 3rd family, etc. + * (that way, each descendant is + * framed only once); + * When two or more branches rejoin, + * only the first traversed is complete; + * Genealogical symbols added for + * birth, wedding and death; + * Support for clipping; + * Support for "hand-merging" of trees + * (see file ex1.tex); + * Six kinds of subtree nodes + * (see file drtree.tex); + * Fonts are easily customizable + * (see in drsetup.tex); + * Currently, sans serif fonts are used + * since this seems best for xeroxing + * and it improves readability; + * Title and credits. + * + * Thanks to Tom Wetmore, John Chandler and Michael P. Gerlek + * for useful comments, hints, and bits of functions. + * + * Other comments welcome, but please, for question regarding TeX, + * ask your local guru. Please. + * + + THINGS TO DO: find out why there are messages like this one: + + Overfull \vbox (0.79999pt too high) detected at line 298 + + (I think this is something due to bad framing, since + 0.8pt is twice the thickness of the frame) + + + KNOWN PROBLEMS: + + 1) Since the whole tree has to be stored in one TeX box, + and that this box is limited in the amount of information + it may contain, you are likely to be unable to put more than + 200 or 300 descendants on a tree; the limit is not fixed + and depends on the amount of information per person. + If you only display the name of a descendant, you can go farther + than if you display his whole life! + + 2) An other problem occurs before even the first problem, + but does not lead to a TeX error message (while the first + problem does); the tree seems to be strangely mixed; + I do not yet know the reason, but I suspect it to be in + the tree macros. The problem was already present with the original + tree macros. + + + * This is the first program I (DR) have modified. + */ + +global(depth) +global(maxdepth) /* the max depth encountered so far */ +global(level) +global(done) /* will record the families already done */ +global(refno) /* reference number for indi */ + +proc main () +{ + table(done) + getindi(indi) + set(prompt,"Enter number of generations desired") + getintmsg(depth,prompt) + set(prompt,"Do you want a clipping ? (y/n)") + getstrmsg(answer,prompt) + if (or(eqstr(answer,"y"),eqstr(answer,"Y"))) + {set(clipping,1)} + else + {set(clipping,0)} + set(prompt,"Do you use US paper ? (y/n)") + getstrmsg(answer,prompt) + if (or(eqstr(answer,"y"),eqstr(answer,"Y"))) + {set(uspaper,1)} + else + {set(uspaper,0)} + set(prompt,"Do you want credits ? (y/n)") + getstrmsg(answer,prompt) + if (or(eqstr(answer,"y"),eqstr(answer,"Y"))) + {set(credits,1)} + else + {set(credits,0)} + "%\\mag1000 % this is default value of \\mag\n" + if (clipping) {"\\input pstricks\n"} + "\\input poster\n" + "\\input drsetup\n" + "\\Poster[hcenter=true,%\n" + " vcenter=true,%\n" + if (clipping) {" clip=pstricks,%\n"} + " cropwidth=.4pt" + call paperdims(uspaper) + "]\n" + "\\vbox{\\setbox0=\\vbox{%" + " Because \\Poster processes in horizontal mode,\n" + "% but the tree macros are in vertical mode.\n" + if (le(nfamilies(indi),1)) + {"\\tree{normal}\n"} + else + { + "\\tree{unframed;norules}\n" + "\\subtree{framed;rules:right}\n" + } + set(maxdepth,1) + set(level,1) + call descout(indi) + if (le(2,nfamilies(indi))) {"\\endsubtree\n"} + "\\endtree\n" + "}% End of \\vbox\n" + "\\title{" call show_name(indi) "}" + "{" call print_title_birth(indi) "}" + "{" call print_title_death(indi) "}" + "{" decr(maxdepth) d(maxdepth) "}" + "{\\wd0}\n" + "\\vskip2cm\n" + "\\copy0\n" + "\\vskip1cm\n" + "\\noindent\\rlap{\\hbox to\\wd0{\\hss" + if (credits) {"\\credits"} + "}}}\n" + "\\endPoster\n" + "\\end\n" + +} + + +proc printindi(indi) +{ + "{\\descfont " call show_name(indi) "}" nl() + call print_occupation(indi,5) + call print_birth(indi,5) + call print_baptism(indi,5) + call print_death(indi,5) +} + +proc printcouple(indi,fam,num) +{ + if(eq(num,1)) + { + "{\\descfont " call show_name(indi) "}" nl() + "\\sepline " nl() + call print_occupation(indi,5) + call print_birth(indi,5) + call print_baptism(indi,5) + call print_death(indi,5) + } + else + {"{$\\langle$ \\descfont " call show_name(indi) " $\\rangle$}" nl()} + call print_marriage(fam,5) +} + +proc printfam(indi,fam,sp) +{ + "\\hglue5mm\\spouse{" call show_name(sp) "}" nl() + call print_occupation(sp,10) + call print_birth(sp,10) + call print_baptism(sp,10) + call print_death(sp,10) +} + +proc descout(indi) +{ + if (eq(0,nfamilies(indi))){call printindi(indi)} + else { + families(indi,fam,sp,num) + { + call printcouple(indi,fam,num) + if (sp) {call printfam(indi,fam,sp)} + if (lookup(done, key(fam))) {call already_seen()} + else{ + if (le(maxdepth,level)) {incr(maxdepth)} + set(level,add(level,1)) + if(le(level,depth)) + { + children(fam,child,no) + { + "\\subtree{normal}% " nl() + call descout(child) + "\\endsubtree " nl() + } + } + set(level,sub(level,1)) + } + set(refno,add(refno,1)) /* increment global counter */ + insert(done, save(key(fam)), refno) + if(ne(num,nfamilies(indi))) + { + "\\endsubtree " nl() + if (eq(level,1)) + {"\\subtree{unframed;rules:right}% "} + else {"\\subtree{unframed;rules:left,right}% "} nl() + } + + } + } +} + + +proc print_birth(indi,mmshift) +{ + if (e, birth(indi)) { "\\hglue" d(mmshift) "mm " call btag() + call show_date_place(e) nl() } +} + +proc print_baptism(indi,mmshift) +{ + if (e, baptism(indi)) { "\\hglue" d(mmshift) "mm " call bapttag() + call show_date_place(e) nl() } +} + + + +proc print_title_birth(indi) +{ + if (e, birth(indi)) { call show_date(e) } +} + + + +proc print_marriage(fam,mmshift) +{ + if (e,marriage(fam)) { "\\hglue" d(mmshift) "mm " call mtag() + call show_date_place(e) nl() } +} + +proc print_death(indi,mmshift) +{ + if (e, death(indi)) { "\\hglue" d(mmshift) "mm " call dtag() + call show_date_place(e) nl() } +} + +proc print_title_death(indi) +{ + if (e, death(indi)) { call show_date(e) } +} + + +proc print_occupation(indi,mmshift) +{ + fornodes (inode(indi), n) { + if (eq(strcmp(tag(n), "OCCU"), 0)) { + "\\hglue" d(mmshift) "mm\\occupation{" + value(n) "}" nl() + } + } +} + +proc show_name (i) +{ + list(parts) + extractnames(inode(i), parts, n, s) + set(head, dequeue(parts)) + call print_name_element(head) + forlist (parts, el, n) {" " call print_name_element(el)} +} + +proc show_date_place(e) +{ + if (date(e)) { "{\\datefont " call show_date(e) "} " } + "{\\placefont " call at() "}" + "{\\placefont " + if (place(e)) { place(e) } + else {" ? "} + "}" /* end of \placefont */ +} + + +proc show_date(e) +{ + list(parts) + extracttokens(date(e), parts, n, " ") + set(head, dequeue(parts)) + call print_date_element(head) + forlist (parts, el, m) {" " call print_date_element(el)} +} + +/* This is for my personal conventions: I use /Unknown/ + for unkown names */ +proc print_name_element(el) +{ + if (eqstr("UNKNOWN", el)) { "\\unknown{}" } + elsif (eqstr("Unknown", el)) { "\\unknown{}" } + else { el } +} + +proc print_date_element(el) +{ + if (eqstr("ABT", el)) { "$\\sim$" } + elsif (eqstr("JAN", el)) { "\\jan{}" } + elsif (eqstr("FEB", el)) { "\\feb{}" } + elsif (eqstr("MAR", el)) { "\\mar{}" } + elsif (eqstr("APR", el)) { "\\apr{}" } + elsif (eqstr("MAY", el)) { "\\may{}" } + elsif (eqstr("JUN", el)) { "\\jun{}" } + elsif (eqstr("JUL", el)) { "\\jul{}" } + elsif (eqstr("AUG", el)) { "\\aug{}" } + elsif (eqstr("SEP", el)) { "\\sep{}" } + elsif (eqstr("OCT", el)) { "\\oct{}" } + elsif (eqstr("NOV", el)) { "\\nov{}" } + elsif (eqstr("DEC", el)) { "\\dec{}" } + else { el } +} + +/* Ideally, all the following should go in a TeX library for Lifelines */ + +proc btag() +{ + "\\btag\\ " +} + +proc bapttag() +{ + "\\bapttag\\ " +} + + + +proc mtag() +{ + "\\mtag\\ " +} + +proc dtag() +{ + "\\dtag\\ " +} + +proc at() +{ + "\\at\\ " +} + +proc paperdims(uspaper) +{ + if (not(eq(uspaper,1))) + { + /* this is for A4 paper */ + ",paperwidth=210mm,paperheight=297mm" + } + + /* US paper is the default */ + +} + +proc already_seen() +{ + "\\subtree{normal}% " nl() + "\\seeabove " nl() + "\\endsubtree " nl() +} + +func eqstr(s1,s2) +{ + if (eq(strcmp(s1,s2),0)) {return(1)} + else {return(0)} +} + diff --git a/reports/desc-tex2/drsetup.tex b/reports/desc-tex2/drsetup.tex new file mode 100644 index 0000000..e815271 --- /dev/null +++ b/reports/desc-tex2/drsetup.tex @@ -0,0 +1,193 @@ +% drsetup.tex +% +% Some definitions for desc-tex2 +% +% D. Roegel, (roegel@loria.fr) 15 January 1995 +% +% Don't modify this file, but the file mysetup.tex, +% which is loaded at the end of this file. +% ================================================ +% +% +\newif\ifDR +% Uncomment this ONLY if you are the author +% +%\DRtrue +% +\hsize=10in +\vsize=7.5in +\parindent=20pt +% This can probably be removed: + \hoffset=-0.8in + \voffset=-0.8in +% +\nopagenumbers +% +% english \today +\def\today{\ifcase\month\or + January\or February\or March\or April\or May\or June\or + July\or August\or September\or October\or November\or December\fi + \space\number\day, \number\year} +% +% This is for the frenchmen... (and includes french definition of \today) +\ifDR + \input french.sty +\fi +% +% The tree macros: must be loaded after french.sty, *if* french.sty +% is loaded, otherwise some things won't work +% (the test for the \tree and \subtree arguments won't work +% because they are not `catcode-independant' and french.sty changes +% some key catcodes) +% +\input drtree +% +% The credits: +% (put your favorite text here) +\def\credits{\vbox{\hsize15cm\noindent + This tree was made on \today\ by ******* with + the {\tt Lifelines} program (from T.~Wetmore), the \TeX\ + text processor (from D.~Knuth), + \TeX\ commands for trees (from D.~Eppstein), + \TeX\ commands for posters (from T. Van Zandt) + and a program by E.~Majani completed by D.~Roegel.\par + It may contain mistakes or omissions and I please + those who would notice some to signal them to me at the + following address:\par + \noindent$\underline{\hbox{\tt **, + **, + **, + USA}}$}} +\ifDR +\def\credits{\vbox{\hsize15cm\noindent + Cet arbre a \'et\'e r\'ealis\'e le \today\ + par Denis Roegel \`a l'aide du logiciel {\tt Lifelines} + (de T.~Wetmore), du formatteur \TeX\ (de D.~Knuth), de + commandes \TeX\ de r\'ealisation d'arbres (de D.~Eppstein), + de commandes \TeX\ de d\'ecoupage (de T. Van Zandt) + et d'un programme de E.~Majani compl\'et\'e par moi-m\^eme.\par + Il peut comporter des erreurs ou des omissions et je prie + ceux qui en rel\`everaient de me les signaler \`a l'adresse + suivante:\par + \noindent$\underline{\hbox{\tt Denis Roegel, + 7 rue de la fonderie, + 67400 ILLKIRCH-GRAFFENSTADEN}}$}} +\fi +% +%--------------------------------------------------------------------------- +% Title of the tree +% +% The title is centered above the tree +% You can change the title fonts here. +% You may also change the title text in the report produced. +% +%--------------------------------------------------------------------------- +\font\titlefont=cmbx12 scaled 4300 +\font\subtitlefont=cmbx10 scaled \magstep5 +\ifDR % this is for the author only + \def\title#1#2#3#4#5{% #1 = name of the ancestor + % #2 = birth date + % #3 = death date + % #4 = number of generations (children=only one generation) + % #5 = total width of the tree + \hbox to#5{\hss\hbox{\titlefont Descendance de #1}\hss} + \kern1cm + \hbox to#5{\hss\hbox{\titlefont (#2 -- #3)}\hss} + \kern1cm + \hbox to#5{\hss\hbox{\subtitlefont(#4 g\'en\'erations)}\hss} + } +\else + \def\title#1#2#3#4#5{% #1 = name of the ancestor + % #2 = birth date + % #3 = death date + % #4 = number of generations (children=only one generation) + % #5 = total width of the tree + \hbox to#5{\hss\hbox{\titlefont Descendance of #1}\hss} + \kern1cm + \hbox to#5{\hss\hbox{\titlefont (#2 -- #3)}\hss} + \kern1cm + \hbox to#5{\hss\hbox{\subtitlefont(#4 generations)}\hss} + } +\fi +%--------------------------------------------------------------------------- +% Special fonts +%--------------------------------------------------------------------------- +\font\descfont=cmssbx10 % descendants +\font\spousefont=cmss10 % spouses +\font\occufont=cmssi10 % occupations +\font\datefont=cmss8 % dates +\font\placefont=cmss8 % places +%--------------------------------------------------------------------------- +% Various formatting things: +\def\spouse#1{\spousefont#1} +% Formatting of the occupation: +\def\occupation#1{{\setbox0=\hbox{\occufont#1}% + \ifdim\wd0>5cm + \vbox{\hsize5cm\pretolerance10000 + \raggedright\noindent\occufont#1\endgraf}% + \else + {\occufont#1}% + \fi + }} +% Separation line in the boxes: +\def\sepline{\noalign{\kern2pt\hrule\kern2pt}} +%--------------------------------------------------------------------------- +% Tags +%--------------------------------------------------------------------------- +% birth tag: +%\def\btag{N:} +\def\btag{$\circ$} +% baptism tag: +%\def\bapttag{B:} +\def\bapttag{{\datefont bp:}} +% marriage tag: +%\def\mtag{M:} +\def\mtag{$\mathord{\scriptstyle\bigcirc\mskip-10mu\bigcirc}$} +% death tag: +%\def\dtag{D:} +\def\dtag{$\dag$} +% at tag: +\ifDR + \def\at{\`a} + \def\seeabove{** voir plus haut **} + \def\unknown{(nom inconnu)} +\else + \def\at{at} + \def\seeabove{** see above **} + \def\unknown{(unknown name)} +\fi +%--------------------------------------------------------------------------- +% Month names +%--------------------------------------------------------------------------- +\ifDR + \def\jan{janvier} + \def\feb{f\'evrier} + \def\mar{mars} + \def\apr{avril} + \def\may{mai} + \def\jun{juin} + \def\jul{juillet} + \def\aug{ao\^ut} + \def\sep{septembre} + \def\oct{octobre} + \def\nov{novembre} + \def\dec{d\'ecembre} +\else + \def\jan{jan} + \def\feb{feb} + \def\mar{mar} + \def\apr{apr} + \def\may{may} + \def\jun{jun} + \def\jul{jul} + \def\aug{aug} + \def\sep{sep} + \def\oct{oct} + \def\nov{nov} + \def\dec{dec} +\fi +% Add your modifications to this file: +\input mysetup +% ----------------- end of file drsetup.tex -------------------- + + diff --git a/reports/desc-tex2/drtree.tex b/reports/desc-tex2/drtree.tex new file mode 100644 index 0000000..44b520d --- /dev/null +++ b/reports/desc-tex2/drtree.tex @@ -0,0 +1,327 @@ +% Modifications to tree.tex by D. Roegel, for desc-tex2 +% ----------------------------------------------------- +% +% (compare with the original file to see changes) +% +% 16 January 1995 D. Roegel (roegel@loria.fr) +% +% There are now six kinds of \subtree nodes: +% +% These nodes are boxes which are marked through a distinct +% very small depth. This correspond to a dirty trick +% mentionned in Appendix D of the TeXbook. +% +% \subtree{normal} (depth 0sp) +% +% \subtree{unframed;rules:right} (depth 5sp) +% +% \subtree{unframed;rules:left,right} (depth 1sp) +% +% \subtree{unframed;rules:left} (depth 3sp) +% +% \subtree{framed;rules:right} (depth 2sp) +% +% \subtree{unframed;norules} (depth 4sp) +% +% Case ``unframed;rules:left'' is normally never needed +% and remains for historical reasons. +% +% +% Note that 1sp is very small since 65536x72.27sp=2.54cm +% +% ----------------------------------------------------------------------- +% Old documentation +% +% Tree -- a macro to make aligned (horizontal) trees in TeX +% +% Input is of the form +% \tree +% item +% \subtree +% \leaf{item} +% . +% . +% . +% \endsubtree +% \subtree +% . +% . +% . +% \endsubtree +% \endsubtree +% \endtree +% +% Nesting is to any level. \leaf is defined as a subtree of one item: +% \def\leaf#1{\subtree#1\endsubtree}. +% +% A structure: +% \subtree +% item_part1 +% item_part2 +% . +% . +% . +% +% will print item_part2 directly below item_part1 as a single item +% as if they were in a \box. +% +% The macro is a 3-pass macro. On the first pass it sets up a data +% structure from the \subtree ... \endsubtree definitions. On the second pass +% it recursively calculates the width of each level of the tree. On the third +% pass it sets up the boxes, glue and rules. +% +% By David Eppstein, TUGboat, vol. 6 (1985), no. 1, pp. 31--35. +% Transcribed by Margaret Kromer (peg), Feb., 1986. +% +% Pass 1 +% At the end of pass 1, the tree is coded as a nested collection of \hboxes +% and \vboxes. +\newbox\treebox\newcount\treeboxcnt +%---------------------------------------------------------------------------- +% Some new things: +\def\ifequal#1#2{\def\first{#1}\def\second{#2}\ifx\first\second} +\newif\ifdontframe +\dontframefalse +\newif\ifnolinkleft +\nolinkleftfalse +\newif\ifnolinkright +\nolinkrightfalse +\newif\ifnothing +\nothingfalse +\newif\ifrootandsecondfam +\rootandsecondfamfalse +\def\framesep{1mm} +\def\framerule{0.4pt} +\def\frameseprule{3.24pt} +%---------------------------------------------------------------------------- +\def\tree#1{\message{Begin tree}\treeboxcnt=1\global\setbox\treebox=\boxtree{#1}} +\def\subtree#1{\ettext \advance\treeboxcnt by 1 \boxtree{#1}} +\def\leaf#1{\subtree{n}#1\endsubtree} +\def\endsubtree{\ettext \egroup \advance\treeboxcnt-1{}% + \ifnum\treeboxcnt=-1 \treeerrora\fi} +\def\endtree{\endsubtree \ifnum\treeboxcnt>0 \treeerrorb\fi% + \settreesizes \typesettree\message{-- end tree}} +% Error messages for unbalanced tree +\def\treeerrora{\errhelp=\treeerrorahelp% + \errmessage{Unbalanced tree -- too many endsubtrees}} +\newhelp\treeerrorahelp{There are more subtrees closed than opened} +\def\treeerrorb{\errhelp=\treeerrorbhelp% + \errmessage{Unbalanced tree -- not enough endsubtrees}} +\newhelp\treeerrorbhelp{Not all the subtrees of the tree are closed. +If you continue, you'll get some mysterious secondary errors.} +% Set up \vbox containing root of tree +\newif\iftreetext\treetextfalse % Whether still aligning text +\def\boxtree#1{\hbox\bgroup % Start outer box of tree or subtree + \baselineskip 2.5ex % Narrow line spacing slightly + \tabskip 0pt % No spurious glue in alignment + %\kern\framerule + %\kern\framesep + \vbox\bgroup % Start inner text \vbox + \kern\framerule + \kern\framesep +% Some new things: + \ifequal{#1}{unframed;rules:left,right}\dontframetrue\fi + \ifequal{#1}{framed;rules:right}\nolinklefttrue\fi + \ifequal{#1}{unframed;rules:left}\nolinkrighttrue\fi + \ifequal{#1}{unframed;norules}\nothingtrue\fi + \ifequal{#1}{unframed;rules:right}\rootandsecondfamtrue\fi + \treetexttrue % Remember for \ettext + \let\par\crcr \obeylines % New line breaks without explicit \cr + \halign\bgroup##\hfil\cr} % Start alignment with simple template +\def\ettext{\iftreetext % Are we still in inner text \vbox? + \crcr\egroup +% Some new things: + \kern\framesep + \kern\framerule + % various depths are added when some flags are set: + \ifdontframe\hrule height0ptwidth0ptdepth1sp\fi + \dontframefalse + \ifnolinkleft\hrule height0ptwidth0ptdepth2sp\fi + \nolinkleftfalse + \ifnolinkright\hrule height0ptwidth0ptdepth3sp\fi + \nolinkrightfalse + \ifnothing\hrule height0ptwidth0ptdepth4sp\fi + \nothingfalse + \ifrootandsecondfam\hrule height0ptwidth0ptdepth5sp\fi + \rootandsecondfamfalse + \egroup + \hskip\frameseprule\relax + %\hskip\framerule\relax + \fi} % Yes, end alignment and box +% Pass 2 +% Recursively calculate widths of tree with \setsizes; keep results in +% \treesizes; \treewidth contains total width calculated so far. \treeworkbox +% is workspace containing subtree being sized. +\newbox\treeworkbox +\def\cons#1#2{\edef#2{\xmark #1#2}} % Add something to start of list +\def\car#1{\expandafter\docar#1\docar} % Take first element of list +\def\docar\xmark#1\xmark#2\docar{#1} % ..by ignoring rest in expansion +\def\cdr#1{\expandafter\docdr#1\docdr#1}% Similarly, drop first element +\def\docdr\xmark#1\xmark#2\docdr#3{\def#3{\xmark #2}} +\def\xmark{\noexpand\xmark} % List separator expands to self +\def\nil{\xmark} % Empty list is just separator +\def\settreesizes{\setbox\treeworkbox=\copy\treebox% + \global\let\treesizes\nil \setsizes} +\newdimen\treewidth % Width of this part of the tree +\def\setsizes{\setbox\treeworkbox=\hbox\bgroup% Get a horiz list as a workspace + \unhbox\treeworkbox\unskip % Take tree, unpack it into horiz list + \inittreewidth % Get old width at this level + \sizesubtrees % Recurse through all subtrees + \sizelevel % Now set width from remaining \vbox + \egroup} % All done, finish our \hbox +\def\inittreewidth{\ifx\treesizes\nil % If this is the first at this level + \treewidth=0pt % ..then we have no previous max width + \else \treewidth=\car\treesizes % Otherwise take old max level width + \global\cdr\treesizes % ..and advance level width storage + \fi} % ..in preparation for next level. +\def\sizesubtrees{\loop % For each box in horiz list (subtree) + \setbox\treeworkbox=\lastbox \unskip % ..pull it off list and flush glue + \ifhbox\treeworkbox \setsizes % If hbox, it's a subtree - recurse + \repeat} % ..and loop; end loop on tree text +\def\sizelevel{% + \ifdim\treewidth<\wd\treeworkbox % If greater than previous maximum + \treewidth=\wd\treeworkbox \fi % Then set max to new high + \global\cons{\the\treewidth}\treesizes}% In either case, put back on list +% Pass 3 +% Recursively typeset tree with \maketree by adding an \hbox containing +% a subtree (in \treebox) to the horizontal list. +\newdimen\treeheight % Height of this part of the tree +\newif\ifleaf % Tree has no subtrees (is a leaf) +\newif\ifbotsub % Bottom subtree of parent +\newif\iftopsub % Top subtree of parent +\def\typesettree{\medskip\maketree\medskip} % Make whole tree +\def\maketree{\hbox{\treewidth=\car\treesizes % Get width at this level + \cdr\treesizes % Set up width list for recursion + \makesubtreebox\unskip % Set \treebox to text, make subtrees + \ifleaf \makeleaf % No subtrees, add glue + \else \makeparent\fi}} % Have subtrees, stick them at right +{\catcode`@=11 % Be able to use \voidb@x +\gdef\makesubtreebox{\unhbox\treebox % Open up tree or subtree + \unskip\global\setbox\treebox\lastbox % Pick up very last box + \ifvbox\treebox % If we're already at the \vbox + \global\leaftrue \let\next\relax % ..then this is a leaf + \else \botsubtrue % Otherwise, we have subtrees + \setbox\treeworkbox\box\voidb@x % Init stack of processed subs + \botsubtrue \let\next\makesubtree % ..and call \maketree on them + \fi \next}} % Finish up for whichever it was +\def\makesubtree{\setbox1\maketree % Call \maketree on this subtree + \unskip\global\setbox\treebox\lastbox % Pick up box before it + \treeheight=\ht1 % Get height of subtree we made + \advance\treeheight 2ex % Add some room around the edges + \ifhbox\treebox \topsubfalse % If picked up box is a \vbox, + \else \topsubtrue \fi % ..this is the top, otherwise not + \addsubtreebox % Stack subtree with the rest + \iftopsub \global\leaffalse % If top, remember not a leaf + \let\next\relax \else % ..(after recursion), set return + \botsubfalse \let\next\makesubtree % Otherwise, we have more subtrees + \fi \next} % Do tail recursion or return +\def\addsubtreebox{% + \setbox\treeworkbox=\vbox{\subtreebox\unvbox\treeworkbox}} +\def\subtreebox{\hbox\bgroup % Start \hbox of tree and lines + \ifdim\dp1=2sp\def\norules{1}% + \else\def\norules{0}% + \fi + \vbox to \treeheight\bgroup % Start \vbox for vertical rules + \ifbotsub \iftopsub \vfil % If both bottom and top subtree + \if\norules1% + \hrule height0pt width 0.4pt + \else + \hrule width 0.4pt % ..vertical rule is just a dot + \fi + \else \treehalfrule{\norules}\fi \vfil % Bottom gets half-height rule + \else \iftopsub + \vfil \treehalfrule{\norules}% Top gets half-height the other way + \else \if\norules1\hrule width 0.4pt height 0pt\kern\treeheight + \else + \hrule width 0.4pt height \treeheight + \fi + \fi\fi % Middle, full height + \egroup % Finish vertical rule \vbox + %\treectrbox{\hrule width 1em}\hskip 0.2em\treectrbox{\box1}\egroup} +% Some new things: + \if\norules1% + \treectrbox{\hrule width 1em height0pt}% + \else + \treectrbox{\hrule width 1em}% + \fi + \treectrbox{\box1 + % this rule enforces the depth to be 0pt, + % and avoids transmission of this depth + % towards the left + \hrule width0ptheight0ptdepth0pt + }\egroup} +\def\treectrbox#1{{\setbox0=\vbox{#1}% + \ifdim\dp0=2sp + \gdef\newdp{2}% + \else + \gdef\newdp{0}% + \fi + \ifdim\dp0=1sp\gdef\newdp{1}\fi + \vbox to \treeheight{\vfil\box0\vfil + \hrule width0ptheight0ptdepth\newdp sp}}} +\def\treehalfrule#1{\dimen\treeworkbox=\treeheight % Get total height + \divide\dimen\treeworkbox 2% + \advance\dimen\treeworkbox 0.2pt % Divide by two, add half horiz height + \if#11\hrule width 0.4pt height 0pt\kern\dimen\treeworkbox + \else \hrule width 0.4pt height \dimen\treeworkbox + \fi + }% Make a vertical rule that high +% Some new things: +% The frame is partly put *inside* the box, since we do not want +% to change the dimensions of the resulting box (see \ettext) +\def\ifdepth#1#2#3{\ifdim\dp\treebox=#1sp\gdef\newdp{#2}\gdef\newdpl{#3}\fi} +\def\noframedtreebox#1{\hbox{\kern\framerule\kern\framesep + \vbox{\kern\framerule\kern\framesep + \box\treebox + \kern\framerule\kern\framesep + #1}% + \kern\framerule\kern\framesep}} +\def\makeleaf{\gdef\newdpl{0}\gdef\newdp{0}% + \ifdepth{2}{2}{0}% + \ifdepth{1}{1}{1}% + \ifdepth{3}{1}{3}% + \ifdepth{4}{2}{3}% + \ifdepth{5}{2}{3}% + \ifdim\dp\treebox=1sp + \noframedtreebox{}% + \else + \if\newdpl3 + \ifdim\dp\treebox=5sp\gdef\newdpl{0}\fi + \noframedtreebox{\hrule height0ptwidth0ptdepth\newdp sp}% + \else + \vbox{\hrule + \hbox{\vrule\kern\framesep + \vbox{%\kern\framesep + \box\treebox + %\kern\framesep + }% + \kern\framesep + \vrule + }% + \hrule + \hrule height0ptwidth0ptdepth\newdp sp + }% + \fi + \fi + }% % Add leaf box to horiz list +% This is an alternative definition giving braces: +%\def\makeleaf{\vbox{\hbox{$\left\{\vcenter{\box\treebox}\right.$}\kern0pt}}% +%\def\makeleaf{\box\treebox}% original definition +\def\makeparent{\ifdim\ht\treebox>% + \ht\treeworkbox % If text is higher than subtrees + \treeheight=\ht\treebox % ..use that height + \else \treeheight=\ht\treeworkbox \fi % Otherwise use height of subtrees + \advance\treewidth-\wd\treebox % Take remainder of level width + \advance\treewidth 1em % ..after accounting for text and glue + %\treectrbox{\box\treebox}\hskip 0.2em % Add text, space before connection + \treectrbox{\makeleaf}%\hskip 0.2em + \if\newdpl3% + \treectrbox{\hrule height 0pt width \treewidth}% + \else + \treectrbox{\hrule height 0.4pt width \treewidth}% + \fi + \treectrbox{\box\treeworkbox}} % Add \hrule, subs + + + + diff --git a/reports/desc-tex2/ex1.tex b/reports/desc-tex2/ex1.tex new file mode 100644 index 0000000..35ea758 --- /dev/null +++ b/reports/desc-tex2/ex1.tex @@ -0,0 +1,54 @@ +% example showing how two trees can be merged ``by hand'' +% that is, you can take two trees generated by desc-tex2, +% and put them aside, with a perfecr alignment, in that you create +% invisible nodes. Just run this file through TeX to see what I mean. +% +% This was made after a suggestion by Michael P. Gerlek +% +% D. Roegel, 16 January 1995 +% +\input pstricks +\input poster +\input drsetup +\Poster[hcenter=true,% + vcenter=true,% + clip=pstricks,% + cropwidth=.4pt,paperwidth=210mm,paperheight=297mm] +\vbox{\setbox0=\vbox{% Because \Poster processes in horizontal mode, +% but the tree macros are in vertical mode. +\tree{unframed;norules}% + % Beginning of first tree + \subtree{framed;rules:right}% + node B1 + \subtree{normal}% + long node B2 + \subtree{normal}% + node B3 + \endsubtree + \endsubtree + \endsubtree + % End of first tree +\subtree{unframed;norules}% once removed + % Beginning of second tree + \subtree{framed;rules:right}% + node C + \subtree{normal}% + C1 + \endsubtree + \subtree{normal}% + C2 + \subtree{normal}% + C2.1 + \endsubtree + \endsubtree + \endsubtree + % End of second tree +\endsubtree +\endtree +}% End of \vbox +\copy0 +\vskip1cm +\noindent\rlap{\hbox to\wd0{\hss%\credits + }}} +\endPoster +\end diff --git a/reports/desc-tex2/extree1.tex b/reports/desc-tex2/extree1.tex new file mode 100644 index 0000000..84586e9 --- /dev/null +++ b/reports/desc-tex2/extree1.tex @@ -0,0 +1,232 @@ +%\mag1000 % this is default value of \mag +\input pstricks +\input poster +\input drsetup +\Poster[hcenter=true,% + vcenter=true,% + clip=pstricks,% + cropwidth=.4pt] +\vbox{\setbox0=\vbox{% Because \Poster processes in horizontal mode, +% but the tree macros are in vertical mode. +\tree{normal} +{\descfont Joseph Patrick Kennedy} +\sepline +\hglue5mm \btag\ {\datefont 6 \sep{} 1888} {\placefont \at\ }{\placefont East Boston,Suffolk Co.,Massachusetts} +\hglue5mm \bapttag\ {\datefont 9 \sep{} 1888} {\placefont \at\ }{\placefont East Boston,Suffolk Co.,Massachusetts} +\hglue5mm \dtag\ {\datefont 18 \nov{} 1969} {\placefont \at\ }{\placefont Hyannis Port,Barnstable,Massachusetts} +\hglue5mm \mtag\ {\datefont 7 \oct{} 1914} {\placefont \at\ }{\placefont Boston,Suffolk Co.,Massachusetts} +\hglue5mm\spouse{Rose Elizabeth Fitzgerald} +\hglue10mm \btag\ {\datefont 22 \jul{} 1890} {\placefont \at\ }{\placefont Boston,Suffolk Co.,Massachusetts} +\subtree{normal}% +{\descfont Joseph Patrick Kennedy} +\hglue5mm \btag\ {\datefont 25 \jul{} 1915} {\placefont \at\ }{\placefont Hull,Plymouth Co.,Massachusetts} +\hglue5mm \dtag\ {\datefont 12 \aug{} 1944} {\placefont \at\ }{\placefont Suffolk,England} +\endsubtree +\subtree{normal}% +{\descfont John Fitzgerald Kennedy} +\sepline +\hglue5mm \btag\ {\datefont 29 \may{} 1917} {\placefont \at\ }{\placefont Brookline,Norfolk Co.,Massachusetts} +\hglue5mm \dtag\ {\datefont 22 \nov{} 1963} {\placefont \at\ }{\placefont Dallas,Dallas Co.,Texas} +\hglue5mm \mtag\ {\datefont 12 \sep{} 1953} {\placefont \at\ }{\placefont Newport,Rhode Island} +\hglue5mm\spouse{Jacqueline Lee Bouvier} +\hglue10mm \btag\ {\datefont 28 \jul{} 1929} {\placefont \at\ }{\placefont Southampton,Long Island,New York} +\subtree{normal}% +{\descfont (Stillborn) Kennedy} +\hglue5mm \btag\ {\datefont 23 \aug{} 1956} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 23 \aug{} 1956} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Caroline Bouvier Kennedy} +\sepline +\hglue5mm \btag\ {\datefont 27 \nov{} 1957} {\placefont \at\ }{\placefont New York City,New York} +\hglue5mm \mtag\ {\datefont 19 \jul{} 1987} {\placefont \at\ }{\placefont Centerville,Massachusetts} +\hglue5mm\spouse{Edwin Arthur Schlossberg} +\subtree{normal}% +{\descfont Rose Schlossberg} +\hglue5mm \btag\ {\datefont 25 \jun{} 1988} {\placefont \at\ }{\placefont New York} +\endsubtree +\endsubtree +\subtree{normal}% +{\descfont John Fitzgerald Kennedy} +\hglue5mm \btag\ {\datefont 25 \nov{} 1960} {\placefont \at\ }{\placefont Washington D.C.} +\endsubtree +\subtree{normal}% +{\descfont Patrick Bouvier Kennedy} +\hglue5mm \btag\ {\datefont 7 \aug{} 1963} {\placefont \at\ }{\placefont Otis AF Base,Falmouth,Barnstable Co.,Massachusetts} +\hglue5mm \dtag\ {\datefont 9 \aug{} 1963} {\placefont \at\ }{\placefont Boston,Suffolk Co.,Massachusetts} +\endsubtree +\endsubtree +\subtree{normal}% +{\descfont Rosemary (Rose-Marie) Kennedy} +\hglue5mm \btag\ {\datefont 20 \feb{} 1920} {\placefont \at\ }{\placefont Brookline,Norfolk Co.,Massachusetts} +\endsubtree +\subtree{normal}% +{\descfont Kathleen Kennedy} +\sepline +\hglue5mm \btag\ {\datefont 20 \feb{} 1920} {\placefont \at\ }{\placefont Brookline,Norfolk Co.,Massachusetts} +\hglue5mm \dtag\ {\datefont 13 \may{} 1948} {\placefont \at\ }{\placefont Ste-Bauzille,Ardeche,France} +\hglue5mm \mtag\ {\datefont 6 \may{} 1944} {\placefont \at\ }{\placefont London,England} +\hglue5mm\spouse{John Robert Cavendish} +\hglue10mm \btag\ {\datefont 1917} {\placefont \at\ }{\placefont ? } +\hglue10mm \dtag\ {\datefont 1944} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Eunice Mary Kennedy} +\sepline +\hglue5mm \btag\ {\datefont 10 \jul{} 1921} {\placefont \at\ }{\placefont Brookline,Norfolk Co.,Massachusetts} +\hglue5mm \mtag\ {\datefont 23 \may{} 1953} {\placefont \at\ }{\placefont New York City,New York} +\hglue5mm\spouse{Robert Sargent Shriver} +\hglue10mm \btag\ {\datefont 1915} {\placefont \at\ }{\placefont ? } +\subtree{normal}% +{\descfont Robert Sargent Shriver} +\hglue5mm \btag\ {\datefont 1954} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Maria Owings Shriver} +\hglue5mm \btag\ {\datefont 1955} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Timothy Perry Shriver} +\hglue5mm \btag\ {\datefont 1959} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Mark Kennedy Shriver} +\hglue5mm \btag\ {\datefont 1964} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Anthony Paul Kennedy Shriver} +\hglue5mm \btag\ {\datefont 1965} {\placefont \at\ }{\placefont ? } +\endsubtree +\endsubtree +\subtree{normal}% +{\descfont Patricia Kennedy} +\sepline +\hglue5mm \btag\ {\datefont 6 \may{} 1924} {\placefont \at\ }{\placefont Brookline,Norfolk Co.,Massachusetts} +\hglue5mm \mtag\ {\datefont 24 \apr{} 1954} {\placefont \at\ }{\placefont New York City,New York} +\hglue5mm\spouse{Peter Lawford} +\hglue10mm \btag\ {\datefont 1923} {\placefont \at\ }{\placefont ? } +\hglue10mm \dtag\ {\datefont 1984} {\placefont \at\ }{\placefont ? } +\subtree{normal}% +{\descfont Christopher Kennedy Lawford} +\hglue5mm \btag\ {\datefont 1955} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Sydney Maleia Lawford} +\hglue5mm \btag\ {\datefont 1956} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Victoria Francis Lawford} +\hglue5mm \btag\ {\datefont 1958} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Robin Elizabeth Lawford} +\hglue5mm \btag\ {\datefont 1961} {\placefont \at\ }{\placefont ? } +\endsubtree +\endsubtree +\subtree{normal}% +{\descfont Robert Francis Kennedy} +\sepline +\hglue5mm \btag\ {\datefont 20 \nov{} 1925} {\placefont \at\ }{\placefont Brookline,Norfolk Co.,Massachusetts} +\hglue5mm \dtag\ {\datefont 6 \jun{} 1968} {\placefont \at\ }{\placefont Los Angeles,Los Angeles Co.,Massachusetts} +\hglue5mm \mtag\ {\datefont 17 \jun{} 1950} {\placefont \at\ }{\placefont Greenwich,Fairfield Co.,Connecticut} +\hglue5mm\spouse{Ethel Skakel} +\hglue10mm \btag\ {\datefont 11 \apr{} 1928} {\placefont \at\ }{\placefont Chicago,Cook Co.,Illinois} +\subtree{normal}% +{\descfont Kathleen Hartington Kennedy} +\hglue5mm \btag\ {\datefont 4 \jul{} 1951} {\placefont \at\ }{\placefont Greenwich,Fairfield Co.,Connecticut} +\endsubtree +\subtree{normal}% +{\descfont Joseph Patrick Kennedy} +\hglue5mm \btag\ {\datefont 24 \sep{} 1952} {\placefont \at\ }{\placefont Boston,Suffolk Co.,Massachusetts} +\endsubtree +\subtree{normal}% +{\descfont Robert Francis Kennedy} +\hglue5mm \btag\ {\datefont 17 \jan{} 1954} {\placefont \at\ }{\placefont Washington D.C.} +\endsubtree +\subtree{normal}% +{\descfont David Anthony Kennedy} +\hglue5mm \btag\ {\datefont 15 \jun{} 1955} {\placefont \at\ }{\placefont Washington D.C.} +\hglue5mm \dtag\ {\datefont 25 \apr{} 1984} {\placefont \at\ }{\placefont Palm Beach,Palm Beach Co.,Florida} +\endsubtree +\subtree{normal}% +{\descfont Mary Courtney Kennedy} +\hglue5mm \btag\ {\datefont 9 \sep{} 1956} {\placefont \at\ }{\placefont Boston,Suffolk Co.,Massachusetts} +\endsubtree +\subtree{normal}% +{\descfont Michael LeMoyne Kennedy} +\hglue5mm \btag\ {\datefont 27 \feb{} 1958} {\placefont \at\ }{\placefont Washington D.C.} +\endsubtree +\subtree{normal}% +{\descfont Mary Kerry Kennedy} +\hglue5mm \btag\ {\datefont 8 \sep{} 1959} {\placefont \at\ }{\placefont Washington D.C.} +\endsubtree +\subtree{normal}% +{\descfont Christopher George Kennedy} +\hglue5mm \btag\ {\datefont 4 \jul{} 1963} {\placefont \at\ }{\placefont Boston,Suffolk Co.,Massachusetts} +\endsubtree +\subtree{normal}% +{\descfont Matthew Maxwell Taylor Kennedy} +\hglue5mm \btag\ {\datefont 9 \jan{} 1965} {\placefont \at\ }{\placefont New York City,New York} +\endsubtree +\subtree{normal}% +{\descfont Douglas Harriman Kennedy} +\hglue5mm \btag\ {\datefont 24 \mar{} 1967} {\placefont \at\ }{\placefont Washington D.C.} +\endsubtree +\subtree{normal}% +{\descfont Rory Elizabeth Katherine Kennedy} +\hglue5mm \btag\ {\datefont 12 \dec{} 1968} {\placefont \at\ }{\placefont Washington D.C.} +\endsubtree +\endsubtree +\subtree{normal}% +{\descfont Jean Ann Kennedy} +\sepline +\hglue5mm \btag\ {\datefont 20 \feb{} 1928} {\placefont \at\ }{\placefont Boston,Suffolk Co.,New York} +\hglue5mm \mtag\ {\datefont 19 \may{} 1956} {\placefont \at\ }{\placefont New York City,New York} +\hglue5mm\spouse{Stephen Edward Smith} +\hglue10mm \btag\ {\datefont 1927} {\placefont \at\ }{\placefont ? } +\subtree{normal}% +{\descfont Stephen Smith} +\hglue5mm \btag\ {\datefont 1957} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont William Kennedy Smith} +\hglue5mm \btag\ {\datefont 1960} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Amanda Mary Smith} +\hglue5mm \btag\ {\datefont 1967} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Kym Maria Smith} +\hglue5mm \btag\ {\datefont 1972} {\placefont \at\ }{\placefont ? } +\endsubtree +\endsubtree +\subtree{normal}% +{\descfont Edward Moore Kennedy} +\sepline +\hglue5mm \btag\ {\datefont 22 \feb{} 1932} {\placefont \at\ }{\placefont Boston,Suffolk Co.,Massachusetts} +\hglue5mm \mtag\ {\datefont 30 \nov{} 1958} {\placefont \at\ }{\placefont Bronxville,Westchester Co.,New York} +\hglue5mm\spouse{Virginia Joan Bennett} +\hglue10mm \btag\ {\datefont 9 \sep{} 1936} {\placefont \at\ }{\placefont Riverdale,New York} +\subtree{normal}% +{\descfont Kara Anne Kennedy} +\hglue5mm \btag\ {\datefont 27 \feb{} 1960} {\placefont \at\ }{\placefont Bronxville,Westchester Co.,New York} +\endsubtree +\subtree{normal}% +{\descfont Edward Moore Kennedy} +\hglue5mm \btag\ {\datefont 26 \sep{} 1961} {\placefont \at\ }{\placefont Boston,Suffolk Co.,Massachusetts} +\endsubtree +\subtree{normal}% +{\descfont Patrick Joseph Kennedy} +\hglue5mm \btag\ {\datefont 14 \jul{} 1967} {\placefont \at\ }{\placefont Boston,Suffolk Co.,Massachusetts} +\endsubtree +\endsubtree +\endtree +}% End of \vbox +\title{Joseph Patrick Kennedy}{6 \sep{} 1888}{18 \nov{} 1969}{3}{\wd0} +\vskip2cm +\copy0 +\vskip1cm +\noindent\rlap{\hbox to\wd0{\hss\credits}}} +\endPoster +\end diff --git a/reports/desc-tex2/extree2.tex b/reports/desc-tex2/extree2.tex new file mode 100644 index 0000000..812c599 --- /dev/null +++ b/reports/desc-tex2/extree2.tex @@ -0,0 +1,160 @@ +%\mag1000 % this is default value of \mag +\input pstricks +\input poster +\input drsetup +\Poster[hcenter=true,% + vcenter=true,% + clip=pstricks,% + cropwidth=.4pt] +\vbox{\setbox0=\vbox{% Because \Poster processes in horizontal mode, +% but the tree macros are in vertical mode. +\tree{unframed;norules} +\subtree{framed;rules:right} +{\descfont John Scott Harrison} +\sepline +\hglue5mm \btag\ {\datefont 4 \oct{} 1804} {\placefont \at\ }{\placefont Vincennes,Indiana} +\hglue5mm \dtag\ {\datefont 25 \may{} 1878} {\placefont \at\ }{\placefont Point Farm,Nr North Bend,Ohio} +\hglue5mm \mtag\ {\datefont 1824} {\placefont \at\ }{\placefont ? } +\hglue5mm\spouse{Lucretia Knapp Johnson} +\hglue10mm \btag\ {\datefont 16 \sep{} 1804} {\placefont \at\ }{\placefont Boone Co.,Kentucky} +\hglue10mm \dtag\ {\datefont 6 \feb{} 1830} {\placefont \at\ }{\placefont ? } +\subtree{normal}% +{\descfont Elizabeth Short Harrison} +\sepline +\hglue5mm \btag\ {\datefont 1825} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1904} {\placefont \at\ }{\placefont ? } +\hglue5mm\spouse{George Coleman Eaton} +\endsubtree +\subtree{normal}% +{\descfont William Henry Harrison} +\hglue5mm \btag\ {\datefont 1827} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1829} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Sarah Lucretia Harrison} +\sepline +\hglue5mm \btag\ {\datefont 1829} {\placefont \at\ }{\placefont ? } +\hglue5mm\spouse{Thomas Jefferson Devin} +\endsubtree +\endsubtree +\subtree{unframed;rules:right}% +{$\langle$ \descfont John Scott Harrison $\rangle$} +\hglue5mm \mtag\ {\datefont 12 \aug{} 1831} {\placefont \at\ }{\placefont ? } +\hglue5mm\spouse{Elizabeth Ramsey Irwin} +\hglue10mm \btag\ {\datefont 18 \jul{} 1810} {\placefont \at\ }{\placefont Mercersburg,Pennsylvania} +\hglue10mm \dtag\ {\datefont 15 \aug{} 1850} {\placefont \at\ }{\placefont North Bend,Ohio} +\subtree{normal}% +{\descfont Archibald Irwin Harrison} +\sepline +\hglue5mm \btag\ {\datefont 1832} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1870} {\placefont \at\ }{\placefont ? } +\hglue5mm\spouse{Elizabeth Lawrence Sheets} +\endsubtree +\subtree{normal}% +{\descfont Benjamin Harrison} +\sepline +\hglue5mm \btag\ {\datefont 20 \aug{} 1833} {\placefont \at\ }{\placefont North Bend,Ohio} +\hglue5mm \dtag\ {\datefont 13 \mar{} 1901} {\placefont \at\ }{\placefont Indianapolis,Indiana} +\hglue5mm \mtag\ {\datefont 20 \oct{} 1853} {\placefont \at\ }{\placefont Oxford,Ohio} +\hglue5mm\spouse{Caroline Lavinia Scott} +\hglue10mm \btag\ {\datefont 1 \oct{} 1832} {\placefont \at\ }{\placefont Oxford,Ohio} +\hglue10mm \dtag\ {\datefont 25 \oct{} 1892} {\placefont \at\ }{\placefont White House,Washington D.C.} +\subtree{normal}% +{\descfont Russell Benjamin Harrison} +\sepline +\hglue5mm \btag\ {\datefont 12 \aug{} 1854} {\placefont \at\ }{\placefont Oxford,Ohio} +\hglue5mm \dtag\ {\datefont 13 \dec{} 1936} {\placefont \at\ }{\placefont Indianapolis,Indiana} +\hglue5mm \mtag\ {\datefont 9 \jan{} 1884} {\placefont \at\ }{\placefont Omaha,Nebraska} +\hglue5mm\spouse{Mary Angeline Saunders} +\hglue10mm \btag\ {\datefont 16 \nov{} 1861} {\placefont \at\ }{\placefont ? } +\hglue10mm \dtag\ {\datefont 28 \nov{} 1944} {\placefont \at\ }{\placefont Washington D.C.} +\endsubtree +\subtree{normal}% +{\descfont Mary Scott Harrison} +\sepline +\hglue5mm \btag\ {\datefont 3 \apr{} 1858} {\placefont \at\ }{\placefont Indianapolis,Indiana} +\hglue5mm \dtag\ {\datefont 28 \oct{} 1930} {\placefont \at\ }{\placefont Greenwich,Connecticut} +\hglue5mm \mtag\ {\datefont 5 \nov{} 1884} {\placefont \at\ }{\placefont Indianapolis,Indianapolis} +\hglue5mm\spouse{(James) Robert McKee} +\hglue10mm \btag\ {\datefont 9 \dec{} 1857} {\placefont \at\ }{\placefont Madison,Indiana} +\hglue10mm \dtag\ {\datefont 21 \oct{} 1942} {\placefont \at\ }{\placefont Greenwich,Connecticut} +\endsubtree +\subtree{normal}% +{\descfont Unnamed Harrison} +\hglue5mm \btag\ {\datefont 13 \jun{} 1861} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 13 \jun{} 1861} {\placefont \at\ }{\placefont ? } +\endsubtree +\endsubtree +\subtree{unframed;rules:left,right}% +{$\langle$ \descfont Benjamin Harrison $\rangle$} +\hglue5mm \mtag\ {\datefont 6 \apr{} 1896} {\placefont \at\ }{\placefont St Thomas Church,New York City,New York} +\hglue5mm\spouse{Mary Scott Dimmick Lord} +\hglue10mm \btag\ {\datefont 30 \apr{} 1858} {\placefont \at\ }{\placefont Honesdale,Pennsylvania} +\hglue10mm \dtag\ {\datefont 5 \jan{} 1948} {\placefont \at\ }{\placefont New York} +\subtree{normal}% +{\descfont Elizabeth Harrison} +\sepline +\hglue5mm \btag\ {\datefont 21 \feb{} 1897} {\placefont \at\ }{\placefont Indianapolis,Indiana} +\hglue5mm \dtag\ {\datefont 25 \dec{} 1955} {\placefont \at\ }{\placefont New York City,New York} +\hglue5mm \mtag\ {\datefont 6 \apr{} 1921} {\placefont \at\ }{\placefont New York City,New York} +\hglue5mm\spouse{James Blaine Walker} +\hglue10mm \btag\ {\datefont 20 \jan{} 1889} {\placefont \at\ }{\placefont Helena,Montana} +\hglue10mm \dtag\ {\datefont AFT \apr{} 1921} {\placefont \at\ }{\placefont New York City,New York} +\endsubtree +\endsubtree +\subtree{normal}% +{\descfont Mary Jane Harrison} +\sepline +\hglue5mm \btag\ {\datefont 1835} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1867} {\placefont \at\ }{\placefont ? } +\hglue5mm\spouse{Samuel Vance Morris} +\endsubtree +\subtree{normal}% +{\descfont Anna Symmes Harrison} +\hglue5mm \btag\ {\datefont 1837} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1838} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont John Irwin Harrison} +\hglue5mm \btag\ {\datefont 1839} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1839} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont Carter Bassett Harrison} +\sepline +\hglue5mm \btag\ {\datefont 1840} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1905} {\placefont \at\ }{\placefont ? } +\hglue5mm\spouse{Sophia Ridgely Lytle Dashiell} +\endsubtree +\subtree{normal}% +{\descfont Anna Symmes Harrison} +\hglue5mm \btag\ {\datefont 1842} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1926} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont John Scott Harrison} +\sepline +\hglue5mm \btag\ {\datefont 1844} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1926} {\placefont \at\ }{\placefont ? } +\hglue5mm\spouse{Marie Sophie Elizabeth Lytle} +\endsubtree +\subtree{normal}% +{\descfont James Findlay Harrison} +\hglue5mm \btag\ {\datefont 1847} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1848} {\placefont \at\ }{\placefont ? } +\endsubtree +\subtree{normal}% +{\descfont James Irwin Harrison} +\hglue5mm \btag\ {\datefont 1849} {\placefont \at\ }{\placefont ? } +\hglue5mm \dtag\ {\datefont 1850} {\placefont \at\ }{\placefont ? } +\endsubtree +\endsubtree +\endtree +}% End of \vbox +\title{John Scott Harrison}{4 \oct{} 1804}{25 \may{} 1878}{3}{\wd0} +\vskip2cm +\copy0 +\vskip1cm +\noindent\rlap{\hbox to\wd0{\hss\credits}}} +\endPoster +\end diff --git a/reports/desc-tex2/mysetup.tex b/reports/desc-tex2/mysetup.tex new file mode 100644 index 0000000..f2164b0 --- /dev/null +++ b/reports/desc-tex2/mysetup.tex @@ -0,0 +1,8 @@ +% here, your personal modifications and additions to drsetup.tex +% +% D. Roegel, January 15, 1995 +% +% Example: +% +%\def\btag{born} +\endinput \ No newline at end of file diff --git a/reports/desc-tex2/poster.doc b/reports/desc-tex2/poster.doc new file mode 100644 index 0000000..bc55c40 --- /dev/null +++ b/reports/desc-tex2/poster.doc @@ -0,0 +1,319 @@ +%% BEGIN poster.doc +%% +%% Documentation for poster.tex/poster.sty. +%% Run with LaTeX, with or without the NFSS. +%% +%% Change these for a4 paper: +\def\paperwidth{8.5in} +\def\paperheight{11in} + +\def\FileVersion{1.2} +\def\FileDate{August 28, 1993} + +\documentstyle[12pt]{article} + +%% PAGE PARAMETERS + +% Paragraphs are marked by large space rather than indentation: +\parindent 0pt +\parskip 6pt plus 1pt minus 1pt + +% No headers, 1in top margin +\topmargin 0pt +\headheight 0pt +\headsep 0pt + +% Total bottom margin 1in, text height 9in +\textheight 9in +\footskip .625in + +% Now adjust for different paper size: +\newdimen\mydim +\mydim=\paperwidth +\advance\mydim-8.5in +\divide\mydim 2 +\advance\oddsidemargin \mydim +\advance\evensidemargin \mydim +\mydim=\paperheight +\advance\mydim-11in +\divide\mydim 2 +\advance\topmargin \mydim + +%% OTHER + +% Short meta (works in verbatim. Can't use < for other purposes. +\catcode`\<=13 \def<#1>{{\rm\it #1\/}} % (works in verbatim) + +% Short verbatim. +\catcode`\"=13 +\def"{\verb"} + +% To make smaller sections: +\def\thesubsection{\arabic{subsection}} + +\catcode`\@=12 % In case I'm using AmS-LaTeX + +\begin{document} + +\begin{center} +\begingroup + \large\bf + Documentation for poster.tex/poster.sty\\[2pt] + Posters and banners with Generic \TeX\\[6pt] +\endgroup + Version \FileVersion\\ + \FileDate\\[6pt] + Timothy Van Zandt\\ + tvz@Princeton.EDU +\end{center} + +\subsection{The macros} + +"poster.tex/poster.sty" contains the macro +\begin{verbatim} + \poster{} +\end{verbatim} +for making posters and banners. is processed in restricted horizontal +mode (i.e., "\hbox" or ``LR-mode'') and is then printed on as many sheets of +paper as are needed. You can then construct the poster or banner by trimming +and piecing together the sheets of paper. + +You can also write +\begin{verbatim} + \Poster \endPoster +\end{verbatim} +and \LaTeX\ users can write +\begin{verbatim} + \begin{Poster} \end{Poster} +\end{verbatim} + +Here are a few details: +\begin{itemize} +\item Use a "\vbox" or \LaTeX's "minipage" or "\parbox" in if you want +to include vertical mode material. For more help with LR-boxes, see +"fancybox.sty", available from archives everywhere. + +\item Don't worry about margins, headers or footers; "\poster" ignores output +routines entirely. + +\item can contain "\catcode" changes, such as verbatim environments. +\end{itemize} + +If you want to use your regular output routines, and have "poster.tex" print +out each page of your document as a poster, then instead put the command +\begin{verbatim} + \PosterPage +\end{verbatim} +towards the beginning of your document, or in the \LaTeX\ preamble. Each page +is printed without its margins, but with the headers and footers, if any. (You +can print out your whole dissertation on $8\times 10$-feet pages.) With +"\PosterPage", you do not have to worry about LR-boxes. + +\subsection{Making the output look big} + +You can use these macros to print a large diagram, such as a genealogical +tree, that would not normally fit on one page. You might also want to magnify +the contents of the poster. For example, you might want to print ``Happy +Birthday'' in 6 inch high letters. Here is a brief description of three ways +to make your output look big. Note that these are not part of "poster.tex", +but are described here for your convenience. For more information, see the +\TeX book. +\begin{enumerate} +\item The simplest and most general method is to set \TeX's "\mag" parameter, +by inserting the line +\begin{verbatim} + \mag +\end{verbatim} +at or near the beginning of the document (or in the \LaTeX\ preamble). The +integer should be 1000 times the magnification factor. For example, to +double the size of the output, use +\begin{verbatim} + \mag 2000 +\end{verbatim} +You may need to generate big bitmaps if using bitmapped fonts (e.g., \TeX's +usual Metafont fonts), rather than scalable outline fonts (e.g., PostScript +fonts). You can reduce the need for extra font bitmaps by using +\begin{verbatim} + \mag \magstep +\end{verbatim} +to magnify the document by $1.2^n$. $n$ can be between 1 and 5. For example, +to magnify the document by $1.2^4=2.074$, use +\begin{verbatim} + \mag \magstep4 +\end{verbatim} +You can also set "\mag" to "\magstephalf", which scales the document by +$1.2^{1.5}$. + +\item If you are making a banner with just one font, then you can define a +large font. For example, +\begin{verbatim} + \font\bigroman=cmr at 8in + \bigroman + \poster[vcenter=true,landscape=true]{Happy Birthday} +\end{verbatim} +It is best to use scalable fonts, such as PostScript fonts, if available. + +\item If you are using a PostScript printer, then you can use macros for +scaling boxes, such as the "\scalebox" and "\scaleboxto" commands in the +PSTricks package. For example, here is the banner from the previous example: +\begin{verbatim} + \poster[vcenter=true,landscape=true]{% + \scaleboxto(0,8in){Happy Birthday}} +\end{verbatim} +You must use scalable fonts, because scaled bitmaps look very ugly. +\end{enumerate} + +\subsection{Parameters} + + "\poster", "\Poster" and "\PosterPage" use the following parameters: +\begin{center} + \def\arraystretch{1.1} + \begin{tabular}{lll} + {\em Parameter} & {\em Value} & {\em Default}\\[2pt] + "paperwidth" & & "8.5in"\\ + "paperheight" & & "11in"\\ + "imagewidth" & & "7.5in"\\ + "imageheight" & & "10in"\\ + "landscape" & "true"/"false" & "false"\\ + "hcenter" & "true"/"false" & "false"\\ + "vcenter" & "true"/"false" & "false"\\ + "crop" & "none"/"corners"/"full" & "corners"\\ + "cropwidth" & & "2pt"\\ + "clip" & "none"/"pstricks" & "none"\\ + "immediatewrites" & "true"/"false" & "true"\\ + "numbering" & "auto"/"rowcol"/"page"/"serial" & "auto" + \end{tabular} +\end{center} + +You can include parameter changes as a list of "=" pairs in an +optional argument to "\poster", "\Poster" or "\PosterPage", enclosed in square +brackets. E.g., +\begin{verbatim} + \poster[clip=pstricks,hcenter=true]{foo} +\end{verbatim} +No extraneous spaces, please. + +You can also redefine the parameters using "\def" or "\LaTeX"'s +"\renewcommand". For parameter "foo", you should redefine "\POSTERfoo". E.g., +the next example is like the last one: +\begin{verbatim} + \def\POSTERclip{pstricks} + \def\POSTERhcenter{true} + \poster{foo} +\end{verbatim} +This is mainly of interest when developing your own custom "\poster" command +or "poster.tex" file. + +Here are some comments on the parameters: +\begin{itemize} +\item +Don't adjust the "paper" and "image" dimensions for your document's +magnification (and don't use \TeX's "true" dimensions). "poster.tex" does this +for you. (That is, set the "page" and "image" dimensions to the actual values +you want for the output.) + +\item +Most printers cannot print right up to the edge of the paper. That is why the +"imagewidth" and "imageheight" should be smaller than the "paperwidth" and +"paperheight". The default values are good for printing on 8.5in by 11in paper +in portrait mode with one-half inch margins. + +\item +Setting "landscape" to "true" is just a convenient way to switch the "height" +and "width" parameters. You still have to take care of printing your document +in landscape mode. E.g., with Rokicki's "dvips", use +\begin{verbatim} + \special{landscape} +\end{verbatim} +For other dvi driver's, consult the documentation. + +\item +Setting "hcenter" and "vcenter" to "true" causes the image to be centered +horizontally and vertically, respectively, in the total number of pages that +are printed. E.g., when "vcenter" is "true", extra space is added to the top +of the first row of pages and to the bottom of the last row of pages. + +\item +The "crop" parameter specifies what kind of crop marks are drawn, to help you +trim each page to size. When "crop" equals "full", you get crop marks along +the full length of all four sides. "cropwidth" is the width of the crop mark +lines. The crop marks lie entirely off the page, for any width. + +\item +Setting "clip" to "pstricks" causes each page to be clipped to the size of the +image (rather than having the image overlap in the margins on each page), but +this only works if you have loaded the PSTricks package. + +\item +When "immediatewrites" is "true", all "\write"'s are "\immediate". I.e., +auxiliary files are written to only when the poster file is first processed. +This is the default. The page references may be incorrect in multi-page +posters. Setting "immediatewrites" to "false" will fix the page references, +but writing to auxiliary files will be repeated with each page of the poster. +E.g., \LaTeX\ users will get errors about multiply defined labels, if they use +the "\label" command in a poster. + +\item +The "numbering" parameter sets the page numbers, as recognized by your "dvi" +driver (it does not affect the page numbering as it appears in the document). +Here is the scheme: +\begin{description} + \item["rowcol"] Each page is numbered "[.]". + \item["page"] Each page is numbered "[..]", where is +"\count0" (e.g., \LaTeX's "page" counter). + \item["serial"] Pages are numbering serially. + \item["auto"] Page numbering is "rowcol" for "\poster" and "\Poster", and +"page" for "\PosterPage". +\end{description} +In each case, if the poster contains only one row of pages (i.e., if it is a +banner), the number is suppressed. +\end{itemize} + +\subsection{Samples} + +The file "poster1.tex" contains the following sample of a framed poster with a +whole page of text: +\begin{verbatim} + \documentstyle[poster]{article} + + \mag\magstep5 % Magnification of 1.2^5 (roughly 2.5) + % Use `true' dimensions below for magnified values. + + \begin{document} + + \begin{Poster}[vcenter=true,hcenter=true] + \setlength{\fboxsep}{.8truein}% + \setlength{\fboxrule}{.1truein}% + \fbox{\begin{minipage}{11.1truein} + + \end{minipage}}% + \end{Poster} + + \end{document} +\end{verbatim} + +The file "poster2.tex" contain the following sample of a banner in landscape +mode. "ptmr" is meant to be the name of the Times-Roman PostScript font, if +your dvi driver supports such a thing. +\begin{verbatim} + \font\bigroman=ptmr at 7.5in + \bigroman + \poster[vcenter=true,landscape=true]{Animals} +\end{verbatim} + +\subsection{Changes} + +\begin{description} +\item[V1.2, 28 August 1993] Add "cropwidth" parameter. + +\item[V1.1, 1 June 1993] Added "immediatewrites" and "numbering" parameters. + +\item[V1.0, 13 May 1993] Added "\PosterPage". + +\item[V0.93, 11~Feb~1993] First stable release. +\end{description} + +\end{document} +%% +%% END poster.doc + diff --git a/reports/desc-tex2/poster.tex b/reports/desc-tex2/poster.tex new file mode 100644 index 0000000..afbd24a --- /dev/null +++ b/reports/desc-tex2/poster.tex @@ -0,0 +1,407 @@ +%% BEGIN poster.tex/poster.sty +%% +\def\fileversion{1.2} +\def\filedate{93/08/28} +%% +%% COPYRIGHT 1993, by Timothy Van Zandt, tvz@Princeton.EDU +%% +%% DESCRIPTION: +%% poster.tex/poster.sty contains a macro for making posters and banners +%% with TeX. It is compatible with most TeX macro packages, including Plain +%% TeX, LaTeX, AmSTeX, and Ams-LaTeX. The only special requirement is that +%% your printer not be bothered by text that lies off the page. This is +%% true of most printers, including laser printers and PostScript printers. +%% +%% INSTALLATION: +%% Put this file where your TeX looks for inputs, under the name poster.tex. +%% Name a copy poster.sty to use as a LaTeX style option, or create a file +%% poster.sty with the lines: +%% \input poster.tex +%% \endinput +%% +%% DOCUMENTATION: +%% See poster.doc, and the sample files poster1.tex and poster2.tex. +%% These might be appended to this file. +%% +%% COPYING: +%% Copying of part or all of this file is allowed under the following +%% conditions only: +%% (1) You may freely distribute unchanged copies of the file. Please +%% include the documentation when you do so. +%% (2) You may modify a renamed copy of the file, but only for personal +%% use or use within an organization. +%% (3) You may copy fragments from the file, for personal use or for +%% distribution, as long as credit is given where credit is due. +%% +%% You are NOT ALLOWED to take money for the distribution or use of +%% this file or modified versions or fragments thereof, except for +%% a nominal charge for copying etc. +%% +%% CODE: +% These macros use TeX primitives, plus the Plain TeX commands: +% \dimen@, \dimen@i, \count@, \newcount, \newtoks, +% \p@, \z@, \@ne +% +% Check if file is loaded, announce file on terminal, and take care of @: +% +\csname PosterLoaded\endcsname +\let\PosterLoaded\endinput + +\message{\space\space v\fileversion\space\space\filedate\space\space } + +\edef\TheAtCode{\the\catcode`\@} +\catcode`\@=11 + +\newbox\@posterbox +\newbox\poster@savedbox +\newbox\poster@cropbox +\newcount\poster@cnt + +\def\POSTERpaperheight{11in} +\def\POSTERpaperwidth{8.5in} +\def\POSTERimageheight{10in} +\def\POSTERimagewidth{7.5in} +\def\POSTERlandscape{false} +\def\POSTERclip{none} +\def\POSTERcrop{corners} +\def\POSTERcropwidth{2pt} +\def\POSTERvcenter{false} +\def\POSTERhcenter{false} +\def\POSTERimmediatewrites{true} +\def\POSTERnumbering{automatic} + +\def\poster@set#1[#2]{% + \poster@@set#2,=\@nil,% + \csname posterwrites@\POSTERimmediatewrites\endcsname + #1} +\def\poster@@set#1=#2,{% + \ifx\@nil#2\else + \expandafter\ifx\csname POSTER#1\endcsname\relax + \errmessage{Poster parameter `#1' not defined}% + \else + \expandafter\edef\csname POSTER#1\endcsname{#2}% + \fi + \expandafter\poster@@set + \fi} + +\def\poster@true{true} + +\def\poster{% + \begingroup + \futurelet\next\poster@i} +\def\poster@i{% + \ifx\next[% + \expandafter\poster@set + \fi + \poster@ii} +\def\poster@ii{% + \let\posternumbering@automatic\posternumbering@rowcol + \afterassignment\poster@iii + \setbox\@posterbox=\hbox} +\def\poster@iii{\aftergroup\poster@iv} +\def\poster@iv{% + \setbox\@posterbox=\hbox{\raise\dp\@posterbox\box\@posterbox}% + \poster@savepage + \poster@magtonum + \ifx\POSTERlandscape\poster@true \poster@landscape \fi + \poster@hoffsets + \poster@voffsets + \ifx\POSTERvcenter\poster@true \poster@vcenter \fi + \ifx\POSTERhcenter\poster@true \poster@hcenter \fi + \poster@makecropbox + \count\@ne=\z@ + \poster@vloop + \endgroup} + +\def\Poster{% + \begingroup + \futurelet\next\Poster@i} +\def\Poster@i{% + \ifx\next[% + \expandafter\poster@set + \fi + \Poster@ii} +\def\Poster@ii{% + \let\posternumbering@automatic\posternumbering@rowcol + \setbox\@posterbox=\hbox\bgroup\ignorespaces} +\def\endPoster{\egroup\poster@iv} + +\def\PosterPage{\futurelet\next\PosterPage@i} +\def\PosterPage@i{% + \ifx\next[% + \expandafter\poster@set + \fi + \PosterPage@ii} +\def\PosterPage@ii{% + \let\posternumbering@automatic\posternumbering@page + \let\poster@trueshipout\shipout + \let\shipout\poster@pageshipout} +\def\poster@pageshipout{% + \begingroup + \let\poster@savepage\relax + \let\shipout\poster@trueshipout + \setbox\@posterbox\box\voidb@x + \afterassignment\poster@@pageshipout + \setbox\@posterbox} +\def\poster@@pageshipout{% + \ifvoid\@posterbox\aftergroup\poster@iv\else\poster@iv\fi} +\let\poster@swapcounters\relax + +% Make writes immediates, so that they are not repeated. +\def\posterwrites@true{% + \let\PosterSaved@write\write + \let\PosterSaved@read\read + \let\PosterSaved@openout\openout + \let\PosterSaved@closeout\closeout + \def\write{\PosterSaved@write-1{}\immediate\PosterSaved@write}% + \def\read{\PosterSaved@write-1{}\immediate\PosterSaved@read}% + \def\openout{\PosterSaved@write-1{}\immediate\PosterSaved@openout}% + \def\closeout{\PosterSaved@write-1{}\immediate\PosterSaved@closeout}} + +\def\posternumbering@rowcol{% + \count\z@=\count\@ne + \count\@ne=\count\tw@ + \count\tw@=\z@} + +\def\posternumbering@serial{% + \count\z@=\poster@cnt + \count\@ne=\z@ + \count\tw@=\z@} + +% Save current contents of page in case it contains \special's: +\def\poster@savepage{% + \begingroup + \global\setbox\poster@savedbox\box\voidb@x + \output{\global\setbox\poster@savedbox\box\@cclv}% + \par\hbox{}\penalty-10000 + \endgroup + \ifvoid\poster@savedbox\else + \dp\poster@savedbox\z@ + \ht\poster@savedbox\z@ + \wd\poster@savedbox\z@ + \fi} + +% \poster@mag set to decimal value of \mag. +\def\poster@magtonum{% + \ifnum\mag=1000 + \def\poster@mag{}% + \else + \count@=10000000 + \divide\count@\mag + \advance\count@ by 200000000 + \expandafter\poster@@magtonum\the\count@ + \fi + \dimen@=\POSTERcropwidth\relax + \multiply\dimen@ 100 + \divide\dimen@\mag + \multiply\dimen@ 10 + \edef\poster@cropwidth{\number\dimen@ sp }} + +\def\poster@@magtonum#1#2#3#4#5#6#7#8#9{% + \count@ #2#3#4#5\relax + \edef\poster@mag{\the\count@.#6#7#8#9}} + +\def\poster@landscape{% + \let\next\POSTERpaperheight + \let\POSTERpaperheight\POSTERpaperwidth + \let\POSTERpaperwidth\next + \let\next\POSTERimageheight + \let\POSTERimageheight\POSTERimagewidth + \let\POSTERimagewidth\next} + +% \dimen@ii set to imageheight +\def\poster@voffsets{% + \dimen@\POSTERimageheight\relax + \dimen@ii=\poster@mag\dimen@ + \voffset=\POSTERpaperheight\relax + \advance\voffset-\dimen@ + \divide\voffset\tw@ + \ifdim\voffset<\z@ + \voffset\z@ + \fi + \dimen@=\poster@mag\voffset + \edef\poster@vmargin{\number\dimen@ sp }% + \advance\voffset\m@ne in + \voffset=\poster@mag\voffset} + +% \dimen@i set to imagewidth +\def\poster@hoffsets{% + \dimen@\POSTERimagewidth\relax + \dimen@i=\poster@mag\dimen@ + \hoffset=\POSTERpaperwidth\relax + \advance\hoffset-\dimen@ + \divide\hoffset\tw@ + \ifdim\hoffset<\z@ + \hoffset=\z@ + \fi + \dimen@=\poster@mag\hoffset + \edef\poster@hmargin{\number\dimen@ sp }% + \advance\hoffset\m@ne in + \hoffset=\poster@mag\hoffset} + +% Center vertically +\def\poster@vcenter{% + \count@=\ht\@posterbox + \divide\count@\dimen@ii + \dimen@=\the\count@\dimen@ii + \advance\dimen@-\ht\@posterbox + \ifdim\dimen@<-.1pt + \advance\count@\@ne + \fi + \setbox\@posterbox=\hbox{\vbox to \the\count@\dimen@ii{% + \vss\box\@posterbox\vss}}} + +% Center horizontally +\def\poster@hcenter{% + \count@=\wd\@posterbox + \divide\count@\dimen@i + \dimen@=\the\count@\dimen@i + \advance\dimen@-\wd\@posterbox + \ifdim\dimen@<-.1pt + \advance\count@\@ne + \fi + \setbox\@posterbox=\hbox to \the\count@\dimen@i{% + \hss\box\@posterbox\hss}} + +% Print rows: +\def\poster@vloop{% + \ifdim\ht\@posterbox>.1\p@ + \ifdim\ht\@posterbox<\dimen@ii + \dimen@ii=\ht\@posterbox + \poster@makecropbox + \fi + \advance\count\@ne\@ne + \count\tw@=\z@ + \dimen@=\wd\@posterbox + \poster@hloop + \dimen@=\ht\@posterbox + \advance\dimen@-\dimen@ii + \ht\@posterbox\dimen@ + \expandafter\poster@vloop + \fi} + +% Print columns. +% \dimen@ is used as scratch to keep track of remaining width. +\def\poster@hloop{% + \ifdim\dimen@>.1\p@ + \advance\count\tw@ by \@ne + \begingroup + \ifdim\dimen@<\dimen@i + \dimen@i=\dimen@ + \poster@makecropbox + \fi + \ifnum\count\@ne=\@ne + \begingroup + \advance\dimen@ii.1\p@ + \ifdim\ht\@posterbox>\dimen@ii + \global\let\next\relax + \else + \gdef\next{\count\@ne=\count\tw@ \count\tw@=\z@}% + \fi + \endgroup + \next + \fi + \global\advance\poster@cnt\@ne + \csname posternumbering@\POSTERnumbering\endcsname + \poster@shipout + \endgroup + \advance\dimen@-\dimen@i + \expandafter\poster@hloop + \fi} + +% Shipout, aligning everything at the top-left corner: +\def\poster@shipout{% + \shipout\hbox{% + \ifvoid\poster@savedbox\else\box\poster@savedbox\fi + \csname beginposterclip@\POSTERclip\endcsname + \lower\ht\@posterbox\hbox to\z@{% + \advance\dimen@-\wd\@posterbox + \kern\dimen@ + \copy\@posterbox + \hss}% + \csname endposterclip@\POSTERclip\endcsname + \copy\poster@cropbox}}% + +% clip=pstricks +\def\beginposterclip@pstricks{% + \expandafter\ifx\csname @pstrickserr\endcsname\relax + \errmessage{% + You must load PSTricks to use poster.tex's clip=pstricks option!}% + \global\let\beginposterclip@pstricks\relax + \else + \gdef\beginposterclip@pstricks{\beginposterclip@@pstricks}% + \gdef\endposterclip@pstricks{\pstVerb{currentpoint initclip moveto}}% + \beginposterclip@@pstricks + \fi} + +\let\endposterclip@pstricks\relax + +\def\beginposterclip@@pstricks{% + \pst@Verb{% + /mtrxc CM def + \tx@STV + CP translate + newpath + 0 0 moveto + \pst@number\dimen@i 0 rlineto + 0 \pst@number\dimen@ii neg rlineto + \pst@number\dimen@i neg 0 rlineto + closepath + clip + newpath + 0 0 moveto + mtrxc setmatrix}} + +\def\poster@makecropbox{% + \setbox\poster@cropbox=\hbox{\csname postercrop@\POSTERcrop\endcsname}% + \ht\poster@cropbox=\z@ + \dp\poster@cropbox=\z@ + \wd\poster@cropbox=\z@} + +\def\postercrop@corners{% + \vtop{% + \hbox{% + \kern -\poster@hmargin + \vrule height \poster@cropwidth width \poster@hmargin + \kern -\poster@cropwidth + \vrule height \poster@vmargin width \poster@cropwidth + \kern \dimen@i + \vrule height \poster@vmargin width \poster@cropwidth + \kern -\poster@cropwidth + \vrule height \poster@cropwidth width \poster@hmargin}% + \nointerlineskip + \vskip\dimen@ii + \hbox{% + \kern -\poster@hmargin + \vrule height \z@ depth \poster@cropwidth width \poster@hmargin + \kern -\poster@cropwidth + \vrule height \z@ depth \poster@vmargin width \poster@cropwidth + \kern \dimen@i + \vrule height \z@ depth \poster@vmargin width \poster@cropwidth + \kern -\poster@cropwidth + \vrule height \z@ depth \poster@cropwidth width \poster@hmargin}}}% + +\def\postercrop@full{% + \begingroup + \hbox to\z@{% + \advance\dimen@ii\poster@vmargin + \kern -\poster@cropwidth + \vrule height \poster@vmargin depth \dimen@ii width \poster@cropwidth + \kern \dimen@i + \vrule height \poster@vmargin depth \dimen@ii width \poster@cropwidth + \hss}% + \kern -\poster@hmargin + \vtop{% + \advance\dimen@i \poster@hmargin + \advance\dimen@i \poster@hmargin + \kern-\poster@cropwidth + \hrule height \poster@cropwidth width \dimen@i + \kern\dimen@ii + \hrule height \z@ depth \poster@cropwidth width \dimen@i}% + \endgroup} + +\catcode`\@=\TheAtCode\relax +\endinput +%% +%% END poster.tex + diff --git a/reports/desc-tex2/poster1.tex b/reports/desc-tex2/poster1.tex new file mode 100644 index 0000000..e21afe7 --- /dev/null +++ b/reports/desc-tex2/poster1.tex @@ -0,0 +1,135 @@ +%% BEGIN poster1.tex +%% +%% Sample for poster.tex/poster.sty. +%% Run with LaTeX, with or without the NFSS. +%% You might have problems with missing fonts. +%% +%% See below if using A4 paper. + +\documentstyle{article} + +\input poster % Input here in case poster.sty not installed. + +\mag\magstep5 % Magnification of 1.2^5 (roughly 2.5) + % Use "true" dimensions below for magnified values. + +\begin{document} + +%% Add paperwidth=210mm,paperheight=297mm if using A4 paper: + +\begin{Poster}[vcenter=true,hcenter=true] +\setlength{\fboxsep}{.8truein}% +\setlength{\fboxrule}{.1truein}% +\fbox{\begin{minipage}{11.1truein} + +\begin{center} + \bf ON SOME \boldmath$\Pi$-HEDRAL SURFACES IN QUASI-QUASI SPACE +\end{center} +\begin{center} + CLAUDE HOPPER, Omnius University +\end{center} + +There is at present a school of mathematicians which holds that the +explosive growth of jargon within mathematics is a deplorable trend. It +is our purpose in this note to continue the work of +Redheffer~\cite{redheffer} in showing how terminology itself can lead to +results of great elegance. + +I first consolidate some results of Baker~\cite{baker} and +McLelland~\cite{mclelland}. We define a class of connected snarfs as +follows: $S_\alpha=\Omega(\gamma_\beta)$. Then if +$B=(\otimes,\rightarrow,\theta)$ is a Boolean left subideal, we have: +$$ +\nabla S_\alpha=\int\int\int_{E(\Omega)} +B(\gamma_{\beta_0},\gamma_{\beta_0})\,d\sigma d\phi d\rho +-\frac{19}{51}\Omega. +$$ +Rearranging, transposing, and collecting terms, we have: +$\Omega=\Omega_0$. + +The significance of this is obvious, for if $\{S_\alpha\}$ be a class of +connected snarfs, our result shows that its union is an utterly +disjoint subset of a $\pi$-hedral surface in quasi-quasi space. + +We next use a result of Spyrpt~\cite{spyrpt} to derive a property of +wild cells in door topologies. Let $\xi$ be the null operator on a door +topology, $\Box$, which is a super-linear space. Let $\{P_\gamma\}$ be +the collection of all nonvoid, closed, convex, bounded, compact, +circled, symmetric, connected, central, $Z$-directed, meager sets in +$\Box$. Then $P=\cup P_\gamma$ is perfect. Moreover, if $P\neq\phi$, +then $P$ is superb. + +\smallskip +{\it Proof.} The proof uses a lemma due to +Sriniswamiramanathan~\cite{srinis}. This states that any unbounded +fantastic set it closed. Hence we have +$$ +\Rightarrow P\sim\xi(P_\gamma)-\textstyle\frac{1}{3}. +$$ + +After some manipulation we obtain +$$ +\textstyle\frac{1}{3}=\frac{1}{3} +$$ +I have reason to believe~\cite{russell} that this implies $P$ is perfect. +If $P\neq\phi$, $P$ is superb. Moreover, if $\Box$ is a $T_2$ space, $P$ +is simply superb. This completes the proof. + +Our final result is a generalization of a theorem of Tz, and +encompasses some comments on the work of Beaman~\cite{beaman} on the +Jolly function. + +Let $\Omega$ be any $\pi$-hedral surface in a semi-quasi space. Define +a nonnegative, nonnegatively homogeneous subadditive linear functional +$f$ on $X\supset\Omega$ such that $f$ violently suppresses $\Omega$. +Then $f$ is the Jolly function. + +\smallskip +{\it Proof.} Suppose $f$ is not the Jolly function. Then +$\{\Lambda,\mbox{@},\xi\}\cap\{\Delta,\Omega,\Rightarrow\}$ is void. Hence +$f$ is morbid. This is a contradiction, of course. Therefore, $f$ is +the Jolly function. Moreover, if $\Omega$ is a circled husk, and +$\Delta$ is a pointed spear, then $f$ is uproarious. + +\small +\begin{center} +\bf References +\end{center} +\def\thebibliography#1{% + \list + {\bf\arabic{enumi}.}{\settowidth\labelwidth{\bf #1.}\leftmargin\labelwidth + \advance\leftmargin\labelsep + \usecounter{enumi}} + \def\newblock{\hskip .11em plus .33em minus .07em} + \sloppy\clubpenalty4000\widowpenalty4000 + \sfcode`\.=1000\relax} +\begin{thebibliography}{9} +\bibitem{redheffer} +R. M. Redheffer, A real-life application of mathematical symbolism, +this {\it Magazine}, 38 (1965) 103--4. +\bibitem{baker} +J. A. Baker, Locally pulsating manifolds, East Overshoe Math. J., 19 +(1962) 5280--1. +\bibitem{mclelland} +J. McLelland, De-ringed pistons in cylindric algebras, +Vereinigtermathematischerzeitung f\"ur Zilch, 10 (1962) 333--7. +\bibitem{spyrpt} +Mrowclaw Spyrpt, A matrix is a matrix is a matrix, Mat. Zburp., 91 +(1959) 28--35. +\bibitem{srinis} +Rajagopalachari Sriniswamiramanathan, Some expansions on the Flausgloten +Theorem on locally congested lutches, J. Math. Soc., North Bombay, 13 +(1964) 72--6. +\bibitem{russell} +A. N. Whitehead and B. Russell, Principia Mathematica, Cambridge +University Press, 1925. +\bibitem{beaman} +J. Beaman, Morbidity of the Jolly function, Mathematica Absurdica, 117 +(1965) 338--9. +\end{thebibliography} +\end{minipage}}% +\end{Poster} + +\end{document} +%% END poster1.tex + diff --git a/reports/desc-tex2/poster2.tex b/reports/desc-tex2/poster2.tex new file mode 100644 index 0000000..86955f3 --- /dev/null +++ b/reports/desc-tex2/poster2.tex @@ -0,0 +1,22 @@ +%% BEGIN poster2.tex +%% +%% A sample file for poster.tex/poster.sty. Makes a banner. +%% Use Plain TeX (or add preamble and use LaTeX) + +\input poster + +\special{landscape} % This works with Rokicki's dvips + +% ptmr should be name of the PostScript Times-Roman font: +% 8in is a good size for this font, but might not work with other fonts. +% You can use a Computer Modern font, if you are prepared to make a big +% font bitmap. + +\font\bigroman=ptmr at 8in +\bigroman + +\poster[vcenter=true,landscape=true]{Happy} + +\end +%% END poster2.tex + diff --git a/reports/desc-tex2/pstricks.con b/reports/desc-tex2/pstricks.con new file mode 100644 index 0000000..2d12812 --- /dev/null +++ b/reports/desc-tex2/pstricks.con @@ -0,0 +1,361 @@ +%% BEGIN: pstricks.con +%% +%% Configuration file for PSTricks v0.93a, 93/03/12. +%% +%% !! SEE INSTRUCTIONS AT END !! + + +%%%%%%%%%%% !! DRIVER CONFIGURATION DEFINITIONS GO HERE: !! %%%%%%%%%%%%%% + + +%% ********************************************************************** +%% ***** Rokicki's dvips ***** Rokicki's dvips ***** Rokicki's dvips **** +%% ********************************************************************** +%% Life is bliss with Rokicki's dvips (tested with v5.396, v5.47, 5.491): +%% +\def\pstdriver{Rokicki's dvips} +{\catcode`\"=12\gdef\pstverb#1{\special{" #1}}} % Check catcode of " +\def\pstunit{1bp}% +\def\pstVerb#1{\special{ps: #1}} +\def\pstverbscale{SDict begin normalscale end} +\def\pstheader#1{\special{header=#1}} +%% +%% In the following, CP is short for currentpoint. +%% The neg is necessary because dvips scales the coordinates by 1 -1. +%% \tx@NET means neg exch neg exch translate. +\def\pstrotate{% + CP CP translate 3 -1 roll neg rotate \tx@NET} +%% +%% If using a version before 5.47, clipping may not work. You can +%% try the following definition of \pstverb: +%\def\pstverb#1{\special{ps: @beginspecial #1 @endspecial}} +%% or change "{initclip}ifelse" to "if" in the definition of @setspecial +%% in dvips' special.pro. +%% +%% ****************** END Rokicki's dvips ***************************** + + +%%%%%%%%%%%%%%%%%%% !! CUSTOMIZATION STUFF GOES HERE: !! %%%%%%%%%%%%%%%%%% +%% If you want to include your own customizations to pstricks.tex, then +%% uncomment the \pstcustomize command, and include your modifications +%% after \pstcustomize. These will be read in after pstricks.tex. +%\pstcustomize + + +%%%%%%%%%%%%%%%%%%%%%%%%% !! END OF INPUT !! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\endinput + + +%%%%%%%%%%%%%%%%%%% !! GENERAL INSTRUCTIONS !! %%%%%%%%%%%%%%%%%%%%%%%%%%%% + +Because there are no standards for dvi-to-PS driver \special's, +some driver-dependent commands must be defined in this file. + +Possibly correct definitions for some dvi drivers are given below. +Copy the section for the driver you want to use to the indicated place +near the beginning of the file, replacing any other definitions you +might find there. + +When changing drivers, you may need to remake the header file. + +See the PSTricks read-me file for further installation instructions. + +Please report good and bad experiences with dvi-to-PS drivers, +along with the definitions of these commands that worked +for you, to tvz@Princeton.EDU. Thanks. + + +%%%%%%%%%%%%%%%% DESCRIPTION OF CONFIGURATION DEFINITIONS %%%%%%%%%%%%%%% + +Here are the commands that must be defined in this file: + + \pstverb{} - The argument is included as verbatim PostScript, + grouped by save and restore. The coordinate system + should be square, not rotated, and with the origin + at TeX's currentpoint. + + \pstVerb{} - The argument is included as verbatim PostScript, not + grouped by (g)save and (g)restore. The currentpoint + should be TeX's currentpoint. + + \pstunit - The units used by driver for graphics included with + \pstverb. Probably 1bp or 1sp. + + \pstverbscale - The PostScript code that scales the coordinate system + from that in effect with \pstVerb to that in effect + with \pstverb. Should not translate to the currentpoint. + + \pstrotate - The PostScript code that takes a number off the stack + and rotates the axes properly. I.e., + \pstVerb{angle \pstrotate} is used to begin rotations. + + \pstheader{} - The argument is a header file (e.g., .pro file). + If your driver does not support such a special, then + the command might just remind you to include the header + when printing. You can use PSTricks without a header, + in which case it does not matter how you define + \pstheader. See read-me.pst for details. + If you cannot change the default directory where your + driver looks for header files, and you cannot write to + that directory, then you include the path for your + PSTricks header files. + E.g., \def\pstheader#1{\special{header=~/tex/#1}}. + + \pstdriver - The name of the driver. + + +%%%%%%%%% !! HOW TO MAKE A TEX FORMAT WITH PSTRICKS PRELOADED !! %%%%%%%% + +See your local TeX documentation for instructions on creating a TeX format. + +Before making the format, be sure that this configuration file is correct. +It will be read only when creating the format, and not with every job. + +If you are not using header files, there are no more special instructions. + +Special instructions when using header files: + + - If you want to include supplementary PSTricks files (e.g., pst-node.tex), + add \input commands in the customization section above. + + - If your definition of \pstheader is, e.g. + + \def\pstheader#1{\special{\header=#1}} + + then change it to + + \def\pstheader#1{% + \expandafter\everyjob\expandafter{\the\everyjob + \special{header=#1}}} + + and put your original definition in the customization section, AFTER + any \input commands. E.g., the customization section might look like: + + \pstcustomize + \input pst-node.tex + \input pst-coil.tex + \def\pstheader#1{\special{header=#1}} + + - Input pstricks.tex at the appropriate time when creating the format. + E.g., when initex stops running: + *\input pstricks + *\dump + + +%%%%%%%%%% !! CONFIGURATIONS FOR SOME DRIVERS !! %%%%%%%%%%%%%%%%%%%%%%%% + + +%% ********************************************************************** +%% ***** Rokicki's dvips ***** Rokicki's dvips ***** Rokicki's dvips **** +%% ********************************************************************** +%% Life is bliss with Rokicki's dvips (tested with v5.396, v5.47, 5.491): +%% +\def\pstdriver{Rokicki's dvips} +{\catcode`\"=12\gdef\pstverb#1{\special{" #1}}} % Check catcode of " +\def\pstunit{1bp}% +\def\pstVerb#1{\special{ps: #1}} +\def\pstverbscale{SDict begin normalscale end} +\def\pstheader#1{\special{header=#1}} +%% +%% In the following, CP is short for currentpoint. +%% The neg is necessary because dvips scales the coordinates by 1 -1. +%% \tx@NET means neg exch neg exch translate. +\def\pstrotate{% + CP CP translate 3 -1 roll neg rotate \tx@NET} +%% +%% If using a version before 5.47, clipping may not work. You can +%% try the following definition of \pstverb: +%\def\pstverb#1{\special{ps: @beginspecial #1 @endspecial}} +%% or change "{initclip}ifelse" to "if" in the definition of @setspecial +%% in dvips' special.pro. +%% +%% ****************** END Rokicki's dvips ***************************** + + +%% ********************************************************************** +%% **** Arbortext's dvips *** Arbortext's dvips *** Arbortext's dvips *** +%% ********************************************************************** +%% Thanks to Wolfgang Sienel: +%% +\def\pstdriver{Arbortext's dvips} +\def\pstverb#1{% + \special{ps::[asis] 0 SPB /ChartCheckPoint save def + Xpos Ypos translate #1 ChartCheckPoint restore 0 SPE}} +\def\pstunit{1bp} +\def\pstVerb#1{\special{ps:: #1}} +\def\pstverbscale{} +\def\pstrotate{CP CP translate 3 -1 roll rotate \tx@NET} +\def\pstheader#1{% + \typeout{**********************************************************}% + \typeout{** Don't forget to include #1 when printing:}% + \typeout{** \space\space dvips -PRO #1 myfile}% + \typeout{**********************************************************}} +%% +%% Comments by Wolfgang on header files: +%% Normally the standard prolog file is downloaded once to the printer +%% with psload.ps (the initializing file for your TeX-printer) before +%% printing TeX-documents. If you don't make any changes to psload.ps +%% you have to type dvips -PRO PATH/pstricks.pro myfile (-PRO just +%% works for UNIX systems. I don't have any idea about other systems). +%% If psload.ps was not downloaded to the printer you have to append +%% pstricks.pro to the standard prolog file dvips.pro. In this case +%% invoke dvips as always. Note that after hitting the enter key you +%% have to specify the option download all prolog in both cases. If you +%% are frequently using pstricks you might want to change psload.ps. In +%% this case contact your local TeX-guru and ask him politely to do this +%% for you. Attention: If psload.ps is getting too big you may run into +%% trouble with printer memory! +%% +%% ****************** END Arbortext's dvips ***************************** + + +%% ********************************************************************** +%% **** Textures *** Textures *** Textures *** Textures *** Textures **** +%% ********************************************************************** +%% These have been tested with v1.3. It is nice to have a PostScript +%% screen previewer, such as TScript (USA: 1-617-734-9700). (The +%% Textures preview window will not show the PSTricks graphics.) +%% +\def\pstdriver{Textures} +\def\pstunit{1bp} +\def\pstverb#1{\special{postscript /TX@Save save def #1 TX@save restore}} +\def\pstVerb#1{\special{postscript grestore #1 gsave}} +\def\pstverbscale{Mag 1000 div 72.27 72 div mul dup neg scale} +\def\pstrotate{% + CP CP translate 3 -1 roll neg rotate \tx@NET} +%% +%% \pstVerb does not define the currentpoint properly. As a workaround, +%% insert the following lines in the customization section above. +%% +%% \def\pst@Verb#1{% +%% \special{postscript \pst@dict /sps { moveto /Mag ed } def +%% userdict begin}% +%% \special{postscript #1 end gsave}} +%% +%% Textures does not support header files. +%% However, it may still be worth using a header file for increased speed. +%% Also, some macros can overload Textures 1.3 when not used with a header +%% file. You can include the header file pstricks.pro by saving the +%% PostScript output to a file and inserting the pstricks.pro with an +%% editor. Probably a better solution is to append pstricks.pro to a +%% copy of the laserprep, and, by changing file names of the modified +%% laserprep and the original laserprep, use the laserprep with pstricks.pro +%% whenever you are printing pstricks documents. +\def\pstheader#1{% + \typeout{******************************************}% + \typeout{*** Include header file #1!! ***}% + \typeout{******************************************}} +%% +%% ****************** END Textures ************************************** + + +%% ********************************************************************** +%% ***** dvi2ps ***** dvi2ps ***** dvi2ps ***** dvi2ps ***** dvi2ps ***** +%% ********************************************************************** +%% I.e., dvi2ps, v2.xx. There are lot's of such things around. +%% This probably doesn't work. Considering upgrading to Rokicki's dvips. +%% +\def\pstdriver{dvi2ps v2.xx} +\def\pstunit{1pt} +\def\pstverb#1{ pstext="save currentpoint translate + Resolution 72.27 div neg scale #1 restore" \space} +\def\pstVerb#1{ pstext="#1" \space} +\def\pstverbscale{Resolution 72.27 div neg scale} +\def\pstrotate{% + CP CP translate 3 -1 roll neg rotate \tx@NET} +\def\pstheader#1{% + \typeout{******************************************************} + \typeout{Don't forget to include the header file #1!!} + \typeout{******************************************************} +%% +%% ***************************** END dvi2ps ***************************** + + +%% ********************************************************************** +%% ***** dvi3ps ***** dvi3ps ***** dvi3ps ***** dvi3ps ***** dvi3ps ***** +%% ********************************************************************** +%% I.e., dvi2ps, version 3.xx, by Kevin Coombes. +%% This has not been tested. Consider upgrading to Rokicki's dvips. +%% +\def\pstdriver{dvi2ps v3.xx} +\def\pstunit{1bp} +\def\pstverb#1{pstext="#1"} +% \def\pstVerb#1{% +% \special{pstext="@endspecial #1 @beginspecial @setspecial"}} % v3.0 +\def\pstVerb#1{\special{psraw="#1"}} % v3.3 +\def\pstverbscale{Resolution 72.27 div neg scale} +\def\pstrotate{% + CP CP translate 3 -1 roll neg rotate \tx@NET} +\def\pstheader#1{% + \typeout{******************************************************} + \typeout{Don't forget to include the header file #1!!} + \typeout{******************************************************} +%% +%% ******************* END dvi3ps *************************************** + + +%% ********************************************************************** +%% **** OzTeX **** OzTeX **** OzTeX **** OzTeX **** OzTeX **** OzTeX **** +%% ********************************************************************** +%% Only the pure graphics objects are supported for OzTeX. +%% No color, rotation, clipping, nodes and node connections, overlays, etc. +%% Also, \rput cannot be used with \SpecialCoor. +%% +%% The reason is given in the documentation for Version 1.3, September 1990: +%% +%% OzTeX generates highly efficient PostScript code but it does so at +%% the expense of some \special functionality. Many DVI-to-PostScript +%% translators allow you to do things like use one \verb|\special| to start +%% rotating TeX text and another to stop the rotation. The way OzTeX +%% interprets a DVI page makes this impossible. +%% +%% If using the header file, you should copy pstricks.pro to global.ps, in +%% the same directory as your dvi file. +%% +\def\pstdriver{OzTeX} +\def\pstverb#1{\special{null.ps #1}} +\def\pstunit{1bp} +\def\pstVerb#1{% + \typeout{PSTRICKS WARNING:}% + \typeout{\space\space You are using features not supported by OzTeX.}% + \typeout{\space\space These will be ignored.}% + \gdef\pstVerb##1{}} +\def\pstverbscale{} +\def\pstrotate{} +\def\pstheader#1{% + \typeout{******************************************************} + \typeout{Don't forget to include the header file #1!!} + \typeout{******************************************************}} +%% +%% ************************* END OzTeX ********************************** + + +%% ********************************************************************** +%% ***** DirectTeX ***** DirectTeX ***** DirectTeX ***** DirectTeX ****** +%% ********************************************************************** +%% DirectTeX is for the Macintosh. These has been tested unsuccessfully, +%% apparently due to a problem with DirectTeX. +%% +\def\pstdriver{DirectTeX} +%% +%% Check catcode of " +{\catcode`\"=12\gdef\pstverb#1{\special{" #1 /Foo{}def }}} +\def\pstunit{1bp} +\def\pstVerb#1{\special{ps: #1 }} +\def\pstverbscale{TeXDict begin normalscale end} +%% +%% In the following, CP is short for currentpoint. The neg is necessary +%% because dvips scales the coordinates by 1 -1: +\def\pstrotate{% + CP CP translate 3 -1 roll neg rotate \tx@NET} +%% +\def\pstheader#1{% + \typeout{**********************************************************}% + \typeout{** Don't forget to include #1 when printing:}% + \typeout{** \space\space DVIReader -header #1 myfile}% + \typeout{**********************************************************}} +%% +%% ****************** END DirectTeX ***************************** + + +%% END pstricks.con diff --git a/reports/desc-tex2/pstricks.pro b/reports/desc-tex2/pstricks.pro new file mode 100644 index 0000000..369ae17 --- /dev/null +++ b/reports/desc-tex2/pstricks.pro @@ -0,0 +1,171 @@ +%! +% PostScript prologue for pstricks.tex. +% Created 1993/3/12. Source file was pstricks.doc +% Version 0.93a, 93/03/12. +% For use with Rokicki's dvips. +/tx@Dict 200 dict def tx@Dict begin +/ADict 25 dict def +/CM { matrix currentmatrix } bind def +/SLW /setlinewidth load def +/CLW /currentlinewidth load def +/CP /currentpoint load def +/ED { exch def } bind def +/L /lineto load def +/T /translate load def +/Atan { /atan load stopped { pop pop 0 } if } def +/Div { dup 0 eq { pop } { div } ifelse } def +/NET { neg exch neg exch T } def +/Pyth { dup mul exch dup mul add sqrt } def +/PtoC { 2 copy cos mul 3 1 roll sin mul } def +/PathLength@ { /z z y y1 sub x x1 sub Pyth add def /y1 y def /x1 x def } +def +/PathLength { flattenpath /z 0 def { /y1 ED /x1 ED /y2 y1 def /x2 x1 def +} { /y ED /x ED PathLength@ } {} { /y y2 def /x x2 def PathLength@ } +pathforall z } def +/STP { .996264 dup scale } def +/STV { SDict begin normalscale end STP } def +/DashLine { dup 0 gt { /a .5 def PathLength exch div } { pop /a 1 def +PathLength } ifelse /b ED /x ED /y ED /z y x add def b a .5 sub 2 mul y +mul sub z Div round z mul a .5 sub 2 mul y mul add b exch Div dup y mul +/y ED x mul /x ED x 0 eq y 0 eq and { /x 1 def /y 1 def } if [ y x ] 1 a +sub y mul setdash stroke } def +/DotLine { /b PathLength def /a ED /z ED /y CLW def /z y z add def a 0 gt +{ /b b a div def } { a 0 eq { /b b y sub def } { a -3 eq { /b b y add +def } if } ifelse } ifelse [ 0 b b z Div round Div dup 0 le { pop 1 } if +] a 0 gt { 0 } { y 2 div a -2 gt { neg } if } ifelse setdash 1 +setlinecap stroke } def +/LineFill { abs CLW add /a ED gsave clip pathbbox a Div ceiling /y2 ED +/x2 ED a Div floor /y1 ED /x1 ED /n y2 y1 sub 1 add cvi def /y1 a y1 mul +def newpath 2 setlinecap n { currentstrokeadjust == x1 y1 moveto x2 y1 L +stroke /y1 y1 a add def } repeat grestore } def +/LineFill { abs CLW add /a ED gsave clip pathbbox a Div ceiling /y2 ED +/x2 ED a Div floor /y1 ED /x1 ED /n y2 y1 sub 1 add cvi def /y1 a y1 mul +def newpath 2 setlinecap systemdict /currentstrokeadjust known { +currentstrokeadjust } { false } ifelse { /t { } def } { /t { transform +0.25 sub round 0.25 add exch 0.25 sub round 0.25 add exch itransform } +bind def } ifelse n { x1 y1 t moveto x2 y1 t L stroke /y1 y1 a add def } +repeat grestore } def +/BeginArrow { ADict begin /@mtrx CM def gsave 2 copy T 2 index sub neg +exch 3 index sub exch Atan rotate newpath } def +/EndArrow { @mtrx setmatrix CP grestore end } def +/Arrow { CLW mul add dup 2 div /w ED mul dup /h ED mul /a ED { 0 h T 1 -1 +scale } if w neg h moveto 0 0 L w h L w neg a neg rlineto gsave fill +grestore } def +/Tbar { CLW mul add /z ED z -2 div CLW 2 div moveto z 0 rlineto stroke 0 +CLW moveto } def +/Bracket { CLW mul add dup CLW sub 2 div /x ED mul CLW add /y ED /z CLW 2 +div def x neg y moveto x neg CLW 2 div L x CLW 2 div L x y L stroke 0 +CLW moveto } def +/RoundBracket { CLW mul add dup 2 div /x ED mul /y ED /mtrx CM def 0 CLW +2 div T x y mul 0 ne { x y scale } if 1 1 moveto .85 .5 .35 0 0 0 +curveto -.35 0 -.85 .5 -1 1 curveto mtrx setmatrix stroke 0 CLW moveto } +def +/Shadow { [ { /moveto load } { /lineto load } { /curveto load } { +/closepath load } pathforall ] cvx newpath 3 1 roll T exec } def +/SD { 0 360 arc fill } def +/SQ { /r ED r r moveto r r neg L r neg r neg L r neg r L fill } def +/ST { /y ED /x ED x y moveto x neg y L 0 x L fill } def +/SP { /r ED gsave 0 r moveto 4 { 72 rotate 0 r L } repeat fill grestore } +def +/NArray { aload length 2 div dup dup cvi eq not { exch pop } if /n exch +cvi def } def +/NArray { /f ED counttomark 2 div dup cvi /n ED n eq not { exch pop } if +f { ] aload /Points ED } { n 2 mul 1 add -1 roll pop } ifelse } def +/Line { NArray n 0 eq not { n 1 eq { 0 0 /n 2 def } if ArrowA /n n 2 sub +def n { Lineto } repeat CP 4 2 roll ArrowB L pop pop } if } def +/Arcto { /a [ 6 -2 roll ] cvx def a r /arcto load stopped { 5 } { 4 } +ifelse { pop } repeat a } def +/CheckClosed { dup n 2 mul 1 sub index eq 2 index n 2 mul 1 add index eq +and { pop pop /n n 1 sub def } if } def +/Polygon { NArray n 2 eq { 0 0 /n 3 def } if n 3 lt { n { pop pop } +repeat } { n 3 gt { CheckClosed } if n 2 mul -2 roll /y0 ED /x0 ED /y1 +ED /x1 ED x1 y1 /x1 x0 x1 add 2 div def /y1 y0 y1 add 2 div def x1 y1 +moveto /n n 2 sub def n { Lineto } repeat x1 y1 x0 y0 6 4 roll Lineto +Lineto pop pop closepath } ifelse } def +/CCA { /y ED /x ED 2 copy y sub /dy1 ED x sub /dx1 ED /l1 dx1 dy1 Pyth +def } def +/CCA { /y ED /x ED 2 copy y sub /dy1 ED x sub /dx1 ED /l1 dx1 dy1 Pyth +def } def +/CC { /l0 l1 def /x1 x dx sub def /y1 y dy sub def /dx0 dx1 def /dy0 dy1 +def CCA /dx dx0 l1 c exp mul dx1 l0 c exp mul add def /dy dy0 l1 c exp +mul dy1 l0 c exp mul add def /m dx0 dy0 Atan dx1 dy1 Atan sub 2 div cos +abs b exp a mul dx dy Pyth Div 2 div def /x2 x l0 dx mul m mul sub def +/y2 y l0 dy mul m mul sub def /dx l1 dx mul m mul neg def /dy l1 dy mul +m mul neg def } def +/IC { /c c 1 add def c 0 lt { /c 0 def } { c 3 gt { /c 3 def } if } +ifelse /a a 2 mul 3 div 45 cos b exp div def CCA /dx 0 def /dy 0 def } +def +/BOC { IC CC x2 y2 x1 y1 ArrowA CP 4 2 roll x y curveto } def +/NC { CC x1 y1 x2 y2 x y curveto } def +/EOC { x dx sub y dy sub 4 2 roll ArrowB 2 copy curveto } def +/BAC { IC CC x y moveto CC x1 y1 CP ArrowA } def +/NAC { x2 y2 x y curveto CC x1 y1 } def +/EAC { x2 y2 x y ArrowB curveto pop pop } def +/OpenCurve { NArray n 3 lt { n { pop pop } repeat } { BOC /n n 3 sub def +n { NC } repeat EOC } ifelse } def +/AltCurve { { false NArray n 2 mul 2 roll [ n 2 mul 3 sub 1 roll ] aload +/Points ED n 2 mul -2 roll } { false NArray } ifelse n 4 lt { n { pop +pop } repeat } { BAC /n n 4 sub def n { NAC } repeat EAC } ifelse } def +/ClosedCurve { NArray n 3 lt { n { pop pop } repeat } { n 3 gt { +CheckClosed } if 6 copy n 2 mul 6 add 6 roll IC CC x y moveto n { NC } +repeat closepath pop pop } ifelse } def +/EndDot { { /z DS def } { /z 0 def } ifelse /b ED 0 z DS SD b { 0 z DS +CLW sub SD } if 0 DS z add CLW 4 div sub moveto } def +/Rect { x1 y1 y2 add 2 div moveto x1 y2 lineto x2 y2 lineto x2 y1 lineto +x1 y1 lineto closepath } def +/OvalFrame { x1 x2 eq y1 y2 eq or { pop pop x1 y1 moveto x2 y2 L } { y1 +y2 sub abs x1 x2 sub abs 2 copy gt { exch pop } { pop } ifelse 2 div +exch { dup 3 1 roll mul exch } if 2 copy lt { pop } { exch pop } ifelse +/b ED x1 y1 y2 add 2 div moveto x1 y2 x2 y2 b arcto x2 y2 x2 y1 b arcto +x2 y1 x1 y1 b arcto x1 y1 x1 y2 b arcto 16 { pop } repeat closepath } +ifelse } def +/Frame { CLW mul /a ED 3 -1 roll 2 copy gt { exch } if a sub /y2 ED a add +/y1 ED 2 copy gt { exch } if a sub /x2 ED a add /x1 ED 1 index 0 eq { +pop pop Rect } { OvalFrame } ifelse } def +/Parab { /y0 exch def /x0 exch def /y1 exch def /x1 exch def /dx x0 x1 +sub 3 div def /dy y0 y1 sub 3 div def x0 dx sub y0 dy add x1 y1 ArrowA +x0 dx add y0 dy add x0 2 mul x1 sub y1 ArrowB curveto /Points [ x1 y1 x0 +y0 x0 2 mul x1 sub y1 ] def } def +/Grid { /a 4 string def /b ED /d ED /n ED cvi dup 1 lt { pop 1 } if /c ED +c div dup 0 eq { pop 1 } if /cy ED c div dup 0 eq { pop 1 } if /cx ED cy +div cvi /y ED cx div cvi /x ED cy div cvi /y2 ED cx div cvi /x2 ED cy +div cvi /y1 ED cx div cvi /x1 ED /h y2 y1 sub 0 gt { 1 } { -1 } ifelse +def /w x2 x1 sub 0 gt { 1 } { -1 } ifelse def b 0 gt { /z1 b 4 div CLW 2 +div add def /Helvetica findfont b scalefont setfont /b b .95 mul CLW 2 +div add def } if gsave n 0 gt { 1 setlinecap [ 0 cy n div ] 0 setdash } +{ 2 setlinecap } ifelse /c x1 def /i 500 w mul x1 add def /e y cy mul +def /f y1 cy mul def /g y2 cy mul def x1 cx mul 0 T { newpath 0 e moveto +b 0 gt { gsave d c a cvs dup stringwidth pop /z2 ED w 0 gt {z1} {z1 z2 +add neg} ifelse h 0 gt {b neg} {z1} ifelse rmoveto show grestore } if 0 +f moveto 0 g L stroke cx w mul 0 T c x2 eq c i eq or {exit} if /c c w +add def } loop grestore gsave n 0 gt { 1 setlinecap [ 0 cx n div ] 0 +setdash } { 2 setlinecap } ifelse /c y1 def /i 500 h mul y1 add def /e x +cx mul def /f x1 cx mul def /g x2 cx mul def 0 y1 cy mul T { newpath e 0 +moveto b 0 gt { gsave d c a cvs dup stringwidth pop /z2 ED w 0 gt {z1 z2 +add neg} {z1} ifelse h 0 gt {z1} {b neg} ifelse rmoveto show grestore } +if f 0 moveto g 0 L stroke 0 cy h mul T c y2 eq c i eq or {exit} if /c c +h add def } loop grestore } def +/ArcArrow { /d ED /b ED /a ED gsave newpath 0 -1000 moveto clip newpath 0 +1 0 0 b grestore c mul /e ED pop pop pop r a e d PtoC y add exch x add +exch r a PtoC y add exch x add exch b pop pop pop pop a e d CLW 8 div c +mul neg d } def +/Ellipse { /mtrx CM def T scale 0 0 1 5 3 roll arc mtrx setmatrix } def +/Rot { CP CP translate 3 -1 roll neg rotate NET } def +/PutCoor { gsave CP T CM STV exch exec moveto setmatrix CP grestore } def +/PutBegin { /lmtrx [ tx@Dict /lmtrx known { lmtrx aload pop } if CM ] def +CP 4 2 roll T moveto } def +/PutEnd { CP /lmtrx [ lmtrx aload pop setmatrix ] def moveto } def +/Uput { /a ED add 2 div /h ED 2 div /w ED /s a sin def /c a cos def /b s +abs c abs 2 copy gt dup /q ED { pop } { exch pop } ifelse def /w1 c b +div w mul def /h1 s b div h mul def q { w1 abs w sub dup c mul abs } { +h1 abs h sub dup s mul abs } ifelse } def +/UUput { /z ED abs /y ED /x ED q { x s div c mul abs y gt } { x c div s +mul abs y gt } ifelse { x x mul y y mul sub z z mul add sqrt z add } { q +{ x s div } { x c div } ifelse abs } ifelse a PtoC h1 add exch w1 add +exch } def +/BeginOL { dup (all) eq exch TheOL eq or { IfVisible not { CP OLUnit T +moveto /IfVisible true def } if } { IfVisible { CP OLUnit NET moveto +/IfVisible false def } if } ifelse } def +/InitOL { /OLUnit [ gsave CM STV 2890.79999 dup moveto setmatrix CP +grestore ] cvx def /BOL { BeginOL } def /IfVisible true def } def +end diff --git a/reports/desc-tex2/pstricks.tex b/reports/desc-tex2/pstricks.tex new file mode 100644 index 0000000..929faf9 --- /dev/null +++ b/reports/desc-tex2/pstricks.tex @@ -0,0 +1,2061 @@ +%% BEGIN: pstricks.tex +%% Generated on <1993/3/12> from `pstricks.doc'. +%% For use with the PostScript header file `pstricks.pro'. +%% +\def\fileversion{0.93a} +\def\filedate{93/03/12} +%% +%% See the PSTricks read-me file and the User's Guide for documentation. +%% +%% COPYRIGHT 1993, by Timothy Van Zandt, tvz@Princeton.EDU +%% +%% Copying of part or all of any file in the pstricks.tex package +%% is allowed under the following conditions only: +%% (1) You may freely distribute unchanged copies of the files. Please +%% include the documentation when you do so. +%% (2) You may modify a renamed copy of any file, but only for personal +%% use or use within an organization. +%% (3) You may copy fragments from the files, for personal use or for use +%% in a macro package for distribution, as long as credit is given +%% where credit is due. +%% +%% You are NOT ALLOWED to take money for the distribution or use of +%% these files or modified versions or fragments thereof, except for +%% a nominal charge for copying etc. +%% +\csname PSTricksLoaded\endcsname +\let\PSTricksLoaded\endinput +\edef\PstAtCode{\the\catcode`\@} +\catcode`\@=11\relax +\expandafter\ifx\csname @latexerr\endcsname\relax +\long\def\@ifundefined#1#2#3{\expandafter\ifx\csname +#1\endcsname\relax#2\else#3\fi} +\def\@namedef#1{\expandafter\def\csname #1\endcsname} +\def\@nameuse#1{\csname #1\endcsname} +\def\@eha{% +Your command was ignored.^^J +Type \space I \space to replace +it with another command,^^J +or \space \space to continue without it.} +\def\@spaces{\space\space\space\space} +\def\typeout#1{\immediate\write\@unused{#1}} +\alloc@7\write\chardef\sixt@@n\@unused +\def\@empty{} +\def\@gobble#1{} +\def\@nnil{\@nil} +\def\@ifnextchar#1#2#3{% +\let\@tempe#1\def\@tempa{#2}\def\@tempb{#3}\futurelet\@tempc\@ifnch} +\def\@ifnch{% +\ifx\@tempc\@sptoken +\let\@tempd\@xifnch +\else +\ifx\@tempc\@tempe \let\@tempd\@tempa \else \let\@tempd\@tempb \fi +\fi +\@tempd} +\begingroup +\def\:{\global\let\@sptoken= } \: +\def\:{\@xifnch} \expandafter\gdef\: {\futurelet\@tempc\@ifnch} +\endgroup +\fi +\typeout{`PSTricks' v\fileversion\space\space <\filedate> (tvz)} +\def\@pstrickserr#1#2{% +\begingroup +\newlinechar`\^^J +\edef\pst@tempc{#2}% +\expandafter\errhelp\expandafter{\pst@tempc}% +\typeout{% +PSTricks error. \space See User's Guide for further information.^^J +\@spaces\@spaces\@spaces\@spaces +Type \space H \space for immediate help.}% +\errmessage{#1}% +\endgroup} +\def\@ehpa{% +Your command was ignored. Default value substituted.^^J +Type \space \space to procede.} +\def\@ehpb{% +Your command was ignored. Will recover best I can.^^J +Type \space \space to procede.} +\def\@ehpc{% +You better fix this before proceding.^^J +See the PSTricks User's Guide or ask your system administrator for help.^^J +Type \space X \space to quit.} +\def\pst@misplaced#1{\@pstrickserr{Misplaced \string#1 command}\@ehpb} +\newdimen\pst@dima +\newdimen\pst@dimb +\newdimen\pst@dimc +\newdimen\pst@dimd +\newdimen\pst@dimg +\newdimen\pst@dimh +\newbox\pst@hbox +\newbox\pst@boxg +\newcount\pst@cnta +\newcount\pst@cntb +\newcount\pst@cntc +\newcount\pst@cntd +\newcount\pst@cntg +\newcount\pst@cnth +\newif\if@pst +\newif\if@star +\def\pst@ifstar#1{% +\@ifnextchar*{\@startrue\def\next*{#1}\next}{\@starfalse#1}} +\def\pst@expandafter#1#2{% +\def\next{#1}% +\edef\@tempa{#2}% +\ifx\@tempa\@empty +\@pstrickserr{Unexpected empty argument!}\@ehpb +\def\@tempa{\@empty}% +\fi +\expandafter\next\@tempa} +\def\pst@dimtonum#1#2{\edef#2{\pst@@dimtonum#1}} +\def\pst@@dimtonum#1{\expandafter\pst@@@dimtonum\the#1} +{\catcode`\p=12 \catcode`\t=12 \global\@namedef{pst@@@dimtonum}#1pt{#1}} +\def\pst@pyth#1#2#3{% +\ifdim#1>#2\pst@@pyth#1#2#3\else\pst@@pyth#2#1#3\fi} +\def\pst@@pyth#1#2#3{% +\ifdim4#1>9#2% +#3=#1\advance#3 .2122#2% +\else +#3=.8384#1\advance#3 .5758#2% +\fi} +\def\pst@divide#1#2#3{% +\begingroup +\pst@dimg=#1\relax\pst@dimh=#2\relax +\pst@cnta=\pst@dimg +\pst@cntb=1073741824 +\pst@cntc=65536 +\def\pst@tempa{\fi\ifnum}% +\loop\ifnum\pst@cnta<\pst@cntb +\pst@tempa\pst@cntc>\@ne +\multiply\pst@cnta2\divide\pst@cntc2 +\repeat +\divide\pst@dimh\pst@cntc +\divide\pst@cnta\pst@dimh +\global\pst@dimg\number\pst@cnta sp +\endgroup +\pst@dimtonum\pst@dimg#3} +\def\pst@configerr#1{% +\@pstrickserr{\string#1 not defined in pstricks.con}\@ehpc} +% % \begin{macrocode} +\def\pstVerb#1{\pst@configerr\pstVerb} +\def\pstverb#1{\pst@configerr\pstverb} +\def\pstverbscale{\pst@configerr\pstverbscale} +\def\pstrotate{\pst@configerr\pstrotate} +\def\pstheader#1{\pst@configerr\pstheader} +\def\pstdriver{\pst@configerr\pstdriver} +\@ifundefined{pstcustomize}% +{\def\pstcustomize{\endinput\let\pstcustomize\relax}}{} +\input pstricks.con +\newif\ifPSTricks +\PSTrickstrue +\def\PSTricksOff{% +\def\pstheader##1{}% +\def\pstverb##1{}% +\def\pstVerb##1{}% +\PSTricksfalse} +\@ifundefined{pst@def}{\def\pst@def#1<#2>{\@namedef{tx@#1}{#2 }}}{} +\@ifundefined{pst@ATH}{\def\pst@ATH<#1>{}}{} +\pstheader{pstricks.pro} +\def\pst@dict{tx@Dict begin } +\def\pst@theheaders{pstricks.pro} +\def\pst@Verb#1{\pstVerb{\pst@dict #1 end}} +\def\tx@Atan{Atan } +\def\tx@Div{Div } +\def\tx@NET{NET } +\def\tx@Pyth{Pyth } +\def\tx@PtoC{PtoC } +\def\tx@PathLength@{PathLength@ } +\def\tx@PathLength{PathLength } +\pst@dimg=\pstunit\relax +\ifdim\pst@dimg=1bp +\def\pst@stp{.996264 dup scale} +\else +\edef\pst@stp{1 \pst@@dimtonum\pst@dimg\space div dup scale} +\fi +\def\tx@STP{STP } +\def\tx@STV{STV } +\def\pst@number#1{\pst@@dimtonum#1\space} +\def\pst@checknum#1#2{% +\edef\next{#1}% +\ifx\next\@empty +\let\pst@num\z@ +\else +\expandafter\pst@@checknum\next..\@nil +\fi +\ifnum\pst@num=\z@ +\@pstrickserr{Bad number: `#1'. 0 substituted.}\@ehpa +\def#2{0 }% +\else +\edef#2{\ifnum\pst@num=2 -\fi\the\pst@cntg.% +\expandafter\@gobble\the\pst@cnth\space}% +\fi} +\def\pst@@checknum{% +\@ifnextchar-% +{\def\pst@num{2}\expandafter\pst@@@checknum\@gobble}% +{\def\pst@num{1}\pst@@@checknum}} +\def\pst@@@checknum#1.#2.#3\@nil{% +\afterassignment\pst@@@@checknum\pst@cntg=0#1\relax\@nil +\afterassignment\pst@@@@checknum\pst@cnth=1#2\relax\@nil} +\def\pst@@@@checknum#1\relax\@nil{% +\ifx\@nil#1\@nil\else\let\pst@num\z@\fi} +\def\pst@getnumii#1 #2 #3\@nil{% +\pst@checknum{#1}\pst@tempg +\pst@checknum{#2}\pst@temph} +\def\pst@getnumiii#1 #2 #3 #4\@nil{% +\pst@checknum{#1}\pst@tempg +\pst@checknum{#2}\pst@temph +\pst@checknum{#3}\pst@tempi} +\def\pst@getnumiv#1 #2 #3 #4 #5\@nil{% +\pst@checknum{#1}\pst@tempg +\pst@checknum{#2}\pst@temph +\pst@checknum{#3}\pst@tempi +\pst@checknum{#4}\pst@tempj} +\def\pst@getdimnum#1 #2 #3\@nil{% +\pssetlength\pst@dimg{#1}% +\pst@checknum{#2}\pst@tempg} +\def\pst@getscale#1#2{% +\pst@expandafter\pst@getnumii{#1 #1} {} {} {}\@nil +\edef#2{\pst@tempg\space \pst@temph\space scale }% +\ifdim\pst@tempg\p@=\z@ +\@pstrickserr{Bad scaling argument `#1'}\@ehpa +\def#2{}% +\else +\ifdim\pst@temph\p@=\z@ +\@pstrickserr{Bad scaling argument}\@ehpa +\def#2{}% +\else +\ifdim\pst@tempg\p@=\p@ \ifdim\pst@temph\p@=\p@ \def#2{}\fi\fi +\fi +\fi} +\def\pst@getint#1#2{% +\pst@cntg=#1\relax +\edef#2{\the\pst@cntg\space}} +\begingroup +\catcode`\{=12 +\catcode`\}=12 +\catcode`\[=1 +\catcode`\]=2 +\gdef\pslbrace[{ ] +\gdef\psrbrace[} ] +\endgroup +\def\@newcolor#1#2{% +\expandafter\edef\csname #1\endcsname{\noexpand\pst@color{#2}}% +\expandafter\edef\csname color@#1\endcsname{#2}% +\ignorespaces} +\def\pst@color#1{% +\def\pst@currentcolor{#1}\pstVerb{#1}\aftergroup\pst@endcolor} +\def\pst@endcolor{\pstVerb{\pst@currentcolor}} +\def\pst@currentcolor{0 setgray} +\def\altcolormode{% +\def\pst@color##1{% +\pstVerb{gsave ##1}\aftergroup\pst@endcolor}% +\def\pst@endcolor{\pstVerb{\pst@grestore}}} +\def\pst@grestore{% +currentpoint +matrix currentmatrix +currentfont +grestore +setfont +setmatrix +moveto} +\def\pst@usecolor#1{\csname color@#1\endcsname\space} +\def\newgray#1#2{% +\pst@checknum{#2}\pst@tempg +\@newcolor{#1}{\pst@tempg setgray}} +\def\newrgbcolor#1#2{% +\pst@expandafter\pst@getnumiii{#2} {} {} {} {}\@nil +\@newcolor{#1}{\pst@tempg \pst@temph \pst@tempi setrgbcolor}} +\def\newhsbcolor#1#2{% +\pst@expandafter\pst@getnumiii{#2} {} {} {} {}\@nil +\@newcolor{#1}{\pst@tempg \pst@temph \pst@tempi sethsbcolor}} +\def\newcmykcolor#1#2{% +\pst@expandafter\pst@getnumiv{#2} {} {} {} {} {}\@nil +\@newcolor{#1}{\pst@tempg \pst@temph \pst@tempi \pst@tempj setcmykcolor}} +\newgray{black}{0} +\newgray{darkgray}{.25} +\newgray{gray}{.5} +\newgray{lightgray}{.75} +\newgray{white}{1} +\newrgbcolor{red}{1 0 0} +\newrgbcolor{green}{0 1 0} +\newrgbcolor{blue}{0 0 1} +\newrgbcolor{yellow}{1 1 0} +\newrgbcolor{cyan}{0 1 1} +\newrgbcolor{magenta}{1 0 1} +\def\psset#1{\@psset#1,\@nil\ignorespaces} +\def\@psset#1,{% +\@@psset#1==\@nil +\@ifnextchar\@nil{\@gobble}{\@psset}} +\def\@@psset#1=#2=#3\@nil{% +\@ifundefined{psset@#1}% +{\@pstrickserr{Graphics parameter `#1' not defined.}\@ehpa}% +{\@nameuse{psset@#1}{#2}}}% +\def\psset@style#1{% +\@ifundefined{pscs@#1}% +{\@pstrickserr{Custom style `#1' undefined}\@ehpa}% +{\@nameuse{pscs@#1}}} +\def\newpsstyle#1#2{\@namedef{pscs@#1}{\psset{#2}}} +\def\@none{none} +\def\pst@getcolor#1#2{% +\@ifundefined{color@#1}% +{\@pstrickserr{Color `#1' not defined}\@eha}% +{\edef#2{#1}}} +\newdimen\psunit \psunit 1cm +\newdimen\psxunit \psxunit 1cm +\newdimen\psyunit \psyunit 1cm +\let\psrunit\psunit +\def\pstunit@off{\let\@psunit\ignorespaces\ignorespaces} +\def\pssetlength#1#2{% +\let\@psunit\psunit +\afterassignment\pstunit@off +#1 #2\@psunit} +\def\psaddtolength#1#2{% +\let\@psunit\psunit +\afterassignment\pstunit@off +\advance#1 #2\@psunit} +\def\pssetxlength#1#2{% +\let\@psunit\psxunit +\afterassignment\pstunit@off +#1 #2\@psunit} +\def\pssetylength#1#2{% +\let\@psunit\psyunit +\afterassignment\pstunit@off +#1 #2\@psunit} +\def\psset@unit#1{% +\pssetlength\psunit{#1}% +\psxunit=\psunit +\psyunit=\psunit} +\def\psset@runit#1{\pssetlength\psrunit{#1}} +\def\psset@xunit#1{\pssetxlength\psxunit{#1}} +\def\psset@yunit#1{\pssetylength\psyunit{#1}} +\def\pst@getlength#1#2{% +\pssetlength\pst@dimg{#1}% +\edef#2{\pst@number\pst@dimg}} +\def\pst@@getlength#1#2{% +\pssetlength\pst@dimg{#1}% +\edef#2{\number\pst@dimg sp}} +\def\pst@getcoor#1#2{\pst@@getcoor{#1}\let#2\pst@coor} +\def\pst@coor{0 0 } +\def\pst@getcoors#1#2{% +\def\pst@aftercoors{\addto@pscode{#1 \pst@coors }#2}% +\def\pst@coors{}% +\pst@@getcoors} +\def\pst@@getcoors(#1){% +\pst@@getcoor{#1}% +\edef\pst@coors{\pst@coor\pst@coors}% +\@ifnextchar({\pst@@getcoors}{\pst@aftercoors}} +\def\pst@getangle#1#2{\pst@@getangle{#1}\let#2\pst@angle} +\def\pst@angle{0 } +\def\cartesian@coor#1,#2,#3\@nil{% +\pssetxlength\pst@dimg{#1}% +\pssetylength\pst@dimh{#2}% +\edef\pst@coor{\pst@number\pst@dimg \pst@number\pst@dimh}} +\def\NormalCoor{% +\def\pst@@getcoor##1{\pst@expandafter\cartesian@coor{##1},\relax,\@nil}% +\def\pst@@getangle##1{% +\pst@checknum{##1}\pst@angle +\edef\pst@angle{\pst@angle \pst@angleunit}}% +\def\psput@##1{\pst@@getcoor{##1}\leavevmode\psput@cartesian}} +\NormalCoor +\def\degrees{\@ifnextchar[{\@degrees}{\def\pst@angleunit{}}} +\def\@degrees[#1]{% +\pst@checknum{#1}\pst@tempg +\edef\pst@angleunit{360 \pst@tempg div mul }% +\ignorespaces} +\def\radians{\def\pst@angleunit{57.2956 mul }} +\def\pst@angleunit{} +\def\SpecialCoor{% +\def\pst@@getcoor##1{\pst@expandafter\special@coor{##1}||\@nil}% +\def\pst@@getangle##1{\pst@expandafter\special@angle{##1}\@empty)\@nil}% +\def\psput@##1{\pst@@getcoor{##1}\leavevmode\psput@special}} +\def\special@coor#1|#2|#3\@nil{% +\ifx#3|\relax +\mixed@coor{#1}{#2}% +\else +\special@@coor#1;;\@nil +\fi} +\def\special@@coor#1{% +\ifcat#1a\relax +\def\next{\node@coor#1}% +\else +\ifx#1[\relax +\def\next{\Node@coor[}% +\else +\ifx#1!\relax +\def\next{\raw@coor}% +\else +\def\next{\special@@@coor#1}% +\fi +\fi +\fi +\next} +\def\special@@@coor#1;#2;#3\@nil{% +\ifx#3;\relax +\polar@coor{#1}{#2}% +\else +\cartesian@coor#1,\relax,\@nil +\fi} +\def\mixed@coor#1#2{% +\begingroup +\specialcoor@ii#1;;\@nil +\let\pst@tempa\pst@coor +\specialcoor@ii#2;;\@nil +\xdef\pst@tempg{\pst@tempa pop \pst@coor exch pop }% +\endgroup +\let\pst@coor\pst@tempg} +\def\polar@coor#1#2{% +\pssetlength\pst@dimg{#1}% +\pst@@getangle{#2}% +\edef\pst@coor{\pst@number\pst@dimg \pst@angle \tx@PtoC}} +\def\raw@coor#1;#2\@nil{% +\edef\pst@coor{% +#1 \pst@number\psyunit mul exch \pst@number\psxunit mul exch }} +\def\node@coor#1\@nil{% +\@pstrickserr{You must load `pst-node.tex' to use node coordinates.}\@ehps +\def\pst@coor{0 0 }} +\def\Node@coor{\node@coor} +\def\special@angle#1#2)#3\@nil{% +\ifx#1!\relax +\edef\pst@angle{#2 \pst@angleunit}% +\else +\ifx#1(\relax +\pst@@getcoor{#2}% +\edef\pst@angle{\pst@coor exch \tx@Atan}% +\else +\pst@checknum{#1#2}\pst@angle +\edef\pst@angle{\pst@angle \pst@angleunit}% +\fi +\fi} +\def\Cartesian{% +\def\cartesian@coor##1,##2,##3\@nil{% +\pssetxlength\pst@dimg{##1}% +\pssetylength\pst@dimh{##2}% +\edef\pst@coor{\pst@number\pst@dimg \pst@number\pst@dimh}}% +\@ifnextchar({\Cartesian@}{}} +\def\Cartesian@(#1,#2){% +\pssetxlength\psxunit{#1}% +\pssetylength\psyunit{#2}% +\ignorespaces} +\def\Polar{% +\def\psput@cartesian{\psput@special}% +\def\cartesian@coor##1,##2,##3\@nil{\polar@coor{##1}{##2}}}% +\def\psset@origin#1{% +\pst@@getcoor{#1}% +\edef\psk@origin{\pst@coor \tx@NET }} +\def\psk@origin{} +\newif\ifswapaxes +\def\psset@swapaxes#1{% +\@nameuse{@pst#1}% +\if@pst +\def\psk@swapaxes{-90 rotate -1 1 scale }% +\else +\def\psk@swapaxes{}% +\fi} +\psset@swapaxes{false} +\newif\ifshowpoints +\def\psset@showpoints#1{\@nameuse{showpoints#1}} +\psset@showpoints{false} +\let\pst@setrepeatarrowsflag\relax +\def\psset@border#1{% +\pst@getlength{#1}\psk@border +\pst@setrepeatarrowsflag} +\psset@border{0pt} +\def\psset@bordercolor#1{\pst@getcolor{#1}\psbordercolor} +\psset@bordercolor{white} +\newif\ifpsdoubleline +\def\psset@doubleline#1{% +\@nameuse{psdoubleline#1}% +\pst@setrepeatarrowsflag} +\psset@doubleline{false} +\def\psset@doublesep#1{\def\psdoublesep{#1}} +\psset@doublesep{1.25\pslinewidth} +\def\psset@doublecolor#1{\pst@getcolor{#1}\psdoublecolor} +\psset@doublecolor{white} +\newif\ifpsshadow +\def\psset@shadow#1{% +\@nameuse{psshadow#1}% +\pst@setrepeatarrowsflag} +\psset@shadow{false} +\def\psset@shadowsize#1{\pst@getlength{#1}\psk@shadowsize} +\psset@shadowsize{3pt} +\def\psset@shadowangle#1{\pst@getangle{#1}\psk@shadowangle} +\psset@shadowangle{-45} +\def\psset@shadowcolor#1{\pst@getcolor{#1}\psshadowcolor} +\psset@shadowcolor{darkgray} +\def\pst@repeatarrowsflag{\z@} +\def\pst@setrepeatarrowsflag{% +\edef\pst@repeatarrowsflag{% +\ifdim\psk@border\p@>\z@ 1\else\ifpsdoubleline 1\else +\ifpsshadow 1\else \z@\fi\fi\fi}} +\def\psls@none{} +\newdimen\pslinewidth +\def\psset@linewidth#1{\pssetlength\pslinewidth{#1}} +\psset@linewidth{.8pt} +\def\psset@linecolor#1{\pst@getcolor{#1}\pslinecolor} +\psset@linecolor{black} +\def\psls@solid{0 setlinecap stroke } +\def\psset@dash#1{% +\pst@expandafter\psset@@dash{#1} * * *\@nil +\edef\psk@dash{\pst@number\pst@dimg \pst@number\pst@dimh}} +\def\psset@@dash#1 #2 #3\@nil{% +\pssetlength\pst@dimg{#1}% +\pssetlength\pst@dimh{#2}} +\psset@dash{5pt 3pt} +\def\psls@dashed{\psk@dash \pst@linetype\space \tx@DashLine} +\def\tx@DashLine{DashLine } +\def\psset@dotsep#1{\pst@getlength{#1}\psk@dotsep} +\psset@dotsep{3pt} +\def\psls@dotted{\psk@dotsep \pst@linetype\space \tx@DotLine}% +\def\tx@DotLine{DotLine } +\def\psset@linestyle#1{% +\@ifundefined{psls@#1}% +{\@pstrickserr{Line style `#1' not defined}\@eha}% +{\edef\pslinestyle{#1}}} +\psset@linestyle{solid} +\def\psfs@none{} +\def\psset@fillcolor#1{\pst@getcolor{#1}\psfillcolor} +\psset@fillcolor{white} +\def\psfs@solid{\pst@usecolor\psfillcolor fill } +\def\psset@hatchwidth#1{\pst@getlength{#1}\psk@hatchwidth} +\psset@hatchwidth{.8pt} +\def\psset@hatchsep#1{\pst@getlength{#1}\psk@hatchsep} +\psset@hatchsep{4pt} +\def\psset@hatchcolor#1{\pst@getcolor{#1}\pshatchcolor} +\psset@hatchcolor{black} +\def\psset@hatchangle#1{\pst@getangle{#1}\psk@hatchangle} +\psset@hatchangle{45} +\def\psfs@hlines{% +\psk@hatchangle rotate +\psk@hatchwidth SLW +\pst@usecolor\pshatchcolor +\psk@hatchsep \tx@LineFill} +\@namedef{psfs@hlines*}{gsave \psfs@solid grestore \psfs@hlines} +\def\tx@LineFill{LineFill } +\def\tx@LineFill{LineFill } +\def\psfs@vlines{% +90 rotate +\psfs@hlines} +\@namedef{psfs@vlines*}{gsave \psfs@solid grestore \psfs@vlines} +\def\psfs@crosshatch{gsave \psfs@hlines grestore \psfs@vlines} +\@namedef{psfs@crosshatch*}{% +gsave \psfs@solid grestore +gsave \psfs@hlines grestore +\psfs@vlines} +\def\psset@fillstyle#1{% +\@ifundefined{psfs@#1}% +{\@pstrickserr{Undefined fill style: `#1'}\@eha}% +{\edef\psfillstyle{#1}}} +\psset@fillstyle{none} +\def\psset@arrows#1{% +\begingroup +\pst@activearrows +\xdef\pst@tempg{#1}% +\endgroup +\expandafter\psset@@arrows\pst@tempg\@empty-\@empty\@nil +\if@pst\else +\@pstrickserr{Bad arrows specification: #1}\@ehpa +\fi} +\def\psset@@arrows#1-#2\@empty#3\@nil{% +\@psttrue +\def\next##1,#1-##2,##3\@nil{\def\pst@tempg{##2}}% +\expandafter\next\pst@arrowtable,#1-#1,\@nil +\@ifundefined{psas@\pst@tempg}% +{\@pstfalse\def\psk@arrowA{}}% +{\let\psk@arrowA\pst@tempg}% +\@ifundefined{psas@#2}% +{\@pstfalse\def\psk@arrowB{}}% +{\def\psk@arrowB{#2}}} +\def\psk@arrowA{} +\def\psk@arrowB{} +\def\pst@arrowtable{,<->,<<->>,>-<,>>-<<,(-),[-]} +\begingroup +\catcode`\<=13 +\catcode`\>=13 +\catcode`\|=13 +\gdef\pst@activearrows{\def<{\string<}\def>{\string>}\def|{\string|}} +\endgroup +\def\tx@BeginArrow{BeginArrow } +\def\tx@EndArrow{EndArrow } +\def\psset@arrowscale#1{\pst@getscale{#1}\psk@arrowscale} +\psset@arrowscale{1} +\def\psset@arrowsize#1{% +\pst@expandafter\pst@getdimnum{#1} {} {} {}\@nil +\edef\psk@arrowsize{\pst@number\pst@dimg \pst@tempg}} +\psset@arrowsize{2pt 3} +\def\psset@arrowlength#1{\pst@checknum{#1}\psk@arrowlength} +\psset@arrowlength{1.4} +\def\psset@arrowinset#1{\pst@checknum{#1}\psk@arrowinset}% +\psset@arrowinset{.4} +\def\tx@Arrow{Arrow } +\@namedef{psas@>}{% +false \psk@arrowinset \psk@arrowlength \psk@arrowsize \tx@Arrow} +\@namedef{psas@>>}{% +false \psk@arrowinset \psk@arrowlength \psk@arrowsize \tx@Arrow +0 h T +gsave +newpath +false \psk@arrowinset \psk@arrowlength \psk@arrowsize \tx@Arrow +CP +grestore +CP newpath moveto +2 copy +L +stroke +moveto} +\@namedef{psas@<}{% +true \psk@arrowinset \psk@arrowlength \psk@arrowsize \tx@Arrow} +\@namedef{psas@<<}{% +true \psk@arrowinset \psk@arrowlength \psk@arrowsize \tx@Arrow +CP newpath moveto 0 a neg L stroke 0 h neg T +false \psk@arrowinset \psk@arrowlength \psk@arrowsize \tx@Arrow} +\def\psset@tbarsize#1{% +\pst@expandafter\pst@getdimnum{#1} {} {} {}\@nil +\edef\psk@tbarsize{\pst@number\pst@dimg \pst@tempg}} +\psset@tbarsize{2pt 5} +\def\tx@Tbar{Tbar } +\@namedef{psas@|}{\psk@tbarsize \tx@Tbar} +\@namedef{psas@|*}{0 CLW -2 div T \psk@tbarsize \tx@Tbar} +\def\psset@bracketlength#1{\pst@checknum{#1}\psk@bracketlength} +\psset@bracketlength{.15} +\def\tx@Bracket{Bracket } +\@namedef{psas@]}{\psk@bracketlength \psk@tbarsize \tx@Bracket} +\def\psset@rbracketlength#1{\pst@checknum{#1}\psk@rbracketlength} +\psset@rbracketlength{.15} +\def\tx@RoundBracket{RoundBracket } +\@namedef{psas@)}{\psk@rbracketlength \psk@tbarsize \tx@RoundBracket} +\def\psas@c{1 \psas@@c} +\def\psas@cc{0 CLW 2 div T 1 \psas@@c} +\def\psas@C{2 \psas@@c} +\def\psas@@c{% +setlinecap +0 0 moveto +0 CLW 2 div L +stroke +0 0 moveto} +\def\psas@{} +\psset@arrows{-} +\def\pst@par{} +\def\addto@par#1{% +\ifx\pst@par\@empty +\def\pst@par{#1}% +\else +\expandafter\def\expandafter\pst@par\expandafter{\pst@par,#1}% +\fi} +\def\use@par{% +\ifx\pst@par\@empty\else +\expandafter\@psset\pst@par,\@nil +\def\pst@par{}% +\fi} +\def\pst@object#1{% +\pst@ifstar{\@ifnextchar[{\pst@@object{#1}}{\@nameuse{#1@i}}}} +\def\pst@@object#1[#2]{% +\addto@par{#2}\@ifnextchar+{\@nameuse{#1@i}}{\@nameuse{#1@i}}} +\def\newpsobject#1#2#3{% +\@ifundefined{#2@i}% +{\@pstrickserr{Graphics object `#2' not defined}\@eha}% +{\@namedef{#1}{\def\pst@par{#3}\pst@object{#2}}}\ignorespaces} +\def\pst@getarrows#1{\@ifnextchar({#1}{\pst@@getarrows{#1}}} +\def\pst@@getarrows#1#2{\addto@par{arrows=#2}#1} +\def\begin@ClosedObj{% +\leavevmode +\pst@killglue +\begingroup +\use@par +\solid@star +\ifpsdoubleline \pst@setdoublesep \fi +\init@pscode} +\def\end@ClosedObj{% +\ifpsshadow \pst@closedshadow \fi +\ifdim\psk@border\p@>\z@ \pst@addborder \fi +\pst@fill +\pst@stroke +\ifpsdoubleline \pst@doublestroke \fi +\ifshowpoints +\addto@pscode{Points aload length 2 div cvi /N ED \psdots@iii}% +\fi +\use@pscode +\endgroup +\ignorespaces} +\def\begin@OpenObj{% +\begin@ClosedObj +\let\pst@linetype\pst@arrowtype +\pst@addarrowdef} +\def\begin@AltOpenObj{% +\begin@ClosedObj +\def\pst@repeatarrowsflag{\z@}% +\def\pst@linetype{0}} +\def\end@OpenObj{% +\ifpsshadow \pst@openshadow \fi +\ifdim\psk@border\p@>\z@ \pst@addborder \fi +\pst@fill +\pst@stroke +\ifpsdoubleline \pst@doublestroke \fi +\ifnum\pst@repeatarrowsflag>\z@ \pst@repeatarrows \fi +\ifshowpoints \pst@OpenShowPoints \fi +\use@pscode +\endgroup +\ignorespaces} +\def\begin@SpecialObj{% +\leavevmode +\pst@killglue +\begingroup +\use@par +\init@pscode} +\def\end@SpecialObj{% +\use@pscode +\endgroup +\ignorespaces} +\def\pst@code{}% +\def\init@pscode{% +\addto@pscode{% +\pst@number\pslinewidth SLW +\pst@usecolor\pslinecolor}} +\def\addto@pscode#1{\xdef\pst@code{\pst@code#1\space}} +\def\use@pscode{% +\pstverb{% +\pst@dict +\tx@STP +newpath +\psk@origin +\psk@swapaxes +\pst@code +end}% +\gdef\pst@code{}} +\def\KillGlue{% +\def\pst@killglue{\unskip\ifdim\lastskip>\z@\expandafter\pst@killglue\fi}} +\def\DontKillGlue{\let\pst@killglue\relax} +\DontKillGlue +\def\solid@star{% +\if@star +\pslinewidth=\z@ +\psdoublelinefalse +\def\pslinestyle{none}% +\def\psfillstyle{solid}% +\let\psfillcolor\pslinecolor +\fi} +\def\pst@setdoublesep{% +\pst@getlength\psdoublesep\psdoublesep +\pslinewidth=2\pslinewidth +\advance\pslinewidth\psdoublesep\p@ +\let\pst@setdoublesep\relax} +\def\tx@Shadow{Shadow } +\def\pst@closedshadow{% +\addto@pscode{% +gsave +\psk@shadowsize \psk@shadowangle \tx@PtoC +\tx@Shadow +\pst@usecolor\psshadowcolor +gsave fill grestore +stroke +grestore +gsave +\pst@usecolor\psfillcolor +gsave fill grestore +stroke +grestore}} +\def\pst@openshadow{% +\addto@pscode{% +gsave +\psk@shadowsize \psk@shadowangle \tx@PtoC +\tx@Shadow +\pst@usecolor\psshadowcolor +\ifx\psfillstyle\@none\else +gsave fill grestore +\fi +stroke}% +\pst@repeatarrows +\addto@pscode{grestore} +\ifx\psfillstyle\@none\else +\addto@pscode{% +gsave +\pst@usecolor\psfillcolor +gsave fill grestore +stroke +grestore} +\fi} +\def\pst@addborder{% +\addto@pscode{% +gsave +\psk@border 2 mul +CLW add SLW +\pst@usecolor\psbordercolor +stroke +grestore}} +\def\pst@stroke{% +\ifx\pslinestyle\@none\else +\addto@pscode{% +gsave +\pst@number\pslinewidth SLW +\pst@usecolor\pslinecolor +\@nameuse{psls@\pslinestyle} +grestore}% +\fi} +\def\pst@fill{% +\ifx\psfillstyle\@none\else +\addto@pscode{gsave \@nameuse{psfs@\psfillstyle} grestore}% +\fi} +\def\pst@doublestroke{% +\addto@pscode{% +gsave +\psdoublesep SLW +\pst@usecolor\psdoublecolor +stroke +grestore}} +\def\pst@arrowtype{% +\ifx\psk@arrowB\@empty 0 \else -2 \fi +\ifx\psk@arrowA\@empty 0 \else -1 \fi +add} +\def\pst@addarrowdef{% +\addto@pscode{% +/ArrowA { +\ifx\psk@arrowA\@empty +\pst@oplineto +\else +\pst@arrowdef{A} +moveto +\fi +} def +/ArrowB { +\ifx\psk@arrowB\@empty \else \pst@arrowdef{B} \fi +} def}} +\def\pst@arrowdef#1{% +\ifnum\pst@repeatarrowsflag>\z@ +/Arrow#1c [ 6 2 roll ] cvx def Arrow#1c +\fi +\tx@BeginArrow +\psk@arrowscale +\@nameuse{psas@\@nameuse{psk@arrow#1}} +\tx@EndArrow} +\def\pst@repeatarrows{% +\addto@pscode{% +gsave +\ifx\psk@arrowA\@empty\else +ArrowAc ArrowA pop pop +\fi +\ifx\psk@arrowB\@empty\else +ArrowBc ArrowB pop pop pop pop +\fi +grestore}} +\def\pst@OpenShowPoints{% +\addto@pscode{% +gsave +\psk@dotsize +\@nameuse{psds@\psk@dotstyle} +/TheDot { +gsave T \psk@dotangle \psk@dotscale Dot grestore +} def +newpath +Points aload length 2 div 2 sub cvi /N ED +N 0 ge +{ \ifx\psk@arrowA\@empty +TheDot +\else +pop pop +\fi +N { TheDot } repeat +\ifx\psk@arrowB\@empty +TheDot +\else +pop pop +\fi } +{ N 2 mul { pop } repeat } +ifelse +grestore}} +\def\pscustom{\def\pst@par{}\pst@object{pscustom}} +\long\def\pscustom@i#1{% +\begin@SpecialObj +\solid@star +\let\pst@ifcustom\iftrue +\let\begin@ClosedObj\begin@CustomObj +\let\end@ClosedObj\endgroup +\def\begin@OpenObj{\begin@CustomObj\pst@addarrowdef}% +\let\end@OpenObj\endgroup +\let\begin@AltOpenObj\begin@CustomObj +\def\begin@SpecialObj{% +\begingroup +\pst@misplaced{special graphics object}% +\def\addto@pscode####1{} +\let\end@SpecialObj\endgroup}% +\def\@multips(##1)(##2)##3##4{\pst@misplaced\multips}% +\def\psclip##1{\pst@misplaced\psclip}% +\def\pst@repeatarrowsflag{\z@}% +\let\pst@setrepeatarrowsflag\relax +\showpointsfalse +\let\showpointstrue\relax +\def\pst@linetype{\pslinetype}% +\let\psset@liftpen\psset@@liftpen +\psset@liftpen{\z@}% +\def\pst@cp{/currentpoint load stopped pop }% +\def\pst@oplineto{/lineto load stopped { moveto } if }% +\def\pst@optcp##1##2{% +\ifnum##1=\z@\def##2{/currentpoint load stopped { 0 0 } if }\fi}% +\let\caddto@pscode\addto@pscode +\def\cuse@par##1{{\use@par##1}}% +\the\pst@customdefs +\setbox\pst@hbox=\hbox{#1}% +\pst@fill +\pst@stroke +\end@SpecialObj} +\def\begin@CustomObj{% +\begingroup +\use@par +\addto@pscode{% +\pst@number\pslinewidth SLW +\pst@usecolor\pslinecolor}} +\def\pst@oplineto{moveto } +\def\pst@cp{} +\def\pst@optcp#1#2{} +\def\psset@liftpen#1{} +\def\psset@@liftpen#1{% +\ifcase#1\relax +\def\psk@liftpen{\z@}% +\def\pst@cp{/currentpoint load stopped pop }% +\def\pst@oplineto{/lineto load stopped { moveto } if }% +\or +\def\psk@liftpen{1}% +\def\pst@cp{}% +\def\pst@oplineto{/lineto load stopped { moveto } if }% +\or +\def\psk@liftpen{2}% +\def\pst@cp{}% +\def\pst@oplineto{moveto }% +\fi} +\psset@liftpen{0} +\def\psk@liftpen{-1} +\def\psset@linetype#1{% +\pst@getint{#1}\pslinetype +\ifnum\pst@dimg<-3 +\@pstrickserr{linetype must be greater than -3}\@ehpa +\def\pslinetype{0}% +\fi} +\psset@linetype{0} +\def\caddto@pscode#1{% +\@pstrickserr{Command can only be used in \string\pscustom}\@ehpa} +\let\cuse@par\caddto@pscode +\def\tx@MSave{% +/msavemtrx +[ tx@Dict /msavemtrx known { msavemtrx aload pop } if CM ] +def } +\def\tx@MRestore{% +tx@Dict /msavemtrx known { length 0 gt } { false } ifelse +{ /msavematrx [ msavematrx aload pop setmatrix ] def } +if } +\newtoks\pst@customdefs +\pst@customdefs{% +\def\newpath{\addto@pscode{newpath}}% +\def\moveto(#1){\pst@@getcoor{#1}\addto@pscode{\pst@coor moveto}}% +\def\closepath{\addto@pscode{closepath}}% +\def\gsave{\begingroup\addto@pscode{gsave}}% +\def\grestore{\endgroup\addto@pscode{grestore}}% +\def\translate(#1){\pst@@getcoor{#1}\addto@pscode{\pst@coor moveto}}% +\def\rotate#1{\pst@@getangle{#1}\addto@pscode{\pst@angle rotate}}% +\def\scale#1{\pst@getscale{#1}\pst@tempg\addto@pscode{\pst@tempg}}% +\def\msave{\addto@pscode{\tx@MSave}}% +\def\mrestore{\addto@pscode{\tx@MRestore}}% +\def\swapaxes{\addto@pscode{-90 rotate -1 1 scale}}% +\def\stroke{\def\pst@par{}\pst@object{stroke}}% +\def\fill{\def\pst@par{}\pst@object{fill}}% +\def\openshadow{\def\pst@par{}\pst@object{openshadow}}% +\def\closedshadow{\def\pst@par{}\pst@object{closedshadow}}% +\def\movepath(#1){\pst@@getcoor{#1}\addto@pscode{\pst@coor tx@Shadow}}% +\def\lineto{\pst@onecoor{lineto}}% +\def\rlineto{\pst@onecoor{rlineto}}% +\def\curveto{\pst@threecoor{curveto}}% +\def\rcurveto{\pst@threecoor{rcurveto}}% +\def\code#1{\addto@pscode{#1}}% +\def\coor(#1){\pst@@getcoor{#1}\addto@pscode\pst@coor\@ifnextchar({\coor}{}}% +\def\rcoor{\pst@getcoors{}{}}% +\def\dim#1{\pssetlength\pst@dimg{#1}\addto@pscode{\pst@number\pst@dimg}}% +\def\setcolor#1{% +\@ifundefined{color@#1}{}{\addto@pscode{\use@color{#1}}}}% +\def\arrows#1{{\psset@arrows{#1}\pst@addarrowdef}}% +\let\file\pst@rawfile +} % END \pst@customdefs +\def\closedshadow@i{\cuse@par\pst@closedshadow} +\def\openshadow@i{\cuse@par\pst@openshadow} +\def\stroke@i{\cuse@par\pst@stroke}% +\def\fill@i{\cuse@par\pst@fill}% +\def\pst@onecoor#1(#2){% +\pst@@getcoor{#2}% +\addto@pscode{\pst@coor #1}} +\def\pst@threecoor#1(#2)#3(#4)#5(#6){% +\begingroup +\pst@getcoor{#2}\pst@tempa +\pst@getcoor{#4}\pst@tempb +\pst@getcoor{#6}\pst@tembc +\addto@pscode{\pst@tempa \pst@tempb \pst@tempc #1}% +\endgroup} +\def\pst@rawfile#1{% +\begingroup +\def\do##1{\catcode`##1=12\relax}" +\dospecials +\catcode`\%=14 +\pst@@rawfile{#1}% +\endgroup} +\def\pst@@rawfile#1{% +\immediate\openin1 #1 +\ifeof1 +\@pstrickserr{File `#1' not found}\@ehpa +\else +\immediate\read1 to \pst@tempg +\loop +\ifeof1 \@pstfalse\else\@psttrue\fi +\if@pst +\addto@pscode\pst@tempg +\immediate\read1 to \pst@tempg +\repeat +\fi +\immediate\closein1\relax} +\def\tx@SD{SD } +\def\tx@SQ{SQ } +\def\tx@ST{ST } +\def\tx@SP{SP } +\@namedef{psds@*}{/Dot { 0 0 DS \tx@SD } def} +\@namedef{psds@o}{% +/r2 DS CLW sub def +/Dot { 0 0 DS \tx@SD \pst@usecolor\psfillcolor 0 0 r2 \tx@SD } def} +\@namedef{psds@square*}{% +/r1 DS .886 mul def +/Dot { r1 \tx@SQ } def} +\@namedef{psds@square}{% +/r1 DS .886 mul def /r2 r1 CLW sub def +/Dot { r1 \tx@SQ \pst@usecolor\psfillcolor r2 \tx@SQ } def} +\@namedef{psds@triangle*}{% +/y1 DS .778 mul neg def /x1 y1 1.732 mul neg def +/Dot { x1 y1 \tx@ST } def} +\@namedef{psds@triangle}{% +/y1 DS .778 mul neg def /x1 y1 1.732 mul neg def +/y2 y1 CLW add def /x2 y2 1.732 mul neg def +/Dot { x1 y1 \tx@ST \pst@usecolor\psfillcolor x2 y2 \tx@ST } def} +\@namedef{psds@pentagon*}{% +/r1 DS 1.149 mul def +/Dot { r1 \tx@SP } def} +\@namedef{psds@pentagon}{% +DS .93 mul dup 1.236 mul /r1 ED CLW sub 1.236 mul /r2 ED +/Dot { r1 \tx@SP \pst@usecolor\psfillcolor +r2 \tx@SP } def} +\@namedef{psds@+}{% +/DS DS 1.253 mul def +/Dot { DS 0 moveto DS neg 0 L stroke +0 DS moveto 0 DS neg L stroke } def} +\@namedef{psds@|}{% +\psk@tbarsize CLW mul add 2 div /DS ED +/Dot { 0 DS moveto 0 DS neg L stroke } def} +\def\psset@dotstyle#1{% +\@ifundefined{psds@#1}% +{\@pstrickserr{Dot style `#1' not defined}\@eha}% +{\edef\psk@dotstyle{#1}}} +\psset@dotstyle{*} +\def\tx@NArray{NArray } +\def\tx@NArray{NArray } +\def\tx@Line{Line } +\def\tx@Arcto{Arcto } +\def\tx@CheckClosed{CheckClosed } +\def\tx@Polygon{Polygon } +\def\tx@CCA{CCA } +\def\tx@CCA{CCA } +\def\tx@CC{CC } +\def\tx@IC{IC } +\def\tx@BOC{BOC } +\def\tx@NC{NC } +\def\tx@EOC{EOC } +\def\tx@BAC{BAC } +\def\tx@NAC{NAC } +\def\tx@EAC{EAC } +\def\tx@OpenCurve{OpenCurve } +\def\tx@AltCurve{AltCurve } +\def\tx@ClosedCurve{ClosedCurve } +\def\psset@curvature#1{% +\edef\pst@tempg{#1 }% +\expandafter\psset@@curvature\pst@tempg * * * \@nil} +\def\psset@@curvature#1 #2 #3 #4\@nil{% +\pst@checknum{#1}\pst@tempg +\pst@checknum{#2}\pst@temph +\pst@checknum{#3}\pst@tempi +\edef\psk@curvature{\pst@tempg \pst@temph \pst@tempi}} +\psset@curvature{1 .1 0} +\def\pscurve{\def\pst@par{}\pst@object{pscurve}} +\def\pscurve@i{% +\pst@getarrows{% +\begin@OpenObj +\pst@getcoors[\pscurve@ii}} +\def\pscurve@ii{% +\addto@pscode{% +\pst@cp +\psk@curvature\space /c ED /b ED /a ED +\ifshowpoints true \else false \fi +\tx@OpenCurve}% +\end@OpenObj} +\def\psecurve{\def\pst@par{}\pst@object{psecurve}} +\def\psecurve@i{% +\pst@getarrows{% +\begin@OpenObj +\pst@getcoors[\psecurve@ii}} +\def\psecurve@ii{% +\addto@pscode{% +\psk@curvature\space /c ED /b ED /a ED +\ifshowpoints true \else false \fi +\tx@AltCurve}% +\end@OpenObj} +\def\psccurve{\def\pst@par{}\pst@object{psccurve}} +\def\psccurve@i{% +\begin@ClosedObj +\pst@getcoors[\psccurve@ii} +\def\psccurve@ii{% +\addto@pscode{% +\psk@curvature\space /c ED /b ED /a ED +\ifshowpoints true \else false \fi +\tx@ClosedCurve}% +\def\pst@linetype{1}% +\end@ClosedObj} +\def\psset@dotsize#1{% +\edef\pst@tempg{#1 }% +\expandafter\psset@@dotsize\pst@tempg -1 -1 -1\@nil} +\def\psset@@dotsize#1 #2 #3\@nil{% +\pst@checknum{#2}\pst@tempg +\pssetlength\pst@dimg{#1}% +\edef\psk@dotsize{% +/DS \pst@number\pst@dimg \pst@tempg CLW mul add 2 div def }} +\psset@dotsize{.5pt 2.5} +\def\psset@dotscale#1{\pst@getscale{#1}\psk@dotscale} +\psset@dotscale{1} +\def\pst@Getangle#1#2{% +\pst@getangle{#1}\pst@tempg +\def\pst@temph{0. }% +\ifx\pst@tempg\pst@temph +\def#2{}% +\else +\edef#2{\pst@tempg\space rotate }% +\fi} +\def\psset@dotangle#1{\pst@Getangle{#1}\psk@dotangle} +\psset@dotangle{0} +\def\psdots{\def\pst@par{}\pst@object{psdots}} +\def\psdots@i{% +\begin@SpecialObj +\pst@getcoors[\psdots@ii} +\def\psdots@ii{% +\addto@pscode{false \tx@NArray \psdots@iii}% +\end@SpecialObj} +\def\psdots@iii{% +\psk@dotsize +\@nameuse{psds@\psk@dotstyle} +newpath +n { gsave T \psk@dotangle \psk@dotscale Dot grestore } repeat} +\def\tx@EndDot{EndDot } +\def\psas@oo{{\pst@usecolor\psfillcolor true} true \psk@dotsize \tx@EndDot} +\def\psas@o{{\pst@usecolor\psfillcolor true} false \psk@dotsize \tx@EndDot} +\@namedef{psas@**}{{false} true \psk@dotsize \tx@EndDot} +\@namedef{psas@*}{{false} false \psk@dotsize \tx@EndDot} +\newdimen\pslinearc +\def\psset@linearc#1{\pssetlength\pslinearc{#1}} +\psset@linearc{0pt} +\def\psline{\def\pst@par{}\pst@object{psline}} +\def\psline@i{% +\pst@getarrows{% +\begin@OpenObj +\pst@getcoors[\psline@ii}} +\def\psline@ii{% +\addto@pscode{\pst@cp \psline@iii \tx@Line}% +\end@OpenObj} +\def\psline@iii{% +\ifdim\pslinearc>\z@ +/r \pst@number\pslinearc def +/Lineto { \tx@Arcto } def +\else +/Lineto /lineto load def +\fi +\ifshowpoints true \else false \fi} +\def\qline(#1)(#2){% +\def\pst@par{}% +\begin@SpecialObj +\def\pst@linetype{0}% +\pst@getcoor{#1}\pst@tempa +\pst@@getcoor{#2}% +\addto@pscode{% +\pst@tempa moveto \pst@coor L +\@nameuse{psls@\pslinestyle}}% +\end@SpecialObj} +\def\pspolygon{\def\pst@par{}\pst@object{pspolygon}} +\def\pspolygon@i{% +\begin@ClosedObj +\def\pst@cp{}% +\pst@getcoors[\pspolygon@ii} +\def\pspolygon@ii{% +\addto@pscode{\psline@iii \tx@Polygon}% +\def\pst@linetype{1}% +\end@ClosedObj} +\def\psset@framearc#1{\pst@checknum{#1}\psk@framearc} +\psset@framearc{0} +\def\psset@cornersize#1{% +\pst@expandafter\psset@@cornersize{#1}\@nil} +\def\psset@@cornersize#1#2\@nil{% +\if #1a\relax +\def\psk@cornersize{\pst@number\pslinearc false }% +\else +\def\psk@cornersize{\psk@framearc true }% +\fi} +\psset@cornersize{relative} +\def\tx@Rect{Rect } +\def\tx@OvalFrame{OvalFrame } +\def\tx@Frame{Frame } +\def\psset@dimen#1{% +\pst@expandafter\psset@@dimen{#1}\@nil} +\def\psset@@dimen#1#2\@nil{% +\if #1o\relax +\def\psk@dimen{.5 }% +\else +\if #1m\relax +\def\psk@dimen{0 }% +\else +\if #1i\relax +\def\psk@dimen{-.5 }% +\fi +\fi +\fi} +\psset@dimen{outer} +\def\psframe{\def\pst@par{}\pst@object{psframe}} +\def\psframe@i(#1){% +\@ifnextchar({\psframe@ii(#1)}{\psframe@ii(0,0)(#1)}} +\def\psframe@ii(#1)(#2){% +\begin@ClosedObj +\pst@getcoor{#1}\pst@tempa +\pst@@getcoor{#2}% +\addto@pscode{\psk@cornersize \pst@tempa \pst@coor \psk@dimen \tx@Frame}% +\def\pst@linetype{2}% +\showpointsfalse +\end@ClosedObj} +\def\psbezier{\def\pst@par{}\pst@object{psbezier}} +\def\psbezier@i{\pst@getarrows\psbezier@ii} +\def\psbezier@ii#1(#2)#3(#4)#5(#6){% +\@ifnextchar({\psbezier@iii{1}(#2)(#4)(#6)}% +{\psbezier@iii{\z@}(0,0)(#2)(#4)(#6)}} +\def\psbezier@iii#1(#2)(#3)(#4)(#5){% +\begin@OpenObj +\pst@getcoor{#2}\pst@tempa +\pst@getcoor{#3}\pst@tempb +\pst@getcoor{#4}\pst@tempc +\pst@getcoor{#5}\pst@tempd +\pst@optcp{#1}\pst@tempa +\ifshowpoints\psbezier@iv\fi +\addto@pscode{ +\pst@tempb \pst@tempa ArrowA +\pst@tempc \pst@tempd ArrowB +curveto}% +\end@OpenObj} +\def\psbezier@iv{% +\addto@pscode{% +gsave +\pst@tempa \pst@tempb \pst@tempc \pst@tempd +newpath moveto L L L +CLW 2 div SLW +[ \psk@dash\space ] 0 setdash stroke +grestore +/Points [\pst@tempa\pst@tempb\pst@tempc\pst@tempd] def}} +\def\tx@Parab{Parab } +\def\parabola{\def\pst@par{}\pst@object{parabola}} +\def\parabola@i{\pst@getarrows\parabola@ii} +\def\parabola@ii#1(#2)#3(#4){% +\begin@OpenObj +\pst@getcoor{#2}\pst@tempa +\pst@@getcoor{#4}% +\addto@pscode{\pst@tempa \pst@coor \tx@Parab}% +\end@OpenObj} +\def\psset@gridwidth#1{\pst@getlength{#1}\psk@gridwidth} +\psset@gridwidth{.8pt} +\def\psset@griddots#1{% +\pst@cntg=#1\relax +\edef\psk@griddots{\the\pst@cntg}} +\psset@griddots{0} +\def\psset@gridcolor#1{\pst@getcolor{#1}\psgridcolor} +\psset@gridcolor{black} +\def\psset@subgridwidth#1{\pst@getlength{#1}\psk@subgridwidth} +\psset@subgridwidth{.4pt} +\def\psset@subgridcolor#1{\pst@getcolor{#1}\pssubgridcolor} +\psset@subgridcolor{gray} +\def\psset@subgriddots#1{% +\pst@cntg=#1\relax\edef\psk@subgriddots{\the\pst@cntg}} +\psset@subgriddots{0} +\def\psset@subgriddiv#1{% +\pst@cntg=#1\relax\edef\psk@subgriddiv{\the\pst@cntg}} +\psset@subgriddiv{5} +\def\psset@gridlabels#1{\pst@getlength{#1}\psk@gridlabels} +\psset@gridlabels{10pt} +\def\psset@gridlabelcolor#1{\pst@getcolor{#1}\psgridlabelcolor} +\psset@gridlabelcolor{black} +\def\tx@Grid{Grid } +\def\psgrid{\def\pst@par{}\pst@object{psgrid}} +\def\psgrid@i{\@ifnextchar(% +{\psgrid@ii}{\expandafter\psgrid@iv\pic@coor}} +\def\psgrid@ii(#1){\@ifnextchar(% +{\psgrid@iii(#1)}{\psgrid@iv(0,0)(0,0)(#1)}} +\def\psgrid@iii(#1)(#2){\@ifnextchar(% +{\psgrid@iv(#1)(#2)}{\psgrid@iv(#1)(#1)(#2)}} +\def\psgrid@iv(#1)(#2)(#3){% +\begin@SpecialObj +\pst@getcoor{#1}\pst@tempa +\pst@getcoor{#2}\pst@tempb +\pst@@getcoor{#3}% +\ifnum\psk@subgriddiv>1 +\addto@pscode{gsave +\psk@subgridwidth SLW \pst@usecolor\pssubgridcolor +\pst@tempb \pst@coor \pst@tempa +\pst@number\psxunit \pst@number\psyunit +\psk@subgriddiv\space \psk@subgriddots\space +{} 0 \tx@Grid grestore}% +\fi +\addto@pscode{gsave +\psk@gridwidth SLW \pst@usecolor\psgridcolor +\pst@tempb \pst@coor \pst@tempa +\pst@number\psxunit \pst@number\psyunit +1 \psk@griddots\space { \pst@usecolor\psgridlabelcolor } +\psk@gridlabels \tx@Grid grestore}% +\end@SpecialObj} +\newif\ifpsmathbox +\psmathboxtrue +\def\pst@mathflag{\z@} +\newtoks\everypsbox +\long\def\pst@makenotverbbox#1#2{% +\edef\pst@mathflag{% +\ifpsmathbox\ifmmode\ifinner 1\else 2\fi\else \z@\fi\else \z@\fi}% +\setbox\pst@hbox=\hbox{% +\ifcase\pst@mathflag\or$\m@th\textstyle\or$\m@th\displaystyle\fi +{\the\everypsbox#2}% +\ifnum\pst@mathflag>\z@$\fi}% +#1} +\def\pst@makeverbbox#1{% +\def\pst@afterbox{#1}% +\edef\pst@mathflag{% +\ifpsmathbox\ifmmode\ifinner 1\else 2\fi\else \z@\fi\else \z@\fi}% +\afterassignment\pst@beginbox +\setbox\pst@hbox\hbox} +\def\pst@beginbox{% +\ifcase\pst@mathflag\or$\m@th\or$\m@th\displaystyle\fi +\bgroup\aftergroup\pst@endbox +\the\everypsbox} +\def\pst@endbox{% +\ifnum\pst@mathflag>\z@$\fi +\egroup +\pst@afterbox} +\def\pst@makebox{\pst@@makebox} +\def\psverbboxtrue{\def\pst@@makebox{\pst@makeverbbox}} +\def\psverbboxfalse{\def\pst@@makebox{\pst@makenotverbbox}} +\psverbboxfalse +\def\pst@longbox{% +\def\pst@makebox{% +\gdef\pst@makebox{\pst@@makebox}% +\pst@makelongbox}} +\def\pst@makelongbox#1{% +\def\pst@afterbox{#1}% +\edef\pst@mathflag{% +\ifpsmathbox\ifmmode\ifinner 1\else 2\fi\else \z@\fi\else \z@\fi}% +\setbox\pst@hbox\hbox\bgroup +\aftergroup\pst@afterbox +\ifcase\pst@mathflag\or$\m@th\or$\m@th\displaystyle\fi +\begingroup +\the\everypsbox} +\def\pst@endlongbox{% +\endgroup +\ifnum\pst@mathflag>\z@$\fi +\egroup} +\def\pslongbox#1#2{% +\@namedef{#1}{\pst@longbox#2}% +\@namedef{end#1}{\pst@endlongbox}} +\newdimen\psframesep +\def\psset@framesep#1{\pssetlength\psframesep{#1}} +\psset@framesep{3pt} +\newif\ifpsboxsep +\def\psset@boxsep#1{\@nameuse{psboxsep#1}} +\psset@boxsep{true} +\def\pst@useboxpar{% +\use@par +\if@star +\let\pslinecolor\psfillcolor +\solid@star +\let\solid@star\relax +\fi +\ifpsdoubleline \pst@setdoublesep \fi} +\def\psframebox{\def\pst@par{}\pst@object{psframebox}} +\def\psframebox@i{\pst@makebox\psframebox@ii} +\def\psframebox@ii{% +\begingroup +\pst@useboxpar +\pst@dima=\pslinewidth +\advance\pst@dima by \psframesep +\pst@dimc=\wd\pst@hbox\advance\pst@dimc by \pst@dima +\pst@dimb=\dp\pst@hbox\advance\pst@dimb by \pst@dima +\pst@dimd=\ht\pst@hbox\advance\pst@dimd by \pst@dima +\setbox\pst@hbox=\hbox{% +\ifpsboxsep\kern\pst@dima\fi +\begin@ClosedObj +\addto@pscode{% +\psk@cornersize +\pst@number\pst@dima neg +\pst@number\pst@dimb neg +\pst@number\pst@dimc +\pst@number\pst@dimd +.5 +\tx@Frame}% +\def\pst@linetype{2}% +\showpointsfalse +\end@ClosedObj +\box\pst@hbox +\ifpsboxsep\kern\pst@dima\fi}% +\ifpsboxsep\dp\pst@hbox=\pst@dimb\ht\pst@hbox=\pst@dimd\fi +\leavevmode\box\pst@hbox +\endgroup} +\def\psdblframebox{\def\pst@par{}\pst@object{psdblframebox}} +\def\psdblframebox@i{\addto@par{doubleline=true}\psframebox@i} +\def\psclip#1{% +\leavevmode +\begingroup +\begin@psclip +\begingroup +\def\use@pscode{% +\pstVerb{% +\pst@dict +/mtrxc CM def +CP CP T +\tx@STV +\psk@origin +\psk@swapaxes +newpath +\pst@code +clip +newpath +mtrxc setmatrix +moveto +0 setgray +end}% +\gdef\pst@code{}}% +\def\@multips(##1)(##2)##3##4{\pst@misplaced\multips}% +\def\nc@object##1##2##3##4{\pst@misplaced{node connection}}% +\hbox to\z@{#1}% +\endgroup +\def\endpsclip{% +\end@psclip +\endgroup}% +\ignorespaces} +\def\endpsclip{\pst@misplaced\endpsclip} +\let\begin@psclip\relax +\def\end@psclip{\pstVerb{currentpoint initclip moveto}} +\def\AltClipMode{% +\def\end@psclip{\pstVerb{\pst@grestore}}% +\def\begin@psclip{\pstVerb{gsave}}} +\def\clipbox{\@ifnextchar[{\psclipbox@}{psclipbox@[\z@]}} +\def\clipbox@[#1]{\pst@makebox\psclipbox@@{#1}} +\def\clipbox@@#1{% +\pssetlength\pst@dimg{#1}% +\leavevmode\hbox{% +\begin@psclip +\pst@Verb{% +CM \tx@STV CP T newpath +/a \pst@number\pst@dimg def +/w \pst@number{\wd\pst@hbox}a add def +/d \pst@number{\dp\pst@hbox}a add neg def +/h \pst@number{\ht\pst@hbox}a add def +a neg d moveto +a neg h L +w h L +w d L +closepath +clip +newpath +0 0 moveto +setmatrix}% +\unhbox\pst@hbox +\end@psclip}} +\def\psshadowbox{% +\def\pst@par{}\pst@object{psshadowbox}} +\def\psshadowbox@i{\pst@makebox\psshadowbox@ii} +\def\psshadowbox@ii{% +\begingroup +\pst@useboxpar +\psshadowtrue +\psboxseptrue +\def\psk@shadowangle{-45 }% +\setbox\pst@hbox=\hbox{\psframebox@ii}% +\pst@dimh=\psk@shadowsize\p@ +\pst@dimh=.7071\pst@dimh +\pst@dimg=\dp\pst@hbox +\advance\pst@dimg\pst@dimh +\dp\pst@hbox=\pst@dimg +\pst@dimg=\wd\pst@hbox +\advance\pst@dimg\pst@dimh +\wd\pst@hbox=\pst@dimg +\leavevmode +\box\pst@hbox +\endgroup} +\def\pscirclebox{\def\pst@par{}\pst@object{pscirclebox}} +\def\pscirclebox@i{\pst@makebox{\pscirclebox@ii{}}} +\def\pscirclebox@ii#1{% +\begingroup +\pst@useboxpar +\setbox\pst@hbox=\hbox{#1\pscirclebox@iii\box\pst@hbox}% +\ifpsboxsep +\pst@dima=.5\wd\pst@hbox +\pst@pyth\pst@dima\pst@dimb\pst@dimc +\advance\pst@dimc\pslinewidth +\advance\pst@dimc\psframesep +\setbox\pst@hbox=\hbox to2\pst@dimc{% +\hss +\vbox{\vskip\pst@dimc\vskip-\pst@dimb\box\pst@hbox}% +\hss}% +\advance\pst@dimc-\pst@dimb +\dp\pst@hbox=\pst@dimc +\fi +\leavevmode\box\pst@hbox +\endgroup} +\def\pscirclebox@iii{% +\if@star +\pslinewidth\z@ +\pstverb{\pst@dict \tx@STP \pst@usecolor\psfillcolor +newpath \pscirclebox@iv \tx@SD end}% +\else +\begin@ClosedObj +\def\pst@linetype{4}\showpointsfalse +\addto@pscode{% +\pscirclebox@iv CLW 2 div add 0 360 arc closepath}% +\end@ClosedObj +\fi} +\def\pscirclebox@iv{% +\pst@number{\wd\pst@hbox}2 div +\pst@number{\ht\pst@hbox}\pst@number{\dp\pst@hbox}add 2 div +2 copy \pst@number{\dp\pst@hbox}sub 4 2 roll +\tx@Pyth \pst@number\psframesep add } +\def\psovalbox{\def\pst@par{}\pst@object{psovalbox}} +\def\psovalbox@i{\pst@makebox{\psovalbox@ii{}}} +\def\psovalbox@ii#1{% +\begingroup +\pst@useboxpar +\pst@dimd=.707\pslinewidth\advance\pst@dimd by 1.414\psframesep +\pst@dimg=\ht\pst@hbox\advance\pst@dimg\dp\pst@hbox +\pst@dimb=.707\pst@dimg\advance\pst@dimb\pst@dimd +\pst@dima=.707\wd\pst@hbox\advance\pst@dima\pst@dimd +\setbox\pst@hbox=\hbox{#1\psovalbox@iii\box\pst@hbox}% +\ifpsboxsep +\setbox\pst@hbox\hbox to 2\pst@dima{\hss\unhbox\pst@hbox\hss}% +\advance\pst@dimb-.5\pst@dimg +\pst@dimg\ht\pst@hbox +\advance\pst@dimg\pst@dimb +\ht\pst@hbox=\pst@dimb +\pst@dimg=\dp\pst@hbox +\advance\pst@dimg\pst@dimb +\dp\pst@hbox=\pst@dimb +\fi +\leavevmode\box\pst@hbox +\endgroup} +\def\psovalbox@iii{% +\begin@ClosedObj +\addto@pscode{% +0 360 +\pst@number\pst@dima \pst@number\pst@dimb +\pst@number{\wd\pst@hbox}2 div +\pst@number\pst@dimg 2 div \pst@number{\dp\pst@hbox}sub +\tx@Ellipse +closepath}% +\def\pst@linetype{2}% +\end@ClosedObj} +\def\psset@arcsepA#1{\pst@getlength{#1}\psk@arcsepA} +\def\psset@arcsepB#1{\pst@getlength{#1}\psk@arcsepB} +\def\psset@arcsep#1{% +\psset@arcsepA{#1}\let\psk@arcsepB\psk@arcsepA} +\psset@arcsep{0} +\def\tx@ArcArrow{ArcArrow } +\def\psarc{\def\pst@par{}\pst@object{psarc}} +\def\psarc@i{% +\@ifnextchar({\psarc@iii}{\psarc@ii}} +\def\psarc@ii#1{\addto@par{arrows=#1}% +\@ifnextchar({\psarc@iii}{\psarc@iii(0,0)}} +\def\psarc@iii(#1)#2#3#4{% +\begin@OpenObj +\pst@getangle{#3}\pst@tempa +\pst@getangle{#4}\pst@tempb +\pst@@getcoor{#1}% +\pssetlength\pst@dima{#2}% +\addto@pscode{\psarc@iv \psarc@v}% +\gdef\psarc@type{0}% +\showpointsfalse +\end@OpenObj} +\def\psarc@iv{% +\pst@coor /y ED /x ED +/r \pst@number\pst@dima def +/c 57.2957 r \tx@Div def +/angleA +\pst@tempa +\psk@arcsepA c mul 2 div +\ifcase \psarc@type add \or sub \fi +def +/angleB +\pst@tempb +\psk@arcsepB c mul 2 div +\ifcase \psarc@type sub \or add \fi +def +\ifshowpoints\psarc@showpoints\fi +\ifx\psk@arrowA\@empty +\ifnum\psk@liftpen=2 +r angleA \tx@PtoC +y add exch x add exch +moveto +\fi +\fi} +\def\psarc@v{% +x y r +angleA +\ifx\psk@arrowA\@empty\else +{ ArrowA CP } +{ \ifcase\psarc@type add \or sub \fi } +\tx@ArcArrow +\fi +angleB +\ifx\psk@arrowB\@empty\else +{ ArrowB } +{ \ifcase\psarc@type sub \or add \fi } +\tx@ArcArrow +\fi +\ifcase\psarc@type arc \or arcn \fi} +\def\psarc@type{0} +\def\psarc@showpoints{% +gsave +newpath +x y moveto +x y r \pst@tempa \pst@tempb +\ifcase\psarc@type arc \or arcn \fi +closepath +CLW 2 div SLW +[ \psk@dash\space ] 0 setdash stroke +grestore } +\def\psarcn{\def\pst@par{}\pst@object{psarcn}} +\def\psarcn@i{\def\psarc@type{1}\psarc@i} +\def\pscircle{\def\pst@par{}\pst@object{pscircle}} +\def\pscircle@i{\@ifnextchar({\pscircle@do}{\pscircle@do(0,0)}} +\def\pscircle@do(#1)#2{% +\if@star +{\use@par\qdisk(#1){#2}}% +\else +\begin@ClosedObj +\pst@@getcoor{#1}% +\pssetlength\pst@dimc{#2}% +\def\pst@linetype{4}% +\addto@pscode{% +\pst@coor +\pst@number\pst@dimc +\psk@dimen CLW mul sub +0 360 arc +closepath}% +\showpointsfalse +\end@ClosedObj +\fi +\ignorespaces} +\def\qdisk(#1)#2{% +\def\pst@par{}% +\begin@SpecialObj +\pst@@getcoor{#1}% +\pssetlength\pst@dimg{#2}% +\addto@pscode{\pst@coor \pst@number\pst@dimg \tx@SD}% +\end@SpecialObj} +\def\pswedge{\def\pst@par{}\pst@object{pswedge}} +\def\pswedge@i{\@ifnextchar({\pswedge@ii}{\pswedge@ii(0,0)}} +\def\pswedge@ii(#1)#2#3#4{% +\begin@ClosedObj +\pssetlength\pst@dimc{#2} +\pst@getangle{#3}\pst@tempa +\pst@getangle{#4}\pst@tempb +\pst@@getcoor{#1}% +\def\pst@linetype{1}% +\addto@pscode{% +\pst@coor +2 copy +moveto +\pst@number\pst@dimc \psk@dimen CLW mul sub % Adjusted radius +\pst@tempa \pst@tempb +arc +closepath}% +\showpointsfalse +\end@ClosedObj} +\def\tx@Ellipse{Ellipse } +\def\psellipse{\def\pst@par{}\pst@object{psellipse}} +\def\psellipse@i(#1){\@ifnextchar(% +{\psellipse@ii(#1)}{\psellipse@ii(0,0)(#1)}} +\def\psellipse@ii(#1)(#2){% +\begin@ClosedObj +\pst@getcoor{#1}\pst@tempa +\pst@@getcoor{#2}% +\addto@pscode{% +0 360 +\pst@coor +\ifdim\psk@dimen\p@=\z@\else +\psk@dimen CLW mul dup 3 1 roll +sub 3 1 roll sub exch +\fi +\pst@tempa +\tx@Ellipse +closepath}% +\def\pst@linetype{2}% +\end@ClosedObj} +\def\multirput{% +\begingroup\pst@getref{\pst@getrputrot\multirput@i}} +\def\multirput@i(#1){\@ifnextchar(% +{\multirput@ii(#1)}{\multirput@ii(0,0)(#1)}} +\def\multirput@ii(#1,#2)(#3,#4)#5{% +\pst@makebox{\multirput@iii(#1,#2)(#3,#4){#5}}} +\def\multirput@iii(#1,#2)(#3,#4)#5{% +\pst@makesmall\pst@hbox +\ifx\pst@rot\@empty\else\pst@rotate\pst@hbox\fi +\pssetxlength\pst@dima{#1}\pssetylength\pst@dimb{#2} +\pssetxlength\pst@dimc{#3}\pssetylength\pst@dimd{#4} +\pst@cntg=#5\relax\pst@cnth=0\relax +\leavevmode +\loop\ifnum\pst@cntg>\pst@cnth +\vbox to \z@{\vss\hbox to \z@{% +\kern\pst@dima\copy\pst@hbox\hss}\vskip\pst@dimb}% +\advance\pst@dima by\pst@dimc +\advance\pst@dimb by\pst@dimd +\advance\pst@cnth by 1 +\repeat +\endgroup\ignorespaces} +\def\multips{\begingroup\pst@getrputrot\multips@i} +\def\multips@i(#1){\@ifnextchar({\@multips@ii(#1)}{\@multips@ii(0,0)(#1)}} +\def\@multips@ii(#1)(#2)#3#4{% +\pst@getcoor{#1}\pst@tempa +\pst@@getcoor{#2}% +\pst@cnta=#3\relax +\addto@pscode{% +\pst@tempa T \the\pst@cnta\space \pslbrace +gsave \ifx\pst@rot\@empty\else\pst@rot rotate \fi }% +\hbox to\z@{% +\def\init@pscode{% +\addto@pscode{% +gsave +\pst@number\pslinewidth SLW +\pst@usecolor\pslinecolor}}% +\def\use@pscode{\addto@pscode{grestore}}% +\def\psclip##1{\pst@misplaced\psclip}% +\def\nc@object##1##2##3##4{\pst@misplaced{node connection}}% +#4}% +\addto@pscode{grestore \pst@coor T \psrbrace repeat}% +\leavevmode +\use@pscode +\endgroup +\ignorespaces} +\def\scalebox#1{% +\begingroup +\pst@getscale{#1}\pst@tempa +\pst@makebox{\@scalebox}} +\def\@scalebox{% +\leavevmode +\ifx\pst@tempa\@empty +\box\pst@hbox +\else +\hbox{% +\ht\pst@hbox=\pst@temph\ht\pst@hbox% +\dp\pst@hbox=\pst@temph\dp\pst@hbox% +\pst@dima=\pst@tempg\wd\pst@hbox% +\ifdim\pst@dima<\z@\kern-\pst@dima\fi +\pst@Verb{CP CP T \pst@tempa \tx@NET}% +\hbox to \z@{\box\pst@hbox\hss}% +\pst@Verb{% +CP CP T +1 \pst@tempg\space div 1 \pst@temph\space div scale +\tx@NET}% +\ifdim\pst@dima>\z@\kern\pst@dima\fi}% +\fi +\endgroup} +\pslongbox{Scalebox}{\scalebox} +\def\scaleboxto(#1,#2){% +\begingroup +\pssetlength\pst@dima{#1}% +\pssetlength\pst@dimb{#2}% +\pst@makebox{\@scaleboxto\@scalebox}} +\def\@scaleboxto{% +\ifdim\pst@dima=\z@\else +\pst@divide{\pst@dima}{\wd\pst@hbox}\pst@tempg +\fi +\ifdim\pst@dimb=\z@ +\let\pst@temph\pst@tempg +\else +\pst@dimc=\ht\pst@hbox\advance\pst@dimc\dp\pst@hbox +\pst@divide{\pst@dimb}{\pst@dimc}\pst@temph +\ifdim\pst@dima=\z@\let\pst@tempg\pst@temph\fi +\fi +\edef\pst@tempa{\pst@tempg\space\pst@temph\space scale }% +\ifdim\pst@dima=\z@ +\ifdim\pst@dimb=\z@ +\@pstrickserr{% +\string\scaleboxto\space dimensions cannot both be zero}\@ehpa +\def\pst@tempa{}% +\fi\fi} +\pslongbox{Scaleboxto}{\scaleboxto} +\def\tx@Rot{Rot } +\def\rotateleft{\pst@makebox{\@rotateleft\pst@hbox}} +\def\@rotateleft#1{% +\leavevmode\hbox{\hskip\ht#1\hskip\dp#1\vbox{\vskip\wd#1% +\pst@Verb{90 \tx@Rot} +\vbox to \z@{\vss\hbox to \z@{\box#1\hss}\vskip\z@}% +\pst@Verb{-90 \tx@Rot}}}} +\def\rotateright{\pst@makebox{\@rotateright\pst@hbox}} +\def\@rotateright#1{% +\hbox{\hskip\ht#1\hskip\dp#1\vbox{\vskip\wd#1% +\pst@Verb{-90 \tx@Rot} +\vbox to \z@{\hbox to \z@{\hss\box#1}\vss}% +\pst@Verb{90 \tx@Rot}}}} +\def\rotatedown{\pst@makebox{\@rotatedown\pst@hbox}} +\def\@rotatedown#1{% +\hbox{\hskip\wd#1\vbox{\vskip\ht#1\vskip\dp#1% +\pst@Verb{180 \tx@Rot}% +\vbox to \z@{\hbox to \z@{\box#1\hss}\vss}% +\pst@Verb{-180 \tx@Rot}}}} +\pslongbox{Rotateleft}{\rotateleft} +\pslongbox{Rotateright}{\rotateright} +\pslongbox{Rotatedown}{\rotatedown} +\def\pst@getref#1{% +\@ifnextchar[% +{\def\refpoint@x{.5}\def\refpoint@y{.5}\pst@@getref{#1}}% +{\let\refpoint@x\relax#1}} +\def\pst@@getref#1[#2]{% +\pst@expandafter\pst@@@getref{#2}\@empty,,\@nil#1} +\def\pst@@@getref#1#2,#3,#4\@nil{% +\ifx\@empty#3\@empty +\@nameuse{getref@#1}\@nameuse{getref@#2}% +\else +\pst@checknum{#1#2}\refpoint@x +\pst@checknum{#3}\refpoint@y +\fi} +\def\getref@t{\def\refpoint@y{1}} +\def\getref@b{\def\refpoint@y{0}} +\def\getref@B{\let\refpoint@y\relax} +\def\getref@l{\def\refpoint@x{0}} +\def\getref@r{\def\refpoint@x{1}} +\def\pst@makesmall#1{% +\ifx\refpoint@x\relax +\setbox#1=\hbox to\z@{\hss\vbox to \z@{\vss\box#1\vss}\hss}% +\else +\pst@@makesmall{#1}% +\fi} +\def\pst@@makesmall#1{% +\pst@dimh=\refpoint@x\wd#1% +\ifx\refpoint@y\relax +\pst@dimg=\dp#1% +\else +\pst@dimg=\refpoint@y\ht#1% +\advance\pst@dimg\refpoint@y\dp#1% +\fi +\setbox#1=\hbox to\z@{% +\hskip-\pst@dimh\vbox to\z@{\vss\box#1\vskip-\pst@dimg}\hss}} +\def\pst@getrputrot#1{% +\@ifnextchar(% +{\def\pst@rot{}#1}% +{\pst@getrot{\@ifnextchar({#1}{#1(0,0)}}}} +\def\pst@getrot#1#2{% +\pst@expandafter{\@ifnextchar*{\pst@@@getrot}{\pst@@getrot}}{#2}\@nil +\ifx\pst@rotlist\@empty\else +\edef\pst@rotlist{\pst@rotlist \pst@rot add }% +\fi +#1} +\def\pst@@getrot#1\@nil{% +\def\next##1@#1=##2@##3\@nil{% +\ifx\relax##2% +\pst@getangle{#1}\pst@rot +\else +\def\pst@rot{##2}% +\fi}% +\expandafter\next\pst@rottable @#1=\relax @\@nil} +\def\pst@@@getrot#1#2\@nil{% +\pst@@getrot#2\@nil +\edef\pst@rot{\pst@rotlist neg \ifx\pst@rot\@empty\else\pst@rot add \fi}}% +\def\pst@rotlist{0 } +\def\pst@rot{} +\def\pst@rottable{% +@0=% +@U=% +@L=90 % +@D=180 % +@R=-90 % +@N=\pst@rotlist neg % +@W=\pst@rotlist neg 90 add % +@S=\pst@rotlist neg 180 add % +@E=\pst@rotlist neg 90 sub } +\def\pst@rotate#1{% +\setbox#1=\hbox{% +\pst@Verb{\pst@rot \tx@Rot}% +\box#1% +\pst@Verb{\pst@rot neg \tx@Rot}}} +\def\psput@cartesian#1{% +\hbox to \z@{\kern\pst@dimg{\vbox to \z@{\vss\box#1\vskip\pst@dimh}\hss}}} +\def\psput@special#1{% +\hbox{% +\pst@Verb{{ \pst@coor } \tx@PutCoor \tx@PutBegin}% +\box#1% +\pst@Verb{\tx@PutEnd}}} +\def\tx@PutCoor{PutCoor } +\def\tx@PutBegin{PutBegin } +\def\tx@PutEnd{PutEnd } +\def\begin@psput#1{\begingroup\pst@killglue\leavevmode\pst@ifstar{#1}}% +\def\end@psput#1(#2){% +\pst@makebox{% +\if@star +\setbox\pst@hbox\hbox{\psframebox*[boxsep=false]{\unhbox\pst@hbox}}% +\fi +#1(#2)% +\endgroup +\ignorespaces}} +\def\rput{\begin@psput{\pst@getref{\pst@getrputrot{\end@psput\rput@i}}}} +\def\rput@i(#1){% +\pst@makesmall\pst@hbox +\ifx\pst@rot\@empty\else\pst@rotate\pst@hbox\fi +\psput@{#1}\pst@hbox} +\def\cput{\def\pst@par{}\pst@object{cput}} +\def\cput@i{\begingroup\pst@killglue\leavevmode\pst@getrputrot\cput@ii} +\def\cput@ii(#1){\pst@makebox{\cput@iii{}(#1)}} +\def\cput@iii#1(#2){% +\setbox\pst@hbox=\hbox{\psboxsepfalse\pscirclebox@ii{#1}}% +\let\refpoint@x\relax +\rput@i(#2)% +\endgroup +\ignorespaces} +\newdimen\pslabelsep +\def\psset@labelsep#1{\pssetlength\pslabelsep{#1}} +\psset@labelsep{5pt} +\def\pst@getrefangle#1\@nil{% +\def\next##1@#1=##2"##3@##4\@nil{% +\ifx\relax##2% +\pst@getangle{#1}\pst@refangle +\def\pst@uputref{}% +\else +\edef\pst@refangle{##2}% +\edef\pst@uputref{##3}% +\fi}% +\expandafter\next\pst@refangletable @#1=\relax"@\@nil} +\def\pst@refangletable{% +@r=0"20% +@u=90"02% +@l=180"10% +@d=-90"01% +@ur=45"22% +@ul=135"12% +@dr=-135"21% +@dl=-45"11} +\def\uput{\begin@psput{\@ifnextchar[{\uput@ii}{\uput@i}}} +\def\uput@i#1{\pssetlength\pslabelsep{#1}\uput@ii} +\def\uput@ii[#1]{% +\pst@expandafter\pst@getrefangle{#1}\@nil +\pst@getrputrot{\end@psput\uput@iii}} +\def\uput@iii(#1){% +\ifx\pst@uputref\@empty +\uput@iv\tx@UUput +\else +\ifx\pst@rot\@empty +\expandafter\uput@v\pst@uputref +\else +\uput@iv\tx@UUput +\fi +\fi +\psput@{#1}\pst@hbox} +\def\uput@iv#1{% +\edef\pst@coor{% +\pst@number\pslabelsep +\pst@number{\wd\pst@hbox}% +\pst@number{\ht\pst@hbox}% +\pst@number{\dp\pst@hbox}% +\pst@refangle\space \ifx\pst@rot\@empty\else\pst@rot\space sub \fi +\tx@Uput #1}% +\setbox\pst@hbox=\hbox to\z@{\hss\vbox to\z@{\vss\box\pst@hbox\vss}\hss}% +\setbox\pst@hbox=\psput@special\pst@hbox +\ifx\pst@rot\@empty\else\pst@rotate\pst@hbox\fi} +\def\uput@v#1#2{% +\ifnum#1>\z@\ifnum#2>\z@\pslabelsep=.707\pslabelsep\fi\fi +\setbox\pst@hbox=\vbox to\z@{% +\ifnum#2=1 \vskip\pslabelsep\else\vss\fi +\hbox to\z@{% +\ifnum#1=2 \hskip\pslabelsep\else\hss\fi +\box\pst@hbox +\ifnum#1=1 \hskip\pslabelsep\else\hss\fi}% +\ifnum#2=2 \vskip\pslabelsep\else\vss\fi}} +\def\tx@Uput{Uput } +\def\tx@UUput{UUput } +\def\pst@getlabelsep#1{% +\@ifnextchar[% +{\def\refpoint@x{.5}\def\refpoint@y{.5}\pst@@getref{#1}}% +{\pst@@getlabelsep{#1}}} +\def\pst@@getlabelsep#1#2{\pssetlength\pslabelsep{#2}\pst@getref{#1}} +\def\Rput{% +\begin@psput{\pst@getlabelsep{\pst@getrputrot{\end@psput{\Rput@i\rput@i}}}}} +\def\Rput@i{% +\pst@dimg=\dp\pst@hbox +\advance\pst@dimg\pslabelsep +\dp\pst@hbox=\pst@dimg +\pst@dimg=\ht\pst@hbox +\advance\pst@dimg\pslabelsep +\ht\pst@hbox=\pst@dimg +\setbox\pst@hbox\hbox{\kern\pslabelsep\box\pst@hbox\kern\pslabelsep}}% +\def\pspicture{\begingroup\pst@ifstar\pst@picture} +\def\pst@picture{% +\@ifnextchar[{\pst@@picture}{\pst@@picture[0]}} +\def\pst@@picture[#1]#2(#3,#4){% +\@ifnextchar({\pst@@@picture[#1](#3,#4)}% +{\pst@@@picture[#1](0,0)(#3,#4)}} +\def\pst@@@picture[#1](#2,#3)(#4,#5){% +\pssetxlength\pst@dima{#2}\pssetylength\pst@dimb{#3}% +\pssetxlength\pst@dimc{#4}\pssetylength\pst@dimd{#5}% +\def\pst@tempa{#1}% +\setbox\pst@hbox=\hbox\bgroup +\begingroup\KillGlue +\@ifundefined{@latexerr}{}{\let\unitlength\psunit}% +\edef\pic@coor{(#2,#3)(#2,#3)(#4,#5)}\ignorespaces} +\def\pic@coor{(0,0)(0,0)(10,10)} +\def\endpspicture{% +\pst@killglue +\endgroup +\egroup +\ifdim\wd\pst@hbox=\z@\else +\@pstrickserr{Extraneous space in the pspicture environment}% +{Type \space \space to procede.}% +\fi +\ht\pst@hbox=\pst@dimd +\dp\pst@hbox=-\pst@dimb +\setbox\pst@hbox=\hbox{% +\kern-\pst@dima +\ifx\pst@tempa\@empty\else +\advance\pst@dimd-\pst@dimb +\pst@dimd=\pst@tempa\pst@dimd +\advance\pst@dimd\pst@dimb +\lower\pst@dimd +\fi +\box\pst@hbox +\kern\pst@dimc}% +\if@star\setbox\pst@hbox=\hbox{\clipbox@@\z@}\fi +\leavevmode\box\pst@hbox +\endgroup} +\@namedef{pspicture*}{\pspicture*} +\@namedef{endpspicture*}{\endpspicture} +\def\tx@BeginOL{BeginOL } +\pst@dimg=40in +\edef\pst@OLunit{\pst@number\pst@dimg} +\def\tx@InitOL{InitOL } +\def\pst@initoverlay#1{\pst@Verb{\tx@InitOL /TheOL (#1) def}} +\def\pst@overlay#1{% +\edef\curr@overlay{#1}% +\pst@Verb{(#1) BOL}% +\aftergroup\pst@endoverlay} +\def\pst@endoverlay{% +\pst@Verb{(\curr@overlay) BOL}} +\def\curr@overlay{all} +\newbox\theoverlaybox +\def\overlaybox{% +\setbox\theoverlaybox=\hbox\bgroup +\begingroup +\let\psoverlay\pst@overlay +\def\overlaybox{% +\@pstrickserr{Overlays cannot be nested}\@eha}% +\def\putoverlaybox{% +\@pstrickserr{You must end the overlay box +before using \string\putoverlaybox}}% +\psoverlay{main}} +\def\endoverlaybox{\endgroup\egroup} +\def\putoverlaybox#1{% +\hbox{\pst@initoverlay{#1}\copy\theoverlaybox}} +\def\psoverlay{\@pstrickserr{\string\psoverlay\space +can only be used after \string\overlaybox}} +\ifx\pstcustomize\relax \input pstricks.con \fi +\catcode`\@=\PstAtCode\relax +\endinput +%% +%% END: pstricks.tex diff --git a/reports/desc-tex2/setup.tex b/reports/desc-tex2/setup.tex new file mode 100644 index 0000000..6996ced --- /dev/null +++ b/reports/desc-tex2/setup.tex @@ -0,0 +1,7 @@ +\hsize=10in +\vsize=7.5in +\parindent=20pt +\hoffset=-0.8in +\voffset=-0.8in +\nopagenumbers +\input drtree diff --git a/reports/desc-tex2/tree.tex b/reports/desc-tex2/tree.tex new file mode 100644 index 0000000..e080b4e --- /dev/null +++ b/reports/desc-tex2/tree.tex @@ -0,0 +1,172 @@ +% Tree -- a macro to make aligned (horizontal) trees in TeX +% +% Input is of the form +% \tree +% item +% \subtree +% \leaf{item} +% . +% . +% . +% \endsubtree +% \subtree +% . +% . +% . +% \endsubtree +% \endsubtree +% \endtree +% +% Nesting is to any level. \leaf is defined as a subtree of one item: +% \def\leaf#1{\subtree#1\endsubtree}. +% +% A structure: +% \subtree +% item_part1 +% item_part2 +% . +% . +% . +% +% will print item_part2 directly below item_part1 as a single item +% as if they were in a \box. +% +% The macro is a 3-pass macro. On the first pass it sets up a data +% structure from the \subtree ... \endsubtree definitions. On the second pass +% it recursively calculates the width of each level of the tree. On the third +% pass it sets up the boxes, glue and rules. +% +% By David Eppstein, TUGboat, vol. 6 (1985), no. 1, pp. 31--35. +% Transcribed by Margaret Kromer (peg), Feb., 1986. +% +% Permission to add to Source Forge repository granted by David Eppstein +% (eppstein@ics.uci.edu) on 14 Nov 2000. In his email, he said: +% +% Sure. The original TeX source for the article is online, at +% http://www.ics.uci.edu/~eppstein/pubs/p-ttree.tex.Z, if that helps. +% +% +% Pass 1 +% At the end of pass 1, the tree is coded as a nested collection of \hboxes +% and \vboxes. +\newbox\treebox\newcount\treeboxcnt +\def\tree{\message{Begin tree}\treeboxcnt=1\global\setbox\treebox=\boxtree} +\def\subtree{\ettext \advance\treeboxcnt by 1 \boxtree} +\def\leaf#1{\subtree#1\endsubtree} +\def\endsubtree{\ettext \egroup \advance\treeboxcnt-1{}% + \ifnum\treeboxcnt=-1 \treeerrora\fi} +\def\endtree{\endsubtree \ifnum\treeboxcnt>0 \treeerrorb\fi% + \settreesizes \typesettree \message{-- end tree}} +% Error messages for unbalanced tree +\def\treeerrora{\errhelp=\treeerrorahelp% + \errmessage{Unbalanced tree -- too many endsubtrees}} +\newhelp\treeerrorahelp{There are more subtrees closed than opened} +\def\treeerrorb{\errhelp=\treeerrorbhelp% + \errmessage{Unbalanced tree -- not enough endsubtrees}} +\newhelp\treeerrorbhelp{Not all the subtrees of the tree are closed. +If you continue, you'll get some mysterious secondary errors.} +% Set up \vbox containing root of tree +\newif\iftreetext\treetextfalse % Whether still aligning text +\def\boxtree{\hbox\bgroup % Start outer box of tree or subtree + \baselineskip 2.5ex % Narrow line spacing slightly + \tabskip 0pt % No spurious glue in alignment + \vbox\bgroup % Start inner text \vbox + \treetexttrue % Remember for \ettext + \let\par\crcr \obeylines % New line breaks without explicit \cr + \halign\bgroup##\hfil\cr} % Start alignment with simple template +\def\ettext{\iftreetext % Are we still in inner text \vbox? + \crcr\egroup \egroup \fi} % Yes, end alignment and box +% Pass 2 +% Recursively calculate widths of tree with \setsizes; keep results in +% \treesizes; \treewidth contains total width calculated so far. \treeworkbox +% is workspace containing subtree being sized. +\newbox\treeworkbox +\def\cons#1#2{\edef#2{\xmark #1#2}} % Add something to start of list +\def\car#1{\expandafter\docar#1\docar} % Take first element of list +\def\docar\xmark#1\xmark#2\docar{#1} % ..by ignoring rest in expansion +\def\cdr#1{\expandafter\docdr#1\docdr#1}% Similarly, drop first element +\def\docdr\xmark#1\xmark#2\docdr#3{\def#3{\xmark #2}} +\def\xmark{\noexpand\xmark} % List separator expands to self +\def\nil{\xmark} % Empty list is just separator +\def\settreesizes{\setbox\treeworkbox=\copy\treebox% + \global\let\treesizes\nil \setsizes} +\newdimen\treewidth % Width of this part of the tree +\def\setsizes{\setbox\treeworkbox=\hbox\bgroup% Get a horiz list as a workspace + \unhbox\treeworkbox\unskip % Take tree, unpack it into horiz list + \inittreewidth % Get old width at this level + \sizesubtrees % Recurse through all subtrees + \sizelevel % Now set width from remaining \vbox + \egroup} % All done, finish our \hbox +\def\inittreewidth{\ifx\treesizes\nil % If this is the first at this level + \treewidth=0pt % ..then we have no previous max width + \else \treewidth=\car\treesizes % Otherwise take old max level width + \global\cdr\treesizes % ..and advance level width storage + \fi} % ..in preparation for next level. +\def\sizesubtrees{\loop % For each box in horiz list (subtree) + \setbox\treeworkbox=\lastbox \unskip % ..pull it off list and flush glue + \ifhbox\treeworkbox \setsizes % If hbox, it's a subtree - recurse + \repeat} % ..and loop; end loop on tree text +\def\sizelevel{% + \ifdim\treewidth<\wd\treeworkbox % If greater than previous maximum + \treewidth=\wd\treeworkbox \fi % Then set max to new high + \global\cons{\the\treewidth}\treesizes}% In either case, put back on list +% Pass 3 +% Recursively typeset tree with \maketree by adding an \hbox containing +% a subtree (in \treebox) to the horizontal list. +\newdimen\treeheight % Height of this part of the tree +\newif\ifleaf % Tree has no subtrees (is a leaf) +\newif\ifbotsub % Bottom subtree of parent +\newif\iftopsub % Top subtree of parent +\def\typesettree{\medskip\maketree\medskip} % Make whole tree +\def\maketree{\hbox{\treewidth=\car\treesizes % Get width at this level + \cdr\treesizes % Set up width list for recursion + \makesubtreebox\unskip % Set \treebox to text, make subtrees + \ifleaf \makeleaf % No subtrees, add glue + \else \makeparent \fi}} % Have subtrees, stick them at right +{\catcode`@=11 % Be able to use \voidb@x +\gdef\makesubtreebox{\unhbox\treebox % Open up tree or subtree + \unskip\global\setbox\treebox\lastbox % Pick up very last box + \ifvbox\treebox % If we're already at the \vbox + \global\leaftrue \let\next\relax % ..then this is a leaf + \else \botsubtrue % Otherwise, we have subtrees + \setbox\treeworkbox\box\voidb@x % Init stack of processed subs + \botsubtrue \let\next\makesubtree % ..and call \maketree on them + \fi \next}} % Finish up for whichever it was +\def\makesubtree{\setbox1\maketree % Call \maketree on this subtree + \unskip\global\setbox\treebox\lastbox % Pick up box before it + \treeheight=\ht1 % Get height of subtree we made + \advance\treeheight 2ex % Add some room around the edges + \ifhbox\treebox \topsubfalse % If picked up box is a \vbox, + \else \topsubtrue \fi % ..this is the top, otherwise not + \addsubtreebox % Stack subtree with the rest + \iftopsub \global\leaffalse % If top, remember not a leaf + \let\next\relax \else % ..(after recursion), set return + \botsubfalse \let\next\makesubtree % Otherwise, we have more subtrees + \fi \next} % Do tail recursion or return +\def\addsubtreebox{\setbox\treeworkbox=\vbox{\subtreebox\unvbox\treeworkbox}} +\def\subtreebox{\hbox\bgroup % Start \hbox of tree and lines + \vbox to \treeheight\bgroup % Start \vbox for vertical rules + \ifbotsub \iftopsub \vfil % If both bottom and top subtree + \hrule width 0.4pt % ..vertical rule is just a dot + \else \treehalfrule \fi \vfil % Bottom gets half-height rule + \else \iftopsub \vfil \treehalfrule % Top gets half-height the other way + \else \hrule width 0.4pt height \treeheight \fi\fi % Middle, full height + \egroup % Finish vertical rule \vbox + \treectrbox{\hrule width 1em}\hskip 0.2em\treectrbox{\box1}\egroup} +\def\treectrbox#1{\vbox to \treeheight{\vfil #1\vfil}} +\def\treehalfrule{\dimen\treeworkbox=\treeheight % Get total height + \divide\dimen\treeworkbox 2% + \advance\dimen\treeworkbox 0.2pt % Divide by two, add half horiz height + \hrule width 0.4pt height \dimen\treeworkbox}% Make a vertical rule that high +\def\makeleaf{\box\treebox} % Add leaf box to horiz list +\def\makeparent{\ifdim\ht\treebox>% + \ht\treeworkbox % If text is higher than subtrees + \treeheight=\ht\treebox % ..use that height + \else \treeheight=\ht\treeworkbox \fi % Otherwise use height of subtrees + \advance\treewidth-\wd\treebox % Take remainder of level width + \advance\treewidth 1em % ..after accounting for text and glue + \treectrbox{\box\treebox}\hskip 0.2em % Add text, space before connection +\treectrbox{\hrule width \treewidth}% + \treectrbox{\box\treeworkbox}} % Add \hrule, subs +% No idea what \spouse is supposed to do... wasn't included +\def\spouse{\bf} diff --git a/reports/desc-tree.ll b/reports/desc-tree.ll new file mode 100644 index 0000000..67722a9 --- /dev/null +++ b/reports/desc-tree.ll @@ -0,0 +1,259 @@ +/* + * @progname desc-tree.ll + * @version 8 + * @author Dick Knowles, knowles@inmet.camb.inmet.com + * @category + * @output Text + * @description + * + This report prints a descendant tree for an individual. A + line is printed for every spouse and child including name, + database key number, birth, marriage, and death information. + The user can set the number of generations or they can all be + done (up to a maximum of 20). The user can also, optionally, + include step children and family database numbers. There are + two slightly different output styles, tree and numbered. Here + are examples of each: + + + Dick Knowles, knowles@inmet.camb.inmet.com + 18 Feb 1993 + 18 Mar 1993 ver. 2 Add date to heading + 19 Dec 1993 ver. 3 (partial) Changes for Cliff Manis + 30 Dec 1993 ver. 4 Updates suggested by Cliff Manis + 07 Mar 1994 ver. 5 Make 0 generations max at 20. + Add message when stopping for gen count. + 10 Mar 1994 ver. 6 Add max line count to limit output. + 10 Aug 1994 ver. 7 Bugfix (by Jim Eggert). + 31 Aug 1997 ver. 8 Added old bugfix for incorrect printing of step + children. (Source of fix unknown at this time.) + +----------------- numbered: + +Tree of descendants for Thomas Leo SARJEANT (19) + +Dated: 30 Dec 1993 + +1- Thomas Leo SARJEANT (19) b. 27 Mar 1916 d. 1 Oct 1978 +s- Rita LACROIX (59) b. 28 Aug 1918 m. 1936 d. 28 Sep 1974 + 2- Thomas Leo SARJEANT (60) b. 26 Feb 1936 + s- Joan MERRIAM (69) m. 13 May 1961 + 3- Thomas John SARJEANT (70) + 3- Marjorie SARJEANT (71) + 3- James SARJEANT (72) + 2- John Bernard SARJEANT (61) b. 8 Nov 1939 + s- Bettye MCPHERSON (504) b. 18 Apr 1932 m. 2 Sep 1973 + 2- Beverly Ann SARJEANT (62) b. 28 Jul 1942 + s- Steven JOHNSON (73) m. 10 Nov 1960 + s- Joseph COSTA (74) b. 20 Apr 1926 m. 8 Oct 1963 + 3- Michael Angelo COSTA (75) b. 30 Jun 1965 + s- Elaine CARTER (319) b. 4 Feb 1966 m. 26 May 1990 +s- Charlotte Lois BENJAMIN (20) b. 29 Nov 1923 m. 12 Oct 1949 + 2- Kathleen SARJEANT (14) b. 23 Jan 1950 + s- Richard James KNOWLES (3) b. 20 Nov 1949 m. 14 Aug 1971 + 3- Jennifer Danielle KNOWLES (15) b. 28 Oct 1974 + 3- Kevin Scott KNOWLES (16) b. 14 May 1976 + 3- James Michael KNOWLES (17) b. 13 Oct 1979 + 3- Brenda Marie KNOWLES (18) b. 7 Oct 1981 + + +----------------- tree (with stepchildren and family numbers): + +Tree of descendants for Thomas Leo SARJEANT (19) + +Dated: 30 Dec 1993 + +-Thomas Leo SARJEANT (19) b. 27 Mar 1916 d. 1 Oct 1978 + s-Rita LACROIX (59) b. 28 Aug 1918 m. 1936 (17) d. 28 Sep 1974 + |-Thomas Leo SARJEANT (60) b. 26 Feb 1936 + | s-Joan MERRIAM (69) m. 13 May 1961 (20) + | |-(ST)Deborah CONNORS (295) + | |-(ST)Diane CONNORS (296) + | | s-John LIPSEY (482) b. m. (160) + | | |-John LIPSEY (479) b. 27 Oct 1979 d. 8 Mar 1993 + | |-(ST)Gayle CONNORS (297) + | | |-Jennifer (483) b. + | |-Thomas John SARJEANT (70) + | |-Marjorie SARJEANT (71) + | |-James SARJEANT (72) + |-John Bernard SARJEANT (61) b. 8 Nov 1939 + | s-Bettye MCPHERSON (504) b. 18 Apr 1932 m. 2 Sep 1973 (168) + | |-(ST)Tammarra Victoria WALL (505) b. 7 Jul 1963 + |-Beverly Ann SARJEANT (62) b. 28 Jul 1942 + | s-Steven JOHNSON (73) m. 10 Nov 1960 (21) + | s-Joseph COSTA (74) b. 20 Apr 1926 m. 8 Oct 1963 (22) + | |-Michael Angelo COSTA (75) b. 30 Jun 1965 + | | s-Elaine CARTER (319) b. 4 Feb 1966 m. 26 May 1990 (89) + s-Charlotte Lois BENJAMIN (20) b. 29 Nov 1923 m. 12 Oct 1949 (3) + |-Kathleen SARJEANT (14) b. 23 Jan 1950 + | s-Richard James KNOWLES (3) b. 20 Nov 1949 m. 14 Aug 1971 (2) + | |-Jennifer Danielle KNOWLES (15) b. 28 Oct 1974 + | |-Kevin Scott KNOWLES (16) b. 14 May 1976 + | |-James Michael KNOWLES (17) b. 13 Oct 1979 + | |-Brenda Marie KNOWLES (18) b. 7 Oct 1981 + +*/ + +global(MAXGENS) +global(MAXLINES) +global(linecount) +global(gens) +global(style) +global(dofami) +global(dostep) +global(mainpre) +global(spousepre) +global(indentpre) + +proc main () { + set(MAXGENS,20) /* make "all" gens max at 20 */ + set(MAXLINES,500) /* set max report lines */ + set(linecount,0) /* initialize linecount */ + set(nm," ") + getindi(nm) /* get individual */ + getintmsg (gens, + concat("How many generations (0 for all, max ", + concat(d(MAXGENS),")?"))) + if (eq(gens,0)) {set(gens,MAXGENS)} /* if 0, set max */ + getintmsg (style, + "Choose style: 0 for tree, 1 for numbered.") + getintmsg (dofami, + "Include family indices? 0 for no, 1 for yes.") + getintmsg (dostep, + "Show stepchildren? 0 for no, 1 for yes.") + + dayformat(0) + monthformat(4) + dateformat(0) + + /* Headers */ + "Tree of descendants for " name(nm) " (" call key_no_char(nm) ")\n\n" + "Dated: " stddate(gettoday()) "\n\n" + + if (eq(style,0)) { /* if tree */ + set(mainpre, "-") + set(spousepre, " s-") + set(indentpre, " |") + } else { /* if numbered */ + set(mainpre, "- ") + set(spousepre, "s- ") + set(indentpre, " ") + } + call dofam(nm,"",1,0) /* start with first person */ + +} + + +/* startfam: + If we haven't reached the maximum or specified generation count, + call dofam for each child in this family. + Otherwise, print a message line if there are further descendants + at this point. +*/ + +proc startfam (fam,prefix,level,isstep) { + if (le(level,gens)) { /* if not at last generation */ + children (fam,child,num) { /* for each child */ + call dofam (child, /* call dofam */ + concat(prefix, indentpre), + add(level,1), + isstep) + } + } else { /* don't do this generation */ + if (gt(nchildren(fam),0)) { /* but if there are children, */ + /* issue message */ + prefix " [[Reached gen count or max. Further descendants here" + if (eq(isstep,1)) { + " (stepchildren)" + } + ".]]\n" + incr(linecount) + } + } +} + +/* dofam: + Write out a person and check for spouses and children. + Each spouse is written, then this routine is called + recursively for each child. An incremented level is passed along + in case the user specified a limited number of generations +*/ + +proc dofam (nm,prefix,level,isstep) { + if (eq(style,0)) { + set(pre,mainpre) + } else { + set(pre,concat(d(level),mainpre)) + } + if (eq(isstep,1)) { + call printpers(nm, + concat(prefix,concat(pre,"(ST)")),0,0) /* print this person */ + } else { + call printpers(nm,concat(prefix,pre),0,0) /* print this person */ + } + if (and(ge(linecount,MAXLINES),gt(nfamilies(nm),0))) { + prefix " [[Reached line count max." + " May be further descendants here." + "]]\n" + } else { + families(nm, fam, spouse, num) { /* do for each family */ + if (ne(spouse,null)) { /* if there is a spouse */ + call printpers( /* print spouse */ + spouse,concat(prefix,spousepre),1,fam) + if (and(ge(linecount,MAXLINES),gt(nchildren(fam),0))) { + prefix " [[Reached line count max." + " May be further descendants here." + "]]\n" + } else { + families (spouse, spsfam, ospouse, num2) { + /* for each of the spouse families*/ + if (eq(fam,spsfam)) {/* this is main family */ + call startfam (spsfam,prefix,level,0) + } else { /* this is step-family*/ + if (eq (dostep,1)) { /* if we're doing stepfams */ + call startfam (spsfam,prefix,level,1) + } /*end if dostep */ + } /*end else not stepfam*/ + } /*end spouse's families*/ + } /* end spouse not ge MAXLINES */ + } else { /* there is no spouse */ + call startfam (fam,prefix,level,0) + } /*end else no spouse*/ + } /*end 'families'*/ + } /* end MAXLINES else */ +} /*end 'proc dofam'*/ + + +/* printpers: + Write output line for one person. + Include birth and death dates if known. + For a spouse, include marriage date if known. +*/ +proc printpers (nm, prefix, spouse, fam) { + prefix name(nm) " (" call key_no_char(nm) ")" + if(e, birth(nm)) { + "\t b. " stddate(birth(nm)) + } + if(e, marriage(fam)) { + if(eq(dofami,1)) { + "\t m. " stddate(e) " (" call key_no_char(fam) ")" + } else { + "\t m. " stddate(e) + } + } + if(e, death(nm)) { + "\t d. " stddate(death(nm)) + } + "\n" + incr(linecount) +} /* end proc printpers */ + +/* + key_no_char: + Return string key of individual or family, without + leading 'I' or 'F'. +*/ +proc key_no_char (nm) { + set(k, key(nm)) + substring(k,2,strlen(k)) +} /* end proc key_no_char */ diff --git a/reports/desc_ged.ll b/reports/desc_ged.ll new file mode 100644 index 0000000..c91171c --- /dev/null +++ b/reports/desc_ged.ll @@ -0,0 +1,143 @@ +/* + * @progname desc_ged.ll + * @version 1 + * @author Nicklaus + * @category + * @output Text + * @description + Generate gedcom of descendents. + For specified set of individuals for specified # of generations + down from the top individuals. (e.g. name all your great-grandparents + for all of your close cousins in one gedcom file) + + Author: Dennis Nicklaus nicklaus@fnal.gov June 1997 +*/ +/* MODIFY this to put in your name and address! */ +proc print_header() +{ + "0 HEAD\n" + "1 SOUR LIFELINES\n" + "2 VERS 3.0.2\n" + "2 NAME LifeLines for UNIX\n" + "1 DATE " stddate(gettoday()) nl() + "0 @SM1@ SUBM\n" + "1 NAME your name here\n" + "1 ADDR your street here\n" + "2 CONT your town\n" + "2 CONT your email\n" +} + +proc main () +{ + getindimsg(person,"Enter person to output GEDCOM descendants of") + indiset(thisgen) + indiset(allgen) + while (person){ + addtoset(thisgen, person, 0) + addtoset(allgen, person, 0) + + set(person,0) + getindimsg(person,"Enter next person to output GEDCOM descendants of") + } + + set(allgen, union(allgen,spouseset(allgen))) + getintmsg (ngen, + "Enter number of generations") + set(gen,1) + while(and(lengthset(thisgen),le(gen,ngen))) { + set (thisgensize,lengthset(thisgen)) + print ("generation ",d(gen)," ",d(thisgensize)) + if (gt(thisgensize,1)) { + print(" people\n") + } else { + print(" person\n") + } + set(gen,add(gen,1)) + + set(thisgen,childset(thisgen)) + set(allgen,union(allgen,thisgen)) + set(allgen,union(allgen,spouseset(thisgen))) + } + call print_header() + gengedcom(allgen) + + call sour_init() + call sour_addset(allgen) + call sour_ged() + + "0 TRLR\n" + +} +global(sour_list) +global(sour_table) + +proc sour_init() +{ + table(sour_table) + list(sour_list) +} +/* sour_addind() adds the sources referenced for this individual */ + +proc sour_addind(i) +{ + traverse(root(i), m, l) { + if (nestr("SOUR", tag(m))) { continue() } + set(v, value(m)) + if (eqstr("", v)) { continue() } + if(reference(v)) { + if (ne(0, lookup(sour_table, v))) { continue() } + set(v, save(v)) + insert(sour_table, v, 1) + enqueue(sour_list, v) + } + } +} + +proc sour_addset(s) +{ + forindiset (s, i, a, n) { + call sour_addind(i) + families(i, f, sp, m) { + call sour_addind(f) + } + } +} + +/* sour_ged() outputs the current source list in GEDCOM format */ + +proc sour_ged() +{ + table(other_table) + list(other_list) + + forlist(sour_list, k, n) { + set(r, dereference(k)) + traverse(r, s, l) { + d(l) + if (xref(s)) { " " xref(s) } + " " tag(s) + if (v, value(s)) { + " " v + if(reference(v)) { + if (ne(0, lookup(other_table, v))) { continue() } + if (ne(0, lookup(sour_table, v))) { continue() } + set(v, save(v)) + insert(other_table, v, 1) + enqueue(other_list, v) + } + } + "\n" + } + } + forlist(other_list, k, n) { + set(r, dereference(k)) + traverse(r, s, l) { + d(l) + if (xref(s)) { " " xref(s) } + " " tag(s) + if (v, value(s)) { " " v } + "\n" + } + } +} + diff --git a/reports/desc_html.ll b/reports/desc_html.ll new file mode 100644 index 0000000..ac4dbb9 --- /dev/null +++ b/reports/desc_html.ll @@ -0,0 +1,159 @@ +/* + * @progname desc_html.ll + * @version 1.4 + * @author Dick Knowles, Scott McGee, anon + * @category + * @output HTML + * @description + +This program is designed to be used in a cgi based genweb site to produce +a descendant chart for a specified individual. It is based on the desc-tree +program by Dick Knowles as modified by Scott McGee. A line is printed for +every spouse and child including name, database key number, birth, marriage, +and death information. + +@(#)desc_html.ll 1.4 10/4/95 +*/ + +include("cgi_html.li") + +global(MAXGENS) +global(MAXLINES) +global(linecount) +global(gens) +global(mainpre) +global(spousepre) +global(indentpre) + +proc main () { + call set_cgi_html_globals() + + set(MAXGENS,20) /* make "all" gens max at 20 */ + set(MAXLINES,500) /* set max report lines */ + set(linecount,0) /* initialize linecount */ + set(nm," ") + getindi(nm) /* get individual */ + + set(gens, 3) + + dayformat(0) + monthformat(4) + dateformat(0) + + set(mainpre, "-") + set(spousepre, " s-") + set(indentpre, " |") + + call do_chart_head(nm, "Descendant") + "
\n"
+  call dofam(nm,"",1,0)               /* start with first person */
+  "
\n" + call do_tail(nm) +} + + +/* startfam: + If we haven't reached the maximum or specified generation count, + call dofam for each child in this family. + Otherwise, print a message line if there are further descendants + at this point. +*/ +proc startfam (fam,prefix,level,isstep) { + if (le(level,gens)) { /* if not at last generation */ + children (fam,child,num) { /* for each child */ + call dofam (child, /* call dofam */ + concat(prefix, indentpre), + add(level,1), + isstep) + } + } else { /* don't do this generation */ + if (gt(nchildren(fam),0)) { /* but if there are children, */ + /* issue message */ + prefix " [[Further descendants here" + if (eq(isstep,1)) { + " (stepchildren)" + } + ".]]\n" + incr(linecount) + } + } +} + +/* dofam: + Write out a person and check for spouses and children. + Each spouse is written, then this routine is called + recursively for each child. An incremented level is passed along + in case the user specified a limited number of generations +*/ + +proc dofam (nm,prefix,level,isstep) { + set(pre,mainpre) + call printpers(nm,concat(prefix,pre),0,0) /* print this person */ + if (and(ge(linecount,MAXLINES),gt(nfamilies(nm),0))) { + prefix " [[Reached line count max." + " May be further descendants here." + "]]\n" + } else { + families(nm, fam, spouse, num) { /* do for each family */ + if (ne(spouse,null)) { /* if there is a spouse */ + /* print spouse */ + call printpers(spouse,concat(prefix,spousepre),1,fam) + if (and(ge(linecount,MAXLINES),gt(nchildren(fam),0))) { + prefix " [[Reached line count max." + " May be further descendants here." + "]]\n" + } else { + families (spouse, spsfam, ospouse, num2) { + /* for each of the spouse families*/ + if(eq(fam,spsfam)){ /* only non-step families */ + call startfam (spsfam,prefix,level,0) + } + } /*end spouse's families*/ + } /* end spouse not ge MAXLINES */ + } else { /* there is no spouse */ + call startfam (fam,prefix,level,0) + } /*end else no spouse*/ + } /*end 'families'*/ + } /* end MAXLINES else */ +} /*end 'proc dofam'*/ + + +/* printpers: + Write output line for one person. + Include birth and death dates if known. + For a spouse, include marriage date if known. +*/ +proc printpers (nm, prefix, spouse, fam) { + prefix + if(nfamilies(nm)){ + set(hasChildren, 0) + families(nm, f, s, n){ + if(nchildren(f)){ + set(hasChildren, 1) + } + } + } + href(nm, "Descendant") + if(e, birth(nm)) { + "\t b. " stddate(birth(nm)) + } + if(e, marriage(fam)) { + "\t m. " stddate(e) + } + if(e, death(nm)) { + "\t d. " stddate(death(nm)) + } + "\n" + incr(linecount) +} /* end proc printpers */ + + +/* + key_no_char: + Return string key of individual or family, without + leading 'I' or 'F'. +*/ +proc key_no_char (nm) { + set(k, key(nm)) + substring(k,2,strlen(k)) +} /* end proc key_no_char */ diff --git a/reports/descged.ll b/reports/descged.ll new file mode 100644 index 0000000..3356ccc --- /dev/null +++ b/reports/descged.ll @@ -0,0 +1,62 @@ +/* + * @progname descged.ll + * @version 2000-07 + * @author Tom Wetmore, Cliff Manis, and Chris Eagle + * @category + * @output Text + * @description + * + * The output of this report is a GEDCOM file of the following: + * all descendents of a named individual + * all spouses of the named indivdual + * spouses of all descendents of the named individual + * (i.e. this program looks only down the tree, never up) + * + * This form of the program is probably the most useful for extracting + * data when a person requests data about someone from your database. + * + * July 2000 + * + * modified by Chris Eagle from genancc1 by: + * + * by Tom Wetmore, ttw@cbnewsl.att.com + * (as sent to Cliff Manis in August 1992) + * + * This report works only with the LifeLines Genealogy program + * + * [I have only given it a name and added lots of comments] /cliff + * + * August 1992 + * + */ + +proc main () +{ + indiset(set1) /*declare an indi set*/ + indiset(set2) /*declare another indi set*/ + + getindi(indi) /*ask user to identify person*/ + addtoset(set1, indi, n) /*add that person to set1*/ + + set(set2, spouseset(set1)) /* get individuals spouse(s) */ + set(set1, union(set1, set2)) /* combine set1 and set2 */ + + indiset(set3) /* set used in determining when to stop */ + set(set3, set1) + + set(set2, childset(set1)) /* find first generation of children */ + set(set1, union(set1, set2)) /* combine set1 and set2 */ + + while (lengthset(difference(set1, set3))) { + set(set2, spouseset(set1)) /* add the childrens spouses */ + set(set1, union(set1, set2)) /* combine set1 and set2 */ + + set(set3, set1) /* remember the previous state */ + set(set2, childset(set1)) /* find more children */ + set(set1, union(set1, set2)) /* combine set1 and set2 */ + } + + gengedcom(set1) /*write final set as GEDCOM file*/ +} + +/* end of report */ diff --git a/reports/divorce.li b/reports/divorce.li new file mode 100644 index 0000000..8bfd8d8 --- /dev/null +++ b/reports/divorce.li @@ -0,0 +1,23 @@ +/* + * @progname divorce.li + * @version 1.0 of 2004-07-03 + * @author Vincent Broman (vpbroman@mstar2.net) + * @category + * @output gedcom event function values + * @description + * + * Utility function supporting divorce/DIVO events in GeDCom data + * divorce( fam) -> event, + * + * I put an equivalent function in my C source, but this can be used everywhere. + */ + +func divorce( fam) { + fornodes( root( fam), childnode) { + if( eqstr( tag( childnode), "DIVO")) { + return( childnode) + } + } + return( 0) +} + diff --git a/reports/drep2.ll b/reports/drep2.ll new file mode 100644 index 0000000..1a918a1 --- /dev/null +++ b/reports/drep2.ll @@ -0,0 +1,231 @@ +/* + * @progname drep2.ll + * @version 2.1 + * @author Robert Simms + * @category + * @output Text + * @description + + Produces an indented report on an individual's families and all + descendant families. Details on individuals include NOTE lines, once. + Line wrapping is done with indention maintained. + + At the beginning of main() is provided the means to easily change + page width, tab size, and left margin. + + Written by: Robert Simms, 16 Feb 2000 + rsimms@math.clemson.edu, http://www.math.clemson.edu/~rsimms + This is based on indiv3.ll, also by Robert Simms. + + Version 2.1: 30 May 2001, fixed the concatenation of multiple notes + so that two spaces are inserted before every note after + the first. Thanks to M.W. Poirier for pointing this out. + ______________ + TODO: Clean up trailing spaces in output. + +*/ + +global(page_width) +global(tab_size) +global(left_margin) +global(gen) +global(genlim) +global(iparent) +global(ichild) + +proc main() { + set(page_width, 72) + set(tab_size, 3) + set(left_margin, 1) + + getindi(person) + getintmsg (genlim, "Maximum number of generations") + report(person, genlim) + + /* NOTE: this footer may need modifying if the page_width is changed */ + concat(" ______________________________ This report was produced on ", + stddate(gettoday()), " _______", nl()) +} + +func report(person, genlim) { + list(toPrint) + list(toScan) + set(gen, 1) + set(iparent, 1) + set(ichild, 2) + enqueue(toPrint, person) + while( and( le(gen,genlim), gt(length(toPrint), 0) ) ) { + ">> Generation " d(gen) nl() + while(i1, dequeue(toPrint)) { + nl() doFams(i1) nl() + enqueue(toScan, i1) + } + while(i1, dequeue(toScan)) { + families(i1, fp, sp, fn) { + children(fp, i_x, n_x) { + if(gt(nfamilies(i_x), 0)) { + enqueue(toPrint, i_x) + } + } + } + } + set(gen, add(gen, 1)) + if(gt(length(toPrint), 0)) { + nl() + } + } +} + +func doFams(indi) { + set(x, 0) + set(skip, left_margin) + set(x, outfam(indi, skip, x)) +} + +func outfam(indi, skip, x) { + set(x, outpers(indi, skip, x, 1, 1)) + if(gt(nfamilies(indi), 0)) { + set(skip, add(skip, tab_size)) + families(indi, fam, sp, num) { + set(x, 0) + set(x, outline(concat("Family #", d(num)), skip, x)) + if(date(marriage(fam))) { + set(s, concat(", ", date(marriage(fam)))) + } + if(nestr("", place(marriage(fam)))) { + set(s, concat(s, ", ", place(marriage(fam)))) + } + set(x, outline(s, skip, x)) + set(x, 0) + set(skip, add(skip, tab_size)) + set(x, outpers(sp, skip, x, 1, 0)) + if(gt(nchildren(fam), 0)) { + set(x, outline("Children", skip, x)) + set(x, 0) + set(skip, add(skip, tab_size)) + children(fam, child, no) { + set(x, outpers(child, skip, x, or(not(nfamilies(child)),eq(gen,genlim)), 0 )) + } + set(skip, sub(skip, tab_size)) + } + set(skip, sub(skip, tab_size)) + } + } + return(x) +} + +func outpers(indi, skip, x, note_flag, parent) { + if(indi) { + print(name(indi), nl()) + set(x, 0) + if(note_flag) { + if(parent) { + set(s, concat(d(iparent), ". ", name(indi))) + set(iparent, add(iparent, 1)) + } else { + set(s, name(indi)) + } + } else { + if(and(lt(gen,genlim), gt(nfamilies(indi), 0))) { + set(s, concat(name(indi), " <",d(ichild),">" )) + set(ichild, add(ichild, 1)) + } else { + set(s, name(indi)) + } + } + set(x, outline(s, skip, x)) + set(skip, add(skip, tab_size)) + set(s, "") + if(birth(indi)) { + set(s, concat(", b. ", long(birth(indi)))) + } + if(death(indi)) { + set(s, concat(s, ", d. ", long(death(indi)))) + } + if(burial(indi)) { + set(s, concat(s, ", buried at ", place(burial(indi)))) + } + set(s, concat(s, ". ")) + set(x, outline(s, skip, x)) + if(note_flag) { + set(s, "") + set(note_separator, "") + fornotes(inode(indi), note) { + set(s, concat(s, note_separator, note)) + set(note_separator, " ") + } + set(x, outtxt(s, skip, x)) + set(skip, sub(skip, tab_size)) + } + } else { + print("_____ _____", nl()) + set(x, 0) + set(x, outline("_____ _____", skip, x)) + } + set(x, 0) + return(x) +} + +func outtxt(txt, skip, x) { + set(cr, index(txt, nl(), 1)) + while(ne(cr, 0)) { + set(txt, save(txt)) + set(txt2, concat(substring(txt, 1, sub(cr, 1)), " ")) + set(x, outline(txt2, skip, x)) + set(txt, substring(txt, add(cr, 1), strlen(txt))) + set(cr, index(txt, nl(), 1)) + } + if(gt(strlen(txt), 0)) { + set(x, outline(txt, skip, x)) + } + return(x) +} + +func outline(text, skip, x) { + if(eq(x, 0)) { + col(add(skip, 1)) + set(x, skip) + } + set(max, sub(page_width, x)) + if(gt(strlen(text), max)) { + set(space, breakpoint(text, max)) + if(eq(space, 0)) { + if(eq(x, skip)) { + set(text, strsave(text)) + substring(text, 1, sub(max, 1)) "-" + set(x, 0) + set(text, substring(text, max, strlen(text))) + set(x, outline(text, skip, x)) + } else { + set(x, 0) + set(x, outline(text, skip, x)) + } + } else { /* space gt 0 */ + set(text, strsave(text)) + substring(text, 1, sub(space, 1)) + set(x, 0) + set(text, strsave(substring(text, add(space, 1), strlen(text)))) + while(eqstr(" ", substring(text, 1, 1))) { /* strip leading spaces */ + set(text, strsave(substring(text, 2, strlen(text)))) + } + set(x, outline(text, skip, x)) + } + } else { + text + set(x, add(x, strlen(text))) + } + return(x) +} + +func breakpoint(text, max) { + set(space, 0) + set(occ, 1) + set(next, index(text, " ", occ)) + incr(occ) + while ( and(le(next, add(max, 1)), ne (next, 0))) { + set(space, next) + set(next, index(text, " ", occ)) + incr(occ) + } + return(space) +} diff --git a/reports/dump-ances.ll b/reports/dump-ances.ll new file mode 100644 index 0000000..30ededd --- /dev/null +++ b/reports/dump-ances.ll @@ -0,0 +1,152 @@ +/* + * @progname dump-ances.ll + * @version 1992-11 + * @author Stephen Woodbridge + * @category + * @output Text, 80 cols + * @description + * + * Program walks thru one's ancestors and dumps information + * about each family. It prunes the tree so an individual is + * only output once. It is a simple program that is easy to + * make changes to, if you want more or less info printed. I + * have included three date routines get_dates(), get_sdates(), + * and get_ldates for variations in the amount of event info that + * gets output to the file. The program lists all children of the + * families as it walks the tree. The ">>>>" marker on a child + * signifies the line of descent. + * + * Writen by Stephen Woodbridge, Nov 1992 + */ +global(UNKNOWN) +global(DONE) +global(ILIST) +global(NLIST) +global(RVAL) + +proc main() +{ + table(DONE) + list(ILIST) + list(NLIST) + list(RVAL) + set(UNKNOWN, "____?____") + + getindi(me) + getintmsg(max, " Maximum Depth :") + enqueue(ILIST, me) + enqueue(NLIST, 1) + set(i, 1) + while (me, dequeue(ILIST)) + { + set(depth, dequeue(NLIST)) + if (not(lookup(DONE, key(me)))) + { + call do_me(me, depth, max) + } + } +} + +proc do_me(me, depth, max) +{ + call out_me(me, depth) + insert(DONE, save(key(me)), 1) + if (le(add(depth, 1), max)) + { + if (dad, father(me)) + { + enqueue(ILIST, dad) + enqueue(NLIST, add(depth, 1)) + } + if (mom, mother(me)) + { + enqueue(ILIST, mom) + enqueue(NLIST, add(depth, 1)) + } + } +} + +proc out_me(me, depth) +{ + "-------------------- " d(depth) " --------------------\n" + if (dad, father(me)) + { + call get_sdates(dad) + call print_name(dad, 1) + pop(RVAL) col(45) pop(RVAL) "\n" + } + else { UNKNOWN "\n"} + + if (mom, mother(me)) + { + call get_sdates(mom) + call print_name(mom, 1) + pop(RVAL) col(45) pop(RVAL) "\n" + } + else { UNKNOWN "\n"} + + if (fam, parents(me)) + { + " m. " long(marriage(fam)) "\n" + + children( fam, child, nchild) + { + if (eq(me, child)) { ">>>> " } else { " " } + call get_sdates(child) + call print_name(child, 1) + pop(RVAL) col(50) pop(RVAL) "\n" + } + } + else + { + " m.\n" + ">>>> " + call get_sdates(me) + call print_name(me, 1) + pop(RVAL) col(50) pop(RVAL) "\n" + } +} + +proc print_name (me, last) +{ + call get_title(me) + push(RVAL, save(concat(fullname(me, 1, not(last), 45), pop(RVAL)))) +} + +proc get_title (me) +{ + fornodes(inode(me), node) + { + if (not(strcmp("TITL", tag(node)))) { set(n, node) } + } + if (n) { push(RVAL, save(concat(" ", value(n)))) } + else { push(RVAL, "") } +} + +proc get_sdates (me) +{ + if (e, birth(me)) { set(b, save(concat("( ", short(e)))) } + else { set(b, "( ") } + if (e, death(me)) { set(d, save(concat(" - " , short(e)))) } + else { set(d, " - ") } + push(RVAL, save(concat(b, concat(d, " )")))) +} + +proc get_ldates (me) +{ + if (e, birth(me)) { set(b, save(concat("( ", long(e)))) } + else { set(b, "( ") } + if (e, death(me)) { set(d, save(concat(" - " , long(e)))) } + else { set(d, " - ") } + push(RVAL, save(concat(b, concat(d, " )")))) +} + +proc get_dates (me) +{ + if (e, birth(me)) { set(b, save(concat("( ", date(e)))) } + else { set(b, "( ") } + if (e, death(me)) { set(d, save(concat(" - " , date(e)))) } + else { set(d, " - ") } + push(RVAL, save(concat(b, concat(d, " )")))) +} + diff --git a/reports/dump_html.ll b/reports/dump_html.ll new file mode 100644 index 0000000..f244940 --- /dev/null +++ b/reports/dump_html.ll @@ -0,0 +1,650 @@ +/* + * @progname dump_html.ll + * @version 1.3 + * @author Scott McGee + * @category + * @output HTML + * @description + +dump_html.ll is designed to dump an entire database to static HTML files. + +by Scott McGee +@(#)dump_html.ll 1.3 10/1/95 + +/* Customization + Before using, there are a few properties that need to be customized for your + own environment. These are done by adding them to your .linesrc ( or for + windows lines.cfg) file. This report is does not need to be modified. + + The properties that are looked up are: + user.fullname -- Name of the database owner + user.email -- Email address of db owner + genweb.image -- define with path to image if you have one to use + genweb.page -- define with path to page if you have one + genweb.page_nam -- where your 'homepage' is + genweb.isLDS -- define if true + genweb.add_index -- define as 1 to add to INDEX file + +*/ + +include("extract_set.li") +include("tools.li") + +/* other globals */ +global(found) /* external file to inline image found flag */ +global(per_file) /* number of people per file to write */ +global(first) /* first person shouldn't be asked about */ + +global(RVAL) /* ?? (part of borrowed code) */ +global(last_surname) /* last surname in index - used for anchors */ +global(first_indi) /* starting person */ + +/* customization globals - customize values assigned in main */ +global(db_owner) /* name of database owner */ +global(owner_addr) /* url of database owner (mailto or homepage) */ +global(genweb_image) /* name of genweb image to place on each page */ +global(genweb_page) /* URL of base genweb (or homepage) web page */ +global(page_name) /* name of base genweb (or homepage) web page */ +global(LDS) /* display LDS Ordinances? (1=yes 0=no) */ +global(html_index) /* put HTML tag in INDEX file (1=yes 0=no) */ + +proc main () { + + indiset(out_set) + + call set_static_html_globals() + set(per_file, 1) + + print("Reading data...\n") + forindi(j, n) { + addtoset(out_set, j, n) + } + print("Working...\n") + call html_out(out_set) +} + +proc set_static_html_globals(){ +/* customize these globals to customize the output to your site */ + set(db_owner, getproperty("user.fullname")) + set(owner_addr, getproperty("user.email")) + set(genweb_image, getproperty("genweb.image")) + set(genweb_page, getproperty("genweb.page")) + set(page_name, getproperty("genweb.page_name")) /* might change to "my homepage" */ + set(LDS, getproperty("genweb.isLDS")) + set(html_index, getproperty("genweb.add_index")) /* use 1 to add to INDEX file */ +} + +proc html_out (o) { + set(s, concat("There are ", d(lengthset(o)), + " people in your list, how many per file?")) + getstr(a,s) + set(per_file, atoi(a)) + if(not(per_file)) { + set(per_file, 1) + } + set(loop_count, 0) + set(file_count, 0) + set(href_table, init_href(o)) + forindiset(o, i, j, n) { + set(indi, i) + if(eq(loop_count, 0)) { + incr(file_count) + call write_head(file_count) + } + incr(loop_count) + call genhtml(indi, o, href_table) + if(or(eq(loop_count, per_file), eq(n, lengthset(o)))) { + call write_tail() + set(loop_count, 0) + } + } + + call do_index(o, href_table) + +} + +proc write_head(count) { + set(filename, concat("genweb/", database(), "/genweb_", d(count), ".html")) + print("Writing ", filename, "\n") + newfile(filename, 0) + "\n" + " genweb_" + d(count) + ".html \n" "\n" + if(genweb_image) { + "\"\"

\n" + } +} + +proc write_tail() { + "
\n" + date(gettoday()) + "
\n" + "Database maintained by " + "\n" + db_owner + "
\n" + "\n" +} + +proc genhtml (i, o, href_table) { +/* print(" ", fullname(i,0,1,300), "\n") */ + "\n" + "

" + set(vn,givens(i)) + set(vn1,save(vn)) + givens(i) + " " + set(nn,surname(i)) + set(nn1,save(nn)) + nn1 + "

\n" + set(path, get_picture(i)) + if (found) { + "\"\"

\n" + } + call afn(i) + if (e, birth(i)) { + "Born : " long(e) "
\n" + } + if (e, baptism(i)) { + "Baptised : " long(e) "
\n" + } + elsif (e, bapt(i)) { + "Baptised : " long(e) "
\n" + } + if (e, death(i)) { + "Died : " long(e) "
\n" + } + if (e, burial(i)) { + "Buried : " long(e) "
\n" + } + if(LDS) { + /* LDS ordinances */ + set(started, 0) + fornodes(inode(i), node) { + if (eq(0, strcmp(tag(node), "BAPL"))) { + if(not(started)) { + set(started, 1) + "
LDS Ordinances: B " + } + } + /* determine if endowed */ + if (eq(0, strcmp(tag(node), "ENDL"))) { + if(not(started)) { + set(started, 1) + "
LDS Ordinances: " + } + "E " + } + } + /* determine if sealed to parents */ + set(fam, fnode(parents(i))) + set(ind, inode(i)) + if(fam) { + fornodes(fam, node) { + if(and(eqstr("CHIL", tag(node)), eqstr(xref(ind), value(node)))) { + fornodes(node, next) { + if(eqstr(tag(next), "SLGC")) { + if(not(started)) { + set(started, 1) + "
LDS Ordinances: " + } + "SC " + } + } + } + } + } + if(started){ + "
\n" + } + } +/* "
" */ + call othernames(i) + call print_html(i) + "
\n" + if (p, father(i)) { + "" "Father : " + set (path, get_href(p, href_table)) + if(found) { + "" + } + if (t,title(p)) {t " "} + fullname(p,0,1,300) + if(found) {""} + do_info(p) + "
\n" + } + if (p, mother(i)) { + "" "Mother : " + set (path, get_href(p, href_table)) + if(found) { + "" + } + if (t,title(p)) {t " "} + fullname(p,0,1,300) + if(found) {""} + do_info(p) + "
\n" + } + families(i, f, s, n) { + "

" "Spouse" + if (gt(nfamilies(i), 1)) { + " " + d(n) + } + " : \n" + if (s) { /* family has a spouse */ + set (path, get_href(s, href_table)) + if(found) { + "" + } + if (t,title(s)) {t " "} + fullname(s,0,1,300) + if(found) {""} + do_info(s) + "
\n" + } + if (e, marriage(f)) { + "Married " + long(e) + "
\n" + } + if (e, divorced(f)) { + "Divorced " + long(e) + "
\n" + } + if(LDS) { + fornodes(fnode(f), node) { + if (eq(0, strcmp(tag(node), "SLGS"))) { + "
LDS Ordinances: SS\n" + } + } + } + "

    \n" + children(f, c, nn) { + "
  1. " + set (path, get_href(c, href_table)) + if(found) { + "" + } + if (t,title(c)) {t " "} + fullname(c,0,1,300) + if(found) {""} + do_info(c) + "
    2. \n" + } + "
\n" + } + call print_notes(i) + "
\n" + +/* Insert code here for Pedigree and Descendant charts + if(parents(i)) { + "Pedigree Chart
\n" + } + if(nfamilies(i)) { + set(hasChildren, 0) + families(i, f, s, n) { + if(nchildren(f)) { + set(hasChildren, 1) + } + } + if(hasChildren) { + "Descendant Chart\n" + } + } + "
\n" +*/ + "
\n" + "[" + "Index to database]
\n" + if(genweb_page) { + "[" + "Return to " + page_name + " ]
\n" + } + "

\n" +} + +func init_href(outset){ + table(href_table) + + forindiset(outset, indi, j, number) { + insert(href_table, save(key(indi)), number) + } + return(href_table) +} + +func get_href(indi, href_table) { + set(path, "") + set(found, 0) + set(value, lookup(href_table, key(indi))) + if(value){ + set(number, add(div(sub(value, 1), per_file), 1)) + set(path, concat("genweb_", d(number), ".html")) + set(found, 1) + } + return(path) +} + +proc print_notes(indi){ + set(first, 1) + traverse(inode(indi), node, l) { + if (not(strcmp("NOTE", tag(node)))) { + if(first) { + "Notes :
\n" + set(first, 0) + } + "

" + call show_path(node) + value(node) + "\n" + fornodes(node, next) { + value(next) + "\n" + } + "

\n" + } + } +} + +proc show_path (node){ + list(path) + while (node) { + push(path, tag(node)) + set(node, parent(node)) + } + "(" + while (s, pop(path)) { + if(eqstr(lower(s), "indi")){ + "Individual " + }elsif(eqstr(lower(s), "fam")){ + "Family " + }elsif(eqstr(lower(s), "famc")){ + "family " + }elsif(eqstr(lower(s), "fams")){ + "family " + }elsif(eqstr(lower(s), "note")){ + "note" + }elsif(eqstr(lower(s), "birt")){ + "birth " + }elsif(eqstr(lower(s), "deat")){ + "death " + }elsif(eqstr(lower(s), "buri")){ + "burial " + }elsif(eqstr(lower(s), "plac")){ + "place " + }else{ + lower(s) + " " + } + } + ")\n" +} + +proc do_index(indi_set, href_table) { + set(last_surname, "ZZ") + list(RVAL) + indiset(index) + + set(index, indi_set) + namesort(index) + print("Writing INDEX.html\n") + call create_index_file(index, href_table) + print("Writing GENDEX.txt\n") + call create_gendex_file(index, href_table) +} + +proc create_gendex_file(index, href_table) { + set(fn, save(concat("genweb/", database(), "/GENDEX.txt"))) + newfile(fn, 0) + forindiset(index, me, v, n) + { + set(path, concat(save(get_href(me, href_table)), "#", key(me))) + path + "|" + surname(me) + "|" + givens(me) " /" + surname(me) "/" + "|" + if (evt, birth(me)) { + date(evt) + } + "|" + if (evt, birth(me)) { + place(evt) + } + "|" + if (evt, death(me)) { + date(evt) + } + "|" + if (evt, death(me)) { + place(evt) + } + "|\n" + } +} + +proc create_index_file(index, href_table) { + set(fn, save(concat("genweb/", database(), "/INDEX.html"))) + newfile(fn, 0) + call html_header("Interactive Genealogical Server Index", html_index) + "\n" + if(genweb_image) { + "\"\"

\n" + } + "

INDEX

\n" + "
    \n" + forindiset(index, me, v, n) + { + call href(me, href_table) + "\n" + } + "
\n" + call write_tail() +} + +proc href(me, href_table) { + if(me) { + call print_name(me, 1) + if(ne(strcmp(upper(surname(me)), last_surname), 0)) { + print(" ", upper(surname(me)), "\n") + set(last_surname, save(upper(surname(me)))) + "\n" + } + "
  • " + set (path, get_href(me, href_table)) + if(found) { + "\n" + } + pop(RVAL) + if(found) { + "" + } + do_info(me) + } +} + +proc html_header(str, isindex) { + "\n" + "\n" + if(isindex) { + "\n" + } + " " + str + " \n" + "\n" + } + +proc print_name (me, last) { + call get_title(me) + set(junk, pop(RVAL)) + push(RVAL, save(concat(fullname(me, 1, not(last), 45), junk))) +} + +proc get_title (me) { + fornodes(inode(me), node) { + if (not(strcmp("TITL", tag(node)))) { + set(n, node) + } + } + if (n) { + push(RVAL, save(concat(" ", value(n)))) + } + else { + push(RVAL, "") + } +} + +proc rjt(n, w) { + if (lt(n, 10)) { + set(d, 1) + } + elsif (lt(n, 100)) { + set(d, 2) + } + elsif (lt(n, 1000)) { + set(d, 3) + } + elsif (lt(n, 10000)) { + set(d, 4) + } + else { + set(d, 5) + } + if (lt(d, w)) { + set(pad, save( trim(" ", sub(w, d)))) + } + else{ + set(pad, "") + } + push(RVAL, save( concat(pad, save(d(n))))) +} + +proc othernames(indi){ + if(indi){ + set(count, 0) + fornodes(inode(indi), subnode){ + if(eqstr(tag(subnode), "NAME")){ + incr(count) + if(eq(count, 2)){ + "
    Other Names: \n
      " + "
    • " + call nameval(subnode) + "
      • " + }elsif(gt(count, 2)){ + "
    • " + call nameval(subnode) + "
      • \n" + } + } + } + if(gt(count, 1)){ + "
    \n" + } + } +} + +proc afn(indi){ + if(indi){ + fornodes(inode(indi), subnode){ + if(eqstr(tag(subnode), "AFN")){ + "AFN " + value(subnode) + "

    \n" + } + } + } +} + +proc nameval(namenode){ + list(np) + extractnames(namenode, np, nc, sc) + forlist(np, v, i){ + v + " " + } +} + +proc print_html(indi){ + fornodes(inode(indi), node) { + if (eqstr("REPORT", tag(node))) { + set(m, child(node)) + if (eqstr("TYPE", tag(m))) { + if (eqstr("HTML", value(m))) { + "
    \n" + fornodes(m, o) { + if (eqstr("DATA", tag(o))) { + value(o) + "\n" + } + } + } + else { + if (eqstr("HTML-STATIC", value(m))) { + "
    \n" + fornodes(m, o) { + if (eqstr("DATA", tag(o))) { + value(o) + "\n" + } + } + } + } + } + } + } +} + +func divorced(fam) { + fornodes(fnode(fam), node) { + if (eq(0, strcmp(tag(node), "DIV"))) { + return(node) + } + } + return(0) +} diff --git a/reports/dump_html_sd.ll b/reports/dump_html_sd.ll new file mode 100644 index 0000000..dbbb5ad --- /dev/null +++ b/reports/dump_html_sd.ll @@ -0,0 +1,949 @@ +/* + * @progname dump_html_sd.ll + * @version 1.0 + * @author Scott McGee, Steve Dum + * @category sample + * @output HTML + * @description + +dump_html_sd.ll dumps an entire database to static HTML files. + +by Scott McGee (smcgee@microware.com) + 1.4 13/06/02 +lots of modifications by Steve Dum (stephen.dum@verizon.net) + +This report basically generate a +master index and write a series of html files for everyone in +your database. It generates both decendant and pedigree charts for +each individual. There are lots of assumptions in how you store +data in your database inbeded in the script -- or should I say how I +store info. SD. + +*/ + +/* customization globals - customize values assigned in main */ +global(db_owner) /* name of database owner */ +global(owner_addr) /* url of database owner (mailto or homepage) */ +global(use_image) /* flag to indicate whether to use genweb image */ +global(genweb_image) /* name of genweb image to place on each page */ +global(use_page) /* flag to add link to genweb page or homepage */ +global(genweb_page) /* URL of base genweb (or homepage) web page */ +global(page_name) /* name of base genweb (or homepage) web page */ +global(LDS) /* display LDS Ordinances? (1=yes 0=no) */ +global(html_index) /* put HTML tag in INDEX file (1=yes 0=no) */ + + +proc set_static_html_globals(){ +/* customize these globals to customize the output to your site */ + set(db_owner, getproperty("user.fullname")) + set(owner_addr, getproperty("user.email")) + set(use_image, 0) /* 1 to use image, 0 to not use image */ + set(genweb_image, "../../pics/genweb.gif") + set(use_page, 0) /* 1 to use link to page, 0 if not */ + set(genweb_page, "../genweb.html") + set(page_name, "genweb page") /* might change to "my homepage" */ + set(LDS, 0) + set(html_index, 0) /* use 1 to add to INDEX file */ +} +/* end of customization globals - customize values assigned in main */ + +/* other globals */ +global(found) /* external file to inline image found flag */ +global(per_file) /* number of people per file to write */ +global(first) /* first person shouldn't be asked about */ + +global(RVAL) /* ?? (part of borrowed code) */ +global(last_surname) /* last surname in index - used for anchors */ +global(first_indi) /* starting person */ +global(sour_count) /* count of source records */ +global(sourcnt) /* count of source records when doing birth/death */ +global(href_table) /* table that has filenames individuals are in */ + +global(linecount) /* globals for descendent chart */ +global(MAXLINES) +global(gens) +global(mainpre) +global(spousepre) +global(indentpre) + +proc main () { + + set(gens, 3) + set(mainpre, "-") + set(spousepre, " s-") + set(indentpre, " |") + set(MAXLINES, 500) + + set(sour_count,0) + indiset(out_set) + + call set_static_html_globals() + set(per_file, 1) + + print("Reading data...\n") + forindi(j, n) { + addtoset(out_set, j, n) + } + print("Working...\n") + call html_out(out_set) +} + +proc html_out (o) { + /* + set(s, concat("There are ", d(lengthset(o)), + " people in your list, how many per file?")) + getstr(a,s) + set(per_file, atoi(a)) + */ + set(per_file,50) + + if (not(per_file)) { + set(per_file, 1) + } + set(loop_count, 0) + set(file_count, 0) + call init_href(o) + forindiset(o, i, j, n) { + set(indi, i) + if (eq(loop_count, 0)) { + incr(file_count) + call write_head(file_count) + } + incr(loop_count) + call genhtml(indi, o) + if (or(eq(loop_count, per_file), eq(n, lengthset(o)))) { + call write_tail() + set(loop_count, 0) + } + } + + call do_index(o) + +} + +proc write_head(count) { + set(filename, concat("html/", database(), "/",database(),"_", d(count), ".html")) + print("Writing ", filename, "\n") + newfile(filename, 0) + "\n" + " " database() "_" d(count) ".html \n" + "\n" + "\n" + if (use_image) { + "\"\"

    \n" + } +} + +proc write_tail() { + "
    \n" + date(gettoday()) + "
    \n" + "Database maintained by " + "\n" + db_owner + "
    \n" + "\n" +} + +proc genhtml (i, o) { +/* print(" ", fullname(i,0,1,300), "\n") */ + "\n" + /* was

    ...

    but fudged to get key in slightly smaller font */ + "

    " + givens(i) " " surname(i) + " (" key(i) ")

    \n" + + set(path, get_picture(i)) + if (found) { + "\"\"
    \n" + } + "

    " date(birth(i)) " - " date(death(i)) "

    " nl() + call afn(i) + call scan_events(i,0) + if (LDS) { + /* LDS ordinances */ + set(started, 0) + fornodes(inode(i), node) { + if (eq(0, strcmp(tag(node), "BAPL"))) { + if (not(started)) { + set(started, 1) + "
    LDS Ordinances: B " + } + } + /* determine if endowed */ + if (eq(0, strcmp(tag(node), "ENDL"))) { + if (not(started)) { + set(started, 1) + "
    LDS Ordinances: " + } + "E " + } + } + /* determine if sealed to parents */ + set(fam, fnode(parents(i))) + set(ind, inode(i)) + if (fam) { + fornodes(fam, node) { + if (and(eqstr("CHIL", tag(node)), eqstr(xref(ind), value(node)))) { + fornodes(node, next) { + if (eqstr(tag(next), "SLGC")) { + if (not(started)) { + set(started, 1) + "
    LDS Ordinances: " + } + "SC " + } + } + } + } + } + if (started){ + "
    \n" + } + } + call othernames(i) + call print_html(i) + "
    \n" + if (p, father(i)) { + "

    \n" + "" "Father : " + call name_href(p,1) + "
    \n" + } + if (p, mother(i)) { + "

    \n" + "" "Mother : " + call name_href(p,1) + "
    \n" + } + families(i, f, s, n) { + "

    \n" + "" "Spouse" + if (gt(nfamilies(i), 1)) { + " " + d(n) + } + " : \n" + if (s) { /* family has a spouse */ + call name_href(s,1) + "
    \n" + } + if (e, marriage(f)) { + "

    \n" + "Married " + long(e) + "
    \n" + } + if (e, divorced(f)) { + "

    \n" + "Divorced " + long(e) + "
    \n" + } + if (LDS) { + fornodes(fnode(f), node) { + if (eq(0, strcmp(tag(node), "SLGS"))) { + "
    LDS Ordinances: SS\n" + } + } + } + if (nchildren(f)) { + "

    \n" + "Children\n" + "

      \n" + children(f, c, nn) { + "
    1. " + call name_href(c,1) + "
      2. \n" + } + "
    \n" + } + } + + call print_notes(inode(i)) + + call print_indi_sources(i) + + if (parents(i)) { + "

    \nPedigree Chart for " fullname(i,0,1,300) "
    \n

    \n"
+     call pedigree(0,i)
+     "
    \n" + } + if (nfamilies(i)) { + "Descendent Chart for " fullname(i,0,1,300) "
    \n
    \n"
+    set(linecount,0)
+    call dofam(i,"",1,0)
+    "
    \n" + } + + /* scan events for sources */ + call scan_events(i,1) + "
    \n" + +/* Insert code here for Pedigree and Descendant charts + if (parents(i)) { + "Pedigree Chart
    \n" + } + if (nfamilies(i)) { + set(hasChildren, 0) + families(i, f, s, n) { + if (nchildren(f)) { + set(hasChildren, 1) + } + } + if (hasChildren) { + "Descendant Chart\n" + } + } + "
    \n" +*/ + "
    \n" + "[" + "Index]
    \n" + if (use_page) { + "[" + "Return to " + page_name + " ]
    \n" + } + "

    \n" +} + +proc init_href(outset){ + table(href_table) + + forindiset(outset, indi, j, number) { + insert(href_table, save(key(indi)), number) + } +} + +func get_href(indi) { + set(path, "") + set(found, 0) + set(value, lookup(href_table, key(indi))) + if (value){ + set(number, add(div(sub(value, 1), per_file), 1)) + set(path, concat(database(),"_", d(number), ".html")) + set(found, 1) + } + return(path) +} + +proc print_notes(i){ + set(first, 1) + fornodes(i, n) { + set(hdr,"") + if (eqstr(tag(n), "NOTE")) { set(hdr,"Note") } + elsif(eqstr(tag(n),"NOTE_L")) { set(hdr,"Note_L") } + elsif(eqstr(tag(n),"NOTE_Q")) { set(hdr,"Note_Q") } + elsif(eqstr(tag(n),"NOTE_E")) { set(hdr,"Note_E") } + if (strcmp(hdr,"")) { + set(s, value(n)) + if (and(strcmp("",s),reference(s))) { + set(n,dereference(s)) + set(hdr, save(concat(hdr," ",substring(s,2,sub(strlen(s),1))))) + } + print_note(n,hdr) + } + } +} + +proc print_indi_sources(indi) { + fornodes(inode(indi), node) { + set(hdr,"") + set(ntag,tag(node)) + set(first,0) + if (eqstr("SOUR", ntag)) { set(hdr,"Source") } + elsif(eqstr("ADDR", ntag)) { set(hdr,"Address") } + elsif(eqstr("_MDCL", ntag)) { set(hdr,"Medical") } + elsif(eqstr("OCCU", ntag)) { set(hdr,"Occupation") } + elsif(eqstr("_FA", trim(ntag,3))) { set(hdr,"Fact") } + if (strcmp("",hdr)) { + if (reference(value(node))) { set(node,dereference(value(node))) } + "

    \n" + "" hdr ":: " + if (nestr("",value(node))) { + incr(first) + value(node) "
    \n" + } + fornodes(node, next) { + if (nestr("",value(next))) { + /* if(eq(first,1)) { "
    " } */ + incr(first) + value(next) "
    \n" + } + fornodes(next, nn) { + if (nestr("",value(next))) { + /* if(eq(first,1)) { "
    " } */ + incr(first) + value(nn) "
    \n" + } + } + } + if(gt(first,1)) { "\n" } + } + } +} + +proc show_path (node){ + list(path) + while (node) { + push(path, tag(node)) + set(node, parent(node)) + } + "(" + while (s, pop(path)) { + if (eqstr(lower(s), "indi")){ + "Individual " + }elsif (eqstr(lower(s), "fam")){ + "Family " + }elsif (eqstr(lower(s), "famc")){ + "family " + }elsif (eqstr(lower(s), "fams")){ + "family " + }elsif (eqstr(lower(s), "note")){ + "note" + }elsif (eqstr(lower(s), "birt")){ + "birth " + }elsif (eqstr(lower(s), "deat")){ + "death " + }elsif (eqstr(lower(s), "buri")){ + "burial " + }elsif (eqstr(lower(s), "plac")){ + "place " + }else{ + lower(s) + " " + } + } + ")\n" +} + +proc do_index(indi_set) { + set(last_surname, "ZZ") + list(RVAL) + indiset(index) + + set(index, indi_set) + namesort(index) + print("Writing index.html\n") + call create_index_file(index) + print("Writing gendex.txt\n") + call create_gendex_file(index) +} + +proc create_gendex_file(index) { + set(fn, save(concat("html/", database(), "/gendex.txt"))) + newfile(fn, 0) + forindiset(index, me, v, n) + { + set(path, concat(save(get_href(me)), "#", key(me))) + path + "|" + surname(me) + "|" + givens(me) " /" + surname(me) "/" + "|" + if (evt, birth(me)) { + date(evt) + } + "|" + if (evt, birth(me)) { + place(evt) + } + "|" + if (evt, death(me)) { + date(evt) + } + "|" + if (evt, death(me)) { + place(evt) + } + "|\n" + } +} + +proc create_index_file(index) { + set(fn, save(concat("html/", database(), "/index.html"))) + newfile(fn, 0) + call html_header(concat("Index for ",database()," Database"), html_index) + "\n" + if (use_image) { + "\"\"

    \n" + } + "

    Index

    \n" + "
      \n" + forindiset(index, me, v, n) + { + call href(me) + "\n" + } + "
    \n" + call write_tail() +} + +/* href generates html link reference for name in form last,first */ +proc href(indi) { + if (indi) { + call print_name(indi, 1) + if (ne(strcmp(upper(surname(indi)), last_surname), 0)) { + print(" ", upper(surname(indi)), "\n") + set(last_surname, save(upper(surname(indi)))) + "\n" + } + "
  • " + set (path, get_href(indi)) + if (found) { + "\n" + } + pop(RVAL) + if (found) { + "" + } + do_info(indi,1) + } +} + +/* name_href generates html link reference for name */ +proc name_href(indi,long) { + set (path, get_href(indi)) + if (found) { + "" + } + if (t,title(indi)) { t " " } + fullname(indi,0,1,300) + if (found) {""} + do_info(indi,long) +} + +proc html_header(str, isindex) { + "\n" + "\n" + if (isindex) { + "\n" + } + " " + str + " \n" + "\n" + } + +proc print_name (me, last) { + call get_title(me) + set(junk, pop(RVAL)) + push(RVAL, save(concat(fullname(me, 1, not(last), 45), junk))) +} + +proc get_title (me) { + fornodes(inode(me), node) { + if (not(strcmp("TITL", tag(node)))) { + set(n, node) + } + } + if (n) { + push(RVAL, save(concat(" ", value(n)))) + } + else { + push(RVAL, "") + } +} + +proc rjt(n, w) { + if (lt(n, 10)) { + set(d, 1) + } + elsif (lt(n, 100)) { + set(d, 2) + } + elsif (lt(n, 1000)) { + set(d, 3) + } + elsif (lt(n, 10000)) { + set(d, 4) + } + else { + set(d, 5) + } + if (lt(d, w)) { + set(pad, save( trim(" ", sub(w, d)))) + } + else{ + set(pad, "") + } + push(RVAL, save( concat(pad, save(d(n))))) +} + +proc othernames(indi){ + if (indi){ + set(count, 0) + fornodes(inode(indi), subnode){ + if (eqstr(tag(subnode), "NAME")){ + incr(count) + if (eq(count, 2)){ + "
    Other Names: \n
      " + "
    • " call nameval(subnode) "
      • " + } elsif (gt(count, 2)){ + "
    • " call nameval(subnode) "
      • \n" + } + } elsif (eqstr(tag(subnode),"ALIA")){ + incr(count) + if (eq(count, 2)){ + "
      Other Names: \n
        " + "
      • " value(subnode) "
        • " + } elsif (gt(count, 2)){ + "
      • " value(subnode) "
        • \n" + } + } + } + if (gt(count, 1)){ + "
      \n" + } + } +} + +proc afn(indi){ + if (indi){ + fornodes(inode(indi), subnode){ + if (eqstr(tag(subnode), "AFN")){ + "AFN " + value(subnode) + "

      \n" + } + } + } +} + +func do_info(me,long){ + if(not(me)){ + return("") + } + set(out, " -") + if (evt, birth(me)) { + if (long) { + set(out, concat(out, " b. ", long(evt))) + } else { + set(out, concat(out, " b. ", short(evt))) + } + } else { + if (evt, baptism(me)) { + if (long) { + set(out, concat(out, " bapt. ", long(evt))) + } else { + set(out, concat(out, " bapt. ", short(evt))) + } + } else { + if (evt, bapt(me)) { + if (long) { + set(out, concat(out, " bapt. ", long(evt))) + } else { + set(out, concat(out, " bapt. ", short(evt))) + } + } + } + } + if (evt, death(me)) { + if (long) { + set(out, concat(out, " d. ", long(evt))) + } else { + set(out, concat(out, " d. ", short(evt))) + } + } + return(out) +} + +func bapt (indi) { + fornodes(inode(indi), node) { + if (eq(0, strcmp(tag(node), "BAPL"))) { + return(node) + } + if (eq(0, strcmp(tag(node), "BAPM"))) { + return(node) + } + if (eq(0, strcmp(tag(node), "BAPT"))) { + return(node) + } + } + return(0) +} + +proc nameval(namenode){ + list(np) + extractnames(namenode, np, nc, sc) + forlist(np, v, i){ + v + " " + } +} + +proc print_html(indi){ + fornodes(inode(indi), node) { + if (eqstr("REPORT", tag(node))) { + set(m, child(node)) + if (eqstr("TYPE", tag(m))) { + if (eqstr("HTML", value(m))) { + "
      \n" + fornodes(m, o) { + if (eqstr("DATA", tag(o))) { + value(o) + "\n" + } + } + } + else { + if (eqstr("HTML-STATIC", value(m))) { + "
      \n" + fornodes(m, o) { + if (eqstr("DATA", tag(o))) { + value(o) + "\n" + } + } + } + } + } + } + } +} + +func divorced(fam) { + fornodes(fnode(fam), node) { + if (eq(0, strcmp(tag(node), "DIV"))) { + return(node) + } + } + return(0) +} + +proc scan_events(indi, flag) { + set(sourcnt,sour_count) + fornodes(inode(indi),e) { + set(match,1) + if (eq(0, strcmp(tag(e), "BIRT"))) { + set (type,"Birth") + } elsif (eq(0, strcmp(tag(e), "DEAT"))) { + set (type,"Death") + } elsif (eq(0, strcmp(tag(e), "BAPL"))) { + set (type,"Baptism") + } elsif (eq(0, strcmp(tag(e), "CHR"))) { + set (type,"Christening") + } elsif (eq(0, strcmp(tag(e), "BURI"))) { + set (type,"Burial") + } elsif (eq(0, strcmp(tag(e), "BAPT"))) { + set (type,"Baptism") + } elsif (eq(0, strcmp(tag(e), "BAPM"))) { + set (type,"Baptism") + } else { + set(match,0) + } + if (eq(match,1)) { + if (flag) { + /* flag == 1 print notes with sources */ + print_sources(e,type) + } else { + "" type " : " long(e) + fornodes(e, s) { + if (and(eqstr(tag(s), "SOUR"),nestr(value(s),""))) { + incr(sourcnt) + " [" d(sourcnt) "]" + } + } + "
      \n" + } + } + } +} + +func print_sources(e,t) { + fornodes(e, s) { + if (and(eqstr(tag(s), "SOUR"),nestr(value(s),""))) { + incr(sour_count) + "

      \n[" d(sour_count) + "][Source " t "]\n" value(s) nl() + fornodes(s, n) { + set(hdr,"") + if (eqstr(tag(n), "NOTE")) { set(hdr,"Note") } + elsif(eqstr(tag(n),"NOTE_L")) { set(hdr,"Note_L") } + elsif(eqstr(tag(n),"NOTE_Q")) { set(hdr,"Note_Q") } + elsif(eqstr(tag(n),"NOTE_E")) { set(hdr,"Note_E") } + if (strcmp(hdr,"")) { + set(s, value(n)) + if (and(strcmp("",s),reference(s))) { + set(n,dereference(s)) + set(hdr,save(concat(hdr," ",s))) + } + print_note(n,hdr) + } + } + } + } +} + +func print_note(node,hdr) { + "

      \n" + "" hdr ": " + if (strcmp("",value(node))) { + value(node) nl() + } + fornodes(node,next) { + set(ctag,tag(next)) + if (or(eqstr("CONT",ctag),eqstr("CONC",ctag))) { + if (eqstr("CONT",ctag)) { "
      " nl() } + value(next) + } + } + "

      \n" +} + +func get_picture (indi) { +/* Note: this code assumes the following tag sturcture + return found==1 if url, found==2 if FILE + +1 _PIC + 2 FILE pics/scott.gif + 2 DATE Jul 1989 +1 _PIC + 2 URL http://www.someurl.net/~user/userpic.gif + + where the first defines an external file stored on the same file + system and gives the path in the FILE record and the type in the + FORM record. The second defines an external file stored on another + site and provides a URL for referencing it. I have proposed this as + an extension to GEDCOM, but nobody said very much. +*/ + + set(found, 0) + set(path, "") + fornodes(inode(indi), node) { + if (eqstr("_PIC", tag(node))) { + set(m, child(node)) + /* files on local system or file on remote system */ + if (or(eqstr("FILE", tag(m)),eqstr("URL", tag(m)))) { + set(path, value(m)) + incr(found) + if (eqstr("FILE",tag(m))) { incr(found) } + } + } + } + return(path) +} + +proc pedigree (level, indi) { + set(has_parent, or(father(indi), mother(indi))) + if (and(lt(level, 4), has_parent)) { + call pedigree(add(1,level), father(indi)) + } + if (indi) { + col(mul(4,level)) + call name_href(indi,le(level,3)) + nl() + } else { + col(mul(4,level)) + "(Spouse not known)" + nl() + } + if (and(lt(level, 4), has_parent)) { + call pedigree(add(1,level), mother(indi)) + } +} + +/* startfam: + If we haven't reached the maximum or specified generation count, + call dofam for each child in this family. + Otherwise, print a message line if there are further descendants + at this point. +*/ +proc startfam (fam,prefix,level,isstep) { + if (le(level,gens)) { /* if not at last generation */ + children (fam,child,num) { /* for each child */ + call dofam (child, /* call dofam */ + concat(prefix, indentpre), + add(level,1), + isstep) + } + } else { /* don't do this generation */ + if (gt(nchildren(fam),0)) { /* but if there are children, */ + /* issue message */ + prefix " [[Further descendants here" + if (eq(isstep,1)) { + " (stepchildren)" + } + ".]]\n" + incr(linecount) + } + } +} + +/* dofam: + Write out a person and check for spouses and children. + Each spouse is written, then this routine is called + recursively for each child. An incremented level is passed along + in case the user specified a limited number of generations +*/ + +proc dofam (nm,prefix,level,isstep) { + set(pre,mainpre) + call printpers(nm,concat(prefix,pre),0,0) /* print this person */ + if (and(ge(linecount,MAXLINES),gt(nfamilies(nm),0))) { + prefix " [[Reached line count max." + " May be further descendants here." + "]]\n" + } else { + families(nm, fam, spouse, num) { /* do for each family */ + if (ne(spouse,null)) { /* if there is a spouse */ + /* print spouse */ + call printpers(spouse,concat(prefix,spousepre),1,fam) + if (and(ge(linecount,MAXLINES),gt(nchildren(fam),0))) { + prefix " [[Reached line count max." + " May be further descendants here." + "]]\n" + } else { + families (spouse, spsfam, ospouse, num2) { + /* for each of the spouse families*/ + if(eq(fam,spsfam)){ /* only non-step families */ + call startfam (spsfam,prefix,level,0) + } + } /*end spouse's families*/ + } /* end spouse not ge MAXLINES */ + } else { /* there is no spouse */ + call startfam (fam,prefix,level,0) + } /*end else no spouse*/ + } /*end 'families'*/ + } /* end MAXLINES else */ +} /*end 'proc dofam'*/ + + +/* printpers: + Write output line for one person. + Include birth and death dates if known. + For a spouse, include marriage date if known. +*/ +proc printpers (nm, prefix, spouse, fam) { + prefix + if(nfamilies(nm)){ + set(hasChildren, 0) + families(nm, f, s, n){ + if(nchildren(f)){ + set(hasChildren, 1) + } + } + } + call name_href(nm,1) + if (e, marriage(fam)) { + "\t m. " stddate(e) + } + "\n" + incr(linecount) +} /* end proc printpers */ diff --git a/reports/eol.ll b/reports/eol.ll new file mode 100644 index 0000000..04eb0b6 --- /dev/null +++ b/reports/eol.ll @@ -0,0 +1,322 @@ +/* + * @progname eol.ll + * @version 4 of 1995-01 + * @author Tom Wetmore and John Chandler + * @category + * @output Text, 80 cols + * @description + * +Say you want to know who all of your end-of-line ancestors are, that +is, your direct ancestors whose parents you have not yet discovered; +these are the people most of us spend most of our time on researching. +Here is a program that will produce the list. Any ancestor will be +listed at most once, even in cases where lines cross. Each person +is shown with date and place of birth and death -- a "guess" is made +for the year of birth if it is not known. + +Set the Do_all variable to 1 if you want the end-of-line list to +include even persons with an unknown surname. + +This program shares the birth-guessing subroutine with tinytafel. +*/ + +global(plist) +global(abbvtab) + +/* Global definitions for birth-guessing subroutine */ +global(pdate) +global(pplace) +global(datemod) /* value returned by get_modifier */ +global(pdmax) +global(pdmin) + +/* Assumptions for guessing year of birth */ +global(Minpar) /* assumed minimum age of parenthood */ +global(Typicl) /* typical age for parenthood or marriage */ +global(Menopa) /* assumed maximum age of motherhood */ +global(Oldage) /* assumed age at death */ + +proc main () { + set(Do_all,0) /* if 0, then ignore surnameless persons */ + + /* Assumptions for guessing year of birth */ + set(Minpar,14) /* assumed minimum age of parenthood */ + set(Typicl,20) /* typical age for parenthood or marriage */ + set(Menopa,50) /* assumed maximum age of motherhood */ + set(Oldage,60) /* assumed age at death */ + + list(ilist) + list(plist) + list(pnlist) + table(seen) + table(abbvtab) + indiset(set) + getindi(indi) + monthformat(4) + "END OF LINE ANCESTORS OF " fullname(indi,1,1,30) "\n\n" + call setupabbvtab() + enqueue(ilist, indi) + while(indi, dequeue(ilist)) { + set(show, 1) + if (par, father(indi)) { + set(do_this,Do_all) + if(not(Do_all)) { + extractnames (inode(par),pnlist,n,s) + set(do_this, strcmp(getel(pnlist,s),"")) + } + if(do_this) { + enqueue(ilist, par) + set(show, 0) + } + } + if (par, mother(indi)) { + set(do_this,Do_all) + if(not(Do_all)) { + extractnames (inode(par),pnlist,n,s) + set(do_this, strcmp(getel(pnlist,s),"")) + } + if(do_this) { + enqueue(ilist, par) + set(show, 0) + } + } + if (show) { + set(pkey, key(indi)) + if(not(lookup(seen,pkey))) { + insert(seen,pkey,1) + addtoset(set, indi, pkey) + } + } + } + namesort(set) + forindiset (set, indi, val, num) { + col(1) fullname(indi,1,0,27) + call set_year_place(indi) + call showevent(29, birth(indi), pdate, pplace) + call showevent(55, death(indi), 0, 0) + nl() + } +} + +proc showevent (column, event, apdate, applace) +{ + col(column) + set(column, add(column, 12)) + if(year(event)) { + stddate(event) sp() + } + elsif(apdate) { " c" apdate " " } + extractplaces(event, plist, num) + if (and(applace,eq(num,0))) { + call extractstr(applace,plist) + set(num,length(plist)) + } + if (gt(num, 0)) { + col(column) + set(last, getel(plist, num)) + if (yes, lookup(abbvtab, last)) { + set(last, yes) + } + trim(last, 10) + } +} + +proc extractstr (string,list) { + list(list) + call ext_step(list,string,1,strlen(string),0) +} +proc ext_step(list,string,start,len,nth) { + if(gt(start,len)) {return()} + set(nth,add(1,nth)) + if (not(strcmp(substring(string,start,start)," "))) { + set(start,add(1,start)) + } + set(end, sub(index(string, ",", nth),1)) + if(lt(end,0)) {set(end,len)} + enqueue (list, substring(string,start,end)) + if (lt(end,len)) {call ext_step(list,string,add(end,2),len,nth)} +} + +proc setupabbvtab () +{ + insert(abbvtab, "Connecticut", "CT") + insert(abbvtab, "Connecticut Colony", "CT") + insert(abbvtab, "New Haven Colony", "CT") + insert(abbvtab, "Massachusetts", "MA") + insert(abbvtab, "Plymouth Colony", "MA") + insert(abbvtab, "New York", "NY") + insert(abbvtab, "England", "ENG") + insert(abbvtab, "Holland", "HOL") + insert(abbvtab, "Maryland", "MD") + insert(abbvtab, "Wales", "WLS") + insert(abbvtab, "Isle of Man", "IOM") + insert(abbvtab, "Nova Scotia", "NS") + insert(abbvtab, "Ireland", "IRE") + insert(abbvtab, "Rhode Island", "RI") + insert(abbvtab, "prob England", "ENG?") +} + +/* set global variable datemod to +1 if event's date is marked AFT, + -1 if marked BEF, and 0 otherwise */ + +proc get_modifier(event) +{ set (datemod,0) + if (junk,date(event)) { + set (junk,trim(junk,3)) + if(not(strcmp(junk,"AFT"))) { set (datemod,1) } + elsif(not(strcmp(junk,"BEF"))) { set (datemod,neg(1)) } + } +} + +/* get birth-year for given person -- use whatever clues available, in +this order. The culture-dependent limits are defined in "main". + + 1. birth + 2. baptism + 3. birth of older sibling (+2) + 4. birth of younger sibling (-2) + 5. baptism of younger sibling (upper limit only) + 6. birth of parent (+14: lower limit only) + 7. death of parent (upper limit only) + 8. marriage or birth of first child (-20: recursive) + 9. marriage or birth of first child (-14: recursive upper limit) + 9. birth of last child (-50: lower limit only) + 10. death, known to be a parent (-60) + 11. death, not known to be a parent +*/ +proc set_year (person) +{ set (maxyr,9999) /* set upper bound */ + set (minyr,0) /* and lower bound */ + set (guess,0) /* clear "best" guess */ + if (yr, year(birth(person))) { /* solid data */ + call get_modifier(birth(person)) + set (iyr,atoi(yr)) + if(ge(datemod,0)) {set(minyr,iyr)} + if(le(datemod,0)) {set(maxyr,iyr)} + if(datemod) {set (yr,0)} + } + if (not(yr)) { + if (yr, year(baptism(person))) { /* pretty good guess */ + set(iyr,atoi(yr)) + call get_modifier(baptism(person)) + if(and(le(datemod,0),lt(iyr,maxyr))) {set(maxyr,iyr)} + set (guess, iyr) + } + + if(sibl,prevsib(person)) { /* try older sibling */ + if (yr, year(birth(sibl))) { + call get_modifier(birth(sibl)) + if(ge(datemod,0)) { + set (iyr,atoi(yr)) + if(gt(iyr,minyr)) {set(minyr,iyr)} + if(not(or(guess,datemod))) {set(guess,add(iyr,2))} + } + } + } + if(sibl,nextsib(person)) { /* try younger sibling */ + if (yr, year(birth(sibl))) { + call get_modifier(birth(sibl)) + if(le(datemod,0)) { + set (iyr,atoi(yr)) + if(lt(iyr,maxyr)) {set(maxyr,iyr)} + if(not(or(guess,datemod))) {set(guess,sub(iyr,2))} + } else {set(yr,0)} + } + if (not(yr)) { + if (yr, year(baptism(sibl))) { + set(iyr,atoi(yr)) + call get_modifier(baptism(sibl)) + if(and(le(datemod,0),lt(iyr,maxyr))) {set(maxyr,iyr)} + } + } + } + + if(sp,mother(person)) { /* set limits from mother */ + if(yr,year(birth(sp))) { + call get_modifier(birth(sp)) + set(iyr,add(atoi(yr),Minpar)) + if(and(ge(datemod,0),gt(iyr,minyr))) {set(minyr,iyr)} + } + if(yr,year(death(sp))) { + call get_modifier(death(sp)) + set(iyr,atoi(yr)) + if(and(le(datemod,0),lt(iyr,maxyr))) {set(maxyr,iyr)} + } + } + + + if(sp,father(person)) { /* set limits from father */ + if(yr,year(birth(sp))) { + call get_modifier(birth(sp)) + set(iyr,add(atoi(yr),Minpar)) + if(and(ge(datemod,0),gt(iyr,minyr))) {set(minyr,iyr)} + } + if(yr,year(death(sp))) { + call get_modifier(death(sp)) + set(iyr,add(atoi(yr),1)) + if(and(le(datemod,0),lt(iyr,maxyr))) {set(maxyr,iyr)} + } + } + + set(maryr,9999) /* marriage date or upper limit */ + set(marbest,9999) /* best guess at marriage date */ + set(lastbirth,0) + families(person,fam,sp,spi) { /* check on marriage/chidren */ + if(yr, year(marriage(fam))) { + call get_modifier(marriage(fam)) + set(iyr,atoi(yr)) /* go by marriage date */ + if(and(le(datemod,0),lt(iyr,maryr))) {set(maryr,iyr)} + if(and(le(datemod,0),lt(iyr,marbest))) {set(marbest,iyr)} + } + if(or(eq(maryr,9999),female(person))) { + children (fam,child,famchi) { + call set_year(child) /* recurse on children */ + if(lt(pdmax,maryr)) {set(maryr,pdmax)} + if(strcmp(pdate,"????")) { + set(iyr,atoi(pdate)) + if(lt(iyr,marbest)) {set(marbest,iyr)} + } + if(gt(pdmin,lastbirth)) {set(lastbirth,pdmin)} + /* get earliest & latest child */ + } + } + } + if(eq(marbest,9999)) {set(marbest,maryr)} + if(lt(maryr,9999)) { + set(iyr,sub(maryr,Minpar)) /* assume biological limit */ + if(lt(iyr,maxyr)) {set(maxyr,iyr)} + if(not(guess)) {set(guess,sub(marbest,Typicl))} /* typical age */ + } + if(gt(lastbirth,0)) { + set(iyr,sub(lastbirth,Menopa)) /* another biological limit */ + if(gt(iyr,minyr)) {set(minyr,iyr)} + } + if (yr, year(death(person))) {call get_modifier(death(person))} + elsif (yr, year(burial(person))) {call get_modifier(burial(person))} + if (yr) { + set (iyr, atoi(yr)) + if(and(le(datemod,0),lt(iyr,maxyr))) {set(maxyr,iyr)} + if(not(guess)) { /* still need a guess? */ + if(nfamilies(person)) { + set(guess,sub(iyr,Oldage))} /* died old */ + else {set(guess,iyr)} /* no family => died young */ + } + } + + if (gt(guess,maxyr)) { set(guess,maxyr) } /* apply limit, in case... */ + if (lt(guess,minyr)) { set(guess,minyr) } + if (gt(guess,0)) {set (yr,d(guess))} + } + if (not(yr)) { set (yr, "????") } + set(pdate, yr) /* values returned */ + set(pdmin,minyr) + set(pdmax,maxyr) +} + +proc set_year_place (person) +{ + call set_year (person) + set(pl, place(birth(person))) + if (not(pl)) {set(pl, place(baptism(person)))} + set(pplace, pl) +} diff --git a/reports/est_life_span.ll b/reports/est_life_span.ll new file mode 100644 index 0000000..b4d2950 --- /dev/null +++ b/reports/est_life_span.ll @@ -0,0 +1,211 @@ +/* + * @progname est_life_span.ll + * @version none + * @author Rafal Prinke + * @category + * @output Text + * @description + +The program below finds the widest possible span of life, estimating +the uncertain and some unknown dates on the basis of user defined +values in the table for various combinations of date modifiers etc. +Then it compares the midpoints of this with midpoints of others' +life spans and if they fall within a user defined range, the two +are considered "possibly identical". This is actually just one procedure +of several that should be in a program like that - but perhaps the +most important one as people may change names, occupations, etc. +but they cannot change the time period. I added two arbitrary tags: +FAPP and LAPP for "first/last appearance" in sources. + +At present the program compares only the life midpoints and surnames +(exactly as they are recorded). Adding other elements for comparison +should not be a problem - but there should be a more complicated +procedure for comparing names. I do not like soundex as it is misleading +(and my bias is founded on the fact that two spellings of my own +surname - Prinke and Brinke - never match under the standard soundex :-) +Perhaps a soundex that would INCLUDE conversion of the first character +into number would nee to be considered? That does not solve many problems +of non-English name, either. So perhaps a user defined soundex? This +might be possible with user defined functions! + +The procedure below does not deal with BETWEEN dates for death yet. +Also people who have no dates at all are not dealt with properly - +they should be compared with everyone (generating a lot of rubbish +output) or their life span should be found out from children or spouses. + */ + +global(year1) /* earliest possible */ +global(year2) /* latest possible */ +global(diffs) +global(someone) +global(another) + +proc life_span(someone) +{ + set(year1,0) + if (bt,birth(someone)) { + set(year1,atoi(year(bt))) + if (ne(index(upper(date(bt)),"BEF",1),0)) { + set(year1,sub(year1,lookup(diffs,"bef_birt"))) + } + if (and(ne(index(upper(date(bt)),"ABT",1),0),ne(index(upper(date(bt)),"EST",1),0))) + { + set(year1,sub(year1,lookup(diffs,"abt_birt"))) + } + } + if (eq(year1,0)) { + if (bp,baptism(someone)) { + set(year1,atoi(year(bp))) + if (ne(index(upper(date(bp)),"BEF",1),0)) { + set(year1,sub(year1,lookup(diffs,"bef_birt"))) + } + if (and(ne(index(upper(date(bp)),"ABT",1),0),ne(index(upper(date(bp)),"EST",1),0))) + { + set(year1,sub(year1,lookup(diffs,"abt_birt"))) + } + } + } + if (eq(year1,0)) { + set(r, inode(someone)) + fornodes (r, n) { + if (eq(0, strcmp("FAPP", tag(n)))) { + extractdate(n,da,mo,ye) + set(year1,ye) + set(year1,sub(year1,lookup(diffs,"app1"))) + } + } + } + if (and(eq(year1,0),ne(nfamilies(someone),0))) { + set(myear,2000) + families(someone,fm,sp,mnr) { + set(fyear,atoi(year(marriage(fm)))) + if (lt(fyear,myear)) { + set (myear,fyear) + set(mar,marriage(fm)) + } + } + if (and(ne(myear,2000),ne(myear,0))) { + set(year1,sub(myear,lookup(diffs,"f_marr"))) + if (ne(index(upper(date(mar)),"BEF",1),0)) { + set(year1,sub(year1,lookup(diffs,"bef_marr"))) + } + if (and(ne(index(upper(date(mar)),"ABT",1),0),ne(index(upper(date(bp)),"EST",1),0))) + { + set(year1,sub(year1,lookup(diffs,"abt_marr"))) + } + } + } + + set(year2,0) + if (dt,death(someone)) { + set(year2,atoi(year(dt))) + if (ne(index(upper(date(dt)),"AFT",1),0)) { + set(year2,add(year2,lookup(diffs,"aft_deat"))) + } + if (and(ne(index(upper(date(dt)),"ABT",1),0),ne(index(upper(date(dt)),"EST",1),0))) + { + set(year2,add(year2,lookup(diffs,"abt_deat"))) + } + } + if (eq(year2,0)) { + if (br,burial(someone)) { + set(year2,atoi(year(br))) + if (ne(index(upper(date(br)),"AFT",1),0)) { + set(year2,add(year2,lookup(diffs,"aft_deat"))) + } + if (and(ne(index(upper(date(br)),"ABT",1),0),ne(index(upper(date(br)),"EST",1),0))) + { + set(year2,add(year2,lookup(diffs,"abt_deat"))) + } + } + } + if (eq(year2,0)) { + set(r, inode(someone)) + fornodes (r, n) { + if (eq(0, strcmp("LAPP", tag(n)))) { + extractdate(n,da,mo,ye) + set(year2,ye) + set(year2,add(year2,lookup(diffs,"app2"))) + } + } + } + if (and(eq(year2,0),ne(nfamilies(someone),0))) { + set(myear,0) + families(someone,fm,sp,mnr) { + set(lyear,atoi(year(marriage(fm)))) + if (gt(lyear,myear)) { + set (myear,lyear) + set(mar,marriage(fm)) + } + } + if (ne(myear,0)) { + set(year2,add(myear,lookup(diffs,"l_marr"))) + if (ne(index(upper(date(mar)),"AFT",1),0)) { + set(year2,add(year2,lookup(diffs,"aft_marr"))) + } + if (and(ne(index(upper(date(mar)),"ABT",1),0),ne(index(upper(date(mar)),"EST",1),0))) + { + set(year2,add(year2,lookup(diffs,"abt_marr"))) + } + } + } + if (ne(add(year1,year2),0)) { + if (and(eq(year1,0),ne(year2,0))) { + set(year1,sub(year2,lookup(diffs,"birt_deat"))) + } + if (and(eq(year2,0),ne(year1,0))) { + set(year2,add(year1,lookup(diffs,"birt_deat"))) + } + } +} + +proc main() +{ + table(diffs) /* values for range of date modifiers etc. */ + insert(diffs,"bef_birt", 10) + insert(diffs,"abt_birt", 10) + insert(diffs,"aft_deat", 10) + insert(diffs,"abt_deat", 10) + insert(diffs,"f_marr",25) + insert(diffs,"l_marr",13) + insert(diffs,"bef_marr", 10) + insert(diffs,"abt_marr", 8) + insert(diffs,"aft_marr", 2) + insert(diffs,"app1", 10) + insert(diffs,"app2", 10) + insert(diffs,"birt_deat", 88) + insert(diffs,"dist", 50) + + forindi(someone,n1) { + call life_span(someone) + set(pb1,surname(someone)) + set(pb1,save(pb1)) + set(midspan1,div(add(year1,year2),2)) + forindi(another,n2) { + print(d(n1)," ",d(n2),"\n") + if (gt(n2,n1)) { + call life_span(another) + set(pb2,surname(another)) + set(pb2,save(pb2)) + set(midspan2,div(add(year1,year2),2)) + set(cont,0) +if (ge(midspan1,midspan2)) { + if (lt(sub(midspan1,midspan2),lookup(diffs,"dist"))) { + set(cont,1) + } +} +if (ge(midspan2,midspan1)) { + if (lt(sub(midspan2,midspan1),lookup(diffs,"dist"))) { + set(cont,1) + } +} + if (and(eq(cont,1),eq(strcmp(pb1,pb2),0))) { + " possibly contemporary: " nl() + key(someone) " " name(someone) " " d(midspan1) " " pb1 nl() + key(another) " " name(another) " " d(midspan2) " " pb2 nl() + + } + } + } + } +} diff --git a/reports/extract_gedcom.ll b/reports/extract_gedcom.ll new file mode 100644 index 0000000..e8cb4ec --- /dev/null +++ b/reports/extract_gedcom.ll @@ -0,0 +1,53 @@ +/* + * @progname extract_gedcom.ll + * @version 1.2 of 1995-08-27 + * @author Scott McGee (smcgee@microware.com) + * @category + * @output GEDCOM + * @description + +This program allows the user to select a group of individuals from a database +and generate a GEDCOM file for them. It allows selection of multiple people +by following family links, and then allows addition of all ancestors of the +selected set or of the first individual, and then all descendants of the +selected set or of the orignal individual. It also allows addition of all +persons with a specified number of relations to any individual in any of the +groups added above. + +For each person asked about, you will be given some information on them to +aid in deciding if they are the one you want or not. This is similar to a +person display when browsing with LifeLines. + +This program will also output all source records referred to in any person +record in the gedcom output. + +Thanks to Tom Wetmore for many small routines that have been addapted for +use in this program as well as LifeLines itself. + +Scott McGee +*/ + +include("extract_set.li") +include("tools.li") +include("outsources.li") + +global(first) /* first person shouldn't be asked about */ +global(first_indi) /* starting person */ + +proc main () { + getindi(indi) + if (indi) { + set(first_indi, indi) + set(out, extract_set(indi)) + call extract_gedcom(indi, out) + } + else { + print("No one identified -- terminating\n") + } +} + +proc extract_gedcom(indi, out) { + print("Generating GEDCOM file for ", d(lengthset(out)), " individuals.\n") + gengedcom(out) + call outsources(out) +} diff --git a/reports/extract_html.ll b/reports/extract_html.ll new file mode 100644 index 0000000..a2d3dc9 --- /dev/null +++ b/reports/extract_html.ll @@ -0,0 +1,693 @@ +/* + * @progname extract_html.ll + * @version 1.4 + * @author Scott McGee (smcgee@microware.com) + * @category + * @output HTML + * @description + +This program allows the user to select a group of individuals from a database +and generate a set of HTML files for them. It allows writing multiple people +per HTML file, and will create an index file and a GENWEB.txt file for genweb +indexing of the resulting data. + +Before running this program, you will want to customize some global values +for your site. In the original release, they are set as follow: + + set(db_owner, getproperty("user.fullname")) + set(owner_addr, getproperty("user.email")) + set(use_image, 1) + set(genweb_image, "../../pics/genweb.gif") + set(use_page, 1) + set(genweb_page, "../genweb.html") + set(page_name, "genweb page") + set(html_index, 0) + +The first two sets will get your fullname and email address from the +corresponding user properties. They do not require editing this file. +The other customizations require editing of this file. +It also says to put an image at the top of each HTML file and specifies +that the image is called genweb.gif. Next, it specifies that a link to my +base page be added to each HTML file, that the location of the base page is +genweb.html, and that the text for the link be "genweb page". It also says +not to use and tag in the INDEX.html file. + +The program, when run, will request a person to start with. It then allows +selection of additional people by following family links. It then allows +addition of all ancestors of the selected set or of the first individual, +and then all descendants of the selected set or of the orignal individual. +It also allows addition of all persons with a specified number of relations +to any individual in any of the groups added above. + +For each person asked about, you will be given some information on them to +aid in deciding if they are the one you want or not. This is similar to a +person display when browsing with LifeLines. + +Note: This program will assume that you have a directory called genweb in your +output directory (as specified by LL_REPORTS) and will write all output files +in that directory. If the genweb directory does NOT exist (at least, with +LL302) you will be prompted for the name of each output file. Be aware that +if you use this to name the files diffently, the references within the files +will NOT be changed to reflect the new file name! + +Future Enhancements (Let me know if you want to do one of these for me!): + A hierarchical index would be a nice option. + Need to add descendant and ancestor (pedigree) charts. + Add seperate page(s) for sources and generate hyperlinks to them. + +Thanks to Tom Wetmore for many small routines that have been addapted for +use in this program as well as LifeLines itself. + +Scott McGee + +@(#)extract_html.ll 1.4 10/1/95 + +*/ + +include("extract_set.li") +include("tools.li") + +/* customization globals - customize values assigned in main */ +global(db_owner) /* name of database owner */ +global(owner_addr) /* url of database owner (mailto or homepage) */ +global(use_image) /* flag to indicate whether to use genweb image */ +global(genweb_image) /* name of genweb image to place on each page */ +global(use_page) /* flag to add link to genweb page or homepage */ +global(genweb_page) /* URL of base genweb (or homepage) web page */ +global(page_name) /* name of base genweb (or homepage) web page */ +global(LDS) /* display LDS Ordinances? (1=yes 0=no) */ +global(html_index) /* add tag to INDEX.html file (1=yes 0=no) */ + +/* other globals */ +global(found) /* external file to inline image found flag */ +global(per_file) /* number of people per file to write */ +global(first) /* first person shouldn't be asked about */ + +global(RVAL) /* ?? (part of borrowed code) */ +global(last_surname) /* last surname in index - used for anchors */ +global(first_indi) /* starting person */ + +proc main () { + + indiset(out_set) + +/* customize these globals to customize the output to your site */ + set(db_owner, getproperty("user.fullname")) + set(owner_addr, getproperty("user.email")) + set(use_image, 1) /* 1 to use image, 0 to not use image */ + set(genweb_image, "../../pics/genweb.gif") + set(use_page, 1) /* 1 to use link to page, 0 if not */ + set(genweb_page, "../genweb.html") + set(page_name, "genweb page") /* might change to "my homepage" */ + set(LDS, 1) + set(html_index, 0) /* 1 to use , 0 if not */ + + set(per_file, 1) + + getindi(indi) + if (indi) { + set(first_indi, indi) + set(out, extract_set(indi)) + call html_out(out) + } + else { + print("No one identified -- terminating\n") + } +} + +proc html_out (o) { + set(s, concat("There are ", d(lengthset(o)), + " people in your list, how many per file?")) + getstr(a,s) + set(per_file, atoi(a)) + if(not(per_file)) { + set(per_file, 1) + } + set(loop_count, 0) + set(file_count, 0) + set(href_table, init_href(o)) + forindiset(o, i, j, n) { + set(indi, i) + if(eq(loop_count, 0)) { + incr(file_count) + call write_head(file_count) + } + incr(loop_count) + call genhtml(indi, o, href_table) + if(or(eq(loop_count, per_file), eq(n, lengthset(o)))) { + call write_tail() + set(loop_count, 0) + } + } + + call do_index(o, href_table) + +} + +proc write_head(count) { + set(filename, concat("genweb/", database(), "/genweb_", d(count), ".html")) + print("Writing ", filename, "\n") + newfile(filename, 0) + "\n" + " genweb_" + d(count) + ".html \n" "\n" + if(use_image) { + "\"\"

      \n" + } +} + +proc write_tail() { + "
      \n" + date(gettoday()) + "
      \n" + "Database maintained by " + "\n" + db_owner + "
      \n" + "\n" +} + +proc genhtml (i, o, href_table) { +/* print(" ", fullname(i,0,1,300), "\n") */ + "\n" + "

      " + set(vn,givens(i)) + set(vn1,save(vn)) + givens(i) + " " + set(nn,surname(i)) + set(nn1,save(nn)) + nn1 + "

      \n" + set(path, get_picture(i)) + if (found) { + "\"\"

      \n" + } + call afn(i) + if (e, birth(i)) { + "Born : " long(e) "
      \n" + } + if (e, baptism(i)) { + "Baptised : " long(e) "
      \n" + } + elsif (e, bapt(i)) { + "Baptised : " long(e) "
      \n" + } + if (e, death(i)) { + "Died : " long(e) "
      \n" + } + if (e, burial(i)) { + "Buried : " long(e) "
      \n" + } + if(LDS) { + /* LDS ordinances */ + set(started, 0) + fornodes(inode(i), node) { + if (eq(0, strcmp(tag(node), "BAPL"))) { + if(not(started)) { + set(started, 1) + "
      LDS Ordinances: B " + } + } + /* determine if endowed */ + if (eq(0, strcmp(tag(node), "ENDL"))) { + if(not(started)) { + set(started, 1) + "
      LDS Ordinances: " + } + "E " + } + } + /* determine if sealed to parents */ + set(fam, fnode(parents(i))) + set(ind, inode(i)) + if(fam) { + fornodes(fam, node) { + if(and(eqstr("CHIL", tag(node)), eqstr(xref(ind), value(node)))) { + fornodes(node, next) { + if(eqstr(tag(next), "SLGC")) { + if(not(started)) { + set(started, 1) + "
      LDS Ordinances: " + } + "SC " + } + } + } + } + } + if(started){ + "
      \n" + } + } +/* "
      " */ + call othernames(i) + call print_html(i) + "
      \n" + if (p, father(i)) { + "" "Father : " + set (path, get_href(p, href_table)) + if(found) { + "" + } + if (t,title(p)) {t " "} + fullname(p,0,1,300) + if(found) {""} + do_info(p) + "
      \n" + } + if (p, mother(i)) { + "" "Mother : " + set (path, get_href(p, href_table)) + if(found) { + "" + } + if (t,title(p)) {t " "} + fullname(p,0,1,300) + if(found) {""} + do_info(p) + "
      \n" + } + families(i, f, s, n) { + "

      " "Spouse" + if (gt(nfamilies(i), 1)) { + " " + d(n) + } + " : \n" + if (s) { /* family has a spouse */ + set (path, get_href(s, href_table)) + if(found) { + "" + } + if (t,title(s)) {t " "} + fullname(s,0,1,300) + if(found) {""} + do_info(s) + "
      \n" + } + if (e, marriage(f)) { + "Married " + long(e) + "
      \n" + } + if (e, divorced(f)) { + "Divorced " + long(e) + "
      \n" + } + if(LDS) { + fornodes(fnode(f), node) { + if (eq(0, strcmp(tag(node), "SLGS"))) { + "
      LDS Ordinances: SS\n" + } + } + } + "

        \n" + children(f, c, nn) { + "
      1. " + set (path, get_href(c, href_table)) + if(found) { + "" + } + if (t,title(c)) {t " "} + fullname(c,0,1,300) + if(found) {""} + do_info(c) + "
        2. \n" + } + "
      \n" + } + call print_notes(i) + "
      \n" + +/* Insert code here for Pedigree and Descendant charts + if(parents(i)) { + "Pedigree Chart
      \n" + } + if(nfamilies(i)) { + set(hasChildren, 0) + families(i, f, s, n) { + if(nchildren(f)) { + set(hasChildren, 1) + } + } + if(hasChildren) { + "Descendant Chart\n" + } + } + "
      \n" +*/ + "
      \n" + "[" + "Index to database]
      \n" + if(use_page) { + "[" + "Return to " + page_name + " ]
      \n" + } + "

      \n" +} + +func init_href(outset){ + table(href_table) + + forindiset(outset, indi, j, number) { + insert(href_table, save(key(indi)), number) + } + return(href_table) +} + +func get_href(indi, href_table) { + set(path, "") + set(found, 0) + set(value, lookup(href_table, key(indi))) + if(value){ + set(number, add(div(sub(value, 1), per_file), 1)) + set(path, concat("genweb_", d(number), ".html")) + set(found, 1) + } + return(path) +} + +proc print_notes(indi){ + set(first, 1) + traverse(inode(indi), node, l) { + if (not(strcmp("NOTE", tag(node)))) { + if(first) { + "Notes :
      \n" + set(first, 0) + } + "

      " + call show_path(node) + value(node) + "\n" + fornodes(node, next) { + value(next) + "\n" + } + "

      \n" + } + } +} + +proc show_path (node){ + list(path) + while (node) { + push(path, tag(node)) + set(node, parent(node)) + } + "(" + while (s, pop(path)) { + if(eqstr(lower(s), "indi")){ + "Individual " + }elsif(eqstr(lower(s), "fam")){ + "Family " + }elsif(eqstr(lower(s), "famc")){ + "family " + }elsif(eqstr(lower(s), "fams")){ + "family " + }elsif(eqstr(lower(s), "note")){ + "note" + }elsif(eqstr(lower(s), "birt")){ + "birth " + }elsif(eqstr(lower(s), "deat")){ + "death " + }elsif(eqstr(lower(s), "buri")){ + "burial " + }elsif(eqstr(lower(s), "plac")){ + "place " + }else{ + lower(s) + " " + } + } + ")\n" +} + +proc do_index(indi_set, href_table) { + set(last_surname, "ZZ") + list(RVAL) + indiset(index) + + set(index, indi_set) + namesort(index) + print("Writing INDEX.html\n") + call create_index_file(index, href_table) + print("Writing GENDEX.txt\n") + call create_gendex_file(index, href_table) +} + +proc create_gendex_file(index, href_table) { + set(fn, save(concat("genweb/", database(), "/GENDEX.txt"))) + newfile(fn, 0) + forindiset(index, me, v, n) + { + set(path, concat(save(get_href(me, href_table)), "#", key(me))) + path + "|" + surname(me) + "|" + givens(me) " /" + surname(me) "/" + "|" + if (evt, birth(me)) { + date(evt) + } + "|" + if (evt, birth(me)) { + place(evt) + } + "|" + if (evt, death(me)) { + date(evt) + } + "|" + if (evt, death(me)) { + place(evt) + } + "|\n" + } +} + +proc create_index_file(index, href_table) { + set(fn, save(concat("genweb/", database(), "/INDEX.html"))) + newfile(fn, 0) + call html_header("Interactive Genealogical Server Index", html_index) + "\n" + if(use_image) { + "\"\"

      \n" + } + "

      INDEX

      \n" + "
        \n" + forindiset(index, me, v, n) + { + call href(me, href_table) + "\n" + } + "
      \n" + call write_tail() +} + +proc href(me, href_table) { + if(me) { + call print_name(me, 1) + if(ne(strcmp(upper(surname(me)), last_surname), 0)) { + print(" ", upper(surname(me)), "\n") + set(last_surname, save(upper(surname(me)))) + "\n" + } + "
    • " + set (path, get_href(me, href_table)) + if(found) { + "\n" + } + pop(RVAL) + if(found) { + "" + } + do_info(me) + } +} + +proc html_header(str, isindex) { + "\n" + "\n" + if(isindex) { + "\n" + } + " " + str + " \n" + "\n" + } + +proc print_name (me, last) { + call get_title(me) + set(junk, pop(RVAL)) + push(RVAL, save(concat(fullname(me, 1, not(last), 45), junk))) +} + +proc get_title (me) { + fornodes(inode(me), node) { + if (not(strcmp("TITL", tag(node)))) { + set(n, node) + } + } + if (n) { + push(RVAL, save(concat(" ", value(n)))) + } + else { + push(RVAL, "") + } +} + +proc rjt(n, w) { + if (lt(n, 10)) { + set(d, 1) + } + elsif (lt(n, 100)) { + set(d, 2) + } + elsif (lt(n, 1000)) { + set(d, 3) + } + elsif (lt(n, 10000)) { + set(d, 4) + } + else { + set(d, 5) + } + if (lt(d, w)) { + set(pad, save( trim(" ", sub(w, d)))) + } + else{ + set(pad, "") + } + push(RVAL, save( concat(pad, save(d(n))))) +} + +proc othernames(indi){ + if(indi){ + set(count, 0) + fornodes(inode(indi), subnode){ + if(eqstr(tag(subnode), "NAME")){ + incr(count) + if(eq(count, 2)){ + "
      Other Names: \n
        " + "
      • " + call nameval(subnode) + "
        • " + }elsif(gt(count, 2)){ + "
      • " + call nameval(subnode) + "
        • \n" + } + } + } + if(gt(count, 1)){ + "
      \n" + } + } +} + +proc afn(indi){ + if(indi){ + fornodes(inode(indi), subnode){ + if(eqstr(tag(subnode), "AFN")){ + "AFN " + value(subnode) + "

      \n" + } + } + } +} + +proc nameval(namenode){ + list(np) + extractnames(namenode, np, nc, sc) + forlist(np, v, i){ + v + " " + } +} + +proc print_html(indi){ + fornodes(inode(indi), node) { + if (not(strcmp("REPORT", tag(node)))) { + set(m, child(node)) + if (not(strcmp("TYPE", tag(m)))) { + if (not(strcmp("HTML", value(m)))) { + "
      \n" + fornodes(m, o) { + if (not(strcmp("DATA", tag(o)))) { + value(o) + "\n" + } + "\n" + } + } + else { + if (eqstr("HTML-STATIC", value(m))) { + "
      \n" + fornodes(m, o) { + if (eqstr("DATA", tag(o))) { + value(o) + "\n" + } + "\n" + } + } + } + } + } + } +} + +func divorced(fam) { + fornodes(fnode(fam), node) { + if (eq(0, strcmp(tag(node), "DIV"))) { + return(node) + } + } + return(0) +} diff --git a/reports/extract_set.li b/reports/extract_set.li new file mode 100644 index 0000000..d2f8956 --- /dev/null +++ b/reports/extract_set.li @@ -0,0 +1,270 @@ +/* + * @progname extract_set.li + * @version 1.5 + * @author Scott McGee (smcgee@microware.com) + * @category + * @output function values + * @description + +A library containing routines to allow extraction of a set of related persons +from a database. + +The function extract_set() is passed a starting indi, and traverses selected +persons relatives until no selections are left. It returns an indi set of +the selected persons. + +The do_info() function will return a string containing the name and birth/ +death type info on the indi passed as a parameter. + +@(#)extract_set.li 1.5 10/13/95 +*/ + +func extract_set(indi){ + list(w) /* working list */ + indiset(o) /* output set */ + indiset(out) /* output set */ + table(t) /* table of seen persons */ + indiset(us) /* temporary set */ + + set(first, 1) + set(count, 1) + enqueue(w, indi) + while (indi, dequeue(w)) { + if (not(lookup(t, key(indi)))) { + insert(t, key(indi), 1) + if (askabout(indi)) { + addtoset(o, indi, count) + incr(count) + if (j, father(indi)) { + enqueue(w, j) + } + if (j, mother(indi)) { + enqueue(w, j) + } + families(indi, f, s, n) { + if(s) { + enqueue(w, s) + } + children(f, j, m) { + enqueue(w, j) + } + } + } + } + } + print("You selected ", d(lengthset(o)), " individuals.\n") + set(useout, 0) + set(msg, "Do you want all the ancestors of these people added to this set? (y or n) ") + getstr(answer, msg) + if(eqstr(lower(trim(answer, 1)), "y")) { + set(anc, ancestorset(o)) + if(anc) { + print("Found ", + d(lengthset(difference(anc, intersect(anc, o)))), + " additional ancestors.\n") + set(out, union(o, anc)) + set(rel, get_relatives(out)) + if(rel){ + print("Found ", + d(lengthset(difference(rel, intersect(rel, out)))), + " additional relatives.\n") + set(out, union(out, rel)) + } + set(useout, 1) + }else{ + print("no ancestors found\n") + } + }else{ + set(msg, concat("Do you want all the ancestors of ", name(first_indi), + " added to this set? (y or n) ")) + getstr(answer, msg) + if(eqstr(lower(trim(answer, 1)), "y")) { + set(m, 1) + addtoset(us, first_indi, m) + if(us) { + set(anc, ancestorset(us)) + if(anc) { + print("Found ", + d(lengthset(difference(anc, intersect(anc, o)))), + " additional ancestors.\n") + set(out, union(o, anc)) + set(rel, get_relatives(out)) + if(rel){ + print("Found ", + d(lengthset(difference(rel, intersect(rel, out)))), + " additional relatives.\n") + set(out, union(out, rel)) + } + set(useout, 1) + }else{ + print("no ancestors found\n") + } + }else{ + print("error: nobody in 'us' set\n") + } + } + } + set(msg, "Do you want all the descendants of these people added to this set? (y or n) ") + getstr(answer, msg) + if(eqstr(lower(trim(answer, 1)), "y")) { + set(anc, descendantset(o)) + if(anc) { + if(useout){ + print("Found ", + d(lengthset(difference(anc, intersect(anc, out)))), + " additional descendants.\n") + set(out, union(out, anc)) + }else{ + print("Found ", + d(lengthset(difference(anc, intersect(anc, o)))), + " additional descendants.\n") + set(out, union(o, anc)) + } + set(rel, get_relatives(union(o, anc))) + if(rel){ + print("Found ", + d(lengthset(difference(rel, intersect(rel, out)))), + " additional relatives.\n") + set(out, union(out, rel)) + } + }else{ + print("no descendantss found\n") + } + }else{ + set(msg, concat("Do you want all the descendants of ", name(first_indi), + " added to this set? (y or n) ")) + getstr(answer, msg) + if(eqstr(lower(trim(answer, 1)), "y")) { + set(m, 1) + addtoset(us, first_indi, m) + if(us) { + set(anc, descendantset(us)) + if(anc) { + if(useout){ + print("Found ", + d(lengthset(difference(anc, intersect(anc, out)))), + " additional descendants.\n") + set(out, union(out, anc)) + }else{ + print("Found ", + d(lengthset(difference(anc, intersect(anc, o)))), + " additional descendants.\n") + set(out, union(o, anc)) + } + set(rel, get_relatives(anc)) + if(rel){ + print("Found ", + d(lengthset(difference(rel, intersect(rel, out)))), + " additional relatives.\n") + set(out, union(out, rel)) + } + }else{ + print("no descendants found\n") + } + }else{ + print("error: nobody in 'us' set\n") + } + } + if(not(useout)){ + set(out, o) + } + } + return(out) +} + +func askabout (indi) { + if(not(first)) { + call showinfo(indi) + set(s, concat("Do you want ", name(indi), + " in your output files? (y or n) ")) + getstr(a, s) + return (eqstr(lower(trim(a, 1)), "y")) + }else{ + set(first, 0) + return (1) + } +} + +proc showinfo (indi) { + print(name(indi), do_info(indi), " (", key(indi), ")\n\n") + set(did_afn, afn(indi)) + print("Father: ", name(father(indi)), do_info(father(indi)), "\n") + print("Mother: ", name(mother(indi)), do_info(mother(indi)), "\n\n\n\n\n\n\n") + set(f, 0) set(s, 0) + families(indi, fa, sp, n) { + if (eq(1, n)) { + set(f, fa) + set(s, sp) + } + } + print("Married: ", long(marriage(f)), "\n") + print("Spouse: ", name(s), do_info(s), "\n\n\n\n\n") + if(not(did_afn)){ + print("\n") + } +} + +func do_info(me){ + if(not(me)){ + return("") + }else{ + set(out, " -") + if (evt, birth(me)) { + set(out, concat(out, " born ", short(evt))) + } + else { + if (evt, baptism(me)) { + set(out, concat(out, " baptised ", short(evt))) + } + else { + if (evt, bapt(me)) { + set(out, concat(out, " baptised ", short(evt))) + } + } + } + if (evt, death(me)) { + set(out, concat(out, " died ", short(evt))) + } + return(out) + } +} + +func afn(indi){ + if(indi){ + fornodes(inode(indi), subnode){ + if(eqstr(tag(subnode), "AFN")){ + print("AFN ", value(subnode), "\n") + return(1) + } + } + } + return(0) +} + +func get_relatives(in_set){ + set(msg, "Do you want to add all relatives within a given link distance? (y or n) ") + getstr(answer, msg) + if(eqstr(lower(trim(answer, 1)), "y")) { + + getint(n, "Please enter link distance.") + + /* create set with all ancestors and descendents */ + + indiset(out_set) + indiset(t) /* temporary working set */ + + /* create set of additional, linked-to persons */ + + set(t, in_set) + while (gt(n, 0)) { + set(a, parentset(t)) + set(b, childset(t)) + set(c, spouseset(t)) + set(t, union(t, union(a, union(b, c)))) + set(n, sub(n, 1)) + } + set(out_set, t) + return(out_set) + } + return(0) +} diff --git a/reports/fam10c.ll b/reports/fam10c.ll new file mode 100644 index 0000000..82a5747 --- /dev/null +++ b/reports/fam10c.ll @@ -0,0 +1,103 @@ +/* + * @progname fam10c.ll + * @version 1.0 + * @author Manis + * @category + * @output Text + * @description + * + * Generates a Family Report for one family. + * + * fam10c + * by: Cliff Manis + * Family Report for LifeLines + */ + +proc main () +{ + getfam(fam) + dayformat(0) + monthformat(4) + dateformat(0) + set(tday, gettoday()) + set (nl,nl()) + set(h,husband(fam)) + set(w,wife(fam)) + col(55) "Date: " stddate(tday) nl + col(0) "Family Report (fam10)" + nl nl + col(0) "HUSBAND: " fullname(h,1,1,50) + col(63) "(RN=" key(h) ")" + nl nl + set(evt, birth(h)) + col(0) "Born: " stddate(evt) col(25) "Place: " place(evt) + set(evt, marriage(fam)) + col(0) "Marr: " stddate(evt) col (25) "Place: " place(evt) + set(evt, death(h)) + col(0) "Died: " stddate(evt) col(25) "Place: " place(evt) + nl nl + col(0) "HUSBAND'S FATHER: " name(father(h)) + col(63) "(RN=" key(father(h)) ")" + nl + col(0) "HUSBAND'S MOTHER: " name(mother(h)) + col(63) "(RN=" key(mother(h)) ")" + nl nl + col(0) "WIFE: " + if (w) { + fullname(w,1,1,50) + col(63) "(RN=" key(w) ")" + } + nl nl + set(evt, birth(w)) + col(0) "Born: " stddate(evt) col(25) "Place: " place(evt) + set(evt, death(w)) + col(0) "Died: " stddate(evt) col(25) "Place: " place(evt) + nl nl + col(0) " WIFE'S FATHER: " name(father(w)) + col(63) "(RN=" key(father(w)) ")" + col(0) " WIFE'S MOTHER: " name(mother(w)) + col(63) "(RN=" key(mother(w)) ")" + nl nl + col(0) "========================================================================" + nl + col(0) "# M/F" col(12) "Childrens Names" col(63) "RECORD NUM" + nl + col(0) "========================================================================" + nl + children(fam, child, num) { + col(0) d(num) + col(4) sex(child) + col(12) name(child) col(63) "(RN=" key(child) ")" + col(4) "Born:" col(13) stddate(birth(child)) + col(26) place(birth(child)) + nl + + col(4) "Died:" col(13) stddate(death(child)) + col(26) place(death(child)) + nl + + families(child, fvar, svar, num) { + if (eq(num,1)) { + col(4) "Marr:" col(13) stddate(marriage(fvar)) + col(26) if (svar) { name(svar) + col(63) "(RN=" key(svar) ")" } + else { " " } + nl + } + } + if (eq(nfamilies(child),0)) { " " nl } + col(4) "---------------------------------------------------------" + } +} + +/* End of Report */ +/* +-- +Cliff Manis K4ZTF Manis/Manes Family History +Researching: MANIS MANES MANESS MANAS WHITEHORN CANTER BIRD CORBETT NEWMAN + USMAIL: P. O. Box 33937, San Antonio, Texas 78265-3937 + INTERNET: cmanis@csoftec.csf.com +-=> Don't waste time learning the tricks of the trade, learn the trade ! + Standard Disclaimer: We are not associated with anyone. (PERIOD). (.) +-- +*/ diff --git a/reports/fam16rn1.ll b/reports/fam16rn1.ll new file mode 100644 index 0000000..5b0c012 --- /dev/null +++ b/reports/fam16rn1.ll @@ -0,0 +1,102 @@ +/* + * @progname fam16rn1.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output Text + * @description + * + * This program produces a family report of the person (husband), wife, + * their children, and some data about the children's marriages. + * It is presently designed for 16 pitch, HP laserjet III, + * printing a single page of information about that family. + * + * fam16rn1 + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * Modifications by Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * and it has been modified many times since. + * + * Output is an ASCII file. + * + */ + +proc main () +{ + getfam(fam) + + dayformat(0) + monthformat(4) + dateformat(0) + set(tday, gettoday()) + set (nl,nl()) + set(h,husband(fam)) + set(w,wife(fam)) + col(6) "Report by: Cliff Manis " + nl + col(19) "MANIS / MANES Family History" + col(50) "P. O. Box 33937 San Antonio, TX 78265-3937" + nl nl nl + col(6) "HUSBAND: " fullname(h,1,1,50) " (RN=" key(h) ")" + col(80) "Report date: " stddate(tday) + nl nl + set(evt, birth(h)) + col(6) "Born: " stddate(evt) col(35) "Place: " place(evt) + set(evt, marriage(fam)) + col(6) "Marr: " stddate(evt) col(35) "Place: " place(evt) + set(evt, death(h)) + col(6) "Died: " stddate(evt) col(35) "Place: " place(evt) + col(6) "HUSBAND'S" col(50) "HUSBAND'S" + col(6) "FATHER: " name(father(h)) " (RN=" key(father(h)) ")" + col(50) "MOTHER: " name(mother(h)) " (RN=" key(mother(h)) ")" + nl nl + col(6) "WIFE: " fullname(w,1,1,50) " (RN=" key(w) ")" + nl nl + set(evt, birth(w)) + col(6) "Born: " stddate(evt) col(35) "Place: " place(evt) + set(evt, death(w)) + col(6) "Died: " stddate(evt) col(35) "Place: " place(evt) + col(6) "WIFE'S" col(50) "WIFE'S" + col(6) "FATHER: " name(father(w)) " (RN=" key(father(w)) ")" + col(50) "MOTHER: " name(mother(w)) " (RN=" key(mother(w)) ")" + nl nl + col(6) "===============================================" + col(53) "=======================================" + col(92) "==========================" nl + col(8) "M/F" + col(22) "CHILDREN" + col(45) "WHEN BORN" + col(62) "WHEN DIED" + col(82) "WHERE BORN" + nl + col(45) "1st MARRIAGE" + col(62) "SPOUSE" + nl + col(6) "===============================================" + col(53) "=======================================" + col(92) "==========================" nl + children(fam, child, num) { + col(6) d(num) + col(9) sex(child) + col(11) name(child) " (RN=" key(child) ")" + col(45) stddate(birth(child)) + col(62) stddate(death(child)) + col(82) place(birth(child)) + families(child, fvar, svar, num) { + if (eq(num,1)) { + col(45) stddate(marriage(fvar)) + col(62) if (svar) { name(svar) " (RN=" key(child) ")" } + else { " " } + nl nl + } + } + if (eq(nfamilies(child),0)) { " " nl nl } + } +} + +/* End of Report */ + diff --git a/reports/fam_ged.ll b/reports/fam_ged.ll new file mode 100644 index 0000000..ce11b43 --- /dev/null +++ b/reports/fam_ged.ll @@ -0,0 +1,61 @@ +/* + * @progname fam_ged.ll + * @version 1.1 of 1994-06-08 + * @author Wetmore and Prinke + * @category + * @output GEDCOM + * @description + +This program extracts a gedcom file of all male line descendants +of a specified person, with their spouses and parents (including +those of the specified person and of all spouses). Also included +are possibly illegitimate children of females - when they have +the same surname as the mother but different than the father (also +if there is no father recorded). + +------------------------------------------------------------------- +fam_ged - a LifeLines family gedcom extraction program + +Version 1, 18 May 1994 by Thomas Wetmore IV, ttw@petrel.att.com + modified 8 June 1994 by Rafal T. Prinke, rafalp@plpuam11.bitnet + +*/ + +proc main () +{ + list(ilist) + indiset(idex) + getindi(indi) + enqueue(ilist, indi) + set(out,1) set(in,2) + while (indi, dequeue(ilist)) { + print("OUT: ", d(out), " ", name(indi), "\n") + addtoset(idex, indi, 0) + set(out, add(out, 1)) + if (male(indi)) { + families(indi, fam, spouse, nfam) { + children(fam, child, nchl) { + print("IN: ", d(in), " ", name(child), "\n") + set(in, add(in, 1)) + enqueue(ilist, child) + } + } + } + if (female(indi)) { + families(indi, fam, spouse, nfam) { + children(fam, child, nchl) { + if (eq(strcmp(surname(indi), surname(child)), 0)) { + if (ne(strcmp(surname(indi), surname(spouse)), 0)) { + print("INfem: ", d(in), " ", name(child), "\n") + set(in, add(in, 1)) + enqueue(ilist, child) + } + } + } + } + } + } + set(idex, union(idex, spouseset(idex))) + set(idex, union(idex, parentset(idex))) + gengedcom(idex) +} diff --git a/reports/famgroup.ll b/reports/famgroup.ll new file mode 100644 index 0000000..9157119 --- /dev/null +++ b/reports/famgroup.ll @@ -0,0 +1,211 @@ +/* + * @progname famgroup.ll + * @version 1.1 + * @author Kris Stanton + * @category + * @output TeX + * @description + * + * Family Group Sheet for LifeLines + * + * Minor fixes by Patrick Texier 12/28/2005 + * + * The output is in LaTeX format. Therefore, the name of the output file + * should end in ".tex". To print (assuming the name of the output file is + * "out.tex"): + * latex out + * dvips out -o out.ps + * lpr out.ps + * or if you have it, you can generate a pdf with + * pdflatex out + */ + +proc main () +{ + getfam(fam) + dayformat(0) + monthformat(6) + dateformat(0) + set(tday, gettoday()) + set (nl,nl()) + set(h,husband(fam)) + set(w,wife(fam)) + col(0) "\\documentclass[landscape]\{article\}" + col(0) "\\setlength\{\\topmargin\}\{-1.3in\}" + col(0) "\\setlength\{\\oddsidemargin\}\{-.8in\}" + col(0) "\\setlength\{\\evensidemargin\}\{-.8in\}" + col(0) "\\setlength\{\\textwidth\}\{11in\}" + col(0) "\\setlength\{\\textheight\}\{9in\}" + col(0) "\\pagestyle\{empty\}" + col(0) "\\begin\{document\}" + col(0) "\\begin{center}" + col(0) "\\bfseries \\Large Family Group Sheet" + col(0) "\\end{center}" nl nl + col(0) "\\begin\{tabular\}\{lp\{7.85in\}\}" + col(0) "\\bfseries \\Large Husband's Name & \\Large " + col(0) fullname(h,1,1,50) " (\\#"key(h)") \\\\ \\cline{2-2}" + col(0) "\\end{tabular}" nl nl + + set(evt, birth(h)) + col(0) "\\begin{tabular}{p{.25in}p{.87in}p{3.75in}p{.4in}p{3.75in}}" + col(0) "& When Born & " stddate(evt) " & Where & " + place(evt) " \\\\ \\cline{3-3} \\cline{5-5}" + + set(evt, death(h)) + col(0) "& When Died & " stddate(evt) " & Where & " + place(evt)" \\\\ \\cline{3-3} \\cline{5-5}" + + set(evt, burial(h)) + col(0) "& When Buried & " stddate(evt) " & Where & " + place(evt) " \\\\ \\cline{3-3} \\cline{5-5}" + + set(evt, marriage(fam)) + col(0) "& When Married & " stddate(evt) " & Where & " + place(evt)" \\\\ \\cline{3-3} \\cline{5-5}" + col(0) "\\end{tabular}" nl nl + + col(0) "\\begin{tabular}{p{.25in}lp{7.84in}}" + col(0) "& Other Wives (if any) & " + spouses (h, sname, famname, number) { + if (ne(w,sname)) { + "$\\triangleright$ " name(sname) + " \\hspace{.1in} " + } + } + " \\\\ \\cline{3-3}" + col(0) "\\end{tabular}" nl nl + + col(0) "\\begin{tabular}{p{.25in}p{.87in}p{3.75in}p{.68in}p{3.48in}}" + col(0) "& His Father & " name(father(h)) + if (father(h)) { " (\\#" key(father(h))")" } + " & His Mother & " name(mother(h)) + if (father(h)) { " (\\#" key(mother(h))")" } + " \\\\ \\cline{3-3} \\cline{5-5}" + col(0) "\\end{tabular}" nl nl + + col(0) "\\vspace{.1in}" + col(0) "\\begin{tabular}{lp{7.44in}}" + col(0) "\\bfseries \\Large Wife's Maiden Name & \\Large " + fullname(w,1,1,50) " (\\#"key(w)")" " \\\\ \\cline{2-2}" + col(0) "\\end{tabular}" nl nl + + set(evt, birth(w)) + col(0) "\\begin{tabular}{p{.25in}p{.87in}p{3.75in}p{.4in}p{3.75in}}" + col(0) "& When Born & " stddate(evt) " & Where & " + place(evt)" \\\\ \\cline{3-3} \\cline{5-5}" + + set(evt, death(w)) + col(0) "& When Died & " stddate(evt) " & Where & " + place(evt)" \\\\ \\cline{3-3} \\cline{5-5}" + + set(evt, burial(w)) + col(0) "& When Buried & " stddate(evt) " & Where & " + place(evt) " \\\\ \\cline{3-3} \\cline{5-5}" + col(0) "\\end{tabular}" nl nl + + col(0) "\\begin{tabular}{p{.25in}lp{7.6in}}" + col(0) "& Other Husbands (if any) & " + spouses (w, sname, famname, number) { + if (ne(h,sname)) { + "$\\triangleright$ " name(sname) + "\\hspace{.1in} " + } + } + " \\\\ \\cline{3-3}" + col(0) "\\end{tabular}" nl nl + + col(0) "\\begin{tabular}{p{.25in}p{.87in}p{3.75in}p{.7in}p{3.44in}}" + col(0) "& Her Father & " name(father(w)) + if (father(w)) { " (\\#" key(father(w))")" } + " & Her Mother &" name(mother(w)) + if (mother(w)) { " (\\#" key(mother(w))")" } + " \\\\ \\cline{3-3} \\cline{5-5}" + col(0) "\\end{tabular}" nl nl + + col(0) "\\vspace{.1in}" + col(0) "\\scriptsize" + col(0) "\\begin{tabular}{c|p{2.15in}|cp{.6in}p{.25in}|p{2in}|cp{.6in}p{.25in}|p{2.1in}} \\hline \\hline" + col(0) "M/F & Children & " + col(0) "\\multicolumn{3}{c|}{When Born} & Where Born & " + col(0) "\\multicolumn{3}{c|}{When Died} & Married \\\\ " + col(0) "& (in order of birth) & \\centering Day & \\centering Month & \\centering Year &" + col(0) "City/Town, County, State/Country & " + col(0) "\\centering Day & \\centering Month & \\centering Year & \\\\ \\hline \\hline" + + children(fam, child, num) { + set(ns, nspouses(child)) + families(child, fvar, svar, no) { + if(eq(1,ns)) { + col(0) "& (\\#"key(child)") & & & & & & & &\\small Date: " + stddate(marriage(fvar)) " \\\\" + } + if(and(gt(ns,1),eq(no,1))) { + col(0) "& (\\#"key(child)") & & & & & & & &\\small Date: " + stddate(marriage(fvar)) " $\\dagger$ \\\\" + } + } + if(eq(0,ns)) { + col(0) "& (\\#"key(child)") & & & & & & & & \\small Date: \\\\ " + } + + extractdate(birth(child), ddy, mmo, yyr) + col(0) "\\small " sex(child) "& \\small " d(num)" \\hspace{.1in}" + givens(child) nl + " & \\centering \\small " if(ne(ddy,0)) {d(ddy)} " & \\centering \\small " + if(eq(mmo,1)){ "January" } + if(eq(mmo,2)){ "February" } + if(eq(mmo,3)){ "March" } + if(eq(mmo,4)){ "April" } + if(eq(mmo,5)){ "May" } + if(eq(mmo,6)){ "June" } + if(eq(mmo,7)){ "July" } + if(eq(mmo,8)){ "August" } + if(eq(mmo,9)){ "September" } + if(eq(mmo,10)){ "October" } + if(eq(mmo,11)){ "November" } + if(eq(mmo,12)){ "December" } + " & \\centering \\small " if(ne(yyr,0)) {d(yyr)} + " & \\small " place(birth(child)) + if(death(child)) { + extractdate(death(child), ddy, mmo, yyr) + } + else { + set(ddy, 0) + set(mmo, 0) + set(yyr, 0) + } + col(0) " & \\centering \\small " if(ne(ddy,0)){d(ddy)} + " & \\small \\centering " + if(eq(mmo,1)){ "January" } + if(eq(mmo,2)){ "February" } + if(eq(mmo,3)){ "March" } + if(eq(mmo,4)){ "April" } + if(eq(mmo,5)){ "May" } + if(eq(mmo,6)){ "June" } + if(eq(mmo,7)){ "July" } + if(eq(mmo,8)){ "August" } + if(eq(mmo,9)){ "September" } + if(eq(mmo,10)){ "October" } + if(eq(mmo,11)){ "November" } + if(eq(mmo,12)){ "December" } + " & \\centering \\small " if(ne(yyr,0)){d(yyr)} + " & \\small To: " + families(child, fvar, svar, no) { + if(and(gt(ns,0),eq(no,1))) { + name(svar) " \\\\ \\hline "} + } + if(eq(0,ns)) { + " \\\\ \\hline "} + } + set(left, sub(14, nchildren(fam))) + while(gt(left, 0)) { + col(0) "& & & & & & & & &\\small Date: \\\\" + col(0) "&\\small " d(sub(15,left)) " & & & & & & & &\\small To: \\\\ \\hline" + set(left, sub(left,1)) + } + col(0) "\\end{tabular}" nl nl + col(0) "\\hspace{8in} \\scriptsize $\\dagger =$ more than one marriage" + col(0) "\\end{document}" nl +} + +/* End of Report */ diff --git a/reports/fami-grps.ll b/reports/fami-grps.ll new file mode 100644 index 0000000..3be467a --- /dev/null +++ b/reports/fami-grps.ll @@ -0,0 +1,409 @@ +/* + * @progname fami-grps.ll + * @version 1993-01-12 + * @author Stephen Woodbridge (woodbri@swoodbridge.com) + * @category + * @output Text, 80 cols + * @description + * + * Program walks thru one's families and dumps information + * about each family. It prunes the tree so an individual is + * only output once. The program lists all children of the + * families as it walks the tree. The "*" marker on a child + * signifies the line of descent/ascent. + * + * Output assumes 132 characters wide and 80 lines per page. + * + * Issues: + * + * o only one child is marked in line of descent regardless + * of the actual number of children one may descend from + * o notes or family group records grater than LPP are NOT + * paginated correctly + * o program does not walk thru descendants yet + * o does not output baptism or burial records + * o does not list other spouses of HUSBAND or WIFE + * + * Copyright 1993 Stephen Woodbridge + */ +global(UNKNOWN) +global(DONE) +global(ILIST) +global(NLIST) +global(RVAL) +global(nl) +global(ff) +global(PAGED) +global(PAGENO) +global(INDEXT) +global(INDEXS) +global(LPP) +global(LC) +global(NLF) +global(NLH) +global(NLW) +global(ONCE) + +proc main() +{ + table(DONE) + table(INDEXT) + indiset(INDEXS) + list(ILIST) + list(NLIST) + list(RVAL) + set(nl, "\n") + set(ff, "\f") + set(PAGED, 1) + set(PAGENO, 0) + set(LPP, 80) + set(LC, 0) + set(NLF, 0) + set(NLH, 0) + set(NLW, 0) + set(ONCE, 1) + + getindi(me) + getintmsg(max, " Maximum Depth :") + enqueue(ILIST, me) + enqueue(NLIST, 1) + set(i, 1) + while (me, dequeue(ILIST)) + { + set(depth, dequeue(NLIST)) + if (not(lookup(DONE, key(me)))) + { + call do_me(me, depth, max) + } + } + if (PAGED) { call print_index() } +} + +proc do_me(me, depth, max) +{ + call fam_group(parents(me), 1, me, depth) + if (le(add(depth, 1), max)) + { + if (dad, father(me)) + { + enqueue(ILIST, dad) + enqueue(NLIST, add(depth, 1)) + } + if (mom, mother(me)) + { + enqueue(ILIST, mom) + enqueue(NLIST, add(depth, 1)) + } + } +} + +proc fam_group(fam, notes, mchild, depth) +{ + if (fam) + { + call count_fgrp(fam, notes) + call fg_hdr(fam, depth) + call pparent(husband(fam), "HUSBAND:") + col(6) "M: " long(marriage(fam)) nl + call pparent(wife(fam), " WIFE:") + "CHILDREN:" nl + children(fam, ch, nc) + { + insert(DONE, save(key(ch)), 1) + call pchild(nc, ch, mchild) + } + if (notes) + { + call print_notes(husband(fam), "\nHusband: ", NLH) + call print_notes(wife(fam), "\n Wife: ", NLW) + } + } + else + { + if (mchild) + { + call fg_hdr(fam, depth) + call pparent(0, "HUSBAND:") + col(6) "M:" nl + call pparent(0, " WIFE:") + "CHILDREN:" nl + insert(DONE, save(key(mchild)), 1) + call pchild(1, mchild, mchild) + if (notes) + { + call print_notes(mchild, "\n Child: ", 0) + } + } + } +} + +proc addtoindex(me) +{ + addtoset(INDEXS, me, 1) + if (l, lookup(INDEXT, key(me))) + { + enqueue(l, PAGENO) + insert(INDEXT, save(key(me)), l) + } + else + { + list(l) + enqueue(l, PAGENO) + insert(INDEXT, save(key(me)), l) + } +} + +proc print_index() +{ + "\f------------------------ INDEX -----------------------------\n" + nl + namesort(INDEXS) + forindiset(INDEXS, me, v, n) + { + call print_name(me, 1) + pop(RVAL) col(50) + set(first, 1) + set(last, 0) + forlist(lookup(INDEXT, key(me)), pg, n) + { + if (ne(last, pg)) + { + if(first) { set(first, 0) } + else { "," } + d(pg) + set(last, pg) + } + } + nl + } +} + +proc fg_hdr(fam, depth) +{ + set(dash, " --------------------------- ") + if (PAGED) + { + if (and(gt(NLF, LC), lt(NLF, LPP))) + { + set(PAGENO, add(PAGENO, 1)) + if (ONCE) { set(ONCE, 0) } else { ff } + dash d(depth) dash col(80) "Page: " d(PAGENO) nl + set(LC, sub(LPP, NLF)) + } + else + { + dash d(depth) dash nl + set(LC, sub(LC, NLF)) + } + } + else + { + dash d(depth) dash nl + } +} + +proc count_fgrp(fam, notes) +{ + set(cnt, 13) + children(fam, ch, nc) + { + set(cnt, add(cnt, 3)) + set(cnt, add(cnt, nspouses(ch))) + } + set(NLF, cnt) + + call cnt_notes(husband(fam), notes) + set(NLH, pop(RVAL)) + + call cnt_notes(wife(fam), notes) + set(NLW, pop(RVAL)) +} + +proc cnt_notes(me, notes) +{ + set(c, 0) + if (and(me, notes)) + { + fornodes(inode(me), node) + { + if (not(strcmp("NOTE", tag(node)))) + { + set(c, add(c, 1)) + fornodes(node, next) + { + set(c, add(c, 1)) + } + } + } + } + if (c) { set(c, add(c, 2)) } + push(RVAL, c) +} + +proc pparent(me, hdr) +{ + if(me) + { + call get_refn(me) + call print_name(me, 1) + hdr col(10) pop(RVAL) col(55) "[" key(me) "]" col(62) pop(RVAL) nl + col(6) "B:" col(10) long(birth(me)) nl + col(6) "D:" col(10) long(death(me)) nl + call addtoindex(me) + if (fam, parents(me)) + { + if (i, husband(fam)) + { + call get_sdates(i) + call print_name(i, 1) + col(10) "FA:" col(15) pop(RVAL) col(60) pop(RVAL) nl + call addtoindex(i) + } + if (i, wife(fam)) + { + call get_sdates(i) + call print_name(i, 1) + col(10) "MO:" col(15) pop(RVAL) col(60) pop(RVAL) nl + call addtoindex(i) + } + } + } + else + { + hdr nl col(6) "B:" nl col(6) "D:" nl + } +} + +proc pchild(num, me, markme) +{ + if (eq(me, markme)) { set(m, "*") } else { set(m, " ") } + call print_name(me, 1) + call rjt(num, 2) + pop(RVAL) m sex(me) col(8) pop(RVAL) col(55) "[" key(me) "]" nl + col(6) "B:" col(10) long(birth(me)) nl + call addtoindex(me) + spouses(me, sp, fam, nf) + { + call print_name(sp, 0) + call addtoindex(sp) + col(6) "M:" d(nf) col(10) long(marriage(fam)) + " TO " pop(RVAL) " [" key(sp) "]" nl + } + col(6) "D:" col(10) long(death(me)) nl +} + +proc print_notes(me, string, nlines) +{ + if (me) + { + call paginate_notes(nlines) + call addtoindex(me) + set(hdr, 1) + fornodes( inode(me), node) + { + if (not(strcmp("NOTE", tag(node)))) + { + if (hdr) + { + call print_name(me, 1) + string pop(RVAL) " [" key(me) "]" nl + set(hdr, 0) + } + col(8) value(node) nl + fornodes(node, next) + { + col(8) value(next) nl + } + } + } + } +} + +proc paginate_notes(nlines) +{ + if (PAGED) + { + if (and(gt(nlines, LC), lt(nlines, LPP))) + { + set(PAGENO, add(PAGENO, 1)) + ff col(80) "Page: " d(PAGENO) nl + set(LC, sub(LPP, add(nlines, 1))) + } + else + { + set(LC, sub(LC, nlines)) + } + } +} + + +proc print_name (me, last) +{ + call get_title(me) + push(RVAL, save(concat(fullname(me, 1, not(last), 45), pop(RVAL)))) +} + +proc get_refn (me) +{ + fornodes( inode(me), node) + { + if (not(strcmp("REFN", tag(node)))) + { + set(refn, node) + } + } + if (refn) { push(RVAL, save(value(refn))) } + else { push(RVAL, "") } +} + + +proc get_title (me) +{ + fornodes(inode(me), node) + { + if (not(strcmp("TITL", tag(node)))) { set(n, node) } + } + if (n) { push(RVAL, save(concat(" ", value(n)))) } + else { push(RVAL, "") } +} + +proc get_sdates (me) +{ + if (e, birth(me)) { set(b, save(concat("( ", short(e)))) } + else { set(b, "( ") } + if (e, death(me)) { set(d, save(concat(" - " , short(e)))) } + else { set(d, " - ") } + push(RVAL, save(concat(b, concat(d, " )")))) +} + +proc get_ldates (me) +{ + if (e, birth(me)) { set(b, save(concat("( ", long(e)))) } + else { set(b, "( ") } + if (e, death(me)) { set(d, save(concat(" - " , long(e)))) } + else { set(d, " - ") } + push(RVAL, save(concat(b, concat(d, " )")))) +} + +proc get_dates (me) +{ + if (e, birth(me)) { set(b, save(concat("( ", date(e)))) } + else { set(b, "( ") } + if (e, death(me)) { set(d, save(concat(" - " , date(e)))) } + else { set(d, " - ") } + push(RVAL, save(concat(b, concat(d, " )")))) +} + +proc rjt(n, w) +{ + if (lt(n, 10)) { set(d, 1) } + elsif (lt(n, 100)) { set(d, 2) } + elsif (lt(n, 1000)) { set(d, 3) } + elsif (lt(n, 10000)) { set(d, 4) } + else { set(d, 5) } + if (lt(d, w)) + { set(pad, save( trim(" ", sub(w, d)))) } + else + { set(pad, "") } + push(RVAL, save( concat(pad, save(d(n))))) +} diff --git a/reports/familycheck.ll b/reports/familycheck.ll new file mode 100644 index 0000000..6f9062b --- /dev/null +++ b/reports/familycheck.ll @@ -0,0 +1,262 @@ +/* + * @progname familycheck.ll + * @version 2000-03-02 + * @author Dennis Nicklaus nicklaus@fnal.gov + * @category + * @output Text, 80 cols + * @description + * + Consistency checks between indi records and family records + (making sure links between kids and spouses go both ways.) + make sure each family that a person says he is a spouse of + has him as a spouse, and, vice-versa, + make sure each person that a family says is a spouse thinks he + is a spouse of that family + It also checks when a person says he is a child in a family that + the family has that person as a child. + And vice-versa, that every child in a family thinks he + is a child of that family. + + Written by Dennis Nicklaus nicklaus@fnal.gov, 1997. +*/ +/* Modifications: + * 02-mar-00 pbm report multiple HUSB, WIFE, FAMC + * 01-mar-00 pbm optionally allow SEX U, and missing SEX records + * 25-sep-99 pbm check for a child in a family more than once + * 19-feb-99 pbm check for multiple SEX records + * 13-feb-99 pbm report a child in family when reporting a family with + * no parents. + * always show keys of family and individual involved. + * display all messages on screen and write to file. + */ + +global(ALLOWSEXU) /* set to 1 if "SEX U" is allowed */ +global(WARNNOSEX) /* set to 1 to warn about INDIs with no SEX record */ + +proc main () +{ + /* user customization section. change the following if desired: */ + set(ALLOWSEXU, 1) /* 1: "SEX U" should not generate a warning */ + set(WARNNOSEX, 0) /* 0: don't warn if INDI has no SEX record */ + /* end of user customization section */ + + print("processing each person and family in the database...") + + forindi(person, number) { + + call checksex(person) + families(person, fam, spouse, nfam) { + set(okboss,0) + set(s, child(root(fam))) + while(s) { + if(or(eqstr(tag(s), "HUSB"), eqstr(tag(s), "WIFE"))) { + if(v, value(s)) { + if(reference(v)) { + if(eqstr(substring(v, 2,sub(strlen(v),1)),key(person))){ + set(okboss, add(okboss,1)) + } + } + } + } + set(s, sibling(s)) + } + if (eq(0,okboss)){ + print("\nperson ",key(person)," is not a spouse in ",key(fam)) + "person " key(person) " is not a spouse in " key(fam) nl() + } + elsif(ne(1,okboss)){ + print("\nperson ",key(person)," is a spouse in ",key(fam), + " ",d(okboss)," times") + "person " key(person) " is a spouse in " key(fam) + " " d(okboss) " times" nl() + } + + } + /* now check that this person is a child in the family + he thinks he is (and only once) */ + set(fcnt, 0) + set(s, child(root(person))) + while(s) { + if(eqstr(tag(s), "FAMC")) { + if(v, value(s)) { + set(fcnt, add(fcnt, 1)) + if(reference(v)) { + set(okboss,0) + children(fam(v),child,num){ + if (eq(person,child)) {set(okboss, add(okboss,1))} + } + set(x, substring(v, 2, sub(strlen(v),1))) + if (eq(0,okboss)){ + print("\nperson ",key(person)," is not in family ", x) + "person " key(person) " is not in family " x nl() + } + if (gt(okboss, 1)) { + print("\nperson ",key(person)," is in family ",x," ", + d(okboss), " times") + "person " key(person) " is in family " x " " + d(okboss) " times" nl() + } + } + } + } + set(s, sibling(s)) + } + if(gt(fcnt, 1)) { + print("\nperson ",key(person)," is a child in ", d(fcnt), " families") + "person " key(person) " is a child in " d(fcnt) " families" nl() + } + } + + /* now check families so that for every spouse the family says is in the + family, that spouse also thinks he/she is in the family. */ + /* the family keys aren't terribly useful in LL (or out since LL + will change the key numbers on import), so print out the key + of the indi involved, also */ + + forfam(fam, number) { + set(wcnt,0) + set(hcnt,0) + set(s, child(root(fam))) + while(s) { + if(or(eqstr(tag(s), "HUSB"), eqstr(tag(s), "WIFE"))) { + if(eqstr(tag(s), "HUSB")) { + set(hcnt, add(hcnt,1)) + if(gt(hcnt, 1)) { + print("\nfamily ",key(fam)," has more then one husband ", + substring(value(s), 2, sub(strlen(value(s)),1))) + "family " key(fam) " has more then one husband " + substring(value(s), 2, sub(strlen(value(s)),1)) + } + } + if(eqstr(tag(s), "WIFE")) { + set(wcnt, add(wcnt,1)) + if(gt(wcnt, 1)) { + print("\nfamily ",key(fam)," has more then one wife ", + substring(value(s), 2, sub(strlen(value(s)),1))) + "family " key(fam) " has more then one wife " + substring(value(s), 2, sub(strlen(value(s)),1)) + } + } + if(v, value(s)) { + if(reference(v)) { + set(i, indi(v)) + if(eq(i,0)) { + print("\nmissing person ",v," in family ",key(fam)) + "missing person " v " in family " key(fam) nl() + } + else { + set(okboss,0) + families(i, fam2, spouse, nfam) { + if (eq(fam,fam2)){ set(okboss,add(okboss,1))} + } + if(eq(okboss, 0)) { + print("\nperson ",key(i), + " is not linked as a spouse to family ", key(fam)) + "person " key(i) + " is not linked as a spouse to family " key(fam) + } + if(gt(okboss, 1)) { + print("\nperson ",key(i), + " is linked as a spouse to family ", key(fam), + " ",d(okboss)," times") + "person " key(i) + " is linked as a spouse to family " key(fam) + " " d(okboss) " times" + } + } + } + } + } + set(s, sibling(s)) + } + if (eq(add(hcnt, wcnt),0)) { + print("\nno parents in family ",key(fam)) + "no parents in family " key(fam) + children(fam,child,num){ + print(" ",key(child)) + " " key(child) + break() + } + nl() + } + children(fam,child,num) { + set(ccnt, 0) + set(s, child(root(child))) + while(s) { + if(eqstr(tag(s), "FAMC")) { + if(v, value(s)) { + if(reference(v)) { + if(eqstr(substring(v,2,sub(strlen(v),1)), key(fam))) { + set(ccnt, add(ccnt, 1)) + } + } + } + } + set(s, sibling(s)) + } + if(eq(ccnt,0)) { + print("\nchild ",key(child)," is not linked to family ",key(fam)) + "child " key(child) " is not linked to family " key(fam) nl() + } + if(gt(ccnt,1)) { + print("\nchild ",key(child)," is linked to family ",key(fam), + " ", d(ccnt)," times") + "child " key(child) " is linked to family " key(fam) + " " d(ccnt) " times" nl() + } + } + } +} + +proc checksex(i) +{ + set(val, "") + set(count, 0) + set(r, inode(i)) + traverse (r, n, x) { + if(eqstr(tag(n), "SEX")) { + set(count, add(count,1)) + if(eq(value(n),0)) { + print("\nSEX record with no value ",key(i)) + "SEX record with no value " key(i) nl() + } + elsif(or(eqstr(value(n), "M"), eqstr(value(n), "F"), + eqstr(value(n), "?"), + and(ALLOWSEXU,eqstr(value(n), "U")))) { + if(and(ne(count, 1),not(eqstr(value(n),val)))) { + print("\nconflicting SEX records ",val," and ",value(n)," ",key(i)) + "conflicting SEX records " val " and " value(n) " " key(i) nl() + } + set(val,value(n)) + } + else { + print("\nSEX record with unrecognize value ",value(n)," ",key(i)) + "SEX record with unrecognize value " value(n) " " key(i) nl() + set(val,value(n)) + } + } + } + if(and(WARNNOSEX, eq(count, 0))) { + print("\nno SEX record ",key(i)) + "no SEX record " key(i) nl() + } + elsif(gt(count,1)) { + print("\ntoo many SEX records (",d(count),") ",key(i)) + "too many SEX records (" d(count) ") " key(i) nl() + } +} + +proc countnodes(n) +{ + set(count, 0) + if(n) { + set(count, 1) + set(t, tag(n)) + while(s, sibling(n)) { + if(eqstr(tag(s), t)) { + set(count, add(count,1)) + } + } + } + return(count) +} diff --git a/reports/familyisfm1.ll b/reports/familyisfm1.ll new file mode 100644 index 0000000..8115cd4 --- /dev/null +++ b/reports/familyisfm1.ll @@ -0,0 +1,95 @@ +/* + * @progname familyisfm1.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output Text, 132 cols + * @description + * + * It will produce a report of all the INDI's in the database, + * in the format as seen at end of report. May be sorted easily + * to see the Father or Mother column sorted report. + * The report name come from: isfm (Indi Spouse Father Mother) + * It is designed for 16 pitch, HP laserjet III, 132 column + * (ASCII output). + * + * familyisfm1 + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * Modifications by Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1991, + * and it has been modified many times since. + * + */ + + +/* + * familyisfm1 + */ + +proc main () +{ + indiset(idx) + forindi(indi,n) { + addtoset(idx,indi,n) + print(d(n)) print(" ") + } + print(nl()) + print("begin sorting") print(nl()) + namesort(idx) + print("done sorting") print(nl()) + col(1) "INDEX OF ALL PERSONS IN DATABASE" + col(1) "Individual" + col(34) "Brth" + col(39) "Deat" + col(44) "First Spouse" + col(75) "Father" + col(106) "Mother" + col(1) "----------------------------------------" + "----------------------------------------" + "----------------------------------------" + forindiset(idx,indi,v,n) { + col(1) fullname(indi,1,0,29) + col(34) year(birth(indi)) + col(39) year(death(indi)) + if(gt(nspouses(indi), 0)) { + spouses(indi, spou, fam, n) { + if (eq(1,n)) { + col(44) fullname(spou,1,0,29) + } + } + } + if(fath,father(indi)) { + col(75) fullname(fath,1,0,29) + } + if(moth,mother(indi)) { + col(106) fullname(moth,1,0,29) + } + } + nl() + print(nl()) +} + +/* Sample output of this report. + +INDEX OF ALL PERSONS IN DATABASE +Individual Brth Deat First Spouse Father Mother +------------------------------------------------------------------------------------------------------------------------ +CUNNINGHAM, Margaret COLQUHOUN, Sir_John +DE_COLQUHOUN, Sir_Humphry 1280 1330 DE_COLQUHOUN, Sir_Ingelramus +DE_COLQUHOUN, Sir_Ingelramus 1250 DE_COLQUHOUN, Sir_Robert +DE_COLQUHOUN, Sir_Robert 1310 1390 ____, Lady_of_Luss DE_COLQUHOUN, Sir_Humphry +DE_COLQUHOUN, Sir_Robert 1220 1280 DE_KILPATRICK, Umfridus +DE_KILPATRICK, Umfridus 1190 1260 +DENTON, Denise Marie 1955 MANESS, Marion +DOUGLAS, Archibald DUNBAR, Elizabeth +DUNBAR, Elizabeth 1485 DOUGLAS, Archibald DUNBAR, James +HAMILTON, Judith 1662 CALHOUN, Alexander + +*/ + +/* End of Report */ + diff --git a/reports/famrep.ll b/reports/famrep.ll new file mode 100644 index 0000000..0a16101 --- /dev/null +++ b/reports/famrep.ll @@ -0,0 +1,453 @@ +/* + * @progname famrep.ll + * @version 6.3 + * @author James P. Jones (jjones@nas.nasa.gov) + * @category + * @output nroff + * @description + * + * This report program produces a Family Group Sheet for the selected + * individual, with options for generating sheets for married children + * of the individual, and their children, etc. + * + * This report works only with the LifeLines Genealogy program + * + * version two: 1 Nov 1992 + * version three: 28 Mar 1993 bug fixes + * version four: 25 Apr 1993 added sources + * version five: 26 Sep 1993 added multiple indi's, bug fix + * version six: 3 Oct 1993 bug fixes + * + * This report program produces a Family Group Sheet for the selected + * individual. User is given the choice of having sheets generated for + * married children of individual, and the children of the children, etc. + * Sources of information are indicated with end-note style + * references. The report produces 'roff output, which I suggest you + * convert to postscript for the highest quality report. Following are + * several examples how to process and print the report (assuming the + * output file name is "fam.out": + * + * tbl fam.out | xroff -me -tstdout | ipr -Pim7 -D"jobheader off" + * tbl fam.out | xroff -me -PprinterName + * tbl fam.out | groff -me | your_postscript_printer + * tbl fam.out | troff -me | dpost | lp -dps + * + * The data in "compiler" table in main() is initialized with property's + * obtained from the lifelines config file (~/.linesrc on unix else + * lines.cfg) with values from + * user.fullname + * user.email + * user.address + * user.phone + */ + +global(sourcelist) /* list of all sources used */ +global(sourcestr) +global(compiler) +global(TRUE) +global(FALSE) +global(ONCE) + +proc main () +{ + monthformat(4) + dateformat(0) + set(TRUE, 1) + set(FALSE, 0) + set(ONCE, TRUE) + list(sourcelist) + + table(compiler) + insert(compiler, "name", getproperty("user.fullname")) + insert(compiler, "addr", getproperty("user.address")) + insert(compiler, "phone", getproperty("user.phone")) + insert(compiler, "email", getproperty("user.email")) + + set(indi, NULL) + while (eq(strcmp(name(indi), NULL), 0)) { + getindi(indi) /* select individual for report */ + if (eq(strcmp(name(indi), NULL), 0)) { + print("Individual not found in database.") + print(nl()) + } + } + while (or(lt(ionly,1), gt(ionly,2))) { + getintmsg(ionly,"Choose (1) Individual only, (2) + Married Descendents: ") + } + if (eq(ionly, 2)) { + set(sonly,0) + while (or(lt(sonly,1), gt(sonly,2))) { + getintmsg(sonly,"Choose (1) Select Spouse, (2) All Spouses: ") + } + } + else { + set(sonly, 1) + } + call FGsheet(indi, ionly, sonly) + print("Report Done, ") +} + +/* Select the individual's spouse for the Family Group Sheet. + */ +proc FGsheet(indi, ionly, sonly) +{ + if (eq(sonly, 1)) { + set(i, nspouses(indi)) + spouses(indi, svar, fvar, no) { /* display spouses */ + if (gt(i, 1)) { + if (gt(no, 7)) { /* leave space for prompt */ + print(nl()) + print(nl()) + print(nl()) + print(nl()) + } + print(d(no)) + print(". ") + print(fullname(svar,TRUE,FALSE,50)) + print(nl()) + } + } + if (gt(i, 1)) { /* select a spouse */ + getintmsg(num, "Choose which spouse for Family Report: ") + } + else { + set(num, 1) + } + if (lt(i, 1)) { + print(name(indi)) + print(" has no spouse in database...") + print(nl()) + } + else { + if (eq(ONCE, TRUE)) { + ".po 0.8i" nl() + ".ll 6.8i" nl() + ".pl +1.5i" nl() + ".nf" nl() + + set(ONCE, FALSE) + } + } + } + spouses(indi, svar, fvar, no) { + if (or(and(eq(sonly,1), eq(no, num)), eq(sonly,2))) { + if (eq(strcmp(sex(indi), "F"), 0)) { + set(tmp, indi) /* Check sex of individual,*/ + set(tindi, svar) /* if Female, replace with */ + set(tsvar, tmp) /* information on husband. */ + set(i, nspouses(tindi)) /* Easier if assume head- */ + set(num, 1) /* of-household is male... */ + if (gt(i, 1)) { + spouses(tindi, tmps, tmpf, no) { + if (eq(name(tsvar), name(tmps))) { + set(num, no) + } + } + } + call doform(tindi, tsvar, fvar, i, num) + } + else { + call doform(indi, svar, fvar, i, num) + } + call printsources(sourcelist) + while (not(empty(sourcelist))) { /* NULL out sources each time */ + set(nil, dequeue(sourcelist)) + set(sourcestr, NULL) + } + ".bp" nl() + + if (eq(ionly, 2)) { + children(fvar, kid, j) { + if(or(ge(nspouses(kid),1), ge(nfamilies(kid),1))) { + call FGsheet(kid, ionly, 2) + } + } + } + } + } +} + +/* Produce the Family Group Sheet form. + */ +proc doform(indi, svar, fvar, numsp, cursp) +{ + ".ps 16" nl() + ".(b C" nl() + if (e, surname(indi)) { upper(surname(indi)) } + "\\0FAMILY\\0GROUP\\0SHEET" nl() + ".ps 10" nl() + "Compiled by: \\fI" lookup(compiler, "name") "\\fR\\0on\\0\\fI" + stddate(gettoday()) + "\\fR" nl() + ".vs 10" nl() + "\\fI" lookup(compiler, "addr") "\\fR" nl() + "\\fIPhone:\\0" lookup(compiler, "phone") "\\0\\0\\0E-mail:\\0" + lookup(compiler, "email") "\\fR" nl() + ".)b" nl() + ".ps 8" nl() + ".TS" nl() + "tab(+) expand box;" nl() + "l s s." nl() + "Husband's Full Name:\\0\\fI" + if (e, name(indi)) { name(indi) "\\fR" nl() } + else { "\\fR" } + "_" nl() + ".T&" nl() + "l | l | l." nl() + "Husband's Data+Day Month Year+City,\\0\\0Town or Place\\0\\0County or Province\\0\\0State or Country" nl() + "_" nl() + "\\0Birth+\\fI" + set(aday, birth(indi)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() /* note: first call to source */ + "_" nl() + "\\0Christened+\\fI" + set(aday, baptism(indi)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + "_" nl() + "\\0Married+\\fI" + set(aday, marriage(fvar)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + "_" nl() + "\\0Death+\\fI" + set(aday, death(indi)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + "_" nl() + "\\0Burial+\\fI" + set(aday, burial(indi)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + "_" nl() + ".T&" nl() + "l | l s." nl() + "\\0Father's Name:+\\fI" + if (e, name(father(indi))) { name(father(indi)) "\\fR" nl() } + else { "\\fR" nl() } + "_" nl() + "\\0Mother's Maiden Name:+\\fI" + if (e, name(mother(indi))) { name(mother(indi)) "\\fR" nl() } + else { "\\fR" nl() } + "_" nl() + "\\0Other Wives:\\fI" + set(f, 0) + set(spstr, save(name(wife(fvar)))) + spouses(indi, wifenm, tmpfvar, no) { + set(wstr, save(name(wifenm))) + if (ne(strcmp(spstr, wstr), 0)) { + "\\fI+" + name(wifenm) + "\\fR" nl() + set(f,1) + } + } + if (eq(f, 0)) { "\\fR" nl() } + "_" nl() + ".TE" nl() + ".TS" nl() + "tab(+) expand box;" nl() + "l s s." nl() + "Wife's Full Maiden Name:\\0\\fI" + if (e, name(svar)) { name(svar) } + "\\fR" nl() + "_" nl() + ".T&" nl() + "l | l | l." nl() + "Wife's Data +Day Month Year+City,\\0\\0Town or Place\\0\\0County or Province\\0\\0State or Country" nl() + "_" nl() + "\\0Birth+\\fI" + set(aday, birth(svar)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + "_" nl() + "\\0Christened+\\fI" + set(aday, baptism(svar)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + "_" nl() + "\\0Death+\\fI" + set(aday, death(svar)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + "_" nl() + "\\0Burial+\\fI" + set(aday, burial(svar)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + "_" nl() + ".T&" nl() + "l | l s." nl() + "\\0Father's Name:+\\fI" + if (e, name(father(svar))) { name(father(svar)) "\\fR" nl() } + else { "\\fR" nl() } + "_" nl() + "\\0Mother's Maiden Name:+\\fI" + if (e, name(mother(svar))) { name(mother(svar)) "\\fR" nl() } + else { "\\fR" nl() } + "_" nl() + "\\0Other Husbands:\\fI" + set(f, 0) + set(spstr, save(name(indi))) + spouses(svar, hubby, tmpfvar, no) { + set(hstr, save(name(hubby))) + if (ne(strcmp(spstr, hstr), 0)) { + "\\fI+" + name(hubby) + "\\fR" nl() + set(f,1) + } + } + if (eq(f, 0)) { "\\fR" nl() } + "_" nl() + ".TE" nl() + /* now for the children... */ + set(haschild, 1) + children(fvar, cvar, no) { + if (eq(haschild, 1)) { + ".TS" nl() + "tab(+) expand box;" nl() + "l |l| l | l | l." nl() + "Complete Names of All Children+Sex+Event+Date+" + "City, Town, County, State or Country" nl() + "_" nl() + set(haschild, 2) + } + + if (or(eq(no, 4), eq(no, 12))) { /* If 4th or 12th kid, start */ + ".TE" nl() /* a new page. There was an */ + ".bp" nl() /* old woman, who lived in a */ + ".TS" nl() /* shoe, she had so many kids... */ + "tab(+) expand box;" nl() + "l |l| l | l | l." nl() + "Complete Names of All Children+Sex+Event+Date+" + "City, Town, County/Province, State, Country" nl() + "_" nl() + } + "T{" nl() + "\\fI(" + d(no) + ") " + if (e, name(cvar)) { name(cvar) } + "\\fR" nl() + "T}+\\fI" + sex(cvar) + "\\fR+Birth+\\fI" + set(aday, birth(cvar)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + "_" nl() + "\\^+\\^+Death+\\fI" + set(aday, death(cvar)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + "_" nl() + "\\^+\\^+Burial+\\fI" + set(aday, burial(cvar)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, place(aday)) { place(aday) } "\\fR" + if (aday) { call dosource(aday) } nl() + + families(cvar, cfvar, csvar, no) { /* spouses */ + "_" nl() + "\\^+\\^+Marriage+\\fI" + set(aday, marriage(cfvar)) + if (e, stddate(aday)) { stddate(aday) } + "+" + if (e, name(csvar)) { name(csvar) } + if (aday) { call dosource(aday) } + "\\fR" nl() + } + "=" nl() + } + if (eq(haschild, 2)) { + ".TE" nl() + } +} + + +/* Short macro procedure to combine SOURCE and SOURCENUM calls, to shorten + * above report code. + */ +proc dosource(eventnode) +{ + call source(eventnode) /* get source of data */ + if (sourcestr) { /* if source not NULL */ + call sourcenum() /* print source number */ + } +} + +/* Retrieve source from a given event (EVENTNODE), and save it in the global + * string SOURCESTR. + */ +proc source(eventnode) +{ + set(sourcestr, NULL) + traverse(eventnode, node, lev) { + if (eq(strcmp(tag(node), "SOUR"), 0)) { + set(sourcestr, value(node)) + } + } +} + +/* Create a "List of Sources" table for the report; in the report itself, + * print only a footnote number, and later the list these number refer to + * can be printed (via PRINTSOURCES). + */ +proc sourcenum() +{ + set(found,0) + forlist(sourcelist, item, i) { + set(numsources,i) + if (eq(strcmp(item, sourcestr), 0)) { /* if source in list */ + " \\s7(" d(i) ")\\s8" /* print out source index */ + set(found, 1) + } + } + if (not(eq(found, 1))) { + push(sourcelist, sourcestr) /* otherwise add it to list */ + " \\s7(" d(add(numsources,i,1)) ")\\s8" /* and print source index */ + } +} + +/* Print a list of all the sources refered to in the document. The numbers + * preceeding each source entry are what the in-line references refer to. + */ +proc printsources(slist) +{ + if (not(empty(slist))) { + ".(b C" nl() + "LIST OF SOURCES REFERENCED IN THIS REPORT" nl() + ".)b" nl() + forlist(slist, item, i) { + "(" d(i) ") " item nl() + } + } +} + +/* End of Report + */ diff --git a/reports/famtree1.ll b/reports/famtree1.ll new file mode 100644 index 0000000..209de11 --- /dev/null +++ b/reports/famtree1.ll @@ -0,0 +1,946 @@ +/* + * @progname famtree1.ll + * @version 2 + * @author James P. Jones, jjones@nas.nasa.gov + * @category + * @output PostScript + * @description + * + * This report builds a postscript ancestry chart, a "tree", containing + * data on five generations. It prompts for the individual to begin with + * and draws the tree including this person. The further from this person + * the less data is printed. Maximum data include: + * o date and place of birth + * o date and place of marriage + * o date and place of death + * o last place of residence + * o spouses of person #1 (up to five) + * as well as: + * o name, address, phone number and e-mail address of compiler + * o date of chart + * + * version one: 9 May 1993 + * + * Code by James P. Jones, jjones@nas.nasa.gov + * + * Contains code from: + * "famrep4" - By yours truely, jjones@nas.nasa.gov + * "pedigree" - By Tom Wetmore, ttw@cbnewsl.att.com + * - and Cliff Manis, cmanis@csoftec.csf.com + * "ancestor.ps" - orginial postscript program by Phil Lloyd, + * lloyd@prl.philips.co.uk (See disclaimer below). + * + * + * This report works only with the LifeLines Genealogy program + * + * Note: + * + * o Change the "compiler" data below to reflect yourself. + * o In order to take advantage of the "residence" slots on the chart, + * use either ADDR (address) or ADDL (address living) tags in your + * database, e.g.: + * + * 1 ADDL + * 2 DATE 20 Jun 1992 + * 2 PLAC 619 W Remington Drive, Sunnyvale, CA 94087 + * + * Put the full address on one line, separated by commas (,) and this + * program will parse the street address from the city/state/zip for + * the report. + */ + +/* +* Updated the filename to famtree2 after fixing problems with list vs +* table variables. 22 September 2002. Paul Buckley. +*/ + +global(chart) +global(id) +global(savfam) +global(addrnode) +global(compiler) + +proc main () +{ + dayformat(2) + monthformat(6) + dateformat(0) + set(addrnode, NULL) + + /* + * Change the compiler name, address, phone, and email to reflect + * yourself. + */ + table(compiler) + insert(compiler,"name", getproperty("user.fullname")) + insert(compiler,"addr", getproperty("user.address")) + insert(compiler,"phone", getproperty("user.phone")) + insert(compiler,"email", getproperty("user.email")) + + getindi(indi) + if (eq(indi, NULL)) { + print("Individual not found...try again.") + print(nl()) + } + else { + table(chart) + print("Creating chart...") + call buildlist(0, 1, indi) + call doheader() + call dochart() + print("done.") + print(nl()) + } +} + +/* + * Load global array (chart) with all INDI records of all direct ancestors + * for individual, (indi + 4 generations), indexed by ah number. + */ +proc buildlist(in, ah, indi) +{ + if (par, father(indi)) { + if (lt(ah, 16)) { + call buildlist(add(1,in), mul(2,ah), par) + } + } +/* setel(par, ah, indi)*/ +/* setel(chart, ah, indi)*/ + insert(chart, d(ah), indi) + + + if (par, mother(indi)) { + if (lt(ah, 16)) { + call buildlist(add(1,in), add(1,mul(2,ah)), par) + } + } +} + +/* + * Find last residence of PERSON by traversing all ADDR and ADDL nodes; + * save result in global addrnode variable. + */ +proc residence(person) +{ + if (not(person)) { + set(addrnode, NULL) + } + else { + traverse(inode(person), node, lev) { + if (or(eq(strcmp(tag(node),"ADDR"),0),eq(strcmp(tag(node),"ADDL"),0))) { + set(addrnode, node) + } + } + } +} + +/* + * Write postscript header to output file. This is database independant + * code. The actual genealogical data will be added below. + */ +proc doheader() +{ + "%! " nl() + "% famtree.ps " nl() + "% " nl() + "% This postscript Ancestry Chart was produced by the LifeLines report " nl() + "% program, famtree1, by James P. Jones. The orginal postscript code " nl() + "% was written by Phil Lloyd 11th November 1986, the blanks filled in " nl() + "% with data extracted from a LifeLines Genealogy database. " nl() + "% ------------------------------------------------------------------- " nl() + "% " nl() + "% This original PostScript program was written by Phil Lloyd. " nl() + "% It may be freely copied, distributed and used, provided these comments " nl() + "% remain unchanged, and that no fee of any kind is charged for the " nl() + "% software. " nl() + "% " nl() + "% (Except for VERY long names, it should always be possible to condense the " nl() + "% text to fit into the boxes, without sacrificing readability [by changing " nl() + "% the font/point size].) " nl() + "% " nl() + "% lloyd@prl.philips.co.uk " nl() + " " nl() + "% create a standard 1 point Helvetica-Bold font " nl() + "/bold /Helvetica-Bold findfont def " nl() + " " nl() + "% create a standard 1 point Helvetica-Oblique font " nl() + "/ital /Helvetica-Oblique findfont def " nl() + " " nl() + "% box procedure " nl() + "% 5 arguments: x and y of middle of left-hand side " nl() + "% n: entry number ( 1 - 31 ) " nl() + "% style: font (bold or ital) " nl() + "% point: point size (vertical) " nl() + "% cond: `point size' (horizontal) " nl() + "% p: person's name " nl() + "/mtrx matrix def " nl() + "/box " nl() + " { /p exch def " nl() + " /cond exch def /point exch def /style exch def " nl() + " /n exch def /y exch def /x exch def " nl() + " " nl() + " /savematrix mtrx currentmatrix def " nl() + " " nl() + " 0 setlinewidth " nl() + " " nl() + " /d 16 def /str 2 string def " nl() + " /w 170 def /h 14 def /hh h 2 div def /brad 3 def " nl() + " x y translate " nl() + " " nl() + " n 0 ne { " nl() + " % black box for number " nl() + " newpath " nl() + " 0.0 0.0 moveto " nl() + " 0.0 hh d hh brad arcto 4 {pop} repeat " nl() + " d hh d hh neg brad arcto 4 {pop} repeat " nl() + " d hh neg 0.0 hh neg brad arcto 4 {pop} repeat " nl() + " 0.0 hh neg 0.0 0.0 brad arcto 4 {pop} repeat " nl() + " 0.0 0.0 lineto " nl() + " fill " nl() + " " nl() + " % white number " nl() + " /Helvetica findfont 10 scalefont setfont " nl() + " 0.0 hh neg moveto " nl() + " n str cvs " nl() + " dup stringwidth pop " nl() + " neg d add 2 div -3.5 moveto " nl() + " 1.0 setgray show 0.0 setgray " nl() + " } if " nl() + " " nl() + " % box for name " nl() + " newpath " nl() + " d 0.0 moveto " nl() + " d hh w hh brad arcto 4 {pop} repeat " nl() + " w hh w hh neg brad arcto 4 {pop} repeat " nl() + " w hh neg d hh neg brad arcto 4 {pop} repeat " nl() + " d hh neg d 0.0 brad arcto 4 {pop} repeat " nl() + " d 0.0 lineto " nl() + " stroke " nl() + " " nl() + " % name in chosen font " nl() + " d 5 add hh neg 3 add moveto " nl() + " style [cond 0 0 point 0 0] makefont setfont " nl() + " p show " nl() + " /Helvetica findfont 10 scalefont setfont " nl() + " " nl() + " savematrix setmatrix " nl() + " } def " nl() + " " nl() + "% tie procedure " nl() + "% 4 arguments: x and y of top right-hand end of tie " nl() + "% vh: half vertical span of the tie " nl() + "% bmul: multiplier to redirect central tail " nl() + "% 1: tail faces left " nl() + "% 0: tail faces right " nl() + "/mtrx matrix def " nl() + "/tie " nl() + " { /bmul exch def /vh exch def /y exch def /x exch def " nl() + " " nl() + " /savematrix mtrx currentmatrix def " nl() + " " nl() + " 1 setlinewidth " nl() + " " nl() + " /h 10 def /h2 h 2 mul def /v vh 2 mul def /trad 4 def " nl() + " x y translate " nl() + " " nl() + " newpath " nl() + " 0.0 0.0 moveto " nl() + " h neg 0.0 h neg vh neg trad arcto 4 {pop} repeat " nl() + " h neg vh neg h2 neg bmul mul vh neg trad arcto 4 {pop} repeat " nl() + " h2 neg bmul mul vh neg lineto " nl() + " 0.0 v neg moveto " nl() + " h neg v neg h neg vh neg trad arcto 4 {pop} repeat " nl() + " h neg vh neg h2 neg bmul mul vh neg trad arcto 4 {pop} repeat " nl() + " stroke " nl() + " " nl() + " savematrix setmatrix " nl() + " } def " nl() + " " nl() + "% dates1 procedure " nl() + "% 34 arguments: x and y start of first line of text " nl() + "% sb1, pb1, cb1: font for the following text " nl() + "% b1: first line of text for "born" " nl() + "% sb2, pb2, cb2: font for following text: " nl() + "% b2: second line of text for "born" " nl() + "% sm1, pm1, cm1: font for following text: " nl() + "% m1: first line of text for "married" " nl() + "% sm2, pm2, cm2: font for following text: " nl() + "% m2: second line of text for "married" " nl() + "% sr1, pr1, cr1: font for following text: " nl() + "% r1: first line of text for "resident" " nl() + "% sr2, pr2, cr2: font for following text: " nl() + "% r2: second line of text for "resident" " nl() + "% sd1, pd1, cd1: font for following text: " nl() + "% d1: first line of text for "died" " nl() + "% sd2, pd2, cd2: font for following text: " nl() + "% d2: second line of text for "died" " nl() + "/mtrx matrix def " nl() + "/dates1 " nl() + " { /d2 exch def /cd2 exch def /pd2 exch def /sd2 exch def " nl() + " /d1 exch def /cd1 exch def /pd1 exch def /sd1 exch def " nl() + " /r2 exch def /cr2 exch def /pr2 exch def /sr2 exch def " nl() + " /r1 exch def /cr1 exch def /pr1 exch def /sr1 exch def " nl() + " /m2 exch def /cm2 exch def /pm2 exch def /sm2 exch def " nl() + " /m1 exch def /cm1 exch def /pm1 exch def /sm1 exch def " nl() + " /b2 exch def /cb2 exch def /pb2 exch def /sb2 exch def " nl() + " /b1 exch def /cb1 exch def /pb1 exch def /sb1 exch def " nl() + " /y exch def /x exch def " nl() + " " nl() + " /savematrix mtrx currentmatrix def " nl() + " /voff 23 neg def /v 19 def /vv 9 def /hoff 45 def " nl() + " x y translate " nl() + " " nl() + " newpath " nl() + " 0.0 voff moveto (born) show " nl() + " 0.0 voff v sub moveto (married) show " nl() + " 0.0 voff v 2 mul sub moveto (resident) show " nl() + " 0.0 voff v 3 mul sub moveto (died) show " nl() + " sb1 [cb1 0 0 pb1 0 0] makefont setfont " nl() + " hoff voff moveto b1 show " nl() + " sb2 [cb2 0 0 pb2 0 0] makefont setfont " nl() + " hoff voff vv sub moveto b2 show " nl() + " sm1 [cm1 0 0 pm1 0 0] makefont setfont " nl() + " hoff voff v sub moveto m1 show " nl() + " sm2 [cm2 0 0 pm2 0 0] makefont setfont " nl() + " hoff voff v sub vv sub moveto m2 show " nl() + " sr1 [cr1 0 0 pr1 0 0] makefont setfont " nl() + " hoff voff v 2 mul sub moveto r1 show " nl() + " sr2 [cr2 0 0 pr2 0 0] makefont setfont " nl() + " hoff voff v 2 mul sub vv sub moveto r2 show " nl() + " sd1 [cd1 0 0 pd1 0 0] makefont setfont " nl() + " hoff voff v 3 mul sub moveto d1 show " nl() + " sd2 [cd2 0 0 pd2 0 0] makefont setfont " nl() + " hoff voff v 3 mul sub vv sub moveto d2 show " nl() + " " nl() + " savematrix setmatrix " nl() + " } def " nl() + " " nl() + "% dates2 procedure " nl() + "% 10 arguments: x and y start of first line of text " nl() + "% sb1, pb1, cb1: font for following text: " nl() + "% b1: first line of text for "born" " nl() + "% sb2, pb2, cb2: font for following text: " nl() + "% b2: second line of text for "born" " nl() + "% sd1, pd1, cd1: font for following text: " nl() + "% d1: first line of text for "died" " nl() + "% sd2, pd2, cd2: font for following text: " nl() + "% d2: second line of text for "died" " nl() + "/mtrx matrix def " nl() + "/dates2 " nl() + " { /d2 exch def /cd2 exch def /pd2 exch def /sd2 exch def " nl() + " /d1 exch def /cd1 exch def /pd1 exch def /sd1 exch def " nl() + " /b2 exch def /cb2 exch def /pb2 exch def /sb2 exch def " nl() + " /b1 exch def /cb1 exch def /pb1 exch def /sb1 exch def " nl() + " /y exch def /x exch def " nl() + " " nl() + " /savematrix mtrx currentmatrix def " nl() + " /voff 23 neg def /v 19 def /vv 9 def /hoff 30 def " nl() + " x y translate " nl() + " " nl() + " newpath " nl() + " 0.0 voff moveto (born) show " nl() + " 0.0 voff v sub moveto (died) show " nl() + " sb1 [cb1 0 0 pb1 0 0] makefont setfont " nl() + " hoff voff moveto b1 show " nl() + " sb2 [cb2 0 0 pb2 0 0] makefont setfont " nl() + " hoff voff vv sub moveto b2 show " nl() + " sd1 [cd1 0 0 pd1 0 0] makefont setfont " nl() + " hoff voff v sub moveto d1 show " nl() + " sd2 [cd2 0 0 pd2 0 0] makefont setfont " nl() + " hoff voff v sub vv sub moveto d2 show " nl() + " " nl() + " savematrix setmatrix " nl() + " } def " nl() + " " nl() + "% dates3 procedure " nl() + "% 10 arguments: x and y start of first line of text " nl() + "% sb1, pb1, cb1: font for following text: " nl() + "% b1: line of text for "born" " nl() + "% sm1, pm1, cm1: font for following text: " nl() + "% m1: line of text for "married" " nl() + "% sr1, pr1, cr1: font for following text: " nl() + "% r1: line of text for "resident" " nl() + "% sd1, pd1, cd1: font for following text: " nl() + "% d1: line of text for "died" " nl() + "/mtrx matrix def " nl() + "/dates3 " nl() + " { /d1 exch def /cd1 exch def /pd1 exch def /sd1 exch def " nl() + " /r1 exch def /cr1 exch def /pr1 exch def /sr1 exch def " nl() + " /m1 exch def /cm1 exch def /pm1 exch def /sm1 exch def " nl() + " /b1 exch def /cb1 exch def /pb1 exch def /sb1 exch def " nl() + " /y exch def /x exch def " nl() + " " nl() + " /savematrix mtrx currentmatrix def " nl() + " /voff 17 neg def /v 11 def /hoff 30 def " nl() + " x y translate " nl() + " " nl() + " newpath " nl() + " 0.0 voff moveto (born) show " nl() + " 0.0 voff v sub moveto (mrrd) show " nl() + " 0.0 voff v 2 mul sub moveto (rsdnt) show " nl() + " 0.0 voff v 3 mul sub moveto (died) show " nl() + " sb1 [cb1 0 0 pb1 0 0] makefont setfont " nl() + " hoff voff moveto b1 show " nl() + " sm1 [cm1 0 0 pm1 0 0] makefont setfont " nl() + " hoff voff v sub moveto m1 show " nl() + " sr1 [cr1 0 0 pr1 0 0] makefont setfont " nl() + " hoff voff v 2 mul sub moveto r1 show " nl() + " sd1 [cd1 0 0 pd1 0 0] makefont setfont " nl() + " hoff voff v 3 mul sub moveto d1 show " nl() + " " nl() + " savematrix setmatrix " nl() + " } def " nl() + " " nl() + "% dates4 procedure " nl() + "% 6 arguments: x and y start of first line of text " nl() + "% sb1, pb1, cb1: font for following text: " nl() + "% b1: line of text for "born" " nl() + "% sd1, pd1, cd1: font for following text: " nl() + "% d1: line of text for "died" " nl() + "/mtrx matrix def " nl() + "/dates4 " nl() + " { /d1 exch def /cd1 exch def /pd1 exch def /sd1 exch def " nl() + " /b1 exch def /cb1 exch def /pb1 exch def /sb1 exch def " nl() + " /y exch def /x exch def " nl() + " " nl() + " /savematrix mtrx currentmatrix def " nl() + " /voff 17 neg def /v 11 def /hoff 30 " nl() + " x y translate " nl() + " " nl() + " newpath " nl() + " 0.0 voff moveto (born) show " nl() + " 0.0 voff v sub moveto (died) show " nl() + " sb1 [cb1 0 0 pb1 0 0] makefont setfont " nl() + " hoff voff moveto b1 show " nl() + " sd1 [cd1 0 0 pd1 0 0] makefont setfont " nl() + " hoff voff v sub moveto d1 show " nl() + " " nl() + " savematrix setmatrix " nl() + " } def " nl() + " " nl() + "% dates5 procedure " nl() + "% 10 arguments: x and y start of first line of text " nl() + "% sb1, pb1, cb1: font for following text: " nl() + "% b1: text for "born" " nl() + "% sm1, pm1, cm1: font for following text: " nl() + "% m1: text for "married" " nl() + "% sr1, pr1, cr1: font for following text: " nl() + "% r1: text for "resident" " nl() + "% sd1, pd1, cd1: font for following text: " nl() + "% d1: text for "died" " nl() + "/mtrx matrix def " nl() + "/dates5 " nl() + " { /d1 exch def /cd1 exch def /pd1 exch def /sd1 exch def " nl() + " /r1 exch def /cr1 exch def /pr1 exch def /sr1 exch def " nl() + " /m1 exch def /cm1 exch def /pm1 exch def /sm1 exch def " nl() + " /b1 exch def /cb1 exch def /pb1 exch def /sb1 exch def " nl() + " /y exch def /x exch def " nl() + " " nl() + " /savematrix mtrx currentmatrix def " nl() + " /voff 15 neg def /v 10 def /wh 85 def /hoff 15 def " nl() + " x y translate " nl() + " " nl() + " newpath " nl() + " 0.0 voff moveto (b) show " nl() + " 0.0 voff v sub moveto (m) show " nl() + " wh voff v sub moveto (r) show " nl() + " wh voff moveto (d) show " nl() + " sb1 [cb1 0 0 pb1 0 0] makefont setfont " nl() + " hoff voff moveto b1 show " nl() + " sm1 [cm1 0 0 pm1 0 0] makefont setfont " nl() + " hoff voff v sub moveto m1 show " nl() + " sr1 [cr1 0 0 pr1 0 0] makefont setfont " nl() + " wh hoff add voff v sub moveto r1 show " nl() + " sd1 [cd1 0 0 pd1 0 0] makefont setfont " nl() + " wh hoff add voff moveto d1 show " nl() + " " nl() + " savematrix setmatrix " nl() + " } def " nl() + " " nl() + "% dates6 procedure " nl() + "% 6 arguments: x and y start of text " nl() + "% sb1, pb1, cb1: font for following text: " nl() + "% b1: text for "born" " nl() + "% sd1, pd1, cd1: font for following text: " nl() + "% d1: text for "died" " nl() + "/mtrx matrix def " nl() + "/dates6 " nl() + " { /d1 exch def /cd1 exch def /pd1 exch def /sd1 exch def " nl() + " /b1 exch def /cb1 exch def /pb1 exch def /sb1 exch def " nl() + " /y exch def /x exch def " nl() + " " nl() + " /savematrix mtrx currentmatrix def " nl() + " /voff 15 neg def /v 10 def /wh 85 def /hoff 15 def " nl() + " x y translate " nl() + " " nl() + " newpath " nl() + " 0.0 voff moveto (b) show " nl() + " wh voff moveto (d) show " nl() + " sb1 [cb1 0 0 pb1 0 0] makefont setfont " nl() + " hoff voff moveto b1 show " nl() + " sd1 [cd1 0 0 pd1 0 0] makefont setfont " nl() + " wh hoff add voff moveto d1 show " nl() + " " nl() + " savematrix setmatrix " nl() + " } def " nl() + " " nl() + "% coordinate transform to landscape format " nl() + "90 rotate 0 -563 translate " nl() + " " nl() + "% scaling used for pocket version " nl() + "% 0.6 0.6 scale " nl() +} + +/* + * Write the rest of the postscript code to the output file, with the + * blanks filled in with data extracted from the user's LifeLines database. + */ +proc dochart() +{ + set(id, 1) +/* set(person, getel(chart, id))*/ + set(person, lookup(chart, d(id))) + + "/Helvetica-Bold findfont 14 scalefont setfont" nl() + "30 500 moveto (Ancestry Chart of: " + name(person) ") show" nl() nl() + + "/Helvetica-Oblique findfont 9 scalefont setfont" nl() + "30 485 moveto (Compiled by: " lookup(compiler, "name") ") show" nl() + "30 475 moveto (" lookup(compiler, "addr") ") show" nl() + "30 465 moveto (" lookup(compiler, "phone") ") show" nl() + "30 455 moveto (" lookup(compiler, "email") ") show" nl() + + nl() + + "/Helvetica-Oblique findfont 9 scalefont setfont" nl() + "30 440 moveto (Chart dated: " + stddate(gettoday()) ") show" nl() nl() + + "/Helvetica findfont 14 scalefont setfont" nl() + "20 270 moveto (Ancestors of:) show" nl() nl() + + /* loop through all spouse, outputing names */ + spouses(person, svar, fvar, num) { + if (eq(num, 1)) { + set(savfam, fvar) + "/Helvetica findfont 12 scalefont setfont" nl() + "36 156 moveto (spouse: #1) show" nl() + "20 145 0 bold 9 9 (" + name(svar) + ") box" nl() + } + if (eq(num, 2)) { + "/Helvetica findfont 12 scalefont setfont" nl() + "36 55 moveto (other spouses:) show" nl() + "20 44 0 bold 9 9 (#2: " + name(svar) + ") box" nl() + } + if (eq(num, 3)) { + "/Helvetica findfont 12 scalefont setfont" nl() + "20 28 0 bold 9 9 (#3: " + name(svar) + ") box" nl() + } + if (eq(num, 4)) { + "/Helvetica findfont 12 scalefont setfont" nl() + "20 12 0 bold 9 9 (#4: " + name(svar) + ") box" nl() + } + if (eq(num, 5)) { + "/Helvetica findfont 12 scalefont setfont" nl() + "20 -4 0 bold 9 9 (#5: " + name(svar) + ") box" nl() + } + } + + "/Helvetica findfont 10 scalefont setfont" nl() nl() + + "% individual" nl() + "20 257 1 bold 9 9 (" + name(person) ") box" nl() + "20 257" nl() + call dates1(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "% parents" nl() + "20 393 2 bold 9 9 (" + name(person) ") box" nl() + "20 393" nl() + call dates1(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "20 121 3 bold 9 9 (" + name(person) ") box" nl() + "20 121" nl() + call dates2(person) + "20 393 136 0 tie" nl() nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "% grandparents" nl() + "210 461 4 bold 9 9 (" + name(person) ") box" nl() + "210 461" nl() + call dates1(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "210 325 5 bold 9 9 (" + name(person) ") box" nl() + "210 325" nl() + call dates2(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "210 189 6" nl() + "bold 9 9 (" + name(person) ") box" nl() + "210 189" nl() + call dates1(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "210 189 6" nl() + "210 53 7 bold 9 9 (" + name(person) ") box" nl() + "210 53" nl() + call dates2(person) + "210 461 68 1 tie 210 189 68 1 tie" nl() nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "% great-grandparents" nl() + "400 495 8 bold 9 9 (" + name(person) ") box" nl() + "400 495" nl() + monthformat(4) + call dates3(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "400 427 9 bold 9 9 (" + name(person) ") box" nl() + "400 427" nl() + call dates4(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "400 359 10 bold 9 9 (" + name(person) ") box" nl() + "400 359" nl() + call dates3(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "400 291 11 bold 9 9 (" + name(person) ") box" nl() + "400 291" nl() + call dates4(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "400 223 12 bold 9 9 (" + name(person) ") box" nl() + "400 223" nl() + call dates3(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "400 155 13 bold 9 9 (" + name(person) ") box" nl() + "400 155" nl() + call dates4(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "400 87 14 bold 9 9 (" + name(person) ") box" nl() + "400 87" nl() + call dates3(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "400 19 15 bold 9 9 (" + name(person) ") box" nl() + "400 19" nl() + call dates4(person) + "400 495 34 1 tie 400 359 34 1 tie" nl() + "400 223 34 1 tie 400 87 34 1 tie" nl() nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "% great-great-grandparents" nl() + "590 512 16 bold 9 9 (" + name(person) ") box" nl() + "590 512" nl() + call dates5(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 478 17 bold 9 9 (" + name(person) ") box" nl() + "590 478" nl() + call dates6(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 444 18 bold 9 9 (" + name(person) ") box" nl() + "590 444" nl() + call dates5(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 410 19 bold 9 9 (" + name(person) ") box" nl() + "590 410" nl() + call dates6(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 376 20 bold 9 9 (" + name(person) ") box" nl() + "590 376" nl() + call dates5(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 342 21 bold 9 9 (" + name(person) ") box" nl() + "590 342" nl() + call dates6(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 308 22 bold 9 9 (" + name(person) ") box" nl() + "590 308" nl() + call dates5(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 274 23 bold 9 9 (" + name(person) ") box" nl() + "590 274" nl() + call dates6(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 240 24 bold 9 9 (" + name(person) ") box" nl() + "590 240" nl() + call dates5(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 206 25 bold 9 9 (" + name(person) ") box" nl() + "590 206" nl() + call dates6(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 172 26 bold 9 9 (" + name(person) ") box" nl() + "590 172" nl() + call dates5(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 138 27 bold 9 9 (" + name(person) ") box" nl() + "590 138" nl() + call dates6(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 104 28 bold 9 9 (" + name(person) ") box" nl() + "590 104" nl() + call dates5(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 70 29 bold 9 9 (" + name(person) ") box" nl() + "590 70" nl() + call dates6(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 36 30 bold 9 9 (" + name(person) ") box" nl() + "590 36" nl() + call dates5(person) nl() + + set(id, add(id, 1)) + set(person, lookup(chart, d(id))) + "590 2 31 bold 9 9 (" + name(person) ") box" nl() + "590 2" nl() + call dates6(person) nl() + + "590 512 17 1 tie 590 444 17 1 tie" nl() + "590 376 17 1 tie 590 308 17 1 tie" nl() + "590 240 17 1 tie 590 172 17 1 tie" nl() + "590 104 17 1 tie 590 36 17 1 tie" nl() nl() + + "showpage" nl() nl() +} + +/* Style #1 for dates information... + */ +proc dates1(person) +{ + list(addrlist) + + "bold 10 9 (" stddate(birth(person)) ")" nl() + "bold 10 9 (" place(birth(person)) ")" nl() + + set(curfam, 0) + if (eq(id, 1)) { + set(curfam, savfam) + } + else { + /* if (eq(mod(d(id), 2), 0)) {*/ + if (eq(mod(id, 2), 0)) { +/* set(curfam, parents(getel(chart, div(id, 2))))*/ + set(curfam, parents(lookup(chart, d(div(id, 2))))) + } + } + "bold 10 9 (" stddate(marriage(curfam)) ")" nl() + "bold 10 9 (" place(marriage(curfam)) ")" nl() + + set(addrnode, NULL) + call residence(person) + + if (gt(strlen(place(addrnode)), 25)) { + extractplaces(addrnode, addrlist, n) + set(line1, NULL) + set(line1, dequeue(addrlist)) + set(line2, NULL) + while (not(empty(addrlist))) { + set(line2, concat(line2, dequeue(addrlist))) + set(line2, concat(line2, " ")) + } + "bold 10 9 (" line1 ")" nl() + "bold 10 9 (" line2 ")" nl() + } + else { + "bold 10 9 (" place(addrnode) ")" nl() + "bold 10 9 (" ")" nl() + } + "bold 10 9 (" stddate(death(person)) ")" nl() + "bold 10 9 (" place(death(person)) ")" nl() + "dates1" nl() +} + +/* Style #2 for dates information... + */ +proc dates2(person) +{ + "bold 10 9 (" stddate(birth(person)) ")" nl() + "bold 10 9 (" place(birth(person)) ")" nl() + "bold 10 9 (" stddate(death(person)) ")" nl() + "bold 10 9 (" place(death(person)) ")" nl() + "dates2" nl() +} + +/* Style #3 for dates information... + */ +proc dates3(person) +{ + list(addrlist) + + "bold 10 7.6 (" short(birth(person)) ")" nl() + + set(curfam, 0) +/* if (eq(mod(d(id), 2), 0)) {*/ + if (eq(mod(id, 2), 0)) { +/* set(curfam, parents(getel(chart, div(id, 2))))*/ + set(curfam, parents(lookup(chart, d(div(id, 2))))) + } + "bold 10 7.6 (" short(marriage(curfam)) ")" nl() + "bold 10 7.6 " + + set(addrnode, NULL) + call residence(person) + + if (gt(strlen(place(addrnode)), 25)) { + extractplaces(addrnode, addrlist, n) + set(line1, NULL) + set(line1, dequeue(addrlist)) + set(line2, NULL) + while (not(empty(addrlist))) { + set(line2, concat(line2, dequeue(addrlist))) + set(line2, concat(line2, " ")) + } + " (" line2 ")" nl() + } + else { + " (" place(addrnode) ")" nl() + } + + "bold 10 7.6 (" short(death(person)) ")" nl() + "dates3" nl() +} + +/* Style #4 for dates information... + */ +proc dates4(person) +{ + "bold 10 7.6 (" short(birth(person)) ")" nl() + "bold 10 7.6 (" short(death(person)) ")" nl() + "dates4" nl() +} + +/* Style #5 for dates information... + */ +proc dates5(person) +{ + list(addrlist) + + "bold 10 5 (" short(birth(person)) ")" nl() + set(curfam, 0) + /* if (eq(mod(d(id), 2), 0)) {*/ + if (eq(mod(id, 2), 0)) { +/* set(curfam, parents(getel(chart, div(id, 2))))*/ + set(curfam, parents(lookup(chart, d(div(id, 2))))) + } + "bold 10 5 (" short(marriage(curfam)) ")" nl() + + set(addrnode, NULL) + call residence(person) + + if (gt(strlen(place(addrnode)), 25)) { + extractplaces(addrnode, addrlist, n) + set(line1, NULL) + set(line1, dequeue(addrlist)) + set(line2, NULL) + while (not(empty(addrlist))) { + set(line2, concat(line2, dequeue(addrlist))) + set(line2, concat(line2, " ")) + } + "bold 10 5 (" line2 ")" nl() + } + else { + "bold 10 5 (" place(addrnode) ")" nl() + } + "bold 10 5 (" short(death(person)) ")" nl() + "dates5" nl() +} + +/* Style #6 for dates information... + */ +proc dates6(person) +{ + "bold 10 5 (" short(birth(person)) ")" nl() + "bold 10 5 (" short(death(person)) ")" nl() + "dates6" nl() +} diff --git a/reports/fdesc.ll b/reports/fdesc.ll new file mode 100644 index 0000000..e0a7806 --- /dev/null +++ b/reports/fdesc.ll @@ -0,0 +1,33 @@ +/* + * @progname fdesc.ll + * @version 1.0 + * @author Wetmore + * @category + * @output GEDCOM + * @description + + + this funny little program is based on Tom Wetmore's "genancc1" + and generates a GEDCOM file with descendants of a chosen individual + who have the same surname (usually this means male line descendants + plus illegitimate children of daughters) plus their spouses. + + a truely good program would need to exclude cases of daughters' + marriages with guys of the same surname but not related and include + male line descendants who changed surnames */ + +proc main () +{ + indiset(set1) + indiset(set2) + getindi(indi) + addtoset(set2, indi, n) + set(set1, descendantset(set2)) + set(set1, union(set1, set2)) + getindiset(set2) + set(set1, intersect(set1, set2)) + set(set2, spouseset(set1)) + set(set1, union(set1, set2)) + gengedcom(set1) + +} diff --git a/reports/fileindex.ll b/reports/fileindex.ll new file mode 100644 index 0000000..95d242c --- /dev/null +++ b/reports/fileindex.ll @@ -0,0 +1,236 @@ +/* + * @progname fileindex.ll + * @version 1999 + * @author Dennis Nicklaus + * @category + * @output HTML + * @description + + I have lines on indi's in my database which look like: + 1 NOTE FILE: BIOGRAPHY $FAMHIST/matthews/alkire.bio + or maybe OBITUARY, MARRIAGE, WILL, NEWS ... instead of BIOGRAPHY. + and the lowercase letters (matthews/alkire.bio in this example) + will change to reflect the location of the file in question. + + The purpose of this report is to make an index for these files. + Each entry looks something like: + ALKIRE, James Denton : matthews_alkire_bio
      + referencing my page for the individual and the file which has the article + in it. (I had to change the file naming scheme from my local disk to the + place where I have my files served to the WWW (geocities used to not allow + subdirectories). + + The files are grouped by type (e.g. BIO, OBIT, ...) and then + are sorted alphabetically by the individual's surname within each grouping. + + Probably not generally useful to anyone else, but shows one thing + that can be done. +*/ + + + +proc main() +{ + indiset(obitset) + indiset(marrset) + indiset(otherset) + indiset(bioset) + indiset(willset) + + table(obittab) + table(marrtab) + table(othertab) + table(biotab) + table(willtab) + + + print("patience please, you have a lot of data\n") + forindi (person, pnum) { + fornotes(inode(person),note){ + set (i, index(note,"FILE:",1)) + if (gt(i,0)){ + + + /* Get the filename. lifted from html.dn */ + + set(what,save(substring(note,add(i,6),strlen(note)))) + set (i, index(what," ",1)) + set(descrip,save(substring(what,1,i))) + + /* now get and flatten the file name */ + set (i, index(what,"FAMHIST/",1)) + set (fname,save(substring(what,add(i,strlen("FAMHIST/")),strlen(what))))o + set (slash, index(fname,"/",1)) + while (gt(slash,0)){ + set(fnameb,save(concat(concat(substring(fname,1,sub(slash,1)),"_"), + substring(fname,add(slash,1),strlen(fname))))) + set(fname,fnameb) + set (slash, index(fname,"/",1)) + } + set (slash, index(fname,".",1)) + while (gt(slash,0)){ + set(fnameb,save(concat(concat(substring(fname,1,sub(slash,1)),"_"), + substring(fname,add(slash,1),strlen(fname))))) + set(fname,fnameb) + set (slash, index(fname,".",1)) + } + /* filename is now complete except for adding .txt on the end of it */ + + + + /* now figure out which table things go in */ + + set (i, index(note,"OBITUARY",1)) + if (gt(i,0)){ + addtoset(obitset,person,0) + list(temp) + if (lookup(obittab, key(person))){ + set(temp,lookup(obittab, key(person))) + enqueue(temp,fname) + } else { + enqueue(temp,fname) + } + insert(obittab, save(key(person)), temp) + } + set (j, index(note,"MARRIAGE",1)) + if (gt(j,0)){ + addtoset(marrset,person,0) + list(temp) + if (lookup(marrtab, key(person))){ + set(temp,lookup(marrtab, key(person))) + enqueue(temp,fname) + } else { + enqueue(temp,fname) + } + insert(marrtab, save(key(person)), temp) + } + set (k, add(index(note,"BIOGRAPHY",1),index(note,"HISTORY",1))) + if (gt(k,0)){ + addtoset(bioset,person,0) + list(temp) + if (lookup(biotab, key(person))){ + set(temp,lookup(biotab, key(person))) + enqueue(temp,fname) + } else { + enqueue(temp,fname) + } + insert(biotab, save(key(person)), temp) + } + set (m, index(note,"WILL",1)) + if (gt(m,0)){ + addtoset(willset,person,0) + list(temp) + if (lookup(willtab, key(person))){ + set(temp,lookup(willtab, key(person))) + enqueue(temp,fname) + } else { + enqueue(temp,fname) + } + insert(willtab, save(key(person)), temp) + } + if (eq(add(add(add(i,j),k),m),0)){ + addtoset(otherset,person,0) + list(temp) + if (lookup(othertab, key(person))){ + set(temp,lookup(othertab, key(person))) + enqueue(temp,fname) + } else { + enqueue(temp,fname) + } + insert(othertab, save(key(person)), temp) + } + } + } + } + /* now sort and print things out */ + print("uniquing\n") +/* uniqueset(obitset) + uniqueset(marrset) + uniqueset(otherset) + uniqueset(bioset)*/ + print("sorting\n") + namesort(obitset) + namesort(marrset) + namesort(otherset) + namesort(bioset) + namesort(willset) + print("printing\n") + call intro() + "
      Have Obituaries for :

      \n" + forindiset(obitset,person,i,j) { + call nameout(person) + forlist(lookup(obittab, key(person)),newfile,n){ + " : " newfile " " + } + "
      \n" + } + "
      Have marriage articles for :

      \n" + forindiset(marrset,person,i,j) { + call nameout(person) + forlist(lookup(marrtab, key(person)),newfile,n){ + " : " newfile " " + } + "
      \n" + } + "
      Have Biographical or historical articles for :

      \n" + forindiset(bioset,person,i,j) { + call nameout(person) + forlist(lookup(biotab, key(person)),newfile,n){ + " : " newfile " " + } + "
      \n" + } + "
      Have Wills for :

      \n" + forindiset(willset,person,i,j) { + call nameout(person) + forlist(lookup(willtab, key(person)),newfile,n){ + " : " newfile " " + } + "
      \n" + } + "
      Have Other info for :

      \n" + forindiset(otherset,person,i,j) { + call nameout(person) + forlist(lookup(othertab, key(person)),newfile,n){ + " : " newfile " " + } + "
      \n" + } + call end() +} + +proc nameout(person) +{ + " " + fullname(person,1,0,999) + " " +} +proc intro() +{ + set(db_owner, getproperty("user.fullname")) + set(owner_email, concat("mailto:",getproperty("user.email"))) + "\n" + "" db_owner " Genealogy Article Index\n" + "\n" + "

      Family Article Index

      \n" + "
      " db_owner " " owner_email "
      \n" + "

      \n" + "This is an index of the various obituaries, biographies, wedding announcements, \n" + "wills, etc. that I have, sorted into those categories. Selecting the name\n" + "of the person will take you to that person's page. Following the person's\n" + "name is a filename or list of filenames which are the articles for that person.\n" + "Selecting the article filename will take you directly to it.\n" + "

      Some of the persons on this list may not have a personal page if they are \n" + "of a generation not included here, or if they are only related to me by marriage.\n" + "But the article should still be present.\n" + "So if you click on a person and don't go anywhere interesting, it's OK.\n" + "But let me know if any of the article links are invalid.\n" + "

      " +} +proc end() +{ +"

      \n" +"This page hosted by \"GeoCities\"\n" +"Get your own Free Home Page
      \n" +"

      \n" +} diff --git a/reports/find.ll b/reports/find.ll new file mode 100644 index 0000000..65d0b28 --- /dev/null +++ b/reports/find.ll @@ -0,0 +1,157 @@ +/* + * @progname find.ll + * @version 2.1 + * @author Prinke, Perry Rapp + * @category + * @output GUI + * @description Display menu of persons with TAG having matching VALUE + +This utility finds all persons whose records contain a specified +TAG and VALUE and displays the resulting list as a menu. + + find.ll - Rafal Prinke, rafalp@plpuam11.amu.edu.pl, 7 OCT 1995 + +The options allow to: + +- find all occurrences of a given TAG when no VALUE is given +- find all occurrences of a given VALUE when no TAG is given +- find all occurrences of a given VALUE under a given TAG when + both are given (the CONT|CONC|TYPE tags are also searched) + +The displayed VALUE is a 25 characters long substring of the field +value starting from the first occurence of the input value. + +The results are displayed in a menuchoice list. +The first choice is to print the remaining choices to a file. +*/ +option(explicit) + +proc main() +{ + list(mnu) + + getstr(tg, "TAG (enter=ANY)") + set(tg, upper(tg)) + + getstr(vl, "VALUE (enter=ANY)") + set(vl, upper(vl)) + + while (1) + { + getstr(rtype, "Records to search (I, F, S, E, X, or for any)") + set(rtype, upper(rtype)) + if (or(eq(rtype, ""), index("IFSEX", rtype, 1))) + { + break() + } + } + + set(outputChoice, "Print to output file") + enqueue(mnu, outputChoice) + + /* people */ + if (or(eq(rtype, ""), eq(rtype, "I"))) + { + forindi (rec, n) + { + call search(rec, tg, vl, mnu) + } + } + /* families */ + if (or(eq(rtype, ""), eq(rtype, "F"))) + { + forfam (rec, n) + { + call search(rec, tg, vl, mnu) + } + } + /* sources */ + if (or(eq(rtype, ""), eq(rtype, "S"))) + { + forsour (rec, n) + { + call search(rec, tg, vl, mnu) + } + } + /* events */ + if (or(eq(rtype, ""), eq(rtype, "E"))) + { + foreven (rec, n) + { + call search(rec, tg, vl, mnu) + } + } + /* others */ + if (or(eq(rtype, ""), eq(rtype, "X"))) + { + forothr (rec, n) + { + call search(rec, tg, vl, mnu) + } + } + + if (eq(length(mnu), 1)) + { + print("No matches found") + } + else + { + set(chc, menuchoose(mnu, "Use record keys as below to browse to desired record")) + if (eq(chc, 1)) + { + "Search for tag <" tg "> and value <" vl ">" + if (eq(rtype, "")) { " in all records" } + else { " in " rtype " records" } + " yielded " d(sub(length(mnu), 1)) " hits:\n" + forlist(mnu,s,c) { + if (ne(s, outputChoice)) + { + s nl() + } + } + } + } +} + +/* + Search rec (an INDI or FAM or ...) + for occurrences of tag tg with value vl + (Either may be empty as wildcards) +*/ +proc search(rec, tg, vl, mnu) +{ + set(rnod, root(rec)) + set(nodtyp, tag(rnod)) + traverse (rnod, n, x) + { + set(xtag, upper(tag(n))) + set(xval, upper(value(n))) + if (eq(strlen(vl), 0)) + { + set(ofst, 1) + } + else + { + set(ofst, index(xval, vl, 1)) + } + if (or(or(and(eqstr(tg, xtag), or(index(xval, vl, 1), + eq(strlen(vl), 0))), and(eq(strlen(tg), 0), index(xval, vl, 1))), + and(index("CONTYPECONC", xtag, 1), index(xval, vl, 1)))) + { + set(z, substring(value(n), ofst, strlen(xval))) + if (gt(strlen(z), 25)) + { + set(z, substring(z, 1, 25)) + } + set(result, concat(rjustify(key(rec), 6), " - ")) + if (eq(nodtyp, "INDI")) + { + set(result, concat(result, + rjustify(fullname(rec, 1, 1, 18), 18))) + } + set(result, concat(result, + " - ", tag(parent(n)), ":", d(x), "_", tag(n), ":", z)) + enqueue(mnu, result) + } + } /* traverse */ +} diff --git a/reports/findmissing.ll b/reports/findmissing.ll new file mode 100644 index 0000000..643082c --- /dev/null +++ b/reports/findmissing.ll @@ -0,0 +1,21 @@ +/* + * @progname findmissing.ll + * @version 1.0 + * @author + * @category + * @output Text + * @description + * + * find persons that are 'isolated' in your database - no parents and not + * in any families.. + */ +proc main () +{ + "THE FOLLOWING PERSONS ARE 'ISOLATED' IN YOUR DATABASE" nl() nl() + forindi(indi, num) { + if (and(not(parents(indi)), eq(0,nfamilies(indi)))) { + name(indi) " (" key(indi) ")" nl() + } + } +} + diff --git a/reports/fix_nameplac.ll b/reports/fix_nameplac.ll new file mode 100644 index 0000000..4f1e942 --- /dev/null +++ b/reports/fix_nameplac.ll @@ -0,0 +1,56 @@ +/* + * @progname fix_nameplac.ll + * @version 1 + * @author Eggert + * @category + * @output GEDCOM + * @description + +This is a quicky to show how to fix name and place spacing. + + +fix_nameplac - a LifeLines names and places fixing program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 8 January 1993 + + +*/ + +proc fixit(root) { + list(components) + traverse(root,node,level) { + set(t,save(tag(node))) + d(level) " " t " " + if (not(strcmp(t,"PLAC"))) { + extractplaces(node,components,nplaces) + forlist(components,place,plnum) { + if (gt(plnum,1)) { ", " } + place + } + } + elsif (not(strcmp(t,"NAME"))) { + extractnames(node,components,nnames,nsurname) + forlist(components,name,nnum) { + if (gt(nnum,1)) { " " } + if (eq(nnum,nsurname)) { "/" } + name + if (eq(nnum,nsurname)) { "/" } + } + } + else { + value(node) + } + "\n" + } +} + + +proc main() { + forindi(person,pnum) { + call fixit(inode(person)) + } + forfam(family,fnum) { + call fixit(fnode(family)) + } + "0 TRLR\n" +} diff --git a/reports/formatted_gedcom.ll b/reports/formatted_gedcom.ll new file mode 100644 index 0000000..ce572c8 --- /dev/null +++ b/reports/formatted_gedcom.ll @@ -0,0 +1,77 @@ +/* + * @progname formatted_gedcom.ll + * @version 1 + * @author Eggert + * @category + * @output GEDCOM + * @description + +This program outputs a LifeLines database in modified GEDCOM format. +Two additions to GEDCOM are made: an inter-record delimiter and a +level indenter. These are set up as global parameters and initialized +at the beginning of the main() procedure. + +formatted_gedcom - a LifeLines formatted GEDCOM listing program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 7 September 1993 + + +The header() procedure writes a GEDCOM header. You will definitely +want to edit this part of the program to reflect your name and +address. Note that I have included a line specifying Macintosh +character encoding, appropriate for my database. You may want to +delete or comment out this line. + +*/ + +global(delimiter) +global(indenter) + +proc header() { + delimiter "0 HEAD\n" + indenter "1 SOUR LIFELINES 2.3.3\n" + indenter "1 DEST ANY\n" + indenter "1 DATE " date(gettoday()) "\n" + indenter "1 FILE " outfile() "\n" + indenter "1 CHAR MACINTOSH\n" + indenter "1 COMM Formatted GEDCOM output produced by formatted_gedcom\n" + delimiter "0 @S1@ SUBM\n" + indenter "1 NAME James Robert Eggert\n" + indenter "1 ADDR 12 Bonnievale Drive\n" + indenter indenter "2 CONT Bedford Massachusetts 01730\n" + indenter indenter "2 CONT USA\n" + indenter "1 PHON 617-275-2004\n" +} + +proc main() { + set(delimiter, +"--------------------------------------------------------------------------\n") + set(indenter," ") + + call header() + forindi(person,num) { + call formatted_gedcom(inode(person),key(person)) + } + forfam(family,num) { + call formatted_gedcom(fnode(family),key(family)) + } + + delimiter "0 TRLR\n" delimiter +} + +proc formatted_gedcom(node,key) { + delimiter + traverse(node,subnode,level) { + if (level) { + set(counter,0) + while(lt(counter,level)) { + indenter + set(counter,add(counter,1)) + } + d(level) " " tag(subnode) " " value(subnode) "\n" + } + else { + "0 @" key "@ " tag(subnode) "\n" + } + } +} diff --git a/reports/ged_write.li b/reports/ged_write.li new file mode 100644 index 0000000..bd56c78 --- /dev/null +++ b/reports/ged_write.li @@ -0,0 +1,255 @@ +/* + * @progname ged_write.li + * @version 3 + * @author Paul B. McBride (pbmcbride@rcn.com) + * @category + * @output GEDCOM + * @description + + LifeLines GEDCOM file generating subroutine library. + This file defines a procedure ged_write() which extends the gengedcom() + builtin function of LifeLines by adding header and trailer records, + and outputting other level 0 record types which are referenced + within the individual and family records that would be output by + gengedcom(). If these records are not output to the GEDCOM file then + LifeLines would report links to undefined records, and not load the file + into the database. This is particularly useful for SOURce records + but also handles REPO, NOTE, EVENt, SUBMitter, other references + to INDIvidual and FAMily records, etc. + + The gengedcom() function of LifeLines outputs a GEDCOM file for + the specified set of INDIviduals. It handles standard links for + FAMilies, and from FAMilies back to INDIviduals. It does not generate + the "0 HEAD" records, or the "0 TRLR" record. Also if there are + other links ("@xx@") to records of other types, or links to INDIviduals + in other structure elements, the records they point to are not output. +Requirements: + LifeLines 3.0.5 or later or 3.0.3-*win32* +Notes: + To use this with 3.0.2 to 3.0.4: + 1) remove lines with "free(...)" + 2) add an inlist(...)" function. (see example at end) +Files: + Two other files are also required, samples of which are at the end + of this file: + header.ged, submit.ged +Bugs: + Links to FAMilies with tags other than "FAMC" and "FAMS" + may cause duplicate FAMily records in some cases. + +08 Sep 1995 v1 add SOUR records to GEDCOM file +08 Feb 1996 v2 add REPO records and other records linked within SOUR records +17 Feb 2000 v3 resolve all other links to records (if possible) +*/ + +global(ged_other_list) +global(ged_other_set) +global(ged_other_setlist) + +proc ged_write(gset) +{ + copyfile("header.ged") /* header file (references @SM1@) */ + + "1 DATE " stddate(gettoday()) nl() + + copyfile("submit.ged") /* submitter file (defines @SM1@) */ + + /* find other records and people referenced by the set */ + + set(slen, lengthset(gset)) + print("Writing GEDCOM file for ", d(slen), " people...") + call ged_other_init() + call ged_other_addset(gset) + if(ne(lengthset(gset), slen)) { + print(" ", d(sub(lengthset(gset),slen)), " added...") + } + + gengedcom(gset) /* output set as GEDCOM file (INDI and FAM records) */ + + /* add other types of records (including SOURces) */ + + call ged_other_write() + + "0 TRLR" nl() /* trailer */ + + print(nl()) +} + +proc ged_other_init() +{ + /* for earlier versions of LifeLines remove lines with free() */ + if(ged_other_list) { free(ged_other_list) } + if(ged_other_set) { free(ged_other_set) } + if(ged_other_setlist) { free(ged_other_setlist) } + /* end of lines to be removed for earlier versions of LifeLines */ + + list(ged_other_list) + indiset(ged_other_set) + list(ged_other_setlist) +} + +proc ged_other_addset(s) +{ + /* make a list of each person and family in the set. These + * are the INDI and FAM records that gengedcom() will output. + */ + forindiset (s, i, a, n) { + set(v, save(concat("@", key(i), "@"))) + enqueue(ged_other_setlist, v) + families(i, f, sp, m) { + set(v, save(concat("@", key(f), "@"))) + enqueue(ged_other_setlist, v) + call ged_other_add(root(f)) + } + } + /* process each INDI and FAM record to see if it contains references + * to other records. We need to add any other record that is referenced + * to the GEDCOM file. + */ + forindiset (s, i, a, n) { + call ged_other_add(root(i)) + families(i, f, sp, m) { + call ged_other_add(root(f)) + } + } + /* add any new people into the original set */ + forindiset (ged_other_set, i, a, n) { + addtoset(s, i, 1) + } +} + +/* ged_other_add() adds the other records referenced */ + +proc ged_other_add(n) +{ + traverse(n, m, l) { + if(gt(l, 0)) { + if(eq(l, 1)) { + if (eqstr("FAMC", tag(m))) { continue() } + if (eqstr("FAMS", tag(m))) { continue() } + if (eqstr("HUSB", tag(m))) { continue() } + if (eqstr("CHIL", tag(m))) { continue() } + if (eqstr("WIFE", tag(m))) { continue() } + } + set(v, value(m)) + if(reference(v)) { + if(eqstr(substring(v,2,2),"I")) { + /* process other references to individuals */ + if(inlist(ged_other_setlist, v)) { continue() } + set(v, save(v)) + enqueue(ged_other_setlist, v) + addtoset(ged_other_set, indi(v), 1) + call ged_other_add(dereference(v)) + /* this persons families will also be included */ + families(indi(v), f, sp, m) { + set(fv, save(concat("@", key(f), "@"))) + enqueue(ged_other_setlist, fv) + call ged_other_add(root(f)) + } + continue() + } + if(eqstr(substring(v,2,2),"F")) { + /* process other references to families */ + /* force a family to be included by adding in one + * of the parents. + */ + if(inlist(ged_other_setlist, v)) { continue() } + set(v, save(v)) + enqueue(ged_other_setlist, v) + call ged_other_add(dereference(v)) + set(spseen, 0) + set(fs, 0) + fornodes(dereference(v), fn) { + if(or(eqstr(tag(fn), "HUSB"),eqstr(tag(fn), "WIFE"))) { + set(fv, value(fn)) + if(reference(fv)) { + set(fs, save(fv)) + if(inlist(ged_other_setlist, fs)) { + /* this individual is already in the set, so + * this family will be output + */ + set(spseen, 1) + break() + } + } + } + } + if(spseen) { continue() } + if(fs) { + /* force this family to be included by adding a parent + * to the set + */ + enqueue(ged_other_setlist, fs) + addtoset(ged_other_set, indi(fs), 1) + call ged_other_add(dereference(fs)) + /* this persons families will also be included */ + families(indi(fs), f, sp, m) { + set(fv, save(concat("@", key(f), "@"))) + enqueue(ged_other_setlist, fv) + call ged_other_add(root(f)) + } + continue() + } + /* family had no parents. add it to the list of others */ + } + if (inlist(ged_other_list, v)) { continue() } + set(v, save(v)) + enqueue(ged_other_list, v) + } + } + } +} + +/* ged_other_write() outputs the current list of other records in GEDCOM format */ + +proc ged_other_write() +{ + forlist(ged_other_list, k, n) { + if(reference(k)) { + set(r, dereference(k)) + traverse(r, s, l) { + d(l) + if (xref(s)) { " " xref(s) } + " " tag(s) + if (v, value(s)) { + " " v + } + "\n" + } + } + } +} + +/* sample inlist() function for other versions of LifeLines + +func inlist(alist, str) +{ + forlist(alist, any, n) { + if(eqstr(any, str)) { return(1) } + } + return(0) +} +* end of sample inlist() function */ + +/* sample header.ged +0 HEAD +1 SOUR LIFELINES +2 VERS 3.0.5 +2 NAME LifeLines +2 CORP T. T. Wetmore +3 ADDR ttw@shore.net +1 SUBM @SM1@ +1 GEDC +2 VERS 5.5 +2 FORM Lineage-Linked +1 CHAR ASCII +* end of sample header.ged */ + +/* sample submit.ged +0 @SM1@ SUBM +1 NAME Your Name Here +1 ADDR Your Street Address +2 CONT Your City, State and Zip Code +2 CONT E-mail: your@email.address +* end of sample submit.ged */ + diff --git a/reports/gedall.ll b/reports/gedall.ll new file mode 100644 index 0000000..c7b82ed --- /dev/null +++ b/reports/gedall.ll @@ -0,0 +1,177 @@ +/* + * @progname gedall.ll + * @version 2000-02-20 + * @author Paul B. McBride (pbmcbride@rcn.com) + * @category + * @output GEDCOM + * @description + * + * This LifeLines report program produces a GEDCOM file containing + * the entire LifeLines database, including header, trailer, and + * submitter records. It also gives the option to keep or remove user defined + * tags, and to remove any other tags. + * + * modified Sep 2005 to use getproperties to automatically generate the header + * by Stephen Dum dr.doom@verizon.net + * + * The default action is to remove all user defined tags. These are tags + * which begin with an underscore, "_", character. + * + * When a tag line is removed, lines following it with higher level + * numbers are also removed. + * + * This report program may require LifeLines 3.0.3 or later. + * + * The gedcom header is generated in main() using property's + * obtained from the lifelines config file (~/.linesrc on unix else + * lines.cfg - or from properties set in the database) with values from + * the user defined properties + * user.fullname + * user.email + * user.address + * + * This report program was tested on databases created from the Test Book + * sample GEDCOM files at http://www.gentech.org + * + * 20 Feb 2000 Paul B. McBride (pbmcbride@rcn.com) + */ + +global(REMOVEUSERTAGS) +global(REMOVELISTEDTAGS) +global(REMOVETAG_LIST) + +global(removed_line_count) +global(removed_udt_count) + +proc main () +{ + list(REMOVETAG_LIST) /* list of tags to be removed */ + set(REMOVELISTEDTAGS, 0) /* set to 1 if there are tags to be removed */ + set(REMOVEUSERTAGS, askyn("Remove user defined tags (_*)")) + set(removed_udt_count, 0) + set(removed_line_count, 0) + + while(1) { + getstrmsg(remtag, "Enter any other tag to be removed") + if(gt(strlen(remtag),0)) { + set(REMOVELISTEDTAGS, 1) + enqueue(REMOVETAG_LIST, remtag) + } + else { break() } + } + + /* header file */ + "0 HEAD " nl() + "1 SOUR LIFELINES" nl() + "2 VERS " version() nl() + "2 NAME LifeLines" nl() + /* + "2 CORP ... " nl() + "3 ADDR .... " nl() + */ + "1 SUBM @SM1@" nl() + "1 GEDC " nl() + "2 VERS 5.5" nl() + "2 FORM Lineage-Linked" nl() + "1 CHAR ASCII" nl() + "1 DATE " stddate(gettoday()) nl() + /* and referenced submitter */ + "0 @SM1@ SUBM" nl() + "1 NAME " getproperty("user.fullname") nl() + "1 ADDR " getproperty("user.address") nl() + "2 CONT E-mail: " getproperty("user.email") nl() + + set(icnt, 0) + forindi(p, n) { + call ged_write_node(root(p)) + set(icnt, add(icnt,1)) + } + print(d(icnt), " INDI records (I*)...\n") + set(fcnt, 0) + forfam(f, n) { + call ged_write_node(root(f)) + set(fcnt, add(fcnt,1)) + } + print(d(fcnt), " FAM records (F*)...\n") + set(ecnt, 0) + foreven(e, n) { + call ged_write_node(root(e)) + set(ecnt, add(ecnt,1)) + } + print(d(ecnt), " EVEN records (E*)...\n") + set(scnt, 0) + forsour(s, n) { + call ged_write_node(root(s)) + set(scnt, add(scnt,1)) + } + print(d(scnt), " SOUR records (S*)...\n") + set(ocnt, 0) + forothr(o, n) { + call ged_write_node(root(o)) + set(ocnt, add(ocnt,1)) + } + print(d(ocnt), " other level 0 records (X*)\n") + + if(gt(removed_udt_count, 0)) { + print(d(removed_udt_count), " user defined tag structures were removed.\n") + } + if(gt(removed_line_count, 0)) { + print(d(removed_line_count), " lines were removed, as requested.\n") + } + + "0 TRLR" nl() /* trailer */ +} + +proc ged_write_node(n) +{ + set(remlevel, 10000) /* this value is larger than the largest level number */ + traverse(n, m, level) { + if(le(level, remlevel)) { + set(remlevel, 10000) /* end of previous tag removal if any */ + if(REMOVEUSERTAGS) { + if(t, tag(m)) { + if(eqstr(trim(t, 1), "_")) { + set(remlevel, level) /* remove line, and subordinate tag lines */ + set(removed_udt_count, add(removed_udt_count, 1)) + } + } + } + } + if(lt(level, remlevel)) { + if(REMOVELISTEDTAGS) { + if(t, tag(m)) { + forlist(REMOVETAG_LIST, rt, n) { + if(eqstr(t, rt)) { + set(remlevel, level) + break() + } + } + } + } + } + if(lt(level, remlevel)) { + /* output this line to the GEDCOM file */ + d(level) + if (xref(m)) { " " xref(m) } + " " tag(m) + if (v, value(m)) { + " " v + } + "\n" + } + else { + set(removed_line_count, add(removed_line_count, 1)) + } + } +} + +func askyn(msg) +{ + set(prompt, concat(msg, "? [y/n] ")) + getstrmsg(str, prompt) + if(and(gt(strlen(str), 0), + or(eq(strcmp(str, "n"),0), eq(strcmp(str, "N"),0)))) { + return(0) + } + return(1) +} diff --git a/reports/gedlist.ll b/reports/gedlist.ll new file mode 100644 index 0000000..5ead205 --- /dev/null +++ b/reports/gedlist.ll @@ -0,0 +1,61 @@ +/* + * @progname gedlist.ll + * @version 1.1 + * @author Paul B. McBride (pbmcbride@rcn.com) + * @category + * @output GEDCOM + * @description + + gedlist.ll generates a GEDCOM file for the male line of the + input individuals. + + Algorithm: + prompt for people + add male line of each person to set + add all children to set + add all spouses to set + add all parents to set + generate GEDCOM file + + Author: Paul B. McBride (pbmcbride@rcn.com) + + Version: + 1.1 January 10, 2001 correct prompt + 1.0 September 27, 2000 created from gdc.ll dated February 28, 1996 + */ + +include("ged_write.li") + +proc main () +{ + indiset(set0) + indiset(set1) /*declare an indi set*/ + indiset(set2) /*declare another indi set*/ + + getindiset(set0, "Identify people to include in GEDCOM File") + + if(eq(lengthset(set0),0)) { return() } + + /* add everyone in the male line for each person*/ + + forindiset(set0, indi, ival, icnt) { + addtoset(set1, indi, 1) /*add that person to set1*/ + set(fath, indi) + while(fath, father(fath)) { + addtoset(set1, fath, 1) /*add the father to set1*/ + } + } + + set(set2, childset(set1)) /* add all the children */ + set(set1, union(set1, set2)) /* combine set1 and set2 */ + + set(set2, spouseset(set1)) /* add all the spouses */ + set(set1, union(set1, set2)) /* combine set1 and set2 */ + + set(set2, parentset(set1)) /* find everyone's parents */ + set(set1, union(set1, set2)) /* combine set1 and set2 */ + + call ged_write(set1) /* write out GEDCOM file */ +} + +/* end of report */ diff --git a/reports/gedlod.ll b/reports/gedlod.ll new file mode 100644 index 0000000..917ce4b --- /dev/null +++ b/reports/gedlod.ll @@ -0,0 +1,72 @@ +/* + * @progname gedlod.ll + * @version 2000-02-15 + * @author Paul B. McBride (pbmcbride@rcn.com) + * @category + * @output GEDCOM + * @description + * + * Generate a GEDCOM file of a person's descent from an ancestor. + * The GEDCOM file will contain the following: + * all descendents of the ancestor who are ancestors of descendant, + * as well as the ancestor and descendant themselves. + * + * 15 Feb 2000 Paul B. McBride (pbmcbride@rcn.com) + */ + +include("prompt.li") +include("ged_write.li") + +proc main () +{ + indiset(iset) + indiset(dset) + indiset(tset) + indiset(uset) + indiset(aset) + indiset(gset) + + getindimsg(descendant,"Identify the descendant") + if(descendant) { + set(i, 1) + while(1) { + getindimsg(ancestor, concat("Identify ", ord(i), " ancestor")) + if(ancestor) { + set(i, add(i,1)) + addtoset(iset, ancestor, 0) + } + else { + break() + } + } + } + if(and(gt(lengthset(iset), 0),ne(descendant,0))) { + set(addspouses, askyn("Include spouses")) + set(addchildren, askyn("Include children")) + + /* find all the people of interest */ + print("Finding Ancestors... ") + addtoset(dset, descendant, 0) + set(tset, ancestorset(dset)) + print(d(lengthset(tset)), nl()) + + print("Finding Descendants... ") + set(uset, descendantset(iset)) + print(d(lengthset(uset)), nl()) + + set(aset, intersect(tset, uset)) + set(aset, union(aset, iset)) /* add in ancestors */ + addtoset(aset, descendant, 0) /* add in descendant */ + + if(addspouses) { + set(tset, spouseset(aset)) /* add their spouses */ + set(aset, union(aset, tset)) + } + + if(addchildren) { + set(tset, childset(aset)) /* find everyone's children */ + set(aset, union(aset, tset)) + } + call ged_write(aset) /* write out GEDCOM file */ + } +} diff --git a/reports/gedmin.ll b/reports/gedmin.ll new file mode 100644 index 0000000..c84f735 --- /dev/null +++ b/reports/gedmin.ll @@ -0,0 +1,506 @@ +/* + * @progname gedmin.ll + * @version 2007-12-15b + * @author Perry Rapp + * @category + * @output GEDCOM + * @description Output only specified tags of a database to GEDCOM + * + * (Adapted from gedall.ll by Paul B. McBride) + * Output only specific nodes of a database to GEDCOM + * + * See proc specify_tags below to adjust what tags are displayed + * + * The gedcom header is generated in main() using property's + * obtained from the lifelines config file (~/.linesrc on unix else + * lines.cfg - or from properties set in the database) with values from + * the user defined properties + * user.fullname + * user.email + * user.address + * + * Note: The tag info is appended to the output GEDCOM file if is is chosen + * so remember to cut it out to make output valid GEDCOM + * + * TechNote: occurrence counts in tables are +1, so that 0 is stored as 1 + * (b/c lookup cannot distinguish 0 from not present) + * + */ +option("explicitvars") /* Disallow use of undefined variables */ + + /* tags to output for anyone & anything */ +global(output_tag_list) +global(output_tag_table) + + /* tags to output for dead persons & marriages of dead persons */ +global(output_tag_dead_list) +global(output_tag_dead_table) + + /* remaining globals are all just for tracking stats of what we did */ +global(removed_tag_table) +global(removed_tag_list) + +global(removed_tag_dead_table) +global(removed_tag_dead_list) + +global(removed_udt_table) +global(removed_udt_list) + +global(removed_udt_dead_table) +global(removed_udt_dead_list) + +global(removed_tag_count) +global(removed_tag_dead_count) +global(removed_udt_count) +global(removed_udt_dead_count) +global(output_tag_count) +global(output_tag_dead_count) +global(living_indi_count) +global(dead_indi_count) +global(living_fam_count) +global(dead_fam_count) + + + /* This is the settings for what to output */ +proc specify_tags() +{ + /* top-level records */ + call keep_tag("INDI") + call keep_tag("FAM") + call keep_tag("SOUR") + /* not keeping EVEN/events */ + call keep_tag("NOTE") + /* lineage-links */ + call keep_tag("HUSB") + call keep_tag("WIFE") + call keep_tag("CHIL") + call keep_tag("FAMS") + call keep_tag("FAMC") + /* basic person info */ + call keep_tag("NAME") + call keep_tag("SEX") + call keep_tag_dead("BIRT") + call keep_tag_dead("DEAT") + call keep_tag_dead("PLAC") + call keep_tag_dead("DATE") + call keep_tag_dead("MARR") + /* basic source info */ + call keep_tag("AUTH") + call keep_tag("TITL") +} + +proc main() +{ + /* tags to be output */ + /* table to filter with, list to display afterwards */ + list(output_tag_list) + table(output_tag_table) + + /* tags to be output */ + /* table to filter with, list to display afterwards */ + list(output_tag_dead_list) + table(output_tag_dead_table) + + /* keep track of all distinct tags removed for display */ + /* table for uniqueness, list to build before and display after */ + table(removed_tag_table) + list(removed_tag_list) + table(removed_tag_dead_table) + list(removed_tag_dead_list) + + /* keep track of all distinct UDTs removed for display */ + /* table for uniqueness, list to build before and display after */ + table(removed_udt_table) + list(removed_udt_list) + table(removed_udt_dead_table) + list(removed_udt_dead_list) + + /* count # items removed (all items, not just distinct ones) */ + set(removed_udt_count, 0) + set(removed_tags_count, 0) + set(living_indi_count, 0) + set(dead_indi_count, 0) + set(living_fam_count, 0) + set(dead_fam_count, 0) + + call specify_tags() + + /* max width of lines when outputting tag lists */ + set(linewid, 70) + + set(removed_udt_count, 0) + set(removed_line_count, 0) + + /* Allow user to add tags to keep */ + while(1) { + getstrmsg(keeptag, "Enter any other tag to be kept") + if(gt(strlen(keeptag),0)) { + call keep_tag(keeptag) + } + else { break() } + } + + /* Allow user to add tags to keep for dead people */ + while(1) { + getstrmsg(keeptag, "Enter any other tag to be kept for dead") + if(gt(strlen(keeptag),0)) { + call keep_tag_dead(keeptag) + } + else { break() } + } + + call print_header() + + call traverse_database() + + call print_trailer() + + if (askyn("Add tag lists at end of file")) { + call print_tags_info(linewid) + } +} + + /* call traverse_node_subtree for all nodes in subtree */ + /* (except ones chopped off higher up) */ +proc traverse_database() +{ + set(icnt, 0) + forindi(p, n) { + set(dead, is_indi_dead(p)) + call traverse_node_subtree(root(p), dead) + if (dead) { incr(dead_indi_count) } else { incr(living_indi_count) } + incr(icnt, 1) + } + print(d(icnt), " INDI (I*) records (L:", d(living_indi_count), ", D:", d(dead_indi_count), ").\n") + + set(fcnt, 0) + forfam(f, n) { + set(dead, is_fam_dead(f)) + call traverse_node_subtree(root(f), dead) + if (dead) { incr(dead_fam_count) } else { incr(living_fam_count) } + incr(fcnt, 1) + } + print(d(fcnt), " FAM (F*) records (L:", d(living_fam_count), ", D:", d(dead_fam_count), ").\n") + + set(ecnt, 0) + foreven(e, n) { + set(dead, 0) + call traverse_node_subtree(root(e), dead) + incr(ecnt, 1) + } + print(d(ecnt), " EVEN (E*) records.\n") + + set(scnt, 0) + forsour(s, n) { + set(dead, 0) + call traverse_node_subtree(root(s), dead) + incr(scnt, 1) + } + print(d(scnt), " SOUR (S*) records.\n") + + set(ocnt, 0) + forothr(o, n) { + set(dead, 0) + call traverse_node_subtree(root(o), dead) + incr(ocnt, 1) + } + print(d(ocnt), " other level 0 (X*) records.\n") + + print(d(add(output_tag_count, output_tag_dead_count)) + , " items output (", d(output_tag_count), "/", d(output_tag_dead_count), "\n") + + print(d(add(removed_tag_count, removed_tag_dead_count, removed_udt_count, removed_udt_dead_count)) + , " items removed (", d(removed_tag_count), "/", d(removed_tag_dead_count) + , "/", d(removed_udt_count), "/", d(removed_udt_dead_count), "\n") +} + +func is_indi_dead(p) +{ + set(dt, death(p)) + if (not(dt)) { + return(0) /* no death event */ + } + if (eqstr(value(dt), "Y")) { + return(1) /* "DEAT Y" mean dead */ + } + if (child(dt)) { + return(1) /* if DEAT node has children, we'll call it dead */ + } + return(0) /* apparently placeholder empty DEAT line */ +} + +func is_fam_dead(f) +{ + set(spct, 0) + spouses(f, sp, ord) { + incr(spct, 1) + if (not(is_indi_dead(sp))) { + return(0) /* has living spouse */ + } + } + if (spct) { + return(1) /* has at least one dead spouse */ + } else { + return(0) /* no spouses */ + } +} + +proc print_tags_info(linewid) +{ + nl() + "---------------" nl() + "PRESERVED ITEMS INFO" nl() + "---------------" nl() + + if(length(output_tag_list)) { + "PRESERVED TAGS (" d(length(output_tag_list)) "):" nl() + call print_list(output_tag_list, output_tag_table, linewid) + } else { + "NO PRESERVED TAGS" nl() + } + d(output_tag_count) " lines preserved" nl() + nl() + + if(length(output_tag_dead_list)) { + "PRESERVED TAGS (DEAD)(" d(length(output_tag_dead_list)) "):" nl() + call print_list(output_tag_dead_list, output_tag_dead_table, linewid) + } else { + "NO PRESERVED TAGS (DEAD)" nl() + } + d(output_tag_dead_count) " additional dead lines preserved" nl() + nl() + + d(add(output_tag_count, output_tag_dead_count)) " total lines preserved" nl() + nl() + + + "---------------" nl() + "REMOVED ITEMS INFO" nl() + "---------------" nl() + + if(length(removed_tag_list)) { + "REMOVED TAGS (NON-DEAD)(" d(length(removed_tag_list)) "):" nl() + call print_list(removed_tag_list, removed_tag_table, linewid) + } else { + "NO REMOVED TAGS (NON-DEAD)" nl() + } + d(removed_tag_count) " regular tags removed (non-dead)" nl() + nl() + + if(length(removed_udt_list)) { + "REMOVED UDTS (NON-DEAD)(" d(length(removed_udt_list)) "):" nl() + call print_list(removed_udt_list, removed_udt_table, linewid) + } else { + "NO REMOVED UDTs (NON-DEAD)" nl() + } + d(removed_udt_count) " udts removed (non-dead)" nl() + nl() + + if(length(removed_tag_dead_list)) { + "REMOVED TAGS (DEAD)(" d(length(removed_tag_dead_list)) "):" nl() + call print_list(removed_tag_dead_list, removed_tag_dead_table, linewid) + } else { + "NO REMOVED TAGS (DEAD)" nl() + } + d(removed_tag_dead_count) " regular tags removed (dead)" nl() + nl() + + if(length(removed_udt_dead_list)) { + "REMOVED UDTS (DEAD)(" d(length(removed_udt_dead_list)) "):" nl() + call print_list(removed_udt_dead_list, removed_udt_dead_table, linewid) + } else { + "NO REMOVED UDTs (DEAD)" nl() + } + d(removed_udt_dead_count) " udts removed (dead)" nl() + nl() + + d(add(removed_tag_count, removed_tag_dead_count)) " total regular tags removed (dead & non-dead)" nl() + d(add(removed_udt_count, removed_udt_dead_count)) " total udts removed (dead & non-dead)" nl() + nl() + + d(add(removed_tag_count, removed_tag_dead_count, removed_udt_count, removed_udt_dead_count)) + " total tags and udts removed (dead & non-dead)" nl() + nl() + + "---------------" nl() + "TRAVERSED ITEMS INFO" nl() + "---------------" nl() + + "INDI: living=" d(living_indi_count) ", dead=" d(dead_indi_count) ", total=" + d(add(living_indi_count, dead_indi_count)) "\n" + + "FAMI: living=" d(living_fam_count) ", dead=" d(dead_fam_count) ", total=" + d(add(living_fam_count, dead_fam_count)) "\n" + +} + + /* dump contents of a list to output, multiple items per line */ +proc print_list(alist, atable, linewid) +{ + set(wid, 0) + forlist(alist, tag, ord) { + set(item, concat(tag, " (", d(add(lookup(atable, tag),-1)), ")")) + /* output line return if needed */ + if (and(gt(wid, 0), gt(add(wid, strlen(item)), linewid))) { + "\n" + set(wid, 0) + } + /* output , if not first item on line */ + if (gt(wid, 0)) { + ", " + } + /* output tag item (tag and occurrence count) */ + item + set(wid, add(wid, strlen(item))) + } + if (gt(wid,0)) { + "\n" + } +} + + /* Add tag to collection of tags to output */ +proc keep_tag(tag) +{ + if (lookup(output_tag_table, tag)) { + print("keep_tag called again for tag: ", tag, "\n") + } else { + insert(output_tag_table, tag, 1) + enqueue(output_tag_list, tag) + } +} + + /* Add tag to collection of tags to output for dead people*/ +proc keep_tag_dead(tag) +{ + if (lookup(output_tag_table, tag)) { + print("keep_tag_dead called for tag after keep_tag: ", tag, "\n") + } elsif (lookup(output_tag_dead_table, tag)) { + print("keep_tag_dead called again for tag: ", tag, "\n") + } else { + insert(output_tag_dead_table, tag, 1) + enqueue(output_tag_dead_list, tag) + } +} + +proc print_header() +{ + /* header file */ + "0 HEAD " nl() + "1 SOUR LIFELINES" nl() + "2 VERS " version() nl() + "2 NAME LifeLines" nl() + /* + "2 CORP ... " nl() + "3 ADDR .... " nl() + */ + "1 SUBM @SM1@" nl() + "1 GEDC " nl() + "2 VERS 5.5" nl() + "2 FORM Lineage-Linked" nl() + "1 CHAR ASCII" nl() + "1 DATE " stddate(gettoday()) nl() + /* and referenced submitter */ + "0 @SM1@ SUBM" nl() + "1 NAME " getproperty("user.fullname") nl() + "1 ADDR " getproperty("user.address") nl() + "2 CONT E-mail: " getproperty("user.email") nl() +} + +proc print_trailer() +{ + "0 TRLR" nl() /* trailer */ +} + +proc traverse_node_subtree(n, dead) +{ + /* first see if list is on the always keep list */ + if (occur, lookup(output_tag_table, tag(n))) { + incr(occur, 1) + insert(output_tag_table, tag(n), occur) + incr(output_tag_count, 1) + call ged_write_node(n) + fornodes(n, chil) { + call traverse_node_subtree(chil, dead) + } + return(0) + } + if (dead) { + /* is tag on the keep if dead list ? */ + if (occur, lookup(output_tag_dead_table, tag(n))) { + incr(occur, 1) + insert(output_tag_dead_table, tag(n), occur) + incr(output_tag_dead_count, 1) + call ged_write_node(n) + fornodes(n, chil) { + call traverse_node_subtree(chil, dead) + } + } + } + /* record being dropped, record stats */ + if (eqstr(trim(tag(n), 1), "_")) { + /* udt being dropped */ + if (dead) { + set(occur, lookup(removed_udt_dead_table, tag(n))) + if (not(occur)) { + set(occur, 1) + enqueue(removed_udt_dead_list, tag(n)) + } + incr(occur, 1) + insert(removed_udt_dead_table, tag(n), occur) + incr(removed_udt_dead_count, 1) + } else { + set(occur, lookup(removed_udt_table, tag(n))) + if (not(occur)) { + set(occur, 1) + enqueue(removed_udt_list, tag(n)) + } + incr(occur, 1) + insert(removed_udt_table, tag(n), occur) + incr(removed_udt_count, 1) + } + } else { + /* regular tag being dropped */ + if (dead) { + set(occur, lookup(removed_tag_dead_table, tag(n))) + if (not(occur)) { + set(occur, 1) + enqueue(removed_tag_dead_list, tag(n)) + } + incr(occur, 1) + insert(removed_tag_dead_table, tag(n), occur) + incr(removed_tag_dead_count, 1) + } else { + set(occur, lookup(removed_tag_table, tag(n))) + if (not(occur)) { + set(occur, 1) + enqueue(removed_tag_list, tag(n)) + } + incr(occur, 1) + insert(removed_tag_table, tag(n), occur) + incr(removed_tag_count, 1) + } + } +} + +proc ged_write_node(n) +{ + /* output this line to the GEDCOM file */ + d(level(n)) + if (xref(n)) { " " xref(n) } + " " tag(n) + if (v, value(n)) { + " " v + } + "\n" +} + +func askyn(msg) +{ + set(prompt, concat(msg, "? [y/n] ")) + getstrmsg(str, prompt) + if(and(gt(strlen(str), 0), + or(eq(strcmp(str, "n"),0), eq(strcmp(str, "N"),0)))) { + return(0) + } + return(1) +} diff --git a/reports/gedn.ll b/reports/gedn.ll new file mode 100644 index 0000000..d5968e1 --- /dev/null +++ b/reports/gedn.ll @@ -0,0 +1,48 @@ +/* + * @progname gedn.ll + * @version none + * @author anon + * @category + * @output GEDCOM + * @description + * + * The output of this report is a GEDCOM file of the following: + * N generations of ancestors, + * all spouses and + * all children of these ancestors and + * all descendents of a person, + * as well as the person him/herself + */ + +include("ged_write.li") + +proc main () +{ + indiset(set1) /*declare an indi set*/ + indiset(set2) /*declare another indi set*/ + indiset(set3) /*declare another indi set*/ + + getindi(ind1) /*ask user to identify person*/ + if(ind1) { + getintmsg(maxgen, "Number of Generations") + print("Finding Ancestors... ") + addtoset(set1, ind1, 1) + set(set2, ancestorset(set1)) + print(d(lengthset(set2)), nl()) + print("Triming Ancestors to ", d(maxgen), " generations... ") + forindiset(set2, ind1, ival, icnt) { + if(le(ival,maxgen)) { + addtoset(set3, ind1, ival) + } + } + print(d(lengthset(set3)), nl()) + + set(set2, spouseset(set3)) /* add their spouses */ + set(set1, union(set3, set2)) /* combine set1 and set2 */ + + set(set2, childset(set1)) /* find everyone's children */ + set(set1, union(set1, set2)) /* combine set1 and set2 */ + + call ged_write(set1) /* write out GEDCOM file */ + } +} diff --git a/reports/gedtags.ll b/reports/gedtags.ll new file mode 100644 index 0000000..95bbf80 --- /dev/null +++ b/reports/gedtags.ll @@ -0,0 +1,81 @@ +/* + * @progname gedtags.ll + * @version 2001-06-28 + * @author Paul B.McBride (pbmcbride@rcn.com) + * @category + * @output Text + * @description + + produces a unique list of all tags used in the database + listed like the following: + INDI + INDI.BIRT + INDI.BIRT.DATE + INDI.BIRT.PLAC + ... + + each line of the output will be unique. + + this can be useful in understanding the structure of the data in a GEDCOM + file, or in checking for errors. + + sort the output file using an external sort program. + + Warning: for some versions of LifeLines probably prior to 3.0.3 + a save() should surround the values to be stored in tables and lists. + + * Paul B.McBride (pbmcbride@rcn.com) 28 June 2001 + */ + +global(tagnames) +global(taglevels) +global(content) + +proc main () +{ + list(tagnames) + list(taglevels) + table(content) + + forindi(pers,x) { + call out(pers) + } + forfam(fm,x) { + call out(fm) + } + foreven(evn, n) { + call out(evn) + } + forsour(src, n) { + call out(src) + } + forothr(oth, n) { + call out(oth) + } + + /* insert sorting code here if desired */ + + forlist(tagnames,n,p) { n "\n" } +} + +proc out(item) +{ + traverse(root(item),y,level) { + + setel(taglevels,add(level,1),tag(y)) + + set(i,0) + set(s,"") + while(le(i,level)) { + if(gt(i,0)) { + set(s,concat(s,".")) + } + set(s,concat(s, getel(taglevels,add(i,1)))) + incr(i) + } + if(eq(lookup(content, s),0)) { + enqueue(tagnames,s) + insert(content,s,1) + } + } +} diff --git a/reports/gen_index b/reports/gen_index new file mode 100644 index 0000000..0343f87 --- /dev/null +++ b/reports/gen_index @@ -0,0 +1,196 @@ +#! /usr/bin/perl -w + +# Parse lifeline reports programs and generate a index +# Written by Stephen Dum stephen.dum@verizon.net +# January 2003 + +use strict; + +my $debug = 0; #non-zero to enable debug output +my $viewoutput = 0; #non-zero to enable printing output information + +sub usage { + print "usage: $0 ...\n"; + print(" generate index.html file from all programs listed\n"); + exit(0); +} + +# parse arguments +while (defined($_=$ARGV[0]) && /^-/) { + shift; + /-d/ && ($debug++,next); + /-o/ && ($viewoutput++,next); + /-h/ && usage(); +} + +my @files = sort @ARGV; + +open OUT,">temp.html" or die "Unable to open temp.html for output"; +print_header(); +read_files(); +print_trailer(); +rename("temp.html","index.html"); + + + +sub print_header { +print OUT < + + + +Report programs for use with Lifelines genealogy Software + + + + + + + + + + +
      +LifeLines stork logo +
      + +
      +      		 +
      +LifeLines, second generation genealogy software +
      +Report Programs +
      +
      +

      +This is an overview of the report programs distributed with Lifelines. +If you want more information about a program, often there are comments +at the beginning of the program that talk about functionality and algorithms, +that have sample output and examples of post processing commands required to +properly view the results. +Some programs require customization before use, for example, they might +have text identifying the person who generated the report. +

      +EOF +} +sub print_trailer { + my $today = `date "+%d %b %Y"`; + print OUT < +
      + +This overview was generated +$today + +
      + + +EOF +} +sub read_files { + my $file; + my $prog; + my $progname; + my $version; + my $author; + my $category; + my $output; + my $description; + my $char_encoding; + while ($file = shift @files ) { + print $file . "\n" if $debug; + next if $file =~ /\.li$/; + if ($file eq "least_related.ll") { + print "Skipping $file\n"; + next; + } + $prog = $file; + $prog =~ s/.ll$//; #strip off .ll + $prog =~ s/.*\/reports\///; #strip off any path prefix on filename + # that includes '/reports/' + open(FIN,$file) or die "Unable to open $file for input"; + $progname=""; + $version=""; + $author=""; + $category=""; + $output=""; + $description=""; + $char_encoding=""; + while () { + if (/^.*\@progname\s*(.*)\s*$/) { + print " progname: $1\n" if $debug; + $progname=$1; + } elsif (/^.*\@version\s*(.*)\s*$/) { + print " version: $1\n" if $debug; + $version=$1; + } elsif (/^.*\@author\s*(.*)\s*$/) { + print " author: $1\n" if $debug; + $author=$1; + } elsif (/^.*\@category\s*(.*)\s*$/) { + print " category: $1\n" if $debug; + $category=$1; + } elsif (/^.*\@output\s*(.*)\s*$/) { + print " output: $1\n" if $debug || $viewoutput; + print "$file output: $1\n" if $viewoutput == 2; + $output=$1; + } elsif (/^.*\@description\s*(.*)\s*$/) { + print " description: $1\n" if $debug; + #$description=$1; + if (length($description) == 0) { + while() { + # skip blank lines + last unless /^\s*\**\s*$/; + } + s/^\s*\**\s*//; + $description=$_; + while() { + # collect descriptin until we get a blank line + # or end of the comment + last if /^\s*\**\s*$/ || /\*\//; + s/^\s*\**\s*//; + $description .= $_; + } + + } + } elsif (/\*\//) { + print "End of program meta tags at line $. for file $file\n" if $debug; + last; + } + } + while() { + next unless /\s*char_encoding\("(.*)"\)/; + $char_encoding = $1; + last; + } + close(FIN); + #print OUT "
      $prog\n
      "; + print OUT "
      $prog\n
      "; + print OUT "Version $version; " if length($version) != 0; + print OUT "by $author" if length($author) != 0; + print OUT "; output format $output" if length($output) != 0; + print OUT "; char encoding $char_encoding" if length($char_encoding) != 0; + $description =~ s/\\n$description"; + } +} + diff --git a/reports/genancc.ll b/reports/genancc.ll new file mode 100644 index 0000000..8e5b29a --- /dev/null +++ b/reports/genancc.ll @@ -0,0 +1,54 @@ +/* + * @progname genancc.ll + * @version 1997-11 + * @author Wetmore, Manis, Kirby + * @category + * @output Text + * @description + * + * The output of this report is a GEDCOM file of the following: + * all ancestors, + * all spouses and + * all children of all ancestors and + * all descendents of a person, + * as well as the person him/herself + * and his/her spouses. + * + * This form of the program is probably the most useful for extracting + * data when a person requests data about someone from your database. + * + * modified from genancc1 + * by Tom Wetmore, ttw@cbnewsl.att.com + * (as sent to Cliff Manis in August 1992) + * + * This report works only with the LifeLines Genealogy program + * + * [I have only given it a name and added lots of comments] /cliff + * August 1992 + * Nov. 1997 I added lines to get all descendants --James Kirby + * + */ + +proc main () +{ + indiset(set1) /*declare an indi set*/ + indiset(set2) /*declare another indi set*/ + indiset(set3) /*declare another indi set*/ + + getindi(indi) /*ask user to identify person*/ + addtoset(set1, indi, n) /*add that person to set1*/ + + set(set2, ancestorset(set1)) /* for ancestors */ + + set(set1, union(set1, set2)) /* combine set1 and set2 */ + set(set2, spouseset(set1)) + set(set1, union(set1, set2)) /* combine set1 and set2 */ + set(set2, childset(set1)) + set(set1, union(set1, set2)) /* combine set1 and set2 */ + set(set3, descendantset(set2)) /* get descendants */ + set(set1, union(set1, set3)) /* combine set1 and set2 */ + + gengedcom(set1) /*write final set as GEDCOM file*/ +} + +/* end of report */ diff --git a/reports/genancc1.ll b/reports/genancc1.ll new file mode 100644 index 0000000..2b04248 --- /dev/null +++ b/reports/genancc1.ll @@ -0,0 +1,64 @@ +/* + * @progname genancc1.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output GEDCOM + * @description + * + * This program is useful for extracting + * data when a person requests data about someone from your database. + * The output of this report is a GEDCOM file of the following: + * all ancestors, + * all spouses and + * all children of all ancestors and + * all descendents of a person, + * as well as the person him/herself + * and his/her spouses. + * + * genancc1 + * + * by Tom Wetmore, ttw@cbnewsl.att.com + * (as sent to Cliff Manis in August 1992) + * + * This report works only with the LifeLines Genealogy program + * + * [I have only given it a name and added lots of comments] /cliff + * + * August 1992 + * + * For example, the output of this report is a GEDCOM file of the + * following: + * + * all ancestors, + * all spouses and + * all children of all ancestors and + * all descendents of a person, + * as well as the person him/herself + * and his/her spouses. + * + * This form of the program is probably the most useful for extracting + * data when a person requests data about someone from your database. + */ + +proc main () +{ + indiset(set1) /*declare an indi set*/ + indiset(set2) /*declare another indi set*/ + + getindi(indi) /*ask user to identify person*/ + addtoset(set1, indi, n) /*add that person to set1*/ + + set(set2, ancestorset(set1)) /* for ancestors */ + + set(set1, union(set1, set2)) /* combine set1 and set2 */ + set(set2, spouseset(set1)) + set(set1, union(set1, set2)) /* combine set1 and set2 */ + set(set2, childset(set1)) + set(set1, union(set1, set2)) /* combine set1 and set2 */ + + gengedcom(set1) /*write final set as GEDCOM file*/ +} + +/* end of report */ + diff --git a/reports/gender_order.ll b/reports/gender_order.ll new file mode 100644 index 0000000..96a21f3 --- /dev/null +++ b/reports/gender_order.ll @@ -0,0 +1,210 @@ +/* + * @progname gender_order.ll + * @version 4 + * @author Jim Eggert + * @category + * @output Text + * @description + +This program computes gender order statistics for children in all the +families in a database. Genders are considered to be ternary: male +(M), female (F), or unknown (U). Children in a family form a pattern +of genders by birth order, e.g. MFFM for a family consisting of a boy, +two girls, then a boy. The frequency of these patterns is calculated. +In addition to the complete gender pattern for a family, initial +gender patterns are computed. For the above example, the initial +patterns are . (no children), M, MF, MFF, and MFFM. The frequency of +these initial patterns can be used to answer questions such as how +many families with a boy then two girls go on to have another boy. + +For example, suppose you want to know what fraction of families with a +child gender pattern P (e.g., P=MFFM) have no more children, have a +boy next (PM), have a girl next (PF), and have a child of unknown (to +the database!) gender next (PU). You can find these fractions as +#complete(P)/#initial(P), #initial(PM)/#initial(P), +#initial(PF)/#initial(P), and #initial(PU)/#initial(P), respectively. +Note that these fractions should add up to 1. Also note that the +pattern "." denotes no children at all. As a initial pattern it gives +the total number of families in the database, as a complete pattern the +number of childless families in the database. + +You can use either of two compare functions to sort the results +differently. Rename the one you want to use as compare, the other one +something else (like compare1). + +gender_order - a LifeLines gender order statistics program + by Jim Eggert (EggertJ@crosswinds.net) + Version 1, 5 August 1993 + listsort code by John Chandler (JCHBN@CUVMB.CC.COLUMBIA.EDU) + Version 2, 10 August 1993 + added family examples, modified output format slightly + Version 3, 26 March 1995 + changed listsort to quicksort + Version 4, 15 Jan 2000 + quicksort bug fix + +*/ + +/* This compare procedure sorts purely alphabetically */ +func compare1(astring,bstring) { + return(strcmp(astring,bstring)) +} + +/* This compare procedure sorts by length + and alphabetically within groups of equal length */ +func compare(astring,bstring) { + set(alen,strlen(astring)) + set(blen,strlen(bstring)) + if (lt(alen,blen)) { return(neg(1)) } + if (gt(alen,blen)) { return(1) } + return(strcmp(astring,bstring)) +} + +/* + quicksort: Sort an input list by generating a permuted index list + Input: alist - list to be sorted + Output: ilist - list of index pointers into "alist" in sorted order + Needed: compare- external function of two arguments to return -1,0,+1 + according to relative order of the two arguments +*/ +proc quicksort(alist,ilist) { + set(len,length(alist)) + set(index,len) + while(index) { + setel(ilist,index,index) + decr(index) + } + if (ge(len,2)) { call qsort(alist,ilist,1,len) } +} + +/* recursive core of quicksort */ +proc qsort(alist,ilist,left,right) { + if(pcur,getpivot(alist,ilist,left,right)) { + set(pivot,getel(alist,getel(ilist,pcur))) + set(mid,partition(alist,ilist,left,right,pivot)) + call qsort(alist,ilist,left,sub(mid,1)) + call qsort(alist,ilist,mid,right) + } +} + +/* partition around pivot */ +func partition(alist,ilist,left,right,pivot) { + while(1) { + set(tmp,getel(ilist,left)) + setel(ilist,left,getel(ilist,right)) + setel(ilist,right,tmp) + while(lt(compare(getel(alist,getel(ilist,left)),pivot),0)) { + incr(left) + } + while(ge(compare(getel(alist,getel(ilist,right)),pivot),0)) { + decr(right) + } + if(gt(left,right)) { break() } + } + return(left) +} + +/* choose pivot */ +func getpivot(alist,ilist,left,right) { + set(pivot,getel(alist,getel(ilist,left))) + set(left0,left) + incr(left) + while(le(left,right)) { + set(rel,compare(getel(alist,getel(ilist,left)),pivot)) + if (gt(rel,0)) { return(left) } + if (lt(rel,0)) { return(left0) } + incr(left) + } + return(0) +} + +proc main() { + list(patterns) + list(initial_counts) + list(complete_counts) + table(indices) + list(sorted_indices) + list(complete_examples) + +/* accumulate gender order statistics, even unknown genders */ + + enqueue(initial_counts,0) + enqueue(complete_counts,0) + enqueue(patterns,".") + enqueue(complete_examples,"no example") + insert(indices,".",1) + set(max_index,1) + set(max_nc,0) + + set(nextfam,0) + print("Processing families ") + forfam(family,fnum) { + setel(initial_counts,1,fnum) + set(pattern,"") + set(index,1) + if (nc,nchildren(family)) { + if (gt(nc,max_nc)) { set(max_nc,nc) } + children(family,child,cnum) { + if (not(strcmp(sex(child),"F"))) { + set(pattern,save(concat(pattern,"F"))) + } + elsif (not(strcmp(sex(child),"M"))) { + set(pattern,save(concat(pattern,"M"))) + } + else { + set(pattern,save(concat(pattern,"U"))) + } + set(index,lookup(indices,pattern)) + if (index) { + setel(initial_counts,index, + add(getel(initial_counts,index),1)) + } + else { + set(max_index,add(max_index,1)) + set(index,max_index) + insert(indices,pattern,index) + enqueue(patterns,save(pattern)) + enqueue(initial_counts,1) + enqueue(complete_counts,0) + } + } + } + else { + if(not(strcmp(getel(complete_examples,1),"no example"))) { + setel(complete_examples,1,save(key(family))) + } + } + if (not(getel(complete_examples,index))) { + setel(complete_examples,index,save(key(family))) + } + setel(complete_counts,index,add(getel(complete_counts,index),1)) + if (ge(fnum,nextfam)) { + print(d(fnum)) print(" ") + set(nextfam,add(nextfam,100)) + } + } + + print("\nSorting results...") + + call quicksort(patterns,sorted_indices) + +/* print out gender order statistics sorted alphabetically */ + + print("done\nPrinting results...") + + set(initialcol,add(max_nc,16)) + set(completecol,add(initialcol,12)) + set(examplecol,add(completecol,12)) + "Gender pattern" col(sub(initialcol,7)) "initial" + col(sub(completecol,8)) "complete" col(examplecol) "example\n" + + forlist(sorted_indices,index,inum) { + getel(patterns,index) + set(initial,getel(initial_counts,index)) + col(sub(initialcol,strlen(d(initial)))) d(initial) + set(complete,getel(complete_counts,index)) + col(sub(completecol,strlen(d(complete)))) d(complete) + col(examplecol) getel(complete_examples,index) "\n" + } + print("done") +} diff --git a/reports/gendex.ll b/reports/gendex.ll new file mode 100644 index 0000000..13e9f3d --- /dev/null +++ b/reports/gendex.ll @@ -0,0 +1,73 @@ +/* + * @progname gendex.ll + * @version 1.2 + * @author Scott McGee (smcgee@microware.com) + * @category + * @output HTML + * @description + +This report program converts a LifeLines database into html gendex document. +You will need to change the contents of proc html_address() and to +set the value of HREF appropriately to your server. + +@(#)gendex.ll 1.2 10/14/95 +*/ + +global(INDEX) +global(HREF) + +proc main() +{ + indiset(INDEX) + set(HREF, "/INDEX=") + print("processing database\n") + set(count, 0) + set(name_count, 0) + forindi(me,num) + { + if(eq(count, 100)){ + set(count, 0) + print(".") + }else{ + incr(count) + incr(name_count) + } + addtoset(INDEX,me,1) + } + print("\nwriting file\n") + call create_gendex_file() + print("\n", d(name_count), " individuals\n") +} + + +proc create_gendex_file() { + set(fn, save("GENDEX.txt")) + newfile(fn, 0) + forindiset(INDEX, me, v, n) + { + set(path, concat(HREF, save(key(me)), "/?LookupInternal")) + path + "|" + surname(me) + "|" + givens(me) " /" + surname(me) "/" + "|" + if (evt, birth(me)) { + date(evt) + } + "|" + if (evt, birth(me)) { + place(evt) + } + "|" + if (evt, death(me)) { + date(evt) + } + "|" + if (evt, death(me)) { + place(evt) + } + "|\n" + } +} diff --git a/reports/genetics.ll b/reports/genetics.ll new file mode 100644 index 0000000..5c75759 --- /dev/null +++ b/reports/genetics.ll @@ -0,0 +1,319 @@ +/* + * @progname genetics.ll + * @version 2.0.1 + * @author Eggert + * @category + * @output Text + * @description + +This LifeLines report program computes the degree of blood relatedness +between any two people in a database. It does this by finding all the +common ancestors, known or implied, and their ancestral distance along +any known path to the two people. + +genetics - a LifeLines report program to calculate degree of relatedness + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1 (15 Sept 1995) + Version 2 (19 Sept 1995) added multiple identical birth capability + Version 2.0.1 (1 Jul 2002) Fix to run with newer LifeLines (Perry Rapp) + +This LifeLines report program computes the degree of blood relatedness +between any two people in a database. It does this by finding all the +common ancestors, known or implied, and their ancestral distance along +any known path to the two people. Ancestors are assumed to exist even +when they are not explicitly in the database if their existence can be +deduced from the family structure. This most commonly occurs when the +mother of a family is unknown, but can be assumed to be identical when +two children are in the database as siblings. Likewise, when both the +mother and the father are missing, this program will assume them to be +identical for siblings in a family. If any of the ancestors are twins +or other multiple identical births, the program will determine this as +a possibility based on equality of birthyears and will ask the user to +verify the identical nature of the twins. + +Because the program is pretty picky, it will only report half-siblings +and half-cousins. You are forced to add up the halves to get the full +picture. But it will find all known genetic relationships between the +two individuals and calculate a genetic overlap fraction. This number +ranges between 0 (not related) to 1 (same person). The program cannot +handle nontraditional families (when more than one husband and/or wife +exists in the family). And it doesn't check for adoptions, it assumes +that all children are the genetic children of their parents. + +This code uses the unusual construct of a table of lists of lists. +*/ + +global(twin_table) + +proc main() { + +table(twin_table) + +/* Get the first individual and find ancestors and multiplicities */ + getindimsg(p1,"Enter first person.") + table(anc1_table) + set(kp1,save(key(p1))) + call recur_anc(kp1,0,anc1_table,0) + +/* Get the second individual and find ancestors and relatedness + only up to common ancestors. +*/ + getindimsg(p2,"Enter second person.") + list(lca_list) + table(lca_table) + set(kp2,save(key(p2))) + call recur_anc(kp2,lca_list,lca_table,anc1_table) + +/* Now calculate relations */ + if (length(lca_list)) { + print(kp1," ",name(indi(kp1))," is\n",kp2," ",name(indi(kp2)),"'s\n") + list(gsums) + set(gmax,0) + forlist(lca_list,lca,ilca) { + set(ll,lookup(anc1_table,lca)) + set(gl1,getel(ll,1)) + set(kl1,getel(ll,2)) + set(ll,lookup(lca_table,lca)) + set(gl2,getel(ll,1)) + set(kl2,getel(ll,2)) + forlist(gl1,g1,il1) { + set(k1,getel(kl1,il1)) + forlist(gl2,g2,il2) { + set(k2,getel(kl2,il2)) + call print_rel(kp1,k1,k2,g1,g2) + set(gsum,add(g1,g2)) + enqueue(gsums,gsum) + if (gt(gsum,gmax)) { set(gmax,gsum) } + } + } + } + } + else { + print(kp1," ",name(indi(kp1))," and ",kp2," ",name(indi(kp2)), + " are not related by blood.\n") + return() + } + +/* Add up path weights */ + set(gsum,0) + forlist(gsums,g,gnum) { + set(gpow,1) + while(lt(g,gmax)) { + set(gpow,add(gpow,gpow)) + incr(g) + } + set(gsum,add(gsum,gpow)) + } +/* Cancel common factors of 2 */ + if (gsum) { + while (not(mod(gsum,2))) { + set(gsum,div(gsum,2)) + decr(gmax) + } + } +/* Figure common denominator */ + set(gpow,1) + while(gmax) { + set(gpow,add(gpow,gpow)) + decr(gmax) + } +/* Print out final answer */ + print("Expected degree of genetic overlap: ",d(gsum),"/",d(gpow),"\n") +} + +/* This is the magic routine that does the real work. + If there is no input stop_table, calculate all the + ancestors along all paths of the input person, and return + the ancestors and their multiplicities. + If there is an input stop_table, calculate the ancestors + up to the ones contained in the stop table, and return + only the ones in the stop table and their multiplicities. + Notes: If there were a fortable() iterator, then the anc_list + would be unnecessary. The fake keys are used to simulate + ancestors who aren't explicitly in the database. + The table entries are lists of two elements. The first element + is a list of generation counts for a path to that ancestor or + his or her twin, the second element is a list of actual keys of the + ancestor. These actual keys differ only if the ancestor is a twin. + If the ancestor is a twin, the key to the table entry is the key of + the "oldest" twin. +*/ +proc recur_anc(kp,anc_list,anc_table,stop_table) { + list(keys) + list(gens) + enqueue(keys,kp) + enqueue(gens,0) + while (ka,dequeue(keys)) { + set(g,dequeue(gens)) + set(k,first_twin(ka)) + if (stop_table) { + set(stop,lookup(stop_table,k)) + } + if (or(not(stop_table),stop)) { + if (ll,lookup(anc_table,k)) { + set(l,getel(ll,1)) + set(kl,getel(ll,2)) + } + else { + list(ll) + list(l) + list(kl) + enqueue(ll,l) + enqueue(ll,kl) + insert(anc_table,k,ll) + if (anc_list) { enqueue(anc_list,k) } + } + enqueue(l,g) + enqueue(kl,ka) + } + if (not(stop)) { + if (a,indi(k)) { + incr(g) + if (par,parents(a)) { + if (aa,father(a)) { + enqueue(keys,save(key(aa))) + } + else { + enqueue(keys,save(concat("H0",key(par)))) /* fake */ + } + if (aa,mother(a)) { + enqueue(keys,save(key(aa))) + } + else { + enqueue(keys,save(concat("W0",key(par)))) /* fake */ + } + enqueue(gens,g) + enqueue(gens,g) + } + } + } + } +} + +proc print_rel(kp1,k1,k2,g1,g2) { + set(p1,indi(kp1)) + if (lt(g1,g2)) { set(deg,g1) set(rem,sub(g2,g1)) } + else { set(deg,g2) set(rem,sub(g1,g2)) } + if (strcmp(k1,k2)) { + incr(deg) /* twin ancestors */ + set(halftwin,"twin-") + } else { set(halftwin,"half-") } + if (eq(deg,0)) { + if (eq(rem,0)) { print("self") } + else { + while (gt(rem,2)) { print("g") decr(rem) } + if (gt(rem,1)) { print("grand") } + if (gt(g1,g2)) { +/* print("half-") */ + if (male(p1)) { print("son") } + elsif (female(p1)) { print("daughter") } + else { print("child") } + } + else { + if (male(p1)) { print("father") } + elsif (female(p1)) { print("mother") } + else { print("parent") } + } + } + } + elsif (eq(deg,1)) { + if (eq(rem,0)) { + print(halftwin) + if (male(p1)) { print("brother") } + elsif (female(p1)) { print("sister") } + else { print("sibling") } + } + else { + while (gt(rem,2)) { print("g") decr(rem) } + if (gt(rem,1)) { print("grand") } + if (gt(g1,g2)) { + print(halftwin) + if (male(p1)) { print("nephew") } + elsif (female(p1)) { print("niece") } + else { print("niece/nephew") } + } + else { + if (male(p1)) { print("uncle") } + elsif (female(p1)) { print("aunt") } + else { print("aunt/uncle") } + } + } + } + else { + print(ord(sub(deg,1))," ",halftwin,"cousin") + if (eq(rem,1)) { print(" once") } + elsif (eq(rem,2)) { print(" twice") } + elsif (eq(rem,3)) { print(" thrice") } + elsif (gt(rem,3)) { print(" ",card(rem)," times") } + if (rem) { print(" removed") } + } + print("\n via their ancestor ",k1," ") + if (p1,indi(k1)) { print(name(p1)) } + else { + print("Unknown ") + if (strcmp(substring(k1,1,1),"H")) { print("wife") } + else { print("husband") } + print(" in family ",substring(k1,3,strlen(k1))) + } + if (strcmp(k1,k2)) { + print("\n and twin ",k2," ",name(indi(k2))) + } + print("\n") +} + +func first_twin(pkey) { + if (tkey,lookup(twin_table,pkey)) { return(tkey) } + set(ft,0) + if (p,indi(pkey)) { + if (parents(p)) { + if (b,birbapyear(p)) { + set(loop,1) + while(loop) { + set(loop,0) + if (q,prevsib(p)) { + if (not(strcmp(sex(p),sex(q)))) { + if (eq(b,birbapyear(q))) { + print(key(p)," ",name(p), + birbapdate(p)," and\n") + print(key(q)," ",name(q), + birbapdate(q)) + getint(rt, + "Are these individuals identical twins? (0=no, 1=yes)") + if (rt) { + set(p,q) + set(loop,1) + set(ft,p) + print(" are twins\n\n") + } + else { print(" are not twins\n\n") } + } + } + } + } + } + } + } + if (ft) { set(tkey,save(key(ft))) } else { set(tkey,pkey) } + insert(twin_table,pkey,tkey) + return(tkey) +} + +func birbapyear(person) { + if (b,birth(person)) { + if (byear,atoi(year(b))) { return(byear) } + } + if (b,baptism(person)) { + if (byear,atoi(year(b))) { return(byear) } + } + return(0) +} + +func birbapdate(person) { + if (b,birth(person)) { + if (byear,atoi(year(b))) { return(concat(" born ",date(b))) } + } + if (b,baptism(person)) { + if (byear,atoi(year(b))) { return(concat(" bapt ",date(b))) } + } + return("") +} diff --git a/reports/genetics2.ll b/reports/genetics2.ll new file mode 100644 index 0000000..bf725f1 --- /dev/null +++ b/reports/genetics2.ll @@ -0,0 +1,113 @@ +/* + * @progname genetics2.ll + * @version 1 of 1995-10-05 + * @author Alexander Ottl (ottl@informatik.uni-muenchen.de) + * @category + * @output Text + * @description + +This LifeLines report program computes the degree of blood relatedness +between any two people in a database. + +Genetic distance d(A,B) is defined recursively by: + d(A,A) = 1 + d(A,B) = d(B,A) + d(A,B) = d(F(A),B) / 2 + d(M(A),B) / 2 +with F(A) and M(A) being the father and mother of A. + +The recursive procedure computedist() follows that definition. +That's the beauty of recursion. + + by Alexander Ottl (ottl@informatik.uni-muenchen.de) + Version 1 (5 Oct 1995) + +*/ + +global(R0) +global(R1) + +proc main() +{ + getindimsg(A, "First person:") + getindimsg(B, "Second person:") + call computedist(A, B) + print("\nExpected degree of genetic overlap: ", + d(R0), "/", d(R1), "\n") +} + +/* BOOL ancestor( INDI, INDI ) */ +func ancestor(A, B) +{ + if(not(strcmp(key(A),key(B)))) { + return(1) + } + families(A, Fam, Spo, Num1) { + children(Fam, Chl, Num2) { + if(ancestor(Chl, B)) { + return(1) + } + } + } + return(0) +} + +/* Actually this should be a function returning a rational number. + I might use a list, but I chose to use two global variables + R0 and R1 for the numerator and denominator */ +/* VOID computedist( INDI, INDI ) */ +proc computedist(A, B) +{ + /* Recursion must terminate some time. + One's distance to himself is 1/1 */ + if(not(strcmp(key(A),key(B)))) { + set(R0,1) + set(R1,1) + } + /* If there is a direct line from A down to B, we must work our way + upwards from B. There must of course then be no line + from B down to A, but no one is his own ancestor, right? */ + elsif(ancestor(A, B)) { + /* print("Common ancestor: ", name(A), "\n") */ + call computedist(B, A) + } + /* Now we try to work our way upwards through the parents */ + else { + set(R0,0) + set(R1,1) + if(F,father(A)) { + call computedist(F, B) + /* Result by half */ + set(R1, mul(2, R1)) + } + if(M,mother(A)) { + /* Save previous result */ + set(Res0, R0) + set(Res1, R1) + call computedist(M, B) + /* Result by half */ + set(R1, mul(2, R1)) + /* Adding up with previous result */ + set(common, mul(R1, Res1)) + set(R0, add(mul(R0, Res1), mul(R1, Res0))) + set(R1, common) + call normalize() + } + } +} + +/* This is not an all-purpose normalizing function. + We expect the denominator R1 to be a power of 2 and + to be greater than the numerator R0. */ +/* VOID normalize(VOID) */ +proc normalize() +{ + if(R0) { + while(not(mod(R0,2))) { + set(R0, div(R0,2)) + set(R1, div(R1,2)) + } + } + else { + set(R1,1) + } +} diff --git a/reports/getbaptism.li b/reports/getbaptism.li new file mode 100644 index 0000000..6a012f0 --- /dev/null +++ b/reports/getbaptism.li @@ -0,0 +1,24 @@ +/* + * @progname getbaptism.li + * @version none + * @author anon + * @category + * @output gedcom node function value + * @description + * + * getbaptism(ind) -> NODE + * The built-in baptism() function is limited to "CHR" records. + * Many programs use the "BAPM" and LDS uses "BAPL" so this version + * looks for all three in the order "CHR", "BAPM", "BAPL". + * + */ +func getbaptism(ind) +{ + if (e, baptism(ind)) { return (e) } + fornodes(root(ind), node) { + set(t, tag(node)) + if (eqstr(t, "BAPM")) { return (node) } + if (eqstr(t, "BAPL")) { return (node) } + } + return (0) +} diff --git a/reports/givens_gender.ll b/reports/givens_gender.ll new file mode 100644 index 0000000..3112ec5 --- /dev/null +++ b/reports/givens_gender.ll @@ -0,0 +1,76 @@ +/* + * @progname givens_gender.ll + * @version 1 + * @author Jim Eggert (eggertj@ll.mit.edu) + * @category + * @output Text + * @description + +Given name gender report program. +This program prints a list of all given names of people, tagged by one +of the following: +M Only males +F Only females +B Males and females +M? Males and persons of unknown gender +F? Females and persons of unknown gender +B? Males, females, and persons of unknown gender + +Very few names should be marked as B. Check them carefully and you +may find some database gender errors. You may be able to help resolve +unknown genders for those names tagged M? and F?. + +If you want to sort the report by name only, do + sort +1b -2b report > report.sort +If you want to sort the report by gender and name, do + sort report > report.sort + +If you want to find a person with a specific given name and gender, +use givens_gender_finder. + + by Jim Eggert (eggertj@ll.mit.edu) + Version 1 (19 April 1995) requires LifeLines 3.0.1 or later. +*/ + +proc main() { + table(namestable) + list(nameslist) + list(codelist) + list(names) + print("Collecting names...") + set(namescount,0) + forindi(person,pnum) { +/* if (gt(pnum,300)) { break() } */ + if (male(person)) { set(a,15) set(m,2) } + elsif (female(person)) { set(a,10) set(m,3) } + else { set(a,6) set(m,5) } + extractnames(inode(person),names,nnames,isurname) + forlist(names,name,iname) { + if (ne(iname,isurname)) { + if (l,lookup(namestable,name)) { + if (not(mod(l,m))) { + insert(namestable,save(name),add(l,a)) + } + } + else { + set(sname,save(name)) + insert(namestable,sname,a) + enqueue(nameslist,sname) + incr(namescount) + } + } + } + } + setel(codelist, 6,"? ") + setel(codelist,10,"F ") + setel(codelist,15,"M ") + setel(codelist,16,"F? ") + setel(codelist,21,"M? ") + setel(codelist,25,"B ") + setel(codelist,31,"B? ") + print("done\nPrinting ", d(namescount)," names...") + while(name,dequeue(nameslist)) { + getel(codelist,lookup(namestable,name)) + name "\n" + } +} diff --git a/reports/givens_gender_finder.ll b/reports/givens_gender_finder.ll new file mode 100644 index 0000000..a7137df --- /dev/null +++ b/reports/givens_gender_finder.ll @@ -0,0 +1,34 @@ +/* + * @progname givens_gender_finder.ll + * @version 1 + * @author Eggert + * @category + * @output Text + * @description + +This program finds all persons with a particular given name and gender. +It is really meant to be a companion to the givens_gender program. + +givens_gender_finder - a LifeLines database given name & gender finder program + by Jim Eggert (eggertj@ll.mit.edu) + Version 1 (19 April 1995) requires LifeLines 3.0.1 or later. + +*/ + +proc main() { + list(names) + getstrmsg(nseek,"Enter name to be found") set(nseek,save(nseek)) + getstrmsg(gseek,"Enter gender to be found") set(gseek,save(gseek)) + forindi(person,pnum) { + if (not(strcmp(gseek,sex(person)))) { + extractnames(inode(person),names,nnames,isurname) + forlist(names,name,iname) { + if (ne(iname,isurname)) { + if (not(strcmp(name,nseek))) { + print(key(person)," ",name(person),"\n") + } + } + } + } + } +} diff --git a/reports/grand.ll b/reports/grand.ll new file mode 100644 index 0000000..f89a4cc --- /dev/null +++ b/reports/grand.ll @@ -0,0 +1,427 @@ +/* + * @progname grand + * @version 1.1 + * @author Stephen Dum + * @category + * @output text + * @description + +For a selected individual this program outputs a list of children, +grand children, great grand children and great great grand children. + +Output format is simple text, roughly 80 columns. Each list is sorted +by date person 'entered' the family either by birth date or adoption. + +Note - if multiple children have the same birth date, they are all given +the same rank. Thus numbering can appear to repeat. I.E. you might see +1., 2., 2., 4. ... if the second and third child were born on the same date. + +grand - a LifeLines database program + by Stephen Dum stephen.dum@verizon.net + Version 1, 15 December 2002 + Version 1.1, 3 June 2007 - minor update +*/ + +global(gkdates) /* list of numeric versions of dates for sorting */ +global(refind) /* list used to hold indexes of dates sorted*/ +global(adopt_event) +proc main() +{ + dayformat(0) /* leave spaces in single digit days */ + monthformat(4) /* print month as Jan... */ + dateformat(0) /* use 'da mon year' order */ + + list(gkdates) + list(refind) + + /* for finding children */ + list(par) /* list of selected individual */ + list(kids) /* children of selected individual */ + list(kids_par) /* and their parent -- unused and all same but + needed for compatibility with later calls */ + list(kids_adop) /* list of adoption flag */ + + /* for finding grand children. at a given index is person in gkids + * and at the same index in gkids_par is the parent */ + list(gkids) /* list of grand children */ + list(gkids_par) /* index into kids array to parent */ + list(gkids_adop) /* adoption flag */ + + /* for finding great grand children */ + list(ggkids) /* list of great grand children */ + list(ggkids_par) /* index into gkids array to the parent */ + list(ggkids_adop) /* adoption flag */ + + /* for finding great great grand children */ + list(gggkids) /* list of great great grand children */ + list(gggkids_par) /* index into ggkids array so we can get parent */ + list(gggkids_adop) /* adoption flag */ + + /* for finding great great great grand children */ + list(ggggkids) /* list of great great great grand children */ + list(ggggkids_par) /* index into gggkids array so we can get parent */ + list(ggggkids_adop) /* adoption flag */ + + /* select individual for report */ + set(indi0, NULL) + set(count,5) + while (not(indi0)) { + getindi(indi0,"Enter person to find grand children for:") + if (not(indi0)) { + print("Individual not found in database.",nl()) + decr(count) + if (not(count)) { + print("aborting", nl()) + return(0) + } + } + } + enqueue(par,indi0) + + /* put out header */ + call print_header(indi0) + + /* compute children of selected individual */ + call compute_child(par,kids,kids_par,kids_adop) + + /* and print children */ + if (not(length(kids))) { + print("No children!",nl()) + return(0) + } + /* for children only 1st 3 params and last are used */ + call print_kids(kids, kids_par, kids_adop, kids, kids_par, + kids, kids_par, kids, 0) + + /* compute grand children */ + call compute_child(kids,gkids,gkids_par,gkids_adop) + if(length(gkids)) { + call print_kids(gkids, gkids_par, gkids_adop, kids, kids_par, + kids, kids_par, kids, 1) + + /* compute great grand children */ + call compute_child(gkids,ggkids,ggkids_par,ggkids_adop) + if(length(ggkids)) { + /* print grand children */ + call print_kids(ggkids, ggkids_par, ggkids_adop, gkids, gkids_par, + kids, kids_par, kids, 2) + + /* compute great great grand children */ + call compute_child(ggkids,gggkids,gggkids_par,gggkids_adop) + if (length(gggkids)) { + call print_kids(gggkids, gggkids_par, gggkids_adop, + ggkids, ggkids_par, + gkids, gkids_par, kids, 3) + + /* compute great great great grand children */ + call compute_child(gggkids,ggggkids,ggggkids_par,ggggkids_adop) + if (length(ggggkids)) { + call print_kids(ggggkids, ggggkids_par, ggggkids_adop, + gggkids, gggkids_par, + ggkids, ggkids_par, gkids, 4) + } + } + } + } +} + +/* compute children from list of parents + * p - list of parents + * c - children being computed + * c_p - indexes into p corresponding to each child + * a - list of adoption dates (or null) for each child + * + * p is passed in, c,c_p and a are outputs and assumed to be zero lenght + * at call + * gkdates - dates to sort by + */ +proc compute_child(p,c,c_p,a) { + /* clear out the gkdates list - easy it's global*/ + list(gkdates) + + forlist(p, e, i) { + families(e, f, indi, j) { + children(f, nextchild, k) { + /* if child is already in the list, we want the + * one with the earliest date only + * This is rare, we could set adopt to -1 and use + * as a flag to print twice, but not count twice + */ + if (birth(nextchild)) { + set(sortdate,get_date(birth(nextchild))) + } else { + set(sortdate,0) + } + if (x,isadopted(nextchild,f,e)) { + /* + * if adopted, put adopt_date into gkdates + * This makes listing + * include adopted as date joined family + */ + if (date(adopt_event)) { + set(sortdate, get_date(adopt_event)) + } + } + if (dupind,finddup(c,nextchild)) { + /* found duplicate + * if new sortdate is smaller than previous, use it + */ + if (lt(sortdate,getel(gkdates,dupind))) { + setel(c_p,dupind,i) + setel(a,dupind,x) + setel(gkdates,dupind,sortdate) + } + } else { + enqueue(gkdates, sortdate) + enqueue(c, nextchild) + enqueue(c_p,i) + enqueue(a,x) + } + } + } + } +} + +/* finddup(clist,ind_child) + * see if ind_child is already in the list, if so, return + * the index for the child - we could use inlist() but + * it doesn't give us the index of the match + */ +func finddup(clist,ind_child) { + forlist(clist,e, i) { + if (eq(e,ind_child)) { return(i) } + } + return(0) +} + +/* print_kids - for lower levels not all arrays are used + * k1 - list of children being printed + * g1 - index into k2 for parents of children + * a - list of adopted flags + * k2 - list of parents of children + * g2 - index into k3 for grand parents + * k3 - list of grandparents + * g3 - index into k4 for great grandparents + * k4 - list of great grandparents + * index - how many levels to print + */ +proc print_kids(k1, g1, a, k2, g2, k3, g3, k4, level) { + list(refind) + set(adopted, 0) /* count number of adopted children */ + /* refind is used to get to names corresponding to elements of + * the gkdates list after sorting + */ + set(len,length(gkdates)) + set(index,len) + while(index) { + setel(refind,index,index) + decr(index) + } + sort(refind,gkdates) + + set(dups,0) + + /* print out the title for the section */ + set(title,start_section(level)) + + /* Iterate over values in refind and print out the data + * lasti - last printed rank for individual + * lastd - birth date of previous entry for same date check + * count - child rank + * + * index - child rank to print for this individual + */ + set(lasti,1) + set(lastd,getel(gkdates,1)) + set(count,0) + forlist(refind, ind, i) { + set(cur_per, getel(k1, ind)) + set(cur_per_par_ind, getel(g1, ind)) + + /* list all children with same birth date as same number + * also, second marriages and adoptions may cause child to be + * listed twice, it's easiest to remove here, since data is sorted + * by birthdate. + */ + incr(count) + if (ne(lastd,getel(gkdates,i))) { + /* dates are different */ + set(index,count) + set(lasti,count) + set(lastd,getel(gkdates,i)) + } else { + /* date same, keep using same index value */ + set(index,lasti) + } + set(adopt,getel(a,ind)) + /* uncomment next 3 lines if you want adopted children to listed, + * but not counted + if (adopt) { + "--" + decr(count) + } + */ + d(index) + /* print first line */ + "." col(5) name(cur_per,false) + col(36) date(birth(cur_per)) + if (eq(level, 0)) { + if(adopt) { + incr(adopted) + col(49) "Adopt:" adopt + } + nl() + } else { + col(49) name(getel(k2,cur_per_par_ind),false) nl() + if(adopt) { + incr(adopted) + col(5) "Adopt:" adopt + } + nl() + } + if (ne(date(death(cur_per)), 0)) { + col(5) "died: " date(death(cur_per)) + if (lt(level,2)) { + nl() + } + } + if (gt(level, 1)) { + set(gpar,getel(g2,cur_per_par_ind)) + col(23) name(getel(k3,gpar),false) + } + if (gt(level,2)) { + col(49) name(getel(k4,getel(g3,gpar)),false) + } + if (gt(level,1)) { + nl() + } + } + + /* print section summary */ + set(count,sub(length(k1),dups)) + nl() + d(count) " " title + if (adopted) { " (" d(adopted) " adopted)" } + nl() + print(d(count), " ", title) + if (adopted) { print(" (",d(adopted)," adopted)") } + print(nl()) +} + +proc print_header(parent) { + col(30) "Children of" nl() + col(30) name(parent,false) nl() + families(parent, f, ind, i) { + col(30) "Spouse: " name(ind, false) nl() + } +} +func start_section(level) { + nl() + if (eq(level,0)) { + set(title,"Children") + print_ref(title) + nl() + col(5) "Name" col(36) "Birth" nl() + } elsif (eq(level,1)) { + set(title,"Grand Children") + print_ref(title) + nl() + col(5) "Name" col(36) "Birth" col(49) "Parent" nl() + } elsif (eq(level,2)) { + set(title,"Great Grand Children") + print_ref(title) + nl() + col(5) "Name" col(36) "Birth" col(49) "Parent" nl() + col(23) "Grand Parent" nl() + } elsif (eq(level,3)) { + set(title,"Great Great Grand Children") + print_ref(title) + nl() + col(5) "Name" col(36) "Birth" col(49) "Parent" nl() + col(23) "Grand Parent" col(49) "Great Grand Parent" nl() + } else { + set(title,"Great Great Great Grand Children") + print_ref(title) + nl() + col(5) "Name" col(36) "Birth" col(49) "Parent" nl() + col(23) "Grand Parent" col(49) "Great Grand Parent" nl() + } + return(title) +} + +func print_ref(title) { + set(l,div(sub(80,strlen(title)),2)) + col(l) title nl() + set(name, concat(" (Compiled by ",getproperty("user.fullname")," ", + stddate(gettoday()),")",nl())) + set(l, add(26,strlen(name))) + set(l,div(sub(80,strlen(name)),2)) + col(l) name +} + +/* check to see if person in family fam is adopted by par */ +/* returns 0 if not adopted */ +func isadopted(per,fam, par) { + /* + * in gedcom 5.5 the structure is + * 1 INDI + * 2 ADOP + * 3 FAMC + * 4 ADOP (BOTH|HUSB|WIFE) + */ + set(x,xref(fnode(fam))) + fornodes(inode(per),e) { + if(eqstr(tag(e),"ADOP")) { + /* + print("adopt record for ",name(per),nl()) + */ + fornodes(e,fam) { + /* check for 'FAMC' with value x */ + if(and(eqstr(tag(fam),"FAMC"),eqstr(value(fam),x))) { + /* now see if famc has a adop record */ + /* + print("... match FAMC ",x,nl()) + */ + fornodes(fam,a) { + if(eqstr(tag(a),"ADOP")) { + /* + print("... ADOP ",value(a)," par=",name(par)) + if (male(par)) { print(" m") } + if (female(par)) { print (" f") } + print(nl()) + */ + set(adopt_event,e) + if(eqstr(value(a),"HUSB")) { + if(male(par)) { + if(da,date(e)) { return(da) } + return("-") + } + } elsif(eqstr(value(a),"WIFE")) { + if(female(par)) { + if(da,date(e)) { return(da) } + return("-") + } + } else { + /* + if(eqstr(value(a),"BOTH")) { .... } + must be "BOTH" (note this has side effect that "" + is treated as both + */ + if(da,date(e)) { return(da) } + else { return("-")} + } + } + } + } + } + } + } + return(0) +} + +/* hack together a integer that can be sorted to represent the date */ +func get_date(datenode) +{ + extractdate(datenode,day,month,year) + return(add(mul(add(mul(year,100), month),100),day)) +} diff --git a/reports/hasnotes1.ll b/reports/hasnotes1.ll new file mode 100644 index 0000000..49fe2f1 --- /dev/null +++ b/reports/hasnotes1.ll @@ -0,0 +1,55 @@ +/* + * @progname hasnotes1.ll + * @version 1.1 + * @author Wetmore, Manis + * @category + * @output Text + * @description + * + * It will produce a report of all the numbers and names (INDI's) + * in the database which have a "NOTE" line at level 1 in the record. + * It is designed for 10 or 12 pitch, HP laserjet III, or any + * other printer (ASCII output). + + * hasnotes1 + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * Modifications by Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in Sep 1992, + * + */ + +proc main () +{ + "PERSONS IN THE DATABASE WITH NOTES" nl() nl() + forindi (i, n) { + set(r, inode(i)) + set(notfound, 1) + fornodes (r, n) { + if (and(notfound, eq(0, strcmp("NOTE", tag(n))))) { + set(notfound, 0) + key(i) col(8) name(i) nl() + } + } + } +} + +/* Sample output of report. + +PERSONS IN THE DATABASE WITH NOTES + +I1 Alda Clifford MANIS +I2 Fuller Ruben MANES +I3 Edith Alberta MANIS +I4 William Bowers MANES +I5 Cordelia "Corda" F. CANTER +I6 William Loyd MANIS + (all these INDI's did have a NOTE line) + +*/ + +/* End of Report */ + diff --git a/reports/hp-anc.ll b/reports/hp-anc.ll new file mode 100644 index 0000000..c7ecb69 --- /dev/null +++ b/reports/hp-anc.ll @@ -0,0 +1,1637 @@ +/* + * @progname hp-anc.ll + * @version 1 of 1995-12-01 + * @author Dennis Nicklaus (nicklaus@wishep.physics.wisc.edu) + * @category + * @output HPGL + * @description + * + * This LifeLines report program generates autoscaling HPGL ancestral and + * descendant charts. The ancestral charts can include the siblings + * of all direct ancestors (aunts, uncles, great-aunts, great-uncles, etc.) + * The chart format is based on the program GedChart, by Tom Blumer. + * +** hp-anc was developed by modifying the output portion (print_person +** function) of ps-anc3 (from ps-anc2). Thus most features of ps-anc3 are +** still supported, except for the multi-page output option. +** +** CAVEATS/FEATURES: +** 1. You might find it useful to be familiar with ps-anc3 first. +** 2. The HPGL text scaling here is very inadequate. +** I just picked a couple of scale factors which work for the +** paper size (usu 24x36 inches (E)) and chart depths (15-18 gen) +** which I needed it for and typically use. The scale factors I +** picked make the text still readable (if you use a 0.25 plotter pen) +** but let you stuff a lot of information onto one chart. +** Gedchart does a better job, but I don't know how. +** And sometimes Gedchart scales the text down too far so it is +** too small to read. These fixed scales avoid that, +** but there is no guarantee that text lines won't run together +** vertically or exceed it's "generation width". +** +** 3. All the scaling & placement is done exactly as in ps-anc3, as +** if we were generating postscript output. Then at the end, +** that scale is just adjusted to an HPGL autoscale. This may +** give you less than perfect results. I certainly haven't +** tried all cases. +** +** 4. Like Gedchart does, hp-anc includes a line of text on the +** chart if you have a note which begins with the keyword tag GEDCHART. +** For instance: +** GEDCHART Fought in the Rev. War +** will result in a line of text "Fought in the Rev. War" +** on the chart for that person. +** +** 5. ps-anc3 didn't have that note capability, and so the extra +** line of text that requires is NOT built into the placement +** algorithm for ancestor charts (but it does work for desc. charts). +** Thus, you might end up with a note line which +** comes out overwriting the next person down on the chart. +** This will generally only be a problem with tightly packed siblings +** or with people with no ancestors in an ancestor plot. +** +** 6. I recommend you use a previewer for the output before +** you waste a nice sheet of vellum and 30 min. on the plotter. +** I run my HPGL output through hpgl2ps-v2 by Dan McCormick, +** then view the postscript using pageview (Sun postscript +** previewer) or ghostscript. hpgl2ps does not do the text scaling +** conversion perfectly. So even though it looks like a line of text +** is too long under the postscript viewer, it may be fine +** when plotted out. You'll have to use some trial and error. +** +** 7. A have added a couple extra date/place style options beyond +** what ps-anc2 had. My favorite is the date+2places(#5) +** which will turn Madison,DaneCo,WI into Madison,WI +** or "Sitter,bei Ankum,Lower Saxony,Germany" into "Sitter,Germany" +** You still may want to look at and edit the HPGL output before +** you print it out to make sure everything is what you want. +** +** 8. Has some rudimentary "print birth & death on same line" option. +** +** 9. Jumped through a lot of hoops to save a little space when +** moving from one generation to the next in do_des. +** +** WISH LIST +** 1. Use multiple colors? (but it already takes a long time to plot. +** it'd be even longer if it has to switch pens) +** 2. Take note line into account for placement of anc. charts. +** 3. Better text scaling +** 4. Figure out how to make characters like a-umlaut, o-umlaut,... in HPGL +** (I currently do these with e" but it isn't great. +** 5. Change dates like "Aft 1990" to "Aft 1990" (remove extra spaces). +** (I currently do this by hand with a text editor) +** +** After you use this program a few times, you might wish to edit the +** function interrogate_user(). This is the first function after +** these comments and the global variable declarations. This +** function is set up to make it easy for you to configure what +** questions this program should ask you each time and what default +** values it should use for questions not asked. +** +** Please contact me if you like this program, find any bugs, have +** any bug fixes, or want to suggest improvements. I am also always +** on the lookout for better ancestral/descendant chart generating +** programs. If you know of a program that generates charts which +** you like better than those generated by this program, please drop +** me a line. +** +** This report program works with the LifeLines Genealogical database +** program only. (see ftp://ftp.cac.psu.edu/pub/genealogy/lines/*) +** +** hp-anc, 1 December 1995, by Dennis Nicklaus (nicklaus@wishep.physics.wisc.edu) +** heavily based on ps-anc3, which is a derivative of : +** ps-anc2, 16 August 1994, by Fred Wheeler (wheeler@ipl.rpi.edu) +** +** CHANGE LOG +** +** This is version 1 +** +** CREDITS +** Many thanks to Fred Wheeler developer of ps-anc2 +** +** ABOUT GEDCHART (a different program) +** +** I got some of the HPGL plotter setup commands from HPGL output +** of the GEDCHART program written by Tom Blumner +** (blumer@ptltd.com). It is used here without his permission. +** The report is very much like that generated by GedChart using the +** -Sa or -Sd option. GEDCHART has some features this program does not. +** +** GedChart is DOS program that generates ancestral and descendant +** charts like this report program, and also fan charts. GedChart +** works directly from a GEDCOM file and is completely independent of +** LifeLines. It is currently up to version 1.6, which is a beta +** version that may lead to a commercial product. You can find +** GedChart at ftp:oak.oakland.edu/pub/msdos/genealgy/gedcht16.zip +** +*/ + +global (high_pos_gen) /* array, highest so far in each generation */ +global (high_pos_all) /* highest position so far for any generation */ +global (last_child_pos) /* place where last child was enqueued on desc. chart */ + +global (name_height) /* height of name text on chart */ +global (generation_height) /* space from parent to child on desc. chart */ +global (date_height) /* height of birth/death/marriage date text */ + +global (no_parent_extra) /* constant, extra vert. line when no parent */ + +/* variables prompted from or configured by the user */ + +global (chart_type) /* int, 0: ancestral, 1: descendant */ +global (all_same_line) /* int, 0: separate name, b,d lines, + 1: name,b.d. all same line,name + 2: name sep.,b.d. on same line + is NOT supported in HP format */ + +global (root_person) /* indi, person for whom to generate the chart */ +global (font_name) /* string, name of font */ +global (max_depth) /* int, maximum number of generations */ +global (chart_label) /* string, label for corner of chart */ +global (color_chart) /* boolean, is chart in color */ +global (multi_page) /* boolean, is chart many page poster type */ +global (x_pages) /* int, number of horizontal pages */ +global (y_pages) /* int, number of vertical pages */ +global (name_letters) /* int, maximum number of letters in a name */ +global (title_method) /* int, code for how to insert titles */ +global (depth_siblings) /* int, number of generations to show siblings */ +global (dateplace_birth) /* int, date style for birth/death/marriage */ +global (dateplace_death) +global (dateplace_marriage) +global (dennis) + +/* variables to return values from procedures to make them functions */ +global (do_anc_stack) /* stack, function do_anc is recursive */ +global (person_height_return) +global (is_prefix_title_return) +global (dateplace_return) + +/* these three constants define how close branches of the tree can get */ +global (branch_dist_prev) /* minimum distance from previous generation */ +global (branch_dist_same) /* minimum distance from same generation */ +global (branch_dist_next) /* minimum distance from next generation */ + +/* stacks for storing the information for each person on the chart */ +/* see proc's enqueue_person and dequeue_all_persons */ + +global (plist_person) /* the person (to extract name, birth, death) */ +global (plist_depth) /* generation depth */ +global (plist_pos) /* vertical position */ +global (plist_line) /* 0,1 boolean, is direct ancestor? */ +global (plist_mdate) /* marriage date */ +global (plist_note) /* marriage date */ + +/* stacks for storing the information for each vertical line on the chart */ +/* see proc's enqueue_vertical and dequeue_all_verticals */ + +global (llist_depth) /* generation depth */ +global (llist_low) /* starting point */ +global (llist_high) /* finishing point */ + +global (shortname_scale) +global (longname_scale) + +global (shortdate_scale) +global (longdate_scale) +global (longname_cutoff) +global (longdate_cutoff) +/* +** procedure: interrogate_user +** +** This procedure is designed to be modified by the user. It asks +** many questions about how to configure the charts. If your answer +** to one of the questions is always the same, you can easily +** hardwire your answer here so that you are never asked again. +** +** An 'if' statement is wrapped around each question. The 'if (1)' +** can be changed to an 'if (0)' to make the program use the default +** value defined in the 'else' clause instead of asking every time. +** +*/ + +proc interrogate_user () +{ + +/* +** QUESTION: What type of chart? +** +** This should always be asked, unless you never use one of the two +** types of charts. +** +*/ + + if (1) { + getintmsg (chart_type, + "Enter 0 for ancestral, 1 for descendant chart") + } else { + set (chart_type, 1) + } + +/* +** QUESTION: Who is the root person? +** +** This question should always be asked, unless you always use the same +** person, which is not likely. If you do set a default, it is a string +** representation of that persons number. +** +*/ + + if (1) { + set (root_person, 0) + while ( not (root_person) ) { + getindimsg (root_person, "Identify root person for chart") + } + } else { + set (root_person, indi ("1")) + } + +/* +** QUESTION: How many generations should be shown? +** +** This should always be explicitly asked. +** +*/ + + if (1) { + getintmsg (max_depth, "Maximum number of generations") + } else { + set (max_depth, 6) + } + if (gt (max_depth,15)) { + set (shortname_scale,";SR0.166,0.266;") + set (longname_scale,";SR0.136,0.216;") + set (shortdate_scale,";SR0.136,0.216;LB") + } else { + set (shortname_scale,";SR0.201,0.322;") + set (longname_scale,";SR0.166,0.266;") + set (shortdate_scale,";SR0.151,0.241;LB") + } + set (longdate_scale,";SR0.100,0.161;LB") + if (lt (max_depth,8)) { + set (longname_cutoff,40) + set (longdate_cutoff,60) + } + else { + set (longname_cutoff,20) + set (longdate_cutoff,36) + } + +/* +** QUESTION: How many lines per person. +*/ + if (1) { + getintmsg (all_same_line, + "birth & death lines: 0=Sep.;1= with name.") + } else { + set (all_same_line, 0) + } + +/* +** QUESTION: How many generations should show siblings? +** +** If you want to show siblings in all generations, set this default to 999. +** This question is only asked for ancestral charts. +** +*/ + + if (eq (chart_type, 0)) { + + if (1) { + getintmsg (depth_siblings, "How many generations to show siblings") + } else { + set (depth_siblings, 1) + } + + } + +/* +** QUESTION: What message should be shown in the corner of the chart? +** +** I suggest not asking this question, and setting a default credit with +** your name. The advantage of this is that you can have the date +** automatically inserted. +** +*/ + + if (1) { + getstrmsg (chart_label, "Label for corner of chart (your name, date)") + set (chart_label, save (chart_label)) + } else { + dayformat (2) + monthformat (6) + dateformat (0) + set (chart_label, + concat ("by Dennis J. Nicklaus, ", save (stddate (gettoday ())))) + } + +/* +** QUESTION: What font should be used? +** +** Because it is such a pain to enter a font name, and a spelling mistake +** will get you an ugly default font, this should be set to a default. I +** suggest one of: Times-Roman, NewCenturySchlbk-Roman, or ZapfChancery. +** Search the Postscript code at bottom of this file for a longer list. +** +*/ + + if (0) { + getstrmsg (font_name, + "Font (Times-Roman, NewCenturySchlbk-Roman, ZapfChancery, etc.") + set (font_name, save (font_name)) + } else { + set (font_name, "Times-Roman") + } + +/* +** QUESTION: Should color be used? +** +** If you don't have access to a color printer, you should probably turn +** off this question. +** +*/ + + if (0) { + getintmsg (color_chart, "Enter 0 for black/white, 1 for color") + } else { + set (color_chart, 0) + } + +/* +** QUESTION: Do you want multi-page poster output? +** +** So that I am not hassled with this question everytime I run this +** program, I turn this question off, but change the default on the +** special occasion that I want a poster chart. +** +*/ + + if (0) { + getintmsg (multi_page, "Enter 0 for single page, 1 for multipage") + } else { + set (multi_page, 0) + } + +/* +** QUESTION: How many pages make up the poster? +** +** You will probably want to always ask this question. This question is +** asked if a poster chart is requested. +** +*/ + + if (multi_page) { + + if (1) { + getintmsg (x_pages, "Number of horizontal pages") + getintmsg (y_pages, "Number of vertical pages") + } else { + set (x_pages, 3) + set (y_pages, 3) + } + + } else { + set (x_pages, 1) + set (y_pages, 1) + } + +/* +** QUESTION: How should titles be used? +** +** I would leave this default set to 'guess' (3), or 'none' (0), if you +** don't want the titles. If find a title that is guessed incorrectly, +** please send an e-mail to wheeler@ipl.rpi.edu. +** +*/ + + if (0) { + getintmsg (title_method, + "Title method (0:none,1:prefix,2:suffix,3:guess)") + } else { + set (title_method, 3) + } + +/* +** QUESTION: What is the maximum length for names? +** +** It is best to just set a default maximum name length. If you want +** to always show the complete name, just set the default to 999. +** +*/ + + if (0) { + getintmsg (name_letters, "Maximum name length") + } else { + set (name_letters, 40) + } + +/* +** QUESTION: How should dates/places of birth/death/marriage be shown? +** +** This is actually three questions, or the same question for birth +** death and marriage dates. The codes cause the dates to be printed +** as follows. +** +** 0: do not show date +** 1: full date only +** [ LifeLines date() function ] +** 2: date and place, just year and State/Country +** [ LifeLines short() function ] +** 3: full date and full place, can get very long and thus smushed +** [ LifeLines long() function ] +** 4: full date and 1st place field +** 5: full date and 1st and last place fields (useful for picking +** up the city, country or city,state without the county). +** +*/ + + if (1) { + set (dateplace_birth, 99) + while (or (lt (dateplace_birth, 0), ge (dateplace_birth, 6))) { + getintmsg (dateplace_birth, + "Birth date style (0:no,1:date,2:short,3:long,4:date+1st place,5:+2pl)") + } + set (dateplace_death, 99) + while (or (lt (dateplace_death, 0), ge (dateplace_death, 6))) { + getintmsg (dateplace_death, + "Death date style (0:no,1:date,2:short,3:long,4:date+1st place,5:+2pl)") + } + set (dateplace_marriage, 99) + while (or (lt (dateplace_marriage, 0), + ge (dateplace_marriage, 6))) { + getintmsg (dateplace_marriage, + "Marriage date style (0:no,1:date,2:short,3:long,4:date+1st place,5:+2pl)") + } + } else { + set (dateplace_birth, 5) + set (dateplace_death, 5) + set (dateplace_marriage, 5) + } + +/* +** END OF QUESTIONS +** +*/ + +} + +/* +** procedure: main +** +** The main procedure. +** +*/ + +proc main () +{ + + /* set constants */ + + set (name_height, 1300) /* height to allow for name text */ + set (date_height, 750) /* height to allow for date text */ + set (generation_height, 1300) /* space from parent to child in des. chart */ + + set (branch_dist_prev, 1200) /* previous generation */ + set (branch_dist_same, 1500) /* same generation */ + set (branch_dist_next, 1200) /* next generation */ + + set (no_parent_extra, 600) /* a little extra line when no parent */ + + /* initialize other global variables and declare global stacks */ + + set (high_pos_all, 0) + + list (high_pos_gen) + list (do_anc_stack) + + list (plist_person) + list (plist_depth) + list (plist_pos) + list (plist_line) + list (plist_mdate) + list (plist_note) + + list (llist_depth) + list (llist_low) + list (llist_high) + + call interrogate_user () + + /* covert the numerical response for color to "true" or "false" */ + + if (eq (color_chart, 0)) { + set (color_true_false, "false") + } else { + set (color_true_false, "true") + } + + /* start iteration that creates the chart */ + + if (eq (chart_type, 0)) { + call do_anc (root_person, 1, 0, 0) + } else { + call do_des (root_person, 1) + } + + /* put the pieces together to make the output file */ + + set (xi, 1) + while ( le (xi, x_pages)) { + set (yi, 1) + while ( le (yi, y_pages)) { + + call print_header (font_name, max_depth, high_pos_all, + color_true_false, chart_label, + xi, x_pages, yi, y_pages) + call dequeue_all_persons () + call dequeue_all_verticals () + call print_tailer() + set (yi, add (yi, 1)) + } + set (xi, add (xi, 1)) + } + +} + +/* +** procedure: do_anc +** +** A recursive function to position persons on an ancestral chart. +** First, a recursive call is made to put the father on the chart. +** Where he is put on the chart determines the minimum position for +** the mother. Once the father and mother are put on the chart, the +** siblings are put on the chart. +** +** The position of the person is returned via the global stack +** do_anc_stack. A stack is necessary since this procedure is +** reentrant. +** +*/ + +proc do_anc (person, depth, min_pos_arg, marriage_date) +{ + /* don't want to modify procedure argument variable, so copy it */ + + set (min_pos, min_pos_arg) + + /* figure out number of siblings and total sibling height */ + /* done differently, depending on whether the parents family exists */ + + set (fam, parents (person)) + if ( and ( fam, le (depth, depth_siblings) ) ) { + + set (sibling_height, 0) + children (fam, child, unused_number) { + call person_height (child) + set (sibling_height, add (sibling_height, person_height_return)) + } + set (num_siblings, nchildren (fam)) + + } else { + + call person_height (child) + set (sibling_height, person_height_return) + set (num_siblings, 1) + + } + + /* add extra width for marriage date of male ancestor, if it is known */ + + if (marriage_date) { + set (sibling_height, add (sibling_height, date_height)) + } + + /* make sure minimum position is greater than zero */ + + if (lt (min_pos, 0)) { + set (min_pos, 0) + } + + /* do not overlap another branch at the younger generation */ + + if (gt (depth, 1)) { + if (high, getel (high_pos_gen, sub (depth, 1))) { + if (lt (min_pos, add (high, branch_dist_prev))) { + set (min_pos, add (high, branch_dist_prev)) + } + } + } + + /* do not overlap another branch at the same generation */ + + if (high, getel (high_pos_gen, depth)) { + if (lt (min_pos, add (high, branch_dist_same))) { + set (min_pos, add (high, branch_dist_same)) + } + } + + /* do not overlap another branch at the older generation */ + + if (lt (depth, max_depth)) { + if (high, getel (high_pos_gen, add (depth, 1))) { + if (lt (min_pos, add (high, branch_dist_next))) { + set (min_pos, add (high, branch_dist_next)) + } + } + } + + /* do father if he exists and is not too deep */ + + set (dad_min_pos, sub (min_pos, name_height)) + set (dad_pos, dad_min_pos) + set (did_dad, 0) /* boolean, is dad on the chart */ + + if (lt (depth, max_depth)) { + if (par, father (person)) { + call dateplace (marriage (parents (person)), dateplace_marriage) + if (dateplace_return) { + call do_anc (par, add (depth, 1), dad_min_pos, dateplace_return) + } else { + call do_anc (par, add (depth, 1), dad_min_pos, 0) + } + set (dad_pos, pop (do_anc_stack)) + set (did_dad, 1) + } + } + + if (lt (min_pos, add (dad_pos, name_height))) { + set (min_pos, add (dad_pos, name_height)) + } + + /* do mother if she exists and is not too deep */ + + set (mom_min_pos, add (add (dad_pos, name_height), sibling_height)) + set (mom_pos, mom_min_pos) + set (did_mom, 0) /* boolean, is mom on the chart */ + + if (lt (depth, max_depth)) { + if (par, mother (person)) { + call do_anc (par, add (depth, 1), mom_min_pos, 0) + set (mom_pos, pop (do_anc_stack)) + set (did_mom, 1) + } + } + + /* find the spacer needed to line up siblings between parents */ + + set (delta, sub (mom_pos, add (dad_pos, name_height))) + set (extra, sub (delta, sibling_height)) + set (spacer, div (extra, add (num_siblings, 1))) + + set (pos, add (dad_pos, name_height)) + set (pos, add (pos, spacer)) + + /* position siblings, differently depending on whether parents exist */ + + if (fam, parents (person)) { + + if ( le (depth, depth_siblings)) { + + children (fam, child, number) { + + /* if this is the ancestor, return the position and use marriage */ + + if (eq (child, person)) { + call enqueue_person (child, depth, pos, 1, marriage_date) + push (do_anc_stack, pos) + } else { + call enqueue_person (child, depth, pos, 0, 0) + } + + /* store the positions of the first and last children */ + + if (eq (number, 1)) { + set (first_pos, pos) + } + if (eq (number, nchildren (fam))) { + set (last_pos, pos) + } + + /* increment position by height of person plus the spacer */ + + call person_height (child) + set (pos, add (pos, person_height_return)) + if (and (eq (child, person), marriage_date)) { + set (pos, add (pos, date_height)) + } + set (pos, add (pos, spacer)) + } + + } else { + + call enqueue_person (person, depth, pos, 1, marriage_date) + push (do_anc_stack, pos) + + /* this may cause a line of zero length to be drawn */ + set (first_pos, pos) + set (last_pos, pos) + + /* increment position by height of person plus the spacer */ + + call person_height (person) + set (pos, add (pos, person_height_return)) + if (marriage_date) { + set (pos, add (pos, date_height)) + } + set (pos, add (pos, spacer)) + } + + /* if father is on the chart, he determines the vertical line start */ + /* otherwise, the oldest sibling does */ + + if (eq (did_dad, 1)) { + set (line_start, dad_pos) + } else { + set (line_start, sub (first_pos, no_parent_extra)) + } + + /* note: line_start may be < 0, that is OK */ + + /* if mother is on the chart, she determines the vertical line end */ + /* otherwise, the youngest sibling does */ + + if (eq (did_mom, 1)) { + set (line_end, mom_pos) + } else { + set (line_end, add (last_pos, no_parent_extra)) + } + + /* print vert. line if parent or any siblings are on the chart */ + + if (or (or (did_mom, did_dad), gt (nchildren (fam), 1))) { + call enqueue_vertical (depth, line_start, line_end) + /* update highest overall position */ + if (lt (high_pos_all, add (line_end, name_height))) { + set (high_pos_all, add (line_end, name_height)) + } + } + + } else { + + /* else, if the person has no visible siblings */ + + call enqueue_person (person, depth, pos, 1, marriage_date) + push (do_anc_stack, pos) + + /* increment position by height of person plus the spacer */ + + call person_height (person) + set (pos, add (pos, person_height_return)) + if (marriage_date) { + set (pos, add (pos, date_height)) + } + set (pos, add (pos, spacer)) + } + + /* update the highest position array, or set it for the first time */ + + if (high, getel (high_pos_gen, depth)) { + if (lt (high, pos)) { + setel (high_pos_gen, depth, pos) + } + } else { + setel (high_pos_gen, depth, pos) + } + + /* update the overall highest position */ + + if (lt (high_pos_all, pos)) { + set (high_pos_all, pos) + } +} + +/* +** procedure: do_des +** +** A recursive function to position persons on a descendant chart. +** +*/ + +proc do_des (person, depth) +{ + /* don't want to modify procedure argument variable, so copy it */ + + set (min_pos, min_pos_arg) + + set (make_line, 0) + set (this_persons_fams,nfamilies(person)) + set (spouse_number,0) + + if (female (person)) { + families (person, fam, spouse, num) { + set (make_line, 1) + if (eq (num, 1)) { + set (line_top, high_pos_all) + } + call dateplace (marriage (fam), dateplace_marriage) + set (mdate, dateplace_return) + if (spouse) { + set (spouse_number,add(1,spouse_number)) + call enqueue_person (spouse, depth, high_pos_all, 0, mdate) + call person_height (spouse) + set (high_pos_all, add (high_pos_all, generation_height)) + set (saw_female_family,0) + set (extra_height, sub (person_height_return,generation_height)) + if (mdate) { + set (extra_height, add (extra_height, date_height)) + } + } else { + set (high_pos_all, add (high_pos_all, generation_height)) + } + if (lt (depth, max_depth)) { + children (fam, child, cn) { + set (saw_female_family,1) + call do_des (child, add (depth, 1)) + } + } + /* if it is not the last spouse, then if there were no kids, + make sure we leave sufficient space below him */ + if (ne(spouse_number,this_persons_fams)){ + if (eq(0,saw_female_family)){ + set (high_pos_all, add (high_pos_all, extra_height)) + set(extra_height,0) + } + } + }/* end families loop */ + if (eq(0,saw_female_family)){ + set (high_pos_all, add (high_pos_all, extra_height)) + set(saw_female_family,2) + } + + if (eq(1,saw_female_family)){ + set(high_pos_all,add(last_child_pos,generation_height)) + } + set(last_child_pos,high_pos_all) + call enqueue_person (person, depth, high_pos_all, 1, 0) + set (line_bot, high_pos_all) + call person_height (person) + set (high_pos_all, add (high_pos_all, person_height_return)) + + } else { + set(last_child_pos,high_pos_all) + call enqueue_person (person, depth, high_pos_all, 1, 0) + set (line_top, high_pos_all) + call person_height (person) + set (high_pos_all, add (high_pos_all, generation_height)) + set (extra_height, sub (person_height_return,generation_height)) + + families (person, fam, spouse, num) { + set (saw_male_family,0) + set (make_line, 1) + if (lt (depth, max_depth)) { + children (fam, child, cn) { + set(saw_male_family,1) + call do_des (child, add (depth, 1)) + } + } + if (eq(0,saw_male_family)){ + set (high_pos_all, add (high_pos_all, extra_height)) + set(saw_male_family,2) + } + call dateplace (marriage (fam), dateplace_marriage) + set (mdate, dateplace_return) + set (line_bot, high_pos_all) + if (spouse) { + if (eq(1,saw_male_family)){ + set(high_pos_all,add(last_child_pos,generation_height)) + set (line_bot, high_pos_all) + set(extra_height,0) + } + set(last_child_pos,high_pos_all) + call enqueue_person (spouse, depth, high_pos_all, 0, mdate) + call person_height (spouse) + set (high_pos_all, add (high_pos_all, person_height_return)) + if (mdate) { + set (high_pos_all, add (high_pos_all, date_height)) + } + } else { + set (high_pos_all, add (high_pos_all, name_height)) + } + } + /* add in the rest of this male's height if he has no family (no kids) */ + if (eq(0,saw_male_family)){ + set (high_pos_all, add (high_pos_all, extra_height)) + set(saw_male_family,1) + } + + } + + if (make_line) { + call enqueue_vertical (depth, line_top, line_bot) + } +} +/* +** procedure: do_des_oldone +** +** older version of do_des +** +*/ +proc do_des_oldone (person, depth) +{ + /* don't want to modify procedure argument variable, so copy it */ + + set (min_pos, min_pos_arg) + + set (make_line, 0) + + if (female (person)) { + + families (person, fam, spouse, num) { + set (make_line, 1) + if (eq (num, 1)) { + set (line_top, high_pos_all) + } + call dateplace (marriage (fam), dateplace_marriage) + set (mdate, dateplace_return) + + + if (spouse) { + call enqueue_person (spouse, depth, high_pos_all, 0, mdate) + call person_height (spouse) + set (high_pos_all, add (high_pos_all, person_height_return)) + if (mdate) { + set (high_pos_all, add (high_pos_all, date_height)) + } + } else { + set (high_pos_all, add (high_pos_all, name_height)) + } + if (lt (depth, max_depth)) { + children (fam, child, cn) { + call do_des (child, add (depth, 1)) + } + } + } + call enqueue_person (person, depth, high_pos_all, 1, 0) + set (line_bot, high_pos_all) + call person_height (person) + set (high_pos_all, add (high_pos_all, person_height_return)) + + } else { + + call enqueue_person (person, depth, high_pos_all, 1, 0) + set (line_top, high_pos_all) + call person_height (person) + set (high_pos_all, add (high_pos_all, person_height_return)) + families (person, fam, spouse, num) { + set (make_line, 1) + if (lt (depth, max_depth)) { + children (fam, child, cn) { + call do_des (child, add (depth, 1)) + } + } + call dateplace (marriage (fam), dateplace_marriage) + set (mdate, dateplace_return) + set (line_bot, high_pos_all) + if (spouse) { + call enqueue_person (spouse, depth, high_pos_all, 0, mdate) + call person_height (spouse) + set (high_pos_all, add (high_pos_all, person_height_return)) + if (mdate) { + set (high_pos_all, add (high_pos_all, date_height)) + } + } else { + set (high_pos_all, add (high_pos_all, name_height)) + } + } + } + + if (make_line) { + call enqueue_vertical (depth, line_top, line_bot) + } +} + +/* +** procedure: dateplace +** +** Get the date of an event in the appropriate style (which may include +** the place. Return via global variable. +** +*/ + +proc dateplace (ev, style) +{ + list(placeList) + if (eq (style, 0)) { + set (dateplace_return, 0) + } + if (eq (style, 1)) { + set (dateplace_return, save (date (ev))) + } + if (eq (style, 2)) { + set (dateplace_return, save (short (ev))) + } + if (eq( style, 3)) { + set (dateplace_return, save (long (ev))) + } + if (eq (style, 4)) { /* date + first place field */ + extractplaces(ev,placeList,nPlaces) + /* we want to find the first non-empty place. + We have to use this placeEq thing here to let + us skip past leading commas, effectively. + We look at the first place field initially, + but if it is blank, then we incr placeEq so + that we check the next place field for a value */ + set (placeEq,1) + forlist (placeList, theplace, placeN) { + if (eq(strlen(theplace),0)){ + incr(placeEq) + } + if (eq(placeN,placeEq)){ + set (dennis,save(theplace)) + } + } + /* if there was no place info, just return the date. + But if there was some place info, concatenate it + onto the date, with a space in between. */ + if (eq (nPlaces,0)){ + set (dateplace_return, save (date (ev))) + } + else { + set (dateplace_return, save (concat (date (ev),concat(" ",dennis)))) + } + } + if (eq (style, 5)) { /* date + first + last place fields */ + extractplaces(ev,placeList,nPlaces) + /* we want to find the first non-empty place. + We have to use this placeEq thing here to let + us skip past leading commas, effectively. + We look at the first place field initially, + but if it is blank, then we incr placeEq so + that we check the next place field for a value */ + set (placeincr_once_already,0) + set (dennislast,"") + set (placeEq,1) + forlist (placeList, theplace, placeN) { + if (eq(strlen(theplace),0)){ + incr(placeEq) + } + else{ + if (eq(placeN,placeEq)){ + if (eq(placeincr_once_already,0)){ + set (dennis,save(theplace)) + set (placeincr_once_already,1) + } + else { + set (dennislast,save(theplace)) + } + incr(placeEq) + } /* end if eq */ + } /* end else non-null */ + } /* end forlist */ + if (ge (strlen(dennislast),0)){ + set (dennisfirst,save(dennis)) + set (dennis,save(concat(concat(dennisfirst,","),dennislast))) + } + /* if there was no place info, just return the date. + But if there was some place info, concatenate it + onto the date, with a space in between. */ + if (eq (nPlaces,0)){ + set (dateplace_return, save (date (ev))) + } + else { + set (dateplace_return, save (concat (date (ev),concat(" ",dennis)))) + } + } + if (ge (style, 6)) { + print ("error: invalid date style code") + } +} + +/* +** procedure: person_height +** +** Return the height of a single persons entry. Only the name, and +** birth and death dates are considered. The name is assumed to be in +** the database, the dates are checked for. The marriage date is not +** checked for here. It is more tricky since it is only put below the +** father's name and you have to make sure you have the date from the +** right marriage. +** +** The height of the person is returned via the global variable +** person_height_return. This global variable is used since LifeLines +** does not yet provide user-defined functions. +** +*/ + +proc person_height (person) +{ + set (person_height_return, name_height) + + call dateplace (birth (person), dateplace_birth) + if (eq(0,all_same_line)){ /* count b. & d. both */ + if (dateplace_return) { + set (person_height_return, add (person_height_return, date_height)) + } + + call dateplace (death (person), dateplace_death) + if (dateplace_return) { + set (person_height_return, add (person_height_return, date_height)) + } + } + if (eq(2,all_same_line)){ /* only count b. or death, not both */ + if (dateplace_return) { + set (person_height_return, add (person_height_return, date_height)) + } + else{ + call dateplace (death (person), dateplace_death) + if (dateplace_return) { + set (person_height_return, add (person_height_return, date_height)) + } + } + } + /* The gedchart note location doesn't work for anc. chart. I don't know why. + I guess it runs out of space or something? + I guess it is OK since they don't usually matter for space + in anc. charts (unless siblings are included or at end generations)*/ + if (eq(chart_type,1)){ + set(hadgednote,0) + fornotes(inode(person),note){ + set (i, index(note,"GEDCHART",1)) + if (gt(i,0)){ + set(hadgednote,1) + } + } + if (eq(hadgednote,1)){ + set (person_height_return, add (person_height_return, date_height)) + } + } + +} + +/* +** procedure: is_prefix_title +** +** Decide if the given title is a prefix type title. Returns boolean +** response in global variable is_prefix_title_return. +** +*/ + +proc is_prefix_title (t) +{ + set (is_prefix_title_return, 0) + + if (index (t, "Mr", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Mrs", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Ms", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Miss", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Dr", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Prof", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Hon", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Judge", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Brot", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Sis", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Deacon", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Fr", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Father", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Rev", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Mons", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Msgr", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Arch", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Bish", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Card", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Pope", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Lord", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Baron", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Duke", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Princ", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Lady", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Queen", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "King", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Pres", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Sen", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Cong", 1)) { set (is_prefix_title_return, 1) } + if (index (t, "Rep", 1)) { set (is_prefix_title_return, 1) } +} + +/* +** procedure: enqueue_person +** +** Store the data for a person in the global lists. It will be +** printed later. +** +*/ +global(chartnote) +proc enqueue_person (person, depth, pos, line, mdate) +{ + enqueue (plist_person, person) + enqueue (plist_depth, depth) + enqueue (plist_pos, pos) + enqueue (plist_line, line) + enqueue (plist_mdate, mdate) + + /* Inserted by D. Nicklaus. Find the GEDCHART NOTE and enqueue it, too */ + set(chartnote,"") + fornotes(inode(person),note){ + set (i, index(note,"GEDCHART",1)) + if (gt(i,0)){ + set(chartnote,save(substring(note,add(9,i),strlen(note)))) + } + + + } + enqueue (plist_note, chartnote) + + + +} + +/* +** procedure: dequeue_all_persons +** +** Dequeue and print all persons stored in the global lists. The +** lines are stored in a second queue as they are printed and then +** placed back in the original, global, queue. +** +*/ + +proc dequeue_all_persons () +{ + list (tlist_person) + list (tlist_depth) + list (tlist_pos) + list (tlist_line) + list (tlist_mdate) + list (tlist_note) + + while (person, dequeue (plist_person)) { + set (depth, dequeue (plist_depth)) + set (pos, dequeue (plist_pos)) + set (line, dequeue (plist_line)) + set (mdate, dequeue (plist_mdate)) + set (noteprint, dequeue (plist_note)) + + call print_person (person, depth, pos, line, mdate,noteprint) + + enqueue (tlist_person, person) + enqueue (tlist_depth, depth) + enqueue (tlist_pos, pos) + enqueue (tlist_line, line) + enqueue (tlist_mdate, mdate) + enqueue (tlist_note, noteprint) + } + + while (person, dequeue (tlist_person)) { + set (depth, dequeue (tlist_depth)) + set (pos, dequeue (tlist_pos)) + set (line, dequeue (tlist_line)) + set (mdate, dequeue (tlist_mdate)) + set (noteprint, dequeue (tlist_note)) + + enqueue (plist_person, person) + enqueue (plist_depth, depth) + enqueue (plist_pos, pos) + enqueue (plist_line, line) + enqueue (plist_mdate, mdate) + enqueue (plist_note, noteprint) + } +} + +/* +** procedure: print_person +** +** Print a line of data for a person in postscript format. Each line +** printed is essentially a call to a postscript function defined in the +** header. +** +*/ + +proc print_person (person, depth, pos, line, mdate,noteprint) +{ + /* since there is no floating point, multiply everything by another + 1000/1000 to not lose too much precision*/ + set(normpos,div(mul(high_pos_all,1000),9950)) + /* I really want to divide by 10020 there, but I need extra room for + the birth and death lines of the lowest person */ + set(pos, sub(high_pos_all,pos)) + set(pos, div(mul(pos,1000),normpos)) + + /* extra offset for b. & d. lines of lowest person */ + set(pos, add(pos,70)) + + if (eq (title_method, 0)) { + set (prefix_title, 0) + set (suffix_title, 0) + } + if (eq (title_method, 1)) { + set (prefix_title, title (person)) + set (suffix_title, 0) + } + if (eq (title_method, 2)) { + set (prefix_title, 0) + set (suffix_title, title (person)) + } + if (eq (title_method, 3)) { + set (prefix_title, 0) + set (suffix_title, 0) + if (t, title (person)) { + call is_prefix_title (t) + if (is_prefix_title_return) { + set (prefix_title, t) + } else { + set (suffix_title, t) + } + } + } + set (xposdennis,add(64,mul(div (8000,max_depth),sub(depth,1)))) + /* First draw the horiz. line */ + /* 1=direct ancestor, 0=sibling, the "line" variable controls this */ + /* chart_type "0 for ancestral, 1 for descendant chart" */ + set (xposdennis_siboff,0) /* initial setting */ +/* if (eq(chart_type,0)){*/ + if (eq(line,0)){ + set (xposdennis_siboff,25) + }/*}*/ + "PA" + d (add(xposdennis,xposdennis_siboff)) + "," + d (pos) + ";PD;PA" + d (add(xposdennis,div (8000,max_depth))) + "," + d (pos) + ";PU;" + + /* now draw the text */ + set(pos, add(pos,9)) + set (xposdennis,add(12,xposdennis)) + "PA" + d (add(xposdennis,xposdennis_siboff)) + "," + d (pos) + if (gt(strlen(name (person)),longname_cutoff)){ + longname_scale + } + else{ + shortname_scale + } + "LB" + set (nlet, name_letters) + if (prefix_title) { + set (nlet, sub (nlet, strlen (prefix_title))) + } + if (suffix_title) { + set (nlet, sub (nlet, strlen (suffix_title))) + } + + /* print name and title, if it exists */ + + if (prefix_title) { + prefix_title " " + } + fullname (person, 0, 1, nlet) + if (suffix_title) { + " " suffix_title + } + if(eq(all_same_line,1)){ + /* print birth date, if it exists */ + call dateplace (birth (person), dateplace_birth) + if (dateplace_return) { + " b. " dateplace_return + } + call dateplace (death (person), dateplace_death) + if (dateplace_return) { + " d. " dateplace_return + } + } + + "PU;" + set (mypos,sub(pos,40)) + + if(ne(all_same_line,1)){ + /* print birth date, if it exists */ + call dateplace (birth (person), dateplace_birth) + if (dateplace_return) { + "PA" + d (add(xposdennis,xposdennis_siboff)) + "," + d (mypos) + if (gt(strlen(dateplace_return),longdate_cutoff)){ + longdate_scale + } + else{ + shortdate_scale + } + "b. " + dateplace_return + + "PU;" + set (mypos,sub(mypos,35)) + } + } + + /* print marriage date, if it exists */ + if (mdate) { + "PA" + d (add(xposdennis,xposdennis_siboff)) + "," + d (mypos) + if (gt(strlen(mdate),longdate_cutoff)){ + longdate_scale + } + else{ + shortdate_scale + } + "m. " + mdate + "PU;" + set (mypos,sub(mypos,35)) + } + + if(ne(all_same_line,1)){ + /* print death date, if it exists */ + call dateplace (death (person), dateplace_death) + if (dateplace_return) { + "PA" + d (add(xposdennis,xposdennis_siboff)) + "," + d (mypos) + if (gt(strlen(dateplace_return),longdate_cutoff)){ + longdate_scale + } + else{ + shortdate_scale + } + "d. " + dateplace_return + "PU;" + set (mypos,sub(mypos,35)) + } + } + /* optional special tagged note */ + if (noteprint) { /* make sure it exists */ + if (gt(strlen(noteprint),0)){ /* make sure it is non-null */ + "PA" + d (add(xposdennis,xposdennis_siboff)) + "," + d (mypos) + if (gt(strlen(noteprint),longdate_cutoff)){ + longdate_scale + } + else{ + shortdate_scale + } + noteprint + "PU;" + set (mypos,sub(mypos,35)) + }} + + + + nl() +} + +/* +** procedure: enqueue_vertical +** +** Enqueue the data for a single vertical line onto the global lists. +** +*/ + +proc enqueue_vertical (depth, low, high) +{ + enqueue (llist_depth, depth) + enqueue (llist_low, low) + enqueue (llist_high, high) +} + +/* +** procedure: dequeue_all_verticals +** +** Dequeue and print all vertical lines. The lines are stored in a +** second queue as they are printed and then placed back in the +** original, global, queue. +** +*/ + +proc dequeue_all_verticals () +{ + list (tlist_depth) + list (tlist_low) + list (tlist_high) + + while (depth, dequeue (llist_depth)) { + set (low, dequeue (llist_low)) + set (high, dequeue (llist_high)) + + call print_vertical (depth, low, high) + + enqueue (tlist_depth, depth) + enqueue (tlist_low, low) + enqueue (tlist_high, high) + } + + while (depth, dequeue (tlist_depth)) { + set (low, dequeue (tlist_low)) + set (high, dequeue (tlist_high)) + + enqueue (llist_depth, depth) + enqueue (llist_low, low) + enqueue (llist_high, high) + } +} + +/* +** procedure: print_vertical +** +** Print a single vertical line to link a married couple or siblings. +** +*/ + +proc print_vertical (depth, low, high) +{ + /* do same normalizations as in print_person */ + /* since there is no floating point, multiply everything by another + 1000/1000 to not lose too much precision*/ + set(normpos,div(mul(high_pos_all,1000),9950)) + set(low, sub(high_pos_all,low)) + set(low, div(mul(low,1000),normpos)) + set(high, sub(high_pos_all,high)) + set(high, div(mul(high,1000),normpos)) + /* extra offset for b. & d. lines of lowest person */ + set(low, add(low,70)) + set(high, add(high,70)) + + + set (xposdennis,add(64,mul(div (8000,max_depth),depth))) + + "PA" + d (xposdennis) + "," + d(low) + ";PD;PA" + d (xposdennis) + "," + d(high) + ";PU;" +} + +/* +** procedure: print_thousandths +** +** Since LifeLines does not offer a floating point type, decimal +** computation is done using integers that represent thousands. This +** procedure converts a number in thousandths to decimal notation and +** prints it. The length of the decimal part is checked to make sure +** it is padded with zeros correctly. +** +*/ + +proc print_thousandths (n_arg) +{ + + /* don't want to modify proc argument, so copy it */ + set (n, n_arg) + + if (lt (n, 0)) { + "-" + set (n, neg (n)) + } + d (n) + +} + +/* +** procedure: print_header +** +** Arguments: +** fn: font name +** md: maximum level, integer +** mp: maximum position, integer in thousandths +** ctf: color true/false, string "true" or "false" +** cl: chart label, string +** xi: which horizontal page +** xn: number of horizontal pages +** yi: which vertical page +** yn: number of vertical pages +** +** Print the initial postscript code. This code will likely be the +** bulk of the output file. It prints the border, defines postscript +** functions for printing peoples names, dates and the lines on the +** chart, and more. It will be followed by the data. +** +** This postscript code was written by Thomas P. Blumer (blumer@ptltd.com). +** The only modification is where data from the arguments is inserted. +** +*/ + +proc print_header (fn, ml, mp, ctf, cl, xi, xn, yi, yn) +{ +"IN;SP1;RO90;TD1;IP;SC0,8128,0,10160;PW0.88;PU;PA17,17;PD;PA8111,17;PA8111,10143;PA17,10143;PA17,17;PW;PW0.25;PU;PA60,60;PD;PA8068,60;PA8068,10100;PA60,10100;PA60,60;PW;WU1;PW0.0255;PU;" +} +/* +** procedure: print_tailer +** +** Print the terminating code HPGL. This code will likely be the +** bulk of the output file. It prints the border, defines postscript +** functions for printing peoples names, dates and the lines on the +** chart, and more. It will be followed by the data. +** +** +** This HPGL code was written by Thomas P. Blumer (blumer@ptltd.com). +** The only modification is where data from the arguments is inserted. + +*/ + +proc print_tailer () +{ + "PU;PA0,0;SP;EC1;PG1;EC1" +} diff --git a/reports/html.dn.ll b/reports/html.dn.ll new file mode 100644 index 0000000..0e51024 --- /dev/null +++ b/reports/html.dn.ll @@ -0,0 +1,752 @@ +/* + * @progname html.dn.ll + * @version 3.0 + * @author Dennis Nicklaus nicklaus@fnal.gov + * @category + * @output HTML + * @description + * + * Selects a person and writes html pages for that person + * and all their descendents through a specified number of generations. + * Actually, you get to specify a set of individuals. It probably + * works nicest if you select people of the same generation, e.g. + * all your ggg-grandparents. + * (I also recommend that you start with the "top of the line" ancestor + * or else you'll have unresolved links in the pedigree chart.) + * + * Output is a set of ASCII HTML files, one for each person in the set. + * In addition, it writes a surname index file named index.html, + * and one named -gendex, which is a GENDEX format index text file. + * is the database name. + * + * Note that I APPEND to the index files! This is necessary if you're building + * up a set of pages by multiple runs of html.dn. But you want to remove + * the old ones, or go to a different directory, if you're starting a whole + * new set of pages. + * + * Why would you want to run it multiple times? Suppose I wanted all my + * relatives through my generation. On my dad's side I know all my great-grandparents + * but on mom's side, only my grandparents. To create my set of pages, + * I'd first run this program, specifying all of my g-gparents (on dad's side) + * and number of generations =4. Then run it a second time, specifying + * only my 2 grandparents on mom's side and # generations=3. + + * The individual's HTML files are named I.html where + * is replaced with the individual's key ID number. + * Since it can re-write the same individual html files multiple times, + * I usually sort the two index files with something like this (suppose db=dad): + * sort -u -t \> -k 2 dadindex.html > dadindex.sort; mv dadindex.sort dadindex.html + * (the individual html files expect the index to be named dadindex.html.) + * For the GENDEX index: + * sort -t \| -k 2 -u dad-gendex >gendex.txt + * (note that I use the -u flag to take out duplicate entries) + * + * Actually, before sorting, I usually run the indexes and (all the indi html files) + * through some big "sed" scripts to take things from the LaTex notation + * I use to either HTML notation or plain text. + * e.g. for the gendex file, which doesn't want html special chars: + * (and you may have to use csh for this quoting convention here to work.) + * sed -e 's/\\"u/ue/g' gendex.out + * + * For the html files, it looks like + * sed -e 's/\\"u/\ü/g' output + * I also use -e 's/\\begin{enumerate}/\/g' -e 's/\\end{enumerate}/\<\/OL\>/g' + * and similar things to go from LaTex to HTML. + * + * The bibliography: The html generator looks for SOUR xrefs used on each indi + * and prints a list of them at the bottom of each HTML file, and references a file + * bib.html which is the expected bibliography. + * But this program doesn't generate the bibliography. + * I personally use book-latex to generate the bibliography then munge + * it around into a nicer HTML format. (I have a C program for this.) + * You can use whatever you want. + * + * SHORTCOMINGS: + * 1. Takes time to do two pretty much identical pages for direct ancestors + * (or anyone else who is descended from more than one of the same starting people. + * (That's OK, the most recent one written will just overwrite the first.) + * + * A previous verion had lots of wasted white space. + * I don't like the way pagemode works at all. + * I had to fill in lots of extra whitespace, e.g. at the top of the pedigree + * chart to make it not overwrite some of the text which was already output. + * It may still fail somewhere along the way. + * I completely changed around the way the pedigree chart is drawn to get + * rid of this problem. The result is a more compact html page, but with + * a few less details on the pedigree chart. + * I left all the old code in there (commented out), so it is confusing to read. + * + * If you look closely, you will notice a few things like: concat(dbname,"") + * These are in there so I can fill in a numeral or something between the + * empty quote marks so that I can have a dad2index.html, e.g. + * + * DETAILS: + * 1. I have a special "1 NOTE FILE:" construct that I use to refer to external files. + * 2. I also use the "1 OBJE" to link to external images (e.g. .GIF) + * relevant to the person. + * 3. change the info in init() before you use this!! + * + * EXAMPLE: + * See http://www.geocities.com/dnicklaus/dadindex.html + * and just pick a name from that index to see what it looks like. + * dadI3.html might be a good one to start at. + * + * Version 3.0 July 1998 + * What's different from Version 2? + * Don't make a page and a link for the child if we know nothing + * about the child except his name and one simple fact. + * Version 2.0 July 1998 (Version 1.0 was Feb. 1998) + * What's different from Version 1? Simpler, more compact pedigree chart. + * + * This report works only with the LifeLines Genealogy program + * + */ +global(dbname) +global(extension) +global(email) +global(personalname) +global(homepage) +global (gotValue) +global (gottenNode) +global (gottenValue) +global (global_gp_var) +proc init () +{ + set(dbname,save(database())) + set(extension,".html") + set(personalname,getproperty("user.fullname")) + set(email,getproperty("user.email")) + set(homepage,"http://www.yourplace.here") +/*e.g.: set(homepage,"http://www.geocities.com/dnicklaus/index.html")*/ +} +proc main () +{ + call init() + getindimsg(person,"Enter person to output HTML for Descendents") + indiset(thisgen) + indiset(allgen) + indiset(newgen) + while (person){ + addtoset(thisgen, person, 0) + addtoset(allgen, person, 0) + + set(person,0) + getindimsg(person,"Enter next person to output HTML for Descendents") + } + + getintmsg (ngen, + "Enter number of generations for complete info") + + /* collect descendents */ + + set(gen,2) /* this code has to do at least 2 generations */ + while(lt(gen,ngen)){ + set(thisgen,childset(thisgen)) + set(allgen,union(allgen,thisgen)) + set(gen,add(gen,1)) + } + set(newgen,childset(thisgen)) + + /* print out individual html files */ + + forindiset(allgen,person,val,thisgensize) { + if (gt(worth_doing(person),1)) { + newfile(save(concat (concat(dbname,key(person)),extension)),0) + call do_it_all(person,1 ) + } + } + /* list last newgen will not have any hyperlinks from the children + in this set */ + forindiset(newgen,person,val,thisgensize) { + if (gt(worth_doing(person),1)) { + newfile(save(concat (concat(dbname,key(person)),extension)),0) + call do_it_all(person,0) + } + } + + /* write out a GENDEX format index */ + newfile(save(concat(concat(dbname,""),"-gendex")),1) + forindiset(allgen,person,val,thisgensize) { + if (gt(worth_doing(person),1)) { + call write_gendex_line(person) + } + } + forindiset(newgen,person,val,thisgensize) { + if (gt(worth_doing(person),1)) { + call write_gendex_line(person) + } + } + /* write out a normal index for HTML use */ + newfile(save(concat(concat(dbname,""),"index.html")),1) + forindiset(allgen,person,val,thisgensize) { + if (gt(worth_doing(person),1)) { + call write_regular_index_line(person) + } + } + forindiset(newgen,person,val,thisgensize) { + if (gt(worth_doing(person),1)) { + call write_regular_index_line(person) + } + } +} +proc do_it_all(indi,linkit) + +{ + print(key(indi)) print(" ") + call do_chart_head(indi) + "

      " name(indi,0) "

      \n" + "
      \n" + call getGif(inode(indi)) + "
      \n" + "
      \n" + if (e,birth(indi)) { "
      born: " long(e) call doAddr(e) "\n" } + if (e,baptism(indi)) { "
      bapt: " long(e) call doAddr(e) "\n" } + if (e,death(indi)) { "
      died: " long(e) call doAddr(e) "\n" } + if (e,burial(indi)) { "
      bur.: " long(e) call doAddr(e) "\n" } + call getValueCont(inode(indi),"OCCU") + if (gotValue){ "
      occu: " gottenValue "\n"} + call getValueCont(inode(indi),"WILL") + if (gotValue){ "
      Will: " long(gottenNode) call doAddr(gottenNode)"\n"} + call getValueCont(inode(indi),"PROB") + if (gotValue){ "
      Probated: " long(gottenNode) call doAddr(gottenNode)"\n"} + + families(indi,fam,sp,spi) { + if(sp){ "
      spouse: " name(sp) "\n" + if (e,marriage(fam)){ "
      marr: " long(e) call doAddr(e) "\n" } + if (e,birth(sp)) { "
      born: " long(e) call doAddr(e) "\n" } + if (e,baptism(sp)) { "
      bapt: " long(e) call doAddr(e) "\n" } + if (e,death(sp)) { "
      died: " long(e) call doAddr(e) "\n" } + if (e,burial(sp)) { "
      bur.: " long(e) call doAddr(e) "\n" } + call getValueCont(inode(sp),"OCCU") + if (gotValue){ "
      occu: " gottenValue "\n"} + + } + if (gt(nchildren(fam),0)){ "
      Children:\n"} + children (fam,ch,famchi) { " " + + if (linkit){ + if (gt(worth_doing(ch),1)) { + "
      " name(ch) "\n" + } + else { + /* here worth_doing must = exactly 0 or 1 + print out the name and the one thing we know, + but no link */ + "
      " name(ch,0) + if (e,birth(ch)) { " -- born: " long(e) call doAddr(e) "." } + if (e,baptism(ch)) { " -- bapt: " long(e) call doAddr(e) "." } + if (e,death(ch)) { " -- died: " long(e) call doAddr(e) "." } + if (e,burial(ch)) { " -- bur.: " long(e) call doAddr(e) "." } + "\n" + } + } + else { "
      " name(ch,0) "
      \n" } + } + } + "
      \n" + if (parents(indi)){ + call has_grandparents(indi) + if (eq(0,global_gp_var)){ + set(fath,father(indi)) + if (fath){ + "Father: " + "" + name(fath) "" + " (" + if (e,birth(fath)) { year(e)} + "-" + if (e,death(fath)) { year(e)} + ")" + "
      \n" + + } + set(moth,mother(indi)) + if (moth){ + "Mother: " + "" + name(moth) "" + " (" + if (e,birth(moth)) { year(e)} + "-" + if (e,death(moth)) { year(e)} + ")" + "
      \n" + + } + } + else{ + + "

      Pedigree Chart

      " +/* " " + " \n" + " " + " \n" + " " + " \n" + " " + " \n" + " " + " \n" + " " + " \n" + " " + " \n" + " " + " \n" + " " + " \n" +*/ + /* all this extra crappy space is apparently necessary because + of the way the pagemode feature gobbles up the output buffer for + lines which haven't been written out yet. It gets gobbled as whitespace*/ +/* pagemode(64,120) + pos(1,1)*/ + "
      "
+/*	call pedout(indi,1,4,1,64)
+	print(nl())
+	pos(64,1)
+	pageout()
+	linemode()
+*/
+	call pedout2(indi)
+	"
      \n" + } + } + "
      \n" + call getText(inode(indi),1) + "
      \n" + call getCensus(inode(indi)) + "
      \n" + call do_file_notes(indi) + + + "

      \nSources for this individual: " + call sour_addind(indi) "
      \n" + "

      \n" +"
      \n" +" Homepage | \n" +" Genealogy Home | \n" +" Index | \n" +" Explanations
      \n" +"
      \n" +"" personalname " " email "
      " + +} + +proc pedout (indi, gen, max, top, bot) +{ + if (and(indi,le(gen,max))) { + set(gen,add(1,gen)) + set(fath,father(indi)) + set(moth,mother(indi)) + set(height,add(1,sub(bot,top))) + set(offset,div(sub(height,8),2)) + call block(indi,add(top,offset),mul(10,sub(gen,2))) + set(half,div(height,2)) + call pedout(fath,gen,max,top,sub(add(top,half),1)) + call pedout(moth,gen,max,add(top,half),bot) + } +} + +proc do_chart_head(indi){ + "" + "" + name(indi,0) + " Family" + "" + "\n" +} +proc block (indi, row, col) +{ + print(".") + set(row,add(3,row)) + + + set(col,add(3,col)) + pos(row,col) + "" + name(indi) + "" + set(row,add(row,1)) + pos(row,col) + set (e,birth(indi)) + if (e){ " b. " long(e)} + set(row,add(row,1)) + pos(row,col) + set (e,death(indi)) + if (e){ " d. " long(e)} + set(row,add(row,1)) + pos(row,col) + +} +proc doname (indi) +{ + if(indi){ + "" + name(indi) + " (" + set (e,birth(indi)) + if (e){short(e)} + " - " + set (e,death(indi)) + if (e){short(e)} + ")" + } +} + +proc getText (root, paragraph) { + if (root) { + fornodes (root, node) { + if (not (strcmp ("TEXT", tag (node)))) { + if (paragraph) { "\n\n" set (paragraph, 0) } + call values (node) + "\n\n

      " + } + } + } +} +proc getGif (root) { + + if (root) { + fornodes (root, node) { + if (not (strcmp ("OBJE", tag (node)))) { + "

      \n" + call getValueCont (node,"TITL") + if (gotValue){ set (title,save(gottenValue)) } + call getValueCont (node,"FILE") + if (gotValue){ set (file,save(gottenValue)) } + "\""
      " + title "
      " + "
      \n" + + } + } + } +} +proc getCensus (root) { + if (root) { + fornodes (root, node) { + if (not (strcmp ("CENS", tag (node)))) { + "Census: " long(node) + "
      \n" + } + } + } +} + +proc values (root) { + if (root) { + if (strlen (value (root))) { "\n" value (root) } + fornodes (root, node) { + if (not (strcmp ("CONT", tag (node)))) { + if (strlen (value (node))) { "\n" value (node) } + } + } + } +} +proc doAddr(event) +{ + fornodes(event, subnode) { + if (eq(0,strcmp("PLAC", tag(subnode)))) { + fornodes(subnode, subnode2) { + if (eq(0,strcmp("ADDR", tag(subnode2)))) { + ", at " value(subnode2) + }}}} +} + +proc getValueCont (root, t) { + set (gotValue, 0) + if (root) { + fornodes (root, node) { + if (and (not (gotValue), not (strcmp (tag (node), t)))) { + set (gotValue, 1) + set (gottenNode, node) + set (gottenValue, save (value (node))) + fornodes (node, subnode) { + if (not (strcmp ("CONT", tag (subnode)))) { + if (strlen (value (subnode))) { + set (gottenValue, + save (concat (gottenValue, concat ("\n", value (subnode))))) + } + } + } + } + } + } +} + +/* sour_addind() adds the sources referenced for this individual */ +proc sour_addind(i) +{ + table(sour_table) + list(sour_list) + + /* first get all the sources in the INDI record */ + traverse(root(i), m, l) { + if (nestr("SOUR", tag(m))) { continue() } + set(v, value(m)) + if (eqstr("", v)) { continue() } + if(reference(v)) { + if (ne(0, lookup(sour_table, v))) { continue() } + set(v, save(v)) + insert(sour_table, v, 1) + v " " + } + } + /* now get all the sources in the FAM records where this person is a spouse */ + families(i,fam,sp,spi) { + traverse(root(fam), m, l) { + if (nestr("SOUR", tag(m))) { continue() } + set(v, value(m)) + if (eqstr("", v)) { continue() } + if(reference(v)) { + if (ne(0, lookup(sour_table, v))) { continue() } + set(v, save(v)) + insert(sour_table, v, 1) + v " " + } + } + } +} + +proc write_gendex_line(person) +{ + set(separator,"|") + dbname key(person) extension + separator + surname(person) + separator + givens(person) " /" surname(person) "/" /* fullname(person,0,1,110)*/ + separator + if (e,birth(person)) { date(e)} + separator + if (e,birth(person)) { place(e)} + separator + if (e,death(person)) { date(e)} + separator + if (e,death(person)) { place(e)} + separator + "\n" +} +proc write_regular_index_line(person) +{ + "" + fullname(person,0,0,110) "" + " (" + if (e,birth(person)) { year(e)} + "-" + if (e,death(person)) { year(e)} + ")" + "
      \n" +} +proc has_grandparents(indi) +{ + set(global_gp_var,0) + set(fath,father(indi)) + if (parents(fath)){ + set(global_gp_var,1) + } + set(moth,mother(indi)) + if (parents(moth)){ + set(global_gp_var,1) + } +} +proc do_file_notes(person) +{ + set (done_once,0) + fornotes(inode(person),note){ + set (i, index(note,"FILE:",1)) + if (gt(i,0)){ + set(what,save(substring(note,add(i,6),strlen(note)))) + set (i, index(what," ",1)) + set(descrip,save(substring(what,1,i))) + + /* now get and flatten the file name */ + set (i, index(what,"FAMHIST/",1)) + set (fname,save(substring(what,add(i,strlen("FAMHIST/")),strlen(what))))o + set (slash, index(fname,"/",1)) + while (gt(slash,0)){ + set(fnameb,save(concat(concat(substring(fname,1,sub(slash,1)),"_"), + substring(fname,add(slash,1),strlen(fname))))) + set(fname,fnameb) + set (slash, index(fname,"/",1)) + } + set (slash, index(fname,".",1)) + while (gt(slash,0)){ + set(fnameb,save(concat(concat(substring(fname,1,sub(slash,1)),"_"), + substring(fname,add(slash,1),strlen(fname))))) + set(fname,fnameb) + set (slash, index(fname,".",1)) + } + if (done_once) { /* this isn't the first time */ + " | " /* simple separator */ + } + else { "More information: " set(done_once,1)} + "" + descrip + "\n" + } + + } +} + + +/* this function helps us to not print out a whole www page for someone + that I don't know anything about except for maybe the name. + return a 1 if I know one simple fact, and a 0 if I don't know anything, + and a bigger number if I know something more complicated about them.*/ + +func worth_doing(child) { + + set (worth, 0) + if (birth(child)) { set (worth,add(worth,1)) } + if (baptism(child)) { set (worth,add(worth,1)) } + if (death(child)) { set (worth,add(worth,1)) } + if (burial(child)) {set (worth,add(worth,1)) } + if (gt(nfamilies(child),0)) { return(10) } + call getValueCont(inode(child),"OCCU") + if (gotValue){ return(10) } + call getValueCont(inode(child),"TEXT") + if (gotValue){ return(10) } + call getValueCont(inode(child),"WILL") + if (gotValue){ return(10) } + call getValueCont(inode(child),"PROB") + if (gotValue){ return(10) } + call getValueCont(inode(child),"OBJE") + if (gotValue){ return(10) } + call getValueCont(inode(child),"FILE") + if (gotValue){ return(10) } + call getValueCont(inode(child),"CENS") + if (gotValue){ return(10) } + + return(worth) +} + + + +proc pedout2 (indi) +{ +/* I actually collect enough names here to do a 5generation pedigree chart, + but I only print out 4 generations. */ + set(fath,father(indi)) + set(moth,mother(indi)) + if (fath) { + set(ffath,father(fath)) + set(mfath,mother(fath)) + if (ffath) { + set(fffath,father(ffath)) + set(mffath,mother(ffath)) + if (fffath) { + set(ffffath,father(fffath)) + set(mfffath,mother(fffath)) + } + if (mffath) { + set(fmffath,father(mffath)) + set(mmffath,mother(mffath)) + } + } + if (mfath) { + set(fmfath,father(mfath)) + set(mmfath,mother(mfath)) + if (fmfath) { + set(ffmfath,father(fmfath)) + set(mfmfath,mother(fmfath)) + } + if (mmfath) { + set(fmmfath,father(mmfath)) + set(mmmfath,mother(mmfath)) + } + } + } + if (moth) { + set(fmoth,father(moth)) + set(mmoth,mother(moth)) + if (fmoth) { + set(ffmoth,father(fmoth)) + set(mfmoth,mother(fmoth)) + if (ffmoth) { + set(fffmoth,father(ffmoth)) + set(mffmoth,mother(ffmoth)) + } + if (mfmoth) { + set(fmfmoth,father(mfmoth)) + set(mmfmoth,mother(mfmoth)) + } + } + if (mmoth) { + set(fmmoth,father(mmoth)) + set(mmmoth,mother(mmoth)) + if (fmmoth) { + set(ffmmoth,father(fmmoth)) + set(mfmmoth,mother(fmmoth)) + } + if (mmmoth) { + set(fmmmoth,father(mmmoth)) + set(mmmmoth,mother(mmmoth)) + } + } + } + +" |--------" call doname(fffath) "\n" +" |\n" +" |---------" call doname(ffath) "\n" +" | |\n" +" | |--------" call doname(mffath) "\n" +" |\n" +" |------" call doname(fath) "\n" +" | |\n" +" | | |--------" call doname(fmfath) "\n" +" | | |\n" +" | |---------" call doname(mfath) "\n" +" | |\n" +" | |--------" call doname(mmfath) "\n" +" |\n" +call doname(indi) "\n" +" |\n" +" | |--------" call doname(ffmoth) "\n" +" | |\n" +" | |---------" call doname(fmoth) "\n" +" | | |\n" +" | | |--------" call doname(mfmoth) "\n" +" | |\n" +" |------" call doname(moth) "\n" +" |\n" +" | |--------" call doname(fmmoth) "\n" +" | |\n" +" |---------" call doname(mmoth) "\n" +" |\n" +" |--------" call doname(mmmoth) "\n" +} + +/* + |--------bill + | + |---------joe + | | + | |--------mary + | + |------sam + | | + | | |--------fred + | | | + | |---------sue + | | + | |--------sally +bill + | |--------john + | | + | |---------jack + | | | + | | |--------mary + | | + |------jane + | + | |--------fred + | | + |---------sue + | + |--------sally + + +*/ +/* End of Report */ diff --git a/reports/html.ll b/reports/html.ll new file mode 100644 index 0000000..ec808b7 --- /dev/null +++ b/reports/html.ll @@ -0,0 +1,219 @@ +/* + * @progname html.ll + * @version 1.0 + * @author Dave Close, + * @category + * @output HTML + * @description + * + * Produces a set of interlinked HTML files, one for each + * person in the data base, and a master name index file. + +Here is a report program I've been using to +generate HTML to allow browsing of my data base. It produces one HTML +file for each person in the data base, and a master index file with +links to each of the other files. Each person's file is hyperlinked +to all his direct relatives. I believe the output is standard HTML and +does not use any peculiar extensions, so it should be viewable with +nearly any browser. +Permission is granted to anyone to use this code for any purpose. + +It does call the divorce() function which I added to my copy of +Lifelines and posted to this list 2002 November 12. + +See: +http://listserv.nodak.edu/cgi-bin/wa.exe?A2=ind0211b&L=lines-l&T=0&F=&S=&P=356 + */ + +global ( page_width ) +global ( left_margin ) + +proc main () +{ + set ( page_width, 500 ) + set ( left_margin, 0 ) + indiset ( iset ) + + forindi ( indi, ni ) + { + addtoset ( iset, indi, 1 ) + + newfile ( concat ( key ( indi ), ".html" ), 0 ) + "" nl () "" nl () + "" name ( indi ) "" nl () + "" nl () "" nl () + "

      " name ( indi ) "

      " nl () + + /* person */ + if ( male ( indi ) ) + { + "Male
      " nl () + } + else + { + "Female
      " nl () + } + dayformat ( 1 ) monthformat ( 1 ) dateformat ( 11 ) + set ( dat, atoi ( stddate ( birth ( indi ) ) ) ) + if ( ne ( dat, 0 ) ) + { + dayformat ( 2 ) monthformat ( 4 ) dateformat ( 8 ) + "Born: " stddate ( birth ( indi ) ) ", " + place ( birth ( indi ) ) "
      " nl () + } + else + { + " Birth information missing
      " nl () + } + dayformat ( 1 ) monthformat ( 1 ) dateformat ( 11 ) + set ( dat, atoi ( stddate ( death ( indi ) ) ) ) + if ( ne ( dat, 0 ) ) + { + dayformat ( 2 ) monthformat ( 4 ) dateformat ( 8 ) + "Died: " stddate ( death ( indi ) ) ", " + place ( death ( indi ) ) "
      " nl () + } + "
      " nl () + + /* parents */ + set ( pa, father ( indi ) ) + set ( ma, mother ( indi ) ) + if ( eqstr ( key ( pa ), "" ) ) + { + " Father unknown
      " nl () + } + else + { + "Father: " name ( pa ) "
      " nl () + } + if ( eqstr ( key ( ma ), "" ) ) + { + " Mother unknown
      " nl () + } + else + { + "Mother: " name ( ma ) "
      " nl () + } + "
      " nl () + + /* families */ + if ( gt ( nfamilies ( indi ), 0 ) ) + { + if ( eq ( nfamilies ( indi ), 1 ) ) + { + "Family:" + } + else + { + "Families:" + } + "" nl () + families ( indi, fam, sp, num ) + { + "" nl () + } + "
      Spouse: " + name ( sp ) "
      " nl () + if ( marriage ( fam ) ) + { + "Married: " + dayformat ( 1 ) monthformat ( 1 ) dateformat ( 11 ) + set ( dat, atoi ( stddate ( marriage ( fam ) ) ) ) + if ( ne ( dat, 0 ) ) + { + dayformat ( 2 ) monthformat ( 4 ) dateformat ( 8 ) + stddate ( marriage ( fam ) ) ", " + } + else + { + "Date unknown, " + } + if ( eqstr ( place ( marriage ( fam ) ), "" ) ) + { + "Place unknown
      " nl () + } + else + { + place ( marriage ( fam ) ) "
      " nl () + } + } + if ( divorce ( fam ) ) + { + "Divorced: " + dayformat ( 1 ) monthformat ( 1 ) dateformat ( 11 ) + set ( dat, atoi ( stddate ( divorce ( fam ) ) ) ) + if ( ne ( dat, 0 ) ) + { + dayformat ( 2 ) monthformat ( 4 ) dateformat ( 8 ) + stddate ( divorce ( fam ) ) ", " + } + else + { + "Date unknown, " + } + if ( eqstr ( place ( divorce ( fam ) ), "" ) ) + { + "Place unknown
      " nl () + } + else + { + place ( divorce ( fam ) ) "
      " nl () + } + } + dayformat ( 1 ) monthformat ( 1 ) dateformat ( 11 ) + set ( dsp, atoi ( stddate ( death ( sp ) ) ) ) + set ( din, atoi ( stddate ( death ( indi ) ) ) ) + set ( ddv, atoi ( stddate ( divorce ( fam ) ) ) ) + if ( ne ( dsp, 0 ) ) + { + if ( lt ( dsp, din ) ) + { + dayformat ( 2 ) monthformat ( 4 ) dateformat ( 8 ) + "Widowed: " stddate ( death ( sp ) ) "
      " nl () + } + } + "      		" + if ( eq ( nchildren ( fam ), 0 ) ) + { + "No children" nl () + } + else + { + "Children:
      " nl () children ( fam, child, no ) + { + "" name ( child ) "
      " nl () + } + } + "
      " nl () + } + else + { + "No family information known
      " nl () + } + "
      Return to complete list of persons " nl () + "" nl () "" nl () + } + + newfile ( "tree.html", 0 ) + "" nl () "" nl () + " Persons " nl () + "" nl () "" nl () + "

      The following persons are recorded in this data base." nl () + "After selecting any one of them, you may proceed directly to their" nl () + "direct relatives through additional links, or return to this page.

      " nl () + "
      " nl () + namesort ( iset ) + set ( n1, lengthset ( iset ) ) + incr ( n1 ) incr ( n1 ) + set ( n2, div ( n1, 3 ) ) + forindiset ( iset, indi, a, b ) + { + "" + surname ( indi ) ", " givens ( indi ) "
      " nl () + if ( eq ( mod ( b, n2 ), 0 ) ) + { + "      		" nl () + } + } + "
      " nl () +} diff --git a/reports/htmlahnen.ll b/reports/htmlahnen.ll new file mode 100644 index 0000000..62552d6 --- /dev/null +++ b/reports/htmlahnen.ll @@ -0,0 +1,130 @@ +/* + * @progname htmlahnen.ll + * @version 2 + * @author Tom Wetmore + * @category + * @output HTML + * @description + * + * Generate an ahnentafel chart in HTML format + */ +/* Version 2, 12/31/95 */ + +proc main () +{ + getindi(per, "Whose Ahnentafel do you want?") + if (not(per)) { return() } + + set(title, concat("Ahnentafel of ", name(per, 0))) + call htmlhead(title) + call htmlheading(3, title) + print("Ahnentafel of ", name(per), "\n") + + list(ilist) /* list of persons waiting to be output */ + list(alist) /* ahnen numbers of those persons */ + list(glist) /* generations of those persons */ + table(ktab) /* table of all persons who have been output */ + table(ctab) /* table of child links */ + + enqueue(ilist, per) /* initialize all structures */ + enqueue(alist, 1) + enqueue(glist, 1) + set(cgen, 0) + call addchild(ctab, 0, per) + + while(per, dequeue(ilist)) { + set(ahnen, dequeue(alist)) + set (tgen, dequeue(glist)) + if (ne(cgen, tgen)) { + "

      " call htmlstrong("Generation ") + call htmlstrong(d(tgen)) "\n" + set(cgen, tgen) + } + "

      " + set(old, lookup(ktab, key(per))) + if (old) { + call htmlstrong(d(ahnen)) " Same as " + call htmlstrong(d(old)) + call htmllink(concat("#", key(per)), " link") + } else { + call htmlname(key(per)) print(".") + insert(ktab, save(key(per)), ahnen) + call htmlstrong(d(ahnen)) " " + call htmlstrong(name(per, 0)) "\n" + set(lst, lookup(ctab, key(per))) + set(comma, 0) + forlist (lst, key, n) { + if (comma) { ", " } + else { set(comma, 1) } + call htmllink(concat("#", key), "chld") + } + if (par,father(per)) { + enqueue(ilist, par) + call addchild(ctab, per, par) + enqueue(alist, mul(2, ahnen)) + enqueue(glist, add(cgen, 1)) + if (comma) { ", " } + else { set(comma, 1) } + call htmllink(concat("#", key(par)), "fath") + } + if (par,mother(per)) { + enqueue(ilist, par) + call addchild(ctab, per, par) + enqueue(alist, add(1, mul(2, ahnen))) + enqueue(glist, add(cgen, 1)) + if (comma) { ", " } + else { set(comma, 1) } + call htmllink(concat("#", key(par)), "moth") + } + if (e, birth(per)) { "
      b. " long(e) "\n" } + if (e, death(per)) { "
      d. " long(e) "\n" } + } + "\n" + } + call htmltail() +} + +proc addchild (ctab, per, par) +{ + set(lst, lookup (ctab, key(par))) + if (not(lst)) { + list(lst) + if (per) { + setel(lst, 1, save(key(per))) + } + insert(ctab, save(key(par)), lst) + } else { + setel(lst, add(1, length(lst)), save(key(per))) + } +} + +proc htmlhead (title) +{ + "" title "\n\n" +} + +proc htmltail () +{ + "\n\n" +} + +proc htmlstrong (str) +{ + "" str "" +} + + +proc htmllink (href, link) +{ + "" link "" +} + +proc htmlname (name) +{ + "" +} + +proc htmlheading (lev, head) +{ + "" head "\n" +} diff --git a/reports/htmlfam.ll b/reports/htmlfam.ll new file mode 100644 index 0000000..3e4c6cd --- /dev/null +++ b/reports/htmlfam.ll @@ -0,0 +1,167 @@ +/* + * @progname htmlfam.ll + * @version 3 + * @author Tom Wetmore (ttw@shore.net) + * @category + * @output HTML + * @description + * + * output family group summaries in HTML format + */ + +/* third draft -- 12/27/95 -- Tom Wetmore -- ttw@shore.net */ + +global(pert) /* person table */ +global(showf) /* families that have been shown */ + +proc main () +{ + getindi(per0, "Who do you want to start with?") + set(fam0, parents(per0)) + list(perq) + list(famq) + table(pert) + list(lst) + insert(pert, save(key(per0)), lst) + table(showf) + + enqueue(perq, per0) + while (per, dequeue(perq)) { + if (fam, parents(per)) { + if (per, husband(fam)) { + call makelink(per, fam) + enqueue(perq, per) + } + if (per, wife(fam)) { + call makelink(per, fam) + enqueue(perq, per) + } + } + } + call showhead() + call showper(per0) + enqueue(famq, fam0) + while (fam, dequeue(famq)) { + if (not(lookup(showf, key(fam)))) { + call showfam(fam) + insert(showf, save(key(fam)), 1) + } + set(husb, husband(fam)) + set(wife, wife(fam)) + if (fam, parents(husb)) { enqueue(famq, fam) } + if (fam, parents(wife)) { enqueue(famq, fam) } + } + call showtail() +} + +proc makelink (per, fam) +{ + if (lst, lookup(pert, key(per))) { + call enqueueifnew(lst, key(fam)) + } else { + list(lst) + enqueue(lst, save(key(fam))) + insert(pert, save(key(per)), lst) + } +} + +proc enqueueifnew (lst, key) +{ + forlist (lst, el, num) { + if (eqstr(key, el)) { return() } + } + enqueue(lst, save(key)) +} + +proc showper (per) +{ + call showone(per) + families(per, fam, sp, num) { + call showone(sp) + call showmarr(fam) + call showchildren(fam) + } + "

      \n" +} + +proc showfam (fam) +{ + "\n" + call showone(husband(fam)) + call showone(wife(fam)) + call showmarr(fam) + call showchildren(fam) + "
      \n" +} + +proc showone (per) +{ + if (not(per)) { return() } + "

      "name(per, 0)"\n" + if (evt, birth(per)) { "
      born "long(evt)"\n" } + if (evt, death(per)) { "
      died "long(evt)"\n" } + set(fam, parents(per)) + if (par, father(per)) { + "
      father " call showlink(par, key(fam)) "\n" + } + if (par, mother(per)) { + "
      mother " call showlink(par, key(fam)) "\n" + } +} + +proc showmarr (fam) +{ + if (evt, marriage(fam)) { "
      married "long(evt)"\n" } +} + +proc showchildren (fam) +{ + if (eq(0, nchildren(fam))) { return() } + "

      Children\n" + children (fam, per, num) { + "
      " d(num) " " call showchild(per) "\n" + } +} + +proc showlink (per, key) { + set(lst, lookup(pert, key(per))) + if (lst) { "" } + name(per, 0) + if (lst) { "" } + call showevents(per) +} + +proc showchild (per) { + if (lst, lookup(pert, key(per))) { + call showlinks(per, lst) + } else { + name(per, 0) + call showevents(per) + } +} + +proc showlinks (per, lst) /* LOOSEEND -- THIS ROUTINE NEEDS MORE */ +{ + if (eq(0, length(lst))) { + call showlink(per, "start") + } else { + call showlink(per, getel(lst, 1)) + } +} + +proc showevents (per) +{ + set(evt, birth(per)) + if (and(evt, year(evt))) { ", b " year(evt) } + set(evt, death(per)) + if (and(evt, year(evt))) { ", d " year(evt) } +} + +proc showhead () { + "Genealogy Page\n\n" + "\n" +} + +proc showtail () { + "\n" +} diff --git a/reports/igi-filter.ll b/reports/igi-filter.ll new file mode 100644 index 0000000..c2ad827 --- /dev/null +++ b/reports/igi-filter.ll @@ -0,0 +1,134 @@ +/* + * @progname igi-filter.ll + * @version 1 of 1993-02-15 + * @author Jim Eggert (eggertj@atc.ll.mit.edu) + * @category + * @output GedCom + * @description + * + * Write GedCom of families/events containing given TAG/VALUE + * +This program is meant to help you filter out useful data from a big IGI +download. You specify what GEDCOM tag you want to look at, and what value +you want to accept. Then it writes a GEDCOM file that contains only those +IGI entries that have what you want. So for example, suppose you have +downloaded all the Hammer families from the IGI, but are really interested +only in those from Harthausen. In this case, you specify PLAC as the GEDCOM +tag, and Harthausen as the value, and you get a GEDCOM file with only the +Harthausen Hammer families. + +The program will look at every GEDCOM level to find the sought tag, in +both individual and family records. For NAME and PLAC entries, all +name or components are searched for a match. A match is defined as +string equality for all provided or available characters, ignoring +case. Thus entering Harth as a desired value will match Harthausen, +Harthofen, and Hart as well. Once a matching value is found, the +program will include in its output the whole matching "family" from +the IGI data. (An IGI "family" is really just an event.) + +This program will run on non-IGI data also. For non-IGI data, it will +generally include somewhat more people in its output file that you +might expect. No big deal. + +igi-filter - a LifeLines program to filter IGI data + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 15 February 1993 + +*/ + +global(this_one) +global(the_tag) +global(the_value) +global(the_length) +global(name_tag) +global(plac_tag) + +proc check_value(a_string) { + set(a_length,strlen(a_string)) + if (gt(a_length,the_length)) { + if (not(strcmp(upper(trim(a_string,the_length)),the_value))) { + set(this_one,1) + } + } else { + if (not(strcmp(trim(the_value,a_length),upper(a_string)))) { + set(this_one,1) + } + } +} + +proc check_values(root) { + list(nlist) + traverse(root,node,level) { + if (and(not(this_one),not(strcmp(tag(node),the_tag)))) { + if (name_tag) { + extractnames(node,nlist,n,ns) + forlist(nlist,n0,nnum) { + call check_value(n0) + } + } + elsif (plac_tag) { + extractplaces(node,nlist,n) + forlist(nlist,n0,nnum) { + call check_value(n0) + } + } + else { + call check_value(value(node)) + } + } + } +} + + +proc main() { + indiset(accept) + getstrmsg(the_tag,"Enter tag for filtering:") + set(the_tag,save(upper(the_tag))) + if (not(strcmp(the_tag,"NAME"))) { set(name_tag,1) } + else { set(name_tag,0) } + if (not(strcmp(the_tag,"PLAC"))) { set(plac_tag,1) } + else { set(plac_tag,0) } + getstrmsg(the_value,"Enter value to be accepted:") + set(the_value,save(upper(the_value))) + set(the_length,strlen(the_value)) + + set(accepted,0) + forindi(person,pnum) { + set(this_one,0) + call check_values(inode(person)) + if (this_one) { + addtoset(accept,person,0) + set(accepted,add(accepted,1)) + } + } + print("Passed ") print(d(accepted)) + print(" of ") print(d(pnum)) print(" individuals.\n") + set(accepted,0) + forfam(family,fnum) { + set(this_one,0) + call check_values(fnode(family)) + if (this_one) { + set(accepted,add(accepted,1)) + if (person,husband(family)) { + addtoset(accept,person,1) + } + elsif (person,wife(family)) { + addtoset(accept,person,1) + } + else { + children(family,person,pnum) { + if (eq(pnum,1)) { addtoset(accept,person,2) } + } + } + } + } + print("Passed ") print(d(accepted)) + print(" of ") print(d(fnum)) print(" families.\nWriting GEDCOM file...") + set(accept,union(accept,spouseset(accept))) + set(accept,union(accept,parentset(accept))) + set(accept,union(accept,childset(accept))) + gengedcom(accept) + "0 TRLR\n" + print("done") +} + diff --git a/reports/igi-import.ll b/reports/igi-import.ll new file mode 100644 index 0000000..5d214bd --- /dev/null +++ b/reports/igi-import.ll @@ -0,0 +1,411 @@ +/* + * @progname igi-import.ll + * @version 1.0 + * @author baud@research.att.com + * @category + * @output GedCom + * @description + * + * Convert igi gedcom to lifelines-standard gedcom + * + * Igi gedcom contains a single NOTE record for each source, either + * on the INDI for a BIRT/CHR or on one of the spouses for a MARR. + * This report rearranges the source information into a SOUR record + * with the associated NOTE text attached to the appropriate source. + * + * Convert UPPERCASE surnames to upper- and lowercase. Try to + * figure out von's and such, but otherwise simply capitalize the + * first letters. Remove periods used for abbreviations. + * + * Dates of the form have the angle brackets stripped. + * + * Note that this report converts INDI/FAM records to INDI/FAM + * records, providing *conclusions* for your database. It would + * be quite easy, but not of interest to me, to produce a similar + * report that produces EVEN records, providing *evidence* for your + * database. + * + * -> Use this report on igi gedcom data *before* igi-merge. <- + * + * 12 NOV 1994 (3.0.1) baud@research.att.com + */ + +proc main () +{ + getstrmsg (msg, "IGI Version [default 3.02/1994]?") + if (streq (msg, "")) { + set (igiversion, "3.02") + set (igidate, "1994") + } else { + if (i, index (msg, "/", 1)) { + set (igiversion, save (trim (msg, sub (i, 1)))) + set (igidate, save (cut (msg, add(i, 1)))) + } else { + set (igiversion, save (msg)) + set (igidate, "") + } + } + + "0 HEAD \n" + "1 SOUR LIFELINES\n" + "2 VER 3.0.1\n" + "2 NAME IGI-IMPORT REPORT\n" + "1 DEST LIFELINES\n" + "2 VER 3.0.1\n" + "1 DATE " date (gettoday ()) "\n" + "1 COPR Copyright " date (gettoday ()) ". Permission is granted to repro" + "duce any subset\n2 CONT of the data contained herein under the condit" + "ion that this copyright\n2 CONT notice is preserved, that the origina" + "l source citations referenced\n2 CONT in the subset are included, and" + " that the submitter of this file is\n2 CONT credited with original au" + "thorship as appropriate.\n" + "1 CHAR ASCII\n" + + "0 @S1@ SOUR\n" + "1 NAME International Genealogical Index\n" + "1 PUBR The Church of Jesus Christ of Latter-day Saints\n" + if (strlen (igiversion)) { + "1 VER " igiversion "\n" + } + if (strlen (igidate)) { + "1 DATE " igidate "\n" + } + + print ("Processing nodes ...\n") + forfam (fam, fn) { + print ("f") + igiimport (fam) + } + + "0 TRLR \n" +} + +func igiimport (fam) +{ + if (marriage (fam)) { + if (note, subnode (inode (husband (fam)), "NOTE")) { + deletenode (note) + } + elsif (note, subnode (inode (wife (fam)), "NOTE")) { + deletenode (note) + } + set (parentsourcetext, "See marriage record.") + catnode (marriage (fam), sourcifyNote (note)) + } else { + children (fam, indi, nc) { + if (note, subnode (inode (indi), "NOTE")) { + deletenode (note) + } + set (childsourcetext, 0) + if (birth (indi)) { + set (childsourcetext, "See birth record.") + catnode (birth (indi), sourcifyNote (note)) + } + if (baptism (indi)) { + set (childsourcetext, "See christening record.") + catnode (baptism (indi), sourcifyNote (note)) + } + reformatnames (inode (indi), childsourcetext) + reformatdates (inode (indi)) + gedcomnode (inode (indi)) + set (parentsourcetext, + save (concat ("See ", + concat (cond (female (indi), "daughter", "son"), + concat (cond (strlen (givens (indi)), " ", ""), + concat (givens (indi), + concat ("'s ", + cond (birth (indi), "birth record.", + "christening record.")))))))) + } + } + if (indi, husband (fam)) { + reformatnames (inode (indi), parentsourcetext) + reformatdates (inode (indi)) + gedcomnode (inode (indi)) + } + if (indi, wife (fam)) { + reformatnames (inode (indi), parentsourcetext) + reformatdates (inode (indi)) + gedcomnode (inode (indi)) + } + reformatdates (fnode (fam)) + gedcomnode (fnode (fam)) + return (0) +} + +func sourcifyNote (node) { + if (node) { + set (text, values (node)) + while (i, index (text, "#:", 1)) { + set (text, save (concat3 (trim (text, sub (i, 1)), + "Number", + cut (text, add (i, 2))))) + } + if (streq (substring (text, sub (strlen (text), 5), strlen (text)), + "Number")) { + set (text, save (concat (text, " unknown"))) + } + set (text, save (concat3 ("International Genealogical Index, ", text, "."))) + set (node, createnodes ("SOUR", text)) + catnode (node, createnode ("SOUR", "@S1@")) + } else { + set (node, createnode ("SOUR", "@S1@")) + } + return (node) +} + +/* common import/export functions */ + +func cond (x, a, b) { + if (x) { + return (a) + } else { + return (b) + } +} + +func gedcomnode (root) { + traverse (root, node, level) { + d (level) + if (x, xref (node)) { " " x } + if (x, tag (node)) { " " x } + if (x, value (node)) { " " x } + "\n" + } + return (0) +} + +func denull (alist) { + list (blist) + forlist (alist, a, an) { + if (a) { enqueue (blist, a) } + } + return (blist) +} + +func reformatdates (root) { + traverse (root, node, level) { + if (streq (tag (node), "DATE")) { + if (v, value (node)) { + if (and (eq (index (v, "<", 1), 1), + eq (index (v, ">", 1), strlen (v)))) { + replacenode + (createnode ("DATE", save (substring (v, 2, sub (strlen (v), 1)))), + subnode (node, "DATE")) + } + } + } + } + return (0) +} + +func reformatnames (root, sourcetext) { + list (namelist) + list (surnamelist) + list (choppedsurnamelist) + list (newchoppedsurnamelist) + if (namenode, subnode (root, "NAME")) { + extractnames (namenode, namelist, nameN, surnameN) + set (lastnamenode, namenode) + forlist (namelist, s, sn) { + set (s, strremove (s, ".")) + set (s, strremove (s, "_")) + setel (namelist, sn, s) + } + enqueue (surnamelist, getel (namelist, surnameN)) + while (surname, dequeue (surnamelist)) { + set (choppedsurnamelist, strchop (surname, " ")) + forlist (choppedsurnamelist, s, sn) { + if (streq ("VON", s)) { + enqueue (newchoppedsurnamelist, s) + } elsif (streq ("DER", s)) { + enqueue (newchoppedsurnamelist, s) + } elsif (and (eq (index (s, "(", 1), 1), + eq (index (s, ")", 1), strlen (s)))) { + enqueue (surnamelist, save (substring (s, 2, sub (strlen (s), 1)))) + } else { + enqueue (newchoppedsurnamelist, save (capitalize (lower (s)))) + } + } + set (newsurname, strjoin (newchoppedsurnamelist, " ")) + if (strlen (newsurname)) { + if (i, index (newsurname, "Mc ", 1)) { + set (newsurname, save (concat (trim (newsurname, add (i, 1)), + cut (newsurname, add (i, 3))))) + } + set (newsurname, save (concat3 ("/", newsurname, "/"))) + } + setel (namelist, surnameN, newsurname) + set (newnamenode, createnode ("NAME", strjoin (namelist, " "))) + addnode (newnamenode, parent (lastnamenode), lastnamenode) + if (sourcetext) { + catnode (newnamenode, createnode ("SOUR", sourcetext)) + } + set (lastnamenode, newnamenode) + } + deletenode (namenode) + } + return (0) +} + +func streq (x, y) { + return (not (strcmp (x, y))) +} + +func createnodes (tag, text) { + set (text, trimspaces (text)) + if (le (strlen (text), 72)) { + return (createnode (tag, text)) + } else { + list (textlist) + while (gt (strlen (text), 72)) { + set (n, 1) + if (i, index (text, " ", n)) { + set (j, i) + } else { + set (j, add (strlen (text), 1)) + } + while (and (i, lt (i, 73))) { + incr (n) + set (j, i) + set (i, index (text, " ", n)) + } + enqueue (textlist, save (trim (text, sub (j, 1)))) + set (text, save (cut (text, add (j, 1)))) + } + if (gt (strlen (text), 0)) { + enqueue (textlist, text) + } + set (root, createnode (tag, dequeue (textlist))) + set (lastnode, 0) + forlist (textlist, text, tn) { + set (node, createnode ("CONT", text)) + addnode (node, root, lastnode) + set (lastnode, node) + } + return (root) + } +} + +func trimspaces (text) { + set (ss, 0) + set (s0, 1) + set (sn, strlen (text)) + while (and (le (s0, sn), streq (substring (text, s0, s0), " "))) { + set (ss, 1) + incr (s0) + } + while (and (le (s0, sn), streq (substring (text, sn, sn), " "))) { + set (ss, 1) + decr (sn) + } + if (ss) { + return (save (substring (text, s0, sn))) + } else { + return (text) + } +} + +func catnode (root, newnode) { + if (root) { + set (lastnode, 0) + fornodes (root, node) { + set (lastnode, node) + } + addnode (newnode, root, lastnode) + } + return (0) +} + +func strchop (s, d) { + list (slist) + set (dn, strlen (d)) + if (strlen (s)) { + set (n, 1) + set (s0, 1) + while (sn, index (s, d, n)) { + enqueue (slist, save (substring (s, s0, sub (sn, 1)))) + set (s0, add (sn, dn)) + incr (n) + } + enqueue (slist, save (cut (s, s0))) + } + return (slist) +} + +func strjoin (slist, d) { + forlist (slist, s, sn) { + if (not (strlen (str))) { + set (str, s) + } elsif (strlen (s)) { + set (str, save (concat3 (str, d, s))) + } + } + return (str) +} + +func subnode (root, tag) { + if (root) { + fornodes (root, node) { + if (streq (tag (node), tag)) { + return (node) + } + } + } + return (0) +} + +func subnodes (root, tag) { + list (nodelist) + if (root) { + fornodes (root, node) { + if (streq (tag (node), tag)) { + enqueue (nodelist, node) + } + } + } + return (nodelist) +} + +func replacenode (newnode, oldnode) { + if (newnode) { + if (root, parent (oldnode)) { + addnode (newnode, root, oldnode) + deletenode (oldnode) + } + } + return (0) +} + +func concat3 (x, y, z) { + return (concat (x, concat (y, z))) +} + +func cut (s, n) { + return (substring (s, n, strlen (s))) +} + +func values (root) { + if (root) { + set (str, value (root)) + fornodes (root, node) { + if (not (str)) { + set (str, value (node)) + } elsif (strlen (value (node))) { + set (str, save (concat3 (str, " ", value (node)))) + } + } + return (str) + } else { + return (0) + } +} + +func strremove (s, d) { + if (strlen (s)) { + while (i, index (s, d, 1)) { + set (s, save (concat (trim (s, sub (i, 1)), cut (s, add (i, 1))))) + } + } + return (s) +} diff --git a/reports/igi-merge.ll b/reports/igi-merge.ll new file mode 100644 index 0000000..8001142 --- /dev/null +++ b/reports/igi-merge.ll @@ -0,0 +1,543 @@ +/* + * @progname igi-merge.ll + * @version 4.0 + * @author Eggert + * @category + * @output GEDCOM + * @description + +This program helps you merge IGI data. IGI data consists of "families" +which are actually events. A real family may be documented by several +events in the IGI database, and thus be represented by several "families". +This program will help you to locate and merge those "families" back into +real families again. + +igi-merge - a LifeLines IGI database merging program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 2 February 1993 Requires LifeLines 2.3.3 or later. + Version 2, 17 February 1993 bug fix, better suggestions + Version 3, 15 March 1993 more tunable suggestions, + added windup and restart + Version 4, 9 November 1994 Requires LifeLines 3.0.1 or later. + Minor windup bug fix. + +The program locates candidate "families" to be merged by comparing the +soundex, double initials of husband to husband and wife to wife, and +event years. (Double initials are like "JO" for John. Any double +initials are allowed to match. Hence George Michael will match Mike, +and Betty Lou will match Lois Amelia.) If the comparison indicates a +possible match, the program prompts you for approval to merge. If you +answer with y or Yes or yazbotchit, the program will merge those two +families, otherwise it will not. The two husbands will be merged +together, as will the two wives. + +The comparison is made following a strictness code entered at the +beginning of the program execution. The user is prompted for the +strictness level, which means more precisely: +1 soundexes and double initials must match +2 soundexes must match +3 soundexes and double initials must match, but empty soundexes match anything +4 soundexes must match, but empty soundexes match anything +5 double intitials must match +6 nothing needs match +I usually use the strictness in a multiple-pass method: First I run +igi-merge with strictness 1. I import the resulting GEDCOM file into +an empty LL database, and run igi-merge with strictness 2 or 3. And so +on until I am satisfied. + +In any case, the event years are always used for declaring matches. +Two families match only if their event years are within forty years of +each other. If the events are marriage events, however, they must be +within five years of each other. If a family has more than one event +associated with it (for partially merged IGI data, for example), any +marriage event has precedence. + +After families are merged, the program puts the children in birth order, +and attempts to locate children who are really the same. It prompts you +for approval to merge any two children born or christened in the same year. + +Any merged individuals will retain one copy of each name variant and of +each variant sex. (There shouldn't be any of the latter!) Other data, +such as birth and marriage events etc, are simply copied; duplicate +information may therefore be retained after the merge. You are urged +to edit the resulting file to look for and possibly delete such +duplication. + +The resulting data is written to a GEDCOM file. You may read this back +into a LifeLines database if you wish. + +If you run out of time (because, for example, you are merging ten +thousand families), you can invoke windup. If you answer the family +merge question with w (or windup, or Whatever), the program will act as +if you answered all the remaining queries negatively. + +If you want to be really fancy, before you issue the w command, write +down the families that you are being queried about. Then later you +can read the resulting GEDCOM file into a new LifeLines database, and +start up igi-merge again. When asked what comparison strictness to +use, answer with zero. You will be prompted for the two families to +restart the program at. Make sure that you enter the top family +first, otherwise it won't work. The program will then resume your +previous igi-merge session where you had left off. + +With windup and restart, you don't really have to have a single block +of time to be able to merge a large dataset. + +The program does some rudimentary checking to see if the source data +really is IGI-like. If not, it complains, but keeps on running +anyway. Because it only writes a GEDCOM file, this program can't +corrupt your database, so don't worry. + +The user interface depends on the size of the LifeLines screen, +I have marked the sensitive lines with a commented # + */ + +global(famged) +global(gedsex) +global(names) +global(ptable) +global(event_year) +global(event_string) +global(event_type) /* 1=birth, 2=baptism, 3=marriage, + and in the future 4=death, 5=burial */ +global(compare_level) +global(windup) + +func get_yesno(prompt) { + set(yes,0) + set(windup,0) + getstrmsg(yesno,prompt) + if (gt(strlen(yesno),0)) { + if (not(strcmp(upper(trim(yesno,1)),"Y"))) { set(yes,1) } + if (not(strcmp(upper(trim(yesno,1)),"W"))) { set(windup,1) } + } + return(yes) +} + +/* Note that marriage events have priority! */ +proc get_event(family) { + set(event_year,0) + if (e,marriage(family)) { + extractdate(e,day,month,event_year) + set(event_string,"m. ") + set(event_type,3) + } + else { + children(family,child,cnum) { + if (eq(cnum,1)) { + if (e,birth(child)) { + set(event_string,concat(name(child)," b. ")) + extractdate(e,day,month,event_year) + set(event_type,1) + } + elsif (e,baptism(child)) { + set(event_string,concat(name(child)," c. ")) + extractdate(e,day,month,event_year) + set(event_type,2) + } + } + } + } + if (not(event_year)) { +/* print("Event year not found.\n") */ + set(event_string,concat(event_string,"date unknown")) + } + else { + set(event_string,concat(event_string,d(event_year))) + } + if (p,place(e)) { + set(event_string,concat(event_string," ")) + set(event_string,concat(event_string,p)) + } + set(event_string,save(trim(event_string,73))) /*#*/ +} + +proc write_ged_indi(person,newperson,ftag,famkey) { + if (not(person)) { break() } + if (lookup(ptable,key(person))) { + print("Database doesn't look like IGI data.\n") + print(" - ", key(person), " ", name(person), "\n") + } + insert(ptable,save(key(person)),famkey) + set(n,inode(person)) + if (newperson) { + while (dequeue(names)) { "" } + set(gedsex,"X") + } + traverse(n,node,level) { + if (level) { + set(t,tag(node)) + if (and(strcmp(t,"FAMS"),strcmp(t,"FAMC"))) { + set(write_line,1) + if (not(strcmp(t,"NAME"))) { + if (newperson) { + enqueue(names,save(value(node))) + } + else { + set(thisname,save(value(node))) + forlist(names,prevname,pnum) { + if (not(strcmp(thisname,prevname))) { + set(write_line,0) + } + } + if (write_line) { enqueue(names,thisname) } + } + } + if (not(strcmp(t,"SEX"))) { + if (newperson) { set(gedsex,save(value(node))) } + elsif (not(strcmp(gedsex,value(node)))) { + set(write_line,0) + } + else { set(gedsex,save(value(node))) } + } + if (write_line) { d(level) " " t " " value(node) "\n" } + } + elsif (newperson) { + d(level) " " t " @" famkey "@\n" + } + } + elsif (newperson) { "0 " xref(node) " INDI\n" } + } + if (newperson) { + enqueue(famged,ftag) + enqueue(famged,save(key(person))) + enqueue(famged,"@\n") + } +} + +proc write_ged_fam(fam) { + if (not(fam)) { break() } + set(n,fnode(fam)) + traverse(n,node,level) { + if (not(level)) { continue() } + if (eq(level,1)) { set(levelonetag,save(tag(node))) } + if (and(and(strcmp(levelonetag,"HUSB"), + strcmp(levelonetag,"WIFE")), + strcmp(levelonetag,"CHIL"))) { + enqueue(famged,save(d(level))) + enqueue(famged," ") + enqueue(famged,save(tag(node))) + enqueue(famged," ") + enqueue(famged,save(value(node))) + enqueue(famged,"\n") + } + } +} + +func compare(aint,bint) { + if (lt(aint,bint)) { return(neg(1)) } + elsif (gt(aint,bint)) { return(1) } + else { return(0) } +} + +proc bubblesort(alist,ilist) +{ +/* print("bubblesorting list of length ") print(d(length(alist))) */ +/* print(" entries.\n") */ + while (dequeue(ilist)) { "" } + forlist(alist,ael,index) { enqueue(ilist,index) } + while (gt(index,0)) { + set(bubblepos,index) + set(bubbleindex,getel(ilist,bubblepos)) + set(abubble,getel(alist,bubbleindex)) + set(movedup,0) + set(comparison,neg(1)) + while (and(gt(bubblepos,1),lt(comparison,0))) { + set(bubbleupindex,getel(ilist,sub(bubblepos,1))) + set(bubbleup,getel(alist,bubbleupindex)) + set(comparison,compare(abubble,bubbleup)) + if (lt(comparison,0)) { + setel(ilist,bubblepos,bubbleupindex) + decr(bubblepos) + set(movedup,1) + } + } + if (eq(movedup,0)) { + set(comparison,1) + while(and(lt(bubblepos,length(alist)),gt(comparison,0))) { + set(bubbledownindex,getel(ilist,add(bubblepos,1))) + set(bubbledown,getel(alist,bubbledownindex)) + set(comparison,compare(abubble,bubbledown)) + if (gt(comparison,0)) { + setel(ilist,bubblepos,bubbledownindex) + incr(bubblepos) + } + } + } + setel(ilist,bubblepos,bubbleindex) + if (eq(movedup,0)) { decr(index) } + } +} + +func sound_compare(asound,bsound) { + if (and(strlen(asound),strlen(bsound))) { + return(strcmp(asound,bsound)) + } + elsif (ge(compare_level,3)) { return(0) } + else { return(1) } +} + +func initial_compare(namelist1,namelist2,len2) { + forlist(namelist2,this2,n) { + if (ge(n,len2)) { break() } + set(init2,save(upper(trim(this2,2)))) + forlist(namelist1,init1,m) { + if (not(strcmp(init1,init2))) { + return(0) + } + } + } + return(1) +} + +global(hsound) +global(wsound) +global(hnamelist) +global(wnamelist) +global(hexists) +global(wexists) + +func names_compare(fam2) { + list(namelist) + set(hsound2,"") + if (and(hexists,husband(fam2))) { + if (lt(compare_level,5)) { + set(hsound2,save(soundex(husband(fam2)))) + if (not(strcmp(hsound2,"Z999"))) { set(hsound2,"") } + if (s,sound_compare(hsound,hsound2)) { return(s) } + } + if (mod(compare_level,2)) { + extractnames(inode(husband(fam2)),namelist,n1,n2) + if (s,initial_compare(hnamelist,namelist,n2)) { return(s) } + } + } + elsif (le(compare_level,2)) { return(1) } + if (and(wexists,wife(fam2))) { + if (lt(compare_level,5)) { + set(wsound2,save(soundex(wife(fam2)))) + if (not(and(strcmp(wsound2,"Z999"), + strcmp(wsound2,hsound2)))) { set(wsound2,"") } + if (s,sound_compare(wsound,wsound2)) { return(s) } + } + if (mod(compare_level,2)) { + extractnames(inode(wife(fam2)),namelist,n1,n2) + if (n,initial_compare(wnamelist,namelist,n2)) { return(n) } + } + } + elsif (le(compare_level,2)) { return(1) } + return(0) +} + +proc main() { + list(husbands) + list(wives) + list(childlist) + list(childyear) + list(childindex) + list(childevent) + list(names) + list(hnamelist) + list(wnamelist) + table(ftable) + table(ptable) + list(famged) + + set(compare_level,neg(1)) + while(or(lt(compare_level,0),gt(compare_level,6))) { + getintmsg(compare_level, + "Enter comparison strictness (0=restart,1=very...6=not at all)") + if (eq(compare_level,0)) { + set(restart,1) + print("Select first family to restart from") + getfam(rfam) + set(rfkey,key(rfam)) + print("Select second family to restart from") + getfam(rfam) + set(rfkey2,key(rfam)) + getintmsg(compare_level, + "Enter real comparison strictness (1=very...6=not at all)") + } + } + set(num_merged,0) + forfam(fam,fnum) { "" } + print("Trying to merge ", d(fnum), " families.\n") + set(next_fnum,0) + set(windup,0) + forfam(fam,fnum) { + if (ge(fnum,next_fnum)) { + print(d(fnum), " ") + incr(next_fnum) + } + set(famkey,save(key(fam))) + if (lookup(ftable,famkey)) { continue() } + insert(ftable,famkey,1) + enqueue(famged,"0 @") + enqueue(famged,famkey) + enqueue(famged,"@ FAM\n") + if (h,husband(fam)) { + enqueue(husbands,save(key(h))) + set(hexists,1) + } + else { set(hexists,0) } + if (w,wife(fam)) { + enqueue(wives,save(key(w))) + set(wexists,1) + } + else { set(wexists,0) } + children(fam,child,cnum) { + enqueue(childlist,save(key(child))) + } + call write_ged_fam(fam) + if (and(not(windup), + or(and(restart,not(strcmp(key(fam),rfkey))), + and(not(restart),or(h,w))))) { + set(hname,save(name(h))) + set(wname,save(name(w))) + set(hsound,save(soundex(h))) + if (not(strcmp(hsound,"Z999"))) { set(hsound,"") } + set(wsound,save(soundex(w))) + if (not(and(strcmp(hsound,wsound), + strcmp(wsound,"Z999")))) { set(wsound,"") } + if (mod(compare_level,2)) { + if (h) { + extractnames(inode(h),hnamelist,n1,n2) + forlist(hnamelist,this,n) { + setel(hnamelist,n,save(upper(trim(this,2)))) + } + while (le(n2,n1)) { + set(junk,pop(hnamelist)) + incr(n2) + } + } + if (w) { + extractnames(inode(w),wnamelist,n1,n2) + forlist(wnamelist,this,n) { + setel(wnamelist,n,save(upper(trim(this,2)))) + } + while (le(n2,n1)) { + set(junk,pop(wnamelist)) + incr(n2) + } + } + } + call get_event(fam) + set(year,event_year) + set(fevent_type,event_type) + set(fevent,event_string) + forfam(fam2,fnum2) { + if (or(windup, + and(or(not(restart),strcmp(key(fam2),rfkey2)), + or(restart,le(fnum2,fnum))))) { + continue() } + set(restart,0) + set(famkey2,save(key(fam2))) + if (not(lookup(ftable,famkey2))) { + if (not(names_compare(fam2))) { + call get_event(fam2) + set(ydiff,sub(event_year,year)) + if (lt(ydiff,0)) { set(ydiff,neg(ydiff)) } +/* if soundexes are identical, and event years are close, ask user */ + set(askit,0) + if (and(eq(event_type,3),eq(event_type,3))) { + if (lt(ydiff,5)) { set(askit,1) } + } + elsif (lt(ydiff,40)) { set(askit,1) } + if (askit) { + print("\n\n\n\n", hname, "\n", wname, "\n") /*#*/ + print(fevent, "\n\n\n\n\n\n\n\n\n") /*#*/ + print(name(husband(fam2)), "\n") + print(name(wife(fam2)), "\n") + print(event_string) + set(yes,get_yesno("Merge these families? (y/n/w)")) + print("\n") + if (yes) { + incr(num_merged) + insert(ftable,famkey2,2) + children(fam2,child,cnum) { + enqueue(childlist,save(key(child))) + } + call write_ged_fam(fam2) + enqueue(husbands,save(key(husband(fam2)))) + enqueue(wives,save(key(wife(fam2)))) + } + elsif (windup) { + print("Winding up...") + } + } + } + } + } + } +/* write out the parents */ + if (hkey,dequeue(husbands)) { + set(h,indi(hkey)) + call write_ged_indi(h,1,"1 HUSB @",famkey) + while (hkey,dequeue(husbands)) { + set(h,indi(hkey)) + call write_ged_indi(h,0,"",famkey) + } + } + if (wkey,dequeue(wives)) { + set(w,indi(wkey)) + call write_ged_indi(w,1,"1 WIFE @",famkey) + while (wkey,dequeue(wives)) { + set(w,indi(wkey)) + call write_ged_indi(w,0,"",famkey) + } + } +/* collect children birthyears */ + forlist(childlist,childkey,cnum) { + set(child,indi(childkey)) + if (e,birth(child)) { + extractdate(e,day,month,year) + enqueue(childevent," b. ") + } + elsif (e,baptism(child)) { + extractdate(e,day,month,year) + enqueue(childevent," c. ") + } + enqueue(childyear,year) + } +/* sort by birthyear */ + call bubblesort(childyear,childindex) + set(prev_year,neg(1)) +/* merge and write children */ + forlist(childindex,index,inum) { + set(child,indi(getel(childlist,index))) + set(merge_child,0) + if (and(not(windup), + eq(getel(childyear,index),prev_year))) { + set(merge_child,1) + print("\n\n\n\n\n") /*#*/ + print(prev_name, prev_event, d(prev_year)) + print("\n\n\n\n\n\n\n\n\n\n\n") /*#*/ + } + set(prev_name,save(name(child))) + set(prev_event,getel(childevent,index)) + set(prev_year,getel(childyear,index)) + if (merge_child) { + print(prev_name, prev_event, d(prev_year)) + set(yes,get_yesno("Merge these children? (y/n)")) + print("\n") + if (yes) { set(merge_child,2) } + } + if (eq(merge_child,2)) { + call write_ged_indi(child,0,"",famkey) + } + else { + call write_ged_indi(child,1,"1 CHIL @",famkey) + } + } +/* empty out children data */ + while (not(empty(childlist))) { + set(e,dequeue(childlist)) + set(e,dequeue(childevent)) + set(e,dequeue(childyear)) + set(e,dequeue(childindex)) + } +/* write out the family part of the GEDCOM file */ + while(not(empty(famged))) { dequeue(famged) } + } + "0 TRLR\n" + print("\nMerged ", d(num_merged), " of ", d(fnum), " families.\n") +} diff --git a/reports/igi-search.ll b/reports/igi-search.ll new file mode 100644 index 0000000..8278d78 --- /dev/null +++ b/reports/igi-search.ll @@ -0,0 +1,200 @@ +/* + * @progname igi-search.ll + * @version 1.1 + * @author Vincent Broman + * @category + * @output Text + * @description + * + * prints out a list of people to look up in the IGI, + * those who are closely enough related, who fall in a time range, + * and whose temple work is not done. + */ + +include( "ldsgedcom.li") + +/* TODO: needs a sort and handling "OF" places */ + +/* + * indvordsdone and marrordsdone test whether all the individual (Bap/End/Sch) + * or marriage (Ssp) ordinances are recorded for this individual + * in the database. + */ + +func indvordsdone( indi) { + return( and( ldsbaptism( indi), + ldsendowment( indi), + or( ldschildsealing( indi), + not( father( indi))))) +} + +func marrordsdone( indi) { + families( indi, f, sp, ctm) { + if( not( ldsspousesealing( f))) { return( 0) } + } + return( 1) +} + +/* return as a string the birth/christening year if known, else 0 */ +func knownbirthyear( indi) { + set( b, birth( indi)) + if( not( b)) { set( b, baptism( indi)) } + if( b) { + return( save( year( b))) + } + return( 0) +} + +global( thisyear) + +/* isdead tests whether this individual is known to be dead + * or can be assumed dead by the rules for LDS temple work submission. + */ +func isdead( indi) { + if( death( indi)) { return( 1) } + if( burial( indi)) { return( 1) } + if( by, knownbirthyear( indi)) { + return( le( strtoint( by), sub( thisyear, 110))) + } + families( indi, f, sp, ctd) { + if( m, marriage( f)) { + if( md, year( m)) { + if( le( strtoint( md), sub( thisyear, 95))) { + return( 1) + } + } + } + } + return( 0) +} + +/* return the set of people who are wide-sense ancestors + * of the given individual, plus the children of these wide-sense ancestors, + * where a wide-sense ancestor is either the given individual himself/herself + * a parent or step-parent of a wide-sense ancestor. + */ +func interestingforebearsof( indi) { + indiset( res) + addtoset( res, indi, key( indi)) + + set( pf, parents( indi)) + if( not( pf)) { return( res) } + + if( h, husband( pf)) { + set( res, union( res, interestingforebearsof( h))) + families( h, f, sp, ctf) { + if( sp) { + set( res, union( res, interestingforebearsof( sp))) + } + children( f, ch, ctc) { + addtoset( res, ch, key( ch)) + } + } + set( hk, key( h)) + } else { + set( hk, "") + } + if( w, wife( pf)) { + families( w, f, sp, cth) { + /* add only husbands not the father */ + if( and( sp, nestr( hk, key( sp)))) { + set( res, union( res, interestingforebearsof( sp))) + } else { + children( f, ch, ctcc) { + addtoset( res, ch, key( ch)) + } + } + } + } + return( res) +} + +proc igiord( e) { + if( e) { + if( v, value( e)) { + v + } else { + if( ed, date( e)) { + ed + } else { + " " + } + " " + if( et, ldstemple( e)) { + et + } else { + " " + } + + } + } +} + +proc printigientry( indi) { + if( n, name( indi)) { + n " " + } else { + " " + } + "(" + if( fa, father( indi)) { + if( fn, name( fa)) { + fn + } + } + "/" + if( mo, mother( indi)) { + if( mn, name( mo)) { + mn + } + } + ") " nl() + if( b, birth( indi)) { + sex( indi) + "B " long( b) + if( c, baptism( indi)) { + " and " + sex( indi) + "C " long( c) + } + } elsif( c, baptism( indi)) { + sex( indi) + "C " long( c) + } else { + sex( indi) + " no B/C event " + } + nl() + set( ba, ldsbaptism( indi)) + set( en, ldsendowment( indi)) + set( cs, ldschildsealing( indi)) + if( or( ba, en, cs)) { + call igiord( ba) + "/" + call igiord( en) + "/" + call igiord( cs) + nl() + } + nl() +} + +proc main() { + set( thisyear, strtoint( year( gettoday()))) + + getindi( i, "Who's ancestors should be checked for IGI entries?") + getint( fby, "First birth year of interest?") + getint( lby, "Last birth year of interest?") + forindiset( interestingforebearsof( i), ai, k, ctb) { + if( by, knownbirthyear( ai)) { + set( iby, strtoint( by)) + if( and( isdead( ai), + not( indvordsdone( ai)), + le( fby, iby), + le( iby, lby))) { + by nl() + call printigientry( ai) + } + } + } +} diff --git a/reports/index1.ll b/reports/index1.ll new file mode 100644 index 0000000..5788048 --- /dev/null +++ b/reports/index1.ll @@ -0,0 +1,60 @@ +/* + * @progname index1.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output Text + * @description + * + * This program produces a report of all INDI's in the database, with + * sorted names as output. + * It is presently designed for 12 pitch, HP laserjet III, + * for printing a index of person in the database (ASCII output). + * + * index1 + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * Modifications by Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * and it has been modified many times since. + * + */ + +proc main () +{ + indiset(idx) + monthformat(4) + forindi(indi,n) { + addtoset(idx,indi,n) + print(".") + } + print(nl()) print("indexed ") print(d(n)) print(" persons.") + print(nl()) + print(nl()) + print("begin sorting") print(nl()) + namesort(idx) + print("done sorting") print(nl()) + +col(1) "======================================================================" nl() +col(16) "INDEX OF ALL PERSONS IN DATABASE" nl() +col(1) " " nl() +col(1) " " nl() +col(1) "LAST, First Index # Birthdate Deathdate" nl() +col(1) "-------------------------------- -------- ------------ ------------" nl() + + forindiset(idx,indi,v,n) { + col(1) fullname(indi,1,0,30) + col(35) key(indi) + col(44) stddate(birth(indi)) + col(60) stddate(death(indi)) + print(".") + } + nl() + print(nl()) +} + +/* End of Report */ + diff --git a/reports/index_html.ll b/reports/index_html.ll new file mode 100644 index 0000000..e493b5f --- /dev/null +++ b/reports/index_html.ll @@ -0,0 +1,186 @@ +/* + * @progname index_html.ll + * @version 1.3 + * @author Scott McGee (smcgee@microware.com) + * @category + * @output HTML + * @description + +This report program converts a LifeLines database into html index document. +You will need to change the contents of proc html_address() and to +set the value of HREF appropriately to your server. +You need to set the value of PATH to point to the directory to put +the file into. +You also need to set the value of HOST to be the http server and +path where you will server these files from. + +@(#)index_html.ll 1.3 10/14/95 +by Scott McGee (smcgee@microware.com) + +*/ + +global(INDEX) +global(HREF) +global(PATH) +global(RVAL) +global(FB) +global(nl) +global(last_surname) +global(name_count) +global(surname_count) +global(owner_email) +global(db_owner) + +proc main() +{ + set(db_owner, getproperty("user.fullname")) + set(owner_email, getproperty("user.email")) + set(FB, 0) + set(nl, nl()) + set(last_surname, "ZZ") + list(RVAL) + indiset(INDEX) + set(PATH, "/users/smcgee/www/") + set(HOST, "http://www.emcee.com") + set(HREF, concat( + "http://www.emcee.com/~smcgee/cgi-bin/genweb_cgi/DB=", + database(), + "/INDEX=")) + print("processing database\n") + set(count, 0) + forindi(me,num) + { + if(eq(count, 100)){ + set(count, 0) + print(".") + }else{ + incr(count) + } + addtoset(INDEX,me,1) + } + print("\nwriting file\n") + set(name_count, 0) + set(surname_count, 0) + call create_index_file() + print("\n", d(name_count), " individuals, ", d(surname_count), " surnames\n") +} + +proc create_index_file() +{ + namesort(INDEX) + set(fn, save(concat(PATH, concat("genweb/", database(), "_idx.html")))) + newfile(fn, FB) + call html_header(0) + "" nl + "\"\"

      \n" + "

      INDEX

      " nl + "
        " nl + forindiset(INDEX, me, v, n) + { + call href(me) nl + } + "
      " nl + call html_address() + "" nl + "" nl +} + +proc href(me) +{ + if(me) + { + call print_name(me, 1) + incr(name_count) + if(ne(strcmp(surname(me), last_surname), 0)){ + incr(surname_count) + print(surname(me)) + print("\n") + set(last_surname, save(surname(me))) + "\n" + } + "
    • \n" + pop(RVAL) + " -" + if (evt, birth(me)) { + " born " + short(evt) + } + else { + if (evt, baptism(me)) { + " baptised " + short(evt) + } + else { + if (evt, bapt(me)) { + " baptised " + short(evt) + } + } + } + if (evt, death(me)) { + " died " + short(evt) + } + } +} +proc html_header(isindex) +{ + "" nl + "" nl + "" + if(isindex) { "" nl } + "Index of database - " + database() + "" nl + "" nl + } + +proc html_address() +{ + "
      " nl + "
      Last update : " + date(gettoday()) + "
      " db_owner " // " owner_email "
      " nl +} + +proc print_name (me, last) +{ + call get_title(me) + set(junk, pop(RVAL)) + push(RVAL, save(concat(fullname(me, 0, not(last), 45), junk))) +} + +proc get_title (me) +{ + fornodes(inode(me), node) + { + if (not(strcmp("TITL", tag(node)))) { set(n, node) } + } + if (n) { push(RVAL, save(concat(" ", value(n)))) } + else { push(RVAL, "") } +} + +proc rjt(n, w) +{ + if (lt(n, 10)) { set(d, 1) } + elsif (lt(n, 100)) { set(d, 2) } + elsif (lt(n, 1000)) { set(d, 3) } + elsif (lt(n, 10000)) { set(d, 4) } + else { set(d, 5) } + if (lt(d, w)) + { set(pad, save( trim(" ", sub(w, d)))) } + else + { set(pad, "") } + push(RVAL, save( concat(pad, save(d(n))))) +} +func bapt (indi) { + fornodes(inode(indi), node) { + if (eq(0, strcmp(tag(node), "BAPL"))) { + return(node) + } + if (eq(0, strcmp(tag(node), "BAPM"))) { + return(node) + } + } + return(0) +} diff --git a/reports/index_mm.ll b/reports/index_mm.ll new file mode 100644 index 0000000..00bb1b5 --- /dev/null +++ b/reports/index_mm.ll @@ -0,0 +1,76 @@ +/* + * @progname index_mm.ll + * @version 4.0 + * @author Eggert + * @category + * @output Text + * @description + +This program lists everyone in a database, with women listed by both +maiden name and married name. It assumes that all women take the surname +of their husbands, which is not always correct. + +index_mm - a LifeLines database listing program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 25 November 1992 + Version 2, 29 November 1992 (gave up on bubblesort) + Version 3, 11 January 1993 (added deathdate and marriage) + Version 4, 18 April 1993 (bug fix, made namewidth variable) + +To sort the resulting report by name, enter the Unix command + sort -b +1 report > sorted.report +*/ + + +proc main () +{ + list(names) + list(keys) + list(indices) + + set(namewidth,40) /* change this value as needed */ + + ". ." col(8) "LAST, First Middle [MAIDEN]" + set(bcol,add(8,namewidth)) + col(bcol) "Birthdate" + set(dcol,add(22,namewidth)) + col(dcol) "Deathdate" + set(mcol,add(36,namewidth)) + col(mcol) "Marriage" + + set(marriednum,0) + print("Writing names...") + set(nextrep,0) + forindi(person,num) { + if (ge(num,nextrep)) { + print(d(num)) print(" ") + set(nextrep,add(nextrep,100)) + } + if (b,birth(person)) { set(bdate,date(b)) } + else { set(bdate,date(baptism(person))) } + if (d,death(person)) { set(ddate,date(d)) } + else { set(ddate,date(burial(person))) } + key(person) col(8) fullname(person,1,0,namewidth) + col(bcol) bdate col(dcol) ddate + families(person,fam,spouse,fnum) { + if (eq(fnum,1)) { + col(mcol) date(marriage(fam)) + } + } + nl() + if (female(person)) { + set(maidenname,save(concat(", ",fullname(person,1,1,100)))) + spouses(person,spouse,fam,fnum) { + if (spousesurname,surname(spouse)) { + set(mdate,date(marriage(fam))) + key(person) col(8) + trim(concat(upper(spousesurname),maidenname),namewidth) + col(bcol) bdate col(dcol) ddate col(mcol) mdate nl() + set(marriednum,add(marriednum,1)) + } + } + } + } + print("\nWrote ") print(d(num)) print(" database names and ") + print(d(marriednum)) print(" married names.\n") +} diff --git a/reports/indiv.ll b/reports/indiv.ll new file mode 100644 index 0000000..26e4d92 --- /dev/null +++ b/reports/indiv.ll @@ -0,0 +1,207 @@ +/* + * @progname indiv.ll + * @version 3.2 + * @author Simms + * @category + * @output Text + * @description + * + * Report on individual with all his families + + Written by: Robert Simms, 27 Mar 1996 + rsimms@math.clemson.edu, http://www.math.clemson.edu/~rsimms + + Produces an indented report on an individual and all families associated + with that individual. Details on individuals include NOTE lines. + Linewrapping is done with indenting maintained. + + At the beginning of main() is provided the means to easily change page width, + tab size, left margin, and whether or not to include notes in output. + ______________ + + Version 2: 5 April 96 -- Unknown spouses can be returned by the family + function, so a check had to be added to make sure that + individuals exist before trying to print information on them. + Now it's fixed to return _____ _____ as the name of an + unknown person. -- Robert Simms + + Version 3: 16 Feb 2000 -- Two spaces at the end of a sentence could result + in a leading space after line-wrap. Added a loop to + eliminate leading spaces after line-wrap. Care had to be taken + to use the strsave() function to get it working correctly. + Also fixed it so that page_width really is the maximum + line length, not one less. + -- Robert Simms + + Version 3.1: 30 May 2001, fixed the concatenation of multiple notes + so that two spaces are inserted before every note + after the first. Thanks to M.W. Poirier for pointing this out. + + To-do: Option to maintain blank lines (paragraphing) in notes. + Once that is done, it will be possible to separate multiple + notes with a blank line, easily. +*/ + +global(page_width) +global(tab_size) +global(left_margin) +global(note_flag) + +proc main() { + set(page_width, 80) + set(tab_size, 3) + set(left_margin, 1) + set(note_flag, 1) /*set equal to 1 to include notes, 0 not to include notes*/ + + + getindi(indi) + set(x, 0) + set(skip, left_margin) + set(x, outfam(indi, skip, x)) + + nl() + " -------------------------------------" + nl() +} + +func outfam(indi, skip, x) { + set(x, outpers(indi, skip, x)) + if(gt(nfamilies(indi), 0)) { + set(skip, add(skip, tab_size)) + families(indi, fam, sp, num) { + set(x, 0) + set(x, outline(concat("Family #", d(num)), skip, x)) + if(date(marriage(fam))) { + set(x, outline(concat(", ", date(marriage(fam))), skip, x)) + } + set(x, 0) + set(skip, add(skip, tab_size)) + /* if multiple spouses in a marriage, this will only pick up + the first one + */ + set(x, outpers(sp, skip, x)) + if(gt(nchildren(fam), 0)) { + set(x, outline("Children", skip, x)) + set(x, 0) + set(skip, add(skip, tab_size)) + children(fam, child, no) { + set(x, outpers(child, skip, x)) + } + set(skip, sub(skip, tab_size)) + } + set(skip, sub(skip, tab_size)) + } + } + return(x) +} + +func outpers(indi, skip, x) { + if(indi) { + print(name(indi), nl()) + set(x, 0) + set(x, outline(name(indi), skip, x)) + set(skip, add(skip, tab_size)) + set(s, "") + if(birth(indi)) { + set(s, concat(", b. ", long(birth(indi)))) + } + if(death(indi)) { + set(s, concat(s, ", d. ", long(death(indi)))) + } + if(burial(indi)) { + set(s, concat(s, ", buried at ", place(burial(indi)))) + } + set(s, concat(s, ". ")) + set(x, outline(s, skip, x)) + if(note_flag) { + set(s, "") + set(note_separator, "") + fornotes(inode(indi), note) { + set(s, concat(s, note_separator, note)) + set(note_separator, " ") + } + set(x, outtxt(s, skip, x)) + set(skip, sub(skip, tab_size)) + } + } else { + print("_____ _____", nl()) + set(x, 0) + set(x, outline("_____ _____", skip, x)) + } + set(x, 0) + return(x) +} + +/* outtxt -- removes new line chars from text and sends it to output + via the outline function +*/ +func outtxt(txt, skip, x) { + set(cr, index(txt, nl(), 1)) + while(ne(cr, 0)) { + set(txt, save(txt)) + set(txt2, concat(substring(txt, 1, sub(cr, 1)), " ")) + set(x, outline(txt2, skip, x)) + set(txt, substring(txt, add(cr, 1), strlen(txt))) + set(cr, index(txt, nl(), 1)) + } + if(gt(strlen(txt), 0)) { + set(x, outline(txt, skip, x)) + } + return(x) +} + +/* outline -- buffered text output with linewrapping and and indentation + preservation + the vars: x -- the column up to which text has been written + on the current line + skip -- current indentation, added to x at the start of a new + line +*/ +func outline(text, skip, x) { + if(eq(x, 0)) { + col(add(skip, 1)) + set(x, skip) + } + set(max, sub(page_width, x)) + if(gt(strlen(text), max)) { + set(space, breakpoint(text, max)) + if(eq(space, 0)) { + if(eq(x, skip)) { + set(text, strsave(text)) + substring(text, 1, sub(max, 1)) "-" + set(x, 0) + set(text, substring(text, max, strlen(text))) + set(x, outline(text, skip, x)) + } else { + set(x, 0) + set(x, outline(text, skip, x)) + } + } else { /* space gt 0 -- good break point found*/ + set(text, strsave(text)) + substring(text, 1, sub(space, 1)) + set(x, 0) + set(text, strsave(substring(text, add(space, 1), strlen(text)))) + while(eqstr(" ", substring(text, 1, 1))) { /* strip leading spaces */ + set(text, strsave(substring(text, 2, strlen(text)))) + } + set(x, outline(text, skip, x)) + } + } else { + text + set(x, add(x, strlen(text))) + } + return(x) +} + +func breakpoint(text, max) { + set(space, 0) + set(occ, 1) + set(next, index(text, " ", occ)) + incr(occ) + while ( and(le(next, add(max, 1)), ne (next, 0))) { + set(space, next) + set(next, index(text, " ", occ)) + incr(occ) + } + return(space) +} diff --git a/reports/infant_mortality.ll b/reports/infant_mortality.ll new file mode 100644 index 0000000..a16a821 --- /dev/null +++ b/reports/infant_mortality.ll @@ -0,0 +1,83 @@ +/* + * @progname infant_mortality.ll + * @version 1 + * @author Eggert + * @category + * @output Text + * @description + +This program finds families that have lost multiple children. +You give it the threshold for the number of young deaths, and the +threshold for the age at death, and it finds all the appropriate +families. + +infant_mortality - a LifeLines program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 19 September 1994 + +*/ + + +global(yob) +global(yod) + +proc main() { + getintmsg(numthresh,"Enter threshold for number of young deaths") + getintmsg(agethresh,"Enter threshold for age at death") + forfam(family,fnum) { + if (ge(nchildren(family),numthresh)) { + set(countdeaths,0) + set(maxageatdeath,0) + children(family,child,cnum) { + call get_dyear(child) + if (yod) { + call get_byear(child) + if (yob) { + set(ageatdeath,sub(yod,yob)) + if (le(ageatdeath,agethresh)) { + set(countdeaths,add(countdeaths,1)) + if (gt(ageatdeath,maxageatdeath)) { + set(maxageatdeath,ageatdeath) + } + } + } + } + } + if (ge(countdeaths,numthresh)) { + key(family) " " + name(husband(family)) " and " name(wife(family)) + "\nlost " d(countdeaths) + " children by the age of " d(maxageatdeath) + ".\n" + children(family,child,cnum) { + call get_byear(child) + call get_dyear(child) + name(child) " (" + if (yob) { d(yob) } + "-" + if (yod) { d(yod) } + ") " + if (and(yob,yod)) { d(sub(yod,yob)) } + "\n" + } + "\n" + } + } + } +} + +proc get_dyear(person) { + set(yod,0) + if (d,death(person)) { extractdate(d,dod,mod,yod) } + if (not(yod)) { + if (d,burial(person)) { extractdate(d,dod,mod,yod) } + } +} + +proc get_byear(person) { + set(yob,0) + if (b,birth(person)) { extractdate(b,dob,mob,yob) } + if (not(yob)) { + if (b,baptism(person)) { extractdate(b,dob,mob,yob) } + } +} diff --git a/reports/interestset.li b/reports/interestset.li new file mode 100644 index 0000000..5cd1256 --- /dev/null +++ b/reports/interestset.li @@ -0,0 +1,51 @@ +/* + * @progname interestset.li + * @version 1.0 + * @author Vincent Broman + * @category + * @output indiset function value + * @description Extracts subset of the database which are close to direct ancestors + */ + + +/* + * Return the set of people who are wide-sense ancestors + * of the given individual, plus the children of these wide-sense ancestors, + * where a wide-sense ancestor is either the given individual himself/herself, + * or a parent or step-parent of a wide-sense ancestor. + */ +func interestingforebearsof( indi) { + indiset( res) + addtoset( res, indi, key( indi)) + + set( pf, parents( indi)) + if( not( pf)) { return( res) } + + if( h, husband( pf)) { + set( res, union( res, interestingforebearsof( h))) + families( h, f, sp, ctf) { + if( sp) { + set( res, union( res, interestingforebearsof( sp))) + } + children( f, ch, ctc) { + addtoset( res, ch, key( ch)) + } + } + set( hk, key( h)) + } else { + set( hk, "") + } + if( w, wife( pf)) { + families( w, f, sp, cth) { + /* add only husbands not the father */ + if( and( sp, nestr( hk, key( sp)))) { + set( res, union( res, interestingforebearsof( sp))) + } else { + children( f, ch, ctcc) { + addtoset( res, ch, key( ch)) + } + } + } + } + return( res) +} diff --git a/reports/ldsgedcom.li b/reports/ldsgedcom.li new file mode 100644 index 0000000..d9e7b34 --- /dev/null +++ b/reports/ldsgedcom.li @@ -0,0 +1,121 @@ +/* + * @progname ldsgedcom.li + * @version 1.2 of 2004-07-03 + * @author Vincent Broman (vpbroman@mstar2.net) + * @category + * @output gedcom event and string function values + * @description + * + * Utility functions supporting LDS aspects of GeDCom data + * ldstemple( event) -> string, + * ldsspousesealing( fam) -> event, + * ldsbaptism( indi) -> event, + * ldsendowment( indi) -> event, + * ldschildsealing( indi) -> event + * + * I put equivalent functions in my C source, but this can be used everywhere. + */ + +func ldstemple( ev) { + fornodes( ev, childnode) { + if( eqstr( tag( childnode), "TEMP")) { + return( save( value( childnode))) + } + } + return( 0) +} + +func ldsspousesealing( fam) { + fornodes( root( fam), childnode) { + if( eqstr( tag( childnode), "SLGS")) { + return( childnode) + } + } + return( 0) +} + +func ldsbaptism( indi) { + fornodes( root( indi), childnode) { + if( eqstr( tag( childnode), "BAPL")) { + return( childnode) + } + } + return( 0) +} + +func ldsendowment( indi) { + fornodes( root( indi), childnode) { + if( eqstr( tag( childnode), "ENDL")) { + return( childnode) + } + } + return( 0) +} + +/* + * ldschildsealing(i) returns a SLGC sealing of child EVENT for the INDI indi + * or if no such event is found zero is returned. + * if the person is a child sealed in more than one family, + * only the first find is returned. + * This searches first the INDI-SLGC or INDI-FAMC-SLGC syntax, then the old FAM-CHIL-SLGC one. + */ + +func ldschildsealing( indi) { + fornodes( root( indi), childnode) { + if( eqstr( tag( childnode), "FAMC")) { + fornodes( childnode, sealnode) { + if( eqstr( tag( sealnode), "SLGC")) { + return( sealnode) + } + } + } else if( eqstr( tag( childnode), "SLGC")) { + return( childnode) + } + } + set( k, save( concat( "@", key( indi), "@"))) + if( p, parents( indi)) { + /* children( p, ch, i) */ + fornodes( root( p), childnode) { + if( and( eqstr( tag( childnode), "CHIL"), + eqstr( value( childnode), k))) { + fornodes( childnode, sealnode) { + if( eqstr( tag( sealnode), "SLGC")) { + return( sealnode) + } + } + } + } + } + return( 0) +} + +/* for testing +proc printordinance( ord) { + if( ord) { + tag( ord) ": " + if( val, value( ord)) { + val + } else { + set( ordd, save( date( ord))) + ordd + if( ordt, ldstemple( ord)) { + if( ordd) { ", " } + ordt + } + } + nl() + } +} + +proc main() { + "All individual ordinances" nl() nl() + forindi( i, c) { + "#" d( c) ": " name( i) + if( b, birth( i)) { " b. " long( b) } + nl() + call printordinance( ldsbaptism( i)) + call printordinance( ldsendowment( i)) + call printordinance( ldschildsealing( i)) + } +} + */ diff --git a/reports/line.ll b/reports/line.ll new file mode 100644 index 0000000..a41ba01 --- /dev/null +++ b/reports/line.ll @@ -0,0 +1,148 @@ +/* + * @progname line.ll + * @version 1 + * @author J.F. Chandler + * @category + * @output Text + * @description + * +displays the descendancy line(s) from one person to another. +This program assumes no individual has more than one set of parents. + +Algorithm partly borrowed from TTW's cousins program. + +Version 1 - 1998 Apr 22 - J.F. Chandler + + This program requires version 3 of LifeLines. +*/ + +global(link1) /* table of links back one person */ +global(link2) /* table of alternate links */ +global(elist) /* list of chain ends */ +global(dots) /* person counter */ + +proc main () { +getindimsg(from,"Which ancestor?") +set(to,0) +if(from) { + getindimsg(to,"Which descendant?") +} +if(not(and(from,to))) { + print("Not found\n") + return() +} +set(fkey,save(key(from))) +set(tkey,save(key(to))) +"Descendancy line from " name(indi(fkey)) "\nto " name(indi(tkey)) ":\n" +print("Searching for the line(s) from:\n",name(from)," to ",name(to)) +print(".\n\nThis may take a while -- ") +print("each dot is 25 persons considered.\n") + +table(link1) +table(link2) +list(elist) + +set(dots,0) +set(found,0) +set(gen,0) +set(maxgen,0) + +/* Link the ancestor to self (unique marker), and add as the first +entry in the list of chain ends. A "zero" person in the list marks +the end of a generation. */ + +insert(link1,fkey,fkey) +enqueue(elist,fkey) +enqueue(elist,0) + +/* Iterate through the list of chain ends, removing them one by one; +link their children back to them; add the children to the chain end +list; check each iteration to see if the target person has been found +through both parents; if so quit the iteration; also quit three +generations after finding through either parent. */ + +while(gt(length(elist),1)) { + set(key,dequeue(elist)) + if(not(key)) { + set(gen,add(1,gen)) + if(eq(gen,maxgen)) { break() } + enqueue(elist,0) + continue() + } + set(indi,indi(key)) + families(indi,fam,sp,n1) { + children(fam,child,n2) { + call include(key,child) + } + } + if(not(found)) { + if(lookup(link1,tkey)) { + set(found,1) + set(maxgen,add(3,gen)) + } + } elsif(lookup(link2,tkey)) { break() } +} + +/* Quit if the "from" is not an ancestor of the "to" person. */ + +if(not(found)) { + print("\nThere is no such line.") + "There is no such line.\n" + return() +} + +set(gen,1) +"\nWorking back:\n\n1. " call do_person(indi(tkey)) +call printrest(tkey,gen) +} + +/* Recursively print the rest of the line back to the source. +If the current person is linked through both parents, also print +the alternate line starting from here. */ + +proc printrest(key,gen) { +set(gen,add(1,gen)) +set(new,lookup(link1,key)) +if(eq(0,strcmp(key,new))) { return() } +d(gen) ". " call do_person(father(indi(key))) +" & " call do_person(mother(indi(key))) +if(alt,save(lookup(link2,key))) { "* " } /* mark a branch point */ +call printrest(new,gen) +if(alt) { + nl() + call printrest(alt,gen) +}} + +/* Link a new child (indi) back to a parent (key). +If the new child has already been linked once, use alternate table. +A truly new child is added to the list of chain ends */ + +proc include(key,indi) { + +set(dots,add(dots,1)) +if(eq(25,dots)) { + set(dots,0) + print(".") +} + +set(new,save(key(indi))) +if(lookup(link1,key(indi))) { + insert(link2,new,key) +} else { + insert(link1,new,key) + enqueue(elist,new) +}} + +/* Print name and dates for a given person */ + +proc do_person(p) { +name(p) " (" +set(e,birth(p)) +if(not(e)) {set(e,baptism(p))} +if(e) {date(e)} +" - " +set(e,death(p)) +if(not(e)) {set(e,burial(p))} +if(e) {date(e)} +")\n" +} diff --git a/reports/listsour.ll b/reports/listsour.ll new file mode 100644 index 0000000..ba0fe12 --- /dev/null +++ b/reports/listsour.ll @@ -0,0 +1,47 @@ +/* + * @progname listsour.ll + * @version 2 + * @author Hannu Väisänen + * @category + * @output Text + * @description + + List source records. + + Written by Hannu V瓣is瓣nen, 1 May 1997. +*/ + +global(sour) + +proc main() +{ + table(sour) + + forindi (person, m) { + print ("i") + call print (person) + } + forfam (family, m) { + print ("f") + call print (family) + } +} + +proc print (p) +{ + traverse (root(p), node, i) { + if (eqstr(tag(node), "SOUR")) { + if (reference(value(node))) { + if (not(lookup(sour, value(node)))) { + insert (sour, save(value(node)), 1) + set (n, dereference(value(node))) + value(node) "\n" + fornodes (n, m) { + tag(m) " " value(m) "\n" + } + "\n" + } + } + } + } +} diff --git a/reports/ll.png b/reports/ll.png new file mode 100644 index 0000000..cb597c9 Binary files /dev/null and b/reports/ll.png differ diff --git a/reports/ll2html.ll b/reports/ll2html.ll new file mode 100644 index 0000000..8a6b0c4 --- /dev/null +++ b/reports/ll2html.ll @@ -0,0 +1,1482 @@ +/* + * @progname ll2html.ll + * @version 2005-11-19 + * @author JRE Jim Eggert + * @category + * @output HTML + * @description + * + * This report program converts a LifeLines database into html documents. + * Family group records are created for each selected individual in + * the database. These records are written in files containing clumps + * of individuals of a user-selected size. Index files are generated + * for an index document. Or, optionally, all output is sent to + * one file. + * + * You will need to change the contents of proc html_address() and to + * set the value of HREF appropriately to your server. + * You need to set the value of PATH to point to the directory to put + * the files into. If you have 1000 individuals in your database this + * program will create up to 1027 files, one for each individual and + * up to 27 index files, if you set the clump size to one. + * + * This program will also generate three pedigree charts for the root + * individual and descendants charts for selected individuals. + * + * You also need to set the value of HOST to be the http server and + * path where you will server these files from. + * + * History + * 01-07-94 sew; Created. + * 11-18-94 jre; Added clump capability. + * 02-16-95 jre; Added privacy option. + * 03-06-95 jre; Added pedigree table, better sorting. + * 05-10-95 jre; Added descendants charts. + * 05-02-97 jre; Added ISO8859 encoding in GENDEX.txt file. + * 07-09-99 jre; Added background decorations, improved HTML. + * 01-15-00 jre; Fixed quicksort bug + * 11-19-05 jre; Updated released version to rev 12. Many changes. + * + */ + +global(INDEX) +global(INDEXTABLE) +global(HREF) +global(PATH) +global(PEDIGREE_NAME) +global(INDEX_NAME) +global(TITLE) +global(ADDRESS) +global(FB) +global(nl) +global(qt) +global(CURRENTCLUMPFILE) +global(root_person) +global(root_key) +global(separate_clumps) +global(PRIVTABLE) +global(privacytern) +global(sort_xlat) +global(html_xlat) +global(ISO8859_xlat) + +/* These globals are for descendant reports */ +global(grouped_henry) +global(comma_separation) +global(first_comma) +global(generations) + +/* This is for descendant and ancestor reports */ +global(written_people) +global(tree) +global(ancestors) +global(qt) +global(deltax) +global(deltay) +global(html_xlat) + +/* These constants are for estimating birth years */ +global(years_between_kids) +global(mother_age) +global(father_age) + +/* These globals are for time limits on privacy */ +global(hundred_years_ago) +global(eighty_years_ago) + +/* Decoration globals */ +global(male_gif) +global(female_gif) +global(unknown_gif) +global(logo_gif) +global(background_gif) + +proc main() +{ + +/* Change these to suit your needs */ + + set(TITLE,"Eggert Family Genealogy") /* Title of main genealogy page */ + set(PEDIGREE_NAME,"Eggert Family Ancestry") /* Pedigree chart title */ + set(INDEX_NAME,"Eggert Family Genealogy Home ") /* Index title */ + set(DESC_NAME,"Eggert Family Descendant List") /* Descendant list title */ + set(PATH, "") /* path for file references */ + set(HREF, "") /* host and path */ + + set(qt, qt()) + set(male_gif,concat(qt,"7m.gif",qt," HEIGHT=68 WIDTH=68")) + set(female_gif,concat(qt,"7f.gif",qt," HEIGHT=80 WIDTH=50")) + set(unknown_gif,concat(qt,"5U.GIF",qt)) + set(logo_gif,concat(",qt,")) + set(background_gif,concat(qt,"oldyellow.gif",qt)) + + set(FB, 0) + set(nl, nl()) + list(INDEX) + table(INDEXTABLE) + table(PRIVTABLE) + table(sort_xlat) + table(html_xlat) + table(ISO8859_xlat) + call init_xlat() + call init_years() + + indiset(people) + getindimsg(root_person,"Enter root individual:") + set(root_key,key(root_person)) + set(clumpsize,0) + while (le(clumpsize,0)) + { + getintmsg(clumpsize,"Enter number of individuals per file:") + } +/* getintmsg(separate_clumps, + * "Do you want clumps in separate files (0=no,1=yes)?") + */ + set(separate_clumps,1) + list(choices) + enqueue(choices,"all") + enqueue(choices,"deceased individuals only") + enqueue(choices,"none") + set(privacytern,sub(menuchoose(choices,"Include notes and dates for:"),1)) + list(nonprivates) + if (privacytern) { + set(person,1) + while(person) { + set(person,0) + getindimsg(person,"Enter non-private person:") + if (person) { enqueue(nonprivates,key(person)) } + } + } + list(desc_roots) + set(person,1) + while(person) { + set(person,0) + getindimsg(person,"Enter root for descendant list:") + if (person) { enqueue(desc_roots,key(person)) } + } + + print("Finding ancestry... ") + addtoset(people, root_person, 0) + set(people,union(ancestorset(people),descendantset(people))) + addtoset(people, root_person, 0) + set(people,union(people,spouseset(people))) +/* set(people,union(people,childset(people))) */ + + set(indicount,0) + set(clumpcount,1) + + print("done\nCollating index... 1") + forindiset(people,me,val,num) + { + /* print(".") */ + incr(indicount) + if (ge(indicount,clumpsize)) + { + incr(clumpcount) + set(indicount,0) + print(" ", d(clumpcount)) + } + set(k,key(me)) + enqueue(INDEX,k) + insert(INDEXTABLE,k,clumpcount) + if (eq(privacytern,1)) { insert(PRIVTABLE,k,privacy(me)) } + elsif (eq(privacytern,0)) { insert(PRIVTABLE,k,0) } + else { insert(PRIVTABLE,k,1) } + } + + if (privacytern) { + while (pkey,dequeue(nonprivates)) { + insert(PRIVTABLE,pkey,0) + } + } + + print(" done\nWriting index(slow)...") +/* */ + call create_index_file(desc_roots) +/* */ + print(" done\nWriting name files...") + call start_clumpfile(1) + forindiset(people, me, val, num) + { + call write_indi(me) + } + call end_clumpfile() +/* */ +/* */ + print(" done\nWriting pedigree chart...") + call pedigree_chart(indi(root_key)) +/* */ +/* Disable privacy checks for protected access reports */ + set(privacyternsave,privacytern) + set(privacytern,0) + print(" done\nWriting descendant lists...") + call descendant_lists(desc_roots) + print("done\n") + set(privacytern,privacyternsave) +} + +proc descendant_lists(desc_roots) { + set(grouped_henry,0) + set(comma_separation,3) + set(first_comma,0) + set(generations,0) + while (desc_key,dequeue(desc_roots)) { + print(desc_key," ") + set(desc_root,indi(desc_key)) + list(henry_list) + table(written_people) + push(henry_list,substring(mysurname(desc_root),1,1)) + set(fn, concat(PATH, "onlyfamilydesc",desc_key,".html")) + if (separate_clumps) { newfile(fn, FB) } + call html_header(DESC_NAME, 0) + "
      \n"
+	call do_header(desc_root)
+	call desc_sub(desc_root,henry_list)
+	call do_trailer(desc_root)
+	"
      " + call html_trailer("","Genealogy%20descendant%20lists") + } +} + +proc pedigree_chart(person) { + set(fn, concat(PATH, "pedigree.html")) + if (separate_clumps) { newfile(fn, FB) } + call html_header(PEDIGREE_NAME, 0) + "Go to graphic version or sort by generation or " + "name.

      \n

      \n"
+    table(written_people)
+    call pedigree(0, 1, person)
+    "
      \n" + call html_trailer("","Pedigree%20list") + + set(fn, concat(PATH, "pedigreen.html")) + if (separate_clumps) { newfile(fn, FB) } + call html_header(PEDIGREE_NAME, 0) + "Go to graphic version or sort by lineage or " + "name.

      \n" + call ahnen(person) + "\n" + call html_trailer("","Ahnentafel%20list") + + set(fn, concat(PATH, "pedigreea.html")) + if (separate_clumps) { newfile(fn, FB) } + call html_header(PEDIGREE_NAME, 0) + "Go to graphic version or sort by lineage or " + "generation.

      \n

      \n"
+    call ahnensort(person)
+    "
      \n" + call html_trailer("","Ancestor%20list") + + set(fn, concat(PATH, "pedigreeg.html")) + if (separate_clumps) { newfile(fn, FB) } + call html_header_graphic(PEDIGREE_NAME, 0) + "Go to text version or sort by generation or name." + call tableau(person) + call html_trailer_graphic("","Pedigree%20graph") +} + +proc pedigree(in, ah, indi) { + if (didah,lookup(written_people,key(indi))) { + rjustify(d(ah),add(1,mul(in,2))) " " call href(indi,neg(1)) " (see " d(didah) ")" nl + } else { + if (par, father(indi)) { call pedigree(add(1,in), mul(2,ah), par) } + rjustify(d(ah),add(1,mul(in,2))) " " call href(indi,neg(1)) nl + insert(written_people,key(indi),ah) + if (par, mother(indi)) { call pedigree(add(1,in), add(1,mul(2,ah)), par) } + } +} + +proc ahnen(person) { + table(written_people) + list(plist) + list(nlist) + enqueue(plist,person) + enqueue(nlist,1) + set(twotothen,1) + set(greatcount,neg(2)) + while(p,dequeue(plist)) { + set(n,dequeue(nlist)) + while (ge(n,twotothen)) { + if (eq(twotothen,1)) { set(label,"Self") } + elsif (eq(twotothen,2)) { set(label,"Parents") } + elsif (eq(twotothen,4)) { set(label,"Grandparents") } + elsif (eq(twotothen,8)) { set(label,"Great-Grandparents") } + else { set(label,concat("Great(x",d(greatcount),")-Grandparents")) } + "

      " label "

      \n" + set(twotothen,add(twotothen,twotothen)) + incr(greatcount) + } + d(n) " " call href(p,neg(1)) + if (other,lookup(written_people,key(p))) { + " (see " d(other) " above)" + } else { + insert(written_people,key(p),n) + if (f,father(p)) { + enqueue(plist,f) + enqueue(nlist,mul(2,n)) + } + if (m,mother(p)) { + enqueue(plist,m) + enqueue(nlist,add(1,mul(2,n))) + } + } + "
      \n" + } +} + +proc ahnensort(person) { + list(plist) + list(nlist) + list(klist) + list(nklist) + table(written_people) + enqueue(plist,person) + enqueue(klist,key(person)) + enqueue(nlist,1) + enqueue(nklist,1) + while(p,dequeue(plist)) { + set(n,dequeue(nlist)) + if (f,father(p)) { + if (didit,lookup(written_people,key(f))) { "" } + else { + insert(written_people,key(f),n) + enqueue(plist,f) + enqueue(klist,key(f)) + set(nf,add(n,n)) + if (gt(nf,nmax)) { set(nmax,nf) } + enqueue(nlist,nf) + enqueue(nklist,nf) + } + } + if (m,mother(p)) { + if (didit,lookup(written_people,key(m))) { "" } + else { + insert(written_people,key(m),n) + enqueue(plist,m) + enqueue(klist,key(m)) + set(nm,add(n,n,1)) + if (gt(nm,nmax)) { set(nmax,nm) } + enqueue(nlist,nm) + enqueue(nklist,nm) + } + } + } + list(sortindex) + list(transindex) + call translate(klist,transindex) + call quicksort(transindex,sortindex) + set(maxspacecount,strlen(d(nmax))) + forlist(sortindex,sindex,counter) + { + set(p,indi(getel(klist,sindex))) + set(n,getel(nklist,sindex)) + set(spacecount,sub(maxspacecount,strlen(d(n)))) + while(spacecount) { " " decr(spacecount) } + d(n) " " call href(p,neg(1)) nl + } +} + +proc do_header(indi_root) +{ + "desc-henry: Descendant report for " fullname(indi_root,0,1,80) + "\nGenerated by the LifeLines Genealogical System on " + stddate(gettoday()) ".\n\n" +} + +proc do_trailer(indi_root) +{ + "\nEnd of Report\n" +} + +proc tableau(indi_root) +{ + set(deltax,80) + set(deltay,16) + + list(tree) /* this will be a list of generations, most recent first */ + /* each generation will be a list of ancestors, most paternal first */ + /* each ancestor will be a list containing their data: +key (can be duplicate), generation, ahnentafel, y position, father ancestor, mother ancestor, duplicate boolean */ + table(ancestors) /* keys are ancestors, entries are lowest ahnentafel numbers */ + list(plist) + list(ancestor) + enqueue(ancestor,key(indi_root)) + enqueue(ancestor,1) + enqueue(ancestor,1) + enqueue(plist,ancestor) +/* Generate basic pedigree tree */ + while (ancestor,dequeue(plist)) { + set(key,getel(ancestor,1)) /* get basic information */ + set(gen,getel(ancestor,2)) + set(ahn,getel(ancestor,3)) + set(person,indi(key)) + if (lt(length(tree),gen)) { /* make another generation if we need it */ + list(generation) + enqueue(tree,generation) /* Note: can't skip a generation! */ + } + set(generation,getel(tree,gen)) /* get the generation */ + enqueue(generation,ancestor) /* put this ancestor on it */ + if (oldahn,lookup(ancestors,key)) { /* if we have already done this ancestor ... */ + setel(ancestor,7,oldahn) /* mark it as a duplicate */ + } else { + setel(ancestor,7,0) /* mark it as a non-duplicate */ + insert(ancestors,key,ahn) /* put it in the table of ancestors */ + if (par,father(person)) { /* and look for a father to enqueue */ + list(father) + enqueue(father,key(par)) enqueue(father,add(gen,1)) enqueue(father,add(ahn,ahn)) + enqueue(plist,father) + setel(ancestor,5,father) + } + if (par,mother(person)) { /* and look for a mother to enqueue */ + list(mother) + enqueue(mother,key(par)) enqueue(mother,add(gen,1)) enqueue(mother,add(ahn,ahn,1)) + enqueue(plist,mother) + setel(ancestor,6,mother) + } + } + } +/* Make the geometry of the tree */ + call make_geometry() +/* Write the output */ + call write_tree() +} + +proc make_geometry() { /* figure out y positions of all the ancestors */ + list(tofix) + set(gennum,length(tree)) + while (gennum) { /* for each generation, oldest generation first */ + set(generation,getel(tree,gennum)) + set(lasty,0) + forlist(generation,ancestor,ancnum) { /* for each ancestor within the generation, patrilineal first */ + if(and(getel(ancestor,5),getel(ancestor,6))) { /* has father and mother */ + set(thisy,div(add(getel(getel(ancestor,5),4),getel(getel(ancestor,6),4)),2)) + } elsif (getel(ancestor,5)) { /* has father */ + set(thisy,getel(getel(ancestor,5),4)) + } elsif (getel(ancestor,6)) { /* has mother */ + set(thisy,getel(getel(ancestor,6),4)) + } else { + set(thisy,add(lasty,deltay)) + } + setel(ancestor,4,thisy) + set(fix,add(lasty,deltay,neg(thisy))) + if (gt(fix,0)) { /* too close to previous ancestor within the generation, fix this person */ + /* and all his/her ancestors */ + enqueue(tofix,ancestor) + /* plus all parents of those persons below this one and their ancestors */ + set(found,0) + forlist(generation,ancestor2,ancnum2) { + if (found) { + if (getel(ancestor2,5)) { enqueue(tofix,getel(ancestor2,5)) } + if (getel(ancestor2,6)) { enqueue(tofix,getel(ancestor2,6)) } + } elsif (eq(ancestor,ancestor2)) { set(found,1) } + } + while(fixee,dequeue(tofix)) { + setel(fixee,4,add(fix,getel(fixee,4))) + if (getel(fixee,5)) { enqueue(tofix,getel(fixee,5)) } + if (getel(fixee,6)) { enqueue(tofix,getel(fixee,6)) } + } + } + set(lasty,getel(ancestor,4)) + } + decr(gennum) + } +} + +proc write_tree() { /* this procedure destroys (recycles?) the tree and all its generations */ + set(x,8) + set(maxx,add(x,mul(deltax,length(tree)))) + set(maxy,0) + forlist(tree,generation,gennum) { + set(thismaxy,getel(getel(generation,length(generation)),4)) + if (gt(thismaxy,maxy)) { set(maxy,thismaxy) } + } + set(maxy,add(maxy,deltay)) + "
      \n" + while(generation,dequeue(tree)) { + while(ancestor,dequeue(generation)) { + set(person,indi(getel(ancestor,1))) + /* first write the person in a box */ + "

      " + strxlat(html_xlat,surname(person)) + "

      \n" + /* then draw any connectors to his/her parents */ + set(top,add(getel(ancestor,4),5)) + set(left,add(x,deltax,neg(18))) + if(getel(ancestor,7)) { /* duplicate */ + if(or(father(person),mother(person))) { /* draw a short line */ + "
      \n" + } + } elsif(and(getel(ancestor,5),getel(ancestor,6))) { /* has father and mother */ + "
      \n" + set(topdad,add(getel(getel(ancestor,5),4),5)) + set(topmom,add(getel(getel(ancestor,6),4),5)) + "
      \n" + } elsif (or(getel(ancestor,5),getel(ancestor,6))) { /* has one parent */ + "
      \n" + } + } + set(x,add(x,deltax)) + } + "
      \n" +} + +proc do_name(person,henry_list,marr) +{ + set(h,"") + if (grouped_henry) { + set(c,sub(first_comma,1)) /* one for the root symbol */ + forlist(henry_list,l,li) { + if (not(strcmp(trim(l,1),"s"))) { + set(h,concat(h,".",l)) + } + else { + if (ge(c,comma_separation)) { + set(h,concat(h,",")) + set(c,mod(c,comma_separation)) + } + if (and(gt(strlen(l),1),gt(li,1))) { + set(h,concat(h,"(",l,")")) + } else { + set(h,concat(h,l)) + } + } + incr(c) + } + } else { + forlist(henry_list,l,li) { set(h,concat(h,l,".")) } + } + h " " + if (person) { call href(person,neg(1)) } else { "" } + if (l,lookup(written_people,key(person))) { + " appears above as " l "\n" + } + else { + if (person) { insert(written_people,key(person),h) } + "\n" + } +} + +proc desc_sub(person,henry_list) +{ + call do_name(person,henry_list,0) + set(nfam,nfamilies(person)) + set(chi,0) + families(person,fam,sp,spi) { + if (gt(nfam,1)) { push(henry_list,concat("s",d(spi))) } + else { push(henry_list,"s") } + call do_name(sp,henry_list,marriage(fam)) + set(junk,pop(henry_list)) + if (or(eq(generations,0), + lt(length(henry_list),generations))) { + children (fam,ch,famchi) { + set(chi,add(1,chi)) + push(henry_list,d(chi)) + call desc_sub(ch,henry_list) + set(junk,pop(henry_list)) + } + } + } +} + +func privacy(person) { + if (living(person)) { return(1) } + set(sib,person) + while (sib,nextsib(sib)) { if (living(sib)) { return(1) } } + set(sib,person) + while (sib,prevsib(sib)) { if (living(sib)) { return(1) } } + if (f,father(person)) { if (living(f)) { return(1) } } + if (m,mother(person)) { if (living(m)) { return(1) } } + return(0) +} + +func living(person) { + if (death(person)) { return(0) } + if (burial(person)) { return(0) } + if (b,birth(person)) { + extractdate(b, da, mo, yr) + if (gt(yr,hundred_years_ago)) { return(1) } + } + if (b,baptism(person)) { + extractdate(b, da, mo, yr) + if (gt(yr,hundred_years_ago)) { return(1) } + } + families(person,fam,spouse,nfam) { + if (m,marriage(fam)) { + extractdate(m, day, mo, yr) + if (gt(yr,eighty_years_ago)) { return(1) } + } + } + return(0) +} + +proc create_index_file(desc_roots) +{ + list(initials) + list(initialcounters) + list(sortindex) + + getintmsg(sortit,"Sort the indexes? (0=no, 1=yes)") + if (sortit) { + + print("sorting...") + list(transindex) + call translate(INDEX,transindex) + call quicksort(transindex,sortindex) + print("writing letter indices...") + + set(initial,"no-initial") + set(counter,1) + forlist(sortindex,sindex,counter) + { + set(me,indi(getel(INDEX,sindex))) + set(myinitial,trim(strxlat(sort_xlat,trim(mysurname(me),1)),1)) + if (strcmp(myinitial,initial)) + { + if (strcmp(initial,"no-initial")) + { + "
    \n" + call html_trailer("",concat("Name%20list%20",initial)) + enqueue(initials, initial) + enqueue(initialcounters, initialcounter) + set(initial, myinitial) + } + else + { + set(initial, myinitial) + } + set(initialcounter,0) + print("-", initial, "-") + set(fn, concat(PATH, "index", initial, ".html")) + if (separate_clumps) { newfile(fn, FB) } + call html_header( + concat(INDEX_NAME,initial) + , 0) + "
      \n" + } + "
    • " call href(me,neg(1)) nl + incr(initialcounter) + } + "
    \n" + call html_trailer("",concat("Name%20list%20",initial)) + enqueue(initials, initial) + enqueue(initialcounters, initialcounter) + + print("writing master_index...") + set(fn, concat(PATH, "master_index", ".html")) + if (separate_clumps) { newfile(fn, FB) } + forlist(sortindex,sindex,counter) { + set(me,indi(getel(INDEX,sindex))) + "
  • " call href(me,neg(1)) nl + } + + print("writing main index...") + set(fn, concat(PATH, "index.html")) + if (separate_clumps) { newfile(fn, FB) } + call html_header(INDEX_NAME, 0) + + "

    qt \n" + "This database contains the families of the ancestors of my children.\n" + "Most of them are German, German-American,\n" + "Syrian, and Syrian-American.\n" + "This list contains about a twelfth of\n" + "my entire genealogical database. If you would like to see more,\n" + "please send e-mail." + + "

    For more information about German genealogy in general, try the\n" + "German genealogy website, where I manage\n" + "the soc.genealogy.german FAQ\n" + "and the\n" + "Schaumburg-Lippe pages.\n" + + "

    \n

    Start with me Eggert, James Robert (1957-?)\n" + + "

    Look at my ancestry chart.\n" + + if (length(desc_roots)) { + "

    Here are some descendant reports:\n

    \n" + } + + "

    Examine my RootsWeb Surname List (RSL) entries and my RootsWeb WorldConnect database.\n" + "

    Here is my list of sources.\n" + "

    There is also a PDF file (~400KB, 162 pages) of the entire ancestry.\n" + "

    Here are some of my special projects.\n" + + indiset(baseset) + addtoset(baseset,indi(root_key),1) + indiset(addset) + addtoset(addset,indi(root_key),1) + set(generations,4) + while(gt(generations,0)) { + set(addset,parentset(addset)) + forindiset(addset,addperson,pval,pnum) { + if (female(addperson)) { addtoset(baseset,addperson,1) } + } + decr(generations) + } + + namesort(baseset) + forindiset(baseset,person,pval,pnum) { + if (eq(pnum,1)) { + "

    These are the base surnames in this ancestry:
    \n" + } + "" mysurname(person) "" + if (eq(pnum,sub(lengthset(baseset),1))) { ", and\n" } + elsif (eq(pnum,lengthset(baseset))) { ".\n" } + else { ",\n" } + } + "

    You can also find surnames alphabetically by their first letter:
    \n" + set(first_dash,1) + while (initial,dequeue(initials)) + { + set(count,dequeue(initialcounters)) + if (first_dash) { + set(first_dash,0) + } else { + " - " + } + "" + initial "" + } + "\n" + "

    There are " d(length(INDEX)) + " main entries in this website, from " + set(pcount,0) + forindi(person,pnum) { set(pcount,pnum) } + d(pcount) " in my database, last updated " + dayformat(2) monthformat(6) dateformat(0) + stddate(gettoday()) ".\n" + + "

    \n" + "

    " + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + + "\n" + "\n" + "\n" + "\n" + "
    Search this site   Point your feedreader to my
    \n" + "
    powered by FreeFind
    		RSS
    \n" + + call html_trailer("
    \neggertjkey\n","Genealogy%20query") + +/* make GENDEX index file */ +/* */ + print("writing GENDEX...") + set(fn, concat(PATH, "GENDEX.txt")) + if (separate_clumps) { newfile(fn, FB) } + forlist(sortindex,sindex,counter) { + set(mykey,getel(INDEX,sindex)) + set(me,indi(mykey)) + set(private,lookup(PRIVTABLE,mykey)) + "clump" d(lookup(INDEXTABLE,mykey)) ".html#" mykey + "|" strxlat(ISO8859_xlat,mysurname(me)) + "|" strxlat(ISO8859_xlat,mygivens(me)) + " /" strxlat(ISO8859_xlat,mysurname(me)) "/" + "|" + if (evt, birth(me)) { + if (not(private)) { date(evt) } + "|" strxlat(ISO8859_xlat,place(evt)) + } else { "|" } + "|" + if (evt, death(me)) { + if (not(private)) { date(evt) } + "|" strxlat(ISO8859_xlat,place(evt)) + } else { "|" } + "|\n" + } +/* */ + } else { + print("writing master_index...") + set(fn, concat(PATH, "master_index", ".html")) + if (separate_clumps) { newfile(fn, FB) } + forlist(INDEX,mykey,counter) { + "

  • " call href(indi(mykey),neg(1)) nl + } +/* */ + print("writing GENDEX...") + set(fn, concat(PATH, "GENDEX.txt")) + if (separate_clumps) { newfile(fn, FB) } + forlist(INDEX,mykey,counter) { + set(me,indi(mykey)) + set(private,lookup(PRIVTABLE,mykey)) + "clump" d(lookup(INDEXTABLE,mykey)) ".html#" mykey + "|" strxlat(ISO8859_xlat,mysurname(me)) + "|" strxlat(ISO8859_xlat,mygivens(me)) + " /" strxlat(ISO8859_xlat,mysurname(me)) "/" + "|" + if (evt, birth(me)) { + if (not(private)) { date(evt) } + "|" strxlat(ISO8859_xlat,place(evt)) + } else { "|" } + "|" + if (evt, death(me)) { + if (not(private)) { date(evt) } + "|" strxlat(ISO8859_xlat,place(evt)) + } else { "|" } + "|\n" + } +/* */ + } + print("done\n") +} + +proc start_clumpfile(clumpnum) +{ + print(" ", d(clumpnum)) + set(CURRENTCLUMPFILE, clumpnum) + set(fn, concat(PATH, "clump", d(CURRENTCLUMPFILE), ".html")) + if (separate_clumps) { newfile(fn, FB) } + call html_header(TITLE, 0) + "
    \n" +} + +proc end_clumpfile() +{ + " [Home] " + call html_trailer("",concat("Genealogy%20query%20",d(CURRENTCLUMPFILE))) +} + +proc write_indi(me) +{ + set(private,lookup(PRIVTABLE,key(me))) + set(myclump,lookup(INDEXTABLE,key(me))) + if (ne(myclump,CURRENTCLUMPFILE)) + { + call end_clumpfile() + call start_clumpfile(myclump) + } + "

    qt \n" + "    " + call print_name(me, 1) "

    \n" + "
    "
+    nl
+    if(e, birth(me))   { "Birth:     " privlong(e,private) nl }
+    if(e, baptism(me)) { "Baptism:   " privlong(e,private) nl }
+    if(e, death(me))   { "Death:     " privlong(e,private) nl }
+    if(e, burial(me))  { "Burial:    " privlong(e,private) nl }
+    nl
+    if (f,father(me)) { "Father:    " call href(f,myclump) nl }
+    if (m,mother(me)) { "Mother:    " call href(m,myclump) nl }
+    set(nfam,nfamilies(me))
+    families(me, fam, sp, nsp)
+    {
+	nl
+	"Married"
+	if (gt(nfam,1)) { "(" d(nsp) ") " } else { "    " }
+	call href(sp,myclump)
+	if(e, marriage(fam)) { "\n           " privlong(e,private) }
+	fornodes(fnode(fam),thisnode) {
+	    if (not(strcmp(tag(thisnode),"DIV")))
+	    {
+		if (not(private)) { ", Divorced" }
+	    }
+	}
+	nl
+	if(nchildren(fam))
+	{
+	    "Children:\n"
+	    children(fam, ch, nch)
+	    {
+		rjt(nch, 5) ". "
+		call href(ch,myclump) nl
+	    }
+	}
+    }
+    nl
+    if (not(private)) { call print_notes(me) }
+    "
    \n" +} + +func privlong(event,private) { + if (private) { strxlat(html_xlat,place(event)) } + else { strxlat(html_xlat,long(event)) } +/* if (private) { place(event) } + else { long(event) } */ +} + +proc print_notes(me) +{ + set(first, 1) + fornodes( inode(me), node) + { + if (not(strcmp("NOTE", tag(node)))) + { + if(first) { "Notes: " nl nl set(first, 0) } + strxlat(html_xlat,value(node)) nl +/* value(node) nl */ + fornodes(node, next) + { + strxlat(html_xlat,value(next)) nl +/* value(next) nl */ + } + nl + } + } + fornodes( inode(me), node) + { + if (not(strcmp("REFN", tag(node)))) + { + if(first) { "Notes: " nl nl set(first, 0) } + "SOURCE: " strxlat(html_xlat,value(node)) nl +/* "SOURCE: " value(node) nl */ + nl + } + } +} + +proc href(me,fromclump) +{ + if(me) + { + set(private,0) + set(myclump,lookup(INDEXTABLE,key(me))) + if (myclump) + { + if (eq(fromclump,myclump)) + { + "" + } + else + { + "" + } + if (privacytern) { set(private,lookup(PRIVTABLE,key(me))) } + } + elsif (privacytern) { set(private,privacy(me)) } + call print_name(me, 1) + if (myclump) { "" } + " (" + if (print_year_place(birth(me),baptism(me),"*",private)) { + set(j,print_year_place(death(me),burial(me)," +",private)) + } else { + set(j,print_year_place(death(me),burial(me),"+",private)) + } + ")" + } +/* else { "_____" } */ +} + +func print_year_place(event,secondevent,symbol,private) +{ + set(noyear,1) + set(noplace,1) + if (not(private)) { + if (event) { + set(d, date(event)) + set(y, year(event)) + if (strlen(y)) { + symbol call print_fix_year(d,y) set(noyear,0) + } + } + if (noyear) { + if (secondevent) { + set(d, date(secondevent)) + set(y, year(secondevent)) + if (strlen(y)) { + symbol call print_fix_year(d,y) set(noyear,0) + } + } + } + } + if (noyear) { set(space,symbol) } else { set(space," ") } + if (event) { + set(p, place(event)) + if (strlen(p)) { space strxlat(html_xlat,p) set(noplace,0) } +/* if (strlen(p)) { space p set(noplace,0) } */ + } + if (noplace) { + if (secondevent) { + set(p, place(secondevent)) + if (strlen(p)) { space strxlat(html_xlat,p) set(noplace,0) } +/* if (strlen(p)) { space p set(noplace,0) } */ + } + } + return(not(and(noyear,noplace))) +} + +proc print_fix_year(d,y) +{ + if (index(d,"BEF",1)) { "<" } + if (index(d,"AFT",1)) { ">" } + if (index(d,"ABT",1)) { "c" } + y +/* Handle PAF slash years */ + set(yp,index(d,y,1)) + set(d2,substring(d,add(yp,4),strlen(d))) + if (d2) { + if (eq(index(d2,"/",1),1)) { + substring(d2,1,5) + } + } +} + +proc html_header(str, isindex) +{ + "\n" + "\n" + "\n" + "\n" + if(isindex) { "" nl } + " " str " \n" + "\n" + "\n" + "\n" + "\n" + "\n" + "

    " logo_gif "  " str "

    \n" + } + +proc html_header_graphic(str, isindex) +{ + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + " " str " \n" + "\n" + "\n" + "\n" + "\n" + "

    " logo_gif "  Eggert Family Ancestry

    \n" + "

    male

    \n" + "

    female

    \n" + "
    \n" + " \n" + "Hover over a name to see the full name. Click on a name for more information.\n" + "
    \n" + "     \n" + "
    \n" +} + + +proc html_trailer(tag,subject) +{ + "
    \n" + "=Jim Eggert
    \n" + "Email:   + qt
    \n" + "Home Page:  http://mysite.verizon.net/eggertj/
    \n" + "Copyright © " year(gettoday()) + " by James R. Eggert, All Rights Reserved.\n" + tag + "\n" + "\n" +} + +proc html_trailer_graphic(tag,subject) +{ + "\n" + "\n" +} + +proc print_name (me, last) +{ + strxlat(html_xlat,fullname(me, 0, not(last), 45)) +/* if (last) { + mysurname(me) ", " mygivens(me) + } else { + mygivens(me) " " mysurname(me) + } */ +/* fullname(me, 0, not(last), 45) */ + fornodes(inode(me), node) + { + if (not(strcmp("TITL", tag(node)))) { set(n, node) } + } + if (n) { " " strxlat(html_xlat,value(n)) } +/* if (n) { " " value(n) } */ +} + +func rjt(n, w) +{ + set(d, strlen(d(n))) + if (lt(d, w)) + { set(pad, trim(" ", sub(w, d))) } + else + { set(pad, "") } + return(concat(pad, d(n))) +} + +/* + quicksort: Sort an input list by generating a permuted index list + Input: alist - list to be sorted + Output: ilist - list of index pointers into "alist" in sorted order + Needed: compare- external function of two arguments to return -1,0,+1 + according to relative order of the two arguments +*/ +proc quicksort(alist,ilist) { + set(len,length(alist)) + set(index,len) + while(index) { + setel(ilist,index,index) + decr(index) + } + if (ge(len,2)) { call qsort(alist,ilist,1,len) } +} + +/* recursive core of quicksort */ +proc qsort(alist,ilist,left,right) { +print(".") + if(pcur,getpivot(alist,ilist,left,right)) { + set(pivot,getel(alist,getel(ilist,pcur))) + set(mid,partition(alist,ilist,left,right,pivot)) + call qsort(alist,ilist,left,sub(mid,1)) + call qsort(alist,ilist,mid,right) + } +} + +/* partition around pivot */ +func partition(alist,ilist,left,right,pivot) { + while(1) { + set(tmp,getel(ilist,left)) + setel(ilist,left,getel(ilist,right)) + setel(ilist,right,tmp) + while(lt(compare(getel(alist,getel(ilist,left)),pivot),0)) { + incr(left) + } + while(ge(compare(getel(alist,getel(ilist,right)),pivot),0)) { + decr(right) + } + if(gt(left,right)) { break() } + } + return(left) +} + +/* choose pivot */ +func getpivot(alist,ilist,left,right) { + set(pivot,getel(alist,getel(ilist,left))) + set(left0,left) + incr(left) + while(le(left,right)) { + set(rel,compare(getel(alist,getel(ilist,left)),pivot)) + if (gt(rel,0)) { return(left) } + if (lt(rel,0)) { return(left0) } + incr(left) + } + return(0) +} + +/* translate a whole key list via sort_xlat to a sortable list */ +proc translate(listin,listout) { + forlist(listin,pkey,i) { + set (p,indi(pkey)) + enqueue(listout, + concat(strxlat(sort_xlat,mysurname(p))," ", + strxlat(sort_xlat,mygivens(p)), " ", + d(estimate_byear(p)))) + } +} + +/* compare indis referred to by strings constructed as in translate() */ +func compare(str1,str2) { + return(strcmp(str1,str2)) +} + +/* compare indis referred to by keys */ +func keycompare(pkey1,pkey2) { + if(not(strcmp(pkey1,pkey2))) { return(0) } + if (s,strcmp(strxlat(sort_xlat,mysurname(indi(pkey1))), + strxlat(sort_xlat,mysurname(indi(pkey2))))) { return(s) } + if (s,strcmp(strxlat(sort_xlat,mygivens(indi(pkey1))), + strxlat(sort_xlat,mygivens(indi(pkey2))))) { return(s) } + return(intcompare(estimate_byear(indi(pkey1)),estimate_byear(indi(pkey2)))) +} + +func intcompare(i1,i2) { + if(lt(i1,i2)) { return(neg(1)) } + if(eq(i1,i2)) { return(0) } + return(1) +} + +/* translate string according to xlat table */ +func strxlat(xlat,string) { + set(fixstring,"") + set(pos,strlen(string)) + while(pos) { + set(char,substring(string,pos,pos)) + if (special,lookup(xlat,char)) { + set(fixstring,concat(special,fixstring)) + } + else { set(fixstring,concat(char,fixstring)) } + decr(pos) + } + return(fixstring) +} + +proc init_xlat() { +/* This initializes the various translation tables. + Note that these use the Macintosh encoding scheme! +*/ + +/* Translation table for sorting purposes. + Note that this is mostly to handle German characters. +*/ + insert(sort_xlat,"","oe") + insert(sort_xlat,"","ue") + insert(sort_xlat,"","ae") + insert(sort_xlat,"","ss") + insert(sort_xlat,"","Ae") + insert(sort_xlat,"","Oe") + insert(sort_xlat,"","Ue") + insert(sort_xlat,"","e") + insert(sort_xlat,"","y") + insert(sort_xlat,"","e") + insert(sort_xlat,"","n~") + insert(sort_xlat,"","oe") + insert(sort_xlat,"<","") + insert(sort_xlat,">","") + +/* For the full list of HTML encodings for special characters, see + http://info.cern.ch/hypertext/WWW/MarkUp/ISOlat1.html +*/ + insert(html_xlat,"","ö") + insert(html_xlat,"","ü") + insert(html_xlat,"","ä") + insert(html_xlat,"","ß") + insert(html_xlat,"","Ä") + insert(html_xlat,"","Ö") + insert(html_xlat,"","Ü") + insert(html_xlat,"","ë") + insert(html_xlat,"","ÿ") + insert(html_xlat,"","é") + insert(html_xlat,"","ì") + insert(html_xlat,"","`") + insert(html_xlat,"&","&") + insert(html_xlat,"","ñ") + insert(html_xlat,"","œ") + insert(html_xlat,"<","<") + insert(html_xlat,">",">") + +/* ISO 8859 translation for the GENDEX.txt file +*/ + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","'") + insert(ISO8859_xlat,"","") + insert(ISO8859_xlat,"","") +} + +proc init_years() { + set(years_between_kids,2) + set(mother_age,23) + set(father_age,25) + set(hundred_years_ago,sub(atoi(year(gettoday())),100)) + set(eighty_years_ago, sub(atoi(year(gettoday())),80)) +} + +func estimate_byear(person) { + set(byear_est,0) + if(byear,get_byear(person)) { return(byear) } + set(older,person) + set(younger,person) + set(yeardiff,0) + set(border,0) + while (or(older,younger)) { + set(older,prevsib(older)) + set(younger,nextsib(younger)) + set(yeardiff,add(yeardiff,years_between_kids)) + if (older) { + incr(border) + if (byear,get_byear(older)) { + return(add(byear,yeardiff)) + } + } + if (younger) { + if(byear,get_byear(younger)) { + return(sub(byear,yeardiff)) + } + } + } +/* estimate from parents' marriage */ + set(my,0) + if (m,marriage(parents(person))) { extractdate(m,bd,bm,my) } + if (my) { + return(add(add(my,mul(years_between_kids,border)),1)) + } +/* estimate from first marriage */ + families(person,fam,spouse,fnum) { + if (gt(fnum,1)) { break() } + if (m,marriage(fam)) { extractdate(m,bd,bm,my) } + if (my) { + if (female(person)) { return(sub(my,mother_age)) } + else { return(sub(my,father_age)) } + } + children(fam,child,cnum) { + if (byear,get_byear(child)) { + if (female(person)) { + return(sub(sub(byear, + mul(sub(cnum,1),years_between_kids)), + mother_age)) + } + else { + return(sub(sub(byear, + mul(sub(cnum,1),years_between_kids)), + father_age)) + } + } + } + } +/* estimate from parents' birthyear */ + set(older,person) set(byear_addend,0) + while(older,prevsib(older)) { + set(byear_addend,add(byear_addend,years_between_kids)) + } + if (byear,get_byear(mother(person))) { + return(add(byear,mother_age,byear_addend)) + } + if (byear,get_byear(father(person))) { + return(add(byear,father_age,byear_addend)) + } + return(0) +} + +func get_byear(person) { + set(byear,0) + if (person) { + if (b,birth(person)) { extractdate(b,day,month,byear) } + if (byear) { return(byear) } + if (b,baptism(person)) { extractdate(b,day,month,byear) } + } + return(byear) +} + +func mysurname(person) { + set(s,surname(person)) + if (not(strlen(s))) { set(s,"____") } + if (not(strcmp(s,""))) { set(s,"____") } + return(s) +} + +func mygivens(person) { + set(s,givens(person)) + if (not(strlen(s))) { set(s,"____") } + return(s) +} + diff --git a/reports/ll2visio.ll b/reports/ll2visio.ll new file mode 100644 index 0000000..df85049 --- /dev/null +++ b/reports/ll2visio.ll @@ -0,0 +1,319 @@ +/* + * @progname ll2visio.ll + * @version 1 of 1999-04-02 + * @author Rafal T. Prinke (rafalp@amu.edu.pl) + * @category + * @output VISIO 5 diagram + * @description + * + * This program generates a text file with male line descendants + * which can be imported by VISIO 5 and converted to a diagram. + * + * The main procedure is based on Tom Wetmore's _pdesc2_ report. + * The procedures "longvitals" and "spousevitals" were originally + * based on the same in Tom Wetmore's _register1_ report but + * have been changed beyond recognition. + * + * The included procedures "upl2.ll" were written by Paul McBride. + * + * The text file describing a diagram to be constructed in VISIO 5 + * consists of records (lines) and data fields separated with a comma (.csv) + * or a tab (.txt). It can also use an arbitrary delimiter but this report + * uses a comma so the output file should be given a .CSV extension. + * The CR (hard return) character is not treated as end of record if + * enclosed in quotation marks. Comment lines are escaped with a semicolon. + * All measurements are in inches. + * + * Here is a quick reference to record types. For one field records + * I have added possible values [with explanations in brackets]. + * + * + * + * Master,MasterID,StencilName + * + * PlacementStyle,Style (0|1|2) [Radial|TopToBottom|LeftToRight] + * RoutingStyle,Style (1|2|3|4|5|) [RightAngle||||Flowchart] + * + * NodeToLineClearance,Horizontal,Vertical + * LineToLineClearance,Horizontal,Vertical + * + * Gridding,UseGrid (0|1) [no|yes] + * BlockSize,Width,Length + * AvenueSize,Width,Height + * + * Template,FileName + * Property,Master,RowName,Label,Prompt,Type,Format,Value,Hidden,Ask + * + * Shape,ID,Master,Text,X,Y,Width,Height,Property + * Link,ID,Master,Text,From,To + * + */ + +include("upl2.ll") + +global(persons) +global(mens) +global(ind1) +global(first) +global(maxgen) +global(upl_tag_list) +global(upl_before_list) +global(upl_after_list) +global(upl_level_list) +global(upl_process_list) +global(upl_out_type) /* 0 = both, 1 = screen, 2 = file */ + +proc main () { + + list(persons) + table(mens) + call upl_build() + set(upl_out_type, 2) /* output to file */ + + while(not(indi)) { + getindi(indi) + } + getintmsg(maxgen,"How many generations? ") + + call head(indi) + call mensae(indi) + call pout(0, indi) + set(first,key(indi)) + + while(not(empty(persons))) { + set(p,pop(persons)) + call longvitals(p) + } +} + +/* This procedure produces a list of individuals which is then + * popped for final output. The reason is that VISIO 5 seems to + * lay out the shapes from top to bottom and from right to left, + * so the older children would be on the right and younger on the left, + * while in traditional genealogical tables the older children are + * on the left. + */ + +proc pout(gen, indi) +{ + push(persons, indi) + set(next, add(1, gen)) + families(indi,fam,sp,num) { + if (lt(next,maxgen)) { + +/* + remove the condition below to include all descendants + (this may not work well yet - father/mother functions need modification) +*/ + + if(eqstr(sex(indi),"M")) { + children(fam, child, no) { + call pout(next, child) + } + } + } + } +} + +/* + * The following is the procedure outputting the header of the .csv + * file for import to VISIO 5. The records field and allowed values + * can be altered to give intended results. + */ + +proc head(u) +{ + + "Master,AUTO,Auto-height Box,Basic Flowchart Shapes.VSS\n" + "Master,CON,Bottom to top variable,Connectors and Callouts.VSS\n" + "PlacementStyle,1\n" + "RoutingStyle,1\n" + ";RoutingStyle,7\n" + "AvenueSize,0.15,0.15\n" + "LineToLineClearance,0.1,0.1\n" + "NodeToLineClearance,0.1,0.1\n" + "BlockSize,0.2,0.2\n" + "Gridding,0\n" + ";Property,AUTO,,,,\n" + ";Template,\n" + "\n" +} + +/* + * The remaining procedures define what information goes into + * one person box. This is rather specific to my files and uses + * Polish terms so should be adapted to one's needs. + */ + + +proc longvitals(i) +{ + set(ikey,key(i)) + set(ind1,i) + +/* + * The following line is the beginning of an individual shape (or box) + * definition, and then the text inside it is constructed. + * NOTE: if there are quotation marks in the data, there may be problems. + */ + + "Shape," ikey ",AUTO," "\"" + +/* The following fragment is intended to overcome the "unknown mother" + * problem when numbering marriages. It is assumed that a dummy FAM record + * (a) has no WIFE, (b) has the word "ANY" as the wife's name, or (c) has two + * or more numbers separated with the bar character as her name (e.g. "2|3") + * when only some wives are possible mothers. + */ + + +if(nestr(ikey,first)) { + if (ne(nfamilies(father(i)),1)) { + if (eqstr(name(mother),"ANY")) { + "(n) " + } + elsif (index(name(mother(i)),"|",1)) { + "(" name(mother) ") " + } + else { + set(wnm,0) + families(father(i),a,b,c) { + if (wife(parents(i))) { + set(wnm,add(wnm,1)) + } + if (eqstr(key(a),key(parents(i)))) { + if (wife(parents(i))) { + "(" d(wnm) ") " } + else { "(n) " } + } + } + } + } +} + +/* biographical data report on person is called */ + +call upl_report(i) + + if (eq(1,nspouses(i))) { + spouses(i,s,f,n) { + "; x " + call spousevitals(s,f) + } + } else { + spouses(i,s,f,n) { + "; x (" d(n) ") " + call spousevitals(s,f) + } + } + + "\"\n" + +/* + * The following line is the definition of a link between two boxes. + * The condition excludes up-link from the first person. + */ + +if(nestr(ikey,first)) { "Link,,CON,," key(father(i)) "," key(i) "\n" } + +} + +proc spousevitals (spouse,fam) +{ + set(e,marriage(fam)) + if (and(e,long(e))) { mylong(e) ", " } + roz(fam) + +/* biographical data report on spouse is called */ + +call upl_report(spouse) + + set(dad,father(spouse)) + set(mom,mother(spouse)) + if (or(dad,mom)) { + ", " + if (male(spouse)) { "s. " } + elsif (female(spouse)) { "dau. " } + else { "ch. " } + } + + if (dad) { givens(dad) /* "==a" */ + fornodes(inode(dad), ok) { + if (eqstr(tag(ok),"OCCU")) { + ", " value(ok) + } + } + } + +/* Other marriages of the spouse. */ + + set(srd,0) + if (gt(nspouses(spouse),1)) { " [" + spouses(spouse,ind2,fm,nsp) { + if (ne(ind2,ind1)) { + if (srd) { "; " } + " x (" d(nsp) ") " + set (es,marriage(fm)) + if (and(es,long(es))) { mylong(es) " " } + roz(fm) + name(ind2,0) + set(srd,1) + } + } + "]" + } +} + +func mylong(ev) +{ + list(datum) + extracttokens(date(ev),datum,n," ") + forlist(datum,q,n) { + if (lookup(mens,q)) { lookup(mens,q) } + else { q } + } + if(place(ev)) { + " (" place(ev) ")" + } +} + + +func roz(fx) +{ + fornodes(root(fx), ok) { + if (eqstr(tag(ok),"DIV")) { + ", div." + fornodes(ok, dt) { + if (eqstr(tag(dt),"DATE")) { + " " mylong(dt) + } + } + } + } +} + + +/* Table of date tokens follows. */ + +proc mensae(w) +{ +insert(mens,"JAN",".I.") +insert(mens,"FEB",".II.") +insert(mens,"MAR",".III.") +insert(mens,"APR",".IV.") +insert(mens,"MAY",".V.") +insert(mens,"JUN",".VI.") +insert(mens,"JUL",".VII.") +insert(mens,"AUG",".VIII.") +insert(mens,"SEP",".IX.") +insert(mens,"OCT",".X.") +insert(mens,"NOV",".XI.") +insert(mens,"DEC",".XII.") +insert(mens,"BEF","a") +insert(mens,"AFT","p") +insert(mens,"ABT","c") +insert(mens,"CIR","c") +insert(mens,"BET","") +insert(mens,"AND","/") +} + diff --git a/reports/lldb.ll b/reports/lldb.ll new file mode 100644 index 0000000..8289ee8 --- /dev/null +++ b/reports/lldb.ll @@ -0,0 +1,226 @@ +/* + * @progname lldb.ll + * @version 1.02 + * @author Marc Nozell + * @category palmpilot + * @output pdb import files + * @description + * + * This program produces a report of all INDI's in the database, with + * sorted names as output for inport into Tom Dyas' Open Source DB + * PalmOS app. + * + * lldb.ll V1.02 + * + * Marc Nozell + * + * This report generator works only with the LifeLines Genealogy program + * + * It will produce a report of all INDI's in the database, with + * sorted names as output for inport into Tom Dyas' Open Source DB + * PalmOS app. + * + * 0) Obtain Tom Wetmore's LifeLines genealogy program for Unix. + * See https://lifelines.github.io/lifelines/ + * + * 1) Obtain Kenneth Albanowski's pilot-link + * package. The Microsoft Windows-based Palm desktop should also + * work. Most Linux distributions include pilot-link (check + * http://rpmfind.net) and should build on most UNIXes. + * + * 2) Obtain Tom Dyas' "DB: Open Source + * Database Program for PalmOS" and supporting tools from + * http://pilot-db.sourceforge.net/ + * + * 3) Run this lifelines report. It will generate two files, lldb.info + * and lldb.csv. + * + * 5) Run the CSV to PDB conversion tool like this: + * csv2pdb --info=lldb.info lldb.csv lldb.pdb + * + * 5) Install the converted info to the Palm device like this: + * pilot-link -i ll.pdb + * + * + * V1.00 11-Sep-1999 + * Initial Version + * + * V1.01 26-Oct-1999 + * + * Cleaned up output files + * Updated to new version Dyas' conversion tool + * (pre-palm-db-tools-0.2.0.tar.gz) + * + * V1.02 10-Nov-2000 + * Updated URLs + * + * Revision 1.7 2004/07/19 05:54:55 dr_doom + * Merge Vincent Broman Changes to reports + * + * Revision 1.6 2003/01/19 02:50:23 dr_doom + * move 1 paragraph description to immediately before @description for index.html + * + * Revision 1.5 2000/11/28 21:39:45 nozell + * Add keyword tags to all reports + * Extend the report script menu to display script output format + * + * Revision 1.4 2000/11/27 20:48:15 nozell + * Header is to verbose, use just Log + * + * Revision 1.3 2000/11/27 20:46:26 nozell + * Typo in CVS header + * + * Revision 1.2 2000/11/27 20:45:43 nozell + * Add CVS keywords + * + * + */ + +proc main () +{ +/* newfile (concat (database (), ".info"), 0) */ + + newfile (concat ("lldb.info"), 0) + + "title \"Genealogy\"\n" + "backup off\n" + "find on\n" + "extended off\n" + "field \"ID\" string 25\n" + "field \"Name\" string 80\n" + "field \"Birth\" string 80\n" + "field \"Death\" string 80\n" + "field \"SpouseID\" string 80\n" + "field \"ChildrenID\" string 80\n" + "field \"FatherID\" string 80\n" + "field \"MotherID\" string 80\n" + +/* newfile (concat (database (), ".csv"), 0) */ + + newfile (concat ("lldb.csv"), 0) + + indiset(idx) + + /* monthformat(4) */ + + /* Grab them all */ + print("Please wait...") + forindi(indi,n) { + addtoset(idx,indi,n) + } + print(nl()) print("Found ") print(d(n)) print(" people.") + print(nl()) + print("begin sorting") print(nl()) + namesort(idx) + print("done sorting") print(nl()) + +/* col(1) "ID,Name,Birth,Death,SpouseID,ChildrenID,FatherID,MotherID" nl() */ + + forindiset(idx,indi,v,n) { + col(1) "\"" key(indi) "\"" + "," + "\""fullname(indi,1,0,30) "\"" + "," + + call showvitals(indi) + call showspouse(indi) + call showkids(indi) + call showparents(indi) + print("+") + } + + nl() + print(nl()) +} + +/************************************************************************/ +proc showvitals (i) +{ + set(b, birth(i)) + set(d, death(i)) + if (and(b, short(b))) { + "\"" long(b) "\"" + } + else { + "\" \"" + } + + "," + + if (and(d, short(d))) { + "\"" long(d) "\"" + } + else { + "\" \"" + } +} + +proc showparents (i) +{ + ",\"" + if(fath,father(i)) { +/* "(" key(fath) ") " */ + key(fath) + } + else { + "-unknown-" + } + + "\"" + + ",\"" + + if(moth,mother(i)) { +/* "(" key(moth) ") " */ + key(moth) + } + else { + "-unknown-" + } + "\"" +} +/************************************************************************/ +proc showspouse (i) { + ",\"" + if (eq(1, nspouses(i))) { + spouses(i, s, f, n) { + name(s) "(" key(s) ") " + } + } + else { + spouses(i, s, f, n) { + ord(n) /* First, Second ... */ + " " name(s) "(" key(s) ") " + } + } + "\"" +} + +/************************************************************************/ +proc showkids (i) { + ",\"" + set(j, 0) + families(i, f, s, n) { + set(j, add(j, nchildren(f))) + } + + if (eq(0, j)) { + " " + } + else { + if (eq(1, j)) { + "Child: " + } + else { + d(j) " Children:" + } + set(j, 1) + families(i, f, s, n) { + children(f, c, m) { + " (" key(c) ")" + set(j, add(j,1)) + } + } + } + "\"" +} diff --git a/reports/longlines.ll b/reports/longlines.ll new file mode 100644 index 0000000..f1dab1e --- /dev/null +++ b/reports/longlines.ll @@ -0,0 +1,107 @@ +/* + * @progname longlines.ll + * @version 2.0 + * @author Chandler + * @category + * @output Text + * @description + +Find the maximal-length male and female lineages in the database. +Optionally, find the maximal-length lineage through a specified ancestor. + +longlines + +Version 1 - 1994 May 19 - John F. Chandler +Version 2 - 2000 May 4 - John F. Chandler + +This program works only with LifeLines. + +*/ +global(len) /* current lineage length */ +global(lenmax) /* longest lineage found */ +global(ends) /* keys of last persons */ +global(linsex) /* sex of lineage desired */ + +proc main(){ +getindi(indi,"Enter specific ancestor, if any, whose longest line you want:") +if(indi) { + "Longest descent from " name(indi) " (" key(indi) ")\n\n" + set(linsex,sex(indi)) + set(len,1) + call getline(indi) + call dumplines() +} else { + "Longest lineages in database\n\n Male" + call getall("M") + call dumplines() + "\n Female" + call getall("F") + call dumplines() +} +} + +/* scan all offspring matching the sex of the input person, and + return the longest lineage(s) from those -- if no matching + offspring, just return the input person as a lineage */ +proc getline(indi) +{ +incr(len) +families(indi,fam,spou,num) { + children(fam,child,numc) { + if(eq(0,strcmp(linsex,sex(child)))) { + set(found,1) + call getline(child) + } + } +} +decr(len) +if(and(not(found),ge(len,lenmax))) { + if(gt(len,lenmax)) {list(ends)} + enqueue(ends,save(key(indi))) + set(lenmax,len) +}} + +proc getall(this_sex) +{ +set(linsex,this_sex) +set(lenmax,0) +print("Starting ", linsex, " ...\n") + +/* find all eligible starting points */ +/* assume that a nameless person doesn't count */ +forindi (indi, num) { + set(skip,"") + if(eq(0,strcmp(linsex,"M"))) {set(par,father(indi))} + else {set(par,mother(indi))} + if(par) {set(skip,name(par))} + if(and(eq(0,strcmp(linsex,sex(indi))),eq(0,strcmp("",skip)))) { + set(len,1) + call getline(indi) + } +}} + +proc dumplines() +{ +/* report results */ +"\n Maximal length " d(lenmax) "\n" +/* dump each lineage, starting with most recent person */ +while(end, dequeue(ends)) { + "\n" + set(count, lenmax) + set(line,indi(end)) + while(line) { + if(eq(count,0)) {" (extension of the requested line...)\n"} + decr(count) + if(eq(0,strcmp(name(line),""))) {"_____"} + name(line) " (" key(line) ")" + if(x, birth(line)) {" b. " year(x)} + if(y, death(line)) { + if(x) {","} + " d. " year(y) + } + "\n" + if(eq(0,strcmp(linsex,"M"))) {set(line,father(line))} + else {set(line,mother(line))} + } + if(lt(count,0)) {" (length " d(sub(lenmax,count)) " with extension)\n"} +}} diff --git a/reports/maritalinfo.ll b/reports/maritalinfo.ll new file mode 100644 index 0000000..2a292ff --- /dev/null +++ b/reports/maritalinfo.ll @@ -0,0 +1,74 @@ +/* +* @progname maritalinfo.ll +* @version 1.0 (2002-11-13) +* @author Perry Rapp +* @category sample +* @output screen +* @description +* +* Simple example of looping through marital (& divorce) info +*/ + +/* get marital & divorce lists, and then display them */ +proc main() { + + getfam(family) + list(marriages) + getmarriages(family, marriages) + if (not(empty(marriages))) { + print("Marital events:", nl()) + forlist (marriages, node, offset) { + if (eq(tag(node), "ENGA")) { + call event_out("Engagement: ", node) + } + if (eq(tag(node), "MARR")) { + call event_out("Marriage: ", node) + } + } + } + list(divorces) + getdivorces(family, divorces) + if (not(empty(divorces))) { + print("Divorce events:", nl()) + forlist (divorces, node, offset) { + if (eq(tag(node), "ANUL")) { + call event_out("Annulment: ", node) + } + if (eq(tag(node), "DIV")) { + call event_out("Divorce: ", node) + } + if (eq(tag(node), "DIVF")) { + call event_out("DivorceFiling: ", node) + } + } + } + +} + +/* send out event info with header, to screen right now */ +proc event_out(hdr, event) { + print(event_string(hdr, event), nl()) +} + +/* make a display string out of an event and a header */ +func event_string(hdr, event) { + set(outstr, concat(hdr, short(event))) + return(outstr) +} + +/* get list of all marital events in family */ +func getmarriages(family, evlist) { + fornodes (root(family), node) { + if (eq(tag(node), "MARR")) { push(evlist, node) } + if (eq(tag(node), "ENGA")) { push(evlist, node) } + } +} + +/* get list of all divorce-style events in family */ +func getdivorces(family, evlist) { + fornodes (root(family), node) { + if (eq(tag(node), "ANUL")) { push(evlist, node) } + if (eq(tag(node), "DIV")) { push(evlist, node) } + if (eq(tag(node), "DIVF")) { push(evlist, node) } + } +} diff --git a/reports/marriages.ll b/reports/marriages.ll new file mode 100644 index 0000000..f5ee953 --- /dev/null +++ b/reports/marriages.ll @@ -0,0 +1,168 @@ +/* + * @progname marriages + * @version 1.0 + * @author Perry Rapp + * @category + * @output Text, 80 cols + * @description + * + * select and produce an a output report of all marriages in + * the database, with date of marriage if known. Sort by either + * spouse, or by date, or by place. + * + * Output is an ASCII file, and may be printed using 80 column format. + * + * Based on previous work by Tom Wetmore and Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * An example of the output may be seen at end of this report. + */ + +proc main () +{ + list(mnu) + enqueue(mnu, "List marriages by husband") + enqueue(mnu, "List marriages by wife") + enqueue(mnu, "List marriages by either spouse") + enqueue(mnu, "List marriages by year") + enqueue(mnu, "List marriages by place") + set(chc, menuchoose(mnu)) + if (eq(chc, 0)) { return(0) } + + set(ct, 0) /* count #records processed */ + set(ctx, 0) /* count module 100 for status feedback */ + + set(rptinterval, 100) /* report progress every this many records */ + + /* for choices 1-3, populate indiset of married individuals */ + indiset(results) + + /* for choices 4-5, populate list of families */ + list(marriages) + list(infos) + + if (gt(chc, 3)) { + /* Record all marriages (along with date or place) */ + forfam(fam, n) { + enqueue(marriages, fam) + if (eq(chc, 4)) { + enqueue(infos, year(date(marriage(fam)))) + } else { + enqueue(infos, place(marriage(fam))) + } + /* display feedback on screen */ + incr(ct) + incr(ctx) + if (eq(ctx, rptinterval)) { + print(d(ct), "F ") + set(ctx, 0) + } + } + } else { + /* Record all married persons, of appropriate gender */ + forindi(indi, n) { + if (gt(nspouses(indi), 0)) { + if (or(and(eq(chc, 1), male(indi)), + and(eq(chc, 2), female(indi)), + eq(chc, 3))) { + addtoset(results, indi, 0) + } + } + /* display feedback on screen */ + incr(ct) + incr(ctx) + if (eq(ctx, rptinterval)) { + print(d(ct), "I ") + set(ctx, 0) + } + } + } + print(nl()) + set(count, length(results)) + if (gt(chc, 3)) { set(count, length(marriages)) } + print("Sorting ", d(count), " results") + print(nl()) + if (gt(chc, 3)) { + sort(marriages, infos) + } else { + namesort(results) + } + print("ending sort") + print(nl()) + col(1) "Person" + if (eq(chc, 5)) { + col(30) "Place" + } else { + col(30) "Date" + } + col(50) "Spouse" + col(1) + "-----------------------------------------" + "-------------------------------------" + if (eq(chc, 5)) { + forlist(marriages, fam, n) { + call display(husband(fam), place(marriage(fam)), wife(fam)) + } + } elsif (eq(chc, 4)) { + forlist(marriages, fam, n) { + call display(husband(fam), date(marriage(fam)), wife(fam)) + } + } else { + forindiset(results,husb,val,n) { + set(first, 1) + spouses(husb,wife,famv,m) { + if (first) { + call display(husb, date(marriage(famv)), wife) + set(first, 0) + } else { + call display(0, date(marriage(famv)), wife) + } + } + /* display feedback on screen */ + incr(ct) + incr(ctx) + if (eq(ctx, rptinterval)) { + print(d(ct), "I ") + set(ctx, 0) + } + } + } + nl() + print(nl()) +} + +/* + Output one result row +*/ +proc display(husb, info, wife) +{ + if (husb) + { + col(1) fullname(husb, 1,0,29) + } + col(30) trim(info, 20) + if (wife) + { + col(50) fullname(wife, 1,0,29) + } +} + +/* Sample output of this report. + +Person Date Spouse +------------------------------------------------------------------------------ +BARTH, Johann Ludwig ____, Hanna +BIRD, Jacob ____, Mrs. +BIRD, John SHRADER, Elizabeth +BOWERS, Anderson ABT 1828 COWAN, Lurina Viney "Vina" +BOWERS, James ____, Martha +BRADSHAW, John F. CLENDENIN, Agnes "Annie" +CANTER, Henry B. ____, Polina +CANTER, James H. 20 APR 1867 WHITEHORN, Martha Marie +CASON, David ca 1790 ____, Mary + +*/ + +/* End of Report */ + diff --git a/reports/marriages1.ll b/reports/marriages1.ll new file mode 100644 index 0000000..79b0c41 --- /dev/null +++ b/reports/marriages1.ll @@ -0,0 +1,81 @@ +/* + * @progname marriages1.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output Text, 80 cols + * @description + * + * select and produce an a output report of all marriages in + * the database, with date of marriage if known. + * + * marriages1 + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * With modifications by: Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * + * select and produce an a output report of all marriages in + * the database, with date of marriage if known. + * + * Output is an ASCII file, and may be printed using 80 column format. + * + * An example of the output may be seen at end of this report. + */ + +proc main () + { + indiset(idx) + forindi(indi, n) { + if (and(male(indi),gt(nspouses(indi),0))) { + addtoset(idx,indi,0) + print("y") + } else { + print("n") + } + } + print(nl()) + print("beginning sort") + print(nl()) + namesort(idx) + print("ending sort") + print(nl()) + col(1) "Male Person" + col(30) "Date" + col(50) "Female Person" + col(1) + "-----------------------------------------" + "-------------------------------------" + forindiset(idx,husb,val,n) { + col(1) fullname(husb, 1,0,29) + spouses(husb,wife,famv,m) { + col(30) trim(date(marriage(famv)), 20) + col(50) fullname(wife, 1,0,29) + } + print(".") + } + nl() + print(nl()) +} + +/* Sample output of this report. + +Male Person Date Female Person +------------------------------------------------------------------------------ +BARTH, Johann Ludwig ____, Hanna +BIRD, Jacob ____, Mrs. +BIRD, John SHRADER, Elizabeth +BOWERS, Anderson ABT 1828 COWAN, Lurina Viney "Vina" +BOWERS, James ____, Martha +BRADSHAW, John F. CLENDENIN, Agnes "Annie" +CANTER, Henry B. ____, Polina +CANTER, James H. 20 APR 1867 WHITEHORN, Martha Marie +CASON, David ca 1790 ____, Mary + +*/ + +/* End of Report */ + diff --git a/reports/menu.ll b/reports/menu.ll new file mode 100644 index 0000000..e93d10a --- /dev/null +++ b/reports/menu.ll @@ -0,0 +1,47 @@ +/* + * @progname menu.ll + * @version 1.0 + * @author ? + * @category + * @output GUI + * @description + + Menu driven shell for LifeLines report programs + +menu.ll - Menu driven shell for LifeLines report programs + +To use this shell, rename "proc main()" in a report to "proc ()", +then add the file/description/call names in three places here. + +The menu loops until the first item is selected so pressing "q" +from LifeLines user interface does not result in quitting. + +*/ + +include("eol.li") +include("longline.li") +include("stat9.li") + +/* more file inclusions go here */ + +proc main() { +list(mnu) +enqueue(mnu, " >> EXIT to LifeLines MAIN MENU << ") +enqueue(mnu, "eol2.ll - End of Line Ancestors - Tom Wetmore, John Chandler") +enqueue(mnu, "longline.ll - Longest Lines - John Chandler") +enqueue(mnu, "stat9.ll - Statistics - Jim Eggert") + +/* more report descriptions go here */ + +set(xitem, 0) +while (ne(1, xitem)) { +set(xitem, menuchoose(mnu, "Choose the program to run")) + +if (eq(xitem, 2)) { call eol() } +elsif (eq(xitem, 3)) { call longline() } +elsif (eq(xitem, 4)) { call stat9() } + +/* more procedure calls go here */ + +} +} diff --git a/reports/name2html.ll b/reports/name2html.ll new file mode 100644 index 0000000..86ab558 --- /dev/null +++ b/reports/name2html.ll @@ -0,0 +1,402 @@ +/* + * @progname name2html.ll + * @version 1.5 + * @author Scott McGee + * @category + * @output HTML + * @description + +Converts the selected indi record to an HTML file. + +This program is based primarily on my version of indi2html with additions +(based on suggestions by Tom Westmore) to handle name lookup and possible +multiple matches. + +@(#)name2html.ll 1.5 10/6/95 +*/ + +include("cgi_html.li") +include("tools.li") + +global(found) /* external file to inline found */ +global(path) /* path to external file to inline */ +global(LDS) /* report LDS ordinaces (1=yes 0=no) */ + +proc main (){ + call set_cgi_html_globals() + set(is_indi_html, 1) + + set(LDS, 1) + getindiset(iset, "What name to you want an HTML file for?") + if (eq(1, lengthset(iset))) { + forindiset(iset, i, v, n) { + set(indi, i) + } + call genhtml(indi) + } elsif (ne(0, lengthset(iset))) { + call list_to_html(iset) + } + else { + "\n" + "No Match\n" + "\n" + if(use_image){ + "\"\"

    \n" + } + "

    No Match

    \n" + "Sorry, no match was found for the requested name!\n" + "\n" + } +} + +proc genhtml (i){ + html_head(i) + + call afn(i) + if (e, birth(i)) { + "Born : " long(e) "
    \n" + } + if (e, baptism(i)) { + "Baptised : " long(e) "
    \n" + } + elsif (e, bapt(i)) { + "Baptised : " long(e) "
    \n" + } + if (e, death(i)) { + "Died : " long(e) "
    \n" + } + if (e, burial(i)) { + "Buried : " long(e) "
    \n" + } + if(LDS) { + /* LDS ordinances */ + set(started, 0) + fornodes(inode(i), node) { + if (eq(0, strcmp(tag(node), "BAPL"))) { + if(not(started)) { + set(started, 1) + "
    LDS Ordinances: B " + } + } + /* determine if endowed */ + if (eq(0, strcmp(tag(node), "ENDL"))) { + if(not(started)) { + set(started, 1) + "
    LDS Ordinances: " + } + "E " + } + } + /* determine if sealed to parents */ + set(fam, parents(i)) + if(fam){ + set(val, concat("@", key(i), "@")) + fornodes(fnode(fam), node) { + if (eq(0, strcmp(tag(node), "CHIL"))) { + if (eq(0, strcmp(value(node), val))) { + fornodes(node, next) { + if (eq(0, strcmp(tag(next), "SLGC"))) { + if(not(started)) { + set(started, 1) + "
    LDS Ordinances: " + } + "SC " + } + } + } + } + } + } + if(started){ + "
    \n" + } + } + call othernames(i) + call print_html(i) + set(hasChildren, 0) + if(nfamilies(i)){ + families(i, f, s, n){ + if(nchildren(f)){ + set(hasChildren, 1) + } + } + } + "
    \n" + if (p, father(i)) { + "" "Father : \n" + href(p, "Lookup") + do_info(p) + "
    \n" + } + if (p, mother(i)) { + "" "Mother : " + href(p, "Lookup") + do_info(p) + "
    \n" + } + families(i, f, s, n) { + "

    " "Spouse" + if (gt(nfamilies(i), 1)){ + " " + d(n) + } + " : \n" + if (s) { /* family has a spouse */ + href(s, "Lookup") + do_info(s) + "
    \n" + }else{ + "(unknown)
    " + } + if (e, marriage(f)) {"Married " long(e) "
    \n"} + if (e, divorced(f)) {"Divorced " long(e) "
    \n"} + if(LDS) { + /* determine if sealed to parents */ + fornodes(fnode(f), node) { + if (eq(0, strcmp(tag(node), "SLGS"))) { + "LDS Ordinances: SS
    " + } + } + } + if(nchildren(f)){ + "Children :

      \n" + children(f, c, nn) { + "
    1. " + href(c, "Lookup") + do_info(c) + } + "
    \n" + }else{ + "(no children)
    \n" + } + } + call print_notes(i) + "
    \n" + if(parents(i)){ + "[" + "Pedigree Chart]
    \n" + } + if(hasChildren){ + "[" + "Descendant Chart]
    \n" + } + call do_tail(i) +} + +proc print_notes(indi){ + set(first, 1) + traverse(inode(indi), node, l) { + if (not(strcmp("NOTE", tag(node)))) { + if(first) { + "Notes :
    \n" + set(first, 0) + } + "

    " + call show_path(node) + value(node) + "\n" + fornodes(node, next) { + value(next) + "\n" + } + "

    \n" + } + } +} + +proc show_path (node){ + list(path) + while (node) { + push(path, tag(node)) + set(node, parent(node)) + } + "(" + while (s, pop(path)) { + if(not(strcmp(lower(s), "indi"))){ + "Individual " + }elsif(not(strcmp(lower(s), "fam"))){ + "Family " + }elsif(not(strcmp(lower(s), "famc"))){ + "family " + }elsif(not(strcmp(lower(s), "fams"))){ + "family " + }elsif(not(strcmp(lower(s), "note"))){ + "note" + }elsif(not(strcmp(lower(s), "birt"))){ + "birth " + }elsif(not(strcmp(lower(s), "deat"))){ + "death " + }elsif(not(strcmp(lower(s), "buri"))){ + "burial " + }elsif(not(strcmp(lower(s), "plac"))){ + "place " + }else{ + lower(s) + " " + } + } + ") " +} + +proc list_to_html (iset) { + "\n" + "Multiple Matches\n" + "\n" + "

    Multiple Matches

    \n" + "More than one person in the database matched the name search. They are:\n" + "
    \n" + forindiset(iset, i, v, n) { + href(i, "Lookup") + do_info(i) + "
    \n" + } + call do_tail(0) +} + +func do_info(me){ + if(not(me)){ + return("") + }else{ + set(out, " -") + if (evt, birth(me)) { + set(out, concat(out, " born ", short(evt))) + } + else { + if (evt, baptism(me)) { + set(out, concat(out, " baptised ", short(evt))) + } + else { + if (evt, bapt(me)) { + set(out, concat(out, " baptised ", short(evt))) + } + } + } + if (evt, death(me)) { + set(out, concat(out, " died ", short(evt))) + } + return(out) + } +} + +proc othernames(indi){ + if(indi){ + set(count, 0) + fornodes(inode(indi), subnode){ + if(eqstr(tag(subnode), "NAME")){ + incr(count) + if(eq(count, 2)){ + "
    Other Names: \n
      " + "
    • " + call nameval(subnode) + "
      • " + }elsif(gt(count, 2)){ + "
    • " + call nameval(subnode) + "
      • \n" + } + } + } + if(gt(count, 1)){ + "
    \n" + } + } +} + +proc nameval(namenode){ + list(np) + extractnames(namenode, np, nc, sc) + forlist(np, v, i){ + v + " " + } +} + +proc afn(indi){ + if(indi){ + fornodes(inode(indi), subnode){ + if(eqstr(tag(subnode), "AFN")){ + "AFN " + value(subnode) + "

    \n" + } + } + } +} + +func divorced(fam) { + fornodes(fnode(fam), node) { + if (eq(0, strcmp(tag(node), "DIV"))) { + return(node) + } + } + return(0) +} + +proc print_html(indi){ + fornodes(inode(indi), node) { + if (not(strcmp("REPORT", tag(node)))) { + set(m, child(node)) + if (not(strcmp("TYPE", tag(m)))) { + if (or(not(strcmp("HTML", value(m))), + not(strcmp("HTML-CGI", value(m))))) { + "
    \n" + fornodes(m, o) { + if (not(strcmp("DATA", tag(o)))) { + value(o) + "\n" + } + } + } + } + } + } +} + + +func html_head(i){ + "\n" + "" key(i) ": " name(i,0) "\n\n" "\n" + if(use_image){ + "\"\"

    \n" + } + "

    " + set(vn,givens(i)) + set(vn1,save(vn)) + givens(i) + " " + set(nn,surname(i)) + set(nn1,save(nn)) + nn1 + "

    \n" + set(path, get_picture(i)) + if (found) { + "\"\"

    \n" + } +} diff --git a/reports/namefreq.ll b/reports/namefreq.ll new file mode 100644 index 0000000..121a586 --- /dev/null +++ b/reports/namefreq.ll @@ -0,0 +1,135 @@ +/* + * @progname namefreq.ll + * @version 3.0 + * @author Chandler + * @category + * @output Text + * @description + +This report counts occurrences of all first (given) names in the +database. Individuals with only surnames are not counted. If the +surname is listed first, the next word is taken as the given name. + +namefreq + +Tabulate frequency of first names in database. + +Version 1 - 1993 Jun 16 - John F. Chandler +Version 2 - 1993 Jun 18 (sort output by frequency) +Version 3 - 1995 Mar 8 (requires LL 3.0 or higher) + (Uses Jim Eggert's Quicksort routine) + +The output file is normally sorted in order of decreasing frequency, +but the sort order can be altered by changing func "compare", e.g., +comment out the existing "set" and uncomment the one for alphabetical +order. + +This program works only with LifeLines. + +*/ +global(name_counts) /* used by comparison in sorting by frequency */ + +/* Comparison function for sorting. Same convention as strcmp. */ +func compare(astring,bstring) { +/* alphabetical: + return(strcmp(astring,bstring)) */ +/* decreasing frequency: */ + if(ret,sub(lookup(name_counts,bstring),lookup(name_counts,astring))){ + return(ret) + } + return(strcmp(astring,bstring)) +} + +/* + quicksort: Sort an input list by generating a permuted index list + Input: alist - list to be sorted + Output: ilist - list of index pointers into "alist" in sorted order + Needed: compare- external function of two arguments to return -1,0,+1 + according to relative order of the two arguments +*/ +proc quicksort(alist,ilist) { + set(len,length(alist)) + set(index,len) + while(index) { + setel(ilist,index,index) + decr(index) + } + call qsort(alist,ilist,1,len) +} + +/* recursive core of quicksort */ +proc qsort(alist,ilist,left,right) { + if(pcur,getpivot(alist,ilist,left,right)) { + set(pivot,getel(alist,getel(ilist,pcur))) + set(mid,partition(alist,ilist,left,right,pivot)) + call qsort(alist,ilist,left,sub(mid,1)) + call qsort(alist,ilist,mid,right) + } +} + +/* partition around pivot */ +func partition(alist,ilist,left,right,pivot) { + while(1) { + set(tmp,getel(ilist,left)) + setel(ilist,left,getel(ilist,right)) + setel(ilist,right,tmp) + while(lt(compare(getel(alist,getel(ilist,left)),pivot),0)) { + incr(left) + } + while(ge(compare(getel(alist,getel(ilist,right)),pivot),0)) { + decr(right) + } + if(gt(left,right)) { break() } + } + return(left) +} + +/* choose pivot */ +func getpivot(alist,ilist,left,right) { + set(pivot,getel(alist,getel(ilist,left))) + set(left0,left) + incr(left) + while(le(left,right)) { + set(rel,compare(getel(alist,getel(ilist,left)),pivot)) + if (gt(rel,0)) { return(left) } + if (lt(rel,0)) { return(left0) } + incr(left) + } + return(0) +} + +proc main () +{ + list(namelist) + table(name_counts) + list(names) + list(ilist) + + forindi (indi, num) { + if(not(mod(num,20))) {print(".")} + extractnames(inode(indi), namelist, ncomp, sindx) + set(gindx,1) if(eq(sindx,1)) { set(gindx,2) } + set(fname, save(getel(namelist, gindx))) + if( or( gt(sindx,1), gt(ncomp,sindx))) { + if(nmatch, lookup(name_counts, fname)) { + set(nmatch, add(nmatch, 1)) + } + else { + enqueue(names, fname) + set(nmatch, 1) + } + insert(name_counts, fname, nmatch) + } + } + "Frequency of given names (first only) in the database\n\n" + "Name Occurrences\n\n" + + call quicksort(names,ilist) + forlist(ilist, index, num) { + set(fname,getel(names,index)) + fname + set(nmatch, lookup(name_counts, fname)) + col(sub(25, strlen(d(nmatch)))) + d(nmatch) "\n" + } +} diff --git a/reports/names_freq.ll b/reports/names_freq.ll new file mode 100644 index 0000000..b467b35 --- /dev/null +++ b/reports/names_freq.ll @@ -0,0 +1,237 @@ +/* + * @progname names_freq.ll + * @version 3.0 + * @author Eggert + * @category + * @output Text + * @description + +Tabulate frequency of names in database. Like namefreq (by John +Chandler), but it computes frequencies for the first five given names, +the surname, and the first two post-surnames. + +The output can be sorted by frequency or by alphabet, or not at all. + +names_freq - a LifeLines names frequency calculation program + by Jim Eggert (EggertJ@crosswinds.net) + Version 1, 8 November 1993 (initial release) + listsort code by John Chandler (JCHBN@CUVMB.CC.COLUMBIA.EDU) + Version 2, 10 April 1995 changed listsort to quicksort + Version 3, 15 January 2000 quicksort bug fix +*/ + +global(indices) /* table for indexing into the various lists */ +global(top_index) /* number of elements in table and lists */ +global(sort_type) /* 0=none, 1=frequency, 2=alphabet */ +global(names) /* list of all names */ +global(givens1) /* list of counts of names in each position */ +global(givens2) +global(givens3) +global(givens4) +global(givens5) +global(surs) +global(posts1) +global(posts2) +global(totals) + +func compare(a,b) { + if (eq(sort_type,1)) { +/* decreasing frequency: */ + if (lt(a,b)) { return(1) } + if (eq(a,b)) { return(0) } + return(neg(1)) + } + else { + return(strcmp(a,b)) + } +} + +/* + quicksort: Sort an input list by generating a permuted index list + Input: alist - list to be sorted + Output: ilist - list of index pointers into "alist" in sorted order + Needed: compare- external function of two arguments to return -1,0,+1 + according to relative order of the two arguments +*/ +proc quicksort(alist,ilist) { + set(index,1) + set(len,length(alist)) + while(le(index,len)) { + setel(ilist,index,index) + incr(index) + } + if (ge(len,2)) { call qsort(alist,ilist,1,len) } +} + +/* recursive core of quicksort */ +proc qsort(alist,ilist,left,right) { + if(pcur,getpivot(alist,ilist,left,right)) { + set(pivot,getel(alist,getel(ilist,pcur))) + set(mid,partition(alist,ilist,left,right,pivot)) + call qsort(alist,ilist,left,sub(mid,1)) + call qsort(alist,ilist,mid,right) + } +} + +/* partition around pivot */ +func partition(alist,ilist,left,right,pivot) { + while(1) { + set(tmp,getel(ilist,left)) + setel(ilist,left,getel(ilist,right)) + setel(ilist,right,tmp) + while(lt(compare(getel(alist,getel(ilist,left)),pivot),0)) { + incr(left) + } + while(ge(compare(getel(alist,getel(ilist,right)),pivot),0)) { + decr(right) + } + if(gt(left,right)) { break() } + } + return(left) +} + +/* choose pivot */ +func getpivot(alist,ilist,left,right) { + set(pivot,getel(alist,getel(ilist,left))) + set(left0,left) + incr(left) + while(le(left,right)) { + set(next,getel(alist,getel(ilist,left))) + set(rel,compare(next,pivot)) + if (gt(rel,0)) { return(left) } + if (lt(rel,0)) { return(left0) } + incr(left) + } + return(0) +} + + +proc count_name(name,thiscount) { + if(index, lookup(indices, name)) { + setel(thiscount,index,add(getel(thiscount,index),1)) + } else { +/* print("(") print(name) print(")") */ + incr(top_index) + set(sname,save(name)) + enqueue(names,sname) + insert(indices,sname,top_index) + enqueue(givens1,0) + enqueue(givens2,0) + enqueue(givens3,0) + enqueue(givens4,0) + enqueue(givens5,0) + enqueue(surs,0) + enqueue(posts1,0) + enqueue(posts2,0) + enqueue(totals,0) + setel(thiscount,top_index,add(getel(thiscount,top_index),1)) + } +} + +proc main () +{ + table(indices) + list(namelist) + list(names) + list(givens1) + list(givens2) + list(givens3) + list(givens4) + list(givens5) + list(surs) + list(posts1) + list(posts2) + list(totals) + list(ilist) + + set(top_index,0) + set(next_num,0) + + print("Counting names...") + forindi (indi, num) { + extractnames(inode(indi), namelist, ncomp, sindx) + forlist(namelist,name,ni) { + call count_name(name,totals) + } + if (and(ge(ncomp,1),or(eq(sindx,0),gt(sindx,1)))) { + call count_name(getel(namelist,1),givens1) + } + if (and(ge(ncomp,2),or(eq(sindx,0),gt(sindx,2)))) { + call count_name(getel(namelist,2),givens2) + } + if (and(ge(ncomp,3),or(eq(sindx,0),gt(sindx,3)))) { + call count_name(getel(namelist,3),givens3) + } + if (and(ge(ncomp,4),or(eq(sindx,0),gt(sindx,4)))) { + call count_name(getel(namelist,4),givens4) + } + if (and(ge(ncomp,5),or(eq(sindx,0),gt(sindx,5)))) { + call count_name(getel(namelist,5),givens5) + } + if (sindx) { + call count_name(getel(namelist,sindx),surs) + } + if (gt(ncomp,sindx)) { + call count_name(getel(namelist,add(sindx,1)),posts1) + } + if (gt(ncomp,add(sindx,1))) { + call count_name(getel(namelist,add(sindx,2)),posts2) + } + if (ge(num,next_num)) { + print(d(num)) print(" ") + set(next_num,add(next_num,100)) + } + } + print(d(num)) + + getintmsg(sort_type,"Sort method (0=no sort, 1=frequency, 2=alphabet)") + if (sort_type) { + print("\nSorting ") print(d(top_index)) print(" names...") + } + if (eq(sort_type,1)) { + call quicksort(totals,ilist) + } + elsif (eq(sort_type,2)) { + call quicksort(names,ilist) + } + else { + forlist(names,name,index) { enqueue(ilist,index) } + } + + print("\nWriting results...") + + "______Frequency of names in the database______\n\n" +"Name 1st 2nd 3rd 4th 5th sur post1 post2 total" +"\n\n" + forlist(ilist, index, num) { + getel(names,index) + + set(nmatch, getel(givens1,index)) + col(sub(30, strlen(d(nmatch)))) + d(nmatch) + set(nmatch, getel(givens2,index)) + col(sub(36, strlen(d(nmatch)))) + d(nmatch) + set(nmatch, getel(givens3,index)) + col(sub(42, strlen(d(nmatch)))) + d(nmatch) + set(nmatch, getel(givens4,index)) + col(sub(48, strlen(d(nmatch)))) + d(nmatch) + set(nmatch, getel(givens5,index)) + col(sub(54, strlen(d(nmatch)))) + d(nmatch) + set(nmatch, getel(surs,index)) + col(sub(60, strlen(d(nmatch)))) + d(nmatch) + set(nmatch, getel(posts1,index)) + col(sub(66, strlen(d(nmatch)))) + d(nmatch) + set(nmatch, getel(posts2,index)) + col(sub(72, strlen(d(nmatch)))) + d(nmatch) + set(nmatch, getel(totals,index)) + col(sub(78, strlen(d(nmatch)))) + d(nmatch) "\n" + } +} diff --git a/reports/namesformat1.ll b/reports/namesformat1.ll new file mode 100644 index 0000000..aefaa29 --- /dev/null +++ b/reports/namesformat1.ll @@ -0,0 +1,59 @@ +/* + * @progname namesformat1.ll + * @version 1.0 + * @author Manis + * @category + * @output Text + * @description + * + * This program produces a report of how the names format may be printed + * using the LifeLines Report Generator. + * + * namesformat1 + * + * Code by Cliff Manis, cmanis@csoftec.csf.com + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Cliff Manis in 1991 + * + * It will produce a report of how the names format may be printed + * using the LifeLines Report Generator. + * + * It is designed for 10 or 12 pitch, HP laserjet III, or any + * other printer. + * + * Output is an ASCII file. + * + * An example of the output may be seen at end of this report. + * + */ + +proc main () +{ + set (nl,nl()) + getindi(indi) + fullname(indi,0,0,30) nl + fullname(indi,1,0,30) nl + fullname(indi,0,1,30) nl + fullname(indi,1,1,30) nl + fullname(indi,0,0,12) nl + fullname(indi,1,0,12) nl + fullname(indi,0,1,12) nl + fullname(indi,1,1,12) nl +} + +/* Sample of report output + +Manis, Alda Clifford +MANIS, Alda Clifford +Alda Clifford Manis +Alda Clifford MANIS +Manis, A C +MANIS, A C +Alda C Manis +Alda C MANIS +* / + +/* End of Report */ + diff --git a/reports/net-ped.ll b/reports/net-ped.ll new file mode 100644 index 0000000..478a3ac --- /dev/null +++ b/reports/net-ped.ll @@ -0,0 +1,242 @@ +/* + * @progname net-ped.ll + * @version 2.1 + * @author Rafal T. Prinke + * @category + * @output Netscape HTML + * @description + + This program generates a set of files covering all known ancestors + with hypertextual links from the top and bottom persons for + easy on-line browsing using Netscape. + + The amount and format of data can be edited in the "vitals" procedure + and "mylong" function. + + Net-Ped -- Pedigree in Netscape HTML table -- bottom to top + Rafal T. Prinke + v.1 -- 25 JUN 1996 - one file/tafel + v.2 -- 25 JUN 1996 (later at night than v.1) + - multiple files/tafels for all ancestors + v.2.1 -- 28 JUN 1996 + - changed table holding last filename to list + - no files for top persons without a parent + - cross-links for related ancestors + - nicer layout + v.2.2 - misc cleanup - tighten checking for non-existent persons + - make html slightly more readable -- by Stephen Dum. + + "proc vitals" code stolen from Tom Wetmore's "ahnentafel" 1995 + output uses some Polish specific abbreviations +*/ + +global(mindi) +global(toplist) +global(fillist) +global(t) +global(a) +global(lastfile) +global(onelist) +global(all) +global(mdupli) +global(fdupli) + +proc main() +{ +list(toplist) +list(fillist) +list(onelist) +table(all) +table(mdupli) +table(fdupli) + +getindimsg(mindi, "Whose Ahnentafel do you want?") +enqueue(toplist, mindi) +set(t,1) +set(t2,concat("t",d(t),".html")) +enqueue(fillist, t2) +set(t,add(t,1)) + +while(indi, dequeue(toplist)) { + set(nf,dequeue(fillist)) + print("file: ") print(nf) print("\n") + newfile(nf,0) + call tafel(indi) + } +} + +proc tafel(indi) +{ +table(quart) +insert(quart,"1",indi) +set(a,1) +while(lt(a,16)) { + if(person,lookup(quart,d(a))) { + if (par,father(person)) { + set(before, lookup(all, key(par))) + if (before) { + insert(fdupli, key(person),1) + } else { + insert(all, key(par), outfile()) + insert(quart,d(mul(a,2)),par) + } + } + if (par,mother(person)) { + set(before, lookup(all, key(par))) + if (before) { + insert(mdupli, key(person),1) + } else { + insert(all, key(par), outfile()) + insert(quart,d(add(1,mul(a,2))),par) + } + } + } + set(a,add(a,1)) + } + +"\n\n\n" +set(a,16) +"" +while(lt(a,32)) { + if (lookup(quart,d(a))) { +if (or( father(lookup(quart,d(a))), mother(lookup(quart,d(a))) )) { + set(t2,concat("t",d(t),".html")) + "\n" + enqueue(toplist,lookup(quart,d(a))) + enqueue(onelist,outfile()) + set(t,add(t,1)) + enqueue(fillist, t2) +} else { + "\n" +} + + + + } else { "\n" } + set(a,add(a,1)) + } "\n" +set(a,8) +"" +while(lt(a,16)) { + "\n" + set(a,add(a,1)) + } "\n" +set(a,4) +"" +while(lt(a,8)) { + "\n" + set(a,add(a,1)) + } "\n" +set(a,2) +"" +while(lt(a,4)) { + "\n" + set(a,add(a,1)) + } "\n" + +if(nestr(key(lookup(quart,d(1))),key(mindi))) { + "\n\n" +} else { + "\n\n" +} + + +"
    " + "" d(a) ".

    " + "" + call vitals(lookup(quart,d(a))) nl() "

    		" + "" d(a) ".

    " + call vitals(lookup(quart,d(a))) nl() "

    		" d(a) ".
    " + "" d(a) ".

    " + call dup(lookup(quart,d(a))) + call vitals(lookup(quart,d(a))) nl() "

    " + "" d(a) ".

    " + call dup(lookup(quart,d(a))) + call vitals(lookup(quart,d(a))) nl() "

    " + "" d(a) ".

    " + call dup(lookup(quart,d(a))) + call vitals(lookup(quart,d(a))) nl() "

    " + "" d(1) ".

    " + call dup(lookup(quart,d(1))) + call vitals(lookup(quart,d(1))) nl() + "

    BACK
    " + "" d(1) ".

    " + call vitals(lookup(quart,d(1))) nl() "

    \n\n\n" + +} + +proc vitals(persn) { + set(e,marriage(fam)) + if (and(e,long(e))) { mylong(e) } + "" name(persn,0) "
    \n" + + set(e,birth(persn)) + if(and(e,long(e))) { "* " mylong(e) "
    \n" } + set(e,death(persn)) + if(and(e,long(e))) { "+ " mylong(e) "
    \n" } + "" + set(srd,0) + if (gt(nspouses(persn),1)) { + spouses(persn,ind2,fm,nsp) { + set(dad,father(ind2)) + set(mom,mother(ind2)) + if (srd) { "; " } + " x (" d(nsp) ") " + set (es,marriage(fm)) + if (and(es,long(es))) { mylong(es) " " } + name(ind2,0) + + if (or(dad,mom)) { + ", " + if (male(ind2)) { "s. " } + elsif (female(ind2)) { "c. " } + else { "dz. " } + } + + if (dad) { + name(dad,0) + fornodes(inode(dad), ok) { + if (eqstr(tag(ok),"OCCU")) { ", " value(ok) } + } + } + else { name(mom,0) } + + set(srd,1) + } } + if (eq(nspouses(persn),1)) { + if (male(persn)) { + spouses(persn,ind2,fm,nsp) { + set (es,marriage(fm)) + if (and(es,long(es))) { "x " mylong(es) } + } } + } +"" +} + +proc dup(persn) { +if (persn) { +if(lookup(fdupli,key(persn))) { + set(yest,lookup(all,key(father(persn)))) + "FATHER: " name(father(persn)) "
    \n" + } + +if(lookup(mdupli,key(persn))) { + set (yest,lookup(all,key(mother(persn)))) + "MOTHER: " name(mother(persn)) "
    \n" + } +} +} + +func mylong(ev) { + set(nic,0) + if (ne(index(date(ev),"/",1),0)) { date(ev) set(nic,1) } + if (ne(index(date(ev),"BEF",1),0)) { + "p. " substring(date(ev),5,strlen(date(ev))) set(nic,1) } + if (ne(index(date(ev),"AFT",1),0)) { + "po " substring(date(ev),5,strlen(date(ev))) set(nic,1) } + if (ne(index(date(ev),"ABT",1),0)) { + "ok. " substring(date(ev),5,strlen(date(ev))) set(nic,1) } + if (eq(nic,0)) { date(ev) } + if (place(ev)) { ", " place(ev) } +} diff --git a/reports/newuser.ll b/reports/newuser.ll new file mode 100644 index 0000000..2e2020d --- /dev/null +++ b/reports/newuser.ll @@ -0,0 +1,49 @@ +/* + * @progname newuser + * @version 1.0 (2005/10/19) + * @author Lawrence M. Hamilton, Jr. + + * @category test + + * @output Text + + * @description Sample report for a new user. + +Sample report to print out basic information about the current database +and version of Lifelines, plus the user properties. Designed with new +LifeLines users in mind. + +This is useful as a simple example of what can be done with LifeLines' +Report Language, and as a building block for new report authors. It +also is good for testing a new LifeLines installation to verify the +values in the LifeLines configuration file. + +See the ll-reportmanual in the Documentation Folder and review the +other reports in the Programs directory for examples and ideas. + +*/ + +proc main() +{ + "Database and Version are controlled by the LifeLines program" nl() + "and are not dependent on the configuration file." nl()nl() + + "If one of the other lines is blank, then that value" nl() + "is not set in your LifeLines' configuration file," nl() + "lines.cfg on Windows and .linesrc on *nix." nl()nl() + + "Database: " database() nl() + "Version: " version() nl() + "Name: " getproperty("user.fullname") nl() + "Address: " getproperty("user.address") nl() + "Phone: " getproperty("user.phone") nl() + "Email: " getproperty("user.email") nl() + "Web: " getproperty("user.url") nl()nl() + + "The values to check in the configuration file are:" nl()nl() + "user.fullname=" nl() + "user.address=" nl() + "user.phone=" nl() + "user.email=" nl() + "user.phone=" +} diff --git a/reports/nonpatronymics.ll b/reports/nonpatronymics.ll new file mode 100644 index 0000000..7e20228 --- /dev/null +++ b/reports/nonpatronymics.ll @@ -0,0 +1,57 @@ +/* + * @progname nonpatronymics.ll + * @version 1.0 + * @author Eggert + * @category + * @output Text + * @description + * + * Find all cases of nonpatronymic inheritances in the database. + * If the child's surname is not identical to the father's surname, + * print both out. If the two surnames have different soundex + * codes, undent the printout. Print statistics at the end. + * + * nonpatronymics + * + * Code by Jim Eggert, eggertj@ll.mit.edu + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Jim Eggert, in 1992. + * + * Output is an ASCII file. + */ + +proc main () +{ + set(n,0) + set(ns,0) + set(header,0) + forindi(indi,num1) { + if (fath,father(indi)) { + if (ne(0,strcmp(surname(indi),surname(fath)))) { + if (eq(header,0)) { + "Dissimilar surnames" nl() + " Similar surnames" nl() + set(header,1) + } + if (eq(strcmp(save(soundex(indi)), + save(soundex(fath))),0)) { + " " + set(ns,add(ns,1)) + } + d(num1) " " name(indi) + " <> " + name(fath) + nl() + set(n,add(n,1)) + } + } + } + nl() d(num1) " individuals scanned." nl() + d(n) " nonpatronymic inheritances found" + if (eq(n,0)) { "." nl() } + else { "," nl() + d(sub(n,ns)) " of which were soundex-dissimilar." nl() + } +} diff --git a/reports/novel/Makefile.am b/reports/novel/Makefile.am new file mode 100644 index 0000000..564d077 --- /dev/null +++ b/reports/novel/Makefile.am @@ -0,0 +1,17 @@ +# This makefile is for the lifelines reports + +AUTOMAKE_OPTIONS = no-dependencies + +# LL_REPORTS is to hold the actual report files +# (included files go in a different target below) +LL_REPORTS = novel.ll + +# OTHER_REPORTS is to hold included files besides actual report files +# (eg, supporting files, graphics, included files) +OTHER_REPORTS = novel.intro novel.README + +pkg_REPORTS = $(LL_REPORTS) $(OTHER_REPORTS) + +subreportdir = $(pkgdatadir)/novel +subreport_DATA = $(pkg_REPORTS) +dist_subreport_DATA = $(pkg_REPORTS) diff --git a/reports/novel/novel.README b/reports/novel/novel.README new file mode 100644 index 0000000..5fc22a6 --- /dev/null +++ b/reports/novel/novel.README @@ -0,0 +1,66 @@ +The "novel" report program is designed to produce a book about an individual +from a LifeLines database. Its called "novel" because it produces a book, +but there is already a report program called "book". Purists would argue +that "novel" is a totally inappropriate name, because there should be +absolutely no fiction in a Lifelines database! + +The idea of the program is to select a person from the database and format +the Gedcom into a readable form that can be understood by anybody, giving +all the information about the person and his/her ancestors and descendants. + +There is also an introductory section put on the front of the report in +which you can describe what it contains, and also add things like requests +for information. The idea is to produce a personalised report you can send +off to a relation, telling them lots of information with the hope that they +will come back with a lot more and let you know about any errors. + +It is structured to handle all the common Gedcom tags and print them as an +intelligible sentence, hopefully not sounding too like junk mail from companies +like "Registers Digest". If it finds a Gedcom tag that isn't programmed in, +it still prints the information, but you will need to add a small routine to +make it read sensibly. There are lots of examples there to use as model. + +Add the call to the routine for a new gedcom node type to longvitals(i), and then +modify othernodes(i)/subnode to prevent it being printed with unknown types. + +I use a node of CNAM for a person's common name/alias e.g. + 1 NAME Margaret Winifred Thorpe + 2 CNAM Peggy +Thus in a paragraph about the person she would be first referenced as "Peggy" and +subsequently as "she" or "her". Without the CNAM record we would use "Margaret" +instead of "Peggy". Sometimes references are made to other folks and if this happens +then the next "she" or "her" would be replaced by "Peggy". + +The order of the text in the descriptions does not entirely rely on the Gedcom being +in chronological order, but it does help. It assumes birth, then "EDUC" nodes +detailing schooling, marriage, "OCCU" for occupation, "RESI" for where they lived, +"RETI" for retirement, then any unknown nodes, then death. NOTE and TEXT records can +be shown from any level. + +The output from the program is used as input to nroff/troff/groff using the +mm set of macros. See the examples at the start of the program. This enables +you to have a document which fits your printer as closely as possible to +give the recipient a good impression. + E.g. + nroff -mm filename > filename.out + groff -mgm -Tascii filename >filename.out + groff -mgm filename >filename.ps [PostScript output/Linux] + + +The files required are: + + novel.ll The report program itself. + novel.intro A file containing the introductory text. Use the one + supplied as a model. + novel.head Nroff macros definitions etc. You can modify this if + you know what you are doing, to vary the output + style. + novel.README This file. + +This program is not being actively worked upon, it only gets changed as +needed and when I have time available. Maintaining the UK+Ireland WWW server +takes all my time. At some stage in the future I intend to include support +for the psfig troff extensions, so that scanned images can also be included. + +Phil Stringer - 10 July 1995 - email: P.Stringer@mcc.ac.uk + diff --git a/reports/novel/novel.intro b/reports/novel/novel.intro new file mode 100644 index 0000000..e9002c9 --- /dev/null +++ b/reports/novel/novel.intro @@ -0,0 +1,69 @@ +.HU "Introduction" +I have now come to the stage in my life where I want to know about my ancestors. It must +mean that I'm starting to feel my age! I started collecting basic information +about my relations, such as who they were, when they were born and when they died. As I +have spent my working life with computers I have looked for a way of storing this +information on a computer so that I can then easily print out new copies of it as I learn +more. +.P +I have found that there are many ways of doing this, with means of storing all sorts of +information. As a result, my plans have now changed as I thought it would be a good idea to hold a +sort of mini-biography about each person, so that in the future there is a much more +interesting record about the person. +.P +The information I want to record starts with the basic details, such as birth +marriage and death etc. this is then filled out with information about details of the +school they attended, where they worked and where they lived. On the more personal +side of things information about their hobbies and interests and the important events +in their life. +As far as families and relationships are concerned I think it would be most interesting +to know how people first met. +.P +I therefore hope to build up a picture of what people were +like and what their lifestyle was and at the same time recording information that could +be used by people in future trying to do further research. +An example of this is recording where people lived at various times in their lives so +that when the census information for that period becomes available the place to look is +available. (Census information is kept secret for 100 years, the latest avaailable at +the moment is the 1891 census). +.P +What you are reading is one of the many types of reports that I can produce from my +computer database. This one shows a particular person and his/her descendants and +ancestors. Please remember when you read it that it is only as accurate as the data +thats present. E.g. if its says that a couple had no children, then that does not +categorically mean it, they may have had children that I didn't know about. +.P +Now go ahead and find out about The Stringers and his/her family. If any details are wrong then +please let me know, and if you have any more information I would also be most grateful +to receive it. If you want information about anybody that I have a record of I can +provide it in a variety of forms, just let me know what you want. +.P +If you would like to +add information about your relations so they appear in the reports as well, I would be +happy to do so. However if you don't have the information, then I will tell you where to +go and find it, but I won't be doing the research myself. The only lines that I will be +doing further research on are my personal ancestors. +.P +One development I am planning is to add pictures to this report as I have access to a +digital scanner which converts photographs to a digital form. This should help with +future problems in identifying people from old photographs! If uou are in the report, +a picture will eventually appear, and if it isn't your best likeness you may wish to +provide a better one! +.P +Finally I am VERY interested in getting hold of copies of any birth, marriage, and +death certificates of anybody in the family tree, as they verify the information +here. Any such certifacates lent to me would be photocopied and returned to the owner +as soon as possible. +.P +If you get a copy of this report, and want to get in touch with me, +but haven't got my address, it's: +.DS + Phil Stringer, + 40 Broomfields, + Denton, + Manchester M34 3TH + + Tel: 0161 320 6530 +.DE +.P +.SK diff --git a/reports/novel/novel.ll b/reports/novel/novel.ll new file mode 100644 index 0000000..8c525c2 --- /dev/null +++ b/reports/novel/novel.ll @@ -0,0 +1,844 @@ +/* + * @progname novel.ll + * @version none + * @author Wetmore, Manis, Stringer + * @category + * @output nroff + * @description + * + * It will produce a report of all descendents and ancestors of a person + * in book form. It understands a wide variety of gedcom records and + * tries hard to produce a readable, personalised document. + * + * It prints a sorts listing of names, at the end of the report + * of everyone in the report. All NOTE and CONT lines will + * be printed in the this report. This report will produced + * a paginated output. + * + * This report produces a nroff output, and to produce the + * output, use: nroff -mm filename > filename.out + * groff -mgm -Tascii filename >filename.out + * groff -mgm filename >filename.ps [PostScript output] + * + * The report uses one additional file as input. + * novel.intro is included at the beginning of the report and is where + * you can put a general intoductory text. If you don't + * provide this, it is skipped. A prototype is provided + * along with this report. + * + * Original code by Tom Wetmore, ttw@cbnewsl.att.com + * with modifications by Cliff Manis + * Extensively re-written by Phil Stringer P.Stringer@mcc.ac.uk + * Modified by Stephen Dum to remove external file dependencies and + * to fix a y2k bug. + * + * This report works only with the LifeLines Genealogy program + * + */ + +global(idex) +global(curgen) +global(glist) +global(ilist) +global(in) +global(out) +global(ftab) +global(sid) +global(lvd) +global(enqc) +global(enqp) +global(stack) +global(fac) /* First item after children */ +global(itab) +proc main () { + getindi(indi) + dayformat(2) + monthformat(6) + output_head() + list(ilist) + list(glist) + list(stack) /* To hold function return values */ + table(ftab) + indiset(idex) + table(sid) + table(lvd) + table(itab) + enqueue(ilist,indi) + enqueue(glist,0) + set(curgen,0) + set(out,1) + set(in,2) + ".ds iN " name(indi) nl() + ".PH " qt() "''\\s+3\\fB" name(indi) sp() call fromto(indi) "\\s-3\\fR" qt() nl() + + if (test("f","novel.intro")) { + copyfile("novel.intro") + } + + print ("Descendants") print(nl()) + ".HU " qt() name(indi) " and " pn(indi,3) " descendants" qt() nl() + set(enqc,1) set(enqp,0) + call scan() + + print ("Ancestors") print(nl()) + ".HU " qt() "The ancestors of " name(indi) qt() nl() + set(curgen,0) + set(enqc,0) set(enqp,1) + call enqpar(indi) + call scan() + + call prindex() +} + +proc enqpar(indi) { + set(dad,father(indi)) + if (dad) { + set(g,sub(curgen,1)) + enqueue(ilist,dad) + enqueue(glist,g) + insert(sid,key(dad),in) + set(in,add(in,1)) + } + set(mom,mother(indi)) + if (mom) { + set(g,sub(curgen,1)) + enqueue(ilist,mom) + enqueue(glist,g) + insert(sid,key(mom),in) + set(in,add(in,1)) + } +} + +proc scan () { + while (indi,dequeue(ilist)) { + print(name(indi)) print(nl()) + set(thisgen,dequeue(glist)) + if (ne(curgen,thisgen)) { + ".GN " d(thisgen) nl() + set(curgen,thisgen) + } + if (enqp) { + call enqpar(indi) + } + ".IN" nl() d(out) ". " + call longvitals(indi,1,1) + set(out,add(out,1)) + } +} + +proc longvitals(i,showc,showp) { + if ( and(i,lookup(lvd,key(i))) ) { + /* call shortvitals(i)*/ + call nicename(i) "." nl() + } else { + set (fac,1) + "\\fB" call nicename(i) "\\fR." nl() + insert(sid,key(i),out) + insert(lvd,key(i),out) + call add_to_ix(i) + call dobirth(i,showp) + call doeduc(i) + call domarr(i,showc) + call dooccu(i) + call doresi(i) + call donotes(inode(i),1) + call dotext(inode(i),1) + call othernodes(inode(i)) + call doreti(i) + call dodeath(i) + } +} + +proc shortvitals(indi) { + call nicename(indi) + set(b,birth(indi)) set(d,death(indi)) + if (and(b,short(b))) { ", b. " short(b) } + if (and(d,short(d))) { ", d. " short(d) } + "." nl() +} + +proc famvitals (indi,fam,spouse,nfam,showc) { + if (eq(0,nchildren(fam))) { + call firstname(indi) + if (spouse) { + " and " call firstname(spouse) + } + " had no children" + if (not(spouse)) { + " from this marriage" + } + "." nl() + } elsif (and(fam,lookup(ftab,key(fam)))) { + set(par,indi(lookup(ftab,key(fam)))) + "Children of " call firstname(indi) " and " call firstname(spouse) " are shown " + "under " call nicename(par) "." nl() + } elsif (showc) { + "Children of " call firstname(indi) + if (spouse) { + " and " call firstname(spouse) + } + ":" nl() + ".VL 0.4i" nl() + insert(ftab,save(key(fam)),key(indi)) + children(fam,child,nchl) { + ".LI " roman(nchl) nl() + set(childhaschild,0) + families(child,cfam,cspou,ncf) { + if(ne(0,nchildren(cfam))) { set(childhaschild,1) } + } + ".CH " nl() + if (and(enqc,childhaschild)) { + call enqch(child) + call shortvitals(child) + } else { + call longvitals(child,0,0) + } + set(fac,1) + } + ".LE" nl() + ".IN" nl() + } else { + call firstname(indi) + if (spouse) { + " and " call firstname(spouse) + } + " had " card(nchildren(fam)) + if(eq(1,nchildren(fam))) { + " child," + set(andn,0) + } else { + " children," + set(andn,sub(nchildren(fam),1)) + } + + children(fam,child,nchl) { + " " + call firstname(child) + call doadopts(child) + call add_to_ix(child) + if(ne(nchl,nchildren(fam))) { + if(eq(nchl,andn)) { + " and" + } else { + "," + } + } + } + "." nl() + } +} + +proc enqch (child) { + enqueue(ilist,child) + enqueue(glist,add(1,curgen)) + insert(sid,key(child),in) + set (in, add (in, 1)) +} + +proc spousevitals (sp,fam) { + if(e,marriage(fam)) { + if (place(e)) { + call wherewhen(e) "," + } + } + " " + call add_to_ix(sp) + if (and(sp,lookup(sid,key(sp)))) { + /*call shortvitals(sp)*/ call nicename(sp) "." nl() + } else { + call nicename(sp) + set(e,birth(sp)) + if(and(e,long(e))) { "," nl() "born" call wherewhen(e) } + set(e,death(sp)) + if(and(e,long(e))) { "," nl() pn(sp,1) " died" call wherewhen(e) } + "." nl() + call showparents(sp) + } +} + +proc showparents(sp) { + set(dad,father(sp)) + set(mom,mother(sp)) + if (or(dad,mom)) { + pn(sp,0) " " + if (death(sp)) { "was the " } else { "is the " } + if (male(sp)) { "son of " } + elsif (female(sp)) { "daughter of " } + else { "child of " } + if (dad) { call nicename(dad) } + if (and(dad,mom)) { nl() "and " } + if (mom) { call nicename(mom) } + if (dad) { call add_to_ix(dad) } + if (mom) { call add_to_ix(mom) } + set(nch,nchildren(parents(sp))) + decr(nch) + if (gt(nch,0)) { + " who had " card(nch) " other " + if (eq(1,nch)) { + "child," + set(andn,0) + } else { + "children," + set(andn,sub(nch,1)) + } + set(cp,0) + children(parents(sp),child,nchl) { + if (ne(key(child),key(sp))) { + " " + call firstname(child) + call doadopts(child) + call add_to_ix(child) + set(cp,add(cp,1)) + if(ne(nch,cp)) { + if(eq(cp,andn)) { + " and" + } else { + "," + } + } + } + } + ". " nl() + } + "." nl() + } +} + +proc dobirth(i,showp) { + set(e,birth(i)) + if(and(e,long(e))) { + ".P" nl() + call firstname(i) + set(fac,0) + " was born" call wherewhen(e) "." nl() + } + if(showp) { call showparents(i) } + set(e,get_baptism(i)) + if(and(e,long(e))) { + if(not(birth(i))) {".P" nl()} + call fn0(i) + if (eqstr(tag(e),"BAPM")) { " was baptized" } + elsif (eqstr(tag(e),"BAPL")) { " was baptized" } + elsif (eqstr(tag(e),"CHR")) { " was christened" } + elsif (eqstr(tag(e),"CHRA")) { " was christened" } + call wherewhen(e) "." nl() + } +} + +proc domarr(i,showc) { + set(j,1) + families(i,f,s,n) { + ".P" nl() + call fn0(i) + if (or(not(s),marriage(f))) { + " married" + } else { + " lived with" + } + if (ne(1,nfamilies(i))) { " " ord(j) ", " } + set(j,add(j,1)) + if (s) { + call spousevitals(s,f) + } else { + if (male(i)) { + " but his wife's name is not known. " + } else { + " but her husband's name is not known. " + } + nl() + } + call dowitness(fnode(f)) + call donotes(fnode(f),1) + call othernodes(fnode(f)) + call famvitals(i,f,s,n,showc) + set(fac,1) + } +} + +proc dodeath(i) { + set(e,death(i)) + if(and(e,long(e))) { + ".P" nl() + call fn0(i) + " died" + call wherewhen(e) "." nl() + call addtostack(e,"CAUS") + if(not(empty(stack))) { + "The cause of death was " + dequeue(stack) "." nl() + } + call donotes(e,0) + } + set(e,burial(i)) + if(and(e,long(e))) { + if(not(long(death(i)))) {".P" nl()} + call fn0(i) + if (p,place(e)) { + if( ne(0,index(upper(p),"CREMAT",1)) ) { + " was laid to rest" + } else { + " was buried" + } + } + else { + " was buried" + } + call wherewhen(e) "." nl() + call donotes(e,0) + call dotext(e,1) + } +} + +proc donotes(in,subpara) { + fornodes(in, node) { + if (eq(0,strcmp("NOTE", tag(node)))) { + if (subpara) { + ".P" nl() + } + value(node) nl() + call addtostack(node,"CONT") + while(it,dequeue(stack)) { + it nl() + } + } + } +} + +proc dotext(in,subpara) { + fornodes(in, node) { + if (eq(0,strcmp("TEXT", tag(node)))) { + if (subpara) { + ".P" nl() + } + call addtostack(node,"SOUR") + if(not(empty(stack))) { + "The following information was found in " + while(it,dequeue(stack)) { + it nl() + } + ".I :" nl() + ".P" nl() + } + value(node) nl() + call addtostack(node,"CONT") + while(it,dequeue(stack)) { + it nl() + } + ".R" nl() + } + } +} + +proc dowitness(snode) { + set(mult,0) + call addtostack(snode,"WITN") + if (not(empty(stack))) { + "Witnessed by " + while(it,dequeue(stack)) { + if (mult) { + " and " + } else { + set(mult,1) + } + it + } + "." nl() + } +} + +proc dooccu(in) { + set(first,1) + fornodes(inode(in), node) { + if (eq(0,strcmp("OCCU", tag(node)))) { + if(first) { + ".P" nl() + call fn2(in) + " occupation was " + set(first,0) + } else { + "Then " + } + value(node) + call wherewhen(node) + "." nl() + } + } +} + +proc doresi(in) { + set(first,1) + fornodes(inode(in), node) { + if (eq(0,strcmp("RESI", tag(node)))) { + if(first) { + ".P" nl() + call fn0(in) + " lived" + set(first,0) + } else { + "Subsequently" + } + call wherewhen(node) + "." nl() + } + } +} + +proc doeduc(in) { + set(first,1) + fornodes(inode(in), node) { + if (eq(0,strcmp("EDUC", tag(node)))) { + if(first) { + ".P" nl() + call fn0(in) + " was educated" + set(first,0) + } else { + "Also" + } + call wherewhen(node) + "." nl() + } + } +} + +proc doreti(in) { + fornodes(inode(in), node) { + if (eq(0,strcmp("RETI", tag(node)))) { + ".P" nl() + call fn0(in) + " retired" + call wherewhen(node) + "." nl() + } + } +} + +/* Short version of adoption */ +proc doadopts(in) { + fornodes(inode(in), node) { + if (eq(0,strcmp("ADOP", tag(node)))) { + " (adopted)" + } + } +} + +proc addtostack(stnode,ntype) { + fornodes(stnode, subnode) { + if (eq(0,strcmp(ntype, tag(subnode)))) { + enqueue(stack,value(subnode)) + } + } +} + +proc addtostackc(stnode,ntype) { + fornodes(stnode, subnode) { + if (eq(0,strcmp(ntype, tag(subnode)))) { + enqueue(stack,value(subnode)) + call addtostack(subnode,"CONT") + } + } +} + +proc stackaddr(e) { + call addtostackc(e,"ADDR") +} + +proc stackplace(stnode) { + fornodes(stnode, subnode) { + if (eq(0,strcmp("PLAC", tag(subnode)))) { + call stackaddr(subnode) + enqueue(stack,value(subnode)) + } + } +} + +proc fromto(indi) { + set(e,birth(indi)) + set(f,death(indi)) + if (or(year(e),year(f))) { + "(" + if (year(e)) {year(e)} else { "?" } + "-" + year(f) + ")" + } +} + +proc when(e) { + if(d,stddate(e)) { + set(i,index(d," ",1)) + if(eq(0,i)) { + " in " + } elsif(eq(i,1)) { + " in" + } elsif(lt(i,4)) { + " on " + } else { " in " } + d + } + call doperi(e) + call addtostack(e,"AGE") + if (not(empty(stack))) { + ", at the age of " dequeue(stack) + } +} + +proc where(e) { + call addtostack(e,"CORP") + call addtostack(e,"SITE") + call stackaddr(e) + call stackplace(e) + if (not(empty(stack))) { + " at " dequeue(stack) + while (elem,dequeue(stack)) { + ", " + elem + /* if (not(empty(stack))) { + ", " + }*/ + } + } +} + +proc wherewhen(e) { + call where(e) + call when(e) +} + +proc whenwhere(e) { + call when(e) + call where(e) +} + +proc doperi(node) { + call addtostack(node,"PERI") + if(not(empty(stack))) { + " from " + set(notfirst,0) +/* if(not(getel(stack,2))) { + dequeue(stack) + } else {*/ + while(it,dequeue(stack)) { + if(getel(stack,1)) { + it ", " + } else { + if(notfirst) {"and " set(notfirst,1)} + it + } + } +/* }*/ + } +} + +proc nicename(i) { + if(eq(0,strlen(givens(i)))) { "____" } else { givens(i) } + sp() + if(surname(i)) {upper(surname(i))} else { "____" } + if(sect,lookup(sid,key(i))) { + if(ne(sect,out)) {" [" d(sect) "]"} + } +} + +/* Print the firstname or He/She depending whether the fac flag is set */ +proc fn0(i) { + if (fac) { + call firstname(i) + set(fac,0) + } else { + pn(i,0) + } +} + +/* Print the firstname or His/Her depending whether the fac flag is set */ +proc fn2(i) { + if (fac) { + call firstname(i) "'s" + set(fac,0) + } else { + pn(i,2) + } +} + +proc firstname(i) { + if (i) { + call addtostack(inode(i),"CNAM") + if (not(empty(stack))) { + dequeue(stack) + } else { + list(parts) + extractnames(inode(i),parts,elems,sn) + if(eq(1,elems)) { + "____ " pop(parts) + } else { + set(nf,1) + forlist(parts,it,n) { + if(ne(sn,n)) { + if(nf) { set(ans,it) set(nf,0) } + /* if( ne(0,index(it,qt(),1)) ) { + set(ans,substring(it,2,sub(strlen(it),1))) + }*/ + } + } + ans + } + } + } +} + +proc othernodes(i) { + fornodes(i, node) { + if (index(" BAPM BAPL BIRT BURI CHIL CHR CHRA CNAM CONF DEAT DIVI EDUC FAMC FAMS HUSB MARR NAME NOTE RESI RETI OBJE OCCU SEX TEXT WIFE WITN ", + concat(" ",upper(tag(node))," "),1)) { + set(null,0) /* lifelines noop */ + } elsif (eq(0,strcmp("FILE", tag(node)))) { + copyfile(value(node)) + } elsif (eq(0,strcmp("DIVI", tag(node)))) { + "The marriage ended in divorce." nl() + } else { + ".P" nl() + tag(node) sp() value(node) + call wherewhen(node) nl() + call subnode(node) + } + } +} + +proc subnode(i) { + fornodes(i, subn) { + if (index(" ADDR AGE CORP DATE PERI PLAC SITE ", + concat(" ",upper(tag(subn))," "),1)) { + set(null,0) + } else { + ".br" nl() + tag(subn) sp() value(subn) nl() + call subnode(subn) + } + } +} + +proc prindex () { + print("Index") print(nl()) + namesort(idex) + monthformat(4) + ".IX" nl() + forindiset(idex,indi,v,n) { + ".br" nl() + fullname(indi,1,0,24) + " " + call fromto(indi) " " + lookup(itab,key(indi)) + nl() + set(tp,n) + } + print(d(tp)) print(" individuals were mentioned in this report") print(nl()) + ".P" nl() "There are " d(tp) " individuals mentioned in this report." + nl() +} + +proc add_to_ix(i) { +/* print("IX ") print(name(i)) print(" ") print(d(out)) print(nl())*/ + addtoset(idex,i,d(out)) + if (l,lookup(itab,key(i))) { +/* print(" - already got ") print(l) print(nl())*/ + insert(itab,key(i),save(concat(concat(l,","),d(out)))) + } else { + insert(itab,key(i),save(d(out))) + } +} + +func get_baptism(indi) { + list(ev) + fornodes(indi,node) { + if (index(" BAPM BAPL CHR CHRA ",concat(" ",upper(tag(node))," "),1)) { + return(node) + } + } + return(0) +} + +func get_tags(indi,str) { + list(ev) + fornodes(indi,node) { + if (index(str,concat(" ",upper(tag(node))," "),1)) { + push(ev,node) + } + } + return(ev) +} + +func output_head() +{ + /* this is really ugly. back slash is already overused in *roff code + * but to include this here we have to escape the backslashs (that were + * already escaped in the *roff code. However, it is better here, + * than the hassels of a separate file for the header info. + */ + ".if t .pl 10.9i \\\" Page length" nl() + ".if n .pl 10.7i" nl() + ".if t .ll 6.75i \\\" Line length" nl() + ".if n .ll 7.25i" nl() + ".\\\".if t .lt 6.75i \\\" Title length" nl() + ".\\\".if n .lt 7.25i" nl() + ".if t .lt 7.75i \\\" Title length" nl() + ".if n .lt 9.25i" nl() + ".po 0.5i \\\" Left margin" nl() + ".ls 1 \\\" Line spacing" nl() + ".\\\".nr Ej 1 \\\" New page before chapter headings" nl() + ".nr Hb 1 \\\" Line break after all headings" nl() + ".nr Hs 6 \\\" Blank line after all headings" nl() + ".\\\".nr Hc 1 \\\" Centre chapter headings" nl() + ".nr Hu 1 \\\" Un-numbered headings are at level 1" nl() + ".nr Hi 1 \\\" Indent after head same as paras" nl() + ".nr Pt 0 \\\" Don't indent paras" nl() + ".nr Cl 6 \\\" Heads in table of contents up to level 6" nl() + ".nr Yr \\n(yr+1900 \\\" the year for we are printing this" nl() + ".if t .ds HF 3 3 3 3 3 3 2 \\\" Heading fonts" nl() + ".ds HP +6 +6 +2 +2 +2 +2 +1 \\\" Heading point sizes" nl() + ".ds pB " getproperty("user.fullname") nl() + ".rm )k \\\" Remove cut marks at top of page" nl() + ".if \"\\nd\"0\" .nr m \\n(mo-1" nl() + ".if \"\\nm\"0\" .ds mO January" nl() + ".if \"\\nm\"1\" .ds mO February" nl() + ".if \"\\nm\"2\" .ds mO March" nl() + ".if \"\\nm\"3\" .ds mO April" nl() + ".if \"\\nm\"4\" .ds mO May" nl() + ".if \"\\nm\"5\" .ds mO June" nl() + ".if \"\\nm\"6\" .ds mO July" nl() + ".if \"\\nm\"7\" .ds mO August" nl() + ".if \"\\nm\"8\" .ds mO September" nl() + ".if \"\\nm\"9\" .ds mO October" nl() + ".if \"\\nm\"10\" .ds mO November" nl() + ".if \"\\nm\"11\" .ds mO December" nl() + ".PF \"'\\fIProduced by \\*(pB\\fR'- \\\\\\\\nP -'\\fI\\n(dy \\*(mO \\n(Yr \\fR'\"" nl() + ".PH" nl() + ".de GN" nl() + ".br" nl() + ".ne 2i" nl() + ".sp 2" nl() + ".in 0" nl() + ".ce" nl() + ".if t \\s+3\\fHGENERATION \\\\$1\\fH\\s-3" nl() + ".if n GENERATION \\\\$1" nl() + ".." nl() + ".de CH" nl() + ".." nl() + ".de IN" nl() + ".sp" nl() + ".in 0" nl() + ".." nl() + ".de IX" nl() + ".SK" nl() + ".HU Index" nl() + "All the people mentioned in this report are given below. Please note that" nl() + "the numbers printed after the name are not page numbers. They are the section" nl() + "number(s) in which that person is mentioned. " nl() + ".if t .2C" nl() + ".." nl() + ".de .I" nl() + ".if t \\fI\\\\$1" nl() + ".if n \\\\$1" nl() + ".." nl() + ".de .R" nl() + ".if t \\fR" nl() + ".." nl() +} diff --git a/reports/outsources.li b/reports/outsources.li new file mode 100644 index 0000000..2de65d7 --- /dev/null +++ b/reports/outsources.li @@ -0,0 +1,63 @@ +/* + * @progname outsources.li + * @version 1.3 + * @author Scott McGee (smcgee@microware.com) + * @category + * @output GEDCOM + * @description + +This is a library of functions and proc to output GEDCOM. It is most useful +to output source records and potentially some info from custom tags. +The proc outsources() will take an indi set and output all the source +structures that are referenced. + +@(#)gedcom.li 1.3 10/13/95 +*/ + + +proc outsources (s){ + table(t) + list(q) + forindiset (s, i, a, n) { + traverse(root(i), m, l) { + if (nestr("SOUR", tag(m))) { + continue() + } + if (not(reference(value(m)))) { + continue() + } + if (eq(1, lookup(t, value(m)))) { + continue() + } + set(v, save(value(m))) + insert(t, v, 1) + enqueue(q, v) + } + } + if(q){ + forlist(q, k, n) { + set(r, dereference(k)) + call outrecord(r) + } + } +} + +proc outrecord(r){ +/* good general purpose procedure that outputs + any LifeLines record in its pure GEDCOM form */ + + traverse(r, s, l) { + d(l) + if (xref(s)) { + " " + xref(s) + } + " " + tag(s) + if (value(s)) { + " " + value(s) + } + "\n" + } +} diff --git a/reports/paf-export.ll b/reports/paf-export.ll new file mode 100644 index 0000000..8683580 --- /dev/null +++ b/reports/paf-export.ll @@ -0,0 +1,517 @@ +/* + * @progname paf-export.ll + * @version 1994-11-12 + * @author Kurt Baudendistel (baud@research.att.com) + * @category + * @output GEDCOM + * @description + * + * Convert lifelines-standard gedcom to paf gedcom. + * This report generates paf-compatible gedcom from a lines-compatible + * database, including the conversion of SOUR entries into the bang- + * tagged NOTEs used by paf for documentation (see 5). This produces + * paf 2.2 output -- you can convert to 2.1 by loading and unloading + * it using paf 2.2. + * + * First, some silly truncation and format conformance stuff: + * + * 1. NAMEs are truncated to four fields (3 given and 1 surname) of + * 16 characters each. The 3rd given name field is filled with + * multiple names concatenated by underscores, up to the 16 character + * limit. Characters trailing the surname are inserted as a TITL + * entry, taking precendence over or being subverted by another TITL + * entry (according to the order of the two -- the first takes + * precedence). + * 2. PLACes are truncated to four fields of 16 characters each. + * Leading commas are inserted to fill to four fields. + * 3. SEX is set to M, F, or blank. + * 4. DATEs are truncated to 23 characters. Date format checking is + * not (yet) performed. If you've done this elsewhere, please let + * me know and I'll stick it in. + * 5. No effort is made to conform to the 80 character per line limit. + * + * Let's define "contify" to mean read a line, check its length, and + * line break it using CONTs at a space so that the maximum line length + * is approached but not violated. Contification is best handled in + * a post-processing phase that simply reads in the file, contify's it, + * and outputs it again. This could be done, but is not. + * + * Should this simply check line lengths and contify those over 80 + * characters, or should the system concatenate and then contify all + * lines? The latter is much more elegant and suitable for systems + * that assume post-processing, as with LaTeX, but the former is + * required to maintain "formatting" in ascii text while providing + * the automatic capability for producing paf-compatible files. I + * would argue that if the former is the case, that no contification + * should take place at all -- if the user wants some control over + * the formatting, then s/he should take full responsibility to + * maintain the formatting completely. And that's where we leave + * it, no contification is done. + * + * Next, only a restricted subset of the entries are output: + * + * 6. Only the following entries are output: + * - Level 1 records, only the first of multiple is output: + * NAME, TITL, SEX, BIRT, CHR, DEAT, BURI + * - Level 2 records, only the first of multiple is output: + * DATE, PLAC + * - Level 1 records, multiple outputs allowed: + * NOTE, FAMS, FAMC, AFN, REFN, HUSB, WIFE, CHIL, MARR, + * BAPL, ENDL, TEMP, SLGC, SLGS + * - Level 1 DIV, DIVF, and ANUL records are translated into DIV Y + * along with bang-tagged NOTEs (notes are not yet supported), + * multiple outputs are allowed. + * - Level 1 OCCU are converted to NOTEs. + * - Level 2 SOUR records are translated into bang-tagged NOTEs + * attached to the individual or to the head of the family, + * husband or wife if there is no husband, for marriage/divorce + * sources, multiple outputs are allowed. + * + * The format of the NOTEs is as described in the 1993 Edition of + * of the PAF Documentation Guidelines produced by the Silicon + * Valley Users Group, where the text of each gedcom record is + * inserted as shown: + * + * m SOUR text -> !event: text + * m @xx@ SOUR -> !event: AUTHor or NAME, TITLe; PERIod; + * PUBRisher and publication information, + * ADDR, DATE; PAGEs; REPOsitory; NOTEs + * m SOUR @xx@ -> !event: See xx. + * + * Generally, source references must be converted to definitions + * before they can be used to produce legal NOTEs according to the + * PAF DC (I use an awk script for this in lieu of real lifelines + * support for sources in 2.3.6). + * + * TITL is replaced by "TITL," PUBL when the PUBL record exists -- + * this structure is used to give the TITLe of an article in a + * PUBLication. + * + * Actually, this is not quite correct: + * . The PDG does not require the bang, but rather uses it to signal + * ``public'' notes -- we assume that all notes are public, though, + * and so require it. + * . The PDG requires ;;;;; before text in a plain note, but this + * seems like overkill. + * + * No other entries are output! + * + * 8. CONTs are only handled correctly for NOTEs and SOURs. + * + * Finally, some output formatting is available: + * + * 9. Submitter information can be optionally included. If used, this + * should be a file of the form + * + * 0 @xx@ SUBM + * 1 NAME Kurt Baudendistel + * 1 ADDR 420 River Rd, Apt D7 + * 2 CONT Chatham, NJ 07928 + * 2 CONT baud@research.att.com + * 1 PHON (908) 582-2168 + * + * Note that errors in this file format will not be checked -- it + * is simply inserted in the gedcom output. + * + * Possible future upgrades: + * + * A. When multiple records, such as BIRT are found, output the later + * ones as NOTEs. + * B. Contify. + * C. Convert date formats to legal ones, including bumping non-date + * information, such as "See Notes" into NOTEs. + * D. Output submitter information that is stored in the database. + * + * This capability is easy to use inside any other program that + * generates a restricted set of families/individuals. Simply include + * the pafX functions given below main and use pafindi/paffam instead + * of the standard outindi/outfam given in simpleged. + * + * From: simpleged ttw@beltway.att.com + * pafcompat eggertj@ll.mit.edu + * + * 12 NOV 1994 (2.3.6) baud@research.att.com + */ + +/* main function */ + +proc main () +{ + "0 HEAD \n" + "1 SOUR LIFELINES\n" + "2 VER 2.3.6\n" + "2 NAME PAF-EXPORT REPORT\n" + "1 DEST PAF\n" + "2 VER 2.2\n" + "1 DATE " date (gettoday ()) "\n" + + getstrmsg (submitterFile, + "What is the name of the submitter information file (null okay)?") + if (strcmp ("", submitterFile)) { + "1 COPR Copyright " date (gettoday ()) ". Permission is granted to repro" + "duce any subset\n2 CONT of the data contained herein under the condit" + "ion that this copyright\n2 CONT notice is preserved, that the origina" + "l source citations referenced\n2 CONT in the subset are included, and" + " that the submitter of this file is\n2 CONT credited with original au" + "thorship as appropriate.\n" + copyfile (submitterFile) + } + "1 CHAR ASCII\n" + + print ("Processing nodes (x10) ...\n") + forindi (indi, num) { + if (eq (mod (num, 10), 0)) { + print ("i") + } + call pafindi (indi) + } + + forfam (fam, num) { + if (eq (mod (num, 10), 0)) { + print ("f") + } + call paffam (fam) + } + + "0 TRLR \n" +} + +/* pafX functions */ + +global (paftitl) + +proc pafindi (indi) +{ + set (root, inode (indi)) + set (noname, 1) + set (notitl, 1) + set (nosex, 1) + set (nobirt, 1) + set (nobapt, 1) + set (nodeat, 1) + set (noburi, 1) + if (eq (nfamilies (indi), 1)) { + set (fams_counter, 0) + } else { + set (fams_counter, 1) + } + "0 " xref (root) " " tag (root) "\n" + fornodes (root, node) { + if (and (noname, not (strcmp ("NAME", tag (node))))) { + "1 NAME" call pafname (value (node)) "\n" + if (and (notitl, strlen (paftitl))) { + "1 TITL" paftitl "\n" + set (notitl, 0) + } + set (noname, 0) + } elsif (and (notitl, not (strcmp ("TITL", tag (node))))) { + "1 TITL " value (node) "\n" + set (notitl, 0) + } elsif (and (nosex, not (strcmp ("SEX", tag (node))))) { + "1 SEX " call pafsex (value (node)) "\n" + set (nosex, 0) + } elsif (and (nobirt, not (strcmp ("BIRT", tag (node))))) { + call pafevent (node, 1, 1, 0, 0) + set (nobirt, 0) + } elsif (and (nobapt, not (strcmp ("CHR", tag (node))))) { + call pafevent (node, 1, 1, 0, 0) + set (nobapt, 0) + } elsif (and (nodeat, not (strcmp ("DEAT", tag (node))))) { + call pafevent (node, 1, 1, 0, 0) + set (nodeat, 0) + } elsif (and (noburi, not (strcmp ("BURI", tag (node))))) { + call pafevent (node, 1, 1, 0, 0) + set (noburi, 0) + } elsif (not (strcmp ("BAPL", tag (node)))) { + "1 BAPL" call pafevent (node, 1, 1, 0, 0)"\n" + } elsif (not (strcmp ("ENDL", tag (node)))) { + "1 ENDL" call pafevent (node, 1, 1, 0, 0)"\n" + } elsif (not (strcmp ("TEMP", tag (node)))) { + "1 TEMP" call pafevent (node, 1, 1, 0, 0)"\n" + } elsif (not (strcmp ("SLGC", tag (node)))) { + "1 SLGC" call pafevent (node, 1, 1, 0, 0)"\n" + } elsif (not (strcmp ("SLGS", tag (node)))) { + "1 SLGS" call pafevent (node, 1, 1, 0, 0)"\n" + } elsif (not (strcmp ("FAMC", tag (node)))) { + "1 FAMC " value (node) "\n" + } elsif (not (strcmp ("FAMS", tag (node)))) { + "1 FAMS " value (node) "\n" + set (f, fam (value (node))) + if (or (not (husband (f)), eq (husband (f), indi))) { + call pafevent (marriage (f), 0, 1, 0, fams_counter) + fornodes (fnode (f), subnode) { + if (or (or (not (strcmp ("DIV", tag (subnode))), + not (strcmp ("DIVF", tag (subnode)))), + not (strcmp ("ANUL", tag (subnode))))) { + call pafevent (subnode, 0, 1, 1, fams_counter) + } + } + } + incr (fams_counter) + } elsif (not (strcmp ("OCCU", tag (node)))) { + "1 NOTE OCCUPATION: " call values (node) "\n" + } elsif (not (strcmp ("NOTE", tag (node)))) { + "1 NOTE " call values (node) "\n" + } elsif (not (strcmp ("AFN", tag (node)))) { + "1 AFN" value (node) "\n" + } elsif (not (strcmp ("REFN", tag (node)))) { + "1 REFN" value (node) "\n" + } + } +} + +proc paffam (fam) +{ + set (root, fnode (fam)) + "0 " xref (root) " " tag (root) "\n" + fornodes (root, node) { + if (not (strcmp ("HUSB", tag (node)))) { + "1 HUSB " value (node) "\n" + } elsif (not (strcmp ("WIFE", tag (node)))) { + "1 WIFE " value (node) "\n" + } elsif (not (strcmp ("CHIL", tag (node)))) { + "1 CHIL " value (node) "\n" + } elsif (not (strcmp ("MARR", tag (node)))) { + call pafevent (node, 1, 0, 0, 0) + } elsif (not (strcmp ("DIV", tag (node)))) { + "1 DIV Y\n" + } elsif (not (strcmp ("DIVF", tag (node)))) { + "1 DIV Y\n" + } elsif (not (strcmp ("ANUL", tag (node)))) { + "1 DIV Y\n" + } + } +} + +proc pafevent (event, eventflag, sourceflag, noteflag, count) +{ + table (tagnotes) + insert (tagnotes,"BIRT","BIRTH") + insert (tagnotes,"CHR", "CHRISTENING") + insert (tagnotes,"DEAT","DEATH") + insert (tagnotes,"BURI","BURIAL") + insert (tagnotes,"MARR","MARRIAGE") + insert (tagnotes,"DIV", "DIVORCE") + insert (tagnotes,"DIVF", "DIVORCEFINAL") + insert (tagnotes,"ANUL", "ANNULMENT") + + if (event) { + set (tagname, lookup (tagnotes, tag (event))) + if (not (strcmp ("", tagname))) { set (tagname, tag (event)) } + + if (eventflag) { + "1 " tag (event) "\n" + set (datecount, 1) + set (placecount, 1) + fornodes (event, evt) { + if (not (strcmp ("DATE", tag (evt)))) { + if (eq (datecount, 1)) { + "2 DATE " call pafdate (value (evt)) "\n" + } + incr (datecount) + } elsif (not (strcmp ("PLAC", tag (evt)))) { + if (eq (placecount, 1)) { + "2 PLAC " call pafplac (value (evt)) "\n" + } + incr (placecount) + } + } + } + + if (noteflag) { + set (countlimit, 0) + } else { + set (countlimit, 1) + } + + if (sourceflag) { + set (datecount, 1) + set (placecount, 1) + fornodes (event, evt) { + if (not (strcmp ("DATE", tag (evt)))) { + if (gt (datecount, countlimit)) { + "1 NOTE " tagname "DATE" + if (count) { "(" d (count) ")" } + ": " call pafdate (value (evt)) "\n" + } + incr (datecount) + } elsif (not (strcmp ("PLAC", tag (evt)))) { + if (gt (placecount, countlimit)) { + "1 NOTE " tagname "PLACE" + if (count) { "(" d (count) ")" } + ": " call pafplac (value (evt)) "\n" + } + if (or (not (strcmp ("SITE", tag (child (evt)))), + not (strcmp ("CEME", tag (child (evt)))))) { + "1 NOTE " + if (not (strcmp (tagname, "BURIAL"))) { + "CEMETERY" + } else { + tagname + "SITE" + } + if (count) { "(" d (count) ")" } + ": " + call values (child (evt)) "\n" + } + incr (placecount) + } elsif (not (strcmp ("CAUS", tag (evt)))) { + "1 NOTE " tagname "CAUSE: " call values (evt) "\n" + } elsif (not (strcmp ("AGE", tag (evt)))) { + "1 NOTE " tagname "AGE: " call values (evt) "\n" + } elsif (not (strcmp ("SOUR", tag (evt)))) { + "1 NOTE !" tagname + if (count) { "(" d (count) ")" } + ": " call pafsour (evt) "\n" + } elsif (not (strcmp ("NOTE", tag (evt)))) { + "1 NOTE " tagname + if (count) { "(" d (count) ")" } + "NOTE:\n2 CONT " call values (evt) "\n" + } + } + } + } +} + +proc pafname (name) +{ + set (c, 1) + set (i, 1) + set (k1, index (name,"/", 1)) + set (k2, index (name,"/", 2)) + set (n, 16) + set (m, 0) + while (lt (i, k1)) { + set (j, index (name," ", c)) + if (or (eq (j, 0), gt (j, k1))) { + set (j, k1) + } + if (lt (c, 4)) { + " " + } else { + "_" + set (n, sub (sub (n, m), 1)) + if (lt (n, 0)) { set (n, 0) } + } + trim (substring (name, i, sub (j, 1)), n) + set (m, sub (j, i)) + set (i, add (j, 1)) + set (c, add (c, 1)) + } + " " + substring (name, k1, k2) + set (paftitl, substring (name, add (k2, 1), strlen (name))) +} + +proc pafsex (name) +{ + if (or (not (strcmp ("M", name)), not (strcmp ("F", name)))) { name } + else { " " } +} + +proc pafdate (name) +{ + trim (name, 23) +} + +proc pafplac (name) +{ + set (c, 1) + set (i, 1) + set (I, add (strlen (name), 1)) + set (plac,"") + while (and (lt (i,I), lt (c, 5))) { + set (j, index (name,",", c)) + if (eq (j, 0)) { + set (j,I) + } + set (plac, concat (plac, trim (substring (name, i, sub (j, 1)), 16))) + set (plac, concat (plac,",")) + set (i, add (j, 1)) + set (c, add (c, 1)) + } + while (lt (c, 5)) { + set (plac, concat (",", plac)) + set (c, add (c, 1)) + } + substring (plac, 1, sub (strlen (plac), 1)) +} + +proc pafsour (root) { + fornodes (root, n) { + if (not (strcmp ("NAME", tag (n)))) { set (auth, n) } + elsif (not (strcmp ("AUTH", tag (n)))) { set (auth, n) } + elsif (not (strcmp ("TITL", tag (n)))) { set (titl, n) } + elsif (not (strcmp ("PUBL", tag (n)))) { set (publ, n) } + elsif (not (strcmp ("PERI", tag (n)))) { set (peri, n) } + elsif (not (strcmp ("PUBR", tag (n)))) { set (pubr, n) } + elsif (not (strcmp ("ADDR", tag (n)))) { set (addr, n) } + elsif (not (strcmp ("PHON", tag (n)))) { set (phon, n) } + elsif (not (strcmp ("DATE", tag (n)))) { set (date, n) } + elsif (not (strcmp ("VOLU", tag (n)))) { set (vol, n) } + elsif (not (strcmp ("VOL", tag (n)))) { set (vol, n) } + elsif (not (strcmp ("NUM", tag (n)))) { set (num, n) } + elsif (not (strcmp ("PAGE", tag (n)))) { set (page, n) } + elsif (not (strcmp ("REPO", tag (n)))) { set (repo, n) } + elsif (not (strcmp ("SOUR", tag (n)))) { set (sour, n) } + elsif (not (strcmp ("FILM", tag (n)))) { set (film, n) } + elsif (not (strcmp ("NOTE", tag (n)))) { set (note, n) } + } + set (any, or (auth, or (titl, or (publ, or (peri, or (pubr, or (addr, + or (phon, or (date, or (vol, or (num, or (page, or (repo, + note))))))))))))) + if (any) { + if (auth) { call values (auth) } + if (publ) { + if (auth) { "," } + if (titl) { "\n2 CONT \"" call values (titl) ",\"" } + "\n2 CONT " call values (publ) + } elsif (titl) { + if (auth) { "," } + "\n2 CONT " call values (titl) + } + ";" if (peri) { "\n2 CONT " call values (peri) } + ";" if (pubr) { "\n2 CONT " call values (pubr) } + if (addr) { if (pubr) { "," } "\n2 CONT " call values (addr) } + if (phon) { + if (or (pubr, addr)) { "," } + "\n2 CONT " call values (phon) + } + if (date) { + if (or (pubr, or (addr, phon))) { "," } + "\n2 CONT " call values (date) + } + ";" if (film) { "\n2 CONT " "Film Number " call values (film) } + if (vol) { "\n2 CONT " "Volume " call values (vol) } + if (num) { "\n2 CONT " "Number " call values (num) } + if (page) { "\n2 CONT " "Page(s) " call values (page) } + ";" if (repo) { "\n2 CONT " call values (repo) } + if (and (film, not (repo))) { + "\n2 CONT Church of Jesus Christ of Latter Day Saints, " + "Salt Lake City, UT" + } + ";" if (note) { "\n2 CONT " call values (note) } + } + if (v, value (root)) { + if (and (eq (index (v, "@", 1), 1), eq (index (v, "@", 2), strlen (v)))) { + if (not (any)) { + "See " substring (v, 2, sub (strlen (v), 1)) "." + } + } else { + "\n2 CONT " call values (root) + } + } + if (sour) { + "\n2 CONT " call pafsour (sour) + } +} + +proc values (node) +{ + value (node) + fornodes (node, n) { + if (not (strcmp ("CONT", tag (n)))) { + "\n2 CONT " value (n) + } + } +} diff --git a/reports/paf-import.ll b/reports/paf-import.ll new file mode 100644 index 0000000..9bdd6d3 --- /dev/null +++ b/reports/paf-import.ll @@ -0,0 +1,433 @@ +/* + * @progname paf-import.ll + * @version 1994-11-12 + * @author Kurt Baudendistel (baud@research.att.com) + * @category + * @output GEDCOM + * @description + * + * Convert paf gedcom to lifelines-standard gedcom, + * transforming name formats and notes. + * + * First, some silly formating: + * + * 1. _'s in NAMEs are converted to spaces. + * 2. Leading commas are stripped from PLACes + * 3. Recognizable posttitles are moved from TITL entries to NAME + * entries. + * + * Then, the meat of the problem + * + * 4. Bang-tagged NOTEs of the form + * + * 1 NOTE !BIRTH-CHRISTENING: ... + * 2 CONT ... + * + * are converted to SOURs in the appropriate event, and the + * original NOTE is deleted. The following NOTEs are recognized and + * translated into the corresponding event (an event is created + * if it does not exist): + * + * NAME -> NAME + * BIRTH -> BIRT + * PARENTS -> BIRT + * FATHER -> BIRT + * MOTHER -> BIRT + * ADOPTION -> ADOP + * CHRISTENING -> CHR + * DEATH -> DEAT + * BURIAL -> BURI + * MARRIAGE -> MARR (in first associated family) + * MARRIAGE(N) -> MARR (in numbered associated family) + * MARRIAGES -> MARR (in all associated families) + * DIVORCE -> DIV (in first associated family) + * DIVORCE(N) -> DIV (in numbered associated family) + * DIVORCES -> DIV (in all associated families) + * DIVORCEFINAL -> DIVF (in first associated family) + * DIVORCEFINAL(N) -> DIVF (in numbered associated family) + * DIVORCEFINALS -> DIVF (in all associated families) + * ANNULMENT -> ANUL (in first associated family) + * ANNULMENT(N) -> ANUL (in numbered associated family) + * ANNULMENTS -> ANUL (in all associated families) + * + * The NOTE is not deleted if any of the components are not + * recognized. Plain bang-tagged NOTEs are converted to TEXT. + * + * Multiple NOTEs produce multiple SOURs, just as you would expect. + * + * 5. Non-bang-tagged NOTEs of the form + * + * 1 NOTE BIRTH: ... + * 2 CONT ... + * + * are converted to NOTEs in the appropriate event for those + * events listed above, and the original NOTE is deleted. Note + * multiple NOTE targets (as in BIRTH-CHRISTENING) are not allowed + * for non-bang-tagged NOTEs, and that containing nodes (like + * PLAC) are not created if they do not exist -- the NOTE is simply + * lost. + * + * For the following NOTEs, a record is created of the + * indicated type (death here can be replaced by any event): + * + * DEATHSITE -> DEAT - PLAC - SITE + * DEATHAGE -> DEAT - AGE + * DEATHCAUSE -> DEAT - CAUS + * CEMETERY -> (same as BURIALSITE) + * EDITOR -> SOUR (at level 1) + * RESEARCHER -> SOUR (at level 1) + * OCCUPATION -> OCCU + * + * Of course, the original note is deleted. + * + * From: paf baud@research.att.com + * + * 12 NOV 1994 (2.3.6) baud@research.att.com + */ + +global (tTagTranslation) +global (tTitleTransformation) +global (sourceListTable) +global (siteListTable) +global (ageListTable) +global (causeListTable) +global (noteListTable) +global (tIndiEvents) +global (tFamEvents) +global (tNotesToDelete) + +proc main () +{ + "0 HEAD \n" + "1 SOUR LIFELINES\n" + "2 VER 2.3.6\n" + "2 NAME PAF-IMPORT REPORT\n" + "1 DEST LIFELINES\n" + "1 DATE " date (gettoday ()) "\n" + "1 CHAR ASCII\n" + + table (tTagTranslation) + insert (tTagTranslation, "NAME", "NAME") + insert (tTagTranslation, "BIRTH", "BIRT") + insert (tTagTranslation, "PARENTS", "BIRT") + insert (tTagTranslation, "FATHER", "BIRT") + insert (tTagTranslation, "MOTHER", "BIRT") + insert (tTagTranslation, "ADOPTION", "ADOP") + insert (tTagTranslation, "CHRISTENING", "CHR") + insert (tTagTranslation, "DEATH", "DEAT") + insert (tTagTranslation, "BURIAL", "BURI") + insert (tTagTranslation, "MARRIAGE", "MARR") + insert (tTagTranslation, "DIVORCE", "DIV") + insert (tTagTranslation, "DIVORCEFINAL", "DIVF") + insert (tTagTranslation, "ANNULMENT", "ANUL") + insert (tTagTranslation, "EDITOR", "SOUR") + insert (tTagTranslation, "RESEARCHER", "SOUR") + insert (tTagTranslation, "OCCUPATION", "OCCU") + + table (tTitleTransformation) + insert (tTitleTransformation, "Jr", "") + insert (tTitleTransformation, "Sr", "") + insert (tTitleTransformation, "I", "") + insert (tTitleTransformation, "II", "") + insert (tTitleTransformation, "III", "") + insert (tTitleTransformation, "IV", "") + insert (tTitleTransformation, "V", "") + insert (tTitleTransformation, "MD", "Dr") + insert (tTitleTransformation, "DDS", "Dr") + insert (tTitleTransformation, "PhD", "Dr") + insert (tTitleTransformation, "SJ", "Father") + insert (tTitleTransformation, "SM", "Brother") + + table (sourceListTable) + table (siteListTable) + table (ageListTable) + table (causeListTable) + table (noteListTable) + + table (tIndiEvents) + insert (tIndiEvents, "NAME", 1) + insert (tIndiEvents, "BIRT", 1) + insert (tIndiEvents, "ADOP", 1) + insert (tIndiEvents, "CHR", 1) + insert (tIndiEvents, "DEAT", 1) + insert (tIndiEvents, "BURI", 1) + insert (tIndiEvents, "SOUR", 1) + insert (tIndiEvents, "OCCU", 1) + + table (tFamEvents) + insert (tFamEvents, "MARR", 1) + insert (tFamEvents, "DIV", 1) + insert (tFamEvents, "DIVF", 1) + insert (tFamEvents, "ANUL", 1) + + table (tNotesToDelete) + + print ("Scanning for sources and event notes (x10) ...\n") + forindi (indi, num) { + if (eq (mod(num,10),0)) { + print ("i") + } + call unpafSources (indi) + call unpafOthers (indi, "SITE", siteListTable) + call unpafOthers (indi, "AGE", ageListTable) + call unpafOthers (indi, "CAUSE", causeListTable) + call unpafOthers (indi, "", noteListTable) + } + + print ("\n\nProcessing nodes (x10) ...\n") + forindi (indi, num) { + if (eq (mod(num,10),0)) { + print ("i") + } + call unpafNode (key (indi), inode (indi)) + } + + forfam (fam, num) { + if (eq (mod(num,10),0)) { + print ("f") + } + call unpafNode (key (fam), fnode (fam)) + } + + "0 TRLR \n" +} + +proc unpafSources (indi) +{ + fornodes (inode (indi), node) { + if (not (strcmp (tag (node), "NOTE"))) { + set (note, value (node)) + if (eq (index (note, "!", 1), 1)) { + if (colon, index (note, ":", 1)) { + set (nTag, save (concat (substring (note, 2, sub (colon, 1)), "-"))) + set (deleteFlag, 1) + while (strcmp (nTag, "")) { + set (mark, index (nTag, "-", 1)) + set (bTag, save (substring (nTag, 1, sub (mark, 1)))) + set (nTag, save (substring (nTag, add (mark, 1), strlen (nTag)))) + set (openLoc, add (index (bTag, "("/*)*/, 1), 1)) + set (closLoc, sub (index (bTag, /*(*/")", 1), 1)) + if (le (openLoc, closLoc)) { + if (bNum, atoi (substring (bTag, openLoc, closLoc))) { + set (bTag, save (trim (bTag, sub (openLoc, 2)))) + } else { + set (bNum, 1) + } + } else { + set (bNum, 1) + } + if (evt, lookup (tTagTranslation, bTag)) { + set (sourceKey, "") + if (lookup (tIndiEvents, evt)) { + if (eq (bNum, 1)) { + set (sourceKey, save (concat (key (indi), evt))) + } + } elsif (lookup (tFamEvents, evt)) { + set (foundFlag, 0) + families (indi, fvar, svar, num) { + if (eq (bNum, num)) { + set (sourceKey, save (concat (key (fvar), evt))) + set (foundFlag, 1) + } + } + if (not (foundFlag)) { + set (deleteFlag, 0) + } + } + if (strcmp (sourceKey, "")) { + call insertListTable (sourceListTable, sourceKey, node) + } + } else { + set (deleteFlag, 0) + } + } + if (deleteFlag) { + insert (tNotesToDelete, save (value (node)), 1) + } + } + } + } + } +} + +proc unpafOthers (indi, kind, otherListTable) +{ + set (tail, save (concat (kind, ":"))) + fornodes (inode (indi), node) { + if (not (strcmp (tag (node), "NOTE"))) { + set (note, value (node)) + if (eq (index (note, "CEMETERY:", 1), 1)) { + set (note, + save (concat ("BURIALSITE", substring (note, 9, strlen (note))))) + } + set (tailIndex, index (note, tail, 1)) + set (spaceIndex, index (note, " ", 1)) + if (or (lt (tailIndex, spaceIndex), + and (eq (spaceIndex, 0), + gt (tailIndex, 0)))) { + set (bEnd, sub (tailIndex, 1)) + set (bTag, save (trim (note, bEnd))) + set (bNum, atoi (substring (bTag, bEnd, bEnd))) + if (ne (bNum, 0)) { + decr (bEnd) + set (bTag, save (trim (bTag, bEnd))) + } + incr (bNum) + if (evt, lookup (tTagTranslation, bTag)) { + set (otherKey, "") + if (lookup (tIndiEvents, evt)) { + if (eq (bNum, 1)) { + set (otherKey, save (concat (key (indi), evt))) + } + } elsif (lookup (tFamEvents, evt)) { + families (indi, fvar, svar, num) { + if (eq (bNum, num)) { + set (otherKey, save (concat (key (fvar), evt))) + } + } + } + if (strcmp (otherKey, "")) { + call insertListTable (otherListTable, otherKey, node) + insert (tNotesToDelete, save (value (node)), 1) + } + } + } + } + } +} + +proc insertListTable (listTable, tableKey, node) { + list (evtList) + set (note, value (node)) + set (first, + save (substring (note, add (index (note, ":", 1), 1), strlen (note)))) + if (not (strcmp (trim (first, 1), " "))) { + set (first, save (substring (first, 2, strlen (first)))) + } + if (strlen (first)) { + enqueue (evtList, first) + } + fornodes (node, n) { + if (not (strcmp ("CONT", tag (n)))) { + enqueue (evtList, save (value (n))) + } + } + set (entryList, lookup (listTable, tableKey)) + if (not (entryList)) { list (entryList) } + enqueue (entryList, evtList) + insert (listTable, tableKey, entryList) +} + +proc unpafNode (rootKey, root) +{ + set (sourceList, 0) + set (noteList, 0) + set (sawBIRT, 0) + traverse (root, node, level) { + set (sawBIRT, or (sawBIRT, not (strcmp (tag (node), "BIRT")))) + if (eq (level, 0)) { + set (deletingFlag, 0) + set (listTableKey, save (concat (rootKey, tag (node)))) + set (sourceList, lookup (sourceListTable, listTableKey)) + if (unbangedSourceList, lookup (noteListTable, listTableKey)) { + while (evt, dequeue (unbangedSourceList)) { + enqueue (sourceList, evt) + } + } + } elsif (eq (level, 1)) { + if (sourceList) { + while (evt, dequeue (sourceList)) { + call reTagNote (add (level, 1), "SOUR", evt) + } + set (sourceList, 0) + } + if (noteList) { + while (evt, dequeue (noteList)) { + call reTagNote (add (level, 1), "TEXT", evt) + } + set (noteList, 0) + } + set (listTableKey, save (concat (rootKey, tag (node)))) + set (sourceList, lookup (sourceListTable, listTableKey)) + set (noteList, lookup (noteListTable, listTableKey)) + set (deletingFlag, and (not (strcmp (tag (node), "NOTE")), + lookup (tNotesToDelete, value (node)))) + } + if (not (deletingFlag)) { + d (level) " " + if (xref (node)) { xref (node) " " } + set (text, value (node)) + if (not (strcmp (tag (node), "NAME"))) { + while (ind, index (text, "_", 1)) { + set (text, + save (concat (concat (substring (text, 1, sub (ind,1)), " "), + substring (text, add (ind, 1), strlen (text))))) + } + "NAME " text "\n" + } elsif (not (strcmp (tag (node), "TITL"))) { + if (titl, lookup (tTitleTransformation, text)) { + "NAME // " text "\n" + if (strlen (titl)) { + d (level) " TITL " titl "\n" + } + } else { + "TITL " text "\n" + } + } elsif (not (strcmp (tag (node), "PLAC"))) { + while (not (strcmp (trim (text, 1), ","))) { + set (text, save (substring (text, 2, strlen (text)))) + } + "PLAC " text "\n" + if (siteList, lookup (siteListTable, listTableKey)) { + while (evt, dequeue (siteList)) { + call reTagNote (add (level, 1), "SITE", evt) + } + } + } elsif (not (strcmp (tag (node), "NOTE"))) { + if (not (strcmp (trim (text, 1), "!"))) { + "TEXT " + } else { + "NOTE " + } + text "\n" + } else { + tag (node) " " text "\n" + if (ageList, lookup (ageListTable, listTableKey)) { + while (evt, dequeue (ageList)) { + call reTagNote (add (level, 1), "AGE", evt) + } + } + if (causeList, lookup (causeListTable, listTableKey)) { + while (evt, dequeue (causeList)) { + call reTagNote (add (level, 1), "CAUS", evt) + } + } + } + } + } + set (listTableKey, save (concat (rootKey, BIRT))) + set (sourceList, lookup (sourceListTable, listTableKey)) + set (noteList, lookup (noteListTable, listTableKey)) + if (and (or (sourceList, noteList), not (sawBIRT))) { + "1 BIRT\n" + if (sourceList) { + while (evt, dequeue (sourceList)) { + call reTagNote (2, "SOUR", evt) + } + } + if (noteList) { + while (evt, dequeue (noteList)) { + call reTagNote (2, "TEXT", evt) + } + } + } +} + +proc reTagNote (relevel, retag, revalueList) { + set (contLevel, add (relevel, 1)) + forlist (revalueList, revalue, rv) { + d (relevel) " " retag " " revalue "\n" + set (relevel, contLevel) + set (retag, "CONT") + } +} diff --git a/reports/pafcompat.ll b/reports/pafcompat.ll new file mode 100644 index 0000000..91705e5 --- /dev/null +++ b/reports/pafcompat.ll @@ -0,0 +1,520 @@ +/* + * @progname pafcompat.ll + * @version 2.0 + * @author Eggert + * @category + * @output Text + * @description + +This LifeLines report program checks a LifeLines database for +compatibility with PAF. I used the Mac PAF manual for field length +specification, and Mac PAF v2.11 for a little testing. + +pafcompat - a LifeLines PAF compatibility checker + by Jim Eggert (eggertj@ll.mit.edu) + Version 1, 2 January 1993 + Version 2, 7 January 1993 added 80 character max for all values + +This program checks: +1. Number (<=3) and length (<=16) of given names. +2. Length of surname. (<=16) +3. Whether something is after the surname. +4. Length of title (<=16) and reference number (<=10). +5. Whether sex is "M" or "F" or " " or not. +6. Number (<=4) and length (<=16) of place fields. +7. Length of date. (<=23) +8. Legal tags at each level, including legal heirarchical structure. +9. No more than one of each tag at each heirarchical level. +10. Values must be less than 80 characters. + +Allowed tags are: + NAME, TITL, SEX, BIRT, CHR, DEAT, BURI, NOTE, FAMS, FAMC, REFN, + BAPL, ENDL, CONT, DATE, PLAC, TEMP, SLGC, HUSB, WIFE, CHIL, + MARR, DIV, SLGS + +This version doesn't parse dates per se, it only checks the length of +the date string. Thus it doesn't know what PAF can understand in a +date string. + +It also doesn't check for valid content of any of the LDS entries. + +*/ + +global(n_place_tokens) +global(longest_token_length) +global(n_givens) +global(post_surname_token) + +proc parse_place(eplace) { + set(n_place_tokens,0) + set(longest_token_length,0) + set(len,1) + set(last_len,0) + while (lt(len,strlen(eplace))) { + set(head,save(trim(eplace,len))) + set(len,add(len,1)) + if (not(strcmp(concat(head,","),trim(eplace,len)))) { + set(n_place_tokens,add(n_place_tokens,1)) + set(this_token_length,sub(len,add(last_len,1))) + set(last_len,len) + if (gt(this_token_length,longest_token_length)) { + set(longest_token_length,this_token_length) + } + } + } +} + + +proc parse_names(pname) { + set(longest_token_length,0) + set(post_surname_token,0) + set(n_givens,0) + set(len,1) + set(last_len,1) + set(sep_level,0) + set(last_name,0) + set(gsep," ") + set(lsep,"/") + while (lt(len,strlen(pname))) { + set(head,save(trim(pname,len))) + set(len,add(len,1)) + if (not(strcmp(concat(head,gsep),trim(pname,len)))) { + if (eq(last_name,0)) { + set(this_token_length,sub(len,add(last_len,1))) + set(last_len,len) + if (gt(this_token_length,longest_token_length)) { + set(longest_token_length,this_token_length) + } + if (or(gt(this_token_length,0),lt(n_givens,3))) { + set(n_givens,add(n_givens,1)) + } + } + } + elsif (ge(last_name,2)) { + set(post_surname_token,1) + } + elsif (not(strcmp(concat(head,lsep),trim(pname,len)))) { + set(this_token_length,sub(len,add(last_len,1))) + set(last_len,len) + if (gt(this_token_length,longest_token_length)) { + set(longest_token_length,this_token_length) + } + if (and(eq(last_name,0),gt(this_token_length,0))) { + set(n_givens,add(n_givens,1)) + } + set(last_name,add(last_name,1)) + } + } +} + + +proc report_indi(person) { + " " key(person) " " name(person) "\n" +} + + +proc report_fam(family) { +t " family " + key(husband(family)) " " name(husband(family)) " & " + key(wife(family)) " " name(wife(family)) "\n" +} + + +proc main() { + list(indi_tags) + list(indi_tag_counts) + list(indi_tag_value) + list(indi_tag_subtags) + list(fam_tags) + list(fam_tag_counts) + list(fam_tag_value) + list(fam_tag_subtags) + list(event_subtags) + list(note_subtags) + list(lds_subtags) + list(slgc_subtag) + list(empty) + list(subtags) + list(subtag_counts) /* as long as the longest subtag list */ + list(subsubtag_counts) /* only for SLGC under family */ + + enqueue(note_subtags,"CONT") + enqueue(event_subtags,"DATE") + enqueue(event_subtags,"PLAC") + enqueue(lds_subtags,"DATE") + enqueue(lds_subtags,"TEMP") + enqueue(slgc_subtag,"SLGC") /* this one has no value! */ + enqueue(subtag_counts,0) + enqueue(subtag_counts,0) + enqueue(subsubtag_counts,0) + enqueue(subsubtag_counts,0) + + enqueue(indi_tags,"NAME") /* 1 */ + enqueue(indi_tag_subtags,empty) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,neg(2)) + enqueue(indi_tags,"TITL") /* 2 */ + enqueue(indi_tag_subtags,empty) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,16) + enqueue(indi_tags,"SEX") /* 3 */ + enqueue(indi_tag_subtags,empty) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,1) + enqueue(indi_tags,"BIRT") /* 4 */ + enqueue(indi_tag_subtags,event_subtags) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,0) + enqueue(indi_tags,"CHR") /* 5 */ + enqueue(indi_tag_subtags,event_subtags) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,0) + enqueue(indi_tags,"DEAT") /* 6 */ + enqueue(indi_tag_subtags,event_subtags) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,0) + enqueue(indi_tags,"BURI") /* 7 */ + enqueue(indi_tag_subtags,event_subtags) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,0) + enqueue(indi_tags,"NOTE") /* 8 */ + enqueue(indi_tag_subtags,note_subtags) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,neg(1)) + enqueue(indi_tags,"FAMC") /* 9 */ + enqueue(indi_tag_subtags,empty) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,neg(2)) + enqueue(indi_tags,"FAMS") /* 10 */ + enqueue(indi_tag_subtags,empty) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,neg(2)) + enqueue(indi_tags,"REFN") /* 11 */ + enqueue(indi_tag_subtags,empty) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,10) + enqueue(indi_tags,"BAPL") /* 12 */ + enqueue(indi_tag_subtags,lds_subtags) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,0) + enqueue(indi_tags,"ENDL") /* 13 */ + enqueue(indi_tag_subtags,lds_subtags) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,0) + enqueue(indi_tags,"SLGC") /* 14 */ + enqueue(indi_tag_subtags,lds_subtags) + enqueue(indi_tag_counts,0) + enqueue(indi_tag_value,0) + + enqueue(fam_tags,"HUSB") /* 1 */ + enqueue(fam_tag_subtags,empty) + enqueue(fam_tag_counts,0) + enqueue(fam_tag_value,neg(2)) + enqueue(fam_tags,"WIFE") /* 2 */ + enqueue(fam_tag_subtags,empty) + enqueue(fam_tag_counts,0) + enqueue(fam_tag_value,neg(2)) + enqueue(fam_tags,"CHIL") /* 3 */ + enqueue(fam_tag_subtags,slgc_subtag) + enqueue(fam_tag_counts,0) + enqueue(fam_tag_value,neg(2)) + enqueue(fam_tags,"MARR") /* 4 */ + enqueue(fam_tag_subtags,event_subtags) + enqueue(fam_tag_counts,0) + enqueue(fam_tag_value,0) + enqueue(fam_tags,"DIV") /* 5 */ + enqueue(fam_tag_subtags,empty) + enqueue(fam_tag_counts,0) + enqueue(fam_tag_value,1) + enqueue(fam_tags,"SLGS") /* 6 */ + enqueue(fam_tag_subtags,lds_subtags) + enqueue(fam_tag_counts,0) + enqueue(fam_tag_value,0) + + print("Checking individuals ") + set(next_print,0) + forindi(person,pnum) { + if (ge(pnum,next_print)) { + print(d(pnum)) print(" ") + set(next_print,add(next_print,100)) + } + forlist(indi_tag_counts,count,cnum) { + setel(indi_tag_counts,cnum,0) + } + fornodes(inode(person),node) { + set(tag_ok,0) + set(node_tag,save(tag(node))) + forlist(indi_tags,vtag,vnum) { + if (not(strcmp(node_tag,vtag))) { + set(tag_ok,vnum) + set(subtags,getel(indi_tag_subtags,vnum)) + set(tag_count,add(getel(indi_tag_counts,vnum),1)) + setel(indi_tag_counts,vnum,tag_count) + set(tag_value,getel(indi_tag_value,vnum)) + } + } + if (not(tag_ok)) { + "Illegal tag " node_tag + call report_indi(person) + } + else { + if (and(gt(tag_count,1), + and(strcmp(node_tag,"NOTE"), + strcmp(node_tag,"FAMS")))) { + "Duplicate " node_tag + call report_indi(person) + } + if (not(tag_value)) { + if (strcmp(value(node),"")) { + "Illegal " node_tag " value " value(node) + call report_indi(person) + } + } + elsif (gt(tag_value,0)) { + if (gt(strlen(value(node)),tag_value)) { + node_tag " too long " value(node) + call report_indi(person) + } + } + elsif (eq(tag_value,neg(2))) { + if (not(strcmp(value(node),""))) { + "Empty " node_tag + call report_indi(person) + } + } + if (lt(tag_value,0)) { + if (gt(strlen(value(node)),80)) { + node_tag " >80 characters " value(node) + call report_indi(person) + } + } + if (eq(tag_ok,3)) { /* "SEX" */ + if (and(and(strcmp(value(node),"M"), + strcmp(value(node),"F")), + strcmp(value(node)," "))) { + "Illegal sex " value(node) + call report_indi(person) + } + } + elsif (eq(tag_ok,1)) { /* "NAME" */ + call parse_names(value(node)) + if (gt(n_givens,3)) { + "Too many given names" + call report_indi(person) + } + if (gt(longest_token_length,16)) { + "Name too long" + call report_indi(person) + } + elsif (eq(longest_token_length,0)) { + "No name" call report_indi(person) + } + if (post_surname_token) { + "Stuff after surname" call report_indi(person) + } + } + forlist(subtags,vstag,vsnum) { + setel(subtag_counts,vsnum,0) + } + fornodes(node,subnode) { + set(subnode_tag,save(tag(subnode))) + set(subtag_count,0) + forlist(subtags,vstag,vsnum) { + if (not(strcmp(subnode_tag,vstag))) { + set(subtag_count,add(getel(subtag_counts,vsnum),1)) + setel(subtag_counts,vsnum,subtag_count) + } + } + if (not(subtag_count)) { + "Illegal subtag " node_tag " " subnode_tag + call report_indi(person) + } + else { + if (and(gt(subtag_count,1), + strcmp(subnode_tag,"CONT"))) { + "Duplicate subtag " subnode_tag " " node_tag + call report_indi(person) + } + if (not(strcmp(subnode_tag,"DATE"))) { + if (gt(strlen(value(subnode)),40)) { + "Date too long " node_tag " " + value(subnode) + call report_indi(person) + } + } + elsif (not(strcmp(subnode_tag,"PLAC"))) { + call parse_place(value(subnode)) + if (gt(n_place_tokens,4)) { + "Too many place levels " node_tag " " + value(subnode) + call report_indi(person) + } + if (gt(longest_token_length,16)) { + "Place too long " node_tag " " + value(subnode) + call report_indi(person) + } + } + elsif (gt(strlen(value(subnode)),80)) { + subnode_tag " >80 characters " value(subnode) + call report_indi(person) + } + } + fornodes(subnode,subsubnode) { + "Illegal node depth " + node_tag " " subnode_tag " " tag(subsubnode) + call report_indi(person) + } + } + } + } + if (not(getel(indi_tag_counts,1))) { + "No name" call report_indi(person) + } + } + print("\nChecking families ") + set(next_print,0) + forfam(family,fnum) { + if (ge(fnum,next_print)) { + print(d(fnum)) print(" ") + set(next_print,add(next_print,100)) + } + forlist(fam_tag_counts,count,cnum) { + setel(fam_tag_counts,cnum,0) + } + fornodes(fnode(family),node) { + set(tag_ok,0) + set(node_tag,save(tag(node))) + forlist(fam_tags,vtag,vnum) { + if (not(strcmp(node_tag,vtag))) { + set(tag_ok,vnum) + set(subtags,getel(fam_tag_subtags,vnum)) + set(tag_count,add(getel(fam_tag_counts,vnum),1)) + setel(fam_tag_counts,vnum,tag_count) + set(tag_value,getel(fam_tag_value,vnum)) + } + } + if (not(tag_ok)) { + "Illegal tag " node_tag + call report_fam(family) + } + else { + if (and(gt(tag_count,1), + strcmp(node_tag,"CHIL"))) { + "Duplicate " node_tag + call report_fam(family) + } + if (not(tag_value)) { + if (strcmp(value(node),"")) { + "Illegal " node_tag " value " value(node) + call report_fam(family) + } + } + elsif (gt(tag_value,0)) { + if (gt(strlen(value(node)),tag_value)) { + node_tag " too long " value(node) + call report_fam(family) + } + } + elsif (eq(tag_value,neg(2))) { + if (not(strcmp(value(node),""))) { + "Empty " node_tag + call report_fam(family) + } + } + if (lt(tag_value,0)) { + if (gt(strlen(value(node)),80)) { + node_tag " >80 characters " value(node) + call report_fam(family) + } + } + if (eq(tag_ok,5)) { /* "DIV" */ + if (strcmp(value(node),"Y")) { + "Illegal divorce value " value(node) + call report_fam(family) + } + } + forlist(subtags,vstag,vsnum) { + setel(subtag_counts,vsnum,0) + } + fornodes(node,subnode) { + set(subnode_tag,save(tag(subnode))) + set(subtag_count,0) + forlist(subtags,vstag,vsnum) { + if (not(strcmp(subnode_tag,vstag))) { + set(subtag_count,add(getel(subtag_counts,vsnum),1)) + setel(subtag_counts,vsnum,subtag_count) + } + } + if (not(subtag_count)) { + "Illegal subtag " node_tag " " subnode_tag + call report_fam(family) + } + else { + if (gt(subtag_count,1)) { + "Duplicate subtag " node_tag " " subnode_tag + call report_fam(family) + } + if (not(strcmp(subnode_tag,"DATE"))) { + if (gt(strlen(value(subnode)),40)) { + "Date too long " + node_tag " " value(subnode) + call report_fam(family) + } + } + elsif (not(strcmp(subnode_tag,"PLAC"))) { + call parse_place(value(subnode)) + if (gt(n_place_tokens,4)) { + "Too many place levels " + node_tag " " value(subnode) + call report_fam(family) + } + if (gt(longest_token_length,16)) { + "Place too long " + node_tag " " value(subnode) + call report_fam(family) + } + } + } + if (not(strcmp(subnode_tag,"SLGC"))) { + forlist(subsubtag_counts,count,cnum) { + setel(subsubtag_counts,cnum,0) + } + fornodes(subnode,subsubnode) { + set(subsubtag_count,0) + set(subsubnode_tag,save(tag(subsubnode))) + forlist(lds_subtags,vstag,vsnum) { + if (not(strcmp(subsubnode_tag,vstag))) { + set(subsubtag_count, + add(getel(subsubtag_counts,vsnum),1)) + setel(subsubtag_counts,vsnum, + subsubtag_count) + } + } + if (not(subsubtag_count)) { + "Illegal subsubtag " + node_tag " " subnode_tag " " + tag(subsubnode) + call report_fam(family) + } + if (gt(subsubtag_count,1)) { + "Duplicate subsubtag " + node_tag " " subnode_tag " " + tag(subsubnode) + call report_fam(family) + } + } + } + else { + fornodes(subnode,subsubnode) { + "Illegal node depth " + node_tag " " subnode_tag " " + tag(subsubnode) + call report_fam(family) + } + } + } + } + } + } +} diff --git a/reports/partition.ll b/reports/partition.ll new file mode 100644 index 0000000..f9bcf7a --- /dev/null +++ b/reports/partition.ll @@ -0,0 +1,228 @@ +/* + * @progname partition.ll + * @version 11 + * @author Eggert + * @category + * @output GEDCOM + * @description + +This program partitions individuals in a database into disjoint +partitions. A partition is composed of people related by one or more +multiples of the following relations: parent, sibling, child, spouse. +There is no known relationship between people in different partitions. + + +partition - a LifeLines database partitioning program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 19 November 1992 (unreleased) + Version 2, 20 November 1992 (completely revamped using queues) + Version 3, 23 November 1992 (added GEDCOM TRLR line, + changed to key-based queues) + Version 4, 1 December 1992 (slight code updates) + Version 5, 9 January 1993 (added birth and death dates to full) + Version 6, 30 January 1993 (now writes multiple GEDCOM output files) + This version requires LifeLines v2.3.3 or later. + Version 7, 21 September1994 (can partition about selected person) + Version 8, 31 March 1995 (allow non-traditional families) + Version 9, 23 February 1999 (changed to depth-first algorithm) + Version 10, 24 September 2001(use cumcount, not forindi loop variable) + Version 11, 7 November 2005 (add header, switch to use gengedcomstrong + change output gedcom files to end in .ged + changes by Stephen A. Dum) + +This program partitions individuals in a database into disjoint +partitions. A partition is composed of people related by one or more +multiples of the following relations: parent, sibling, child, spouse. +There is no known relationship between people in different partitions. +You may select a particular person about whom to construct the largest +partition, or you may do the whole database. The partitions are +written to the report in overview form or full form with the +partitions delimited by a +------------------------------------------------------------ +long line, or in GEDCOM form to separate partition files. The +overview form merely lists the number of people in each partition by +the number of hops from the first person found in the partition. +(They are found in order of the forindi iterator.) The full form +lists each person in each partition, giving the number of hops, key, +name, and birth and death dates (if known). The GEDCOM form writes +the partitions in GEDCOM format. You will be prompted for a root +filename for the GEDCOM files; individual GEDCOM filenames will be of +the form root_filename.p, where p is the partition number. + +Each allowed relationship (parent, sibling, child, spouse) is called a +hop, and the degree of relationship is called the hop count. While +the program is processing, it displays to the screen the number of the +partition it is working on followed by a colon, then the cumulative +number of individuals in that partition for each hop increment. + +*/ + +global(include_new) +global(plist) +global(hlist) +global(mark) +global(pset) +global(pcount) + +global(hopcount) +global(prev_hopcount) +global(prev_pcount) +global(setcount) +global(cumcount) + +proc include(person,hops,setcount,report_type) +{ + if (person) { + set(pkey,key(person)) + if (lookup(mark,pkey)) { + set(include_new,0) + } + else { + set(pkey2,save(pkey)) + enqueue(plist,pkey2) + enqueue(hlist,hops) + insert(mark,pkey2,setcount) + addtoset(pset,person,hops) + incr(pcount) + if (not(mod(pcount,100))) { + print(d(pcount),"/",d(length(plist))," ") + } + set(include_new,1) + if (eq(report_type,1)) { + d(setcount) col(6) d(hops) + col(11) pkey col(18) name(person) + col(48) stddate(birth(person)) + col(62) stddate(death(person)) "\n" + } + } + } +} + +proc main () +{ + table(mark) + list(plist) + list(hlist) + indiset(pset) + + dayformat(0) + monthformat(4) + dateformat(0) + + getindimsg(person_root, + "Enter a person for just one partition, nothing for all partitions:") + getintmsg(report_type, + "Enter 0 for overview, 1 for full, 2 for GEDCOM report:") + if (eq(report_type,2)) { + if (person_root) { + set(prompt,"Enter filename for GEDCOM partition:") + } + else { + set(prompt,"Enter root filename for GEDCOM partitions:") + } + getstrmsg(gedcom_root,prompt) + set(gedcom_root,save(concat(gedcom_root,"_"))) + } + else { set(gedcom_root,0) } + + set(setcount,1) + set(pcount,0) + set(hopcount,1) + set(prev_hopcount,neg(1)) + set(prev_pcount,0) + set(cumcount,0) + if (eq(report_type,1)) { + "Ptn Hops Key Person" + col(48) "Birthdate" col(62) "Deathdate\n" + } + if (person_root) { + call do_one_partition(person_root,report_type,gedcom_root) + } + else { + forindi(person,num) { + call do_one_partition(person,report_type,gedcom_root) + } + if (le(report_type,1)) { + "Entire database contains " d(cumcount) " individual" + if (gt(cumcount,1)) { "s" } + " in " d(sub(setcount,1)) " partition" + if (gt(setcount,2)) { "s" } + ".\n" + } + } +} + +proc do_one_partition(person,report_type,gedcom_root) { + list(hopcountlist) + call include(person,hopcount,setcount,report_type) + if (include_new) { + if (eq(report_type,0)) { + "Ptn Hops Individuals\n" + } + print("\n",d(setcount),": ") + while (pkey,pop(plist)) { + set(person,indi(pkey)) + set(hopcount,pop(hlist)) +/* print(pkey,d(hopcount)) */ + setel(hopcountlist,hopcount,add(1,getel(hopcountlist,hopcount))) + incr(hopcount) + +/* Look for family links and follow them to the families, + then look for links to other individuals in those families. + Nonstandard linking tags may be added here. +*/ + + fornodes(inode(person),node) { + set(t,tag(node)) + if (or(not(strcmp(t,"FAMS")), + not(strcmp(t,"FAMC")))) { + set(family,fam(value(node))) + fornodes(fnode(family),node2) { + set(t,tag(node2)) + if (or(not(strcmp(t,"HUSB")), + not(strcmp(t,"WIFE")), + not(strcmp(t,"CHIL")))) { + call include(indi(value(node2)), + hopcount,setcount,report_type) + } + } + } + } + } + if (eq(report_type,0)) { + forlist(hopcountlist,counter,hops) { + print(d(setcount),d(counter), " ") + } + } + if (le(report_type,1)) { + "Partition " d(setcount) " contains " d(pcount) + " individual" + if (gt(pcount,1)) { "s" } + ".\n" + "------------------------------------------------------------\n" + } + if (eq(report_type,2)) { + newfile(concat(gedcom_root,d(setcount),".ged"),0) + /* output a gedcom header */ + "0 HEAD\n" + "1 SOUR Lifelines\n" + "2 VERS " version() "\n" + "1 DEST ANY\n" + "1 DATE " date(gettoday()) "\n" + "1 SUBM\n" + "1 GEDC\n" + "2 VERS 5.5\n" + "2 FORM LINEAGE-LINKED\n" + "1 CHAR ASCII\n" + gengedcomstrong(pset) + "0 TRLR\n" + } + set(cumcount,add(cumcount,pcount)) + indiset(pset) + set(pcount,0) + set(hopcount,0) + set(prev_hopcount,neg(1)) + set(prev_pcount,pcount) + incr(setcount) + } +} diff --git a/reports/pdesc.ll b/reports/pdesc.ll new file mode 100644 index 0000000..07021c4 --- /dev/null +++ b/reports/pdesc.ll @@ -0,0 +1,144 @@ +/* + * @progname pdesc.ll + * @version 4.3 + * @author Wetmore, Manis, Jones, Eggert, Simms + * @category + * @output Text + * @description + * + * Produces indented descendant list with line wrapping at 78 columns + * (user-specifiable) while maintaining the indentation level. Enhancement + * from version 2 is the addition of user-specified maximum number of + * generations. Version 4 makes the page_width (not 1 less) the limit on + * character a shift inplacement. Also eliminated an extra space at the + * beginning of each line that was not controlled by a left_margin parameter. + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * With modifications by: Cliff Manis + * With modifications by: James P. Jones + * With modifications by: Jim Eggert (unknown spouse bugfix) + * With modifications by: Robert Simms (indented line wrap) Mar '96 + * (max number of generations) Jun '97 + * (line wrap cleaned up) 16 Feb 2000 + * With modifications by: Vincent Broman (header cleanup) 2003-02 + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990. + * + * It will select and produce a descendant report for the person + * selected. Children of each spouse are printed below that spouse. + * + * Descendants report format, which print the date in long format. + * + * Output is an ASCII file. + */ + +global(page_size) +global(tab_size) +global(max_depth) +global(left_margin) + +proc main () { + set(page_size, 78) + set(tab_size, 3) /* extra indentation upon line-wrap */ + set(left_margin, 0) + + getindi(indi) + getintmsg (max_depth, "Maximum number of generations") + set(skip, left_margin) + call pout(0, indi) + + "===============================================" nl() +} + +proc pout(gen, indi) { + set(skip, mul(4,gen)) + col(add(skip, 1)) + set(x, skip) + set(s, concat(d(add(gen, 1)), "--")) + s + set(x, add(x, tab_size)) + set(skip, x) + call outp(indi, skip, x) + set(next, add(1, gen)) + families(indi,fam,sp,num) { + set(skip, add(2,mul(4,gen))) + col(add(skip, 1)) + set(x, skip) + "sp-" + /* Don't try to show a spouse name if none known */ + if (sp) { + set(x, add(x, 4)) + set(skip, x) + call outp(sp, skip, x) + } else { + "Unknown" nl() + } + if (lt(next,max_depth)) { + children(fam, child, no) { + call pout(next, child) + } + } + } +} + +proc outp(indi, skip, x) { + set(s, concat(fullname(indi, 1, 1, 40), + " (", + long(birth(indi)), + " - ", + long(death(indi)), + ")")) + set(x, outline(s, add(tab_size, skip), x)) + "\n" +} + +func outline(text, skip, x) { + if (eq(x, 0)) { + col(add(skip, 1)) + set(x, skip) + } + set(max, sub(page_size, x)) + if (gt(strlen(text), max)) { + set(space, breakit(text, max)) + if (eq(space, 0)) { + if (eq(x, skip)) { + set(text, strsave(text)) + substring(text, 1, sub(max, 1)) "-" + set(x, 0) + set(text, substring(text, max, strlen(text))) + set(x, outline(text, skip, x)) + } else { + set(x, 0) + set(x, outline(text, skip, x)) + } + } else { /* space gt 0 */ + set(text, strsave(text)) + substring(text, 1, sub(space, 1)) + set(x, 0) + set(text, strsave(substring(text, add(space, 1), strlen(text)))) + while(eqstr(" ", substring(text, 1, 1))) { /* strip leading spaces */ + set(text, strsave(substring(text, 2, strlen(text)))) + } + set(x, outline(text, skip, x)) + } + } else { + text + set(x, add(x, strlen(text))) + } + return(x) +} + +func breakit(text, max) { + set(space, 0) + set(occ, 1) + set(next, index(text, " ", occ)) + incr(occ) + while ( and(le(next, add(max, 1)), ne (next, 0))) { + set(space, next) + set(next, index(text, " ", occ)) + incr(occ) + } + return(space) +} diff --git a/reports/ped.ll b/reports/ped.ll new file mode 100644 index 0000000..8956725 --- /dev/null +++ b/reports/ped.ll @@ -0,0 +1,124 @@ +/* + * @progname ped.ll + * @version 1996-08-09 + * @author Bill.Alford@anu.edu.au + * @category + * @output HTML + * @description + + html pedigree/ancestral chart part of an individuals report. + This coding can be generalised to print many generations back but + for html purposes we only need go back 2 generations because the + width of the page becomes far too big otherwise. In this case I've + hard coded out what the generalised coding would look like. I've + used ideas from the output of the gedcom2html program. + + Typical output from this reports looks like: + +
    +                     _William Alford___
+ _William Alford____|
+|                   |_Elizabeth Shore__
+|
+|--William Alford
+|
+|                    _Robert Goldsbrough__
+|_Jane Goldsbrough__|
+                    |_Hannah Browne_______
+
    +

    + + Bill.Alford@anu.edu.au 9 Aug 1996 */ + +global(line1) /* position on line 1 */ +global(line2) /* position on line 2 */ +global(line3) /* position on line 3 */ +global(line5) /* position on line 5 */ +global(line6) /* position on line 6 */ +global(line7) /* position on line 7 */ +global(nstrngff) /* father's fathers name string */ +global(nstrngf) /* father's name string */ +global(nstrngfm) /* father's mothers name string */ +global(nstrngi) /* individual's name string */ +global(nstrngmf) /* mother's father name string */ +global(nstrngm) /* mother's name string */ +global(nstrngmm) /* mother's mother name string */ + +proc ped(indi, href_table) +{ + set(nstrngff,save(name(father(father(indi)),0))) + set(nstrngf,save(name(father(indi),0))) + set(nstrngfm,save(name(mother(father(indi)),0))) + set(nstrngi,save(name(indi,0))) + set(nstrngmf,save(name(father(mother(indi)),0))) + set(nstrngm,save(name(mother(indi),0))) + set(nstrngmm,save(name(mother(mother(indi)),0))) + set(line1,strlen(nstrngff)) + set(line2,strlen(nstrngf)) + set(line3,strlen(nstrngfm)) + set(line5,strlen(nstrngmf)) + set(line6,strlen(nstrngm)) + set(line7,strlen(nstrngmm)) + set(dif1,0) + set(dif2,0) + set(dif3,0) + set(dif5,0) + set(dif6,0) + set(dif7,0) + if (ne(line2,line6)) { + if (gt(line2,line6)) { set(dif6,sub(line2,line6)) } + else { set(dif2,sub(line6,line2)) } + } + if (ne(line1,line3)) { + if (gt(line1,line3)) { set(dif3,sub(line1,line3)) } + else { set(dif1,sub(line3,line1)) } + } + if (ne(line5,line7)) { + if (gt(line5,line7)) { set(dif7,sub(line5,line7)) } + else { set(dif5,sub(line7,line5)) } + } + set(diff1,dif1) + set(diff2,dif2) + set(diff3,dif3) + set(diff5,dif5) + set(diff6,dif6) + set(diff7,dif7) + +/* Output the html */ + + "
    \n"
+        col(add(line2,6,dif2)) call ped_ahref(father(father(indi)),href_table)
+        "_" nstrngff "__"
+        while (gt(diff1,0)) { "_" decr(diff1) }
+        "" nl()
+        " " call ped_ahref(father(indi),href_table) "_" nstrngf "__"
+        while (gt(diff2,0)) { "_" decr(diff2) }
+        "|" nl()
+        "|" col(add(line2,5,dif2)) "|"
+        call ped_ahref(mother(father(indi)),href_table) "_" nstrngfm "__"
+        while (gt(diff3,0)) { "_" decr(diff3) }
+        "" nl()
+        "|" nl()
+        "|--" call ped_ahref(indi,href_table) nstrngi "" nl()
+        "|" nl()
+        "|" col(add(line6,6,dif6))
+        call ped_ahref(father(mother(indi)),href_table) "_" nstrngmf "__"
+        while (gt(diff5,0)) { "_" decr(diff5) }
+        "" nl()
+        "|" call ped_ahref(mother(indi),href_table) "_" nstrngm "__"
+        while (gt(diff6,0)) { "_" decr(diff6) }
+        "|" nl()
+        col(add(line6,5,dif6)) "|"
+        call ped_ahref(mother(mother(indi)),href_table) "_" nstrngmm "__"
+        while (gt(diff7,0)) { "_" decr(diff7) }
+        "" nl()
+        "
    \n" + "

    \n" +} + +proc ped_ahref(indi,href_table) +{ + "" +} diff --git a/reports/pedigree.ll b/reports/pedigree.ll new file mode 100644 index 0000000..978dc76 --- /dev/null +++ b/reports/pedigree.ll @@ -0,0 +1,77 @@ +/* + * @progname pedigree.ll + * @version none + * @author Wetmore, Manis, Hume Smith + * @category + * @output Text + * @description + * + * Select and produce an ancestor report for the person selected. + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * With modifications by: Cliff Manis + * more by Hume Smith (who refuses to learn YACL and so may do odd things): + * - optional depth limit + * - draws helpful lines + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * name is from pedigreel (long format) + * + * Output is an ASCII file, and will probably need to be printed + * using 132 column format. Sample (depth 2): + + +! + +-Ivan Cottnam "Cott" SMITH (10 Jan 1932- ) #2 + | +! ++-Hume Cottnam Llewellyn SMITH (18 Dec 1966- ) #1 + | +! + +-Gail Ida HUME (26 Mar 1943- ) #3 + +! + + * ! indicates more is known beyond that depth. + */ + +proc main () +{ + getindi(indi) + getintmsg(depth,"How many generations (-1 for all)?") + dayformat(0) + monthformat(4) + dateformat(0) + call pedigree(1, depth, indi, "", " ", " ") +} + +proc pedigree (ah, depth, indi, indent, above, below) +{ + if (eq(depth,0)) { + indent "+!" nl() + } else { + if (par, father(indi)) { + call pedigree(mul(2,ah), sub(depth,1), par, concat(indent, above), " ", "| ") + } + + indent "+-" + fullname(indi,1,1,50) + set(flag,0) + set(birth," ") + set(death," ") + if (evt, birth(indi)) { + set(flag,1) + set(birth, stddate(evt)) + } + if (evt, death(indi)) { + set(flag,1) + set(death, stddate(evt)) + } + if (flag) { " (" birth "-" death ")" } + " #" d(ah) nl() + + if (par, mother(indi)) { + call pedigree(add(1,mul(2,ah)), sub(depth,1), par, concat(indent, below), "| ", " ") + } + } +} + +/* eof */ diff --git a/reports/pedigree_html.ll b/reports/pedigree_html.ll new file mode 100644 index 0000000..3ba8442 --- /dev/null +++ b/reports/pedigree_html.ll @@ -0,0 +1,63 @@ +/* + * @progname pedigree_html.ll + * @version 1.3 + * @author Scott McGee (smcgee@microware.com) + * @category + * @output HTML + * @description + * + * Select and produce an ancestor report for the person selected. + * + * @(#)pedigree_html.ll 1.3 10/4/95 + * + * By Scott McGee (smcgee@microware.com) + * Based on pedigreel by Tom Wetmore, ttw@cbnewsl.att.com + * And Cliff Manis + */ + +include("cgi_html.li") + + +proc main () { + call set_cgi_html_globals() + + set (nl,nl()) + getindi(indi) + + call do_chart_head(indi, "Pedigree") + "
    \n"
+  call pedigree(0, indi)
+  "
    \n" + call do_tail(indi) +} + +proc pedigree (level, indi) { + set(has_parent, or(father(indi), mother(indi))) + if(and(lt(level, 4), has_parent)) { + set(par, father(indi)) + call pedigree(add(1,level), par) + } + if(indi) { + col(mul(4,level)) + href(indi, "Pedigree") + if (evt, birth(indi)) { + ", b. " + if(gt(level, 3)) { + short(evt) + } + else { + long(evt) + } + } + nl() + } + else { + col(mul(4,level)) + "(Spouse not known)" + nl() + } + if(and(lt(level, 4), has_parent)) { + set(par, mother(indi)) + call pedigree(add(1,level), par) + } +} diff --git a/reports/pedigreel.ll b/reports/pedigreel.ll new file mode 100644 index 0000000..3fedbed --- /dev/null +++ b/reports/pedigreel.ll @@ -0,0 +1,87 @@ +/* + * @progname pedigreel.ll + * @version 1.0 + * @author Wetmore, Manis + * @category + * @output Text, 132 cols + * @description + * + * select and produce a ancestor report for the person selected. + * Ancestors report format, which print the event in long format. + * Output is an ASCII file, and will probably need to be printed + * using 132 column format. + * + * pedigreel + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * With modifications by: Cliff Manis + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * name is from pedigreel (long format) + * + * An example of the output may be seen at end of this report. + */ + +proc main () +{ + set (nl,nl()) + getindi(indi) + call pedigree(0, 1, indi) + nl() +} + +proc pedigree (in, ah, indi) +{ + if (par, father(indi)) { + call pedigree(add(1,in), mul(2,ah), par) + } + print(name(indi)) print(nl()) + col(mul(8,in)) fullname(indi,1,1,50) + if (evt, birth(indi)) { ", b. " long(evt) } + " (" d(ah) ")" nl() + if (par, mother(indi)) { + call pedigree(add(1,in), add(1,mul(2,ah)), par) + } +} + +/* Sample output of this report. 132 Column Format. + + This report was requested for "Fuller Ruben Manes". + + + John MANESS, b. ca 1770-1780 (16) + Samuel P. MANES, b. ca 1780-90 (8) + William Thomas MANES, b. 26 Nov 1828, Hamblen, Tennessee (4) + Fanny (MANES), b. ca 1790-1800 (9) + William Bowers MANES, b. 6 Jan 1868, Hamblen Co, TN ? (2) + James BOWERS (20) + Anderson BOWERS, b. ca 1803, TN (10) + Martha (21) + Martha A. BOWERS, b. 14 APR 1829, TN (5) + William COWAN (88) + Samuel COWAN (44) + Mrs. (COWAN) (89) + Christopher Columbus COWAN, b. About 1765 (22) + Mrs (COWAN) (45) + Lurina Viney "Vina" COWAN, b. 1808, TN (11) + Mary BOYD, b. 1772, Boyd's Creek, Sevier Co, TN (23) +Fuller Ruben MANES, b. 19 Nov 1902, Union Valley, Sevier Co, TN (1) + Henry B. CANTER, b. ca 1820, VA (12) + James H. CANTER, b. ca 1847, Claiborne Co, TN (6) + Polina (CANTER), b. ca 1822 (13) + Cordelia "Corda" F. CANTER, b. 7 Dec 1869, Jonesboro, Washington Co, TN (3) + James WHITEHORN, b. VA (14) + Martha Marie WHITEHORN, b. 22 DEC 1846, Washington Co, TN ? (7) + Thomas FOSTER (60) + Kennedy "Kan" Powell FOSTER, b. 1814 (30) + Martha "Patsy" FOSTER, b. Tennessee (15) + David CASON (62) + Rebecca KERSAWN, b. 1818, NC (31) + Mary (63) + +*/ + +/* End of Report */ + diff --git a/reports/pedigreelhs.ll b/reports/pedigreelhs.ll new file mode 100644 index 0000000..4317a67 --- /dev/null +++ b/reports/pedigreelhs.ll @@ -0,0 +1,75 @@ +/* + * @progname pedigreelhs.ll + * @version none + * @author Wetmore, Manis, Hume Smith + * @category + * @output Text + * @description + * + * Select and produce an ancestor report for the person selected. + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * With modifications by: Cliff Manis + * more by Hume Smith (who refuses to learn YACL and so may do odd things): + * - optional depth limit + * - draws helpful lines + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * name is from pedigreel (long format) + * + * Output is an ASCII file, and will probably need to be printed + * using 132 column format. Sample (depth 2): + + +! + +-Ivan Cottnam "Cott" SMITH (10 Jan 1932- ) #2 + | +! ++-Hume Cottnam Llewellyn SMITH (18 Dec 1966- ) #1 + | +! + +-Gail Ida HUME (26 Mar 1943- ) #3 + +! + + * ! indicates more is known beyond that depth. + */ + +proc main () +{ + getindi(indi) + getintmsg(depth,"How many generations (-1 for all)?") + dayformat(0) + monthformat(4) + dateformat(0) + call pedigree(1, depth, indi, "", " ", " ") +} + +proc pedigree (ah, depth, indi, indent, above, below) +{ + if (eq(depth,0)) { + indent "+!" nl() + } else { + if (par, father(indi)) { + call pedigree(mul(2,ah), sub(depth,1), par, concat(indent, above), " ", "| ") + } + + indent "+-" + fullname(indi,1,1,50) + set(flag,0) + set(birth," ") + set(death," ") + if (evt, birth(indi)) { + set(flag,1) + set(birth, stddate(evt)) + } + if (evt, death(indi)) { + set(flag,1) + set(death, stddate(evt)) + } + if (flag) { " (" birth "-" death ")" } + " #" d(ah) nl() + + if (par, mother(indi)) { + call pedigree(add(1,mul(2,ah)), sub(depth,1), par, concat(indent, below), "| ", " ") + } + } +} diff --git a/reports/pedtex/Makefile.am b/reports/pedtex/Makefile.am new file mode 100644 index 0000000..f8911f1 --- /dev/null +++ b/reports/pedtex/Makefile.am @@ -0,0 +1,17 @@ +# This makefile is for the lifelines reports + +AUTOMAKE_OPTIONS = no-dependencies + +# LL_REPORTS is to hold the actual report files +# (included files go in a different target below) +LL_REPORTS = pedtex.ll + +# OTHER_REPORTS is to hold included files besides actual report files +# (eg, supporting files, graphics, included files) +OTHER_REPORTS = pedtex.readme setup.tex tree.tex + +pkg_REPORTS = $(LL_REPORTS) $(OTHER_REPORTS) + +subreportdir = $(pkgdatadir)/pedtex +subreport_DATA = $(pkg_REPORTS) +dist_subreport_DATA = $(pkg_REPORTS) diff --git a/reports/pedtex/pedtex.ll b/reports/pedtex/pedtex.ll new file mode 100644 index 0000000..6960cc3 --- /dev/null +++ b/reports/pedtex/pedtex.ll @@ -0,0 +1,65 @@ +/* + * @progname pedtex.ll + * @version 1.0 + * @author Eric Majani + * @category + * @output TeX + * @description + * + * generates TeX files for pedigree charts + */ + +global(depth) +global(level) + +proc main () +{ + getindi(indi) + set(prompt,"Enter number of generations desired") + getintmsg(depth,prompt) + "\\input setup" nl() + "\\tree " nl() + set(level,1) + call pedout(indi) + "\\endtree " nl() + "\\end " nl() + +} + +proc printindi(indi) +{ + "{\\bf " name(indi) "}" nl() + if (e, birth(indi)) { " b. " short(e) nl() } + if(male(indi)) + { + spouses(indi,sp,fam,num) + { + if(e,marriage(fam)) { " m. " short(e) nl() } + } + } + if (e, death(indi)) { " d. " short(e) nl() } +} + +proc pedout(indi) +{ + call printindi(indi) + set(level,add(level,1)) + if(le(level,depth)) + { + if (par,father(indi)) + { + set(fath,father(indi)) + "\\subtree " nl() + call pedout(fath) + "\\endsubtree " nl() + } + if (par,mother(indi)) + { + set(moth,mother(indi)) + "\\subtree " nl() + call pedout(moth) + "\\endsubtree " nl() + } + } + set(level,sub(level,1)) +} diff --git a/reports/pedtex/pedtex.readme b/reports/pedtex/pedtex.readme new file mode 100644 index 0000000..76dae99 --- /dev/null +++ b/reports/pedtex/pedtex.readme @@ -0,0 +1,55 @@ +From: "(Eric Majani)" +Subject: pedtex: generating TeX files for pedigree charts + +Introducing PEDTEX: a program which generates a TeX file that can then be used + to +produce a Pedigree Chart in PostScript format. All you need is to have TeX +installed on your machine, and three files included here: pedtex, tree.tex, +and setup.tex. + +Good luck! Feel free to ask me questions about pedtex and the \tree, \endtree, +\subtree, \endsubtree TeX macros, but please, no questions +about TeX. Ask your local TeX wizard for Tex-specific questions. Thanks. + +----------------------- Remarks on the use of pedtex ------------------------- + +1. You can change the prinindi procedure to anything you like. The example + given here is just that, an example. + +2. Beware of the use of TeX special characters, and their interpretation + by Lifelines (i.e. \' will be changed to /'): however I already + found out that \& is not modified by LifeLines. + +3. pedtex creates a basic TeX file which can always be modified to suit your + tastes, additions of special TeX characters. The nice thing about pedtex + is that it puts all the genealogy information from the database. You can + therefore include the pedigree chart in a TeX document (if you're writing + a book on your family for example). + +4. The steps to produce a Postscript file (or a .dvi file for visualization + by xdvi for example): + + 4.1 Make sure the files setup.tex and tree.tex (and pedtex) are in the + current directory + + 4.2 Run lines + + 4.3 Use the report generation menu and run the pedtex program. Make sure that + your output file is of the type: filename.tex + The integer to enter is the number of generations desired. + + 4.4 Quit lines + + 4.5 Run tex on filename.tex: tex filename + + 4.6 Run dvips (or xdvi for visualization) on filename.dvi: dvips filename + + 4.7 Print or visualize the PostScript file filename.ps + + +5. Do not modify the tree.tex file, unless you are a TeX programming expert + +6. The setup.tex file however should be modified to your taste. You should + however have no problem with the one I provide (no guarantees though). + +7. The files that follow are: tree.tex, setup.tex diff --git a/reports/pedtex/setup.tex b/reports/pedtex/setup.tex new file mode 100644 index 0000000..17f528d --- /dev/null +++ b/reports/pedtex/setup.tex @@ -0,0 +1,7 @@ +\hsize=10in +\vsize=7.5in +\parindent=20pt +\hoffset=-0.8in +\voffset=-0.8in +\nopagenumbers +\input tree diff --git a/reports/pedtex/tree.tex b/reports/pedtex/tree.tex new file mode 100644 index 0000000..e080b4e --- /dev/null +++ b/reports/pedtex/tree.tex @@ -0,0 +1,172 @@ +% Tree -- a macro to make aligned (horizontal) trees in TeX +% +% Input is of the form +% \tree +% item +% \subtree +% \leaf{item} +% . +% . +% . +% \endsubtree +% \subtree +% . +% . +% . +% \endsubtree +% \endsubtree +% \endtree +% +% Nesting is to any level. \leaf is defined as a subtree of one item: +% \def\leaf#1{\subtree#1\endsubtree}. +% +% A structure: +% \subtree +% item_part1 +% item_part2 +% . +% . +% . +% +% will print item_part2 directly below item_part1 as a single item +% as if they were in a \box. +% +% The macro is a 3-pass macro. On the first pass it sets up a data +% structure from the \subtree ... \endsubtree definitions. On the second pass +% it recursively calculates the width of each level of the tree. On the third +% pass it sets up the boxes, glue and rules. +% +% By David Eppstein, TUGboat, vol. 6 (1985), no. 1, pp. 31--35. +% Transcribed by Margaret Kromer (peg), Feb., 1986. +% +% Permission to add to Source Forge repository granted by David Eppstein +% (eppstein@ics.uci.edu) on 14 Nov 2000. In his email, he said: +% +% Sure. The original TeX source for the article is online, at +% http://www.ics.uci.edu/~eppstein/pubs/p-ttree.tex.Z, if that helps. +% +% +% Pass 1 +% At the end of pass 1, the tree is coded as a nested collection of \hboxes +% and \vboxes. +\newbox\treebox\newcount\treeboxcnt +\def\tree{\message{Begin tree}\treeboxcnt=1\global\setbox\treebox=\boxtree} +\def\subtree{\ettext \advance\treeboxcnt by 1 \boxtree} +\def\leaf#1{\subtree#1\endsubtree} +\def\endsubtree{\ettext \egroup \advance\treeboxcnt-1{}% + \ifnum\treeboxcnt=-1 \treeerrora\fi} +\def\endtree{\endsubtree \ifnum\treeboxcnt>0 \treeerrorb\fi% + \settreesizes \typesettree \message{-- end tree}} +% Error messages for unbalanced tree +\def\treeerrora{\errhelp=\treeerrorahelp% + \errmessage{Unbalanced tree -- too many endsubtrees}} +\newhelp\treeerrorahelp{There are more subtrees closed than opened} +\def\treeerrorb{\errhelp=\treeerrorbhelp% + \errmessage{Unbalanced tree -- not enough endsubtrees}} +\newhelp\treeerrorbhelp{Not all the subtrees of the tree are closed. +If you continue, you'll get some mysterious secondary errors.} +% Set up \vbox containing root of tree +\newif\iftreetext\treetextfalse % Whether still aligning text +\def\boxtree{\hbox\bgroup % Start outer box of tree or subtree + \baselineskip 2.5ex % Narrow line spacing slightly + \tabskip 0pt % No spurious glue in alignment + \vbox\bgroup % Start inner text \vbox + \treetexttrue % Remember for \ettext + \let\par\crcr \obeylines % New line breaks without explicit \cr + \halign\bgroup##\hfil\cr} % Start alignment with simple template +\def\ettext{\iftreetext % Are we still in inner text \vbox? + \crcr\egroup \egroup \fi} % Yes, end alignment and box +% Pass 2 +% Recursively calculate widths of tree with \setsizes; keep results in +% \treesizes; \treewidth contains total width calculated so far. \treeworkbox +% is workspace containing subtree being sized. +\newbox\treeworkbox +\def\cons#1#2{\edef#2{\xmark #1#2}} % Add something to start of list +\def\car#1{\expandafter\docar#1\docar} % Take first element of list +\def\docar\xmark#1\xmark#2\docar{#1} % ..by ignoring rest in expansion +\def\cdr#1{\expandafter\docdr#1\docdr#1}% Similarly, drop first element +\def\docdr\xmark#1\xmark#2\docdr#3{\def#3{\xmark #2}} +\def\xmark{\noexpand\xmark} % List separator expands to self +\def\nil{\xmark} % Empty list is just separator +\def\settreesizes{\setbox\treeworkbox=\copy\treebox% + \global\let\treesizes\nil \setsizes} +\newdimen\treewidth % Width of this part of the tree +\def\setsizes{\setbox\treeworkbox=\hbox\bgroup% Get a horiz list as a workspace + \unhbox\treeworkbox\unskip % Take tree, unpack it into horiz list + \inittreewidth % Get old width at this level + \sizesubtrees % Recurse through all subtrees + \sizelevel % Now set width from remaining \vbox + \egroup} % All done, finish our \hbox +\def\inittreewidth{\ifx\treesizes\nil % If this is the first at this level + \treewidth=0pt % ..then we have no previous max width + \else \treewidth=\car\treesizes % Otherwise take old max level width + \global\cdr\treesizes % ..and advance level width storage + \fi} % ..in preparation for next level. +\def\sizesubtrees{\loop % For each box in horiz list (subtree) + \setbox\treeworkbox=\lastbox \unskip % ..pull it off list and flush glue + \ifhbox\treeworkbox \setsizes % If hbox, it's a subtree - recurse + \repeat} % ..and loop; end loop on tree text +\def\sizelevel{% + \ifdim\treewidth<\wd\treeworkbox % If greater than previous maximum + \treewidth=\wd\treeworkbox \fi % Then set max to new high + \global\cons{\the\treewidth}\treesizes}% In either case, put back on list +% Pass 3 +% Recursively typeset tree with \maketree by adding an \hbox containing +% a subtree (in \treebox) to the horizontal list. +\newdimen\treeheight % Height of this part of the tree +\newif\ifleaf % Tree has no subtrees (is a leaf) +\newif\ifbotsub % Bottom subtree of parent +\newif\iftopsub % Top subtree of parent +\def\typesettree{\medskip\maketree\medskip} % Make whole tree +\def\maketree{\hbox{\treewidth=\car\treesizes % Get width at this level + \cdr\treesizes % Set up width list for recursion + \makesubtreebox\unskip % Set \treebox to text, make subtrees + \ifleaf \makeleaf % No subtrees, add glue + \else \makeparent \fi}} % Have subtrees, stick them at right +{\catcode`@=11 % Be able to use \voidb@x +\gdef\makesubtreebox{\unhbox\treebox % Open up tree or subtree + \unskip\global\setbox\treebox\lastbox % Pick up very last box + \ifvbox\treebox % If we're already at the \vbox + \global\leaftrue \let\next\relax % ..then this is a leaf + \else \botsubtrue % Otherwise, we have subtrees + \setbox\treeworkbox\box\voidb@x % Init stack of processed subs + \botsubtrue \let\next\makesubtree % ..and call \maketree on them + \fi \next}} % Finish up for whichever it was +\def\makesubtree{\setbox1\maketree % Call \maketree on this subtree + \unskip\global\setbox\treebox\lastbox % Pick up box before it + \treeheight=\ht1 % Get height of subtree we made + \advance\treeheight 2ex % Add some room around the edges + \ifhbox\treebox \topsubfalse % If picked up box is a \vbox, + \else \topsubtrue \fi % ..this is the top, otherwise not + \addsubtreebox % Stack subtree with the rest + \iftopsub \global\leaffalse % If top, remember not a leaf + \let\next\relax \else % ..(after recursion), set return + \botsubfalse \let\next\makesubtree % Otherwise, we have more subtrees + \fi \next} % Do tail recursion or return +\def\addsubtreebox{\setbox\treeworkbox=\vbox{\subtreebox\unvbox\treeworkbox}} +\def\subtreebox{\hbox\bgroup % Start \hbox of tree and lines + \vbox to \treeheight\bgroup % Start \vbox for vertical rules + \ifbotsub \iftopsub \vfil % If both bottom and top subtree + \hrule width 0.4pt % ..vertical rule is just a dot + \else \treehalfrule \fi \vfil % Bottom gets half-height rule + \else \iftopsub \vfil \treehalfrule % Top gets half-height the other way + \else \hrule width 0.4pt height \treeheight \fi\fi % Middle, full height + \egroup % Finish vertical rule \vbox + \treectrbox{\hrule width 1em}\hskip 0.2em\treectrbox{\box1}\egroup} +\def\treectrbox#1{\vbox to \treeheight{\vfil #1\vfil}} +\def\treehalfrule{\dimen\treeworkbox=\treeheight % Get total height + \divide\dimen\treeworkbox 2% + \advance\dimen\treeworkbox 0.2pt % Divide by two, add half horiz height + \hrule width 0.4pt height \dimen\treeworkbox}% Make a vertical rule that high +\def\makeleaf{\box\treebox} % Add leaf box to horiz list +\def\makeparent{\ifdim\ht\treebox>% + \ht\treeworkbox % If text is higher than subtrees + \treeheight=\ht\treebox % ..use that height + \else \treeheight=\ht\treeworkbox \fi % Otherwise use height of subtrees + \advance\treewidth-\wd\treebox % Take remainder of level width + \advance\treewidth 1em % ..after accounting for text and glue + \treectrbox{\box\treebox}\hskip 0.2em % Add text, space before connection +\treectrbox{\hrule width \treewidth}% + \treectrbox{\box\treeworkbox}} % Add \hrule, subs +% No idea what \spouse is supposed to do... wasn't included +\def\spouse{\bf} diff --git a/reports/places.ll b/reports/places.ll new file mode 100644 index 0000000..7c0c9f9 --- /dev/null +++ b/reports/places.ll @@ -0,0 +1,153 @@ +/* + * @progname places.ll + * @version 5.0 + * @author Olsen, Eggert + * @category + * @output Text + * @description + * + * Prints out the value of all the lines in your database with the PLAC tag, + * along with enough information so you can find the line easily. The purpose + * of this report is so you can find all the places that seem wrong + * (misspelled, ambiguous, incomplete [left out the county name], etc), and + * double-check them or correct them. + +places + +Version 1, 25 Nov 1992 by David Olsen (dko@cs.wisc.edu) +Version 2, 3 Dec 1992 by Jim Eggert (eggertj@atc.ll.mit.edu) + (Changed numbers to real key values.) +Version 3, 5 Feb 1993 by David Olsen (dko@cs.wisc.edu) + (Prints place names in reverse order. Runs faster.) +Version 4, 13 Feb 1993 by Jim Eggert (eggertj@atc.ll.mit.edu) + (Prints place names in regular or reverse order.) +Version 5, 1 Sep 1993 by Jim Eggert (eggertj@atc.ll.mit.edu) + (Fixes a bug involving families with no parents) + +Report program for LifeLines v. 2.3.3. + +Prints out the value of all the lines in your database with the PLAC +tag, along with enough information so you can find the line easily. +The places are printed either exactly as they appear in the database +(e.g. Madison, Dane, Wisconsin) or in reverse order (e.g. Wisconsin, +Dane, Madison). The purpose of this report is so you can find all the +places that seem wrong (mispelled, ambiguous, incomplete, etc.), and +double-check them or correct them. + +The places are printed out in the order that they appear in the +database, so the report is not very useful in its native form. To +make it more useful, run the output file through the program 'sort', +making it much easier to spot incorrect names. For example, if you +have 100 entries within Middlesex County, Massachusetts, but in one of +them you mispelled Middlesex as Middlesx, it will be very easy to spot +this in the sorted output. + +If the place name is part of an individual record, it is followed by +the key and name of the individual and by the hierarchy of tags +between the INDI tag and the PLAC tag (usually just a single tag, such +as BIRT or DEAT). If the place name is part of a family record, it is +followed by the family key, the key and name of the husband (or wife +if there is no husband, or first child if there is no parent), the +relationship in the family of that person, and the hierarchy of tags +between the FAM tag and the PLAC tag (usually just the single tag +MARR). + +Some sample output (in reverse order) that has already been sorted: + +California, Los Angeles, Long Beach | I130 Newel Knight YOUNG | DEAT +California, Los Angeles, Los Angeles | I6811 Gunella CHRISTIANSEN | DEAT +California, Los Angeles, Newhall | I836 Cena Elizabeth HAWKINS | DEAT +California, Los Angeles, San Fernando | I836 Cena Elizabeth HAWKINS | BURI +California, Napa, Napa | I1439 Cora Anna BEAL | DEAT +California, Riverside, Riverside | F328 (I1370 Benjamin BERRY, husb) | MARR +California, San Bernadino, | I6843 Emily LUDVIGSEN | BURI +California, San Bernadino, San Bernadino | I1364 Francis LYTLE | DEAT +California, San Bernadino, San Bernadino | I1365 Sophronia Jane MILLETT | DEAT +California, San Bernadino, San Bernadino | I1367 Nancy Ellen LYTLE | BIRT +California, San Bernadino, San Bernadino | I1369 Hulda Lorene LYTLE | BIRT +California, San Bernadino, San Bernadino | I694 Mary Ann HENRY | BIRT +California, Shasta, Redding | I1378 Eliza Lemira MILLETT | DEAT +California, Whittier, Rose Hills | I2318 Zetta Fern MORTENSEN | BURI +Canada, Nova Scotia, Cape Breton | F184 (I749 Ezra KING, husb) | MARR +Canada, Nova Scotia, Cape Breton | I749 Ezra KING | DEAT + + +*/ + +proc main() +{ + list(tag_stack) + list(place_names) + + set(reverse,0) + getstrmsg(yesno,"Reverse place name components? (y/n)") + if (strlen(yesno)) { + if (not(strcmp(upper(trim(yesno,1)),"Y"))) { set(reverse,1) } + } + print("Printing all places.\n") + print("Be patient. This may take a while.\n") + + forindi (person, id) { + + traverse (inode(person), node, level) { + + setel(tag_stack, add(level, 1), tag(node)) + + if (eq(strcmp(tag(node), "PLAC"), 0)) { + extractplaces(node, place_names, num_places) + if (reverse) { + pop(place_names) + while (p, pop(place_names)) { ", " p } + } + else { + dequeue(place_names) + while (p, dequeue(place_names)) { ", " p } + } + " | " key(person) " " name(person) " |" + forlist (tag_stack, tag, tag_number) { + if (and(gt(tag_number, 1), le(tag_number, level))) { " " tag } + } + "\n" + } + } + } + + forfam (fam, fnum) { + + traverse (fnode(fam), node, level) { + setel(tag_stack, add(level, 1), tag(node)) + + if (eq(strcmp(tag(node), "PLAC"), 0)) { + extractplaces(node, place_names, num_places) + if (reverse) { + pop(place_names) + while (p, pop(place_names)) { ", " p } + } + else { + dequeue(place_names) + while (p, dequeue(place_names)) { ", " p } + } + " | " key(fam) + " (" + if (person,husband(fam)) { set(relation,", husb") } + elsif (person,wife(fam)) { set(relation,", wife") } + else { + children(fam,child,cnum) { + if (eq(cnum,1)) { + set(person,child) + set(relation,", chil") + } + } + } + if (person) { + key(person) " " name(person) relation + } + ") |" + forlist (tag_stack, tag, tag_number) { + if (and(gt(tag_number, 1), le(tag_number, level))) { " " tag } + } + "\n" + } + } + } +} diff --git a/reports/pointers.ll b/reports/pointers.ll new file mode 100644 index 0000000..3d243b7 --- /dev/null +++ b/reports/pointers.ll @@ -0,0 +1,126 @@ +/* + * @progname pointers + * @version 1.0 + * @author Chandler + * @category + * @output Text + * @description + +Test a database for reciprocity of pointers between persons and families. + +Report any failures, primarily the following: + + Person Inn is a spouse/child in Fnn, but Fnn has no corresponding pointer. + Family Fnn has HUSB/WIFE/CHIL Inn, but Inn has no corresponding pointer. + +Some failures are supposed to be impossible, but are covered here +nonetheless: + + Family Fnn has HUSB/WIFE/CHIL Inn, but Inn does not exist. + Family Fnn has a null HUSB/WIFE/CHIL line. + Person Inn is a spouse/child in Fnn, but Fnn does not exist. + Person Inn has a null FAMS/FAMC line. + +Version 1.0 - 2003 Jul 2 - John F. Chandler + +This program works only with LifeLines. + +*/ + +global(pointers) + +proc main() { +table(spou) /* each entry is the list of spouses in the keyed family */ +table(chil) /* each entry is the list of children in the keyed family */ + +"Testing database " qt() database() qt() " for pointer reciprocity\n" + +set(pointers,0) + +/* loop through persons and note all the families they belong to */ +forindi(i,n) { + set(k,save(key(i))) + fornodes(root(i),node) { + set(type,tag(node)) + if(eqstr(type,"FAMC")) { + call tally(type,"child",chil,node,k) + } elsif(eqstr(type,"FAMS")) { + call tally(type,"spouse",spou,node,k) + } + } +} +/* loop through families and compare the members against the list + compiled by scanning persons -- flag any mismatches */ +forfam(f,n) { + set(id,save(key(f))) + set(cl,lookup(chil,id)) + set(sl,lookup(spou,id)) + fornodes(root(f),node) { + set(type,tag(node)) + if(eqstr(type,"CHIL")) { call checkoff(type,cl,id,node) } + elsif(or(eqstr(type,"HUSB"),eqstr(type,"WIFE"))) { + call checkoff(type,sl,id,node) + } + } +/* any remaining list elements are errors */ + if(sl) { + while(k,dequeue(sl)) { + "\nPerson " k " is a spouse in " id + ", but " id " has no corresponding pointer." + } + } + if(cl) { + while(k,dequeue(cl)) { + "\nPerson " k " is a child in " id + ", but " id " has no corresponding pointer." + } + } +} +"\n\nFinished after checking " d(pointers) " pointers.\n" + +} + +/* check a family member against the expected list. + anyone not on the list is an error. + remove each person from the list when found here. */ +proc checkoff(type,list,id,node) { + incr(pointers) + if(eq(mod(pointers,500),0)) { print(".") } + if(k,value(node)) { + set(key,substring(k,2,sub(strlen(k),1))) + if(list) { + set(count,length(list)) + while(gt(count,0)) { + decr(count) + set(c,dequeue(list)) + if(eqstr(c,key)) { set(count,-1) } + else { enqueue(list,c) } + } + } + if(eq(count,0)) { + "\nFamily " id " has " type " " key ", but " key + if(reference(k)) { " has no corresponding pointer." } + else { " does not exist." } + } + } else { "\nFamily " id " has a null " type " line." } +} + +/* build a list of persons who belong to families */ +proc tally(type,member,table,node,k) { + incr(pointers) + if(eq(mod(pointers,500),0)) { print(".") } + set(id,value(node)) + if(reference(id)) { + set(id,save(substring(id,2,sub(strlen(id),1)))) + if(l,lookup(table,id)) { enqueue(l,k) } + else { + list(l) + enqueue(l,k) + insert(table,id,l) + } + } elsif(id) { + "\nPerson " k " is a " member " in " id + ", but " id " does not exist." + } else { "\nPerson " k " has a null " type " line." } +} + diff --git a/reports/prompt.li b/reports/prompt.li new file mode 100644 index 0000000..10f066c --- /dev/null +++ b/reports/prompt.li @@ -0,0 +1,43 @@ +/* + * @progname prompt.li + * @version None + * @author anon + * @category + * @output booleans and ints function values + * @description + + miscellaneous prompt functions and procedures + */ + +func askny(msg) +{ + set(prompt, concat(msg, "? [n/y] ")) + getstrmsg(str, prompt) + if(and(gt(strlen(str), 0), + or(eq(strcmp(str, "y"),0), eq(strcmp(str, "Y"),0)))) { + return(1) + } + return(0) +} + +func askyn(msg) +{ + set(prompt, concat(msg, "? [y/n] ")) + getstrmsg(str, prompt) + if(and(gt(strlen(str), 0), + or(eq(strcmp(str, "n"),0), eq(strcmp(str, "N"),0)))) { + return(0) + } + return(1) +} + +func getintdef(msg, def) +{ + set(prompt, concat(msg, "? [", d(def), "]")) + getstrmsg(str, prompt) + if(and(gt(strlen(str), 0), + gt(index("0123456789",trim(str,1),1),0))) { + return(atoi(str)) + } + return(def) +} diff --git a/reports/ps-anc.ll b/reports/ps-anc.ll new file mode 100644 index 0000000..5ad96c9 --- /dev/null +++ b/reports/ps-anc.ll @@ -0,0 +1,5617 @@ +/* + @prognam ps-anc + @version 8.86, 4 Jul 2004 + @author Robert Simms + @output PostScript + @category chart making + @description PS Charts + + a LifeLines genealogy report program that produces ancestry charts in + PostScript + + This is an interim version on the way to a release of ps-anc9. + For a log of changes, visit the web page + http://www.math.clemson.edu/~rsimms/genealogy/ll/ps-anc/log.html +*/ + +/* +** ps-anc, 9 Sep 1994, by Fred Wheeler (wheeler@ipl.rpi.edu) +** ps-anc2, 16 August 1994, by Fred Wheeler (wheeler@ipl.rpi.edu) +** ps-anc5, 19 Feb 1996, enhanced by Phil Stringer (P.Stringer@mcc.ac.uk) +** - all comments/bugs should now go to Phil Stringer +** ps-anc6, 30 Jan 1997, enhanced by Phil Stringer (P.Stringer@mcc.ac.uk) +** ps-anc7, 1 Feb 1997, enhanced by Phil Stringer (P.Stringer@mcc.ac.uk) +** ps-anc8, 18 Mar 1998, enhanced by Robert Simms and Allan Yates, +** rsimms@math.clemson.edu and ayates@nortel.ca +** +** GETTING THIS FILE +** +** The ps-anc final release versions are available via the Internet: +** (1) https://lifelines.github.io/lifelines/ +** (1) ftp://ftp.cac.psu.edu/pub/genealogy/lines/reports/ +** (2) http://www.math.clemson.edu/~rsimms/genealogy/ll/ +** +** BRIEF DESCRIPTION +** +** This LifeLines report program generates Postscript ancestral and +** descendant charts. The ancestral charts can include the siblings +** of all direct ancestors (aunts, uncles, great-aunts, great-uncles, +** etc.). A multi-page poster chart can also be generated. The +** chart format is based on the program GedChart, by Tom Blumer. +** +** The Postscript file created can be sent to any size printer; it +** will automatically adapt the size of the chart. I send the same +** file to A-size (8.5 by 11) and B-size (11 by 17) printers. +** +** After you use this program a few times, you should edit the +** function interrogate_user(). This is the first function after +** these comments and the global variable declarations. This +** function is set up to make it easy for you to configure what +** questions this program should ask you each time and what default +** values it should use for questions not asked. +** +** Please contact me if you like this program, find any bugs, have +** any bug fixes, or want to suggest improvements. I am also always +** on the lookout for better ancestral/descendant chart generating +** programs. If you know of a program that generates charts which +** you like better than those generated by this program, please drop +** me a line. +** +** This report program works with the LifeLines Genealogical database +** program only. (see ftp://ftp.cac.psu.edu/pub/genealogy/lines/*) +** +** CHANGE LOG +** +** CHANGES since version 1: +** Completely new descendant chart in addition to ancestral chart +** Multi-page poster option +** Multi-page charts scaled correctly (thanks to broman@Np.nosc.mil) +** Maximum name length configurable by user (fixes long squashed names) +** Option to suppress siblings of later generations in ancestral charts +** Checks that user selects a valid person (bug fix) +** Can make a guess at whether a title is a prefix or suffix type +** Use of titles is configurable (prefix, suffix, guess, none) +** Birth/death/marriage date styles are configurable (may include place) +** Corner message is slightly smaller, and chart will not overlap it +** Marriage date is printed before death date +** +** CREDITS +** +** Code improvements received from: +** Vincent Broman (broman@Np.nosc.mil) +** +** Helpful comments received from: +** Vincent Broman (broman@Np.nosc.mil) +** Frank H. Flaesland (phranx@imr.no) +** Linda Wilson (lwilson@mcc.com) +** Stacy Johnson (sjohnson@oucsace.cs.ohiou.edu) +** John F. Chandler (jchbn@cuvmb.cc.columbia.edu) +** Susan Radel +** +** CHANGES in version 3: +** Birth/death/marriage date style addition (full date with short place). +** Examples for including other fonts. +** Option for bold lines/text for direct line of ascent. +** Option to start on right or left of page. +** Option for landscape or portrait format. +** Small additional space between border and text to improve appearance. +** Now fills the page if max generations > actual generations. +** With multi-page output generations are multiple of x-pages to prevent +** text split over sheets. +** Option to show aunts/uncles from parents multiple marriages. +** +** CHANGES in version 4: +** Border enhanced at the corners. +** Chart title font changed. +** Lines now used to join families rather than being used as a framework. +** Names now adjacent to line or halfway between if in 2 families. +** Descendant chart has reduced lines and is more tree like +** +** CHANGES in version 5: +** Enhanced descendant chart +** Automatic choice of chart type if no children or no ancestors +** Multi-page landscape bug fixed +** Enhancements to user option specification +** Character set enhanced to iso-8859-1 +** Additional personal titles +** +** CHANGES in version 6: +** Corrected multi-page landscape printing +** Descriptive title at bottom of chart +** Smaller and faster PostScript code on multi-page output +** (previously n-pages had n * single page size of file) +** Automatic choice of ancestor/descendant chart if no descendants/ancestors +** Fixed bug on descendant charts of overprinting if it branched up, and +** there was a spouse with birth and death details, and no children in +** that family. +** Character set inadvertently lost iso-8859-1 support. +** +** CHANGES in version 7: +** Fixed bug on descendant charts of overlapping vertical lines if it +** branched up, and there was a spouse and no children in that family. +** iso-8859-1 support reinstated. +** More efficient print_all_persons code from Fred Wheeler +** +** CREDITS +** +** Code improvements received from: +** Phil Stringer (p.stringer@mcc.ac.uk) +** +** CHANGES in version 8 by Robert Simms and (+) Allan Yates: +** +** >procedure do_anc: +** Closed up extra space between branches of the chart by changing +** min_pos to person_minpos, to be used to keep person from being drawn +** too high on chart, but not to keep all ancestors of a person from being +** drawn above this point. Introduced abs_min_pos as the absolutely +** highest position for any older siblings or half siblings of a person. +** Fixed the printing of half siblings to be subject to the sibling depth +** limit obtained from the interrogate function. +** Fixed a mis-alignment in half sib. branch vertical line. +** >procedure do_des: +** Fixed conditions for drawing vertical line to exclude case where there +** are children but no spouse and depth = max_depth. In this case the +** children heights are never computed so a vertical line can't be drawn. +** >general: +** +Added option for displaying surnames in upper case. +** +Added date option to display the first two items in a place list +** +Added option for not displaying large descriptive title, print small +** one instead with title text added +** +Do not print preceding comma if place exists and date does not exist +** Fixed positioning of names that caused some names to be too close +** to vertical lines, eliminating horizontal lines in come cases. +** Added support in PostScript file for increasing the page margins together +** with a new question in the interrogate function. (This required +** calculation of a clip rectangle since the device clip rectangle would +** allow redundant display of parts of the chart at adjoining edges in +** multi-page charts.) This is useful for imposing a margin when a +** PostScript file is converted to another format, such as Adobe PDF. +** This was to prevent the converted file from having a zero margin +** which doesn't print well on most printers. +** Centered chart label and coordinated its placement with that of the title +** to avoid having the two overlap. This fix became more necessary with +** the addition of the ability to increase the margins. +** Added option for centering or left justifying chart label. +** Replaced tabs in LifeLines code with spaces to avoid irregular +** indentation. +** Experimented with putting page drawing code into a procedure to reduce +** the size of multi-page files. Determined that doing so would +** require changing the MaxOpStack limit in PostScript to handle the +** potentially large number of items that would go into the procedure. +** This could potentially place a limit on how many individuals +** could be shown in a chart for some devices. So, the idea was dropped. +** +** CREDITS: +** Phil Stringer, for initiating the min_pos fix in procedure do_anc. +******************************************************************************* +** +** ABOUT GEDCHART (a different program) +** +** This program includes PostScript code written by Tom Blumer +** (blumer@ptltd.com). It is used here with his permission. This +** PostScript code is from Tom Blumer's GedChart package. The report +** is very much like that generated by GedChart using the -Sa or -Sd +** option. +** +** GedChart is DOS program that generates ancestral and descendant +** charts like this report program, and also fan charts. GedChart +** works directly from a GEDCOM file and is completely independent of +** LifeLines. It is currently up to version 1.6, which is a beta +** version that may lead to a commercial product. You can find +** GedChart at ftp:oak.oakland.edu/pub/msdos/genealgy/gedcht16.zip +** +*/ + +option("explicitvars") /* to catch misspellings or uninit'ed use of variables*/ + +/* If translation tables are in effect, and UTF-8 or 8-bit characters are used + in a custom title, for instance, then it might be necessary to specify what + codeset the report is using (say ISO-8859-1, ISO-8859-2, UTF-8, etc.) + to ensure that those 8-bit characters arrive safely in the output + This is done with the char_encoding() statement... */ +/*char_encoding("ISO-8859-1")*/ + +global(version) /* version string */ +global(TRUE) /* int, set to 1 for use as boolean value */ +global(FALSE) /* int, set to 0 for use as boolean value */ +global(UP) /* int, constant, set to -1 for desc. branches */ +global(NEUTRAL) /* int, constant, set to 0 for desc. branches */ +global(DOWN) /* int, constant, set to 1 for desc. branches */ +global(max_dateplace) /* int, number of date-place styles */ +global(place_modify) /* boolean, use (included) abbreviation routine */ + +global(updown_override) /* int, to force desc. to be all up or all down */ +global(high_pos_gen) /* array, highest so far in each generation */ +global(high_pos_gen_offset) /* used to allow non-positive array indexing */ +global(high_depth) /* int, highest depth so far */ +global(low_depth) /* int, lowest depth so far */ + +global(name_height) /* height of name text on chart */ +global(date_height) /* height of birth/death/marriage date text */ +global(corner_height) /* space between parent and extreme child + * -- name_height was formerly used for this */ +global(min_sibling_spacer) /* constant, min. vert. space between siblings */ +global(cloaked_depth) /* used for hidding a gen. from get_clearance */ +global(tighten) /* boolean, descendant branches to be closer */ +global(debug) +global(debug2) +global(debug_postscript) + +/* variables prompted from or configured by the user */ + +global(chart_type) /* int, 0: ancestral, 1: descendant */ +global(root_person) /* indi, person for whom to generate the chart */ +global(root_fam) /* fam, family for combination chart */ +global(font_name) /* string, name of font for individual names*/ +global(ifont_name) /* string, name of font for person info */ +global(enc_choice) /* int, specifies character encoding to use */ +global(max_depth) /* int, maximum number of gen. up from root */ +global(min_depth) /* int, minimum number of gen. down from root */ +global(start_depth) /* int, depth of root, used by reserve() also */ +global(chart_label) /* string, label for corner of chart */ +global(chart_label_centered) /* boolean, center chart_label on first page */ +global(color_chart) /* boolean, is chart in color */ +global(multi_page) /* boolean, is chart many page poster type */ +global(x_pages) /* int, number of horizontal pages */ +global(y_pages) /* int, number of vertical pages */ +global(name_letters) /* int, maximum number of letters in a name */ +global(title_method) /* int, code for how to insert titles */ +global(depth_siblings) /* int, number of generations to show siblings */ +global(dateplace_birth) /* int, date style for birth/death/marriage */ +global(dateplace_death) +global(dateplace_marriage) +global(dateplace_burial) +global(show_altname) /* boolean, whether or not to show 2nd names */ +global(show_address) /* boolean, whether or not to show addresses */ +global(no_resides_at) /* boolean, show all or just current addresses */ +global(surname_upper) /* boolean, display surnames in upper case? */ +global(display_title) /* boolean, display descriptive title? */ +global(chart_title_override) /* string, user-specified title */ +global(display_label) /* boolean, display identifying label? */ +global(label_outside) /* boolean, place label outside border? */ +global(display_border) /* boolean, display a fancy border? */ +global(bold_chart) /* bool, direct line in bold 0: no, 1: yes */ +global(bold_factor) /* int, how much larger bold lines should be */ +global(mirror_chart) /* bool, root person on right 0: no, 1: yes */ +global(mom_first) /* bool, mothers at branch tops: no(0), yes(1) */ +global(halfsib) /* bool, show half siblings 0: no, 1: yes */ +global(halfsib_anc) /* bool, show half sibling ancestors 0: no,1:yes*/ +global(depth_halfsib_anc) /* int, smallest generation in which half + siblings will have ancestors plotted */ +global(desc_gender) /* int, gender restriction on descendants */ +global(opt_rel_famc) /* bool, non-birth branches use thin blue line*/ +global(duplic_handling) /* int, 0 do nothing, 1 dashed line, 2 anc once */ +global(portrait) /* int, 0: landscape, 1: portrait */ +global(paper_width) /* int, width in points of target paper */ +global(paper_height) /* int, height in points of target paper */ +global(paper_name) /* string, name of paper for PostScript device */ +global(margin_top) /* int, minimum top margin, in points*/ +global(margin_bottom) /* int, minimum bottom margin, in points*/ +global(margin_left) /* int, minimum left margin, in points*/ +global(margin_right) /* int, minimum rightmargin, in points*/ +global(manual_feed_opt) /* int, 0 don't specify, 1 on, 2 off */ +global(postscript_level) /* int, 1 or 2 for PostScript level 1 or greater */ +global(pacificpage) /* int, 0/1 have pacific page cartridge on Laser */ + +/* variables to return additional values from functions */ +global(min_gap_return) +global(branch_up_min_pos) +global(dup_line_return) + +/* these three constants define how close branches of the tree can get */ +global(branch_dist_prev) /* minimum distance from previous generation */ +global(branch_dist_same) /* minimum distance from same generation */ +global(branch_dist_next) /* minimum distance from next generation */ + +/* stacks for storing the information for each person on the chart */ +/* see proc's enqueue_person and print_all_persons */ + +global(plist_person) /* the person (to extract name, birth, death) */ +global(plist_depth) /* generation depth */ +global(plist_pos) /* vertical position */ +global(plist_line) /* 0,1 boolean, is direct ancestor? */ +global(plist_mdate) /* marriage date */ +global(plist_up) /* 0,1 boolean, person connects to next up level*/ +global(plist_down) /* 0,1 boolean, person connects to next down level */ +global(plist_duplic) /* 0,1 boolean, the person is a duplicate appearance */ +global(plist_height) /* to store person height for ease of branch adjustment */ + +/* set for enabling originality of chart appearances by individuals */ +global(original_person) +global(original_depth) +global(duplicate_anc_return) +global(duplicate_return) + +/* stacks for storing the information for each vertical line on the chart */ +/* see proc's enqueue_vertical and print_all_verticals */ + +global(llist_depth) /* generation depth */ +global(llist_low) /* starting point */ +global(llist_high) /* finishing point */ +global(llist_color) /* line color */ +global(llist_duplic) /* dashed lines for duplicates */ + +/* stacks for marking the beginning of a branch in the person and line lists */ +global(branch_start_person) +global(branch_start_line) + + +global(ps_xlat) /* for a table to hold character translations */ +global(opt_xlat) /* boolean, to control character translation */ +global(opt_deparen) /* boolean, control removal of parenthesized name text */ + +/* + keyword: SHORTEN + uncomment the following 'include' command and verify that the + included file contains subroutines for place name shortening +*/ + +/* include("shorten.lllib") */ + + +/* +** function: interrogate_user +** +** This function is designed to be modified by the user. It asks +** many questions about how to configure the charts. If your answer +** to one of the questions is always the same, you can easily +** hardwire your answer here so that you are never asked again. +** +** An 'if' statement is wrapped around each question. The 'if(TRUE)' +** can be changed to an 'if(FALSE)' to make the program use the default +** value defined in the 'else' clause instead of asking every time. +** +** The questions are grouped in the following way: +** o CHART CONTENT -- root person, chart type, # gen, # gen sib, +** show half siblings, show half sibling ancestors, +** # gen half sibling ancestors, matrilinear/patrilinear drop line +** o LAYOUT -- multi-page and orientation, # pages for multi-page, +** root person on left or right, mothers or fathers at tops of branches +** o ADD-ONS -- border, title, label, label text, center label, +** label in/outside border +** o STYLE -- font, character encoding, color, desc. branch directions, +** bold lines of descent, bold line width factor, duplicate handling, +** display of non-birth relations +** o FORMAT OF INFORMATION -- date/place format, show 2nd names, +** address specifics, title before/after name, +** lower/upper-case surnames,max. length for names, +** removing parenthesized text from names +** o OUTPUT OPTIONS -- paper size/type, minimum margins, manual feed request +** PacificPage margin modification, filter some PostScript strings +** +*/ + +func interrogate_user() { + +/* CHART CONTENT */ + +/* +** QUESTION: Who is the root person? +** +** This question should always be asked, unless you always use the same +** person, which is not likely. If you do set a default, it is a string +** representation of that persons number. +** +*/ + + if(TRUE) { + set(root_person, 0) + getindimsg(root_person, "Identify root person for chart (blank to cancel)") + if(not(root_person)) { + return(0) /* signals abnormal termination of interrogate_user() */ + } + } else { + set(root_person, indi("1")) + } + +/* +** QUESTION: What type of chart? +** +** This should always be asked, unless you never use two of the three +** types of charts. +** +*/ + if(TRUE) { + list(options) + setel(options, 1, "Ancestors") + setel(options, 2, "Descendants and Spouses") + setel(options, 3, "Direct Descendants (Drop line)") + setel(options, 4, "Ancestors and Descendants of a Family (Combo.)") + setel(options, 5, "Ancestors and Descendants of an Extended Family (Cousins)") + setel(options, 6, "Multiple Charts (program editing required)") + set(chart_type, menuchoose(options, "Select chart type:")) + if(or(le(chart_type, 0), ge(chart_type, 7))) { + return(0) /* signals abnormal termination of interrogate_user() */ + } + +/* + indiset(pset) + addtoset(pset, root_person, 1) + if(eq(lengthset(childset(pset)), 0) ) { + print(" Printing ancestor chart as ", name(root_person), nl()) + print(" has no known children.", nl()) + set(chart_type, 1) + } elsif(eq(lengthset(parentset(pset)), 0) ) { + print(" Choose a chart with descendants as ", name(root_person), + " has no known ancestors.", nl()) + getintmsg(chart_type, + "Specify chart type: 2/descendant, 3/drop line, 4/combo.") + } else { + getintmsg(chart_type, + "Enter chart type: 1/anc., 2/des., 3/drop line, 4/combo., 5/cousins") + } +*/ + } else { + set(chart_type, 1) + } + + /* + The following is code that pertains to the combination and cousin charts. + No user-modification is needed between here and the next question. + */ + if(or( eq(chart_type, 4), eq(chart_type, 5) )) { + print(" Choose a family via spouse...") + set(root_fam, choosefam(root_person)) + if(eq(root_fam, 0)) { + return(0) /* signals abnormal termination of interrogate_user() */ + } + print(" done.", nl()) + + if(not(and(husband(root_fam), wife(root_fam)))) { + print(" That family only has one parent.", nl()) + print(" This chart-type requires a family with two parents.", nl()) + return(0) + } + } + +/* +** QUESTION: How many generations should be shown? +** +** If there are less than this, then the page is filled anyway, +** so you only need to ask if you want a restricted number. +** +*/ + + if(TRUE) { + set(min_depth, 1) + set(max_depth, 1) + if(ge(chart_type, 2)) { /* chart has descendants: gen #s go negative */ + getintmsg(min_depth, + "Maximum number of generations of descendants, including root") + if(le(min_depth, 0)) { + set(min_depth, 1) + } + } + if(and( ne(chart_type, 2), ne(chart_type, 3) )) { + /* chart has ancestors: gen #s go positive */ + getintmsg(max_depth, + "Maximum number of generations of ancestors, including root") + if(le(max_depth, 0)) { + set(max_depth, 1) + } + } + + } else { + set(min_depth, 1) + set(max_depth, 1) + if(ne(chart_type, 1)) { + set(min_depth, 4) + } + if(or( eq(chart_type, 1), eq(chart_type, 4), eq(chart_type, 5) )) { + set(max_depth, 4) + } + } + +/* +** QUESTION: How many ancestral generations should show siblings? +** +** If you want to show siblings in all generations, set this default to 999. +** This question is only asked for ancestral charts. +** +*/ + + if(and( ne(chart_type, 2), ne(chart_type, 3) )) { + + if(FALSE) { + getintmsg(depth_siblings, + "How many ancestral generations to show siblings") + } else { + set(depth_siblings, 999) + } + } + +/* +** QUESTION: Should half siblings be shown? +** +** In the ancestral report, if a parent has had multiple marriages +** this determines whether the children of these marriages are shown +** in the aunts/uncles. They are placed above the father or below the +** mother with a thin vertical line in the aunt/uncle colour. +** +*/ + + if( and( ne(chart_type, 2), ne(chart_type, 3), gt(depth_siblings, 0))) { + + if(FALSE) { + getintmsg(halfsib, + "Enter 1 to show half-brothers/sisters, 0 to omit them") + } else { + set(halfsib, 1) + } + } + +/* +** QUESTION: Should ancestors of half siblings be shown? +** In the ancestral report, if a parent has had multiple marriages +** this determines whether the ancestors of these spouses are shown. +*/ + + if( and(ne(chart_type, 2), ne(chart_type, 3))) { + + if(FALSE) { + if(halfsib) { + getintmsg(halfsib_anc, + "Enter 1 to show ancestors of half siblings, 0 to omit them") + } + } else { + set(halfsib_anc, 1) + } + } + +/* QUESTION: In how many generations do you want to show ancestors +** of half siblings? +** +** This is the last generation in which, if there are half siblings shown, +** their ancestors will be shown, subject to the maximum depth limit. +*/ + + if( and(ne(chart_type, 2), ne(chart_type, 3))) { + + if(FALSE) { + if(halfsib_anc) { + getintmsg(depth_halfsib_anc, + "Number of generations from which to show ancestors of half siblings") + if(ge(depth_halfsib_anc, max_depth)) { + set(depth_halfsib_anc, sub(max_depth, 1)) + } + } + } else { + set(depth_halfsib_anc, sub(max_depth, 1)) + } + } + +/* +** QUESTION: Do you want descendant lines be matrilinear/patrilinear? +** +** Currently only for dropline charts, this option allows the restriction +** of descendant lines followed to a particular gender. +** For branches that are cut off, a short horizontal line is drawn from a +** person towards the younger generation to indicate that the person has +** descendants. This is the same thing that is done when a person has +** descendants in that go off-chart. +*/ + + if(TRUE) { + if(eq(chart_type, 3)) { + getintmsg(desc_gender, + "Enter 2 for patrilinear, 1 for matrilinear, 0 for all descendants") + } else { + set(desc_gender, 0) /* won't be used */ + } + } else { + set(desc_gender, 0) + } + +/* LAYOUT */ + +/* +** QUESTION: Do you want multi-page poster output, and select orientation. +** +** This controls whether (PostScript) output spans multiple pages. +** In PostScript, this is achieved by enlarging the chart and moving +** the plot origin to cause the desired portion of the chart to land in +** a clipped region of a given page. +** +*/ + + if(TRUE) { + list(options) + setel(options, 1, "Single page, in portrait") + setel(options, 2, "Single page, in landscape") + setel(options, 3, "Multi page, using portrait sheets of paper") + setel(options, 4, "Multi page, using landscape sheets of paper") + set(mc, menuchoose(options, "Select page type:")) + if( eq(0, mc)) { + return(0) + } elsif( eq(1, mc)) { + set(multi_page, 0) + set(portrait, 1) + } elsif( eq(2, mc)) { + set(multi_page, 0) + set(portrait, 0) + } elsif( eq(3, mc)) { + set(multi_page, 1) + set(portrait, 1) + } else { + set(multi_page, 1) + set(portrait, 0) + } + /* purge options list for later use */ + list(options) /* new - RES */ + /*while(length(options)) {set(mc, pop(options))}*/ + } else { + set(multi_page, 0) + set(portrait, 1) + } + +/* +** QUESTION: How many pages make up the poster? +** +** You will probably want to always ask this question. This question is +** asked if a poster chart is requested. +** +*/ + + if(multi_page) { + + if(TRUE) { + getintmsg( x_pages, "Number of horizontal pages on finished chart") + getintmsg( y_pages, "Number of vertical pages on finished chart") + } else { + set(x_pages, 1) + set(y_pages, 2) + } + + } else { + set(x_pages, 1) + set(y_pages, 1) + } + +/* +** QUESTION: Should the younger generations be on the left or right? +** +*/ + + if(FALSE) { + getintmsg( mirror_chart, + "Enter younger generations on the left (0), or the right (1)") + } else { + set( mirror_chart, 1) + } + +/* +** QUESTION: Should mothers appear at the tops of ancestral branches? +*/ + + if( and(ne(chart_type, 2), ne(chart_type, 3))) { + + if(TRUE) { + getintmsg(mom_first, + "Enter 1 to put mothers at top of anc. branches, 0 for fathers") + } else { + set(mom_first, 0) + } + } + +/* ADD-ONS */ + +/* +** QUESTION: Should a decorative border be shown? +*/ + + if(FALSE) { + getintmsg(display_border, + "Enter 1 to print a decorative border, 0 to print no border") + } else { + set(display_border, 1) + } + +/* +** QUESTION: Should descriptive title be displayed? +*/ + + if(TRUE) { + getintmsg(display_title, + "Enter 1 to display descriptive title , 0 for no title") + } else { + set(display_title, 1) + } + +/* +** QUESTION: Use an automaticly generated title, or a user-specified one? +*/ + + if(and(FALSE, display_title)) { + getstrmsg(chart_title_override, + "Enter chart title, or none to have one created automatically.") + } else { + set(chart_title_override, "") + } + +/* +** QUESTION: Should a chart label be shown? +** +** The chart label identifies the preparer, and optionally, +** what would have been in the chart title, should one be omitted. +*/ + + if(FALSE) { + getintmsg(display_label, + "Enter 1 to display identifying label , 0 for no label") + } else { + set(display_label, 0) + } + +/* +** QUESTION: What message (label) should be shown at the bottom of the chart? +** +** I suggest not asking this question, and setting a default credit with +** your name. The advantage of this is that you can have the date +** automatically inserted. +** +*/ + + set(label_set, 0) + + if(FALSE) { + if(display_label) { + getstrmsg(chart_label, "Label for corner of chart (your name, date)") + set(chart_label, save(chart_label)) + set(label_set, 1) + } + } + if(not(label_set)) { + /* want to make sure there is a label written to the PostScript file, */ + /* in case user sets 'display_label' to true in PostScript output later */ + dayformat(2) + monthformat(4) + dateformat(0) /* format for date, if used in 'rpt_name' or 'chart_label' */ + + set(rpt_name, + "produced by Your Name, your web, e-mail, or mail address, for instance" + ) + if(display_title) { + /* don't need to repeat information given in title */ + set( chart_label, concat( save( stddate( gettoday() )), " ", rpt_name)) + } else { + set(chart_label, + concat(save(stddate(gettoday())), " ", chart_title(), " ", rpt_name)) + } + } + + +/* +** QUESTION: Should the chart_label be centered? +** +** Concerns the position on the first page (lower left) for the chart label. +** The choices are to center the label, or to put it near the left edge. +** +*/ + + if(display_label) { + + if(FALSE) { + getintmsg(chart_label_centered, + "Enter 1 to center chart label, 0 for left") + } else { + set(chart_label_centered, 0) + } + } + +/* +** QUESTION: Print label inside or outside the border? +** If both a border and the label are to be on a chart, it is possible +** to specify whether the label should go inside or outside the border. +*/ + + if( and(display_border, display_label)) { + + if(FALSE) { + getintmsg(label_outside, + "Enter 1 to place label outside border, 0 for inside") + } else { + set(label_outside, 1) + } + + } else { + set(label_outside, 1) + } + +/* STYLE */ + +/* +** QUESTION: What font should be used for names? +** +** Because it is such a pain to enter a font name, and a spelling mistake +** will get you an ugly default font, this should be set to a default. I +** suggest one of: Times-Roman, NewCenturySchlbk-Roman, or ZapfChancery. +** Choosing the font via lists is provided primarily for when one is +** curious as to what the others look like on a chart. +** +** Search the Postscript code at bottom of this file for ideas (and spellings). +** Look for "bolddict" where font names and their bold equivalents are defined. +** When adding a new font choice, you should add the bold name (if one exists) +** in the PS code yourself, using the existing code as a guide. If your font +** doesn't have a bold version, then the font itself will be used when a bold +** font is called for. +** +** For fonts with characters that are to be placed right-to-left it may be +** necessary to add the font's name and an association with the 'rlshow' +** procedure within the PostScript code. This is done in the setup of a +** PostScript dictionary. Look for "fshowdict begin" below and follow +** existing code as an example. If that font also has a bold version, then +** do the same for it, or the font will be shown r-to-l but the bold version +** will go l-to-r. +** +** If a font encoding array (like ISOLatin1, provided by PostScript Level 2) +** is used with a font that uses non-standard character names, then many +** or all characters may not show (they get replaced with .notdef). +** In that case, in order to use the font, font reencoding should not be used. +** +** Some fonts don't specify a FontBBox -- the dimensions of a rectangle that +** will enclose any letter form, or glyph, from the font. In this case, +** the PostScript code produced may rely on estimating character dimensions +** by testing a few letters. Hershey-Gothic-English is such a font. +*/ + + if(TRUE) { + set(font_name, choose_font("individual names")) + if(not(font_name)) { + return(0) + } + } else { + /*set( font_name, "Times-Roman")*/ + set( font_name, "ZapfChancery-MediumItalic") + /*copyfile("/usr/local/lib/ghostscript/zcr.gsf")*/ + /*copyfile("/usr/local/lib/ghostscript/zcb.gsf")*/ + } + +/* +** QUESTION: Which font should be used for individual info (dates/places)? +*/ + + if(TRUE) { + set(ifont_name, choose_font("individual info")) + if(not(ifont_name)) { + return(0) + } + } else { + set(ifont_name, "Times-Roman") + } + +/* +** QUESTION: Which, if any, character encoding to enforce? +** +** In some PostScript fonts, there are more characters available than +** the 256 integers (ASCII) used to represent different text characters. +** An encoding vector is used to assign a subset of the available glyphs or +** letterforms to the 256 character codes (0 through 255). +** This allows PostScript output to match the characters available to +** genealogy software on many platforms. +** +** However, if accented characters are not needed, or the encodings in +** the fonts are sufficient, then simply using +** an encoding built into a font file (no change) results in a smaller +** PostScript file. +** +** Printers may be incapable of composing accents with plain letters when +** an accented character is not directly available in a font. +** To get around this, printing the output through Ghostscript or converting +** the PostScript output to PDF with Ghostscript or other conversion utility +** should work. +** +** ISO-Latin 1, or ISO 8859-1, is a world-wide standard for most languages +** of Latin origin: Albanian, Basque, Breton, Catalan, Cornish, Danish, Dutch +** English, Faroese, Finish (exc. S,s,Z,z with caron), +** French (except OE, oe, and Y-with-dieresis), Frisian, Galician, German, +** Greenlandic, Icelandic, Irish Gaelic (new orthography), Italian, Latin, +** Luxemburgish, Norwegian, Portuguese, Rhaeto-Romanic, Scottish Gaelic, +** Spanish, Swedish. +** +** ISO Latin 2, or ISO 8859-2, covers these languages: Albanian, Croatian, +** Czech, English, German, Hungarian, Latin, Polish, Romanian (cedilla below +** S,s,T,t instead of comma), Slovak, Sloverian, Sorbian. +*/ + + if(TRUE) { + list(options) + setel(options, 1, "ISO Latin 1") + setel(options, 2, "ISO Latin 2") + setel(options, 3, "MS-DOS Codepage 437 (extended ASCII) international chars.") + setel(options, 4, "let the font decide for me (use encoding specified in PS font)") + set(enc_choice, menuchoose(options, + "Select font reencoding, or (q) to use font's built-in encoding")) + if(eq(enc_choice, 4)) { + set(enc_choice, 0) + } + } else { + set(enc_choice, 1) + } + + +/* +** QUESTION: Should color be used? +** +** If you don't have access to a color printer, you should probably turn +** off this question. +** +*/ + + if(FALSE) { + getintmsg( color_chart, "Enter 0 for black/white, 1 for color") + } else { + set(color_chart, 1) + } + +/* +** QUESTION: Which way should descendant branches go? +** +** The charting procedures can make decisions about branch directions, +** roughtly, choosing up for the first half and down for the second half +** of a person's descendant branches. +** This may be overriden by forcing all branches to go up or all to go down. +*/ + + if(FALSE) { + if(and( ne(chart_type, 1) , ne(chart_type, 3))) { + getintmsg( updown_override, + "Desc. branch direction: -2: all up, 0: mix, 2: all down") + } else { + set(updown_override, 0) + } + } else { + set(updown_override, 0) + } + +/* +** QUESTION: Should the direct line of descent be put in bold? +** +** Puts the text and lines for the direct line in bold. +** +*/ + + if(FALSE) { + getintmsg(bold_chart, "Enter 1 for bold direct line, 0 for all the same") + } else { + set(bold_chart, 1) + } + +/* +** QUESTION: What scale factor should be used to make bold lines? +** +** The default value should be 2 or 3. +** A value of 1 will make bold lines look the same as non-bolded ones. +*/ + + if(and( FALSE, bold_chart)) { + getintmsg(bold_factor, + "Enter the bold factor for direct relation lines") + } else { + set(bold_factor, 3) + } + +/* +** QUESTION: How should duplicate individuals be handled? +** +** When someone appears on a chart twice it can be helpful +** to mark the duplicate entries so they aren't thought to +** be different ancestors/descendants at first glance. +** +** The options are to print a duplicate's horizontal lines in +** a dashed style or to do that plus truncate a duplicate's ancestors +** (since they would possibly already appear on the chart). + +*/ +/* RES!? -has truncation of descendants been enabled yet? */ + + if(FALSE) { + getintmsg(duplic_handling, + "For duplicate individuals, make: 0 no change, 1 dashed, 2 truncated") + } else { + set(duplic_handling, 2) + } + +/* +** QUESTION: Do you want to show non-birth or legal relatives +** (by adoption, fostering, or sealing relationsships) with +** thin light blue lines, same as for other non-blood relatives? +** Non-birth child-to-family (FAMC) connections are indicated +** (according to GEDCOM 5.5) with a PEDI subnode of the FAMC node. +** The recognized values for the PEDI subnode are +** Birth, Adopted, Foster, Sealed. +*/ + + if(TRUE) { + getintmsg(opt_rel_famc, + "Enter 1/0 for Adopted, Foster, and Sealing connections to be non-blood") + } else { + set(opt_rel_famc, 1) + } + +/* FORMAT OF INFORMATION */ + +/* +** QUESTION: How should dates/places of birth/death/marriage be shown? +** +** This is actually three questions, or the same question for birth +** death and marriage dates. The codes cause the dates to be printed +** as follows. +** +** 0: do not show date +** 1: full date only +** [ LifeLines date() function ] +** 2: date and place, just year and State/Country +** [ LifeLines short() function ] +** 3: full date and full place, can get very long and thus smushed +** [ LifeLines long() function ] +** 4: full date and first item on PLAC line +** 5: full date and first two items on PLAC line +** 6: full date and first three items on PLAC line +** 7: year and up to two sufficient components from the PLAC line +** +** For more specific comments and the code that corresponds to these styles, +** search for "func dateplace(". +** To enable place modification or shortening, a date-place style that calls +** on the modify function must be used. Currently: 4, 5, 6, 7. +** keyword: SHORTEN +*/ + + if(FALSE) { + set(dateplace_birth, 99) + while( or( lt(dateplace_birth, 0), gt(dateplace_birth, max_dateplace))) { + getintmsg(dateplace_birth, + "Birth date style (0:no,1:date,2:short,3:long,4:d+1p,5:d+2p,6:d+3p,7:y+2p)") + } + set(dateplace_death, 99) + while( or( lt(dateplace_death, 0), gt(dateplace_death, max_dateplace))) { + getintmsg(dateplace_death, + "Death date style (0:no,1:date,2:short,3:long,4:d+1p,5:d+2p,6:d+3p,7:y+2p)") + } + set(dateplace_marriage, 99) + while( or( lt(dateplace_marriage, 0), gt(dateplace_marriage, max_dateplace))) { + getintmsg(dateplace_marriage, + "Marriage date style (0:no,1:date,2:short,3:long,4:d+1p,5:d+2p,6:d+3p,6:y+2p)") + } + set(dateplace_burial, 99) + while( or( lt(dateplace_burial, 0), gt(dateplace_burial, max_dateplace))) { + getintmsg(dateplace_burial, + "Burial date style (0:no,1:date,2:short,3:long,4:d+1p,5:d+2p,6:d+3p,7:y+2p*)") + } + } else { + set(dateplace_birth, 6) + set(dateplace_death, 6) + set(dateplace_marriage, 6) + set(dateplace_burial, 6) + } + +/* +** QUESTION: Is it ok to abbreviate (some) place components? +** +** Should a function made available in an external file via an include +** statement prior to this function (interrogate_user) be used to +** abbreviate some place components, such as country, state, or province +** names? +*/ + + if(FALSE) { + getintmsg( place_modify, + "Enter a 1 to allow place abbreviating, 0 to dissallow") + } else { + set(place_modify, 0) /* keyword: SHORTEN */ + } + +/* +** QUESTION: Should second names be shown with person info? +** +** Should there be a second name for a person, is it to be shown +** with the other person info (in the same font size as the other info lines)? +*/ + + if(FALSE) { + getintmsg( show_altname, + "Enter 1 to show 2nd name as information, 0 to suppress") + } else { + set(show_altname, 1) + } + +/* +** QUESTION: Should addresses be shown? +** +** Should a person's last address node be used to obtain a street address, +** phone number, and e-mail address? +*/ + + if(FALSE) { + getintmsg( show_address, + "Enter 1 to show address information, 0 to suppress") + } else { + set(show_address, 0) + } + +/* +** QUESTION: Should any address node (ADDR, RESI) be used or +** just active ones (ADDR)? +** +** Notes: ADDR is a GEDCOM 5.5 standard. +** RESI is a GEDCOM 5.5 standard for a former, "resided at" +** address. This allows the ADDR node type to be used strictly +** for current addresses. +*/ + + if(show_address) { + + if(FALSE) { + getintmsg(no_resides_at, + "Enter 1 to show only current addresses, 0 for any address type") + } else { + set(no_resides_at, 0) + } + } + +/* +** QUESTION: How should an individual's title be used? +** +** I would leave this default set to 'guess' (3), or 'none' (0), if you +** don't want the titles. If you find a title that is guessed incorrectly, +** please send an e-mail to the maintainer. +** +*/ + + if(FALSE) { + getintmsg(title_method, "Title method (0:none,1:prefix,2:suffix,3:guess)") + } else { + set(title_method, 3) + } + +/* +** QUESTION: Should surnames be in upper case? +** +*/ + + if(FALSE) { + getintmsg(surname_upper, + "Enter 1 for surnames in upper case, 0 for as is") + } else { + set(surname_upper, 0) + } + +/* +** QUESTION: What is the maximum length for names? +** +** It is best to just set a default maximum name length. If you want +** to always show the complete name, just set the default to 999. +*/ + + if(FALSE) { + getintmsg(name_letters, "Maximum name length") + } else { + set(name_letters, 40) + } + +/* +** QUESTION: Should parenthesized text be omitted from names in charts. +** +** This is to improve the chances that all important parts of a name +** are shown. Before names are cut to their length limit +** (name_letters, above) text within a full name that is parenthesized may +** be removed. The routine used will catch any logical pairings of +** '(' and ')' and can even handle nesting of parentheses. +*/ + + if(FALSE) { + getintmsg(opt_deparen, + "Enter 1 to remove parenthesized text from names, 0 otherwise.") + } else { + set(opt_deparen, 1) + } + +/* OUTPUT OPTIONS */ + +/* +** QUESTION: What paper size is expected? +** +** This presents a list of paper sizes to choose from, or the option +** of a custom size. The custom size feature would be appropriate to +** make a chart that can be included as an EPS file in another document. +** +** The variables paper_height and paper_width are set to integer values +** corresponding to the page dimensions, in points (72 points = 1 inch)* +** Here are sizes and names taken from the PostScript news group's FAQ: + Paper Size Dimension (in points) + ------------------------------ --------------------- + Comm #10 Envelope 297 x 684 + C5 Envelope 461 x 648 + DL Envelope 312 x 624 + Folio 595 x 935 + Executive 522 x 756 + Letter 612 x 792 + Legal 612 x 1008 + Ledger 1224 x 792 + Tabloid 792 x 1224 + ** A0 2384 x 3370 + A1 1684 x 2384 + A2 1191 x 1684 + A3 842 x 1191 + A4 595 x 842 + A5 420 x 595 + A6 297 x 420 + A7 210 x 297 + A8 148 x 210 + A9 105 x 148 + B0 2920 x 4127 + B1 2064 x 2920 + B2 1460 x 2064 + B3 1032 x 1460 + B4 729 x 1032 + B5 516 x 729 + B6 363 x 516 + B7 258 x 363 + B8 181 x 258 + B9 127 x 181 + B10 91 x 127 + + * In PostScript and desktop publishing in general, points 1/72 inch, + or .3527777778 mm. 1 pica = 12 points. In traditional typography, + points are 1/72.27 inch, or .3514598035 mm. Metric resolutions are + common with phototypesetters and supported by HTML, while laser and + inkjet printers primarily use points or inches. + + **ISO 216 paper size system is based on the principle of doubling and + halving to produce larger or smaller sizes, which are proportional to + the original when rotated one quarter turn. The side length ratio which + accomplishes this is 1 : 'square root of 2'. + Size A0 has an area of one square meter. + The fixed aspect ratio of the different size papers makes photocopier + enlarging/reducing a breeze. Only the U.S. and Canada persist in their + government and business use of non-ISO paper sizes, among industrialized + nations. +*/ + + if(TRUE) { + list(options) + setel(options, 1, "Adaptive, maximum area available") + setel(options, 2, "EPSF, custom size (single page)") + setel(options, 3, "Letter, 8 1/2\" x 11\" or 612 x 792 points") + setel(options, 4, "Legal, 8 1/2\" x 14\" or 612 x 1008 points") + setel(options, 5, "Ledger (Tabloid), 11\" x 17\" or 792 x 1224 points") + setel(options, 6, "A4, 595 x 842 points") + setel(options, 7, "A3, 842 x 1191 points") + setel(options, 8, "B5, 516 x 729 points") + setel(options, 9, "B4, 729 x 1032 points") + set(mc, menuchoose(options, "Select page size:")) + if( eq(mc, 1)) { + set(paper_name, "NONE") /* other paper_names are suitable for ps2pdf */ + } elsif( eq(mc, 2)) { + getintmsg(paper_width, "Enter image width, in points") + getintmsg(paper_height, "Enter image height, in points") + set(paper_name, "EPSF") + set( multi_page, 0) + set( x_pages, 1) + set( y_pages, 1) + } elsif( eq(mc, 3)) { /* Letter */ + set(paper_width, 612) + set(paper_height, 792) + set(paper_name, "letter") + } elsif( eq(mc, 4)) { /* Legal */ + set(paper_width, 612) + set(paper_height, 1008) + set(paper_name, "legal") + } elsif( eq(mc, 5)) { /* Ledger */ + set(paper_width, 792) + set(paper_height, 1223) + set(paper_name, "ledger") + } elsif( eq(mc, 6)) { /* A4 */ + set(paper_width, 595) + set(paper_height, 842) + set(paper_name, "a4") + } elsif( eq(mc, 7)) { /* A3 */ + set(paper_width, 842) + set(paper_height, 1191) + set(paper_name, "a3") + } elsif( eq(mc, 8)) { /* B5 */ + set(paper_width, 516) + set(paper_height, 729) + set(paper_name, "b5") + } elsif( eq(mc, 9)) { /* B4 */ + set(paper_width, 729) + set(paper_height, 1032) + set(paper_name, "b4") + } else { /* user must have chosen 'q'uit */ + return(0) + } + } else { + /* DEFAULT paper size, if the question is not to be asked */ + /* copy from above, capitalization and spelling of name are important */ + set(paper_name, "NONE") + } + +/* +** QUESTION: Specify minimum margins for each side of the paper. +** +** The resulting PostScript file asks the printer how close to +** the edge of the paper it can print. +** If the maximum size chart is desired, set the margins to zero. +** +** For all but the Adaptive page size, if a margin is required, specify it +** here to ensure a margin at least that wide. +** Margins on printed pages may be wider if the printing device requires +** more distance from the edges of the paper. +** +** For the Adaptive page size, margins are subtracted from what the printing +** device gives as it's printing area. In this case, margins specified here +** are added onto the devices margins. +** Be aware that when converting to a PDF file, margins become fixed. +** This can result in edges of the intended output getting cropped by printing +** from a PDF viewer. If necessary, a shrink-to-fit option may be used +** with such viewers -or- the margins specified here may be made large +** enough to accomodate most printers self-imposed margins. 30 points may do. +** +** The answers to these questions should be to the nearest integer point value, +** 18 points = 1/4 inch, 36 points = 1/2 inch, 72 points = 1 inch. +** +*/ + + if(FALSE) { + getintmsg(margin_top, "Minimum width of TOP margin") + getintmsg(margin_bottom, "Minimum width of BOTTOM margin") + getintmsg(margin_left, "Minimum width of LEFT margin") + getintmsg(margin_right, "Minimum width of RIGHT margin") + } else { + set(margin_top, 30) + set(margin_bottom, 30) + set(margin_left, 30) + set(margin_right, 30) + } + +/* +** QUESTION: Do you want to try to tell the printer to request a manual feed? +** +*/ + if( and( nestr(paper_name, "EPSF"), nestr(paper_name, "NONE"))) { + + if(TRUE) { + getintmsg(manual_feed_opt, + "Manual feed request: 0 don't specify, 1 on, 2 off") + } else { + set( manual_feed_opt, 0) + } + + } else { + set( manual_feed_opt, 0) + } + +/* +** QUESTION: Use PostScript Level 1 or Level 2 paper size request? +** +*/ + if( eq(manual_feed_opt, 1)) { + + if(TRUE) { + set(postscript_level, 0) + while( and( ne(postscript_level, 1), ne(postscript_level, 2))) { + getintmsg(postscript_level, + "Specify PostScript Level of printer: 1 or 2 (for 2 or higher)") + } + } else { + set(postscript_level, 1) + } + } + +/* +** QUESTION: Use modification for PacificPage cartridge? +** +** Adds to the PostScript output a margin modification specific to this +** device. This PostScript modification should be left out for +** PostScript Level 1 compatibility. +*/ + + if(FALSE) { + getintmsg(pacificpage, + "Enter 1 for PacificPage modification, 0 to leave it out") + } else { + set(pacificpage, 0) + } + +/* +** QUESTION: Do you want to filter some PostScript strings to protect +** PostScript files from errors. +** +** Unbalanced parentheses or lone backslash characters can cause problems in +** strings stored in PostScript files. This option enables their being +** made safer. +*/ + + if(FALSE) { + getintmsg(opt_xlat, + "Enter 1 to protect PostScript from dangerous characters, 0 otherwise") + } else { + set(opt_xlat, 1) + } + +/* +** END OF QUESTIONS +** +*/ + + return(1) /* signals that all necessary questions were answered */ +} + +/* +** function: choose_font +** +** Assists the user in selecting a font name. +** +*/ + +func choose_font(purpose) { + list(options) + setel(options, 1, "Roman") + setel(options, 2, "Italic (default)") + setel(options, 3, "Arabic") + setel(options, 4, "Hebrew") + set(ff, menuchoose(options, concat("Select font face for ", purpose, ": "))) + if(eq(ff, 1)) { + list(options) + setel(options, 1, "Times Roman (default)") + setel(options, 2, "New Century Schoolbook") + setel(options, 3, "Garamond") + setel( options, 4, "Hershey Plain") + set(mc, menuchoose(options, "Select font family: ")) + if( eq(2, mc)) { + set(font_choice, "NewCenturySchlbk-Roman") + } elsif( eq(3, mc)) { + set(font_choice, "AGaramond-Regular") + } elsif( eq(4, mc)) { + set(font_choice, "Hershey-Plain") + } else { + set(font_choice, "Times-Roman") + } + } elsif(eq(ff, 2)) { + list(options) + setel(options, 1, "Times Italic (default)") + setel(options, 2, "New Century Schoolbook Italic") + setel(options, 3, "Garamond Italic") + setel(options, 4, "ZapfChancery") + set(mc, menuchoose(options, "Select font: ")) + if(eq(1, mc)) { + set(font_choice, "Times-Italic") + } elsif(eq(2, mc)) { + set(font_choice, "NewCenturySchlbk-Italic") + } elsif(eq(3, mc)) { + set(font_choice, "AGaramond-Italic") + } elsif(eq(4, mc)) { + set(font_choice, "ZapfChancery-MediumItalic") + /*copyfile("/usr/local/lib/ghostscript/fonts/zcr.gsf")*/ + /*copyfile("/usr/local/lib/ghostscript/fonts/zcb.gsf")*/ + } else { + set(font_choice, "Times-Italic") + } + } elsif(eq(ff, 3)) { + list(options) + setel(options, 1, "OmegaRsimms") + setel(options, 2, "Baghdad") + set(mc, menuchoose(options, "Select font: ")) + if(eq(1, mc)) { + set(font_choice, "OmArabicRsimms (default)") + } elsif(eq(2, mc)) { + set(font_choice, "Baghdad") + } else { + set(font_choice, "OmArabicRsimms") + } + } elsif(eq(ff, 4)) { + list(options) + setel(options, 1, "Jerusalem") + set(mc, menuchoose(options, "Select font: ")) + if(eq(1, mc)) { + set(font_choice, "Jerusalem (default)") + } else { + set(font_choice, "Jerusalem") + } + } else { + set(font_choice, 0) /* user must want to quit */ + } + return(font_choice) +} + +/* +** procedure: main +** +** The main procedure. +** +*/ + +proc main() { + /* set constants */ + + set(version, "ps-anc8.86, 4 Jul 2004") + set(TRUE, 1) /* to make code in interrogate_user() */ + set(FALSE, 0) /* more user friendly */ + set(UP, neg(1)) /* constant, branch direction indicator */ + set(NEUTRAL, 0) /* constant, branch direction indicator */ + set(DOWN, 1) /* constant, branch direction indicator */ + + set(name_height, 1000) /* height to allow for name text */ + set(date_height, 600) /* height to allow for date text */ + + set(branch_dist_prev, 1000) /* previous generation */ + set(branch_dist_same, 1250) /* same generation */ + set(branch_dist_next, 1000) /* next generation */ + set(tighten, TRUE) /* ok for desc branches to be side-by-side */ + + set(corner_height, 1000) /* space between parent and extreme child + -- name_height was formerly used for this*/ + set(min_sibling_spacer, 500) /* force this much space between siblings */ + + set(max_dateplace, 6) /* number of date-place styles */ + + /* initialize other global variables and declare global stacks */ + + set(debug, FALSE) /* debugging output should depend on these */ + set(debug2, FALSE) + set(debug_postscript, TRUE) /* adds features to PostScript file: */ + /* in PS file, set show_positions to 'true' */ + + print(nl()) /* trying to make screen output not get clobbered by LL menu */ + if(interrogate_user()) { /* set options, some specified by user */ + set(start_depth, 0) /* any posInteger or neg(posInteger) is ok */ + + /* make depths rel. to start_depth, and figure depth offset for array */ + /*if(or( eq(chart_type, 1), eq(chart_type, 4), eq(chart_type, 5) )) {*/ + if( and(ne(chart_type, 2), ne(chart_type, 3))) { + set(depth_siblings, add(start_depth, sub(depth_siblings, 1))) + set(depth_halfsib_anc, add(start_depth, sub(depth_halfsib_anc, 1))) + } + set( max_depth, add(start_depth, sub(max_depth, 1))) + set( min_depth, sub(start_depth, sub(min_depth, 1))) + set( high_pos_gen_offset, sub( 1, min_depth)) + + call initialize_data() /* declares and clears contents of lists */ + + if(place_modify) { + /* keyword: SHORTEN + these commands prepare for place abbreviation supported + by an included program + */ + table(abbvtab) + call setupabbvtab() + } + + if(opt_xlat) { + /* Initialize PostScript translation table to escape characters */ + table(ps_xlat) + insert(ps_xlat,"(","\\(") + insert(ps_xlat,")","\\)") + insert(ps_xlat,"\\","\\\\") + } + + /* generate chart data */ + if( eq(chart_type, 1)) { + set(not_used, do_anc( root_person, start_depth, 0, 0, 0, 2, 0) ) + } elsif( eq(chart_type, 2)) { + set(not_used, do_des2(root_person, start_depth, 0, NEUTRAL, 2, 0, 0, 0)) + } elsif( eq(chart_type, 4)) { + call combo2() /* all the information it needs is global */ + } elsif( eq(chart_type, 5)) { + call do_cousins() /* all the information it needs is global */ + } elsif( eq(chart_type, 3)) { + set(not_used, dropline(root_person, start_depth, 0, FALSE, 2, 0)) + } elsif( eq(chart_type, 6)) { + /* With a few rules, you can put multiple charts in the same layout + The first chart may be of any type, but for now, additional charts + within the same layout must be among anc, des, and drop line. */ + /* The combo and cousins charts insist on their central generation + being at 'start_depth'. However, anc, des, and drop line charts may + be started from any generation, specified in their 'depth' argument. */ + /* Run the program, choose a person who has descendants (to avoid the + automatic choice of ancestor chart) + Give '5' for the chart type. + If duplicate appearances happen accross different charts, then + the lists original_person and original_depth must be init'ed between + chart calls to keep them from being treated as duplicates, if desired. + */ + set(display_label, 1) + set(chart_label_centered, 0) + set(chart_label, " Rugrats created by Arlene Klasky, Gabor Csupo and Paul Germain.") + set(display_title, 1) + set(chart_title_override, "The Rugrats") + + set(child_depth, sub(start_depth, 1)) + + set(root_person, indi("17")) /* Tommy Pickles */ + set(root_fam, parents(root_person)) /* Stu & Didi */ + call do_cousins() + print("Done Stu & Didi.", nl()) + + set(root_person, indi("7")) /* Phil */ + set(root_fam, parents(root_person)) + call combo2() + print("Done Phil & Lil", nl()) + + set(root_fam, fam("F1")) + call combo2() + /*set(root_person, indi("1"))*/ /* Chuckie Finster */ + /*set(not_used, do_anc(root_person, child_depth, 0, 0, 0, 2, 0))*/ + print("Done Chuckie.", nl()) + + set(root_person, indi("26")) /* Susie Carmichael */ + set(root_fam, parents(root_person)) + call combo2() + print("Done Susie.", nl()) + } + print(" ", d(length(plist_person)), " individuals shown on the chart.",nl()) + + /* use chart data to create a PostScript file as output */ + call write_ps(font_name, ifont_name, + x_pages, y_pages, high_depth, low_depth) + + /* apply external file conversion/viewing command */ + newfile(outfile(), TRUE) /* thump output buffer */ + + list(actions) + list(choices) + print("Output file full-name: ", outfile(), nl()) + enqueue(choices, "Convert with 'ps2pdf'") + if(eqstr(paper_name, "NONE")) { + enqueue(actions, concat("ps2pdf -dPDFSETTINGS=/printer ", outfile(), + " `echo ", outfile(), "|sed 's:\.ps:\.pdf:'` && rm -i ", outfile() )) + } else { + enqueue(actions, concat("ps2pdf -dPDFSETTINGS=/printer ", + "-sPAPERSIZE=", paper_name, " ", + outfile(), + " `echo ", outfile(), "|sed 's:\.ps:\.pdf:'` && rm -i ", outfile() )) + } + /*enqueue(actions, concat("ps2pdf ", outfile())*/ + enqueue(choices, "View with 'MacGhostViewX'") + enqueue(actions, concat("open -a ", + "/Applications/MacGhostViewX/MacGhostViewX.app ", outfile())) + enqueue(choices, "Convert with 'PStill'") + enqueue(actions, concat("open -a ", + "/Applications/Stone\\ Studio/PStill.app ", outfile())) + set(mc, menuchoose(choices, "Choose an action or (q)uit to leave as is")) + if(mc) { + print("performing: ", getel(actions, mc), nl()) + system(getel(actions, mc)) + } + + } +} + +/* +** function: do_anc +** +** A recursive function to position persons on an ancestral chart. +** First, a recursive call is made to put the father on the chart. +** Where he is put on the chart determines the minimum position for +** the mother. Once the father and mother are put on the chart, the +** siblings are put on the chart. +** +*/ + +func do_anc(person, depth, person_minpos, marriage_date, has_des, rel, duplicate) { + if( or( gt(depth, add(high_depth, 1)), eq(length(plist_person), 0)) ) { + set(ceiling, FALSE) + } else { + set(ceiling, TRUE) + } + set(min_gap_set, FALSE) + if(and(tighten, lt(depth, max_depth))) { + call cloak(add(depth, 1)) + } + set(abs_min_pos, get_clearance(depth, 0)) + if(gt(depth, max_depth)) { + set(duplicate_anc_return, 0) + set(min_gap_return, -1) + return(max(person_minpos, abs_min_pos)) + } + + set(fam, choosefamc(person)) + set(rel_next, rel_famc(person, fam, rel)) + if(fam) { /* make a var suitable for passing as a parameter */ + set(has_anc, 1) + } else { + set(has_anc, 0) + } + if(mom_first) { + set(par1, mother(person)) + set(par2, father(person)) + } else { + set(par1, father(person)) + set(par2, mother(person)) + } + set(notcutoff, not( + and( eq(duplic_handling, 2), or(duplicate, blocked(person, depth)) ) )) + + /* Figure out number of siblings and total sibling height. */ + /* Father is allowed to be older_sib_height above person_minpos. */ + /* sibling_height will be min distance between the first and last */ + /* sibling horizontal */ + set(sibling_height, 0) + set(older_sib_height, 0) + set(num_not_younger, 1) /* count of prior sibling buffers space */ + if(and( fam, le(depth, depth_siblings), notcutoff )) { + set(num_siblings, nchildren(fam)) + children(fam, child, cn) { + if(eq(person, child)) { + set(older_sib_height, sibling_height) + if(gt(num_siblings, 1)) { + set(older_sib_height, add(older_sib_height, corner_height)) + } + set(num_not_younger, cn) + } + if(ne(cn, num_siblings)) { + set(sibling_height, add(sibling_height, + person_height2(child, eq(child, person), marriage_date), + min_sibling_spacer)) + } + call reserve(child, depth) + } + call reserve(fam, depth) + } else { + set(num_siblings, 1) + call reserve(person, depth) + } + + /* See if father had any other children by a different mother + * and add up the space to show them. */ + set(branch_top, max(sub(person_minpos, older_sib_height), abs_min_pos)) + /* space for adjustment for cases except half-sibs with their ancestors */ + if(ceiling) { + set(min_gap, sub(branch_top, abs_min_pos)) + } + set(hsibling_height, 0) + set(do_hs, 0) + set(hs_line_start, 0) + /* remember the people of this branch in case they have to be moved */ + call remember_branch_start() /* for branch adjustment */ + + if(and( gt(nfamilies(par1), 1), le(depth, depth_siblings), + halfsib, notcutoff )) { + set(dup_line, 1) + families(par1, fv, sv, nf) { +/* if(ne(fam, fv)) {*/ +/* RES: stopgap */ + if(nestr(key(fam), key(fv))) { + set(dup_line, and( dup_line, blocked(fv, depth))) + if(and( halfsib_anc, le(depth, depth_halfsib_anc), notcutoff )) { + call reserve(fv, depth) /* reserve since parents will show */ + set(mdate, dateplace(marriage(fv), dateplace_marriage)) + set(pos, do_anc(sv, add(depth, 1), add(branch_top, hsibling_height), + mdate, 1, 0, duplicate) ) + if(not(do_hs)){ + set(hs_line_start, pos) /* top end of half sib. vertical */ + set(branch_top, pos) + /* this min_gap will be less than or equal to the previous one */ + if(and(ceiling, ne(min_gap_return, -1))) { + set(min_gap, min(min_gap_return, min_gap)) + set(min_gap_set, TRUE) + } + set(do_hs, 1) + } else { + set(hs_bottom, pos) + /* show children by previous spouse */ + set(pos, distribute_children(fv_prev, branch_top, hs_bottom, + hsibling_height, depth, rel_next) ) + set(branch_top, hs_bottom) + } + set(fv_prev, fv) + /* figure height of siblings by current spouse */ + set(hsibling_height, corner_height) + children(fv, child, cn) { + set(hsibling_height, add(hsibling_height, + person_height2(child, FALSE, 0), min_sibling_spacer)) + call reserve(child, depth) + } + } else { + children(fv, child, cn) { + set(hsibling_height, add(hsibling_height, + person_height2(child, FALSE, 0), min_sibling_spacer)) + call reserve(child, depth) + if(not(do_hs)) { + set(do_hs, 1) + } + } + } + } + } /* end families loop for stepfamilies via parent #1 */ + } + + /* do father if he exists and is not too deep */ + set(dad_min_pos, add(branch_top, hsibling_height) ) + if(and( fam, lt(depth, max_depth), notcutoff )) { + /* don't want to stretch the siblings, so constrain dad * + * to be older_sib_height distance from person_minpos; * + * it will get added back before placement of person */ + set(dad_pos, do_anc(par1, add(depth, 1), dad_min_pos, + dateplace(marriage(fam), dateplace_marriage), 1, rel_next, + or(duplicate, blocked(person, depth))) ) + set(first_sib_pos, add(dad_pos, corner_height)) + set(dup_dad, duplicate_anc_return) + if( and( ceiling, ne(min_gap_return, -1), not(min_gap_set) ) ) { + set(min_gap, min(min_gap_return, min_gap)) + set(min_gap_set, TRUE) + } + } else { /* didn't do dad */ + set(dad_pos, dad_min_pos) + if(gt(num_siblings, 1)) { + /* if there are siblings then allow for just corner_height vert. * + * line above first sibling when siblings aren't shown */ + set(first_sib_pos, add(dad_pos, corner_height)) + } else { + set(first_sib_pos, dad_min_pos) + } + set(dup_dad, 0) + } + + /* Do mother if she exists and is not too deep. */ + /* Her branch, will be at least branch_dist_same from dad's branch. */ + set(last_sib_pos, add(first_sib_pos, sibling_height)) + set(mom_min_pos, last_sib_pos) + if(and( fam, lt(depth, max_depth), notcutoff )) { + set(mom_min_pos, add(mom_min_pos, corner_height)) + set(mom_pos, do_anc(par2, add(depth, 1), mom_min_pos, 0, 1, rel_next, + or(duplicate, blocked(person, depth))) ) + set(last_sib_pos, sub(mom_pos, corner_height)) + set(dup_mom, duplicate_anc_return) + set(do_vertical_line, TRUE) + } else { /* didn't do mom */ + if(gt(num_siblings, 1)) { + /* if more than one sibling then corner_height * + * is added to siblings vertical line */ + set(mom_pos, add(mom_min_pos, corner_height)) + set(do_vertical_line, TRUE) + } else { + /* no vertical line */ + set(mom_pos, mom_min_pos) + set(do_vertical_line, FALSE) + } + set(dup_mom, 0) + } + + /* find the spacer needed to line up siblings between mother and father */ + set(extra, sub(sub(last_sib_pos, first_sib_pos), sibling_height)) + set(spacer, div(extra, add(num_siblings, 1))) + if(and( debug, lt(spacer, 0) )) { + print(" Spacer<0 for ", name(person), "(", key(person), ")", nl()) + print(" Dad_min_pos, dad_pos: ", d(dad_min_pos), ", ", d(dad_pos), nl()) + print(" sibling_height: ", d(sibling_height), nl()) + print(" Mom_min_pos, mom_pos: ", + d(mom_min_pos), ", ", d(mom_pos), nl(), nl()) + } + + /* Shift the parents' branches back up the page if possible. */ + /* min_gap = space availble for upward shift */ + /* compared with diff between anticipated person_pos and minimum person_pos */ + /* - includes stretching of older siblings */ + set(person_pos, add(dad_pos, older_sib_height, mul(num_not_younger, spacer))) + set(gapshrink, sub(person_minpos, person_pos)) + if(ceiling) { + set(gapshrink, max(neg(min_gap), gapshrink)) + } + + /* call branch_adjust to pop the branch_start* stacks, even if shift=0 */ + call branch_adjust(gapshrink) + if(ne(gapshrink, 0)) { + /* adjust local position variables affected by branch shift */ + set(dad_pos, add(dad_pos, gapshrink)) + set(mom_pos, add(mom_pos, gapshrink)) + set(first_sib_pos, add(first_sib_pos, gapshrink)) + /*set(last_sib_pos, add(last_sib_pos, gapshrink))*/ /*RES-not used again */ + if(do_hs) { + set(branch_top, add(branch_top, gapshrink)) + set(hs_line_start, add(hs_line_start, gapshrink)) + } + if(ceiling) { + set(min_gap, min(0, add(min_gap, gapshrink))) + } + if(debug) { + print(" ", make_thousandths(neg(gapshrink))) + print(" units of space recovered for the branch of ", name(person), nl()) + } + } + + /* position siblings differently depending on whether there's more than 1 */ + set(pos, first_sib_pos) + if(and( le(depth, depth_siblings), gt(num_siblings, 1), notcutoff )) { + children(fam, child, cn) { + set(pos, add(pos, spacer)) + /* if this is the ancestor, return the position and use marriage */ +/* if(eq(child, person)) {*/ +/*RES: stopgap measure for INDI equality problem in LL from CVS March 2004 */ if(eqstr(key(child), key(person))) { + call enqueue_person(child, depth, pos, rel, marriage_date, + 1, has_des, fam) + set(do_anc_return, pos) + set(duplicate_anc_return, duplicate_return) + } else { + call enqueue_person(child, depth, pos, half(rel_next), 0, 1, 0, fam) + } + /* increment position by height of person, used for high_pos */ + set(pos, add(pos, + person_height2(child, eq(child, person), marriage_date))) + if(ne(cn, num_siblings)) { + set(pos, add(pos, min_sibling_spacer)) + } + } /* end of children loop */ + + } else { /* depth > depth_siblings or person has no siblings */ + if(do_vertical_line) { + /* center person on vertical line of parent(s) */ + set(pos, add(pos, spacer)) + } + call enqueue_person(person, depth, pos, rel, marriage_date, + has_anc, has_des, fam) + set(do_anc_return, pos) + set(duplicate_anc_return, duplicate_return) + /* increment position by height of person, used for */ + /* high_pos and maternal half siblings line start */ + set(pos, add(pos, person_height2(person, TRUE, marriage_date))) + } + + if(do_vertical_line) { + call enqueue_vertical(depth, dad_pos, mom_pos, rel_next, blocked(fam, depth)) + /* pos is used in setting high_pos later */ + set(pos, max(mom_pos, pos)) + /* only if parents have been shown should a family be considered as shown */ + if(and( lt(depth, max_depth), has_anc, not(blocked(fam, depth)) )) { + call reserve(fam, start_depth) + } + } + + /* If father had any other kids by a different mother print them */ + /* use hpos instead of pos to avoid messing up pos for high_pos setting */ + if(do_hs) { + if(and( halfsib_anc, le(depth, depth_halfsib_anc), notcutoff )) { + set(hs_bottom, dad_pos) + set(hpos, distribute_children(fv_prev, branch_top, hs_bottom, + hsibling_height, depth, rel_next)) + } else { + set(hpos, branch_top) /*sub(dad_pos, hsibling_height)) */ + set(hs_line_start, hpos) + families(par1, fv, sv, nf) { +/* if(ne(fam, fv)) {*/ +/* RES: stopgap */ + if(nestr(key(fam), key(fv))) { + children(fv, child, un) { + call enqueue_person(child, depth, hpos, half(rel_next), 0, 1, 0, fv) + /* increment position by height of person */ + set(hpos, add( + hpos, person_height2(child, FALSE, 0), min_sibling_spacer)) + } + } + } + } + call enqueue_vertical(depth, hs_line_start, dad_pos, + half(rel_next), dup_line) + } + + /* See if mother had any other children by a different father */ + set(do_hs, 0) + if(and( halfsib, le(depth, depth_siblings), + gt(nfamilies(par2), 1), notcutoff )) { + set(hs_line_start, mom_pos) + /* pos here is from end of vertical line of parents */ + set(branch_top, + add(max(pos, add(mom_pos, corner_height)), min_sibling_spacer)) + set(dup_line, 1) + set(pos, branch_top) + families(par2, fv, sv, nf) { +/* if(ne(fam, fv)) {*/ +/* RES: more stopgap measure */ + if(nestr(key(fam), key(fv))) { + set(dup_line, and(dup_line, blocked(fv, depth))) + if(and( lt( depth, max_depth), halfsib_anc )) { + set(do_hs, 1) + call reserve(fv, depth) /* reserve since parents will show */ + /* get height of stepfather's children */ + set(hsibling_height, corner_height) + children(fv, child, un) { + set(hsibling_height, add(hsibling_height, + person_height2(child, FALSE, 0), min_sibling_spacer)) + call reserve(child, depth) + } + /* print ancestors of stepfather, including marriage date */ + set(mdate, dateplace(marriage(fv), dateplace_marriage)) + set(hs_bottom, do_anc(sv, add(depth, 1), + add(branch_top, hsibling_height), mdate, 1, 0, duplicate) ) + /* show this stepfather's children */ + set(pos, distribute_children(fv, branch_top, hs_bottom, + hsibling_height, depth, rel_next) ) + set(branch_top, hs_bottom) + } else { + set(hs_bottom, pos) + children(fv, child, un) { + if(not(do_hs)) { /* first maternal half siblings group */ + set(do_hs, 1) + } + call enqueue_person(child, depth, pos, + half(rel_next), 0, 1, 0, fv) + set(hs_bottom, pos) + set(pos, add(pos, person_height2(child, FALSE, 0), + min_sibling_spacer)) + } + } + } + } + /* If there were any maternal half siblings draw the vertical line */ + if(do_hs) { + call enqueue_vertical(depth, hs_line_start, hs_bottom, + half(rel_next), dup_line) + } + } + + if(ceiling) { + set(min_gap_return, min_gap) + } else { + set(min_gap_return, -1) + } + call max_with_high_pos_gen(depth, pos) + return(do_anc_return) +} + +/* +** function: do_des2 +** +** Produces descendant branches which recursively do as follows: +** For the specified person, show all spouses and, if not at the generation +** limit, show in the next generation a descendant branch for each child +** by those spouses. +** +** Branches may be directed up or down, under the influence of the user +** option 'updown_override'. However, a person's marriages are always +** in database order from top to bottom. +** +** If the user option 'duplic_handling' specifies that truncation of +** a duplicate person's branch is prefered, this is done only if +** all of a person's marriages have been shown. +*/ + +func do_des2(person, depth, min_pos, updown, rel, has_anc, duplicate, famc) { + set(rel, rel_famc(person, famc, rel)) + set(nfam, nfamilies(person)) + set(child_depth, sub(depth, 1)) + if(eq(updown, NEUTRAL)) { + if(or( and(mom_first, eqstr(sex(person), "F")), + and(not(mom_first), eqstr(sex(person), "M")) )) { + set(updown, direction(DOWN)) + } else { + set(updown, direction(UP)) + } + } + set(notcutoff, not(and( + eq(duplic_handling, 2), or(duplicate, blocked(person, depth)) ))) + if(not(notcutoff)) { /* if we're about to cut off a branch... */ + families(person, fv, sp, nf) { /* cut off only if all marriages are shown */ + set(notcutoff, or(notcutoff, not(blocked(fv, depth)))) + } + } + if(tighten) { + call cloak(add(depth, 1)) + call cloak(child_depth) + } + if(and( eq(updown, UP), notcutoff )) { + if(or( lt(depth, sub(low_depth, 1)), + and(lt(depth, low_depth), cloak_check(low_depth)) )) { + set(ceiling, FALSE) + } else { + set(ceiling, TRUE) + } + call remember_branch_start() + if(nfam) { + set(line_top, branch_up(person, 0, depth, 1, rel)) + set(person_pos, branch_up_min_pos) + } else { + set(person_pos, get_clearance(depth, min_pos)) + } + call enqueue_person(person, depth, person_pos, rel, 0, has_anc, nfam, famc) + set(shift, sub(min_pos, person_pos)) + if(ceiling) { + set(shift, max(0, shift)) + } + call branch_adjust(shift) + set(person_pos, add(person_pos, shift)) + if(nfam) { + set(line_top, add(line_top, shift)) + call enqueue_vertical(child_depth, line_top, person_pos, + rel, dup_line_return) + } + call max_with_high_pos_gen(depth, + add(person_pos, person_height2(person, 0, 0))) + } elsif(and( eq(updown, DOWN), notcutoff )) { + set(person_pos, get_clearance(depth, min_pos)) + set(person_extent, add(person_pos, person_height2(person, 0, 0))) + if(nfam) { + set(person_pos, branch_down(person, person_pos, person_extent, TRUE, 0, + depth, 1, rel)) + } else { + call max_with_high_pos_gen(depth, person_extent) + } + call enqueue_person(person, depth, person_pos, rel, 0, has_anc, nfam, famc) + } else { /* cut off this person's branch */ + set(person_pos, get_clearance(depth, min_pos)) + call enqueue_person(person, depth, person_pos, rel, 0, has_anc, 0, famc) + set(person_extent, add(person_pos, person_height2(person, 0, 0))) + call max_with_high_pos_gen(depth, person_extent) + } + return(person_pos) +} + +/* +** procedure: distribute_children +** +** Given a family key, evenly space +** the children of the family in a vertical range determined +** by top and bottom positions of the range. +** +** sibling_height should include an extra corner_height to allow for +** vertical skip that balances with the mandatory corner_height skip that +** follows the last sibling's placement. +** +*/ +/* RES - would be nice to either eliminate this pocedure or make + it general enough to take on more tasks from do_anc +*/ + +func distribute_children(fam, top, bottom, sibling_height, depth, rel) { + set(extra, sub(bottom, add(top, sibling_height))) + set(spacer, div(extra, add(nchildren(fam), 1))) + if(and(debug, lt(spacer, 0))) { + print(" distribute_children: spacer < 0 !!\n") + print(" top: ", d(top), " bottom: ", d(bottom), nl()) + } + + set(pos, add(top, corner_height, spacer)) + children(fam, child, num) { + call enqueue_person(child, depth, pos, half(rel), 0, 1, 0, fam) + set(pos, add( + pos, person_height2(child, FALSE, 0), min_sibling_spacer, spacer)) + } + return(pos) +} + +/* +** function: branch_up +** +** For a specific person, charts his/her spouses and the children/descendants +** by them. +** +** Shouldn't be called if nfamilies(person) is 0, or 1 when exclude_fam=0. +** To notify us of a problem, this function is designed to intentionally +** force an error message if there are no families to work with. That is +** because there is no good value to return in that case. +*/ +/* RES -- add descriptions of the various return values to the above comment */ + +func branch_up(person, exclude_fam, depth, show_des, rel) { + set(child_depth, sub(depth, 1)) + set(nfam, nfamilies(person)) + if(exclude_fam) { decr(nfam) } + set(switch_fam, half(add(nfam, 1))) /* last family to branch up */ + set(dup_line, 1) + set(dir, UP) + set(fnn, 0) + if(tighten) { + call cloak(add(depth, 1)) + call cloak(child_depth) + } + set(spouse_minpos, get_clearance(depth, 0)) + families(person, fv, sv, fn) { + if(ne(fv, exclude_fam)) { + incr(fnn) + set(dup_line, and(dup_line, blocked(fv, depth))) + call reserve(sv, depth) + call reserve(fv, depth) + if(tighten) { + call cloak(sub(child_depth, 1)) + } + set(child_minpos, add(spouse_minpos, corner_height)) + set(child_minpos, get_clearance(child_depth, child_minpos)) + set(child_extent, 0) + set(first_child_pos, child_minpos) + if(gt(depth, min_depth)) { + set(num_children, nchildren(fv)) + set(switch_child, half(add(nchildren(fv), 1))) + children(fv, child, cn) { + if(show_des) { + set(child_pos, + do_des2(child, child_depth, child_minpos, dir, rel, 1, 0, fv)) + } else { + set(child_pos, child_minpos) + call enqueue_person(child, child_depth, child_pos, rel, 0, 1, 0, fv) + set(child_extent, add(child_pos, person_height2(child, 0, 0))) + set(child_minpos, add(child_extent, min_sibling_spacer)) + } + if(eq(cn, 1)) { + set(first_child_pos, child_pos) + } + if(eq(cn, num_children)) { + set(spouse_minpos, add(child_pos, corner_height)) + } + if(and(eq(nfam, 1), eq(cn, switch_child))) { + set(dir, DOWN) + } + } + if(num_children) { + call max_with_high_pos_gen(child_depth, child_extent) + } + } + set(spouse_pos, sub(first_child_pos, corner_height)) + if(eq(fnn, 1)) { + set(branch_top, spouse_pos) + } + /* + print("sp: ", d(spouse_pos), " bt: ", d(branch_top), " fnn: ", d(fnn), " fv: ", key(fv), nl()) + */ + if(le(depth, max_depth)) { + set(mdate, dateplace(marriage(fv), dateplace_marriage)) + call enqueue_person(sv, depth, spouse_pos, 0, mdate, 0, 1, 0) + set(spouse_extent, add(person_height2(sv, TRUE, mdate), spouse_pos)) + call max_with_high_pos_gen(depth, spouse_extent) + if(not(blocked(fv, depth))) { + call reserve(fv, start_depth) + } + set(spouse_minpos, + max(add(get_high_pos_gen(depth), branch_dist_same), spouse_minpos)) + } + if(eq(fnn, switch_fam)) { + set(dir, DOWN) + } + } + } + set(branch_up_min_pos, spouse_minpos) + set(dup_line_return, dup_line) + return(branch_top) +} + +/* +** procedure: branch_down +** +** person_extent should be either the bottom of the info on the person, +*/ +/* RES -- add descriptions of the various return values to the above comment + also need to just fix the above comment +*/ + +func branch_down(person, prev_spouse_pos, prev_spouse_extent, adjustable, exclude_fam, depth, show_des, rel) { + set(person_pos, prev_spouse_pos) + set(child_depth, sub(depth, 1)) + set(nfam, nfamilies(person)) + if(exclude_fam) { decr(nfam) } + set(switch_fam, half(nfam)) /* last family to branch up */ + set(dup_line, 1) + if(tighten) { + call cloak(sub(child_depth, 1)) + } + set(child_minpos, add(prev_spouse_pos, corner_height)) + set(child_minpos, get_clearance(child_depth, child_minpos)) + set(dir, direction(UP)) + set(fnn, 0) + families(person, fv, sv, fn) { + if(ne(fv, exclude_fam)) { + incr(fnn) + set(dup_line, and(dup_line, blocked(fv, depth))) + call reserve(sv, depth) + call reserve(fv, depth) + if(tighten) { + call cloak(sub(child_depth, 1)) + } + set(child_minpos, add(prev_spouse_pos, corner_height)) + set(child_minpos, get_clearance(child_depth, child_minpos)) + set(child_extent, 0) + set(first_child_pos, child_minpos) + set(last_child_pos, child_minpos) + call remember_branch_start() + if(gt(depth, min_depth)) { + set(num_children, nchildren(fv)) + set(switch_child, half(num_children)) /* favors DOWN when odd num_ch. */ + if(and(eq(nfam, 1), eq(switch_child, 0))) { + set(dir, direction(DOWN)) + } + children(fv, child, cn) { + if(show_des) { + set(child_pos, + do_des2(child, child_depth, child_minpos, dir, rel, 1, 0, fv)) + } else { + set(child_pos, child_minpos) + call enqueue_person(child, child_depth, child_pos, + rel, 0, 1, 0, fv) + set(child_extent, add(child_pos, person_height2(child, 0, 0))) + set(child_minpos, add(child_extent, min_sibling_spacer)) + } + if(eq(cn, 1)) { + set(first_child_pos, child_pos) + } + if(eq(cn, num_children)) { + set(last_child_pos, child_pos) + } + if(and(eq(nfam, 1), eq(cn, switch_child))) { + set(dir, direction(DOWN)) + } + } + if(num_children) { + call max_with_high_pos_gen(child_depth, child_extent) + } + } + set(spouse_pos, add(last_child_pos, corner_height)) + /* adjust children + spouse to keep spouse clear of prev parent info */ + set(shift, max( + 0, sub(add(prev_spouse_extent, branch_dist_same), spouse_pos) )) + call branch_adjust(shift) + set(first_child_pos, add(first_child_pos, shift)) + set(spouse_pos, add(spouse_pos, shift)) + if(and(eq(fnn, 1), adjustable)) { + set(person_pos, add(prev_spouse_pos, min( + sub(sub(first_child_pos, corner_height), prev_spouse_pos), + max(0, sub(spouse_pos, add(prev_spouse_extent, branch_dist_same))) + ))) + } + if(le(depth, max_depth)) { + set(mdate, dateplace(marriage(fv), dateplace_marriage)) + call enqueue_person(sv, depth, spouse_pos, 0, mdate, 0, 1, 0) + set(spouse_extent, add(person_height2(sv, TRUE, mdate), spouse_pos)) + } else { + set(spouse_extent, name_height) + } + set(prev_spouse_pos, spouse_pos) + set(prev_spouse_extent, spouse_extent) + /* set next fam's child_minpos before this spouse can interfere */ + set(child_minpos, add(prev_spouse_pos, corner_height)) + set(child_minpos, get_clearance(child_depth, child_minpos)) + if(le(depth, max_depth)) { + call max_with_high_pos_gen(depth, spouse_extent) + if(not(blocked(fv, depth))) { + call reserve(fv, start_depth) + } + } + if(eq(fnn, switch_fam)) { + set(dir, direction(DOWN)) + } + } + } + if(gt(fnn, 0)) { + call enqueue_vertical(child_depth, person_pos, spouse_pos, rel, dup_line) + } + return(person_pos) +} + +/* +** function: dropline +** +** Generates a drop line chart of descendants of a person. +** The return value is the vertical position of the person's horizontal line. +** +*/ + +func dropline(person, depth, has_anc, duplicate, rel, famc) { + set(rel, rel_famc(person, famc, rel)) + set(abs_min_pos, get_clearance(depth, 0)) + set(child_depth, sub(depth, 1)) + set(low_depth, min(depth, low_depth)) + set(high_depth, max(depth, high_depth)) + set(notcutoff, not(and( + eq(duplic_handling, 2), or(duplicate, blocked(person, depth)) ))) + if(and(desc_gender, ne(depth, start_depth))) { + set(notcutoff, and(notcutoff, or( + and(eq(desc_gender, 1), eqstr(sex(person), "F")), + and(eq(desc_gender, 2), eqstr(sex(person), "M")) ))) + } + call reserve(person, depth) + set(line_to_kids, FALSE) + set(vertical_line, FALSE) + set(dup_line, TRUE) + set(first_pos, abs_min_pos) + set(last_pos, first_pos) + set(child_pos, first_pos) + call remember_branch_start() + families(person, fam, spouse, fn) { + set(dup_line, and(dup_line, blocked(fam, depth))) + call reserve(fam, depth) + children(fam, child, cn) { + if(and(ge(child_depth, min_depth), notcutoff)) { + set(child_pos, dropline(child, child_depth, TRUE, + or(duplicate, blocked(person, depth)), rel, fam)) + if(not(line_to_kids)) { + set(first_pos, child_pos) + } else { + set(vertical_line, TRUE) + } + } + set(line_to_kids, TRUE) + } + if(and( ge(child_depth, min_depth), not(blocked(fam, depth)), + notcutoff)) { + /* marriage, indicated by vert. line, is original on the chart */ + call reserve(fam, start_depth) + } + } + + set(last_pos, child_pos) + if(vertical_line) { + call enqueue_vertical(child_depth, first_pos, last_pos, 2, dup_line) + } + + set(this_pos, half(add(first_pos, last_pos))) + set(shift, max(0, sub(abs_min_pos, this_pos))) + call branch_adjust(shift) + set(this_pos, add(this_pos, shift)) + call enqueue_person(person, depth, this_pos, rel, 0, has_anc, line_to_kids, famc) + + /* RES - this could be made obsolete if done by enqueue_person */ + /* maybe enqueue_person could return the person's extent */ + set(this_extent, add(this_pos, person_height2(person, FALSE, 0))) + call max_with_high_pos_gen(depth, this_extent) + return(this_pos) +} + + +/* +** procedure: combo2 +** +** Show ancestors and descendants of a couple. +*/ + +proc combo2() { + set(child_depth, sub(start_depth, 1)) + if(mom_first) { + set(par1, wife(root_fam)) + set(par2, husband(root_fam)) + } else { + set(par1, husband(root_fam)) + set(par2, wife(root_fam)) + } + set(mdate, dateplace(marriage(root_fam), dateplace_marriage)) + set(num_siblings, nchildren(root_fam)) + + call reserve(root_fam, start_depth) + call reserve(par1, start_depth) + call reserve(par2, start_depth) + + if(gt(nfamilies(par1), 1)) { + set(hline_top, branch_up(par1, root_fam, start_depth, 1, 1)) + } + call remember_branch_start() + set(dad_pos, do_anc(par1, start_depth, 0, 0, 1, 2, 0) ) + + if(and( ge(num_siblings, 1), gt(start_depth, min_depth) )) { + set(first_sib_pos, add(dad_pos, corner_height)) + set(child_minpos, first_sib_pos) + set(prev_pos, child_minpos) + set(last_sib_pos, first_sib_pos) + set(dir, direction(UP)) + set(switch_child, half(add(nchildren(root_fam), 1))) + children(root_fam, child, cn) { + call cloak(start_depth) + call remember_branch_start() + set(this_pos, + do_des2(child, child_depth, child_minpos, dir, 2, 1, 0, root_fam) ) + set(prev_pos, this_pos) + if(eq(cn, 1)) { + set(first_sib_pos, this_pos) + } + if(eq(cn, num_siblings)) { + set(last_sib_pos, this_pos) + } + if(eq(cn, switch_child)) { + set(dir, direction(DOWN)) + } + } + set(dad_minpos, sub(first_sib_pos, corner_height)) + set(sibling_span, add( + sub(last_sib_pos, first_sib_pos), mul(2, corner_height) )) + } else { + set(sibling_span, 0) + set(dad_minpos, dad_pos) + } + + set(shift, sub(dad_minpos, dad_pos)) + call branch_adjust_first(shift) + /* need to shift dad's ancestor branch */ + set(dad_pos, dad_minpos) + + set(mom_minpos, add(dad_pos, sibling_span)) + call remember_branch_start() + call cloak(child_depth) + set(mom_pos, do_anc(par2, start_depth, mom_minpos, mdate, 1, 2, 0) ) + + set(mom_shift, max(0, sub(mom_pos, mom_minpos))) + call multi_branch_adjust(mom_shift, nchildren(root_fam)) + + /* dad's marriage line for other spouses + do this now to avoid the vert line being shifted by multi_branch_adjust */ + if(gt(nfamilies(par1), 1)) { + call enqueue_vertical(child_depth, hline_top, dad_pos, 1, dup_line_return) + } + + + call enqueue_vertical(child_depth, dad_pos, mom_pos, 2, 0) + + set(not_used, + branch_down(par2, mom_pos, 0, FALSE, root_fam, start_depth, 1, 1)) +} + + +/* +** procedure: do_cousins +** show a couple as married along with their ancestors, descendants, and +** the descendants of their siblings +*/ + +proc do_cousins() { + set(child_depth, sub(start_depth, 1)) + set(grand_depth, add(start_depth, 1)) + + set(num_sib, nchildren(root_fam)) + set(mdate_root_fam, dateplace(marriage(root_fam), dateplace_marriage)) + if(mom_first) { + set(par1, wife(root_fam)) + set(par2, husband(root_fam)) + } else { + set(par1, husband(root_fam)) + set(par2, wife(root_fam)) + } + + set(dfam, choosefamc(par1)) + set(drel, rel_famc(par1, dfam, 2)) + if(dfam) { + set(num_dsib, nchildren(dfam)) + set(mdate_dfam, dateplace(marriage(dfam), dateplace_marriage)) + if(mom_first) { + set(dpar1, wife(dfam)) + set(dpar2, husband(dfam)) + } else { + set(dpar1, husband(dfam)) + set(dpar2, wife(dfam)) + } + } else { + set(dpar1, 0) + set(dpar2, 0) + set(num_dsib, 1) + set(mdate_dfam, 0) + } + + set(mfam, choosefamc(par2)) + set(mrel, rel_famc(par2, mfam, 2)) + if(mfam) { + set(num_msib, nchildren(mfam)) + set(mdate_mfam, dateplace(marriage(mfam), dateplace_marriage)) + if(mom_first) { + set(mpar1, wife(mfam)) + set(mpar2, husband(mfam)) + } else { + set(mpar1, husband(mfam)) + set(mpar2, wife(mfam)) + } + } else { + set(mpar1, 0) + set(mpar2, 0) + set(num_msib, 1) + set(mdate_mfam, 0) + } + + call reserve(par1, start_depth) + call reserve(par2, start_depth) + call reserve(root_fam, start_depth) + if(dfam) { /* this is enough to catch extra appearances in anc branches */ + call reserve(dpar1, grand_depth) + call reserve(dpar2, grand_depth) + call reserve(dfam, grand_depth) + families(dpar1, fv, sv, fn) { /* claim originality for start_depth people */ + children(fv, cv, cn) { + call reserve(cv, start_depth) + families(cv, cfv, csv, cfn) { + call reserve(cfv, start_depth) + } + } + } + families(dpar2, fv, sv, fn) { + if(ne(sv, dpar1)) { + children(fv, cv, cn) { + call reserve(cv, start_depth) + families(cv, cfv, csv, cfn) { + call reserve(cfv, start_depth) + } + } + } + } + } + if(mfam) { + call reserve(mpar1, grand_depth) + call reserve(mpar2, grand_depth) + call reserve(mfam, grand_depth) + families(mpar1, fv, sv, fn) { /* claim originality for start_depth people */ + children(fv, cv, cn) { + call reserve(cv, start_depth) + families(cv, cfv, csv, cfn) { + call reserve(cfv, start_depth) + } + } + } + families(mpar2, fv, sv, fn) { + if(ne(sv, mpar1)) { + children(fv, cv, cn) { + call reserve(cv, start_depth) + families(cv, cfv, csv, cfn) { + call reserve(cfv, start_depth) + } + } + } + } + } + + print(" Determining relative spacing of 1st parent's ancestors...\n") + if(gt(nfamilies(dpar1), 1)) { + set(hline_top, branch_up(dpar1, dfam, grand_depth, FALSE, half(drel))) + call cloak(start_depth) + } + set(ddad_pos, do_anc(dpar1, grand_depth, 0, mdate_dfam, 1, drel, 0) ) + set(ddad_minpos, ddad_pos) + + set(dmom_pos, do_anc(dpar2, grand_depth, ddad_minpos, 0, 1, drel, 0) ) + set(dmom_relpos, sub(dmom_pos, ddad_pos)) + if(not(blocked(dfam, grand_depth))) { + call reserve(dfam, start_depth) + } +/* RES interferes with relative position figuring of the grandparents */ +/* RES need to just replace this with a reserving of the spouses and children */ +/* + set(not_used, branch_down(dpar2, dmom_pos, 0, FALSE, dfam, + grand_depth, FALSE, half(drel))) +*/ + + print(" Determining relative spacing of 1st parent's siblings...\n") + set(child_minpos, add(ddad_minpos, corner_height)) + set(prevpos, child_minpos) + if(gt(num_dsib, 1)) { + list(dsib_relpos) + set(dir, direction(UP)) /* all of 1st parent's siblings can branch up */ + set(cnn, 0) + children(dfam, child, cn) { + if(ne(child, par1)) { + set(cnn, add(cnn, 1)) + call cloak(grand_depth) + set(thispos, + do_des2(child, start_depth, child_minpos, dir, + half(drel), 1, 0, dfam)) + setel(dsib_relpos, cn, sub(thispos, prevpos)) + set(prevpos, thispos) + if(eq(cnn, 1)) { + set(first_dsib_pos, thispos) + setel(dsib_relpos, cn, 0) + } + if(eq(cnn, sub(num_dsib, 1))) { + set(last_dsib_pos, thispos) + set(dad_minpos, add(thispos, + person_height2(child, FALSE, 0), branch_dist_same)) + } + } + } + /* ddad_minpos might be affected by up-branching of descendants */ + set(ddad_minpos, sub(first_dsib_pos, corner_height)) + } else { + set(first_dsib_pos, child_minpos) + set(last_dsib_pos, first_dsib_pos) + set(dad_minpos, add(ddad_minpos, corner_height)) + } + + print(" Determining relative spacing of the family's descendants...\n") + if(gt(nfamilies(par1), 1)) { + call cloak(grand_depth) + set(line_top, branch_up(par1, root_fam, start_depth, TRUE, 1)) + set(dad_minpos, max( + dad_minpos, add(get_high_pos_gen(start_depth), branch_dist_same) )) + } + set(dad_relpos, sub(dad_minpos, last_dsib_pos)) + set(older_dsib_height, sub(dad_minpos, ddad_minpos)) + + set(prevpos, add(dad_minpos, corner_height)) + set(child_minpos, prevpos) + if( and(gt(num_sib, 0), ge(child_depth, min_depth)) ) { + list(sib_relpos) + set(dir, direction(UP)) + set(switch_child, half(add(nchildren(root_fam), 1))) + children(root_fam, child, cn) { + call cloak(start_depth) + set(thispos, + do_des2(child, child_depth, child_minpos, dir, 2, 1, 0, root_fam) ) + setel(sib_relpos, cn, sub(thispos, prevpos)) + set(prevpos, thispos) + if(eq(cn, 1)) { + set(first_sib_pos, thispos) + setel(sib_relpos, cn, 0) + } + if(eq(cn, num_sib)) { + set(last_sib_pos, thispos) + } + if(eq(cn, switch_child)) { + set(dir, direction(DOWN)) + } + } + } else { + set(first_sib_pos, child_minpos) + set(last_sib_pos, first_sib_pos) + } + set(sib_span, add(sub(last_sib_pos, first_sib_pos), mul(2, corner_height))) + /* place dad corner_height before his first child */ + set(dad_pos, max( dad_minpos, sub(first_sib_pos, corner_height) )) + if(gt(num_dsib, 1)) { +/* commented out because it can cause first parent to push away from siblings*/ +/* set(dad_relpos, sub(dad_pos, last_dsib_pos))*/ + set(older_dsib_height, sub(dad_pos, ddad_minpos)) + } + + set(dsib_span, add(older_dsib_height, corner_height)) + set(spacer1, div( max(0, sub(dmom_relpos, dsib_span)), add(num_dsib, 1) )) + set(ddad_minpos, max( ddad_minpos, + sub(sub(dad_pos, older_dsib_height), mul(num_dsib, spacer1)) )) + + call enqueue_person(par1, start_depth, dad_pos, 2, mdate_root_fam, 1, 1, 0) + set(par1_extent, add(dad_pos, person_height2(par1, TRUE, mdate_root_fam))) + call max_with_high_pos_gen(start_depth, par1_extent) + + print(" Determining relative spacing of the 2nd parent's ancestors...\n") +/* RES - up-branch above mother would have parent(s) that block mdad from + determining how close he can go to dmom's branch + + if(gt(nfamilies(mpar1), 1)) { + call cloak(child_depth) + set(hline_top, branch_up(mpar1, mfam, grand_depth, FALSE, half(mrel))) + } +*/ + call cloak(start_depth) /* RES - necessary due to par1 info lines ? */ + set(mdad_pos, do_anc(mpar1, grand_depth, 0, mdate_mfam, 1, mrel, 0)) + set(mdad_relpos, sub(mdad_pos, dmom_pos)) + + call cloak(start_depth) + set(mmom_pos, do_anc(mpar2, grand_depth, mdad_pos, 0, 1, mrel, 0) ) + set(mmom_relpos, sub(mmom_pos, mdad_pos)) + if(not(blocked(mfam, grand_depth))) { + call reserve(mfam, start_depth) + } + set(not_used, branch_down(mpar2, mmom_pos, 0, FALSE, mfam, + grand_depth, FALSE, half(mrel))) + + set(mom_pos, max( add(last_sib_pos, corner_height), + add(get_high_pos_gen(start_depth), branch_dist_same) )) + call enqueue_person(par2, start_depth, mom_pos, 2, 0, 1, 1, 0) + set(par2_extent, add(mom_pos, person_height2(par2, FALSE, 0))) + call max_with_high_pos_gen(start_depth, par2_extent) + set(not_used, branch_down(par2, mom_pos, 0, FALSE, root_fam, + start_depth, TRUE, 1)) + + print(" Determining relative spacing of 2nd parent's siblings...\n") + set(prevpos, mom_pos) + set(child_minpos, + add(mom_pos, person_height2(par2, FALSE, 0), branch_dist_same)) + if(gt(num_msib, 1)) { + list(msib_relpos) + set(dir, direction(DOWN)) /* all of 2nd parent's siblings branch down */ + set(cnn, 0) + children(mfam, child, cn) { + if(ne(child, par2)) { + incr(cnn) + call cloak(grand_depth) + call cloak(child_depth) /* RES experimental */ + set(thispos, do_des2(child, start_depth, child_minpos, + dir, half(mrel), 1, 0, mfam)) + setel(msib_relpos, cn, sub(thispos, prevpos)) + set(prevpos, thispos) + if(eq(cnn, sub(num_msib, 1))) { + set(last_msib_pos, thispos) + } + } + } + } else { + set(last_msib_pos, prevpos) + } + set(msib_span, sub(add(last_msib_pos, corner_height), + sub(mom_pos, corner_height)) ) + set(spacer2, div( max(0, sub(mmom_relpos, msib_span)), add(num_msib, 1) )) + + call initialize_data() +/*------------------------cousin middle-------------------------------------*/ + + print(" Determining final positions on the chart...\n") + call reserve(root_fam, start_depth) + call reserve(par1, start_depth) + call reserve(par2, start_depth) + if(dfam) { /* this is enough to catch extra appearances in anc branches */ + call reserve(dpar1, grand_depth) + call reserve(dpar2, grand_depth) + call reserve(dfam, grand_depth) + families(dpar1, fv, sv, fn) { /* claim originality for start_depth people */ + children(fv, cv, cn) { + call reserve(cv, start_depth) + families(cv, cfv, csv, cfn) { + call reserve(cfv, start_depth) + } + } + } + families(dpar2, fv, sv, fn) { + if(ne(sv, dpar1)) { + children(fv, cv, cn) { + call reserve(cv, start_depth) + families(cv, cfv, csv, cfn) { + call reserve(cfv, start_depth) + } + } + } + } + } + if(mfam) { + call reserve(mpar1, grand_depth) + call reserve(mpar2, grand_depth) + call reserve(mfam, grand_depth) + families(mpar1, fv, sv, fn) { /* claim originality for start_depth people */ + children(fv, cv, cn) { + call reserve(cv, start_depth) + families(cv, cfv, csv, cfn) { + call reserve(cfv, start_depth) + } + } + } + families(mpar2, fv, sv, fn) { + if(ne(sv, mpar1)) { + children(fv, cv, cn) { + call reserve(cv, start_depth) + families(cv, cfv, csv, cfn) { + call reserve(cfv, start_depth) + } + } + } + } + } + + if(gt(nfamilies(dpar1), 1)) { + set(hline_top, branch_up(dpar1, dfam, grand_depth, FALSE, half(drel))) + call cloak(start_depth) + } + set(ddad_pos, do_anc(dpar1, grand_depth, ddad_minpos, mdate_dfam, 1, drel, 0)) + if(gt(nfamilies(dpar1), 1)) { + call enqueue_vertical(start_depth, hline_top, ddad_pos, + half(drel), dup_line_return) + } + if(debug2) { + if(ne(ddad_minpos, ddad_pos)) { + print(" ddad appears to be slipping...", nl()) + print(" ", d(ddad_minpos), " -> ", d(ddad_pos), nl()) + } + } + + set(prevpos, add(ddad_pos, corner_height)) + set(dir, direction(UP)) + children(dfam, child, cn) { + if(ne(child, par1)) { + set(child_minpos, add(prevpos, getel(dsib_relpos, cn), spacer1)) + call cloak(grand_depth) + set(prevpos, + do_des2(child, start_depth, child_minpos, dir, half(drel), 1, 0, dfam)) + if(and(debug, ne(prevpos, child_minpos))) { + print(name(child), " child_minpos != actual\n") + } + } else { + if(ne(cn, num_dsib)) { + print("The first parent has been moved to last in his/her sibling order.", nl()) + } + } + } + + call remember_branch_start() + set(dad_minpos, add(prevpos, dad_relpos)) + if(gt(nfamilies(par1), 1)) { + call cloak(grand_depth) + set(hline_top, branch_up(par1, root_fam, start_depth, TRUE, 1)) + set(dad_pos, max(branch_up_min_pos, + add(get_high_pos_gen(start_depth), branch_dist_same)) ) + } +/* HERE */ + call enqueue_person(par1, start_depth, dad_pos, 2, mdate_root_fam, 1, 1, 0) + set(par1_extent, add(dad_pos, person_height2(par1, TRUE, mdate_root_fam))) + call max_with_high_pos_gen(start_depth, par1_extent) + set(dad_minpos, add(prevpos, dad_relpos, spacer1)) + call branch_adjust(max(0, sub(dad_minpos, dad_pos))) + set(dad_pos, max(dad_minpos, dad_pos)) + if(gt(nfamilies(par1), 1)) { + call enqueue_vertical(child_depth, hline_top, dad_pos, + 1, dup_line_return) + } + + set(dmom_minpos, add(dad_pos, corner_height, spacer1)) + call cloak(start_depth) /* to ignore dsibs */ + set(dmom_pos, do_anc(dpar2, grand_depth, dmom_minpos, 0, 1, drel, 0)) + if(debug2) { + if(ne(dmom_minpos, dmom_pos)) { + print(" dmom appears to be slipping...", nl()) + print(d(dmom_minpos), " -> ", d(dmom_pos), nl()) + } + } + call enqueue_vertical(start_depth, ddad_pos, dmom_pos, drel, + blocked(dfam, grand_depth)) + if(not(blocked(dfam, grand_depth))) { + call reserve(dfam, start_depth) + } + set(not_used, branch_down(dpar2, dmom_pos, 0, FALSE, dfam, + grand_depth, FALSE, half(drel))) + + /* RES - new25jun 1 line*/ + set(mdad_minpos, max(add(dmom_pos, mdad_relpos), + get_high_pos_gen(start_depth))) + if(gt(nfamilies(mpar1), 1)) { + call remember_branch_start() + set(hline_top, branch_up(mpar1, mfam, grand_depth, FALSE, half(mrel))) +/* RES - new22jun */ + set(shift, max(0, sub(mdad_minpos, branch_up_min_pos))) + call branch_adjust(shift) + set(hline_top, add(hline_top, shift)) + call cloak(start_depth) + } + /* RES - max with mdad_minpos + c.h. + sp2 is a safeguard */ + set(mom_pos, max( add(dad_pos, sib_span), + add(mdad_minpos, corner_height, spacer2))) + set(mdad_minpos, max(mdad_minpos, sub(sub(mom_pos, corner_height), spacer2))) + call cloak(start_depth) + set(mdad_pos, do_anc(mpar1, grand_depth, mdad_minpos, mdate_mfam, 1, mrel, 0)) + if(gt(nfamilies(mpar1), 1)) { + call enqueue_vertical(start_depth, hline_top, mdad_pos, + half(mrel), dup_line_return) + } + + set(mmom_minpos, add(mdad_pos, max(mmom_relpos, msib_span)) ) + set(spacer, div( max(0, sub(sub(mom_pos, dad_pos), sib_span)), + add(num_sib, 1) )) + + set(prevpos, add(dad_pos, corner_height)) + if(ge(child_depth, min_depth)) { + set(dir, direction(UP)) + set(switch_child, half(add(nchildren(root_fam), 1))) + children(root_fam, child, cn) { + set(child_minpos, add(prevpos, getel(sib_relpos, cn), spacer)) + call cloak(start_depth) + set(prevpos, + do_des2(child, child_depth, child_minpos, dir, 2, 1, 0, root_fam)) + if(debug) { + if(ne(child_minpos, prevpos)) { + print(" ! Descendant branch slipping down page ! (", + name(child), ")\n") + print(" As a result, there will be extra space above the branch.\n") + } + } + if(eq(cn, switch_child)) { + set(dir, direction(DOWN)) + } + } + } + + if(gt(add(prevpos, spacer, corner_height), mom_pos)) { + print(" 2nd parent will be moved to compensate for descendant slippage\n") + set(mom_pos, max(mom_pos, add(prevpos, spacer, corner_height))) + } + /* RES - fix unknown reason why mom has no corner between her and mpar1 */ + set(mom_pos, max(mom_pos, add(mdad_pos, corner_height, spacer2))) + call enqueue_person(par2, start_depth, mom_pos, 2, 0, 1, 1, 0) + set(par2_extent, add(mom_pos, person_height2(par2, FALSE, 0))) + call max_with_high_pos_gen(start_depth, par2_extent) + call enqueue_vertical(child_depth, dad_pos, mom_pos, 2, 0) + set(not_used, branch_down(par2, mom_pos, 0, FALSE, root_fam, + start_depth, TRUE, 1)) + + set(prevpos, mom_pos) + set(dir, direction(DOWN)) + children(mfam, child, cn) { + if(ne(child, par2)) { + set(child_minpos, add(prevpos, getel(msib_relpos, cn), spacer2)) + call cloak(grand_depth) + call cloak(child_depth) + set(prevpos, + do_des2(child, start_depth, child_minpos, dir, half(mrel), 1, 0, mfam)) + } else { + if(ne(cn, num_msib)) { + print("The second parent has been moved to first in his/her sibling order.", nl()) + } + } + } + + set(mmom_minpos, max(mmom_minpos, add(prevpos, corner_height, spacer2))) + call cloak(start_depth) /* to ignore msibs */ + set(mmom_pos, do_anc(mpar2, grand_depth, mmom_minpos, 0, 1, 2, 0) ) + if(and(debug, ne(mmom_pos, mmom_minpos))) { + print(" mmom appears to be slipping...", nl()) + print(" ", d(mmom_minpos), " -> ", d(mmom_pos), nl()) + } + call enqueue_vertical(start_depth, mdad_pos, mmom_pos, mrel, + blocked(mfam, grand_depth)) + if(not(blocked(mfam, grand_depth))) { + call reserve(mfam, start_depth) + } + set(not_used, branch_down(mpar2, mmom_pos, 0, FALSE, mfam, + grand_depth, FALSE, half(mrel))) +} + +/*========================== end of charting functions ======================*/ + +/* +** function: rel_famc +** +** Checks for a pedigree tag on a FAMC link to determine if the relationsship +** is not by birth. Returns 0 if not birth or echoes the relationship passed +** in otherwise. +*/ + +func rel_famc(ind, fam, rel) { + if(or(not(opt_rel_famc), not(fam))) { + return(rel) + } + set(ped_label, pedigree(ind, fam)) + if(eq(1, index(lower(ped_label), "birth", 1))) { + return(rel) + } else { + return(0) + } +} + +/* +** function: pedigree +** +** Returns a string identifying the nature of a child-to-family (FAMC) link. +** Different relationships are indicated by a subnode tag of PEDI which may +** have the following values: Birth, Adopted, Foster, Sealed +*/ + +func pedigree(ind, fam_match) { + if(or(not(ind), not(fam_match))) { + return(0) + } + set(pedi_label, "") + fornodes(inode(ind), node) { + if(eqstr(tag(node), "FAMC")) { + set(fam_this, fam(value(node))) + if(eq(fam_this, fam_match)) { + set(birth_famc, 1) + set(pedi_label, "Birth (assumed)") + fornodes(node, subnode) { + if(eqstr(tag(subnode), "PEDI")) { + set(birth_famc, 0) + set(pedi_label, value(subnode)) + if( or( eqstr(pedi_label, "Birth"), + eqstr(pedi_label, "birth")) ) { + set(birth_famc, 1) + } elsif(eqstr(pedi_label, "")) { + print("! ", name(indi), + " has a FAMC.PEDI node with no value.", nl()) + } + } + } + } + } + } + return(pedi_label) +} + +/* +** function: choosefamc +** +** Offers the choice of parent families of a child when there are several, +** as with adoption, fostering, or sealing (LDS). +** A child-to-family link is indicated by a FAMC tag with a family +** cross-reference in an individual's GEDCOM record. +** +*/ + +func choosefamc(ind) { + if(not(ind)) { + return(0) + } + list(choices) + table(fams) + fornodes(inode(ind), node) { + if(eqstr(tag(node), "FAMC")) { + set(choice, "") + set(choice, concat("FAMC ", value(node))) + set(fam_this, fam(value(node))) + set(birth_famc, 1) + set(pedi_label, "Birth (assumed)") + fornodes(node, subnode) { + if(eqstr(tag(subnode), "PEDI")) { + set(birth_famc, 0) + set(pedi_label, value(subnode)) + if( or( eqstr(pedi_label, "Birth"), + eqstr(pedi_label, "birth")) ) { + set(birth_famc, 1) + } elsif(eqstr(pedi_label, "")) { + print(" ", name(indi), " has a FAMC.PEDI node with no value.", nl()) + } + break() + } + } + set(choice, concat(choice, " ", pedi_label)) + enqueue(choices, choice) + insert(fams, d(length(choices)), fam_this) + } + } + if(empty(choices)) { + return(0) + } + if(eq(length(choices), 1)) { + set(mc, 1) + } else { + set(mc, + menuchoose(choices, concat("Choose a parent family of ", name(ind)))) + if(eq(mc, 0)) { + return(0) + } + } + return(lookup(fams, d(mc))) +} + +/* +** procedure: reserve +** +** +*/ + +proc reserve(person, depth) { + if(and(person, duplic_handling)) { + /* better code for LL 3.0.5 users -tentative*/ + /* problem seems to be that inlist only returns T/F, not position */ + /* + set(n, inlist(original_person, person)) + if(ne(n, 0)) { + set(level, getel(original_depth, n)) + if(le( abs(sub(depth, start_depth)), abs(sub(level, start_depth)) )) { + setel(original_depth, n, depth) + } + } else { + enqueue(original_person, key(person)) + enqueue(original_depth, depth) + } + */ + set(on_list, 0) + forlist(original_person, i, n) { + if(eqstr(key(person), i)) { + set(on_list, 1) + set(level, getel(original_depth, n)) + if(le( abs(sub(depth, start_depth)), abs(sub(level, start_depth)) )) { + setel(original_depth, n, depth) + } + break() + } + } + if(not(on_list)) { + enqueue(original_person, key(person)) + enqueue(original_depth, depth) + } + } +} + +/* +** function: blocked +** +** Return 1 if individual is blocked by a reservation at an earlier depth, +** 0 otherwise +*/ + +func blocked(person, depth) { + set(ans, 0) + if(not(person)) { + return(ans) + } + if(duplic_handling) { + /* better code for LL 3.0.5 users -tentative*/ + /* + set(n, inlist(original_person, person)) + if(ne(n, 0)) { + if(gt( abs(sub(depth, start_depth)), abs( sub(level, start_depth)) )) { + set(ans, 1) + break() + } + } + */ + forlist(original_person, i, n) { + if(eqstr(key(person), i)) { + set(level, getel(original_depth, n)) + /* only block appearances farther away from root than original person */ + if(gt( abs(sub(depth, start_depth)), abs(sub(level, start_depth)) )) { + set(ans, 1) + break() + } + } + } + } + return(ans) +} + + +/* +** procedure: remember_branch_start +** +** pushes lengths of person and line lists onto special stacks +** +*/ + +proc remember_branch_start() { + push(branch_start_person, add(length(plist_pos), 1)) + push(branch_start_line, add(length(llist_low), 1)) + set(bsp, length(branch_start_person)) + set(bsl, length(branch_start_line)) + if(ne(bsp, bsl)) { + print("! for some reason, a fragment of a branch mark was left behind\n") + print(" length(branch_start_person): ", d(bsp), nl()) + print(" length(branch_start_line): ", d(bsl), nl()) + } +} + + +/* +** procedure: branch_adjust +** +** 'shift' is the signed distance of the adjustment, +** positive for down the chart. +** +** Originally written to recover space when younger siblings get spread +** apart and their first parent branch has room to move back up the page. +** Now this task has been made general enough to be able to shift any branch +** in either direction, vertically. -- by Robert Simms +*/ + +proc branch_adjust(shift) { + set(start_plist, pop(branch_start_person)) + set(start_llist, pop(branch_start_line)) + + if(and(ne(shift, 0), ge(length(plist_depth), start_plist))) { + /* initialize low_depth_this_branch and high_depth_this_branch */ + set(low_depth_this_branch, getel(plist_depth, start_plist)) + set(high_depth_this_branch, low_depth_this_branch) + forlist(plist_depth, stored_depth, pc) { + if(ge(pc, start_plist)) { + /* find the depth range from plist_depth */ + set(low_depth_this_branch, min(low_depth_this_branch, stored_depth)) + set(high_depth_this_branch, max(high_depth_this_branch, stored_depth)) + } + } + /* make adjustment in global lists */ + forlist(plist_pos, stored_pos, pc) { + if(ge(pc, start_plist)) { + setel(plist_pos, pc, add(stored_pos, shift)) + } + } + forlist(llist_low, stored_pos, pc) { + if(ge(pc, start_llist)) { + setel(llist_low, pc, add(stored_pos, shift)) + } + } + forlist(llist_high, stored_pos, pc) { + if(ge(pc, start_llist)) { + setel(llist_high, pc, add(stored_pos, shift)) + } + } + set(depth_val, low_depth_this_branch) + while(le(depth_val, high_depth_this_branch)) { + set(stored_pos, get_high_pos_gen(depth_val)) + /* don't need to do this for current depth of caller because + * high_pos_gen has likely already been read and will be set by caller + * after use of this procedure. Leave it just in case -- it's easier. */ + call set_high_pos_gen(depth_val, add(stored_pos, shift)) + incr(depth_val) + } + } +} + +/* +** procedure: branch_adjust_first +** +** 'shift' is the signed distance of the adjustment, +** positive for down the chart. +** +** this procedure will adjust the first branch delimited by 'markers' +** (markers are indices stored in branch_start_person and branch_start_line +** that refer to the various plist_ and llist_ lists that store person and line +** vertical coordinates. +*/ + +proc branch_adjust_first(shift) { + set(start_plist, dequeue(branch_start_person)) + set(start_llist, dequeue(branch_start_line)) + if(gt(length(branch_start_person), 0)) { + set(stop_plist, getel(branch_start_person, 1)) + } else { + set(stop_plist, add(length(plist_person), 1)) + } + if(gt(length(branch_start_line), 0)) { + set(stop_llist, getel(branch_start_line, 1)) + } else { + set(stop_llist, add(length(llist_low), 1)) + } + + if(and(ne(shift, 0), ge(length(plist_depth), start_plist))) { + /* initialize low_depth_this_branch and high_depth_this_branch */ + set(low_depth_this_branch, getel(plist_depth, start_plist)) + set(high_depth_this_branch, low_depth_this_branch) + forlist(plist_depth, stored_depth, pc) { + if(and(ge(pc, start_plist), lt(pc, stop_plist))) { + /* find the depth range from plist_depth */ + set(low_depth_this_branch, min(low_depth_this_branch, stored_depth)) + set(high_depth_this_branch, max(high_depth_this_branch, stored_depth)) + } + } + /* make adjustment in global lists */ + forlist(plist_pos, stored_pos, pc) { + if(and(ge(pc, start_plist), lt(pc, stop_plist))) { + setel(plist_pos, pc, add(stored_pos, shift)) + } + } + forlist(llist_low, stored_pos, pc) { + if(and(ge(pc, start_llist), lt(pc, stop_llist))) { + setel(llist_low, pc, add(stored_pos, shift)) + } + } + forlist(llist_high, stored_pos, pc) { + if(and(ge(pc, start_llist), lt(pc, stop_llist))) { + setel(llist_high, pc, add(stored_pos, shift)) + } + } + set(depth_val, low_depth_this_branch) + while(le(depth_val, high_depth_this_branch)) { + set(stored_pos, get_high_pos_gen(depth_val)) + /* don't need to do this for current depth of caller because + * high_pos_gen has likely already been read and will be set by caller + * after use of this procedure. Leave it just in case -- it's easier. */ + /* doing this under the assumption that nothing has been placed beneath this branch on the chart*/ + call set_high_pos_gen(depth_val, add(stored_pos, shift)) + incr(depth_val) + } + } +} + + +/* +** procedure: multi_branch_adjust +** +** 'shift' is the signed distance of the adjustment, +** positive for down the chart. +** +** Originally written to recover space when younger siblings get spread +** apart and their first parent branch has room to move back up the page. +** Now this task has been made general enough to be able to shift any branch +** in either direction, vertically. -- by Robert Simms +*/ + +proc multi_branch_adjust(total_shift, nbranches) { + set(i, 1) + set(stop_plist, dequeue(branch_start_person)) + set(stop_llist, dequeue(branch_start_line)) + while(le(i, nbranches)) { + set(start_plist, stop_plist) + set(start_llist, stop_llist) + set(stop_plist, dequeue(branch_start_person)) + set(stop_llist, dequeue(branch_start_line)) + + set(shift, div(mul(i, total_shift), add(nbranches, 1))) + + if(and(ne(shift, 0), ge(length(plist_depth), start_plist))) { + /* initialize low_depth_this_branch and high_depth_this_branch */ + set(low_depth_this_branch, getel(plist_depth, start_plist)) + set(high_depth_this_branch, low_depth_this_branch) + forlist(plist_depth, stored_depth, pc) { + if(and(ge(pc, start_plist), lt(pc, stop_plist))) { + /* find the depth range from plist_depth */ + set(low_depth_this_branch, min(low_depth_this_branch, stored_depth)) + set(high_depth_this_branch, max(high_depth_this_branch, stored_depth)) + } + } + /* make adjustment in global lists */ + forlist(plist_pos, stored_pos, pc) { + if(and(ge(pc, start_plist), lt(pc, stop_plist))) { + setel(plist_pos, pc, add(stored_pos, shift)) +/* RES - won't be necessary when highest person in each gen is tracked */ + call max_with_high_pos_gen(getel(plist_depth, pc), add(stored_pos, + shift, getel(plist_height, pc))) + } + } + forlist(llist_low, stored_pos, pc) { + if(and(ge(pc, start_llist), lt(pc, stop_llist))) { + setel(llist_low, pc, add(stored_pos, shift)) + } + } + forlist(llist_high, stored_pos, pc) { + if(and(ge(pc, start_llist), lt(pc, stop_llist))) { + setel(llist_high, pc, add(stored_pos, shift)) + } + } + } + incr(i) + } +/* MUST reassess high_pos_gen for each gen in [low, high] this branch */ +/* + set(depth_val, low_depth_this_branch) + while(le(depth_val, high_depth_this_branch)) { + set(stored_pos, get_high_pos_gen(depth_val)) + call set_high_pos_gen(depth_val, + add(stored_pos, div(mul(sub(nbranches, 1), shift), nbranches))) + incr(depth_val) + } +*/ +} + + +/* +** procedure: max_with_high_pos_gen +** +** handles the updating of the highest position (down) on the page +** in a particular generation and over all generations +*/ + +proc max_with_high_pos_gen(depth, pos) { + /* update the highest position array, or set it for the first time */ + set(prev_high, get_high_pos_gen(depth)) + call set_high_pos_gen(depth, max(pos, prev_high)) +} + +/* +** functions: calc_high_pos_text & calc_high_pos_line +** +** Determines maximum of all entries in +** high_pos_gen array and llist_high list, respectively. +** +*/ + +/* RES!!! + Really need to search over plist_pos -- but we need pos+extent + which means plist_extent will need to be created + (that will help with accurate knowledge of highest element anyway) +*/ +func calc_high_pos_text() { + set(high_pos_text, get_high_pos_gen(low_depth)) + set(depth_val, low_depth) + while(le(depth_val, high_depth)) { + set(high_pos_text, max(high_pos_text, get_high_pos_gen(depth_val))) + incr(depth_val) + } + return(high_pos_text) +} + +func calc_high_pos_line() { + set(high_pos_line, getel(llist_high, 1)) + forlist(llist_high, x, pc) { + set(high_pos_line, max(high_pos_line, x)) + } + return(high_pos_line) +} + +/* +** functions: calc_low_pos_text & calc_low_pos_line +** +** Determines minimum of all entries in +** plist_pos array and llist_low list, respectively. +** +*/ + +func calc_low_pos_text() { + set(low_pos_text, get_high_pos_gen(low_depth)) + forlist(plist_pos, x, pc) { + set(low_pos_text, min(low_pos_text, x)) + } + return(low_pos_text) +} + +func calc_low_pos_line() { + set(low_pos_line, getel(llist_low, 1)) + forlist(llist_low, x, pc) { + set(low_pos_line, min(low_pos_line, x)) + } + return(low_pos_line) +} + +/* +** function: get_clearance +** +** handles the determination of a minimum position down the chart +** necessary for a person to stay clear of others already on the chart +** +*/ + +func get_clearance(depth, min_pos) { + set(next_depth, sub(depth, 1)) + set(prev_depth, add(depth, 1)) + + set(new_min_pos, min_pos) + if(high, get_high_pos_gen(prev_depth)) { + if(not(cloak_check(prev_depth))) { + set(new_min_pos, max(add(high, branch_dist_prev), new_min_pos)) + } + } + if(high, get_high_pos_gen(depth)) { + set(new_min_pos, max(add(high, branch_dist_same), new_min_pos)) + } + if(high, get_high_pos_gen(next_depth)) { + if(not(cloak_check(next_depth))) { + set(new_min_pos, max(add(high, branch_dist_next), new_min_pos)) + } + } + list(cloaked_depth) + return(new_min_pos) +} + +/* +** procedure cloak +** +** To be called just before a main charting procedure. +** Enables temporary hidding of a generation from get_clearance() +** so that generations closer to the root don't interfere with placement of +** branches in adjacent generations, such as with placement of maternal +** ancestor branches. +*/ + +proc cloak(depth) { + push(cloaked_depth, depth) +} + +/* +** function not_cloaked +** +** Checks whether a generation has been hidden from get_clearance... +** if not then TRUE is returned, +** if yes then FALSE is returned and the hidden status is cleared. +*/ + +func not_cloaked(depth) { + if(inlist(cloaked_depth, depth)) { + list(cloaked_depth) + return(FALSE) + } else { + return(TRUE) + } +} + +/* +** function cloak_check +** +** Returns true or false depending on whether a depth is the cloaked_depth. +*/ + +func cloak_check(depth) { + return(inlist(cloaked_depth, depth)) +} + +/* +** procedure: set_high_pos_gen +** & +** function: get_high_pos_gen +** +** They simplify access to the high_pos_gen list. +** LifeLines lists are indexed from 1. In order to allow generation +** (depth) numbers to span an arbitrary range of integers, it is necessary +** to translate the depth range to one that has a minimum value of 1. +** The global variable high_pos_gen_offset is the amount necessary +** to translate the depths. +** +*/ + +proc set_high_pos_gen(depth, pos) { + if(and(ge(depth, min_depth), le(depth, max_depth))) { + set(low_depth, min(low_depth, depth)) + set(high_depth, max(high_depth, depth)) + /* not using max(pos, get_high_pos_gen(depth)) because * + * branch_adjust() might need to decrease these numbers */ + setel(high_pos_gen, add(depth, high_pos_gen_offset), pos) + } else { + print(" ! Attempt to access array out of bounds: set_high_pos_gen()\n") + print(" position: ", d(pos), " depth: ", d(depth), nl()) + } +} + +func get_high_pos_gen(depth) { + if(and(ge(depth, low_depth), le(depth, high_depth))) { + set(ans, getel(high_pos_gen, add(depth, high_pos_gen_offset))) + } else { + set(ans, 0) + } + return(ans) +} + +/* +** function: person_height2 +** +** Return the height of a single person's information. +** All lines of information on a person that print_person() may issue +** should be accounted for here. +** The name is assumed to be in the database. So this height will always +** be at least name_height. The dates are checked for in the person's record. +** +** A TRUE (non-zero) value for the second parameter along with a non-zero +** marriage date (third parameter) will result in +** an extra date_height being added to the person's height corresponding +** to the assumed intention of including the marriage date when the +** associated enqueue_person() call is made. +** It is thus the responsibility of the calling code to determine when to +** use a marriage date. +*/ + +func person_height2(person, use_mdate, mdate) { + /* determine height of person and put in global var person_height_return */ + set(num_info_lines, 0) + set(person_height_return, name_height) + if(show_altname) { + if(altname, name2(person)) { + incr(num_info_lines) + } + } + if(dateplace(birth(person), dateplace_birth)) { + incr(num_info_lines) + } + if(and(use_mdate, mdate)) { + incr(num_info_lines) + } + if(dateplace(death(person), dateplace_death)) { + incr(num_info_lines) + } + if(dateplace(burial(person), dateplace_burial)) { + incr(num_info_lines) + } + set(num_info_lines, add(num_info_lines, address_ps(person, FALSE)) ) + set(person_height_return, add(person_height_return, + mul(num_info_lines, date_height)) ) + return(person_height_return) +} + +/* +** function: dateplace +** +** Get the date of an event in the appropriate style (which may include +** the place). Comments below describe the date styles. +** +*/ + +func dateplace(ev, style) { + if(or( eq(ev, 0), eq(style, 0) )) { + set(dateplace_return, 0) + } + /* 1 - use only the date value */ + if(eq(style, 1)) { + set(dateplace_return, save(date(ev))) + } + + /* 2 - use only the year and/or LAST place component (no modification) */ + if(eq(style, 2)) { + set(dateplace_return, save(short(ev))) + } + + /* 3 - use VERBATIM values from date and place (no modification) */ + if(eq(style, 3)) { + set(dateplace_return, save(long(ev))) + } + + /* 4 - date value and the FIRST component of the place */ + if(eq(style, 4)) { + if(long(ev)) { + if(place(ev)) { + list(pl) + extractplaces(ev, pl, np) + set(where, modify(dequeue(pl))) + if(eqstr(date(ev), "")) { + set(dateplace_return, save(where)) + } else { + set(dateplace_return, save(concat(date(ev), ", ", where))) + } + } else { + set(dateplace_return, save(date(ev))) + } + } else { + set(dateplace_return, 0) + } + } + + /* 5 - date value and the FIRST TWO components of the place */ + if(eq(style, 5)) { + if(long(ev)) { + if(place(ev)) { + list(pl) + extractplaces(ev, pl, np) + if(eq(1, np)) { + set(where, modify(dequeue(pl))) + } else { + set(where, concat(modify(dequeue(pl)), ", ", modify(dequeue(pl)))) + } + if(eqstr(date(ev), "")) { + set(dateplace_return, save(where)) + } else { + set(dateplace_return, save(concat(date(ev), ", ", where))) + } + } else { + set(dateplace_return, save(date(ev))) + } + } else { + set(dateplace_return, 0) + } + } + + /* 6 - date value and the first THREE components of the place */ + if(eq(style, 6)) { + if(long(ev)) { + if(place(ev)) { + list(pl) + extractplaces(ev, pl, np) + if(eq(1, np)) { + set(where, modify(dequeue(pl))) + } elsif(eq(2, np)) { + set(where, concat(modify(dequeue(pl)), ", ", modify(dequeue(pl)))) + } else { + set(where, concat( + modify(dequeue(pl)), ", ", + modify(dequeue(pl)), ", ", + modify(dequeue(pl)) )) + } + if(eqstr(date(ev), "")) { + set(dateplace_return, save(where)) + } else { + set(dateplace_return, save(concat(date(ev), ", ", where))) + } + } else { + set(dateplace_return, save(date(ev))) + } + } else { + set(dateplace_return, 0) + } + } + /* 7 - For US places, in the format "city, county, state, country" + where any one component implies that all less specific ones are present, + this style will choose, when available, the country, + state, county and state, or city and state + If enabled, place modification (abbreviation) is applied to the + country (when the only place item) or + the state (when NOT the only place item). + */ + if(eq(style, 7)) { + if(long(ev)) { + if(place(ev)) { + list(pl) + extractplaces(ev, pl, np) + if(eq(1, np)) { + set(where, modify(getel(pl,1))) + } elsif(eq(np, 2)) { + set(where, getel(pl, 1)) + } elsif(eq(np, 3)) { + set(where,concat(getel(pl, 1), ", ", modify(getel(pl, 2)))) + } elsif(ge(np, 4)) { + set(where, concat(getel(pl, sub(np, 3)), ", " , + modify(getel(pl, sub(np, 1))))) + } + if(eqstr(date(ev), "")) { + set(dateplace_return, save(where)) + } else { + set(dateplace_return, save(concat(year(ev), ", ", where))) + } + } else { + set(dateplace_return, save(year(ev))) + } + } else { + set(dateplace_return, 0) + } + } + if(ge(style, 7)) { + set(dateplace_return, 0) + print(" error: invalid date style code", nl()) + } + return(dateplace_return) +} + +/* +** function: address_ps +** +** Prints address info as PostScript strings, if the print_flag is non-zero. +** Returns a count of the number of info lines whether or not info is printed. +** +** Finds last address or residence of PERSON by traversing +** all ADDR (GEDCOM 5.5), +** and RESI (GEDCOM 5.5) +** nodes. +** Here are some examples: +** 1 ADDR 122 Oak Street +** 2 CONT Somewhere, MO 55555 +** 1 PHON 501-555-1212 +** 1 EMAI itsme@sofa.net +** or +** 1 RESI +** 2 ADDR 122 Oak Street +** 3 CONT Somewhere, MO 55555 +** 2 DATE from 23 Dec 1996 +** +** Phone and e-mail information is printed as well. +** +*/ + +func address_ps(person, print_flag) { + set(lines_return, 0) + if(not(and(person, show_address))) { + return(lines_return) + } + list(addrlist) + set(addrnode, FALSE) + set(found_addr, FALSE) + traverse(inode(person), node, lev) { + if(eq(lev, 1)) { + if(eqstr(tag(node),"ADDR")) { + set(addrnode, node) + set(found_addr, TRUE) + } elsif(and( eqstr(tag(node),"RESI"), not(no_resides_at), + not(found_addr) )) { + set(addrnode, node) + } + } + } + if(addrnode) { + if(eqstr(tag(addrnode), "RESI")) { + set(addrflag, "* ") + set(newnode, 0) + traverse(addrnode, node, lev) { + if(and( eq(parent(node), addrnode), or(eqstr(tag(node), "ADDR"), + eqstr(tag(node), "PLAC") ))) { + set(newnode, node) + } + } + if(newnode) { + set(addrnode, newnode) + } else { + print("RESI node with no ADDR subnode, for ", name(person), nl()) + } + } else { + set(addrflag, "! ") + } + if(gt(strlen(place(addrnode)), 23)) { + if(debug) { + print(" caught a long place node, for ", name(person), nl()) + } + extractplaces(addrnode, addrlist, np) + /* RES - might be better to do this with a stack, to handle more than 2 */ + set(line1, 0) + set(line1, modify(dequeue(addrlist))) + set(line2, 0) + if(not(empty(addrlist))) { + set(line2, concat(line2, modify(dequeue(addrlist)))) + } + while(not(empty(addrlist))) { + set(line2, concat(line2, " ", modify(dequeue(addrlist)))) + } + if(print_flag) { + "(" addrflag strxlat(ps_xlat, line1) ")" + "(" addrflag strxlat(ps_xlat, line2) ")" + } + set(lines_return, 2) + } elsif(gt(strlen(place(addrnode)), 0)) { + print(" caught an empty place/addr node, for ", name(person), nl()) + if(print_flag) { + "(" addrflag strxlat(ps_xlat, place(addrnode)) ")" + } + set(lines_return, 1) + } else { + set(line1, 0) + set(line1, modify(value(addrnode))) + if(not(line1)) { + print("ADDR node with no address info with tag, for ", name(person), + nl()) + set(lines_return, 0) + } else { + if(print_flag) { + "(" addrflag strxlat(ps_xlat, line1) ")" + } + set(lines_return, 1) + traverse(addrnode, subnode, lev) { + if(and(eq(parent(subnode), addrnode), eqstr(tag(subnode), "CONT") )) { + set(line2, modify(value(subnode))) + if(print_flag) { + "(" addrflag strxlat(ps_xlat, line2) ")" + } + incr(lines_return) + } + } + } + } + } + traverse(inode(person), subnode, lev) { + if(or( eqstr(tag(subnode), "EMAI"), eqstr(tag(subnode), "PHON") )) { + incr(lines_return) + if(print_flag) { + "(" "! " strxlat(ps_xlat, value(subnode)) ")" + } + } + if(eqstr(tag(subnode), "PLACE")) { + print("5-letter subnode tag: PLACE, for ", name(person), nl()) + } + if(eqstr(tag(subnode), "EMAIL")) { + print("5-letter subnode tag: EMAIL, for ", name(person), nl()) + } + } + return(lines_return) +} + +/* +** function: name2 +** +** Returns the name from the second NAME node, or a 0 (FALSE) if none. +** This function attempts to format the name as is done to other names +** elsewhere in the program. The difficulty lies in LifeLines having +** name formatting commands that only that work only with the first NAME +** node of a person, and not on NAME nodes or strings. +*/ + +func name2(ind) { + if(not(ind)) { + return(0) + } + set(altnamenode, 0) + set(found_one, FALSE) + traverse(inode(ind), node, lev) { + if(eq(lev, 1)) { + if(eqstr(tag(node), "NAME")) { + if(not(found_one)) { + set(found_one, TRUE) + } else { + set(altnamenode, node) + break() + } + } + } + } + if(altnamenode) { + list(parts) + extractnames(altnamenode, parts, np, sni) + set(altname, "") + forlist(parts, nstr, si) { + if(and(ge(si, sni), surname_upper)) { + set(altname, concat(altname, upper(nstr), " ")) + } else { + set(altname, concat(altname, nstr, " ")) + } + } + set(altname, trim(altname, sub(strlen(altname), 1))) + } else { + set(altname, 0) + } + return(altname) +} + + +/* +** function: modify +** +** Use a function (shorten), possibly accessed via an "include" statement +** prior to the main() procedure code block. +** The purpose of which is to modify place strings. +** If the global variable 'place_modify' is set to FALSE, then place strings +** will be returned unaltered. keyword: SHORTEN +** +*/ + +func modify(old) { + if(and(strlen(old), place_modify)) { + if(index(old, ",", 1)) { /* is this a string with commas? */ + list(pl) + extracttokens(old, pl, np, ",") + set(new, "") + if(gt(length(pl), 0)) { + set(new, shorten(dequeue(pl))) + while(gt(length(pl), 0)) { + set(new, concat(new, ", ", shorten(dequeue(pl)))) + } + } + } else { + set(new, shorten(old)) + } + } else { + set(new, old) + } + if(debug) { print("modify: ", old, " -> ", new, nl())} + return(new) +} + +/* +** function: strxlat +** +** If there is a chance that text containing unbalanced parentheses may +** be written to a PostScript file as a string (which is delimited with +** parentheses) then at least the lone parentheses must be escaped, meaning +** preceeded by a '\' character. The appearance of '\' characters in such +** strings must also be escaped. +** This function returns a string with all parentheses and +** backslash characters escaped. +** This idea was copied and/or adapted from Jim Eggert's modification +** to the ps-circ(le) program for LifeLines. +** A typical call would look like: +** set(str, strxlat(ps_xlat, name(person))) +** which would translate characters in person's name according to the +** table called ps_xlat. The output is assigned to str. +** The output of strxlat() can also be sent directly to output. +*/ + +func strxlat(xlat, string) { + if(opt_xlat) { + set(fixstring, "") + set(pos, 1) + while(le(pos, strlen(string))) { + set(char, substring(string, pos, pos)) + if (special, lookup(xlat, char)) { + set(fixstring, concat(fixstring, special)) + } else { + set(fixstring, concat(fixstring, char)) + } + incr(pos) + } + } else { + set(fixstring, string) + } + return(save(fixstring)) /* save() is used for compatibilty with older LL */ +} + +/* +** function: deparen +** +** Removes parenthesized text from a string and returns the result. +** This routine can handle nesting of parentheses and multiple occurences +** of parenthesized text in the same string. +*/ + +func deparen(str) { + if(and(opt_deparen, index(str, ")", 1), nestr(str, ""))) { + list(maybe) + set(level, 0) + while(len, strlen(str)) { + set(s, substring(str, 1, 1)) + set(str, substring(str, 2, len)) + if(eqstr(s, ")")) { + if(gt(level, 0)) { + set(d, pop(maybe)) + while(nestr(d, "(")) { + set(d, pop(maybe)) + } + if(d, pop(maybe)) { + if(nestr(d, " ")) { + push(maybe, d) + } + } elsif(eqstr(" ", substring(str, 1, 1))) { + set(str, substring(str, 2, len)) + } + decr(level) + } else { + push(maybe, s) + } + } elsif(eqstr(s, "(")) { + push(maybe, s) + incr(level) + } else { + push(maybe, s) + } + } + while(s, dequeue(maybe)) { + set(str, concat(str, s)) + } + } + return(str) +} + + +/* +** procedures: enqueue_person +** +** Store the data for a person in the global lists. It will be +** printed later. +** +** Some variable meanings: +** line 2 = bold line, for direct anc/des +** 1 = thin line, for non-direct, blood relatives +** (aunts and uncles, cousins) +** 0 = thin line in second color, for non-blood relatives +** rel_up = 1 if person is connected to the next level up, 0 otherwise +** rel_down = 1 if person is connected to the next level down, 0 otherwise +** fam = parents, if chart flow is down through this person +** 0, otherwise +** The purpose is to check the type of connection to parents +** and set line style accordingly. +*/ + +proc enqueue_person(person, depth, pos, rel, mdate, rel_up, rel_down, fam) { + set(line, rel_famc(person, fam, rel)) + set(duplicate, blocked(person, depth)) + if(not(duplicate)) { + call reserve(person, start_depth) + } + set(height, person_height2(person, mdate, mdate)) + + enqueue(plist_person, person) + enqueue(plist_depth, depth) + enqueue(plist_pos, pos) + enqueue(plist_line, line) + enqueue(plist_mdate, mdate) + enqueue(plist_up, rel_up) + enqueue(plist_down, rel_down) + enqueue(plist_duplic, duplicate) + enqueue(plist_height, height) + + set(duplicate_return, duplicate) +} + +/* +** procedure: initialize_data +** +** Empty the lists that hold chart data. +** This clears the way for a second pass for the more complex charts. +** +*/ + +proc initialize_data() { + list(branch_start_person) + list(branch_start_line) + list(original_person) + list(original_depth) + list(high_pos_gen) + + list(plist_person) + list(plist_depth) + list(plist_pos) + list(plist_line) + list(plist_mdate) + list(plist_up) + list(plist_down) + list(plist_duplic) + list(plist_height) + + list(llist_depth) + list(llist_low) + list(llist_high) + list(cloaked_depth) + list(llist_color) + list(llist_duplic) + + set(low_depth, start_depth) + set(high_depth, start_depth) +} + +/* +** procedure: print_all_persons +** +** Print all persons stored in the global lists. +*/ + +proc print_all_persons() { + while(length(plist_person)) { + set(person, dequeue(plist_person)) + set(depth, dequeue(plist_depth)) + set(pos, dequeue(plist_pos)) + set(line, dequeue(plist_line)) + set(mdate, dequeue(plist_mdate)) + set(rel_up, dequeue(plist_up)) + set(rel_down, dequeue(plist_down)) + set(duplic, dequeue(plist_duplic)) + call print_person(person, depth, pos, line, mdate, rel_up, rel_down, duplic) + } +} + + +/* +** procedure: print_person +** +** Print a line of data for a person in PostScript format. Each line +** printed is essentially a call to a PostScript function defined in the +** header. +** +*/ + +proc print_person(person, depth, pos, rel, mdate, rel_up, rel_down, duplicate) { + /* specify an index for storage in PostScript array*/ + d(length(plist_person)) " {" + + /* print generation */ + d(depth) " " + + /* print vertical position */ + make_thousandths(pos) " " + + /* 2=direct ancestor, 1=blood relative, 0=non-blood relative */ + d(rel) " " + if(or(lt(rel, 0), lt(2, rel))) { + print(" >> print_person() caught invalid relationship code for ", + name(person), nl()) + } + + /* duplicate individual */ + if(duplicate) { "1 " } else { "0 " } + + /* person has ancestors (descendants, if mirror_chart)*/ + if(rel_up) { "1 " } else { "0 " } + + /* person has descendants (ancestors, if mirror_chart)*/ + if(rel_down) { "1 " } else { "0 " } + + set(t, title(person)) + if(eqstr(t, "")) { + set(t, 0) + } + if(person) { + if(or(t, eq(title_method, 0))) { + set(prefix_title, 0) + set(suffix_title, 0) + } + if(eq(title_method, 1)) { + set(prefix_title, t) + set(suffix_title, 0) + } + if(eq(title_method, 2)) { + set(prefix_title, 0) + set(suffix_title, t) + } + if(eq(title_method, 3)) { + set(prefix_title, 0) + set(suffix_title, 0) + if(is_prefix_title(t)) { + set(prefix_title, t) + } else { + set(suffix_title, t) + } + } + + set(nlet, name_letters) + if(prefix_title) { + set(nlet, sub(nlet, add(strlen(prefix_title), 1))) + } + if(suffix_title) { + set(nlet, sub(nlet, add(strlen(suffix_title), 1))) + } + } + + /* print name and title */ + "(" + if(not(person)) { + " " + } else { + if(prefix_title) { + prefix_title " " + } + strxlat(ps_xlat, deparen(fullname(person, surname_upper, 1, nlet))) + if(suffix_title) { + " " suffix_title + } + } + ")" + + /* print info: birth, death, etc. */ + " [" + if(person) { + if(show_altname) { + if(altname, name2(person)) { + "(" strxlat(ps_xlat, altname) ")" + } + } + if(date_birth, dateplace(birth(person), dateplace_birth)) { + "(b. " strxlat(ps_xlat, date_birth) ")" + } + + /* print marriage date, if it exists */ + if(mdate) { + "(m. " strxlat(ps_xlat, mdate) ")" + } + + /* print death date, if it exists */ + if(date_death, dateplace(death(person), dateplace_death)) { + "(d. " strxlat(ps_xlat, date_death) ")" + } + + /* print burial date/place, if it exists */ + if(date_burial, dateplace(burial(person), dateplace_burial)) { + "(bur. " strxlat(ps_xlat, date_burial) ")" + } + + /* print last known address or living address */ + set(dummy, address_ps(person, TRUE)) + } + + "]" /* end of info array */ + + " (" /* drop in a complimentary indi. key -- to aid in debugging */ + if(person) { + key(person, 1) + } else { + "-" + } + ")" + + /* call PostScript function to process and print this data */ + "} Q" + + nl() +} + +/* +** function: is_prefix_title +** +** Decide if the given title is a prefix type title. +** +*/ + +func is_prefix_title(t) { + set(is_prefix_title_return, 0) + if( index(t, "Arch", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Baron", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Bish", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Brot", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Card", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Colonel", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Canon", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Cong", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Deacon", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Dr", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Duke", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Father", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Fr", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Hon", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Judge", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "King", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Lady", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Lord", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Miss", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Mons", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Mr", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Mrs", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Ms", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Msgr", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Pope", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Pres", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Princ", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Prof", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Queen", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Rabbi", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Rav", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Rep", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Sen", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Sir", 1)) { set( is_prefix_title_return, 1) } + if( index(t, "Sis", 1)) { set( is_prefix_title_return, 1) } + return(is_prefix_title_return) +} + +/* +** procedures: enqueue_vertical +** +** Enqueue the data for a single vertical line onto the global lists. +** +*/ + +proc enqueue_vertical(depth, low, high, color, duplicate) { + enqueue(llist_depth, depth) + enqueue(llist_low, low) + enqueue(llist_high, high) + enqueue(llist_color, color) + enqueue(llist_duplic, duplicate) +} + +/* +** procedure: print_all_verticals +** +** Dequeue and print all vertical lines. The lines are stored in a +** second queue as they are printed and then placed back in the +** original, global, queue. +** +*/ + +proc print_all_verticals() { + while(length(llist_depth)) { + set(depth, dequeue(llist_depth)) + set(low, dequeue(llist_low)) + set(high, dequeue(llist_high)) + set(color, dequeue(llist_color)) + set(duplic, dequeue(llist_duplic)) + + d(length(llist_depth)) + " {" d(depth) + " " make_thousandths(low) + " " make_thousandths(high) + " " d(color) + " " d(duplic) + "} P" nl() + } +} + +/* +** function: make_thousandths +** +** Since LifeLines does not have a floating point type, decimal +** computation is done using integers that represent thousands. This +** procedure converts a number in thousandths to decimal notation as a string. +** The result always has three decimal places. +*/ + +func make_thousandths(n) { + set(s, "") + if(lt(n, 0)) { + set(s, "-") + set(n, neg(n)) + } + set(s, concat(s, d(div(n, 1000)), ".")) + set(t, d(mod(n, 1000))) + if(eq(strlen(t), 1)) { + set(s, concat(s, "00", t)) + } + if(eq(strlen(t), 2)) { + set(s, concat(s, "0", t)) + } + if(eq(strlen(t), 3)) { + set(s, concat(s, t)) + } + return(s) +} + +/* +** function: direction +** +** applies global option: updown_override to direction (UP or DOWN) +** and returns a direction. This allows for statements like +** set(dir, direction(UP)) that are simpler than the actual formula used. +*/ + +func direction(updown) { + return(mod(add(updown, updown_override), 2)) +} + +/* +** functions: min and max; half +** +** min() and max() return the minimum and maximum of a pair of integers +** +** half() returns the integer part of dividing its argument by 2. +*/ + +func min(x, y) { + if(le(x, y)) { + set(ans, x) + } else { + set(ans, y) + } + return(ans) +} + +func max(x, y) { + if(ge(x, y)) { + set(ans, x) + } else { + set(ans, y) + } + return(ans) +} + +func half(x) { + return(div(x, 2)) +} + +/* +** function: abs +** +** Return the absolute value of an integer +*/ + +func abs(x) { + if(lt(x, 0)) { + set(ans, neg(x)) + } else { + set(ans, x) + } + return(ans) +} + +/* +** function: chart_title +** +** Return a string containing a standard chart title based +** on chart type and possibly generation restrictions. +*/ + +func chart_title() { + set(title_return, "") + if(nestr(chart_title_override, "")) { + set(title_return, chart_title_override) + } else { + if(eq(chart_type, 1)) { + set(title_return, concat("The ancestors of ", + name(root_person, surname_upper), + fromto(root_person) )) + } elsif(or( eq(chart_type, 2), eq(chart_type, 3) )) { + set(title_return, concat("The descendants of ", + name(root_person, surname_upper), + fromto(root_person) )) + } elsif(eq(chart_type, 4)) { + if(eq(low_depth, start_depth)) { + set(title_return, "The ancestors of the ") + } else { + set(title_return, "The ancestors and descendants of the ") + } + set(title_return, concat(title_return, + name(husband(root_fam), surname_upper), " and ", + name(wife(root_fam), surname_upper), " family" )) + } elsif(eq(chart_type, 5)) { + if(eq(low_depth, start_depth)) { + set(title_return, "The ancestors of the extended family of " ) + } else { + set(title_return, + "The ancestors and descendants of the extended family of " ) + } + set(title_return, concat(title_return, + name(husband(root_fam), surname_upper), " and ", + name(wife(root_fam), surname_upper) )) + } else { + set(title_return, concat("<>" )) + } + } + return(title_return) +} + +/* +** function: fromto +** +** Return a string reprsenting the time when a person lived. +*/ + +func fromto(indi) { + set(e, birth(indi)) + set(f, death(indi)) + set(s, "") + if(or(year(e), year(f))) { + /* balanced parenthesis are OK unescaped in PostScript strings */ + set(s, concat(s, " (")) + if(e) { + if(year(e)) { + set(s, concat(s, year(e))) + } else { + set(s, concat(s, "?")) + } + } + set(s, concat(s, "-")) + if(f) { + if(year(f)) { + set(s, concat(s, year(f))) + } else { + set(s, concat(s, "?")) + } + } + set(s, concat(s, ")")) + } + return(save(s)) +} + +/* +** procedure: write_ps +** +** Generate the PostScript code. Defines PostScript +** functions for printing peoples names, dates and the lines on the +** chart, and more. Then the actual names and lines with their positions +** and other data are inserted as array definitions in the PostScript code. +** Maybe some day, other output procedures will be written, like write_pdf? +** +** Arguments: +** cl: chart label, string +** fn: font name for an individual's name +** fi: font name for an individual's info (birth, death, marriage, etc.) +** xn: number of horizontal pages +** yn: number of vertical pages +** ml: maximum level, integer +** nl: minimum level, integer +** +** Not all arguments are passed, because there are so many. +** +** The original PostScript code was written by Thomas P. Blumer +** (blumer@ptltd.com). +** +*/ + +proc write_ps(fn, fi, xn, yn, ml, nl) { + "%!PS-Adobe-3.0" if(eqstr(paper_name, "EPSF")) {" EPSF-3.0"} nl() + "%%Title: " chart_title() nl() + "%%CreationDate: " stddate(gettoday()) nl() + "%%Creator: " version + ", a report program for LifeLines" nl() + "%%Pages: " d(mul(xn, yn)) nl() + "%%PageOrder: Ascend" nl() + if(nestr(paper_name, "NONE")) { + "%%BoundingBox: 0 0 " d(paper_width) " " d(paper_height) nl() + } + "%%Orientation: " + if(portrait) { + "Portrait" + } else { + "Landscape" + } + nl() + "%%EndComments" nl() + "%%BeginDefaults" nl() + "%%ViewingOrientation: " if(portrait) {"1 0 0 1"} else {"0 -1 1 0"} nl() + "%%EndDefaults" nl() + "%%BeginProlog" nl() + "% --- Define constants ---" nl() + "% ** This first section of constants are " + "user-modifiable here in the PS file **" nl() + "/fontname /" fn " def" nl() + "/ifontname /" fi " def" nl() + "/titlefontname fontname def" nl() + "/labelfontname /Helvetica def" nl() + "/chart_title (" strxlat(ps_xlat, chart_title()) ") def" nl() + "/display_title " if(display_title) {"true"} else {"false"} " def" nl() + "/chart_label (" strxlat(ps_xlat, chart_label) ") def" nl() + "/display_label " if(display_label) {"true"} else {"false"} " def" nl() + "/chart_label_centered " + if(chart_label_centered) {"true"} else {"false"} " def" nl() + "/label_outside_border " + if(label_outside) {"true"} else {"false"} " def" nl() + "/show_border " if(display_border) {"true"} else {"false"} " def" nl() + "/mirror " if(mirror_chart) { "true" } else { "false" } " def" nl() + "/portrait " if(portrait) { "true" } else { "false" } " def" nl() + "/margin_top " d(margin_top) " def" nl() + "/margin_bottom " d(margin_bottom) " def" nl() + "/margin_left " d(margin_left) " def" nl() + "/margin_right " d(margin_right) " def" nl() + "% indent is the fraction of generation width to allow for horizontal lines" + nl() + "/indent .05 def" nl() + "/use_color " if(color_chart) { "true" } else { "false" } " def" nl() + "/use_bold " if(bold_chart) { "true" } else { "false" } " def" nl() + "/bold_factor " make_thousandths(mul(bold_factor, 1000)) " def" nl() + "/tweak 0 def % points to shift chart vertically within border" nl() + "% Red,Green,Blue intensities for lines and text (regular and bold)" nl() + "% Values may have decimals and must be between 0 and 1." nl() + "/lr 0 def /lg 1 def /lb 1 def" nl() + "/Lr 0 def /Lg 0 def /Lb 1 def" nl() + "/tr 0 def /tg 0 def /tb 0 def" nl() + "/Tr 0 def /Tg 0 def /Tb 0 def" nl() + if(debug_postscript) { + "/show_positions false def % make true to show person positions" nl() + } + "/show_keys false def % set to true to turn on display of keys" nl() + "% ** End of user-modifiable constants **" nl() + if(nestr(paper_name, "NONE")) { + "/paper_height " d(paper_height) " def" nl() + "/paper_width " d(paper_width) " def" nl() + } + "/name_height " make_thousandths(name_height) " def" nl() + "/date_height " make_thousandths(date_height) " def" nl() + "/xpages " d(xn) " def" nl() + "/ypages " d(yn) " def" nl() + "/minpos_text " make_thousandths(calc_low_pos_text()) " def" nl() + "/minpos_line " make_thousandths(calc_low_pos_line()) " def" nl() + "/maxpos_text " make_thousandths(calc_high_pos_text()) " def" nl() + "/maxpos_line " make_thousandths(calc_high_pos_line()) " def" nl() + "/maxlevel " d(ml) " def" nl() + "/minlevel " d(nl) " def" nl() + "% --- Start Subroutines ---" nl() + "% emulations of Level 2 operators" nl() + "%" nl() + "/*SF { % Complete selectfont emulation" nl() + " exch findfont exch" nl() + " dup type /arraytype eq {makefont}{scalefont} ifelse setfont" nl() + "} bind def" nl() + nl() + "/BuildRectPath {" nl() + " dup type dup /integertype eq exch /realtype eq or {" nl() + " 4 -2 roll moveto" nl() + " dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto closepath" nl() + " }{" nl() + " dup length 4 sub 0 exch 4 exch" nl() + " {" nl() + " 1 index exch 4 getinterval aload pop" nl() + " BuildRectPath" nl() + " } for" nl() + " pop" nl() + " } ifelse" nl() + "} bind def" nl() + nl() + "/*RC {" nl() + " gsave newpath BuildRectPath clip grestore" nl() + "} bind def" nl() + nl() + "% install Level 2 emulations, or substitute built-in Level 2 operators" nl() + "/languagelevel where" nl() + " {pop languagelevel}{1} ifelse" nl() + "2 lt {" nl() + " /RC /*RC load def" nl() + " /SF /*SF load def" nl() + "}{" nl() + " /RC /rectclip load def % use RC instead of rectclip" nl() + " /SF /selectfont load def % use SF instead of selectfont" nl() + "} ifelse" nl() + "/SF2 {SF" nl() + " /fshow fshowdict currentfont /FontName get get load def" nl() + "} bind def" nl() + nl() + "% Handy little functions: min, max" nl() + "/min {" nl() + " 2 copy gt { exch } if pop" nl() + "} bind def" nl() + "/max {" nl() + " 2 copy lt { exch } if pop" nl() + "} bind def" nl() + nl() + "% Line and Person array filling procedures" nl() + "/P {Alin 3 1 roll put} def" nl() + "/Q {Aind 3 1 roll put} def" nl() + nl() + "/black-and-white-device % true for black & white, false otherwise" nl() + "{ statusdict begin" nl() + " /processcolors where" nl() + " { pop processcolors } { 1 } ifelse" nl() + " end" nl() + " 1 eq" nl() + "} def" nl() + nl() + "% wshow* usage: string num wshow* --" nl() + "% scale to fit string in specified width at current point" nl() + "/wshow* {" nl() + " /s exch def" nl() + " /len exch def" nl() + " s stringwidth pop line_gap add dup len lt {" nl() + " pop s fshow" nl() + " }{" nl() + " gsave" nl() + " % scale for exact fit (current point is not affected)" nl() + " len exch div dup scale" nl() + " s fshow" nl() + " grestore" nl() + " } ifelse" nl() + "} bind def" nl() + nl() + "% wlen usage: string num1 num2 wlen num3 num4" nl() + "% The string is to be rendered no longer than specified length (num1)," nl() + "% starting with initial font size (num2)." nl() + "% Determines scale (num3) necessary to render string with length (num4)" nl() + "% Assumes 'direct' variable is currently set to indicate use of bold font." + nl() + "/wlen {" nl() + " /s exch def" nl() + " /len exch def" nl() + " /fntsiz exch def" nl() + " /bfn exch def" nl() + " /fn exch def" nl() + " use_bold direct and {" nl() + " bfn fntsiz SF2" nl() + " } {" nl() + " fn fntsiz SF2" nl() + " } ifelse" nl() + " s stringwidth pop line_gap add dup len lt {" nl() + " % text already fits so return scale of 1 and text length" nl() + " 1 exch" nl() + " } {" nl() + " % scale, len for text length since scale makes fit exact" nl() + " len exch div len" nl() + " } ifelse" nl() + "} bind def" nl() + nl() + "%" nl() + "% Show text from right to left, with left end at current point" nl() + "%" nl() + "/rlshow {" nl() + " dup stringwidth rmoveto" nl() + " { (_) dup 0 4 -1 roll put" nl() + " dup stringwidth pop neg 0 rmoveto" nl() + " currentpoint 3 -1 roll show" nl() + " moveto" nl() + " } forall" nl() + "} bind def" nl() + nl() + "%" nl() + "% Print a title across the bottom of the page" nl() + "%" nl() + "/print_title {" nl() + " /fsize th1 18 div def" nl() + " /len tw1 .9 mul def" nl() + " titlefontname fsize SF2" nl() + " chart_title stringwidth pop dup len lt {" nl() + " pop" nl() + " } {" nl() + " % compute new font size for exact fit lengthwise" nl() + " len exch div fsize mul /fsize exch def" nl() + " titlefontname fsize SF2" nl() + " } ifelse" nl() + " titlefontname findfont /FontBBox get dup" nl() + " 3 get /sy2 exch fsize mul 1000 div def" nl() + " 1 get /sy1 exch fsize mul 1000 div def" nl() + " sy2 0 eq {" nl() + " newpath 0 0 moveto" nl() + " (A) false charpath flattenpath pathbbox newpath" nl() + " sy2 max /sy2 exch def pop sy1 min /sy1 exch def pop" nl() + " newpath 0 0 moveto" nl() + " (p) false charpath flattenpath pathbbox newpath" nl() + " sy2 max /sy2 exch def pop sy1 min /sy1 exch def pop" nl() + " } if" nl() + " /title_length chart_title stringwidth pop def" nl() + " /title_height sy2 sy1 sub def" nl() + " /title_allowance title_height 1.1 mul def" nl() + " /startx tw1 title_length sub 2 div def" nl() + " /starty sy1 neg title_height .05 mul add def" nl() + " startx starty chart_title stringwidth pop" nl() + " startx starty moveto" nl() + " textcolr0" nl() + " chart_title fshow" nl() + " 0 title_allowance translate % set origin above title" nl() + " /th1 th1 title_allowance sub def % shorten chart space accordingly" nl() + "} bind def" nl() + nl() + "/print_label {" nl() + " /labelfs 6 def" nl() + " /len wp1 def" nl() + " labelfontname labelfs SF2" nl() + " chart_label stringwidth pop dup len lt {pop} {" nl() + " len exch div labelfs mul /labelfs exch def" nl() + " labelfontname labelfs SF2" nl() + " } ifelse" nl() + " labelfontname findfont /FontBBox get dup" nl() + " 3 get /sy2 exch labelfs mul 1000 div def" nl() + " 1 get /sy1 exch labelfs mul 1000 div def" nl() + " sy2 0 eq {" nl() + " newpath 0 0 moveto" nl() + " (A) false charpath flattenpath pathbbox newpath" nl() + " sy2 max /sy2 exch def pop sy1 min /sy1 exch def pop" nl() + " newpath 0 0 moveto" nl() + " (p) false charpath flattenpath pathbbox newpath" nl() + " sy2 max /sy2 exch def pop sy1 min /sy1 exch def pop " nl() + " } if" nl() + " chart_label_centered" nl() + " {len chart_label stringwidth pop sub 2 div}" nl() + " {0} ifelse" nl() + " 0 sy1 neg moveto" nl() + " chart_label fshow" nl() + " sy2 sy1 sub 1.2 mul dup" nl() + " 0 exch translate" nl() + " th1 exch sub /th1 exch def" nl() + "} bind def" nl() + nl() + + /* To write an alternative PostScript border procedure, + here are the current guidelines for compatibility: + - external PostScript variables used in the original border procedure: + lincolr0 -- a procedure that sets the drawing color to the one used + for blood relatives + tw1 -- the width, in points, available + th1 -- the height, in points, available + wp1 -- the width, in points, available on the lower left page + - what the border procedure must do when finished: + 1. translate to just inside the lower left corner of the border + 2. subtract border thickness from /tw1, /th1, and /wp1 + 3. set /bgap to the empty space at the bottom on the inside of + the border -- some of which is used as extra space for a title + or inside label + */ + "% Print a decorative border" nl() + "%" nl() + "/print_border {" nl() + " /bwid1 2.5 def" nl() + " /gapwid 1.5 def" nl() + " /bwid2 0.7 def" nl() + " /bgap 10 def" nl() + " /tbwid bwid1 gapwid bwid2 bgap add add add def" nl() + " /tw 7.2 def" nl() + " /rect {" nl() + " /rh exch def" nl() + " /rw exch def" nl() + " moveto" nl() + " rw 0 rlineto" nl() + " 0 rh rlineto" nl() + " rw neg 0 rlineto" nl() + " closepath stroke" nl() + " } def" nl() + " /rectt {" nl() + " /rh exch def" nl() + " /rw exch def" nl() + " /rhs rh tw sub tw sub def" nl() + " /rws rw tw sub tw sub def" nl() + " moveto" nl() + " 0 tw rmoveto" nl() + " tw 0 rlineto" nl() + " 0 tw neg rlineto" nl() + " rws 0 rlineto" nl() + " 0 tw rlineto" nl() + " tw 0 rlineto" nl() + " 0 rhs rlineto" nl() + " tw neg 0 rlineto" nl() + " 0 tw rlineto" nl() + " rws neg 0 rlineto" nl() + " 0 tw neg rlineto" nl() + " tw neg 0 rlineto" nl() + " closepath stroke" nl() + " } def" nl() + nl() + /* assuming that 2*(border thickness) < (chart width) */ + " 2 setlinecap" nl() + " 0 setlinejoin" nl() + " bwid1 setlinewidth" nl() + " lincolr0" nl() + " bwid1 2 div dup tw1 bwid1 sub th1 bwid1 sub rectt" nl() + " bwid2 setlinewidth" nl() + " bwid1 gapwid bwid2 2 div add add dup" nl() + " tw1 bwid1 2 mul sub gapwid 2 mul sub bwid2 sub " nl() + " th1 bwid1 2 mul sub gapwid 2 mul sub bwid2 sub rect" nl() + " % move the chart origin inside the border zone" nl() + " tbwid tbwid translate" nl() + " % take border thickness away from chart area" nl() + " /th1 th1 tbwid 2 mul sub def" nl() + " /tw1 tw1 tbwid 2 mul sub def" nl() + " /wp1 wp1 tbwid xpages 1 eq {2 mul} if sub def" nl() + "} bind def" nl() + nl() + + "% calculate max. font sizes and scale factor for placement of chart elements" nl() + "% depends on: th1, tw1" nl() + "% determines: posunit, minpos, rl, fntsize, fntsize2, linwid, dashwid," nl() + "% char2line, line2char, line_gap, name_adjust, name_extra, len1" nl() + "/calcScale {" nl() + " % for now, overestimate the upwards name_adjust with name_height" nl() + " /minpos minpos_text name_height sub minpos_line min def" nl() + " /maxpos maxpos_text maxpos_line max def" nl() + " /posunit th1 maxpos minpos sub div def" nl() + nl() + " % Now we have the remaining height and width, compute" nl() + " % the column width, font size etc." nl() + " %" nl() + " /rl tw1 maxlevel minlevel sub 1 add div def" nl() + nl() + " % calculate base font size from segment length" nl() + " /fntsize rl 9.0 div def" nl() + nl() + /* RES: make so two solid marks of dashed line appear on indent length */ + " /dashwid rl indent mul 3 div def" nl() + nl() + " % size of name text, layout relies on a restricted font size" nl() + " fntsize name_height posunit mul gt {" nl() + " /fntsize name_height posunit mul def" nl() + " } if" nl() + nl() + " % find out how low below baseline any of the letters can reach" nl() + " fontname findfont /FontBBox get dup" nl() + " 3 get /sy2 exch fntsize mul 1000 div def" nl() + " 1 get /sy1 exch fntsize mul 1000 div def" nl() + " sy2 0 eq {" nl() + " newpath 0 0 moveto" nl() + " (A) false charpath flattenpath pathbbox newpath" nl() + " sy2 max /sy2 exch def pop sy1 min /sy1 exch def pop" nl() + " newpath 0 0 moveto" nl() + " (p) false charpath flattenpath pathbbox newpath" nl() + " sy2 max /sy2 exch def pop sy1 min /sy1 exch def pop " nl() + " } if" nl() + " /name_desc sy1 neg def" nl() + nl() + " % font for birth/death dates" nl() + " /fntsize2 fntsize date_height mul def" nl() + nl() + " % find out how low below baseline any of the letters can reach" nl() + " ifontname findfont /FontBBox get dup" nl() + " 3 get /sy2 exch fntsize2 mul 1000 div def" nl() + " 1 get /sy1 exch fntsize2 mul 1000 div def" nl() + " sy2 0 eq {" nl() + " newpath 0 0 moveto" nl() + " (A) false charpath flattenpath pathbbox newpath" nl() + " sy2 max /sy2 exch def pop sy1 min /sy1 exch def pop" nl() + " newpath 0 0 moveto" nl() + " (p) false charpath flattenpath pathbbox newpath" nl() + " sy2 max /sy2 exch def pop sy1 min /sy1 exch def pop " nl() + " } if" nl() + " /info_desc sy1 neg def" nl() + " /info_asc sy2 def" nl() + nl() + " % calc line width from font size" nl() + " /linwid fntsize .06 mul def" nl() + nl() + " % name_adjust -- adjustment to 'center' names on horiz. lines." nl() + " % it's the distance from baseline to middle of '-'." nl() + " % char2line & line2char -- indicate offsets to horiz. line ends" nl() + " % relative to char origins matching behavior of minus char. as a line" nl() + " boldfontname fntsize SF2" nl() + " newpath 0 0 moveto" nl() + " (-) false charpath flattenpath pathbbox newpath" nl() + " exch /minus_end exch def add 2 div /name_adjust exch def" nl() + " /char2line exch def" nl() + " (-) stringwidth pop minus_end sub /line2char exch def" nl() + " /line_gap char2line line2char add def" nl() + nl() + " % this is the highest a name can extend above its horiz. line (pos)" nl() + " /name_extra sy2 name_adjust sub def" nl() + nl() + " % name string length for all generations" nl() + " /len1 rl 1 indent 2 mul sub mul def" nl() + "} def" nl() + nl() + "% Draw a vertical line" nl() + "%" nl() + "/l {" nl() + " /duplic exch 1 eq def" nl() + " dup /direct exch 2 eq def" nl() + " /blood exch 1 ge def" nl() + " /parent exch def" nl() + " /pos exch def" nl() + " /level exch def" nl() + nl() + " mirror {" nl() + " /x maxlevel level sub rl mul def" nl() + " } {" nl() + " /x level minlevel sub 1 add rl mul def" nl() + " } ifelse" nl() + " /y1 top pos minpos sub posunit mul sub def" nl() + " /y2 top parent minpos sub posunit mul sub def" nl() + " blood {lincolr0}{lincolr1} ifelse" nl() + " duplic {[dashwid] 0 setdash}{[] 0 setdash} ifelse" nl() + " use_bold direct and {" nl() + " linwid bold_factor mul setlinewidth" nl() + " } {" nl() + " linwid setlinewidth" nl() + " } ifelse" nl() + " 0 setlinecap" nl() + " % 2 setlinecap affects dashes, so have to extend line ends manually" nl() + " x y1 currentlinewidth 2 div add moveto" nl() + " x y2 currentlinewidth 2 div sub lineto stroke" nl() + "} bind def" nl() + nl() + "%" nl() + "% Print a person" nl() + "% called once for each individual on chart" nl() + "%" nl() + "/i {" nl() + " /key exch def % database key, make show_keys true to show" nl() + " /info exch def % array of info strings: birth, death, etc." nl() + " /name exch def" nl() + " /rel_down exch 1 eq def % true if person connects to next level down" nl() + " /rel_up exch 1 eq def % true if person connects to next level up" nl() + " /duplic exch 1 eq def % true for duplicate individual" nl() + " dup % copy line-type for two uses" nl() + " /direct exch 2 eq def % true for direct ancestor, false for indirect" + nl() + " /blood exch 1 ge def % true for blood relatives" nl() + " /pos exch def % vertical position" nl() + " /level exch def % generation level, 0 = youngest" nl() + nl() + " mirror { % smallest gen. # on the right" nl() + " /rel_left rel_up def" nl() + " /rel_right rel_down def" nl() + " /x1 maxlevel level sub rl mul def" nl() + " } { % smallest gen. # on the left" nl() + " /rel_left rel_down def" nl() + " /rel_right rel_up def" nl() + " /x1 level minlevel sub rl mul def" nl() + " } ifelse" nl() + " /x2 x1 rl add def" nl() + nl() + " % x1=left edge, x=start of text, x2=right edge" nl() + nl() + " /ylin top pos minpos sub posunit mul sub def" nl() + nl() + " % Calculate the printed length of the name" nl() + " fontname boldfontname fntsize len1 name wlen" nl() + " /lname exch def /scalefactor exch def" nl() + nl() + " % use relative change in fontsize determined by wlen to scale name_adjust" + nl() + " % then determine the baseline position relative to the horizontal line" + nl() + " /y ylin name_adjust scalefactor mul sub def" nl() + nl() + " % Find the size of the longest text string" nl() + " /ls lname def" nl() + " /infoscale 1 def" nl() + " info {" nl() + " dup length 0 gt" nl() + " {ifontname boldifontname fntsize2 len1 5 4 roll wlen" nl() + " dup ls gt {/ls exch def}{pop}ifelse" nl() + " dup infoscale lt {/infoscale exch def}{pop}ifelse" nl() + " }{pop" nl() + " }ifelse" nl() + " }forall" nl() + nl() + " direct rel_left rel_right and or {" nl() + " % center record within generation" nl() + " /x x1 rl ls line_gap scalefactor mul add sub 2 div add def" nl() + " }{" nl() + " rel_right {/x x2 rl indent mul sub ls sub def} if" nl() + " rel_left {/x x1 rl indent mul add def} if" nl() + " } ifelse" nl() + " /xlin x def" nl() + " /x xlin line2char scalefactor mul add def" nl() + nl() + " use_bold direct and {" nl() + " boldfontname fntsize SF2" nl() + " linwid bold_factor mul setlinewidth" nl() + " } {" nl() + " fontname fntsize SF2" nl() + " linwid setlinewidth" nl() + " } ifelse" nl() + nl() + " blood {lincolr0}{lincolr1} ifelse" nl() + " duplic {[dashwid] 0 setdash}{[] 0 setdash} ifelse" nl() + " 0 setlinecap % don't cap lines -- stay clear of name characters" nl() + nl() + " rel_left {" nl() + " x1 ylin moveto xlin ylin lineto stroke" nl() + " } if" nl() + " rel_right {" nl() + " x lname add char2line scalefactor mul add ylin moveto" nl() + " x2 ylin lineto stroke" nl() + " } if" nl() + nl() + " % print name" nl() + " direct use_bold and {textcolr0}{textcolr1} ifelse" nl() + " x y moveto" nl() + " len1 name wshow*" nl() + " % drop down by height of name font descenders" nl() + " /y y name_desc sub def" nl() + " % drop down by height of small text above its baseline + small font gap" nl() + " /y y info_asc infoscale mul sub def" nl() + nl() + " use_bold direct and {" nl() + /* RES - alternative is to pass infoscale to wshow* */ + /* that would avoid danger of generating too many fonts in PS engine */ + " boldifontname fntsize2 infoscale mul SF2" nl() + " }{" nl() + " ifontname fntsize2 infoscale mul SF2" nl() + " } ifelse" nl() + nl() + " % print info: birth, death, etc." nl() + " info" nl() + " { dup length 0 gt" nl() + " { x y moveto" nl() + " len1 exch wshow*" nl() + " /y y fntsize2 sub def" nl() + " }{pop" nl() + " }ifelse" nl() + " }forall" nl() + if(debug_postscript) { + nl() + " show_positions { % not for use with show_keys simultaneously" nl() + " pos abs floor 1 ge {" nl() + " pos abs log cvi" nl() + " }{1}ifelse" nl() + " pos 0 lt {1 add} if" nl() + " 5 add string /tmp exch def" nl() + " pos tmp cvs" nl() + " x y moveto" nl() + " len1 tmp wshow*" nl() + " }if" nl() + } + " show_keys {" nl() + " x y moveto" nl() + " len1 key wshow*" nl() + " }if" nl() + "} bind def" nl() + nl() + + "% If colour is required, set the appropriate fields" nl() + "% and define colour setting procedures accordingly." nl() + "% Note: setcmykcolor is a PostScript Level 2 operator." nl() + "%" nl() + "use_color black-and-white-device not and {" nl() + " /setcmykcolor where { pop" nl() + " Tr Tg Tb add add 0 eq {" nl() + " /Tk 1 def" nl() + " } {" nl() + " /Tk 0 def" nl() + " /Tr 1 Tr sub def /Tg 1 Tg sub def /Tb 1 Tb sub def" nl() + " } ifelse" nl() + nl() + " tr tg tb add add 0 eq {" nl() + " /tk 1 def" nl() + " } {" nl() + " /tk 0 def" nl() + " /tr 1 tr sub def /tg 1 tg sub def /tb 1 tb sub def" nl() + " } ifelse" nl() + nl() + " Lr Lg Lb add add 0 eq {" nl() + " /Lk 1 def" nl() + " } {" nl() + " /Lk 0 def" nl() + " /Lr 1 Lr sub def /Lg 1 Lg sub def /Lb 1 Lb sub def" nl() + " } ifelse" nl() + nl() + " lr lg lb add add 0 eq {" nl() + " /lk 1 def" nl() + " } {" nl() + " /lk 0 def" nl() + " /lr 1 lr sub def /lg 1 lg sub def /lb 1 lb sub def" nl() + " } ifelse" nl() + nl() + " /textcolr0 {Tr Tg Tb Tk setcmykcolor} bind def % direct names" nl() + " /textcolr1 {tr tg tb tk setcmykcolor} bind def % indirect names" nl() + " /lincolr0 {Lr Lg Lb Lk setcmykcolor} bind def % direct lines" nl() + " /lincolr1 {lr lg lb lk setcmykcolor} bind def % indirect lines" nl() + " } {" nl() + " /textcolr0 {Tr Tg Tb setrgbcolor} bind def % direct names" nl() + " /textcolr1 {tr tg tb setrgbcolor} bind def % indirect names" nl() + " /lincolr0 {Lr Lg Lb setrgbcolor} bind def % direct lines" nl() + " /lincolr1 {lr lg lb setrgbcolor} bind def % indirect lines" nl() + " } ifelse" nl() + "} {" nl() + " /textcolr0 {} bind def" nl() + " /textcolr1 {} bind def" nl() + " /lincolr0 {} bind def" nl() + " /lincolr1 {} bind def" nl() + "} ifelse" nl() + nl() + + "% page printing procedure" nl() + "/print-a-page {" nl() + " /ypage exch def" nl() + " /xpage exch def" nl() + " /th1 th0 def" nl() + " /tw1 tw0 def" nl() + " /wp1 wp def" nl() + " % adjust for portrait or landscape" nl() + " % move origin so that desired page lands on the clip rectangle" nl() + " gsave % so we can undo portrait/landscape adjustments" nl() + nl() + " portrait {" nl() + " % portrait mode" nl() + " llx lly translate" nl() + " }{" nl() + " llx ury translate -90 rotate" nl() + " } ifelse" nl() + nl() + " % specify (rectangular) clipping path to keep the margins clean" nl() + " 0 0 wp hp RC" nl() + nl() + " % move origin so that desired portion of chart lands within clipping path" + nl() + " xpage wp mul neg ypage hp mul neg translate" nl() + nl() + " label_outside_border {" nl() + " display_label {print_label} if" nl() + " show_border {print_border} if" nl() + " display_title {" nl() + " show_border {" nl() + " % let the title or inside label get in closer to the border" nl() + " 0 bgap .9 mul neg translate /th1 th1 bgap .9 mul add def" nl() + " } if" nl() + " print_title" nl() + " } if" nl() + " }{" nl() + " show_border {print_border} if" nl() + " display_label display_title or {" nl() + " % let the title or inside label get in closer to the border" nl() + " 0 bgap .9 mul neg translate /th1 th1 bgap .9 mul add def" nl() + " display_label {print_label} if" nl() + " display_title {print_title} if" nl() + " } if" nl() + " } ifelse" nl() + nl() + + " calcScale % figure font size and scale factor to make chart fit" nl() + nl() + + " % chart starts this high on the page from chart origin. Allow for" nl() + " % the first name to extend above the 0 position." nl() + " /top th1 tweak add def" nl() + nl() + + " % print all lines and person info" nl() + " Aind {exec i} forall" nl() + " Alin {exec l} forall" nl() + nl() + " grestore" nl() + nl() + "} def % print-a-page procedure" nl() + "% --- End of Subroutines ---" nl() + "%%EndProlog" nl() + "%%BeginSetUp" nl() + if(and( nestr(paper_name, "NONE"), nestr(paper_name, "EPSF") )) { + if(manual_feed_opt) { + "%%BeginFeature: *ManualFeed " + if(eq(manual_feed_opt, 1)) {"True"} else {"False"} nl() + "/languagelevel where {pop languagelevel 2 ge}{false} ifelse" nl() + " {1 dict dup /ManualFeed " + if(eq(manual_feed_opt, 1)) {"true"} else {"false"} + " put setpagedevice" nl() + " }{statusdict /manualfeed " + if(eq(manual_feed_opt, 1)) {"true"} else {"false"} + " put}" nl() + "ifelse" nl() + "%%EndFeature" nl() + } + "%%BeginFeature: " + if(eq(manual_feed_opt, 1)) {"*PageRegion "} else {"*PageSize "} + if(eq(postscript_level, 1)) { + lower(paper_name) + } else { + paper_name + } + nl() + "/languagelevel where {pop languagelevel 2 ge}{false} ifelse" nl() + " {1 dict" nl() + " dup /Policies 2 dict dup /PageSize 2 put dup /MediaType 0 put put" nl() + " setpagedevice" nl() + " 2 dict" nl() + " dup /PageSize [" d(paper_width) " " d(paper_height) "] put" nl() + " dup /ImagingBBox null put" nl() + " setpagedevice" nl() + " }{ " lower(paper_name) nl() + " } ifelse" nl() + "%%EndFeature" nl() + } + nl() + if(ne(enc_choice, 0)) { + "/encvecmod* { % on stack should be /Encoding and an encoding array" nl() + " % make an array copy so we don't try to modify the original via pointer" + nl() + " dup length array copy" nl() + " encvecmod aload length dup 2 idiv exch 2 add -1 roll exch" nl() + " {dup 4 2 roll put}" nl() + " repeat" nl() + "} def" nl() + "/reenc {" nl() + " findfont" nl() + " dup length dict begin" nl() + " {1 index /FID eq {pop pop} {" nl() + " 1 index /Encoding eq {" nl() + " encvecmod* def" nl() + " }{def} ifelse" nl() + " } ifelse" nl() + " } forall" nl() + " currentdict" nl() + " end" nl() + " definefont pop" nl() + "} def" nl() + } + if(eq(enc_choice, 1)) { + "% Adjust the font so that it is iso-8859-1 compatible" nl() + "/languagelevel where" nl() + " {pop languagelevel}{1} ifelse" nl() + "2 ge {" nl() + " % Use built-in ISOLatin1Encoding if PS interpreter is Level 2" nl() + " /encvecmod* {pop ISOLatin1Encoding} def" nl() + "}{" nl() + /* This array indicates changes to go from the Standard Encoding Vector + to the ISOLatin1 Encoding Vector for ISO-8859-1 compatibility, + according to the PostScript Language Reference Manual, 2nd ed. + The characters from A0 to FF are essential for 8859-1 conformance. + */ + " /encvecmod [" nl() +"16#90 /dotlessi 16#91 /grave 16#92 /acute 16#93 /circumflex" nl() +"16#94 /tilde 16#95 /macron 16#96 /breve 16#97 /dotaccent" nl() +"16#98 /dieresis 16#99 /.notdef 16#9a /ring 16#9b /cedilla" nl() +"16#9c /.notdef 16#9d /hungarumlaut 16#9e /ogonek 16#9f /caron" nl() +"16#a0 /space 16#a1 /exclamdown 16#a2 /cent 16#a3 /sterling" nl() +"16#a4 /currency 16#a5 /yen 16#a6 /brokenbar 16#a7 /section" nl() +"16#a8 /dieresis 16#a9 /copyright 16#aa /ordfeminine 16#ab /guillemotleft" + nl() +"16#ac /logicalnot 16#ad /hyphen 16#ae /registered 16#af /macron" nl() +"16#b0 /degree 16#b1 /plusminus 16#b2 /twosuperior 16#b3 /threesuperior" + nl() +"16#b4 /acute 16#b5 /mu 16#b6 /paragraph 16#b7 /periodcentered" + nl() +"16#b8 /cedilla 16#b9 /onesuperior 16#ba /ordmasculine 16#bb /guillemotright" + nl() +"16#bc /onequarter 16#bd /onehalf 16#be /threequarters 16#bf /questiondown" + nl() +"16#c0 /Agrave 16#c1 /Aacute 16#c2 /Acircumflex 16#c3 /Atilde" nl() +"16#c4 /Adieresis 16#c5 /Aring 16#c6 /AE 16#c7 /Ccedilla" nl() +"16#c8 /Egrave 16#c9 /Eacute 16#ca /Ecircumflex 16#cb /Edieresis" nl() +"16#cc /Igrave 16#cd /Iacute 16#ce /Icircumflex 16#cf /Idieresis" nl() +"16#d0 /Eth 16#d1 /Ntilde 16#d2 /Ograve 16#d3 /Oacute" nl() +"16#d4 /Ocircumflex 16#d5 /Otilde 16#d6 /Odieresis 16#d7 /multiply" nl() +"16#d8 /Oslash 16#d9 /Ugrave 16#da /Uacute 16#db /Ucircumflex" nl() +"16#dc /Udieresis 16#dd /Yacute 16#de /Thorn 16#df /germandbls" nl() +"16#e0 /agrave 16#e1 /aacute 16#e2 /acircumflex 16#e3 /atilde" nl() +"16#e4 /adieresis 16#e5 /aring 16#e6 /ae 16#e7 /ccedilla" nl() +"16#e8 /egrave 16#e9 /eacute 16#ea /ecircumflex 16#eb /edieresis" nl() +"16#ec /igrave 16#ed /iacute 16#ee /icircumflex 16#ef /idieresis" nl() +"16#f0 /eth 16#f1 /ntilde 16#f2 /ograve 16#f3 /oacute" nl() +"16#f4 /ocircumflex 16#f5 /otilde 16#f6 /odieresis 16#f7 /divide" nl() +"16#f8 /oslash 16#f9 /ugrave 16#fa /uacute 16#fb /ucircumflex" nl() +"16#fc /udieresis 16#fd /yacute 16#fe /thorn 16#ff /ydieresis" nl() + " ] def" nl() + "} ifelse" nl() + nl() + } elsif(eq(enc_choice, 2)) { + /* The following array specifies changes to make to a font encoding + to make characters A0 through FF match the ISO Latin alphabet no. 2 + This will work as long as there are instructions in the font for + drawing the glyphs named here. Missing glyphs would be + substituted with /.notdef from the font by the PostScript interpreter. + */ + "/encvecmod [" nl() + "16#a0 /space 16#a1 /Aogonek 16#a2 /breve 16#a3 /Lslash" nl() + "16#a4 /currency 16#a5 /Lcaron 16#a6 /Sacute 16#a7 /section" nl() + "16#a8 /dieresis 16#a9 /Scaron 16#aa /Scedilla 16#ab /Tcaron" nl() + "16#ac /Zacute 16#ad /hyphen 16#ae /Zcaron 16#af /Zdotaccent" nl() + "16#b0 /degree 16#b1 /aogonek 16#b2 /ogonek 16#b3 /lslash" nl() + "16#b4 /acute 16#b5 /lcaron 16#b6 /sacute 16#b7 /caron" nl() + "16#b8 /cedilla 16#b9 /scaron 16#ba /scedilla 16#bb /tcaron" nl() + "16#bc /zacute 16#bd /hungarumlaut 16#be /zcaron 16#bf /zdotaccent" nl() + "16#c0 /Racute 16#c1 /Aacute 16#c2 /Acircumflex 16#c3 /Abreve" nl() + "16#c4 /Adieresis 16#c5 /Lacute 16#c6 /Cacute 16#c7 /Ccedilla" nl() + "16#c8 /Ccaron 16#c9 /Eacute 16#ca /Eogonek 16#cb /Edieresis" nl() + "16#cc /Ecaron 16#cd /Iacute 16#ce /Icircumflex 16#cf /Dcaron" nl() + "16#d0 /Dcroat 16#d1 /Nacute 16#d2 /Ncaron 16#d3 /Oacute" nl() + "16#d4 /Ocircumflex 16#d5 /Ohungarumlaut 16#d6 /Odieresis 16#d7 /multiply" + nl() + "16#d8 /Rcaron 16#d9 /Uring 16#da /Uacute 16#db /Uhungarumlaut" nl() + "16#dc /Udieresis 16#dd /Yacute 16#de /Tcommaaccent 16#df /germandbls" nl() + "16#e0 /racute 16#e1 /aacute 16#e2 /acircumflex 16#e3 /abreve" nl() + "16#e4 /adieresis 16#e5 /lacute 16#e6 /cacute 16#e7 /ccedilla" nl() + "16#e8 /ccaron 16#e9 /eacute 16#ea /eogonek 16#eb /edieresis" nl() + "16#ec /ecaron 16#ed /iacute 16#ee /icircumflex 16#ef /dcaron" nl() + "16#f0 /dcroat 16#f1 /nacute 16#f2 /ncaron 16#f3 /oacute" nl() + "16#f4 /ocircumflex 16#f5 /ohungarumlaut 16#f6 /odieresis 16#f7 /divide" + nl() + "16#f8 /rcaron 16#f9 /uring 16#fa /uacute 16#fb /uhungarumlaut" nl() + "16#fc /udieresis 16#fd /yacute 16#fe /tcommaaccent 16#ff /dotaccent" nl() + " ] def" nl() + nl() + } elsif(eq(enc_choice, 3)) { + /* This array indicates changes necessary to go from the Standard Encoding + Vector to one matching the int'l characters and some others in the + IBM Extended Character Set (extended ASCII). + */ + "/encvecmod [" nl() +"16#80 /Ccedilla 16#81 /udieresis 16#82 /eacute 16#83 /acircumflex" nl() +"16#84 /adieresis 16#85 /agrave 16#86 /aring 16#87 /ccedilla" nl() +"16#88 /ecircumflex 16#89 /edieresis 16#8a /egrave 16#8b /idieresis" nl() +"16#8c /icircumflex 16#8d /igrave 16#8e /Adieresis 16#8f /Aring" nl() +"16#90 /Eacute 16#91 /ae 16#92 /AE 16#93 /ocircumflex" nl() +"16#94 /odieresis 16#95 /ograve 16#96 /ucircumflex 16#97 /ugrave" nl() +"16#98 /ydieresis 16#99 /Odieresis 16#9a /Udieresis 16#9b /cent" nl() +"16#9c /sterling 16#9d /yen 16#9e /.notdef 16#9f /florin" nl() +"16#a0 /aacute 16#a1 /iacute 16#a2 /oacute 16#a3 /uacute" nl() +"16#a4 /ntilde 16#a5 /Ntilde 16#a6 /ordfeminine 16#a7 /ordmasculine" +nl() +"16#a8 /questiondown 16#a9 /.notdef 16#aa /.notdef 16#ab /onehalf" nl() +"16#ac /onequarter 16#ad /exclamdown 16#ae /guillemotleft " + "16#af /guillemotright" nl() +"16#e1 /germandbls 16#ed /oslash 16#f1 /plusminus 16#f6 /divide" nl() +"16#f8 /degree 16#f9 /bullet" nl() + " ] def" nl() + nl() + } + + "% Copyright (c) 1991-1993 Thomas P. Blumer. All Rights Reserved." nl() + "% Permission granted to use in LifeLines report generation." nl() + "% table of how to get bold fonts" nl() + "/bolddict 40 dict def" nl() /* dictionary size might need boosting */ + "bolddict begin" nl() + " % default table entry is that boldfontname = fontname" nl() + " fontname fontname def" nl() + " ifontname ifontname def" nl() + " labelfontname labelfontname def" nl() + /* ADD new bold font associations below here */ + " /AvantGarde-Book /AvantGarde-Demi def" nl() + " /AvantGarde-BookOblique /AvantGarde-DemiOblique def" nl() + " /Bookman-Light /Bookman-Demi def" nl() + " /Bookman-LightItalic /Bookman-DemiItalic def" nl() + " /Courier /Courier-Bold def" nl() + " /Courier-Oblique /Courier-BoldOblique def" nl() + " /Times-Roman /Times-Bold def" nl() + " /Times-Italic /Times-BoldItalic def" nl() + " /Helvetica /Helvetica-Bold def" nl() + " /Helvetica-Condensed /Helvetica-Condensed-Bold def" nl() + " /Helvetica-Condensed-Oblique /Helvetica-Condensed-BoldObl def" nl() + " /Helvetica-Narrow /Helvetica-Narrow-Bold def" nl() + " /Helvetica-Narrow-Oblique /Helvetica-Narrow-BoldOblique def" nl() + " /Helvetica-Oblique /Helvetica-BoldOblique def" nl() + " /Hershey-Plain /Hershey-Plain-Bold def" nl() + " /NewCenturySchlbk-Roman /NewCenturySchlbk-Bold def" nl() + " /NewCenturySchlbk-Italic /NewCenturySchlbk-BoldItalic def" nl() + " /Palatino-Roman /Palatino-Bold def" nl() + " /Palatino-Italic /Palatino-BoldItalic def" nl() + " /ZapfChancery /ZapfChancery-Bold def" nl() + " /ZapfChancery-MediumItalic /ZapfChancery-Bold def" nl() + " /OmArabicRsimms /OmArabicRsimms-Bold def" nl() + "end" nl() + nl() + "/boldfontname bolddict fontname get def" nl() + "/boldifontname bolddict ifontname get def" nl() + nl() + "% The fshowdict is used to declare which PostScript proc to use" nl() + "% to show strings. For some Arabic and Hebrew fonts at least, the" nl() + "% characters have positive widths, which makes the 'show' command" nl() + "% place a character to the right of the prior one." nl() + "% A special 'show' variant, 'rlshow,' compensates for this." nl() + "% Record font names, both internal and those used to refer to a font." nl() + "% A font's real FontName should be here when there's the possibility" nl() + "% of using aliases for that font -- like using ZapfChancery instead of" nl() + "% ZapfChancery-MediumItalic. The font still thinks its name is the" nl() + "% latter." nl() + "/fshowdict 25 dict def" nl() + "fshowdict begin" nl() + " fontname /show def" nl() + " ifontname /show def" nl() + " boldfontname /show def" nl() + " boldifontname /show def" nl() + " labelfontname /show def" nl() + /* these two are typical substitution fonts */ + " /Courier /show def" nl() + " /Helvetica-Bold /show def" nl() + /* real font names, for which aliases may be used*/ + " /ZapfChancery-MediumItalic /show def" nl() + /* ADD NEW rlshow associations below here */ + " /Baghdad /rlshow def" nl() + " /Jerusalem /rlshow def" nl() + " /Jslm /rlshow def" nl() + " /OmArabicRsimms /rlshow def" nl() + " /OmArabicRsimms-Bold /rlshow def" nl() + " /OmegaSerifArabicOne /rlshow def" nl() + "end" nl() + nl() + if(ne(enc_choice, 0)) { + "/NewFont fontname reenc" nl() + "/fontname /NewFont def" nl() + nl() + "/NewBoldFont boldfontname reenc" nl() + "/boldfontname /NewBoldFont def" nl() + nl() + "/NewLabelFont labelfontname reenc" nl() + "/labelfontname /NewLabelFont def" nl() + nl() + "/NewTitleFont titlefontname reenc" nl() + "/titlefontname /NewTitleFont def" nl() + nl() + "/NewIFont ifontname reenc" nl() + "/ifontname /NewIFont def" nl() + nl() + "/NewBoldIFont boldifontname reenc" + "/boldifontname /NewBoldIFont def" + "% end font reencoding" nl() + nl() + } + + "% Find printable dimension for chart with a sequence of steps" nl() + nl() + "% get printable area for each page" nl() + "clippath pathbbox newpath" nl() + "/ury exch def /urx exch def" nl() + "/lly exch def /llx exch def" nl() + nl() + if(pacificpage) { + "% adjust for PacificPage cartridge" nl() + "statusdict /product known {" nl() + " statusdict begin product end (PacificPage) eq" nl() + " version (4.06) eq and {" nl() + " /lly lly 5 add def" nl() + " /ury ury 10 sub def" nl() + " } if" nl() + "} if" nl() + nl() + } + if(nestr(paper_name, "NONE")) { + "% ensure minimum margins and that chart fits in defined paper size" nl() + "llx margin_left lt {/llx margin_left def} if" nl() + "lly margin_bottom lt {/lly margin_bottom def} if" nl() + "paper_height margin_top sub dup ury lt {/ury exch def}{pop} ifelse" nl() + "paper_width margin_right sub dup urx lt {/urx exch def}{pop} ifelse" nl() + nl() + } else { /* paper dimensions not specified, so take margins from print area */ + "/llx llx margin_left add def /lly lly margin_bottom add def" nl() + "/urx urx margin_right sub def /ury ury margin_top sub def" nl() + nl() + } + "% get available width and height for printing on a sheet of paper" nl() + "/wp urx llx sub def" nl() + "/hp ury lly sub def" nl() + nl() + "% adjust for portrait or landscape" nl() + "portrait not {" nl() + " /tmp hp def" nl() + " /hp wp def" nl() + " /wp tmp def" nl() + "} if" nl() + nl() + "% get width and height of the multi-page printable area" nl() + "/tw0 wp xpages mul def" nl() + "/th0 hp ypages mul def" nl() + nl() + "% store vertical lines and individual records in arrays" nl() + "/Alin " d(length(llist_depth)) " array def" nl() + "/Aind " d(length(plist_person)) " array def" nl() + nl() + call print_all_verticals() + nl() + call print_all_persons() + "%%EndSetUp" nl() + set(yi, sub(yn, 1)) + while(ge(yi, 0)) { + set(yi_ord, sub(sub(yn, 1), yi)) + set(xi, 0) + while(lt(xi, xn)) { + set(page_num, add(mul(yi_ord, xn), xi, 1)) + "%%Page: " d(page_num) " " d(page_num) nl() + if(nestr(paper_name, "NONE")) { + "%%PageBoundingBox: 0 0 " d(paper_width) " " d(paper_height) nl() + } + d(xi) " " d(yi) " print-a-page" nl() + "showpage" nl() + set(xi, add(xi, 1)) + } + set(yi, sub(yi, 1)) + } + "%%EOF" nl() +} diff --git a/reports/ps-circle.ll b/reports/ps-circle.ll new file mode 100644 index 0000000..e192c39 --- /dev/null +++ b/reports/ps-circle.ll @@ -0,0 +1,1109 @@ +/* + * @progname ps-circle.ll + * @version 2.6.2 of 2003-12-10 + * @author Jim Eggert (eggertj@ll.mit.edu), Henry Sikkema (hasikkema@yahoo.ca) + * @category + * @output PostScript + * @description + + Print a five to ten-generation ancestry circle chart in PostScript. + +Version 2.5, December 2002 by Henry Sikkema (hasikkema@yahoo.ca) +Version 1.1, September 2002 +Version 1, 15 September 1993 by Jim Eggert (eggertj@ll.mit.edu) + +This program generates a basic five to ten-generation ancestry circle chart. +Its output is a Postscript file specifying the chart. This program +uses a modified version of the CIRC.PS program written by +David Campbell and John Dunn. + +You must choose the number of generations to print (5 - 10 generations). +For a larger number of generations the print may get VERY small but may +be enlarged using a program such as Corel Draw or other programs and printed +onto a larger paper or printed in parts. + +You have the option of creating a colour gradient background or an +alternating colour scheme for males and females. The gradient does take a while to +process since all I do is to draw and fill circles with decreasing radius. Please +email (see above) me if you know how to make a better gradient. To change the colours +you need to modify the resulting Postscript file. The colours are given +in RGB format. The default colors are RED for female text and BLUE for male text, +the backgrounds are opposite: light blue to female box fillin and light red for +male box fill in. The default colour gradient is a light brown on the inside +to a darker brown on the outside for an attempted antique look. + +http://sikkema.netfirms.com/family/tree/ps-circle/ps-circle.html + +The data currently printed depends on the level number and on the length +of the names. When there are more than one given name (i.e. second and +third names), if they are too long they are eliminated. + +The full birth date is printed if there is no known death date. In this +case, the date is preceeded by 'b:' to indicate that the date is a birth, +for example (b: 12 Sep 1901); the only exception is on level one where +the 'b:' is dropped for the sake of space. When only a death date is known, +it will be preceeded by a dash, for example (-1978). In every other case, only +the birth and death years are printed, for example (1901-1978). + +The case (capitalization) of the names are not changed at all from the GEDCOM file. + +This data is currently printed: + First line Second Line Third line +----------------------------------------------------------------- +Level 1: Given Names Surname Dates +Level 2: Full Name Dates --- +Level 3: Full Name Dates --- +Level 4: First Name Surname Dates +Level 5: First Name Surname Dates +Level 6: First Name Surname Dates +Level 7: Full Name Dates --- +Level 8: Full Name Dates --- +Level 9: Full Name, Dates --- --- +Level 10: Full Name, Dates --- --- + +Future: - color coding based on country of origin. (Robert Simms) + - marriage date estimate + - proper zooming in Ghostview + - eliminate blank pages with small radius +*/ + +global(indicentre) +global(marrest) +global(version) +global(printmarr) +global(gradient) +global(maxlevel) +global(printdate) +global(numindilines) +global(nummarr) +global(enc_choice) /* int, specifies character encoding to use */ +global(x_pages) +global(y_pages) +global(radius) +global(font_name) + +proc removeparentheses(n){ + set(b,index(n,"(",1)) + if(gt(b,0)){/*remove ( if it exists*/ + set(cb,index(n,")",1)) + if(gt(cb,b)){ /*remove upto the ) */ + set(startpt,add(cb,1)) + }else{ + set(startpt,add(b,1)) + } + set(endpt,strlen(n)) + if(gt(endpt,startpt)){ + set(n,concat(trim(n,sub(b,1)),substring(n,startpt,endpt))) + }else{ + set(n,trim(n,sub(b,1))) + } + } + set(b,index(n,")",1)) + if(gt(b,0)){/*remove ) if it exists*/ + set(startpt,add(b,1))set(endpt,strlen(n)) + if(gt(endpt,startpt)){ + set(n,concat(trim(n,sub(b,1)),substring(n,startpt,endpt))) + }else{ + set(n,trim(n,sub(b,1))) + } + } + set(b,substring(n,strlen(n),strlen(n))) + if(eq(b," ")){ /*remove final space if it exists*/ + set(n,trim(n,sub(strlen(n),1))) + } + set(b,index(n," ",1)) + if(gt(b,0)){/*remove double space if it exists*/ + set(startpt,add(b,1))set(endpt,strlen(n)) + if(gt(endpt,startpt)){ + set(n,concat(trim(n,sub(b,1)),substring(n,startpt,endpt))) + }else{ + set(n,trim(n,sub(b,1))) + } + } + n +} +proc put_given_name(person,length){ + if (ne(trimname(person,add(length,strlen(surname(person)),1)),"")){set(l,trimname(person,add(length,strlen(surname(person)),1)))}else{set(l,givens(person))} + if(ne(trim(l,sub(index(l,surname(person),1),2)),"")){set(n,trim(l,sub(index(l,surname(person),1),2)))} + call removeparentheses(n) +} + +proc put_full_name(person,sur_upper,n_order,length){ + set(n,fullname(person,sur_upper,n_order,length)) + call removeparentheses(n) + +} +proc endline(ahnen,offset,info,max){") " d(ahnen) " " d(offset) " " d(info) " " d(max) "} addind\n"} + +proc putperson(family, person, level, ahnen, info,dateformat) { + list(levellength) + setel(levellength,1,25) + setel(levellength,2,26) + setel(levellength,3,23) + setel(levellength,4,16) + setel(levellength,5,15) + setel(levellength,6,15) + setel(levellength,7,21) + setel(levellength,8,21) + setel(levellength,9,21) + setel(levellength,10,21) + setel(levellength,11,21) + + set(max,0) + set(offset,0) + + if(eq(dateformat,1)){ + if (eq(level,1)) { + if (givens(person)){set(max,add(max,1))} + if (surname(person)){set(max,add(max,1))} + if (or(year(death(person)),year(birth(person)))){set(max,add(max,1))} + + if (givens(person)){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" call put_given_name(person,getel(levellength,level)) call endline(ahnen,offset,info,max)} + if (surname(person)){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" surname(person) call endline(ahnen,offset,info,max)} + if (or(year(death(person)),year(birth(person)))){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" if (year(death(person))){year(birth(person))"-" year(death(person))}else{if(eq(indicentre,0)){"b:"}date(birth(person))}call endline(ahnen,offset,info,max)} + + }elsif(and(ge(level,2),le(level,6))){ + if (givens(person)){set(max,add(max,1))} + if (surname(person)){set(max,add(max,1))} + if (or(year(death(person)),year(birth(person)))){set(max,add(max,1))} + + if (givens(person)){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" call put_given_name(person,getel(levellength,level)) call endline(ahnen,offset,info,max)} + if (surname(person)){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" surname(person) call endline(ahnen,offset,info,max)} + if (or(year(death(person)),year(birth(person)))){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" if (year(death(person))){"("year(birth(person))"-" year(death(person))")"}else{if (year(birth(person))){"b:"date(birth(person))}}call endline(ahnen,offset,info,max)} + + }elsif(or(eq(level,7),eq(level,8))){ + if (or(givens(person),surname(person))){set(max,add(max,1))} + if (or(year(death(person)),year(birth(person)))){set(max,add(max,1))} + + if (or(givens(person),surname(person))){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" call put_full_name(person,0,1,getel(levellength,level)) call endline(ahnen,offset,info,max)} + if (or(year(death(person)),year(birth(person)))){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" if (year(death(person))){"("year(birth(person))"-" year(death(person))")"}else{if (year(birth(person))){"b:"date(birth(person))}}call endline(ahnen,offset,info,max)} + }elsif(ge(level,9)){set(offset,add(offset,1))set(max,add(max,1)) + set(numindilines,add(numindilines,1))d(numindilines)" {""(" call put_full_name(person,0,1,getel(levellength,level)) " " if (year(death(person))){"("year(birth(person))"-" year(death(person))")"}else{if (year(birth(person))){"b:"date(birth(person))}} call endline(ahnen,offset,info,max) + } + }elsif(ge(dateformat,2)){ /* (yyyy-yyyy) date format ------------------------------------- */ + if (eq(level,1)) { + if (givens(person)){set(max,add(max,1))} + if (surname(person)){set(max,add(max,1))} + if (or(eq(dateformat,3),or(year(death(person)),year(birth(person))))){set(max,add(max,1))} + + if (givens(person)){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" call put_given_name(person,getel(levellength,level)) call endline(ahnen,offset,info,max)} + if (surname(person)){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" surname(person) call endline(ahnen,offset,info,max)} + if (or(eq(dateformat,3),or(year(death(person)),year(birth(person))))){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" if (year(birth(person))){year(birth(person))}else{if(eq(dateformat,3)){" "}} "-" if (year(death(person))){year(death(person))}else{if(eq(dateformat,3)){" "}}call endline(ahnen,offset,info,max)} + + }elsif(and(ge(level,2),le(level,6))){ + if (givens(person)){set(max,add(max,1))} + if (surname(person)){set(max,add(max,1))} + if (or(eq(dateformat,3),or(year(death(person)),year(birth(person))))){set(max,add(max,1))} + + if (givens(person)){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" call put_given_name(person,getel(levellength,level)) call endline(ahnen,offset,info,max)} + if (surname(person)){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" surname(person) call endline(ahnen,offset,info,max)} + if (or(eq(dateformat,3),or(year(death(person)),year(birth(person))))){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "((" if (year(birth(person))){year(birth(person))}else{if(eq(dateformat,3)){" "}} "-" if (year(death(person))){year(death(person))}else{if(eq(dateformat,3)){" "}} ")"call endline(ahnen,offset,info,max)} + }elsif(or(eq(level,7),eq(level,8))){ + if (or(givens(person),surname(person))){set(max,add(max,1))} + if (or(eq(dateformat,3),or(year(death(person)),year(birth(person))))){set(max,add(max,1))} + + if (or(givens(person),surname(person))){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "(" call put_full_name(person,0,1,getel(levellength,level)) call endline(ahnen,offset,info,max)} + if (or(eq(dateformat,3),or(year(death(person)),year(birth(person))))){set(numindilines,add(numindilines,1))d(numindilines)" {"set(offset,add(offset,1)) "((" if (year(birth(person))){year(birth(person))}else{if(eq(dateformat,3)){" "}} "-" if (year(death(person))){year(death(person))}else{if(eq(dateformat,3)){" "}} ")"call endline(ahnen,offset,info,max)} + }elsif(ge(level,9)){set(offset,add(offset,1))set(max,add(max,1)) + set(numindilines,add(numindilines,1))d(numindilines)" {""(" call put_full_name(person,0,1,getel(levellength,level)) + if (or(eq(dateformat,3),or(year(death(person)),year(birth(person))))){" (" if (year(birth(person))){year(birth(person))}else{if(eq(dateformat,3)){" "}} "-" if (year(death(person))){year(death(person))}else{if(eq(dateformat,3)){" "}}")"} + call endline(ahnen,offset,info,max) + } + } + + if (eq(printmarr,1)){ + if (eq(marrest,1)){ /*marriage date estimation does not yet work!*/ + if (ne(date(marriage(family)),"")){if (eq("M",sex(person))){set(nummarr,add(nummarr,1))d(nummarr)" {(" stddate(marriage(family)) ") " d(ahnen) " " d(info)"} addmarr\n"}} + }else{ + if (ne(date(marriage(family)),"")){if (eq("M",sex(person))){set(nummarr,add(nummarr,1))d(nummarr)" {(" stddate(marriage(family)) ") " d(ahnen) " " d(info)"} addmarr\n"}} + } + } +} + +proc semicirc(family, person, level, ahnen, info, maxlevel,dateformat) { + + if (and(person,le(level,maxlevel))) { + call putperson(family,person,level,ahnen,info,dateformat) + set(nextlevel, add(level,1)) + set(nextahnen, mul(ahnen,2)) + call semicirc(parents(person), father(person), nextlevel, nextahnen, info,maxlevel,dateformat) + call semicirc(parents(person), mother(person), nextlevel, add(nextahnen,1), info,maxlevel,dateformat) + } +} + +proc putpageprintouts(xn,yn){ + set(page_num, 0) + set(yi, sub(yn, 1)) + while(ge(yi, 0)) { + set(yi_ord, sub(sub(yn, 1), yi)) + set(xi, sub(xn, 1)) + while(ge(xi, 0)) { + set(page_num, add(page_num, 1)) + "%%Page: " d(page_num) " " d(page_num) "\n" + "cleartomark mark\n" + d(xi) " " d(yi) " print-a-page\n" + "showpage\n" + set(xi, sub(xi, 1)) + } + set(yi, sub(yi, 1)) + } +} + +proc printfile(){ +"%!PS-Adobe-3.0\n" +"%%Title: (PS-CIRCLE.PS - Circular Genealogical Pedigree Chart in Postscript format)\n" +"%%Creator: " version " - a Lifelines circle ancestry chart report generator\n" +"%%CreationDate: " stddate(gettoday()) "\n" +"%%Pages: "d(mul(x_pages,y_pages))"\n" +"%%PageOrder: Ascend\n" +"%%Orientation: Portrait\n" +"%%EndComments\n\n" + +"%%BeginDefaults\n" +"%%ViewingOrientation: 1 0 0 1\n" +"%%EndDefaults\n\n" + +"%%BeginProlog\n\n" +"% much of the code involved with font encoding and with multipaging\n" +"% is borrowed from Robert Simms \n\n" + +"%page margins\n" +"/margin_top 20 def\n" +"/margin_bottom 20 def\n" +"/margin_left 20 def\n" +"/margin_right 20 def\n\n" + +"%number of pages in each direction\n" + +"/xpages "d(x_pages)" def\n" +"/ypages "d(y_pages)" def\n\n" + +"/fontname /"font_name" def\n\n" + +"/portrait true def\n\n" + +"/inch {72 mul} def\n\n" + +"/*SF { % Complete selectfont emulation\n" /**/ +" exch findfont exch\n" +" dup type /arraytype eq {makefont}{scalefont} ifelse setfont\n" +"} bind def\n\n" + +"/BuildRectPath{\n" +" dup type dup /integertype eq exch /realtype eq or{\n" +" 4 -2 roll moveto %Operands are: x y width height\n" +" dup 0 exch rlineto\n" +" exch 0 rlineto\n" +" neg 0 exch rlineto\n" +" closepath\n" +" }{\n" +" dup length 4 sub 0 exch 4 exch{\n" +" 1 index exch 4 getinterval aload pop\n" +" BuildRectPath\n" +" }for\n" +" pop\n" +" }ifelse\n" +"} bind def\n\n" + +"/*RC { gsave newpath BuildRectPath fill grestore } bind def\n\n" /**/ + +"% install Level 2 emulations, or substitute built-in Level 2 operators\n" +"/languagelevel where\n" +" {pop languagelevel}{1} ifelse\n" +"2 lt {\n" +" /RC /*RC load def\n" /**/ +" /SF /*SF load def\n" /**/ +"}{\n" +" /RC /rectclip load def % use RC instead of rectclip\n" +" /SF /selectfont load def % use SF instead of selectfont\n" +"} ifelse\n\n" + +"%Coordinate conversion utilities\n" +"/polar { %(ang rad) -> (x y)\n" +" /rad exch def /ang exch def\n" +" /x rad ang cos mul def /y rad ang sin mul def\n" +" x y\n" +"} def\n\n" + +"/midang {\n" +" /inf exch def\n" +" inf 1 eq {360 2 maxlevel exp div mul -90.0 add} %for first level male, go counter clockwise from bottom\n" +" {360 2 maxlevel exp div mul 90.0 add} ifelse %for first level female, go clockwise from bottom\n" +"} def\n\n" + +"%Shortcut macros\n" +"/m {moveto} def /l {lineto} def\n\n" + +"%Constants\n" +"/pi 3.14159265358979 def\n" +"/ptsize 10 def\n" +"/offset ptsize 1.25 mul neg def\n\n" + +"/radius {4.0 7.0 div exch indicentre add mul inch} def\n" + +"%begin font encoding borrowed from Robert Simms\n" +if(ne(enc_choice, 0)) { + "/encvecmod* { % on stack should be /Encoding and an encoding array\n" + " % make an array copy so we don't try to modify the original via pointer\n" + " dup length array copy\n" + " encvecmod aload length dup 2 idiv exch 2 add -1 roll exch\n" + " {dup 4 2 roll put}\n" + " repeat\n" + "} def\n" + "/reenc {\n" + " findfont\n" + " dup length dict begin\n" + " {1 index /FID eq {pop pop} {\n" + " 1 index /Encoding eq {\n" + " encvecmod* def\n" + " }{def} ifelse\n" + " } ifelse\n" + " } forall\n" + " currentdict\n" + " end\n" + " definefont pop\n" + "} def\n" +} +if(eq(enc_choice, 1)) { + "% Adjust the font so that it is iso-8859-1 compatible\n" + "/languagelevel where {pop languagelevel}{1} ifelse 2 ge {\n" + " /encvecmod* {pop ISOLatin1Encoding} def % Use built-in ISOLatin1Encoding if PS interpreter is Level 2\n" + "}{\n" + /* This array indicates changes to go from the Standard Encoding Vector + to the ISOLatin1 Encoding Vector for ISO-8859-1 compatibility, + according to the PostScript Language Reference Manual, 2nd ed. + The characters from A0 to FF are essential for 8859-1 conformance. + */ + " /encvecmod [\n" + " 16#90 /dotlessi 16#91 /grave 16#92 /acute 16#93 /circumflex\n" + " 16#94 /tilde 16#95 /macron 16#96 /breve 16#97 /dotaccent\n" + " 16#98 /dieresis 16#99 /.notdef 16#9a /ring 16#9b /cedilla\n" + " 16#9c /.notdef 16#9d /hungarumlaut 16#9e /ogonek 16#9f /caron\n" + " 16#a0 /space 16#a1 /exclamdown 16#a2 /cent 16#a3 /sterling\n" + " 16#a4 /currency 16#a5 /yen 16#a6 /brokenbar 16#a7 /section\n" + " 16#a8 /dieresis 16#a9 /copyright 16#aa /ordfeminine 16#ab /guillemotleft\n" + " 16#ac /logicalnot 16#ad /hyphen 16#ae /registered 16#af /macron\n" + " 16#b0 /degree 16#b1 /plusminus 16#b2 /twosuperior 16#b3 /threesuperior\n" + " 16#b4 /acute 16#b5 /mu 16#b6 /paragraph 16#b7 /periodcentered\n" + " 16#b8 /cedilla 16#b9 /onesuperior 16#ba /ordmasculine 16#bb /guillemotright\n" + " 16#bc /onequarter 16#bd /onehalf 16#be /threequarters 16#bf /questiondown\n" + " 16#c0 /Agrave 16#c1 /Aacute 16#c2 /Acircumflex 16#c3 /Atilde\n" + " 16#c4 /Adieresis 16#c5 /Aring 16#c6 /AE 16#c7 /Ccedilla\n" + " 16#c8 /Egrave 16#c9 /Eacute 16#ca /Ecircumflex 16#cb /Edieresis\n" + " 16#cc /Igrave 16#cd /Iacute 16#ce /Icircumflex 16#cf /Idieresis\n" + " 16#d0 /Eth 16#d1 /Ntilde 16#d2 /Ograve 16#d3 /Oacute\n" + " 16#d4 /Ocircumflex 16#d5 /Otilde 16#d6 /Odieresis 16#d7 /multiply\n" + " 16#d8 /Oslash 16#d9 /Ugrave 16#da /Uacute 16#db /Ucircumflex\n" + " 16#dc /Udieresis 16#dd /Yacute 16#de /Thorn 16#df /germandbls\n" + " 16#e0 /agrave 16#e1 /aacute 16#e2 /acircumflex 16#e3 /atilde\n" + " 16#e4 /adieresis 16#e5 /aring 16#e6 /ae 16#e7 /ccedilla\n" + " 16#e8 /egrave 16#e9 /eacute 16#ea /ecircumflex 16#eb /edieresis\n" + " 16#ec /igrave 16#ed /iacute 16#ee /icircumflex 16#ef /idieresis\n" + " 16#f0 /eth 16#f1 /ntilde 16#f2 /ograve 16#f3 /oacute\n" + " 16#f4 /ocircumflex 16#f5 /otilde 16#f6 /odieresis 16#f7 /divide\n" + " 16#f8 /oslash 16#f9 /ugrave 16#fa /uacute 16#fb /ucircumflex\n" + " 16#fc /udieresis 16#fd /yacute 16#fe /thorn 16#ff /ydieresis\n" + " ] def\n" + "} ifelse\n\n" +} elsif(eq(enc_choice, 2)) { + /* The following array specifies changes to make to a font encoding + to make characters A0 through FF match the ISO Latin alphabet no. 2 + This will work as long as there are instructions in the font for + drawing the glyphs named here. Missing glyphs would be + substituted with /.notdef from the font by the PostScript interpreter. + */ + "/encvecmod [\n" + " 16#a0 /space 16#a1 /Aogonek 16#a2 /breve 16#a3 /Lslash\n" + " 16#a4 /currency 16#a5 /Lcaron 16#a6 /Sacute 16#a7 /section\n" + " 16#a8 /dieresis 16#a9 /Scaron 16#aa /Scedilla 16#ab /Tcaron\n" + " 16#ac /Zacute 16#ad /hyphen 16#ae /Zcaron 16#af /Zdotaccent\n" + " 16#b0 /degree 16#b1 /aogonek 16#b2 /ogonek 16#b3 /lslash\n" + " 16#b4 /acute 16#b5 /lcaron 16#b6 /sacute 16#b7 /caron\n" + " 16#b8 /cedilla 16#b9 /scaron 16#ba /scedilla 16#bb /tcaron\n" + " 16#bc /zacute 16#bd /hungarumlaut 16#be /zcaron 16#bf /zdotaccent\n" + " 16#c0 /Racute 16#c1 /Aacute 16#c2 /Acircumflex 16#c3 /Abreve\n" + " 16#c4 /Adieresis 16#c5 /Lacute 16#c6 /Cacute 16#c7 /Ccedilla\n" + " 16#c8 /Ccaron 16#c9 /Eacute 16#ca /Eogonek 16#cb /Edieresis\n" + " 16#cc /Ecaron 16#cd /Iacute 16#ce /Icircumflex 16#cf /Dcaron\n" + " 16#d0 /Dcroat 16#d1 /Nacute 16#d2 /Ncaron 16#d3 /Oacute\n" + " 16#d4 /Ocircumflex 16#d5 /Ohungarumlaut 16#d6 /Odieresis 16#d7 /multiply\n" + " 16#d8 /Rcaron 16#d9 /Uring 16#da /Uacute 16#db /Uhungarumlaut\n" + " 16#dc /Udieresis 16#dd /Yacute 16#de /Tcommaaccent 16#df /germandbls\n" + " 16#e0 /racute 16#e1 /aacute 16#e2 /acircumflex 16#e3 /abreve\n" + " 16#e4 /adieresis 16#e5 /lacute 16#e6 /cacute 16#e7 /ccedilla\n" + " 16#e8 /ccaron 16#e9 /eacute 16#ea /eogonek 16#eb /edieresis\n" + " 16#ec /ecaron 16#ed /iacute 16#ee /icircumflex 16#ef /dcaron\n" + " 16#f0 /dcroat 16#f1 /nacute 16#f2 /ncaron 16#f3 /oacute\n" + " 16#f4 /ocircumflex 16#f5 /ohungarumlaut 16#f6 /odieresis 16#f7 /divide\n" + " 16#f8 /rcaron 16#f9 /uring 16#fa /uacute 16#fb /uhungarumlaut\n" + " 16#fc /udieresis 16#fd /yacute 16#fe /tcommaaccent 16#ff /dotaccent\n" + "] def\n\n" +} elsif(eq(enc_choice, 3)) { + /* This array indicates changes necessary to go from the Standard Encoding + Vector to one matching the int'l characters and some others in the + IBM Extended Character Set + */ + "/encvecmod [\n" + " 16#80 /Ccedilla 16#81 /udieresis 16#82 /eacute 16#83 /acircumflex\n" + " 16#84 /adieresis 16#85 /agrave 16#86 /aring 16#87 /ccedilla\n" + " 16#88 /ecircumflex 16#89 /edieresis 16#8a /egrave 16#8b /idieresis\n" + " 16#8c /icircumflex 16#8d /igrave 16#8e /Adieresis 16#8f /Aring\n" + " 16#90 /Eacute 16#91 /ae 16#92 /AE 16#93 /ocircumflex\n" + " 16#94 /odieresis 16#95 /ograve 16#96 /ucircumflex 16#97 /ugrave\n" + " 16#98 /ydieresis 16#99 /Odieresis 16#9a /Udieresis 16#9b /cent\n" + " 16#9c /sterling 16#9d /yen 16#9e /.notdef 16#9f /florin\n" + " 16#a0 /aacute 16#a1 /iacute 16#a2 /oacute 16#a3 /uacute\n" + " 16#a4 /ntilde 16#a5 /Ntilde 16#a6 /ordfeminine 16#a7 /ordmasculine\n" + " 16#a8 /questiondown 16#a9 /.notdef 16#aa /.notdef 16#ab /onehalf\n" + " 16#ac /onequarter 16#ad /exclamdown 16#ae /guillemotleft 16#af /guillemotright\n" + " 16#e1 /germandbls 16#ed /oslash 16#f1 /plusminus 16#f6 /divide\n" + " 16#f8 /degree 16#f9 /bullet\n" + "] def\n\n" +} +if(ne(enc_choice, 0)) { + "/gedfont fontname reenc\n" + "/fontname /gedfont def\n\n" +} +"%end font encoding end of section borrowed from Robert Simms\n" + +if (eq(gradient,1)){ + "/gradient{ %draw and fill 256 circles with a decreasing radius and slightly diffent colour\n" + " /blue2 exch def /green2 exch def /red2 exch def\n" + " /blue1 exch def /green1 exch def /red1 exch def\n\n" + + " /maxrad maxlevel radius def\n" + " /delta_r maxrad neg 256 div def %find radius step to use\n\n" + + " gsave\n" + " maxrad delta_r 0.0 { %step through the circles from large to small\n" + " /r exch def\n" + " /ratio r maxrad div def\n" + " /red red1 red2 sub ratio mul red2 add def % work out the new colour\n" + " /blue blue1 blue2 sub ratio mul blue2 add def\n" + " /green green1 green2 sub ratio mul green2 add def\n\n" + + " red green blue setrgbcolor\n" + " newpath 0.0 0.0 r 0 360 arc fill %draw and fill circles\n" + " } for\n" + " grestore\n" + "} def\n\n" +} +"/fan{ %Fan Template\n" + " gsave\n" +if(or(ne(printmarr,1),ne(transparent,1))){ + " %begin gender specific shading of boxes\n" + " /c 1 def %flag for the alternating colours\n" + " 1 indicentre sub 1 maxlevel {%shade the boxes if necessary\n" + " /i exch def\n" + " /delta_ang 360.0 2 i exp div def %set the angle stepsize\n" + " /r1 i radius def /r2 i 1 sub radius def %find the inner and outer radius for the box\n" + if (ge(maxlevel,8)){ + " i 8 ge {0}{0.7 radfactor div} ifelse" + }else{ + " .7 radfactor div" + } + " setlinewidth %if level is beyond 7 make lines thinnest possible\n\n" + " 90.0 delta_ang 449.99 { %step through all angles from 90 to 90+360 (450)\n" + " /ang1 exch def /ang2 ang1 delta_ang add def %find the beginning and ending angle for each box\n" + " newpath\n" + " i 0 gt{%draw the box\n" + " ang1 r1 polar m 0 0 r1 ang1 ang2 arc ang2 r2 polar l 0 0 r2 ang2 ang1 arcn\n" + " }{\n" + " 0 0 1 radius 0 0 1 radius 0 360 arc\n" + " }ifelse\n" + " closepath\n" +if(eq(transparent,0)){ + " i 0 gt { %fill in box if necessary\n" + " c 1 eq {/c1 0 def rf gf bf setrgbcolor} {/c1 1 def rm gm bm setrgbcolor} ifelse\n" + " }{\n" + " centrepersonsex 0 eq {rm gm bm setrgbcolor} {rf gf bf setrgbcolor} ifelse\n" + " }ifelse\n" + " gsave fill grestore\n" + " i 0 gt{/c c1 def}if %exchange color for next box\n" + " rl gl bl setrgbcolor\n\n" +} +if(eq(printmarr,0)){ +if(eq(transparent,0)){ + " i 9 le {stroke} if %draw outline of box if level is less than 10\n" +}else{ + " stroke\n" +} +} + " }for\n" + " }for %end gender specific shading of boxes\n" +} +if (eq(printmarr,1)){ + " %begin draw boxes around husband and wife\n" + " rl gl bl setrgbcolor\n" + " 2 indicentre sub 1 maxlevel { %step through the levels\n" + " /i exch def\n" + if (ge(maxlevel,8)){ + " i 8 ge {0}{0.7 radfactor div} ifelse" + }else{ + " .7 radfactor div" + } + " setlinewidth\n\n" + " /delta_ang 360.0 2 i 1 sub exp div def %set the angle stepsize\n" + " 90.0 delta_ang 449.99 {\n" + " /ang1 exch def /ang2 ang1 delta_ang add def\n" + " /r1 i radius def /r2 i 1 sub radius def\n\n" + + " %draw tic marks around marriage date\n" + " /delta_r r1 r2 sub 15 div def\n" + " /angave ang1 delta_ang 2 div add def\n" + " /r_inner r2 delta_r add def\n" + " /r_outer r1 delta_r sub def\n\n" + + " newpath angave r_outer polar m angave r1 polar l stroke\n" + " r2 0 gt{\n" + " newpath angave r2 polar m angave r_inner polar l stroke\n" + " }if\n\n" + +if(eq(transparent,0)){ + " rm gm bm setrgbcolor %erase small gap between male and female\n" + " .5 setlinewidth\n" + " newpath angave r_outer polar m angave r_inner polar l stroke\n" + " rl gl bl setrgbcolor\n" + if (ge(maxlevel,8)){ + " i 8 ge {0}{0.7 radfactor div} ifelse" + }else{ + " .7 radfactor div" + } + " setlinewidth\n" +} + + " %finish tic marks\n\n" + + " newpath %draw box around parents\n" + " ang1 r1 polar m 0 0 r1 ang1 ang2 arc\n" + " ang2 r2 polar l 0 0 r2 ang2 ang1 arcn closepath\n" + " stroke\n" + " }for\n" + " }for %end draw boxes around husband and wife\n\n" +} + + +if (eq(printdate,1)){ + " 0 0 0 setrgbcolor\n" + " fontname 5 SF\n" + " /radiusprint maxlevel radius 1.01 mul def\n" + " datetoday radiusprint 300 circtext\n" +} +" grestore\n" +"} def\n\n" + +"/angtext{ %Angled Line Printing Procedure for outer lines than do not curve\n" +" /inf exch def /offst exch def /ang exch def /levelnum exch def /str exch def\n\n" + +" gsave\n" +" ang rotate %rotate coordinate system for printing\n\n" + +" /r1 levelnum 1 sub radius def /r2 levelnum radius def\n" +if(eq(printmarr,1)){ +" levelnum 1 eq indicentre 0 eq and{/r1 0 def /r2 0 def}if\n\n" +} +" /y r1 r2 add 2 div def\n\n" + +" inf 0 eq{0 offst -10 mul 15 add translate}{y 0.0 translate}ifelse\n\n" + +" str stringwidth pop 2 div neg offst moveto\n" +" str show\n" +" grestore\n" +"} def\n\n" + +"/circtext{ %Circular Line Printing Procedure for inner lines than do curve\n\n" + +" /angle exch def /textradius exch def /str exch def\n\n" + +" /xradius textradius ptsize 4 div add def\n" +" gsave\n" +" angle str findhalfangle add rotate\n" +" str {/charcode exch def ( ) dup 0 charcode put circchar} forall\n" +" grestore\n" +"} def\n\n" + +"/findhalfangle {stringwidth pop 2 div 2 xradius mul pi mul div 360 mul} def\n\n" + +"/circchar{ %print each character at a different angle around the circle\n" +" /char exch def\n\n" + +" /halfangle char findhalfangle def\n" +" gsave\n" +" halfangle neg rotate\n" +" textradius 0 translate\n" +" -90 rotate\n" +" char stringwidth pop 2 div neg 0 moveto\n" +" char show\n" +" grestore\n" +" halfangle 2 mul neg rotate\n" +"} def\n\n" + +"/setprintcolor{\n" +" /ahnen exch def /inf exch def\n" +" ahnen 2 div dup cvi eq {redmale greenmale bluemale setrgbcolor}{redfemale greenfemale bluefemale setrgbcolor} ifelse\n" +" ahnen inf mul 1 eq {redmale greenmale bluemale setrgbcolor} if\n" +"} def\n\n" + +"/position{ %compute position from ahnentafel number\n" +" /ahnenn exch def\n" +" ahnenn 2 maxlevel -1 add exp lt {\n" +" /a 2 ahnenn log 1.9999 log div floor exp def\n" +" /numerator 2 a mul -1 add -2 ahnenn a neg add mul add def\n" +" /fact 2 maxlevel -2 add exp def\n" +" numerator a div fact mul\n" +" }{2 maxlevel exp ahnenn neg add} ifelse\n" +"} def\n\n" + +"/level {1 add log 2 log div ceiling cvi} def %compute generation level from ahnentafel number\n\n" + +"/info{\n" +" /max exch def /inf exch def /noffset exch def /ahnen exch def\n" +" /fntfactor {[0 0.85 0.85 0.8 0.7 0.5 0.4 0.3 0.3 0.25 0.25 0.25 0.25] exch get} def %set different font sizes for each level\n\n" + +" ahnen 2 maxlevel exp lt {\n" +" /place ahnen position def\n" +" /levelnum ahnen level def %get the level number of the current person\n" +" /radtab levelnum radius def %get the radius of the current level\n" +" /ftsize ptsize levelnum fntfactor mul def %find the new fontsize depending on the current level number\n" +" /offset ftsize 1.25 mul neg def %find the distance that the text should be printed from the ring\n" +" inf ahnen setprintcolor %print the names and information in alternating colors as defined below in line #350\n" +" fontname ftsize SF %set the font to use\n\n" + +" levelnum 5 lt {levelnum radtab place noffset inf max inner} % the inner four rings\n" +" {levelnum place noffset inf 0 max outer} ifelse % all outer rings\n" +" } if\n" +"} def\n\n" + +if(eq(indicentre,1)){ + "/indiinfo{\n" + " /inf exch def /noffset exch def /ahnen exch def\n" + " /ftsize ptsize 0.9 mul def %find the new fontsize depending on the current level number\n" + " /offset ftsize 1.25 mul neg def %find the distance that the text should be printed from the ring\n" + " inf ahnen setprintcolor %print the names and information in alternating colors as defined below in line #350\n" + " fontname ftsize SF %set the font to use\n\n" + + " 0 0 noffset 0 angtext\n" + "} def\n\n" +} + +"/nstr 7 string def\n" +"/prtn {-0.5 inch 5.5 inch m nstr cvs show} def\n" +"/prt {-0.5 inch 5.5 inch m show} def\n\n" + +if (eq(printmarr,1)){ + "/minfo{\n" + " /inf exch def /ahnen exch def\n" + " /fntfactor {[0 0.7 0.7 0.6 0.6 0.5 0.4 0.3 0.3 0.25 0.25 0.25 0.25] exch get} def %set different font sizes for each level\n\n" + + " ahnen 2 maxlevel exp lt {\n" + " /place ahnen 1 eq {0}{ahnen 2 div position}ifelse def %get the position of the text counting on the outer ring from bottom upwards\n" + " /levelnum ahnen level def %get the level number of the current person\n" + " /ftsize ptsize levelnum fntfactor mul 0.80 mul def %find the new fontsize depending on the current level number\n" + " /offset ftsize 0.35 mul neg def %find the distance that the text should be printed from the ring\n" + " rl gl bl setrgbcolor\n" + " dup\n" + " /namelength exch length def\n" + " /f namelength 11 lt {1}{11 namelength div}ifelse def\n" + " fontname ftsize f mul SF %set the font to use\n\n" + + " levelnum place 0 inf 1 1 outer\n" + " } if\n" + "} def\n\n" +} + +"/inner{\n" +" /max exch def /inf exch def /noffset exch def /place exch def /radtab exch def /levelnum exch def\n" +" % slight modifications for each level for line spacing\n" +if(eq(indicentre,0)){ + " max 3 eq {/factor {[0.0 0.98 0.97 0.97 0.975] exch get} def}if\n" + " max 2 eq {/factor {[0.0 0.80 0.885 0.935 0.94] exch get} def}if\n" + " max 1 eq {/factor {[0.0 0.70 0.835 0.905 0.91] exch get} def}if\n\n" +} +if(eq(indicentre,1)){ + " max 3 eq {/factor {[0.0 0.96 0.98 0.98 0.975] exch get} def}if\n" + " max 2 eq {/factor {[0.0 0.96 0.935 0.945 0.94] exch get} def}if\n" + " max 1 eq {/factor {[0.0 0.96 0.905 0.915 0.91] exch get} def}if\n\n" +} + +" levelnum 1 eq indicentre 0 eq and{/offset offset 0.75 mul def} if %max the offset a bit smaller for the first level\n" +" radtab levelnum factor mul noffset offset mul add place inf midang circtext\n" +"} def\n\n" + +"/outer{\n" +" /max exch def /marr exch def /inf exch def /noffset exch def /place exch def /levelnum exch def\n\n" + +" % in the following:\n" +" % f1 spreads the text out apart from eachother when more positive (larger)\n" +" % f2 shifts the set of text counter clockwise when more positive (larger)\n" +if(eq(maxlevel,5)){ + " max 3 eq {levelnum 5 eq {/f1 -2.5 def /f2 1.35 def} if}if\n" + " max 2 eq {levelnum 5 eq {/f1 -2.5 def /f2 0.25 def} if}if\n\n" +} +if(eq(maxlevel,6)){ + " max 3 eq {levelnum 5 eq {/f1 -2.5 def /f2 6.50 def} if\n" + " levelnum 6 eq {/f1 -1.7 def /f2 1.50 def} if}if\n" + " max 2 eq {\n" + " levelnum 5 eq {/f1 -2.5 def /f2 4.85 def} if\n" + " levelnum 6 eq {/f1 -1.7 def /f2 1.50 def} if}if\n\n" +} +if(eq(maxlevel,7)){ + " max 3 eq {levelnum 5 eq {/f1 -2.5 def /f2 6.50 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 4.30 def} if}if\n" + " max 2 eq {\n" + " levelnum 5 eq {/f1 -2.5 def /f2 4.85 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 3.30 def} if\n" + " levelnum 7 eq {/f1 -1.0 def /f2 0.70 def} if}if\n" + " max 1 eq {\n" + " levelnum 5 eq {/f1 -2.5 def /f2 4.85 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 4.30 def} if\n" + " levelnum 7 eq {/f1 -2.0 def /f2 1.20 def} if}if\n\n" +} +if(eq(maxlevel,8)){ + " max 3 eq {levelnum 5 eq {/f1 -2.5 def /f2 6.50 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 4.30 def} if}if\n" + " max 2 eq {\n" + " levelnum 5 eq {/f1 -2.5 def /f2 4.85 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 3.30 def} if\n" + " levelnum 7 eq {/f1 -1.0 def /f2 2.20 def} if\n" + " levelnum 8 eq {/f1 -0.7 def /f2 0.80 def} if}if\n" + " max 1 eq {\n" + " levelnum 5 eq {/f1 -2.5 def /f2 4.85 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 3.30 def} if\n" + " levelnum 7 eq {/f1 -1.0 def /f2 1.50 def} if\n" + " levelnum 8 eq {/f1 -0.7 def /f2 0.50 def} if}if\n\n" +} +if(eq(maxlevel,9)){ + " max 3 eq {levelnum 5 eq {/f1 -2.5 def /f2 6.50 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 4.30 def} if}if\n" + " max 2 eq {\n" + " levelnum 5 eq {/f1 -2.5 def /f2 4.85 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 4.00 def} if\n" + " levelnum 7 eq {/f1 -1.0 def /f2 2.00 def} if\n" + " levelnum 8 eq {/f1 -0.6 def /f2 1.40 def} if}if\n" + " max 1 eq {\n" + " levelnum 5 eq {/f1 -2.5 def /f2 4.85 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 4.00 def} if\n" + " levelnum 7 eq {/f1 -1.0 def /f2 2.00 def} if\n" + " levelnum 8 eq {/f1 -0.6 def /f2 1.40 def} if\n" + " levelnum 9 eq {/f1 0.0 def /f2 0.00 def} if}if\n\n" +} +if(eq(maxlevel,10)){ + " max 3 eq {levelnum 5 eq {/f1 -2.5 def /f2 6.50 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 4.30 def} if}if\n" + " max 2 eq {\n" + " levelnum 5 eq {/f1 -2.5 def /f2 4.85 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 4.00 def} if\n" + " levelnum 7 eq {/f1 -1.0 def /f2 2.00 def} if\n" + " levelnum 8 eq {/f1 -0.6 def /f2 1.40 def} if}if\n" + " max 1 eq {\n" + " levelnum 5 eq {/f1 -2.5 def /f2 4.85 def} if\n" + " levelnum 6 eq {/f1 -1.6 def /f2 4.00 def} if\n" + " levelnum 7 eq {/f1 -1.0 def /f2 1.70 def} if\n" + " levelnum 8 eq {/f1 -0.6 def /f2 1.20 def} if\n" + " levelnum 9 eq {/f1 0.0 def /f2 0.40 def} if\n" + " levelnum 10 ge{/f1 0.0 def /f2 0.225 def}if}if\n\n" +} + +" marr 1 eq {/f1 0.0 def /f2 0.0 def} if\n\n" + +" /ang place inf midang f1 noffset mul f2 add add def\n" +" levelnum ang offset inf angtext\n" +"} def\n\n" + +"% borrowed from Robert Simms\n" +if(eq(indicentre,1)){ + "/addcenterindi {centerperson_array 3 1 roll put} def\n" +} +if(eq(printmarr,1)){ + "/addmarr {marriage_array 3 1 roll put} def\n" +} + "/addind {person_array 3 1 roll put} def\n\n" +} + +proc main() { + monthformat(4) + stddate(0) + dayformat(2) + + set(version, "ps-circle.ll version 2.6.2, 10 December 2003 - code by Henry Sikkema") + + set(numindilines,-1) + set(nummarr,-1) + + set(mc, -1) + + while (lt(mc,0)){ + list(options) + setel(options,1,"Family in centre (husband/wife).") + setel(options,2,"Individual in centre") + set(mc,menuchoose(options, "Select the number of generations you want printed:")) + if(eq(mc,0)){break()} + if(eq(mc,1)){set(indicentre,0) getfam(fam)} + if(eq(mc,2)){set(indicentre,1) getindi(person)} + } + + list(options) + setel(options,1,"5 generations.") + setel(options,2,"6 generations.") + setel(options,3,"7 generations.") + setel(options,4,"8 generations.") + setel(options,5,"9 generations.") + setel(options,6,"10 generations.") + set(maxlevel,menuchoose(options, "Select the numbers of generation you want printed:")) + if(eq(maxlevel,0)){break()} + set(maxlevel,add(maxlevel,4)) + + list(options) + setel(options,1,"Full birth date info if no date is given: ex b:11 Oct 1758") + setel(options,2,"Year only format: example (1758-1823)") + setel(options,3,"Year only format (spaces for unknown date) ex: ( -1823)") + set(mc, menuchoose(options, "Select date format:")) + if(eq(mc,0)){break()} + if(eq(mc,1)){set(dateformat,1)} + if(eq(mc,2)){set(dateformat,2)} + if(eq(mc,3)){set(dateformat,3)} + + list(options) + setel(options,1,"Yes, print marriage dates only if exact date is known.") + setel(options,2,"Yes, print marriage date even when estimate is found in file") + setel(options,3,"No, do not print marriage dates.") + set(mc, menuchoose(options, "Print marriage dates?")) + if(eq(mc,0)){break()} + if(eq(mc,1)){set(printmarr,1)set(marrest,0)} + if(eq(mc,3)){set(printmarr,0)} + if(eq(mc,2)){set(printmarr,1)set(marrest,1)} + + list(options) + setel(options,1,"Colour text (default: blue for males, red for females)") + setel(options,2,"Black Text (best for printing on non-colour printers)") + set(mc, menuchoose(options, "Select text colour option:")) + if(eq(mc,0)){break()} + if(eq(mc,1)){set(colourtext,1)} + if(eq(mc,2)){set(colourtext,0)} + + list(options) + setel(options,1,"Gender Specific Colour scheme (default: pink for males, light blue for females)") + setel(options,2,"Transparent Background (best for printing on non-colour printers)") + setel(options,3,"Gradient Colour scheme") + set(mc,menuchoose(options, "Select text colour option:")) + if (eq(mc,0)){break()} + if (eq(mc,1)){set(alternating,1)set(gradient,0)} + if (eq(mc,2)){set(alternating,0)set(gradient,0)} + if (eq(mc,3)){set(alternating,0)set(gradient,1)} + + list(options) + setel(options,1,"Yes, put on today's date.") + setel(options,2,"No, do not put on today's date.") + set(mc,menuchoose(options, "Do you want today's date printed on the circle?")) + if (eq(mc,0)){break()} + if (eq(mc,1)){set(printdate,1)} + if (eq(mc,2)){set(printdate,0)} + + list(options) + setel(options,1,"Helvetica/Arial") + setel(options,2,"Times-Roman") + setel(options,3,"Courier") + setel(options,4,"AvantGarde-Book") + setel(options,5,"Times-Roman") + setel(options,6,"ZapfChancery") + + set(mc,menuchoose(options, "Choose a font to use:")) + if (eq(mc,0)){break()} + if (eq(mc,1)){set(font_name,"Helvetica")} + if (eq(mc,2)){set(font_name,"Times-Roman")} + if (eq(mc,3)){set(font_name,"Courier")} + if (eq(mc,4)){set(font_name,"AvantGarde-Book")} + if (eq(mc,5)){set(font_name,"Palatino-Roman")} + if (eq(mc,6)){set(font_name,"ZapfChancery")} + + list(options) + setel(options,1,"Single page (maximum circle size on a single page)") + setel(options,2,"Multipage according to number of pages selected") + setel(options,3,"Multipage according to radius of chart") + set(mc,menuchoose(options, "Select page type: ")) + if (eq(mc,0)){break()} + if (eq(mc,1)){ + set(x_pages,1)set(y_pages,1)set(radius,0) + } + if(gt(mc,1)){ + print( "Radius (inches) # of pages Radius (inches) # of pages" + ,nl()," 0-8 1x1=1 32-33 4x4=16" + ,nl()," 8-10 2x1=2 33-42 5x4=20" + ,nl()," 10-16 2x2=4 42-43 6x4=24" + ,nl()," 16-21 3x2=6 43-50 6x5=30" + ,nl()," 21-25 3x3=9 50-54 7x5=35" + ,nl()," 25-32 4x3=12 54-59 7x6=42",nl() + ) + } + if (eq(mc,2)){ + getint( x_pages, "Number of horizontal portrait pages on chart") + getint( y_pages, "Number of vertical portrait pages on chart") + set(radius,0) + } + if (eq(mc,3)){ + getint(radius, "Enter desired radius in inches:") + if (le(radius,8)){set(x_pages,1)set(y_pages,1)} + if (and(ge(radius,8),lt(radius,10))){set(x_pages,2)set(y_pages,1)} + if (and(ge(radius,10),lt(radius,16))){set(x_pages,2)set(y_pages,2)} + if (and(ge(radius,16),lt(radius,21))){set(x_pages,3)set(y_pages,2)} + if (and(ge(radius,21),lt(radius,25))){set(x_pages,3)set(y_pages,3)} + if (and(ge(radius,25),lt(radius,32))){set(x_pages,4)set(y_pages,3)} + if (and(ge(radius,32),lt(radius,33))){set(x_pages,4)set(y_pages,4)} + if (and(ge(radius,33),lt(radius,42))){set(x_pages,5)set(y_pages,4)} + if (and(ge(radius,42),lt(radius,43))){set(x_pages,6)set(y_pages,4)} + if (and(ge(radius,43),lt(radius,50))){set(x_pages,6)set(y_pages,5)} + if (and(ge(radius,50),lt(radius,54))){set(x_pages,7)set(y_pages,5)} + if (and(ge(radius,54),lt(radius,59))){set(x_pages,7)set(y_pages,6)} + } + print(nl()) +/* +** ISO-Latin 1, or ISO 8859-1, is a world-wide standard for most languages +** of Latin origin: Albanian, Basque, Breton, Catalan, Cornish, Danish, Dutch +** English, Faroese, Finish (exc. S,s,Z,z with caron), +** French (exc. OE, oe, Y with dieresis), Frisian, Galician, German, +** Greenlandic, Icelandic, Irish Gaelic (new orthography), Italian, Latin, +** Luxemburgish, Norwegian, Portuguese, Rhaeto-Romanic, Scottish Gaelic, +** Spanish, Swedish. +** +** ISO Latin 2, or ISO 8859-2, covers these languages: Albanian, Croatian, +** Czech, English, German, Hungarian, Latin, Polish, Romanian (cedilla below +** S,s,T,t instead of comma), Slovak, Sloverian, Sorbian. +*/ + list(options) + setel(options, 1, "ISO Latin 1 most West European languages") + setel(options, 2, "ISO Latin 2 Central and East European languages") + setel(options, 3, "IBM PC (covers at least the international chars)") + set(enc_choice, menuchoose(options, + "Select font reencoding, or (q) to use what's in the fonts")) + if (eq(enc_choice,0)){break()} + + call printfile() + + if (eq(printdate,1)){ + monthformat(6) /*capitalized full word (eg, January, February) */ + "/datetoday (Date: " stddate(gettoday()) ") def\n\n" + monthformat(4) /*capitalized abbreviation (eg, Jan, Feb) */ + } + + "/indicentre "d(indicentre)" def %1=put individual in centre,0=family at centre\n" + if(eq(indicentre,1)){if(eq(sex(person),"M")){set(psex,0)}else{set(psex,1)} + "/centrepersonsex "d(psex)" def %0=male; 1=female\n\n"}else{"\n"} + + "/maxlevel " d(maxlevel) " def\n" + + "% color of the text in RGB format\n" + if(eq(colourtext,1)){ + "/redmale 0.0 def /greenmale 0.0 def /bluemale 1.0 def\n" + "/redfemale 1.0 def /greenfemale 0.0 def /bluefemale 0.0 def\n\n" + }else{ + "/redmale 0.0 def /greenmale 0.0 def /bluemale 0.0 def\n" + "/redfemale 0.0 def /greenfemale 0.0 def /bluefemale 0.0 def\n\n" + } + + if (eq(gradient,1)){ + "0.6431 0.3255 0.0228 % inside centre color in RGB format\n" + "0.9922 0.7686 0.5490 % outside rim color in RGB format to form a radial gradient\n" + "gradient\n\n" + "/transparent 1 def % 1=transparent, 0=color shading\n\n" + + "/rf 0.0 def /gf 0.0 def /bf 0.0 def %rgb female box fill\n" + "/rm 0.0 def /gm 0.0 def /bm 0.0 def %rgb male box fill\n\n" + + }else{ + if (eq(alternating,0)){ + "/transparent 1 def % 1=transparent, 0=color shading\n\n" + + "/rf 1.0 def /gf 1.0 def /bf 1.0 def %rgb female box fill\n" + "/rm 1.0 def /gm 1.0 def /bm 1.0 def %rgb male box fill\n\n" + }else{ + "/transparent 0 def % 1=transparent, 0=color shading\n\n" + + "/rf 0.8 def /gf 0.8 def /bf 1.0 def %rgb female box fill\n" + "/rm 1.0 def /gm 0.8 def /bm 0.8 def %rgb male box fill\n\n" + } + } +/* "/printmarr "d(printmarr)" def\n"*/ + + "/rl 0.0 def /gl 0.0 def /bl 0.0 def % rgb for lines\n" + +"% partially borrowed from Robert Simms\n" +"% Find printable dimension for chart with a sequence of steps\n\n" + +"% get printable area for each page\n" +"clippath pathbbox newpath\n" +"/ury exch def /urx exch def\n" +"/lly exch def /llx exch def\n\n" + +"/llx llx margin_left add def /lly lly margin_bottom add def\n" +"/urx urx margin_right sub def /ury ury margin_top sub def\n\n" + +"% get available width and height for printing on a sheet of paper\n" +"/wp urx llx sub def\n" +"/hp ury lly sub def\n\n" + +"% get width and height of the multi-page printable area\n" +"/tw0 wp xpages mul def\n" +"/th0 hp ypages mul def\n\n" + +"tw0 th0 gt {\n" +if(eq(radius,0)) {" /mindim th0 def\n"} +" th0 wp div ceiling cvi xpages lt {/xpages th0 wp div ceiling cvi def /tw0 wp xpages mul def /ypages ypages def}{/xpages xpages def /ypages ypages def}ifelse\n" +"}{\n" +if(eq(radius,0)) {" /mindim tw0 def\n"} +" tw0 hp div ceiling cvi ypages lt {/ypages tw0 hp div ceiling cvi def /th0 hp ypages mul def /xpages xpages def}{/xpages xpages def /ypages ypages def}ifelse\n" +"}ifelse\n\n" + +if(gt(radius,0)) { + "/radfactor " d(radius) " inch 8 inch div def\n" +}else{ + "/radfactor mindim 8 inch div def\n" +} +"/scalefactor 7.0 maxlevel indicentre add div radfactor mul def\n\n" + +"/print-a-page { % page printing procedure\n" +" /ypage exch ypages 2 div 1 sub sub def %y-correction to center chart\n" +" /xpage exch xpages 2 div 1 sub sub def %x-correction to center chart\n" +" ypage ypages lt xpage xpages lt and { %only print if page is in correct range\n" +" gsave\n" +" llx lly translate\n" +" 0 0 wp hp RC % specify (rectangular) clipping path to keep the margins clean\n" +" xpage wp mul ypage hp mul translate % move origin so that desired portion of chart lands within clipping path\n" +" scalefactor dup scale %enlarge scale to fit page\n" +" fan %draw circle template\n" + if(eq(indicentre,1)){" centerperson_array {exec indiinfo} forall %put in center person\n"} + " person_array {exec info} forall %put in all people with dates\n" + if(eq(printmarr,1)) {" marriage_array {exec minfo} forall %put in marriage dates\n"} +" 1 dup scale %reset scale to normal\n" +" grestore\n" +" } if\n" +"} def % print-a-page procedure\n\n" + +"%%EndProlog\n" +"%%BeginSetUp\n\n" + +"/fillarray{% store vertical lines and individual records in arrays\n" + +if(eq(indicentre,1)){ + "0 {(" call put_given_name(person,20) ") " d(psex) " 1 0} addcenterindi\n" + "1 {(" surname(person) ") " d(psex) " 2 0} addcenterindi\n" + "2 {(" if (or(eq(dateformat,0),year(death(person)))){year(birth(person))"-" year(death(person))}else{date(birth(person))}") " d(psex) " 3 0} addcenterindi\n" + call semicirc(parents(person),father(person),1,1,1,maxlevel,dateformat) + call semicirc(parents(person),mother(person),1,1,2,maxlevel,dateformat) +}else{ + call semicirc(fam,husband(fam),1,1,1,maxlevel,dateformat) + call semicirc(fam,wife(fam),1,1,2,maxlevel,dateformat) +} +"} def\n\n" + +if(eq(indicentre,1)){"/centerperson_array 3 array def\n"} +if(eq(printmarr,1)){"/marriage_array "d(add(nummarr,1))" array def\n"} +"/person_array "d(add(numindilines,1))" array def\n" + +"fillarray\n\n" + +"mark\n\n" +"%%EndSetUp\n" +call putpageprintouts(x_pages,y_pages) +"%%EOF\n" +print("Output file full-name: ", outfile(), nl()) +} diff --git a/reports/ps-fan/Makefile.am b/reports/ps-fan/Makefile.am new file mode 100644 index 0000000..041a7b9 --- /dev/null +++ b/reports/ps-fan/Makefile.am @@ -0,0 +1,17 @@ +# This makefile is for the lifelines reports + +AUTOMAKE_OPTIONS = no-dependencies + +# LL_REPORTS is to hold the actual report files +# (included files go in a different target below) +LL_REPORTS = ps-fan.ll + +# OTHER_REPORTS is to hold included files besides actual report files +# (eg, supporting files, graphics, included files) +OTHER_REPORTS = ps-fan.ps + +pkg_REPORTS = $(LL_REPORTS) $(OTHER_REPORTS) + +subreportdir = $(pkgdatadir)/ps-fan +subreport_DATA = $(pkg_REPORTS) +dist_subreport_DATA = $(pkg_REPORTS) diff --git a/reports/ps-fan/ps-fan.ll b/reports/ps-fan/ps-fan.ll new file mode 100644 index 0000000..28a6e07 --- /dev/null +++ b/reports/ps-fan/ps-fan.ll @@ -0,0 +1,54 @@ +/* + * @progname ps-fan1.ll + * @version 1993-08-16 + * @author Andrew Deacon (deacon@inf.ethz.ch) + * @category + * @output PostScript + * @description + * + * Write a PostScript fan chart. + * + * Code (by Tom re-arranged) by Andrew Deacon, deacon@inf.ethz.ch + * + * This report works only with the LifeLines Genealogy program + * + * This report was adapted from a file made by Cliff Manis using the + * GEDCHART software written by Tom Blumer. + * + * Output is a PostScript file. The file "ps-fan.ps" is included + * when the report is generated. This file consists of the PostScript + * commands used by the GEDCHART software written by Tom Blumer. + * + */ + +global(PS_HDR_FILE) + +proc main () +{ + set (nl,nl()) + getindi(indi) + set(PS_HDR_FILE, "ps-fan.ps") /* PostScript Header file name */ + copyfile(PS_HDR_FILE) + call pedigree(0, 1, 1, indi) + "showpage" nl() /* PostScript Tail command */ +} + +proc pedigree (in, lev, ah, indi) +{ + "(" fullname(indi,1,1,50) ")" + " (" if (evt, birth(indi)) { "b. " date(birth(indi)) } ")" + " (" if (evt, death(indi)) { "d. " date(death(indi)) } ")" + " " d(in) + " " d(sub(ah, lev)) + " i" + nl() + + if (lt(in,4)) { + if (par, father(indi)) { + call pedigree(add(1,in), mul(2,lev), mul(2,ah), par) + } + if (par, mother(indi)) { + call pedigree(add(1,in), mul(2,lev), add(1,mul(2,ah)), par) + } + } +} diff --git a/reports/ps-fan/ps-fan.ps b/reports/ps-fan/ps-fan.ps new file mode 100644 index 0000000..7105abe --- /dev/null +++ b/reports/ps-fan/ps-fan.ps @@ -0,0 +1,323 @@ +%!PS-Adobe-2.0 EPSF-1.2 +%%BoundingBox:0 0 1100 790 +/maxlevel 5 def +/color false def +/lr 0 def /lg 1 def /lb 1 def +/Lr 0 def /Lg 0 def /Lb 1 def +/tr 0 def /tg 1 def /tb 1 def +/Tr 0 def /Tg 0 def /Tb 1 def +/fontname /Helvetica def +/encvec [ +16#80 /Ccedilla +16#81 /udieresis +16#82 /eacute +16#83 /acircumflex +16#84 /adieresis +16#85 /agrave +16#86 /aring +16#87 /ccedilla +16#88 /ecircumflex +16#89 /edieresis +16#8a /egrave +16#8b /idieresis +16#8c /icircumflex +16#8d /igrave +16#8e /Adieresis +16#8f /Aring +16#90 /Eacute +16#91 /ae +16#92 /AE +16#93 /ocircumflex +16#94 /odieresis +16#95 /ograve +16#96 /ucircumflex +16#97 /ugrave +16#98 /ydieresis +16#99 /Odieresis +16#9a /Udieresis +16#9b /cent +16#9c /sterling +16#9d /yen +16#9f /florin +16#a0 /aacute +16#a1 /iacute +16#a2 /oacute +16#a3 /uacute +16#a4 /ntilde +16#a5 /Ntilde +16#a6 /ordfeminine +16#a7 /ordmasculine +16#a8 /questiondown +16#aa /logicalnot +16#ab /onehalf +16#ac /onequarter +16#ad /exclamdown +16#ae /guillemotleft +16#af /guillemotright +] def +% Copyright (c) 1991-1993 Thomas P. Blumer. All Rights Reserved. +/border true def + +color { + /setcmykcolor where { pop + Tr Tg Tb add add 0 eq { + /Tk 1 def + } { + /Tk 0 def + /Tr 1 Tr sub def /Tg 1 Tg sub def /Tb 1 Tb sub def + } ifelse + + Lr Lg Lb add add 0 eq { + /Lk 1 def + } { + /Lk 0 def + /Lr 1 Lr sub def /Lg 1 Lg sub def /Lb 1 Lb sub def + } ifelse + + /textcolr0 {Tr Tg Tb Tk setcmykcolor} bind def % direct ancestor name + /lincolr0 {Lr Lg Lb Lk setcmykcolor} bind def % direct ancestor lines + } { + /textcolr0 {Tr Tg Tb setrgbcolor} bind def % direct ancestor name + /lincolr0 {Lr Lg Lb setrgbcolor} bind def % direct ancestor lines + } ifelse +} { + /textcolr0 {} bind def + /lincolr0 {} bind def +} ifelse + +% get printable area +clippath pathbbox newpath +/ury exch def /urx exch def +/lly exch def /llx exch def +/lly lly 5 add def +/ury ury 10 sub def + +% set landscape mode, get width and height +/w ury lly sub def +/h urx llx sub def +w h lt { + % stay in portrait mode + llx lly translate + /tmp h def + /h w def + /w tmp def +} { + % set landscape mode + urx lly translate 90 rotate +} ifelse + +% decorative border +border { + /bwid1 2.5 def + /gapwid 1.5 def + /bwid2 0.7 def + /rect { + /rh exch def + /rw exch def + moveto + rw 0 rlineto + 0 rh rlineto + rw neg 0 rlineto + closepath stroke + } def + + bwid1 setlinewidth + lincolr0 + bwid1 2 div dup w bwid1 sub h bwid1 sub rect + + bwid2 setlinewidth + bwid1 gapwid bwid2 2 div add add dup + w bwid1 2 mul sub gapwid 2 mul sub bwid2 sub + h bwid1 2 mul sub gapwid 2 mul sub bwid2 sub rect + + % cut the border out of the imageable area + /tmp bwid1 gapwid bwid2 gapwid add add add def + tmp tmp translate + /w w tmp 2 mul sub def + /h h tmp 2 mul sub def +} if + +% Reencode the font so that we can use the IBMPC set of international chars +/encdict 12 dict def +/reenc { + encdict begin + /newenc exch def + /nfont exch def + /ofont exch def + /ofontdict ofont findfont def + /newfont ofontdict maxlength 1 add dict def + ofontdict { + exch dup /FID ne { + dup /Encoding eq + {exch dup length array copy newfont 3 1 roll put} + {exch newfont 3 1 roll put} ifelse + } + {pop pop} + ifelse + } forall + newfont /Fontname nfont put + newenc aload pop + newenc length 2 idiv + { newfont /Encoding get 3 1 roll put} + repeat + nfont newfont definefont pop + end +} def + +fontname /gedfont encvec reenc +/fontname /gedfont def +% end font reencoding + +% clear path +newpath + +% get radius of circular chart +/r w 2 div def +/dy h r sub def +/dx r r mul dy dy mul sub sqrt def +/a dy dx atan def + +% get center of circle, make it origin +/cx r def +/cy dy def +cx cy translate + +% ang1 = end angle for chart +% ang2 = begin angle for chart +/ang1 a 180 add def +/ang2 a neg def +/ang ang1 ang2 sub def + +% draw outline of chart +%0 0 moveto 0 0 r ang2 ang1 arc closepath stroke + +% 1-icf = fraction of radius segment for inner circle +/icf .67 def + +% length of one radius segment +/rl r maxlevel icf sub div def + +% calculate base font size from segment length +/fntsize rl 9.0 div def +fontname findfont fntsize scalefont setfont +/space ( ) stringwidth pop def + +% calc line width from segment length - .24 pts = 1 pixel +/linwid fntsize .1 mul def +linwid setlinewidth +/namey linwid 2 mul def + +2 setlinecap + +% name string length for 0 generation +/len0 rl def + +% name string length for other generations +/len1 rl space 2 mul sub def + +% show string given as argument +% select font size so that string fits in available length +/wshow { + /s exch def + /len exch def + fontname findfont fntsize scalefont setfont + s stringwidth pop dup len lt { + pop + } { + % compute new font size for exact fit + len exch div fntsize mul /fsize exch def + fontname findfont fsize scalefont setfont + } ifelse + textcolr0 + s show +} bind def + +% starting y for root children +/siby fntsize -2 mul def + +% called once for each individual on chart +/i { + /leaf exch def + /level exch def + /death exch def + /birth exch def + /name exch def + level maxlevel lt { + level 0 eq { + % print name, birth date, death date + gsave + len0 -2 div siby translate + /x 0 def + x namey moveto + len0 name wshow + /siby siby fntsize 2 mul sub def + + fontname findfont fntsize scalefont setfont + birth length 0 gt { + x fntsize neg moveto + len0 birth wshow + /siby siby fntsize sub def + } if + death length 0 gt { + x fntsize neg 2 mul moveto + len0 death wshow + /siby siby fntsize sub def + } if + grestore + } { + % x1 = inner radius, x2 = outer radius + /x1 level icf sub rl mul def + /x2 x1 rl add def + + % aw = angle of wedge for one individual in this generation + /aw ang 2 level bitshift div def + + % a = angular position of this individual + /a aw leaf 2 mul 1 add mul def + /a ang1 a sub def + + % rotate coord system so this individual is on x axis + % display name and other info + gsave + a 90 lt { + a rotate + lincolr0 + x1 0 moveto x2 0 lineto stroke + /x x1 space add def + } { + a 180 sub rotate + lincolr0 + x2 neg 0 moveto x1 neg 0 lineto stroke + /x x2 neg space add def + } ifelse + + % print name, birth date, death date + x namey moveto + len1 name wshow + + fontname findfont fntsize scalefont setfont + birth length 0 gt { + x fntsize neg moveto + len1 birth wshow + } if + death length 0 gt { + x fntsize neg 2 mul moveto + len1 death wshow + } if + grestore + + % draw arc connecting this individual to his/her child + level 0 gt { + leaf 1 and 0 eq { + % father + lincolr0 + 0 0 x1 a aw sub a arc stroke + } { + % mother + lincolr0 + 0 0 x1 a a aw add arc stroke + } ifelse + } if + } ifelse + } if +} bind def diff --git a/reports/ps-pedigree.ll b/reports/ps-pedigree.ll new file mode 100644 index 0000000..6f5275b --- /dev/null +++ b/reports/ps-pedigree.ll @@ -0,0 +1,702 @@ +/* + * @progname ps-pedigree.ll + * @version 1.1.0 + * @author Stephen Woodbridge, woodbri@swoodbridge.com + * @category + * @output PostScript + * @description + * + * This report generates Multiple linked Pedigree Charts + * Each chart is 7 or 8 generations and as a line moves off + * a chart the new chart number is referenced. The output + * of this report is a POSTSCRIPT file. The text size is very + * small but readable (it seams less readable as I age!) on + * 8.5x11 paper with 8 generations and larger but somewhat + * compressed at 7 generations per chart. And an index of all + * persons on the charts is also created. + * + * Code by Stephen Woodbridge, woodbri@swoodbridge.com + * Copyright 1992 by Stephen Woodbridge + * + * Version one of this report was written in XLISP and this is a + * direct translation of that Lisp code. + * + * --- Version control info --- + * + * 10/22/92 - First Release 1.0.0 + * 10/28/92 - changed box width to expand the text font + * added CENTER_LAST global to center names in last boxes + * 11/05/92 - Release 1.1.0 Added name sorted index and misc. other + * features and enhancements. + * 11/03/03 - Included into LifeLines standard distribution. + * ps-pedi.ps renamed to ps-pedigree.ps + * + * --- Comments about the program --- + * + * There are lots of global flags that control whether or not aspects + * of the output are generated. These are set in "init_globals" and + * the comments there will explain them. The title string for the + * index is also set here. The program will also generate an index of + * just the people in the pedigree OR all people in the database. This + * is controlled by the flag INDEX_ALL. + * + * All global are in capitals. Global constants are set in + * init_globals and are not changed as the program runs. The global + * variables are used throughout the execution. + * There is a global TRACE which will print most proc names as they + * are executed. This is helpful in tracking down SEGV crashes. There + * is a global LIST which will print the name of each person or a "." + * as it is processed. The enqueueing of people to be processed is + * done in plot_me. + * + * You can adjust the margins on the paper. This has the effect of + * pushing the plot off the top/bottom/left/right. See M_TOP/M_BOT/ + * M_LEFT/M_RIGHT in init_globals. The current setting leaves a + * margin at the top for three-hole punching or binding. + * + * --- Comments about the PostScript output --- + * + * You can change the paper size without regenerating the output. + * The plot will scale to fit the paper. A ledger size paper makes + * the plots much easier to read. This can be done by editing line + * 66 in the output file. Just above this line are definitions for + * "a-size","a4-size" and "b4-size" paper. You can add your own paper + * sizes and reference them on line 66. + * + * Changing the small text font size will not nessasarily change the + * output on the paper because I compute an x and y scale factor the + * forces the chart into the bounds of the paper. Feel free to + * experiment and let me know if you get a good combination. + * + */ + +/* global variables */ + +global(RVAL) /* stack used to return values from procs */ +global(ILIST) /* indi's to be done in next depth of charts */ +global(NLIST) /* chart num of indi's above */ +global(WHICH_CHART) /* table xrefs of indi to chart number */ +global(FROM_CHART) +global(INDXSET) + +global(CHART_NO) +global(CURRENT_CHART_NO) +global(PAGE) /* postscript page number being outputed */ +global(PAGE_INDX) + +/* global constants */ + +global(M_BOT) +global(M_LEFT) +global(M_RIGHT) +global(M_TOP) + +global(LF_HGT) +global(LF_WDT) +global(SF_HGT) +global(SF_WDT) + +global(BOX_H) +global(BOX_DH) + +global(BOX_NC_1) +global(BOX_NC_2) + +global(BOX_W) +global(BOX_WW) +global(BOX_SP) +global(BOX_DW) + +global(CHART_PREFIX) +global(LEN_CHART_PREFIX) + +global(TEXT_HGT) +global(TEXT_WDT) + +global(INDEX_SIZE) +global(INDEX_LPP) +global(HEADER_SIZE) + +global(LINE_COUNT) + +global(PLOT_INUMS) +global(PLOT_DATE) +global(CENTER_LAST) +global(INDEX_ALL) +global(TITLE) + +global(TRACE) +global(LIST) +global(PS_HDR_FILE) + +/* + *--------------------------------------------------------* + */ + +proc main () +{ + set(TRACE, 0) /* trace proc calling sequence to trace down + SEGV: signal 11 crashes */ + + set(LIST, 0) /* list names as they are processed */ + + call init_globals() + + list(RVAL) + list(ILIST) + list(NLIST) + table(WHICH_CHART) + table(FROM_CHART) + indiset(INDXSET) + + getindi(me) + + /* + * The program can make 3 thru n generation charts + * but only the 7 and 8 have good aspect ratios that + * make them usable. + */ + getintmsg(max, "Enter max generations per chart [7 or 8]") + if (or( eq(max, 7), eq(max, 8))) + { + getintmsg(dmax, "Enter max depth of charts:") + + enqueue(ILIST, me) + enqueue(NLIST, 1) + + call plot_init(max, TITLE) + set(i, 1) + while(le(i, dmax)) + { + set (jlist, ILIST) + set (mlist, NLIST) + list(ILIST) + list(NLIST) + while (me, dequeue (jlist)) + { + set(cno, dequeue(mlist)) + set(CURRENT_CHART_NO, cno) + call new_plot_page(cno) + call do_ancestors(me, 1, 0, max) + call title_chart(cno, me, max) + } + set(i, add(i, 1)) + } + call plot_fini() + + call do_index() + call index_fini() + } +} + +proc init_globals() +{ + /* initialize global constants */ + + /* Paper margins for output in points */ + set(M_TOP, 27) /* 0.375in*72points/in */ + set(M_BOT, 0) + set(M_LEFT, 0) + set(M_RIGHT, 0) + + /* Large and small font sizes in points */ + set(LF_HGT, 18) + set(LF_WDT, 12) + set(SF_HGT, 5) + set(SF_WDT, 4) + + /* Size of text in boxes */ + set(TEXT_HGT, SF_HGT) + set(TEXT_WDT, SF_WDT) + + /* height of box and vertical spacing */ + set(BOX_H, add(1, TEXT_HGT)) + set(BOX_DH, add(1, BOX_H)) + + /* width of boxes in number of characters */ + set(BOX_NC_1, 42) + set(BOX_NC_2, 30) + + /* width of boxes and horizontal spacing */ + set(BOX_W, mul(BOX_NC_2, TEXT_WDT)) + set(BOX_WW, mul(BOX_NC_1, TEXT_WDT)) + set(BOX_SP, div( mul(BOX_W, 3), 20)) /* BOX_W*0.15 */ + set(BOX_DW, add(BOX_W, BOX_SP)) + + /* controls for the index */ + set(INDEX_SIZE, 8) + set(INDEX_LPP, 80) + set(HEADER_SIZE, 10) + + /* controls for what and how the charts appear */ + set(CHART_PREFIX, "") /* if CHART_PREFIX=0 then don't number charts */ + set(LEN_CHART_PREFIX, 0) + set(PLOT_INUMS, 1) /* bool 0=don't plot inums, 1=plot inums */ + set(PLOT_DATE, 1) /* bool 0=don't date charts, 1=date charts */ + set(CENTER_LAST, 1) /* bool 0=don't center names in last column, + 1=center names */ + set(INDEX_ALL, 0) /* bool 0=only index names on charts, + 1=index all names in database */ + + /* global variables used to keep track of which chart */ + + set(CHART_NO, 1) + set(CURRENT_CHART_NO, 0) + set(PAGE, 0) + set(PAGE_INDX, 1) + + set(PS_HDR_FILE, "ps-pedigree.ps") /* PostScript Header file name */ + + set(TITLE, "Pedigree Index") /* Title string for Index pages */ + + dayformat(0) + monthformat(3) + dateformat(0) +} + +proc do_ancestors (me, depth, width, max) +{ +if (TRACE) { print("do_ancestors ") } + if (me) + { + if (LIST) { + print(fullname(me,1,0,40)) print(" -") + print(key(me)) print(sp()) print(d(depth)) + print(sp()) print(d(width)) print(nl()) + } else + { print(".") } + + set(my_tag, lookup(WHICH_CHART, key(me))) + call plot_me(me, depth, width, max) + if ( and( or( eq(1, depth), not(my_tag)), lt(depth, max))) + { + if (dad, father(me)) + { + call get_width(1, width) + set(nwid, pop(RVAL)) + call do_ancestors(dad, add(1, depth), nwid, max) + call connect_boxes( me, depth, width, nwid, max) + } + if (mom, mother(me)) + { + call get_width(neg(1), width) + set(nwid, pop(RVAL)) + call do_ancestors(mom, add(1, depth), nwid, max) + call connect_boxes( me, depth, width, nwid, max) + } + } + else + { + call box_org(depth, width, max) + call draw_ext(me, pop(RVAL), pop(RVAL), my_tag, eq(depth, max)) + } + } +} + +proc plot_me (me, depth, width, max) +{ +if (TRACE) { print("plot_me ") } + set(last, eq(max, depth)) + set(first, eq(1, depth)) + set(style, ge(add(1, depth), max)) + call box_org(depth, width, max) + set(my_x, pop(RVAL)) + set(my_y, pop(RVAL)) + /* + * This if controls whether or not siblings are plotted + */ + if (first) { call do_sibs(me, my_x, my_y, last) } + else { call box_me(me, my_x, my_y, last) } + + if (not(lookup(WHICH_CHART, key(me)))) + { + set(ntag, CURRENT_CHART_NO) + if (and( last, parents(me))) + { + set(CHART_NO, add(1, CHART_NO)) + set(ntag, CHART_NO) + call draw_ext(me, my_x, my_y, ntag, last) + enqueue(ILIST, me) + enqueue(NLIST, ntag) + insert(FROM_CHART, save(d(CHART_NO)), CURRENT_CHART_NO) + } + insert(WHICH_CHART, save(key(me)), ntag) + addtoset(INDXSET, me, ntag) + } +} + +proc box_me (me, x, y, last) +{ +if (TRACE) { print("box_me ") } + call get_dates(me) + call print_name(me, 0) + if (PLOT_INUMS) { set(num, save(concat("-", key(me)))) } + else { set(num, "") } + call draw_box_text(x, y, pop(RVAL), pop(RVAL), num, last) +} + +proc do_sibs (me, x, y, last) +{ +if (TRACE) { print("do_sibs ") } + set(nkids, nchildren(parents(me))) + set(bdh, mul(2, BOX_DH)) + set(sy, div(mul(sub(nkids, 1), bdh), 2)) + children( parents(me), child, nchild) + { + set(yy, add(y, sy)) + call box_me(child, x, yy, last) + set(sy, sub(sy, bdh)) + } +} + +proc do_index() +{ +if (TRACE) { print("do_index ") } + print(nl()) print("Collecting Index ...") + if (INDEX_ALL) + { + forindi(me, num) + { + if (not(lookup(WHICH_CHART, key(me)))) { addtoset(INDXSET, me, 0) } + } + } + print(nl()) print("Sorting Index ...") + namesort(INDXSET) + print(nl()) print("Outputing Index ") + forindiset(INDXSET, me, chart, num) + { call index_out(me, chart) print(".") } +} + +/* + * -------- Postscript output routines --------- + */ + +proc plot_init (max, title) +{ +if (TRACE) { print("plot_init ") } + set(PAGE, 0) + copyfile(PS_HDR_FILE) + call expt(2, sub(max, 2)) + set(h, mul( add( pop(RVAL), 1), mul(2, BOX_DH))) + set(w, div( mul( add(max, 1), BOX_W), 2)) + set(w, add(w, add( mul(max, BOX_SP), BOX_WW))) + if (CHART_PREFIX) + { set(w, add(w, mul( add(LEN_CHART_PREFIX, 3), TEXT_WDT))) } + + "%%BeginSetup" nl() + + "/pointsize " d(INDEX_SIZE) " def" nl() + "/headerpointsize "d(HEADER_SIZE) " def" nl() + "/filename (" title ") def" nl() + "/noheader false def" nl() + "/date (" date(gettoday()) ") def" nl() + + "/nc-1 " d(BOX_NC_1) " def" nl() + "/nc-2 " d(BOX_NC_2) " def" nl() + "/margin-l " d(M_LEFT) " def" nl() + "/margin-r " d(M_RIGHT) " def" nl() + "/margin-t " d(M_TOP) " def" nl() + "/margin-b " d(M_BOT) " def" nl() + "/width-needed " d(w) " def" nl() + "/height-needed " d(h) " def" nl() + "/text-wdt " d(TEXT_WDT) " def" nl() + "/text-hgt " d(TEXT_HGT) " def" nl() + "setup" nl() + "/newpagesetup save def" nl() + "mark" nl() + + "%%EndSetup" nl() + + set(LINE_COUNT, 0) +} + + +proc new_plot_page (page_no) +{ +if (TRACE) { print("new_plot_page ") } + set(PAGE, add(1, PAGE)) + "%%Page: " d(page_no) " " d(PAGE) nl() "mark plotpagesetup" nl() +} + +proc plot_fini () +{ + set(PAGE, add(1, PAGE)) +} + +proc draw_box_text (x, y, name, date, num, last) +{ +if (TRACE) { print("draw_box_text ") } + if (last) + { "(" name " " date " " num ") " + if(CENTER_LAST) { set(t, " ct1") } else { set(t, " t1")} + } + else + { "(" name " " num ") (" date ") " set(t, " t2") } + d(x) " " d(y) t nl() +} + +proc draw_ext (me, x, y, chartno, last) +{ +if (TRACE) { print("draw_ext ") } + if (parents(me)) + { + if (last) { set(bw, div(BOX_WW, 2)) } + else { set(bw, div(BOX_W, 2)) } + "np " d(add(x, bw)) " " d(y) + " mto " d(div(BOX_SP, 3)) " 0 rlto drw" nl() + if (and( chartno, CHART_PREFIX)) + { + d( add(x, add(bw, add(TEXT_WDT, div(BOX_SP, 3))))) " " + d( sub(y, div(TEXT_HGT, 2))) " mto (" + CHART_PREFIX d(chartno) ") show" nl() + } + } +} + +proc connect_boxes (me, depth, width1, width2, max) +{ +if (TRACE) { print("connect_boxes ") } + call box_org(depth, width1, max) + set(x1, pop(RVAL)) + set(y1, pop(RVAL)) + call box_org(add(1, depth), width2, max) + set(x2, pop(RVAL)) + set(y2, pop(RVAL)) + set(dx, div( add(x1, x2), 2)) + set(w2, div(BOX_W, 2)) + set(w3, div(BOX_WW, 2)) + set(dh, 0) + set(dw, w2) + set(rad, BOX_H) + set(style, 0) + if (eq(depth, 1)) + { + set(nkids, nchildren(parents(me))) + set(sy, div( mul( sub(nkids, 1), mul(2, BOX_DH)), 2)) + if (gt(width2, 0)) + { set(y1, add(y1, sy)) } else { set(y1, sub(y1, sy)) } + } + if (lt(y1, y2)) + { set(dh, BOX_H) } else { set(dh, neg(BOX_H)) } + if (eq( sub(max, depth), 1)) + { + set(dw, w3) + set(style, 1) + set(rad, div(rad, 2)) + set(dx, div( sub( add(x1, add(w2, x2)), w3), 2)) + } + elsif( eq( sub(max, depth), 2)) + { + set(dw, w2) + set(style, 1) + } + if (style) + { + d(div(rad, 2)) " gr np " d(add(x1, w2)) " " d(y1) " mto " + d(dx) " " d(y1) " " d(dx) " " d(y2) " pto " + d(sub(x2, dw)) " " d(y2) " pto lto drw" nl() + } + else + { + d(rad) " gr np " d(x1) " " d(add(y1, dh)) " mto " + d(x1) " " d(y2) " " d(sub(x2, w2)) " " d(y2) " pto lto drw" nl() + } +} + +proc title_chart (chart_no, me, max) +{ +if (TRACE) { print("title_chart ") } + if (gt( sub(max, 2), 0)) + { + set(x, 0) + call expt(2, sub(max, 2)) + set(y, mul( add( pop(RVAL), 1), mul(2, BOX_DH))) + set(w, div( mul( add(max, 1), BOX_W), 2)) + set(w, add(w, add( mul(max, BOX_SP), BOX_WW))) + if (CHART_PREFIX) + { set(w, add(w, mul( add(4, LEN_CHART_PREFIX), TEXT_WDT))) } + d(y) " " d(w) " " d(x) " 0 mbox 18 1 rbox" nl() + if (PLOT_DATE) + { + d(add(x, LF_WDT)) " 1.2 mul " d(div(SF_HGT,2)) " mto (" + date(gettoday()) ") show" nl() + } + d(LF_WDT) " " d(LF_HGT) " mfont" nl() + call get_dates(me) + call print_name(me, 1) + d(add(x, mul(2, LF_WDT))) " " + d(sub(y, add(LF_HGT, div(LF_HGT, 2)))) " mto (" + pop(RVAL) ") show" nl() + d(add(x, mul(2, LF_WDT))) " " + d(sub(y, add( mul(LF_HGT, 2), div(LF_HGT,2)))) " mto (" + pop(RVAL) ") show" nl() + if (CHART_PREFIX) + { + d(add(x, LF_WDT)) " " d(div(LF_HGT,2)) " mto (Chart: " + CHART_PREFIX d(chart_no) + if (e, lookup(FROM_CHART, d(chart_no))) + { " From: " d(e) } + ") show" nl() + } + "cleartomark showpage" nl() + "%%EndPage: " d(PAGE) " " d(PAGE) nl() + } +} + +/* + * -------- Postscript output routines for index --------- + */ + +proc index_fini() +{ +if (TRACE) { print("index_fini ") } + "cleartomark showpage" nl() + "%%EndPage: " d(PAGE) " " d(PAGE) nl() + "%%Trailer" nl() + "%%Pages: " d(PAGE) nl() +} + +proc index_out (me, chart) +{ +if (TRACE) { print("index_out ") } + set(blanks, " ") + if (not(mod(LINE_COUNT, INDEX_LPP))) + { + "%%Page: " d(PAGE) " " d(PAGE) nl() + "mark indexpagesetup " d(PAGE_INDX) " pagesetup" nl() + } + + "(" + if (chart) { call rjt(chart, 5) pop(RVAL) } else { " " } + " " trim( save( concat( key(me)," ")), 6) + call get_dates(me) + call print_name(me, 1) + " " trim( save( concat(pop(RVAL),blanks)), 50) " " sex(me) + " " pop(RVAL) ")l" nl() + + set(LINE_COUNT, add(LINE_COUNT,1)) + if (not(mod(LINE_COUNT, INDEX_LPP))) + { + "cleartomark showpage" nl() + "%%EndPage: " d(PAGE) " " d(PAGE) nl() + set(PAGE, add(PAGE, 1)) + set(PAGE_INDX, add(PAGE_INDX, 1)) + set(LINE_COUNT, 0) + } +} + +/* + * -------- Utility routines --------- + */ + +proc print_name (me, last) +{ +if (TRACE) { print("print_name ") } + call get_title(me) + push(RVAL, save(concat(fullname(me, 1, not(last), 45), pop(RVAL)))) +} + +proc get_title (me) +{ +if (TRACE) { print("get_title ") } + fornodes(inode(me), node) + { + if (not(strcmp("TITL", tag(node)))) { set(n, node) } + } + if (n) { push(RVAL, save(concat(" ", value(n)))) } + else { push(RVAL, "") } +} + +proc get_dates (me) +{ +if (TRACE) { print("get_dates ") } + if (e, birth(me)) { set(b, save(concat("( ", date(e)))) } + else { set(b, "( ") } + if (e, death(me)) { set(d, save(concat(" - " , date(e)))) } + else { set(d, " - ") } + push(RVAL, save(concat(b, concat(d, " )")))) +} + +proc box_org (depth, width, max) +{ +if (TRACE) { print("box_org ") } + set(xx, div( mul(BOX_W, 9), 16)) + call expt(2, sub(max, 2)) + set(yy, mul( add( pop(RVAL), 1), BOX_DH)) + if ( eq(depth, 1)) + { push(RVAL, yy) push(RVAL, xx) } + else + { + call expt(2, sub(max, depth)) + set(dy, mul( pop(RVAL), BOX_DH)) + call abs(width) + set(y, sub( mul(pop(RVAL), dy), div(dy, 2))) + set(dx, add(BOX_SP, div(BOX_W, 2))) + set(dd, sub( sub(max, 2), depth)) + set(x, 0) + if ( eq(dd, neg(1))) + { set(dxx, div(BOX_W, 2)) } + elsif (eq(dd, neg(2))) + { set(dxx, add( div(BOX_W, 2), div(BOX_WW, 2))) } + else + { set(dxx, 0) } + set(x, add(dxx, add(xx, mul(dx, sub(depth, 1))))) + if ( lt(width, 0)) { set(y, neg(y)) } + push(RVAL, add(yy, y)) + push(RVAL, x) + } +} + +proc get_width (sign, width) +{ +if (TRACE) { print("get_width ") } + if (eq(width, 0)) + { push(RVAL, sign) } + else + { + call abs(width) + set(awidth, pop(RVAL)) + set(s2, div(width, awidth)) + if (eq(s2, sign)) + { push(RVAL, mul(width, 2)) } + else + { push(RVAL, mul( sub( mul(awidth, 2), 1), s2)) } + } +} + +proc abs (int) +{ +if (TRACE) { print("abs ") } + if (lt(int, 0)) + { push(RVAL, neg(int)) } + else + { push(RVAL, int) } +} + +proc rjt(n, w) +{ + if (lt(n, 10)) { set(d, 1) } + elsif (lt(n, 100)) { set(d, 2) } + elsif (lt(n, 1000)) { set(d, 3) } + elsif (lt(n, 10000)) { set(d, 4) } + else { set(d, 5) } + if (lt(d, w)) + { set(pad, save( trim(" ", sub(w, d)))) } + else + { set(pad, "") } + push(RVAL, save( concat(pad, save(d(n))))) +} + +proc expt(x, y) +{ +if (TRACE) { print("expt ") } + if (le(y, 0)) { set(result, 1) } + else + { + set(result, x) + while (y, sub(y,1)) + { set(result, mul(result, x)) } + } + push(RVAL, result) +} + diff --git a/reports/ps-pedigree.ps b/reports/ps-pedigree.ps new file mode 100644 index 0000000..0d78e22 --- /dev/null +++ b/reports/ps-pedigree.ps @@ -0,0 +1,293 @@ +%!PS-Adobe-1.0 +%%Creater: ps-pedigree +%%Title: Ancestry Charts +%%Pages: (atend) +%%DocumentFonts: Helvetica Courier Courier-Bold +%%EndComments + +/#findfont /findfont load def +/findfont { +dup #findfont dup /Encoding get 8#340 get /.notdef eq { + 12 dict begin + /newcodesandnames [ + 8#200 /aacute 8#335 /acircumflex 8#336 /adieresis + 8#337 /agrave 8#202 /atilde 8#201 /aring + 8#340 /ccedilla 8#342 /eacute 8#344 /ecircumflex + 8#345 /edieresis 8#346 /egrave 8#203 /iacute + 8#347 /icircumflex 8#354 /idieresis 8#204 /igrave + 8#205 /ntilde 8#206 /oacute 8#355 /ocircumflex + 8#356 /odieresis 8#207 /ograve 8#210 /otilde + 8#211 /scaron 8#212 /uacute 8#357 /ucircumflex + 8#360 /udieresis 8#362 /ugrave 8#213 /ydieresis + 8#214 /zcaron + 8#215 /Aacute 8#300 /Acircumflex 8#311 /Adieresis + 8#314 /Agrave 8#217 /Atilde 8#216 /Aring + 8#321 /Ccedilla 8#322 /Eacute 8#323 /Ecircumflex + 8#324 /Edieresis 8#325 /Egrave 8#220 /Iacute + 8#326 /Icircumflex 8#327 /Idieresis 8#221 /Igrave + 8#222 /Ntilde 8#223 /Oacute 8#330 /Ocircumflex + 8#331 /Odieresis 8#224 /Ograve 8#225 /Otilde + 8#226 /Scaron 8#227 /Uacute 8#332 /Ucircumflex + 8#333 /Udieresis 8#334 /Ugrave 8#230 /Ydieresis + 8#231 /Zcaron + ] def + /basefontdict exch def + /newfontname exch def + /newfont basefontdict maxlength dict def + basefontdict { + exch dup /FID ne { + dup /Encoding eq { exch 256 array copy } { exch } ifelse + newfont 3 1 roll put + } { pop pop } ifelse + } forall + newfont /FontName newfontname put + newcodesandnames aload pop + newcodesandnames length 2 idiv { newfont /Encoding get 3 1 roll put } + repeat newfontname newfont definefont + end +} { exch pop } ifelse +} def + +/headerpointsize 10 def +/font /Courier def +/pointsize 10 def +/Linespace {/Linespace pointsize 1.1 mul neg dup 3 1 roll def } def +/margin 10 def +/xoffset .35 def +/yoffset -0.30 def +/def_yoffset yoffset def +/def_xoffset xoffset def +/def_pointsize pointsize def +/roundpage true def +/useclippath true def +/pagebbox [0 0 612 792] def + +/inch {72 mul} bind def +/mm {2.8453 mul} bind def +/point {72 div} bind def +/min {2 copy gt {exch} if pop} bind def +/max {2 copy lt {exch} if pop} bind def +/rectpath {4 2 roll moveto dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto + closepath } def + +/a-size {8.5 inch 11 inch} bind def +/a4-size {210 mm 297 mm} bind def +/b4-size {10.125 inch 14.2 inch} bind def +/paper {/paper-x exch def /paper-y exch def} bind def + +a-size paper + +/mfont % w h mfont +{/fh exch def +/fw exch def +/Helvetica findfont +[fw 0 0 fh 0 0] makefont setfont +c-bs-1 c-bs-2 } def + +/c-bs-1 % calculate box size from current fh fw +{[fh 1 add fw nc-1 mul] cvx +/box-size-1 exch def} def + +/c-bs-2 % calculate box size from current fh fw +{[fh 2 mul 1 add fw nc-2 mul] cvx +/box-size-2 exch def} def + +/box-it % x y h w box-it +{2 copy 6 2 roll +box-org box} def + +/center-up % x y string center-up +{ dup stringwidth pop % x y string w +3 -1 roll 1 add % x string w y +exch 2 div % x string y (w/2) +4 -1 roll exch sub % string y (x-w/2) +exch moveto show } def + +/center-dn % x y string center-dn +{ dup stringwidth pop % x y string w +3 -1 roll fh sub % x string w (y-fsize) +1 add +exch 2 div % x string (y-fsize) (w/2) +4 -1 roll exch sub % string (y-fsize) (x-w/2) +exch moveto show } def + +/bbox % h w x y box % where x y is lower left corner +{newpath moveto % h w +dup 0 rlineto % h w +exch 0 exch rlineto % w +neg 0 rlineto +closepath 0.3 setlinewidth stroke} def + +/box % h w x y box % where x y is lower left corner +{newpath moveto % h w +dup 0 rlineto % h w +exch 0 exch rlineto % w +neg 0 rlineto +closepath 0.1 setlinewidth stroke} def + +/rbox % [x1 y1 x2 y2 x3 y3 x4 y4] r w rbox +{/w exch def /r exch def /a exch def +a 0 2 da1 r add newpath moveto +a 2 4 da a 4 4 da a 6 2 da1 a 0 2 da a 0 4 da +closepath w setlinewidth stroke} def + +/mbox % h w x y mbox => [x1 y1 x2 y2 x3 y3 x4 y4] +{2 copy % h w x y x y +5 index add 2 copy % h w x1 y1 x2 y2 x2 y2 +exch 6 index add exch % h w x1 y1 x2 y2 x3 y3 +2 copy 9 index sub % h w x1 y1 x2 y2 x3 y3 x4 y4 +8 array astore +3 1 roll pop pop} def + +/box-org % x y h w box-org +{2 div % x y h (w/2) +exch 2 div exch % x y (h/2) (w/2) +4 -1 roll exch sub % y (h/2) (x-w/2) +3 1 roll sub % (x-w/2) (y-h/2) +} def + +/t2 % text1 text2 x y +{ 2 copy % text1 text2 x y x y +box-size-2 box-it % text1 text2 x y +2 copy 6 -1 roll % text2 x y x y text1 +center-up % text2 x y +3 -1 roll % x y text2 +center-dn } def + +/t1 % text x y +{ 2 copy % text x y x y +box-size-1 box-it % text x y +box-size-1 box-org +exch fw add exch 1 add % text (xorg+fw) yorg +moveto show } def + +/ct1 % text x y +{ 2 copy +box-size-1 box-it % text x y +3 -1 roll % x y text +dup stringwidth pop % x y text w +2 div % x y text (w/2) +4 -1 roll exch sub % y text (x-w/2) +3 -1 roll fh 1 sub 2 div sub % text (x-w/2) (y-(fh+1)/2) +moveto show } def + +/da2 { r arcto 4 {pop} repeat} def +/da1 {getinterval aload pop} def +/da {da1 da2} def +/gr {/r exch def} def +/pto {2 copy 6 2 roll da2} def + +/np {newpath} def +/mto {moveto} def +/rmto {rmoveto} def +/lto {lineto} def +/rlto {rlineto} def +/drw {0.1 setlinewidth stroke} def + +/plotpagesetup +{ newpagesetup restore /newpagesetup save def +90 rotate 12 12 translate +margin-l paper-y neg margin-b add translate +paper-x margin-l margin-r 36 add add sub width-needed div +paper-y margin-t margin-b 18 add add sub height-needed div +scale +text-wdt text-hgt mfont +} def + +/setup +{ + /linespace pointsize pointsize .10 mul add neg def + /headerspace headerpointsize headerpointsize .10 mul add 2 + linespace mul sub neg def + + font findfont pointsize scalefont setfont + + pagedimensions + + /standard_height 80 def_pointsize def_pointsize .10 mul add mul + yoffset inch sub margin 2 div add def + + /rel_height height def + /rel_width 7.5 inch def + + rel_height standard_height lt + { /yoffset yoffset def_yoffset sub margin point 2 div add def }if + width rel_width lt + { /xoffset xoffset def_xoffset sub margin point 2 div sub def }if +} def + +/indexpagesetup +{ + newpagesetup restore /newpagesetup save def + xcenter ycenter translate + width 2 div neg height 2 div translate + xoffset inch yoffset inch translate + margin 2 div dup neg translate + + 0 headerspace translate +} def + +/pagedimensions { + useclippath userdict /gotpagebbox known not and { + /pagebbox [clippath pathbbox newpath] def + roundpage currentdict /roundpagebbox known and {roundpagebbox} if + } if + pagebbox aload pop .5 sub + + 4 -1 roll exch 4 1 roll 4 copy + sub /width exch def + sub /height exch def + add 2 div /xcenter exch def + add 2 div /ycenter exch def + userdict /gotpagebbox true put +} def + + +/page_num_len { % count number of digits of the current page number + /digits 1 def + /tens 10 def + { page tens lt + { exit } + { /digits digits 1 add def + /tens tens 10 mul def } ifelse + } loop +} def + +/page_num { % convert page to a string + page_num_len page digits string cvs +} def + +/printpage { % stk:int (right justified from this "int" value) + page_num stringwidth pop % get length of string + sub % calculate white space + 0 rmoveto page_num % move over to the right that much + 0 setgray show +} def + + +/show_simpleheader { + currentdict /headerfont known + {headerfont findfont headerpointsize scalefont setfont} + {/Courier-Bold findfont headerpointsize scalefont setfont} ifelse + currentdict /date known + { 0 0 moveto date 0 setgray show } if + currentdict /filename known + { 0 0 moveto + filename stringwidth pop 2 div width xoffset inch + .5 inch add sub 2 div exch sub + 0 rmoveto filename 0 setgray show } if + 0 0 moveto width xoffset inch .75 inch add sub printpage +} def + +/pagesetup { + /page exch def + gsave + 0 headerpointsize .10 mul 2 linespace mul sub translate + show_simpleheader + grestore + 0 0 moveto 0 +} bind def + +/l {show Linespace add dup 0 exch moveto} bind def + +%%EndProlog diff --git a/reports/refn.ll b/reports/refn.ll new file mode 100644 index 0000000..47c0358 --- /dev/null +++ b/reports/refn.ll @@ -0,0 +1,79 @@ +/* + * @progname refn.ll + * @version 1.0 + * @author Larry Hamilton + * @category + * @output Text + * @description Report of all User Reference Numbers (REFN). + + Prints out the value of all the lines in your database with the REFN tag, + along with enough information so you can find the line easily. The purpose + of this report is so you can find all the REFNs, and double-check them for + duplicates. + + * Modified from Olsen, Eggert - places.ll + * + * by Larry Hamilton (lmh@hamiltongensociety.org) + * Version 1.0, November 10, 2005 + * + * The REFNs are printed out in the order that they appear in the database. + * + * To sort the output: + * on Unix\Linux: sort -f originalfilename -o sortedfilename + * on Windows: sort originalfilename /O sortedfilename + * + */ + +proc main() +{ + list(tag_stack) + + print("Printing all REFNs.\n") + print("Be patient. This may take a while.\n\n") + print("If there are no REFNs in the database,\nthere will not be a prompt for an output file name.\n") + + forindi (person, id) { + + traverse (inode(person), node, level) { + + setel(tag_stack, add(level, 1), tag(node)) + + if (eq(strcmp(tag(node), "REFN"), 0)) { + tag(node) " " value(node) " | " key(person) " " name(person) + forlist (tag_stack, tag, tag_number) { + if (and(gt(tag_number, 1), le(tag_number, level))) { " " tag } + } + "\n" + } + } + } + + forfam (fam, fnum) { + + traverse (fnode(fam), node, level) { + setel(tag_stack, add(level, 1), tag(node)) + + if (eq(strcmp(tag(node), "REFN"), 0)) { + tag(node) " " value(node) " | " key(fam) " (" + if (person,husband(fam)) { set(relation,", husb") } + elsif (person,wife(fam)) { set(relation,", wife") } + else { + children(fam,child,cnum) { + if (eq(cnum,1)) { + set(person,child) + set(relation,", chil") + } + } + } + if (person) { + key(person) " " name(person) relation + } + ") |" + forlist (tag_stack, tag, tag_number) { + if (and(gt(tag_number, 1), le(tag_number, level))) { " " tag } + } + "\n" + } + } + } +} diff --git a/reports/reg_html.ll b/reports/reg_html.ll new file mode 100644 index 0000000..04b53a7 --- /dev/null +++ b/reports/reg_html.ll @@ -0,0 +1,128 @@ +/* + * @progname reg_html.ll + * @version none + * @author Wetmore, Prinke + * @category + * @output HTML + * @description + * + * The output produces a HTML-marked file (without header) with + * one family group per line so that it is displayed on WWW when + * found with grep and properly formatted. + * Continental European genealogical symbols are used: + * * = born + = died x = married + * + * Original code by Tom Wetmore, ttw@cbnewsl.att.com, 1990 + * Modified for HTML/WWW by Rafal Prinke, rafalp@plpuam11.bitnet, 1995 + * + * This program is based on regvital by Tom Wetmore. I deleted + * all nroff output code and indexing code, and made some other + * modifications. + * + * + * The CGI script I wrote for searching the file and then navigating + * through it using the personal key numbers in angle brackets: + * + * #!/bin/sh + * echo Content-type: text/html + * echo + * if [ $# = 0 ] + * then + * echo "" + * echo "Surname search" + * echo "" + * echo "" + * echo "" + * echo "

    Give the surname of the family

    " + * echo "Regular expressions allowed

    " + * echo "" + * else + * echo "" + * echo "Search results" + * echo "" + * echo "" + * echo "" + * echo "

    Now you can jump to any person displayed

    " + * echo "type the person's number in angle brackets (lesser/greater)

    " + * grep -i "$*" <> + * echo "" + * fi + * + * + * + */ + +proc main () +{ + monthformat(2) + dateformat(5) + forindi(indi,n) { + print(" ") print(name(indi)) print(nl()) + call longvitals(indi) + set(j,1) + families(indi,fam,spouse,nfam) { + if (eq(1,nspouses(indi))) { + "

    x " } + else { "

    x " d(j) ") " + set(j,add(j,1)) } + if (eq(0,nchildren(fam))) { + call spousevitals(spouse,fam) + ", children not recorded [" key(spouse,1) "]" } + else { + call spousevitals(spouse,fam) + " [" key(spouse,1) "]" + children(fam,child,nchl) { + "
    " d(nchl) ". " + name(child) " [" key(child,1) "]" + } + } + "
    " + } + } + } + +proc longvitals(i) +{ + set(father,father(i)) + set(mother,mother(i)) + nl() "-------------------------

    " + if (or(father,mother)) { + "Parents: " + if (father) { name(father) } + if (and(father,mother)) { " & " } + if (mother) { name(mother) } + } + "

    <" key(i,1) ">" givens(i) " " surname(i) "

    " + set(e,birth(i)) + if(or(date(e),place(e))) { " * " } + if(date(e)) { stddate(e) ", " } + if(place(e)) { place(e) ", " } + set(e,death(i)) + if(or(date(e),place(e))) { " + " } + if(date(e)) { stddate(e) ", " } + if(place(e)) { place(e) ", " } + fornodes(inode(i), node) { + if (eq(0,strcmp("OCCU", tag(node)))) { + value(node) ", " + } + } + fornodes(inode(i), node) { + if (eq(0,strcmp("NOTE", tag(node)))) { + value(node) + fornodes(node, subnode) { + if (or(eqstr("CONT",tag(subnode)), + eqstr("CONC",tag(subnode)))) { + " " value(subnode) + } + } + } + } +} + +proc spousevitals (sp,fam) +{ + set(e,marriage(fam)) + if(date(e)) { stddate(e) ", " } + if(place(e)) { place(e) ", " } + name(sp) +} diff --git a/reports/register-rtf.ll b/reports/register-rtf.ll new file mode 100644 index 0000000..c601332 --- /dev/null +++ b/reports/register-rtf.ll @@ -0,0 +1,1225 @@ +/* + * @progname register-rtf.ll + * @version 1.6 + * @author Doug McCallum + * @category + * @output RTF + * @description + * + * RTF based Register Report Generator. + * This program has many options but basically takes a person + * and generates an RTF document that can be read by a number + * of word processors. The document can optionally be cross-indexed + * and footnoted. The format is close to the NEHGS Register Form. + * + * Options are set by setting variables at the beginning of main + * The options are: + * option values + * ------------- ---------------------------------------------------- + * doindex 0 == no index, 1 == create index + * prefix a string. This is prefixed to the standard + * numbers for people + * donotes 0 == don't output notes, 1 == output notes in-line + * 2 == output notes at end with a reference in text + * author a string used in the author info field + * strictness 0 == all descendents, 1 == modified form, 2 = strict + * childby 0 == list children together, 1 == indicate parent by + * titlepage 0 == no title page, 1 == generate title page + * dosources 0 == don't output sources, 1 == output sources + * occupation 0 == don't output occupation, 1 == output occupation + * + * Not implemented yet: + * showrefn 0 == don't show user refn tags, 1 == show tags + * + * + * Notes: + * when an index is created, it must be turned on in the word processor + * since only the indexing is actually done. Each time a name is seen + * it is indexed. If the name is a reference to the person as child of, + * then it is indexed in plain form numbers. If the person is a spouse + * the page number is italic and if the person is the first entry in + * the family info, then the page number is bold. + * + * The "prefix" is intended for use when doing multifamily reports. + * Further work needs to be done, but it can get you quite a ways + * toward that end. A future version of this program may handle + * the multi-family case directly. + * + * If notes are done in-line, each NOTE is a new paragraph and blank + * lines mark paragraphs. If done as endnotes, the NOTES are indicated + * with ids in the form [id1, id2] and then a Notes page created to + * print all the notes. + * + * All main lines and the Generation lines are treated as headings and + * can be put into a table of contents. This is always done but the + * table is not inserted into the document. + * + * If a marriage would occur multiple times, it is only referred + * to and not duplicated after the first time. This is complicated + * by an indi having multiple marriages and the duplicated spouse + * also having multiple marriages with only one marriage in the duplicate + * tree. These are called out as well. + * + * I don't plan to implement the generation tags (superscript generation + * numbers) on individuals at this point. They are easy enough to do + * since the current generation is always known but I find them not + * particularly useful in the text. + * + * The program can take a long time since it manipulates a lot of data. + * Future versions may improve performance as better algorithms are + * found. + * + * An individual's occupation(s) should be output into the report + * but isn't currently done. This probably should be an option along + * with the specific format to use. + * + * A future version should replace all occurrences of English + * text with variable references to make translation easier. Mostly + * this is the label stuff (b., d., bur., children, etc.). There should + * also be an option to expand the abbreviations to the full word. + * + * At some point, information such as the various baptism, christening, + * and other event information will be included as well. This will + * most likely be done as hidden text of some form or perhaps as + * annotations. This will make the text available but it would have + * to be turned on in the document. + * + * Sources should eventually be turned into endnotes so Word can do + * any special processing. + */ +include("rtflib") +global(childby) +global(curr_index) +global(doindex) +global(donotes) +global(dosources) +global(endtags) +global(generation) +global(inum_set) +global(nextgen) +global(prev_fam_list) +global(strictness) +global(taglist) +global(titlepage) +global(all_sources) +global(occupation) + +proc main() +{ + /* program options */ + set(doindex, 1) /* set to zero if you don't want an index */ + set(prefix, "") /* string to prefix indi number with */ + set(donotes, 1) /* 0 = no notes, 1 = inline, 2 = end */ + set(dosources, 1) /* 0 = no sources, 1 = sources */ + set(childby, 1) /* 0 = all children, 1 = children by spouse */ + set(strictness, 0) /* all descendents, including female lines */ + set(occupation, 1) + set(author, "Author/Compiler Name") /* default author name */ + set(titlepage, 1) /* want a title page */ + + set(now, gettoday()) + dayformat(1) + monthformat(1) + dateformat(8) + set(created, stddate(now)) + + /* program proper */ + + /* initialize the variables used */ + + indiset(inum_set) /* this set keeps the family numbers */ + list(prev_fam_list) /* keeps track of marriages to avoid dups */ + list(generation) /* current generation being processed */ + list(nextgen) /* next generation to process */ + table(endtags) /* if notes at end, keep track of tags */ + list(taglist) /* the tags in order created */ + set(curr_index, 0) /* current index for indi/family */ + set(curr_gen, 0) /* current generation counter */ + set(indi,0) + list(all_sources) /* contains list of all sources referenced */ + + getindi(indi) + if (not(indi)) { + /* if no one selected, exit */ + return (0) + } + /* + * initialize the RTF file for standard paper (default) + */ + call rtf_open(0) + set(title, concat("Descendents of ", fullname(indi, 0, 1, 128))) + call rtf_set_info(title, name(indi), author, author, created) + /* + * define default table size of 6in with 4 columns of + * .125in, .375in, .375in, 5.125in + */ + call rtf_set_row_width(4, 8640) /* 6in * 1440 */ + call rtf_set_col_width(540) /* .45in * 1440 */ + call rtf_set_col_width(720) /* .500in * 1440 */ + call rtf_set_col_width(540) /* .45in * 1440 */ + /* want a footer with page number centered */ + call rtf_footer(0, 2) + if (dosources) { + /* if doing sources, what footnote type */ + call rtf_ftn_type(1, 0) /* everything at end */ + } + + /* add the first person to the list of people to process */ + /* this primes the pump, so to speak */ + call next_indi(indi) + enqueue(nextgen, indi) + if (titlepage) { + call dotitle(author, title) + } + + /* + * all is setup to go down the descendency list. + * continue until all are individuals are processed. + * note that nextgen is the next generation to process + * and generation is the current one. + * both are queues so we keep order. Basically, all + * children of the person being processed are appended + * to the end of the nextgen list. + */ + + while (or(length(generation), length(nextgen))) { + /* + * if no current generation but a nextgen exists, + * start a new paragraph with header for the Generation + * and make the nextgen the current generation + */ + if (empty(generation)) { + call rtf_para_indent(0, 0) + call rtf_pstart(1) + call rtf_para_keepnext() + call rtf_hstart() + set(curr_gen, add(curr_gen, 1)) + capitalize(ord(curr_gen)) + " Generation\n" + call rtf_hend() + call rtf_pend() + set(generation, nextgen) + list(nextgen) + } + /* + * the real work is done in out_register + * get the next person to process and then + * let out_register do the work. + */ + set(indi, dequeue(generation)) + call out_register(indi) + } + if (dosources) { + call dump_sources() + } + if (eq(donotes, 2)) { + /* end notes need to be dumped if they exist */ + call endnotes() + } + call rtf_close() +} + +/* + * out_register( indi ) + * outputs the standard register format for the + * individual. Any children get added to nextgen + * if they have families. Global variables are used + * to modify the exact output. + */ +proc out_register(indi) +{ + /* + * We always start a new paragraph with hanging indent for the number. + * It is then tagged to be kept intact to avoid splitting across pages. + * The indivual's number if found and printed and then the name + * is output followed by marriage(s), birth, death, etc. + */ + call rtf_pstart(3) + call rtf_para_indent(neg(540), 540) + call rtf_para_keepintact() + d(inum(indi)) "." + call rtf_tab(0) + call rtf_bold(1) + fullname(indi, 0, 1, 128) + /* the individual's name is entered as a level 2 TOC header */ + call rtf_toc_entry(2, fullname(indi, 0, 1, 128)) + call rtf_bold(0) + if (doindex) { + /* + * optional indexing, main entry is bold + * It would be nice to have index same text + * as the output name but the format is different. + * Need to find a better way to tie together so edit + * will do the right thing. + */ + rtf_index(surname(indi), givens(indi), 1) + } + /* + * it is important to not print duplicate marriages since in some + * families this can lead to excessive information. In my own, + * there were 5 children of one ancestor married 5 children of + * another ancestor. Over seven generations there have been + * additional crossings of the lines and a non-pruned tree is HUGE + * + * There are two types of pruning of this type that need to be + * considered. The first is the simple case of a single marriage + * that is duplicated. It can be handled with a simple reference + * to the first occurrence. The second type is more complex where + * there are multiple marriages. Some of the marriages may be + * duplicates and need to be pruned, but some may be ones that + * haven't been seen yet. This occurs when person A marries person B. + * The implication that B is married to A. If B is also married to C + * the multiple case occurs. In this case if B is seen as a child + * and the family info is about to be output, the marriage to A is + * a duplicate but the one to C is not. + */ + if (check_marriages(indi)) { + /* + * duplicate marriages (common ancestors) + * are not duplicated but referred to the only + * instance. If there were multiple marriages, + * then the duplicates can be referred to but the + * non-duplicate ones need expansion. + */ + call rtf_italic(1) + set(prev, prevmarr(indi)) + "(See marriage to " + set(f, getel(prev_fam_list, prev)) + if (male(indi)) { set(s, wife(f)) } + else { set(s, husband(f)) } + fullname(s, 0, 1, 128) + if (and(doindex, surname(s))) { + rtf_index(surname(s), givens(s), 2) + } + ", number " prefix d(inum(s)) ")" + call rtf_italic(0) + call rtf_para_space(0, 120) + call rtf_pend() + } else { + /* not a complete duplicate so generate lots of text */ + call rtf_para_keepnext() + if(e, birth(indi)) { + " b. " long(e) + if (dosources) { + call do_sources(e) + } + } + /* + * this is an attempt to track duplicate marriages. + * It needs to be looked at more carefully. + */ + set(nmarr, nfamilies(indi)) + /* + * run through all of this person's families + */ + families (indi, famvar, spvar, cnt) { + if (spvar) { + set(prev, check_prev(famvar)) + if (not(prev)) { + /* save for future reference */ + enqueue(prev_fam_list, famvar) + } + /* + * basic format of marriage is + * m. [date][[,] place] [(mnum)] spouse + * [b. [date][, place]] + * ([daughter|son] of spouse's parents) + * [d. [date][, place]] [bur. [date][, place]]. + */ + /* If first spouse, use a ';' but ',' for rest */ + if (eq(1, cnt)) { + "; m." + } elsif (ne(0, cnt)) { + ", m." + } + if (not(prev)) { + if (e, marriage(famvar)) { + " " long(e) + if (dosources) { + call do_sources(e) + } + "," + } + } + if (gt(nmarr, 1)) { + " (" d(cnt) ")" + } + if (not(prev)) { + " " fullname(spvar, 0, 1, 128) + if (and(doindex, surname(spvar))) { + rtf_index(surname(spvar), + givens(spvar), 2) + } + set(items, 0) + if (e, birth(spvar)) { + " b. " long(e) + if (dosources) { + call do_sources(e) + } + set(items, 1) + } + /* + * we know parents so give a referral. + * in a future version, this should be updated + * to determine if spouses had common ancestor + * and give the family number cross-reference. + * This would apply to my own genealogy. + */ + if (f, parents(spvar)) { + call rtf_italic(1) + if (male(spvar)) { + " (son of " + } else { + " (daughter of " + } + set(j, "") + if (f, father(spvar)) { + set(j, " and ") + fullname(f, 0, 1, 128) + } + if (f, mother(spvar)) { + j fullname(f, 0, 1, 128) + } + ")" + call rtf_italic(0) + + /* spouse's death info */ + if (e, death(spvar)) { + if (eq(items, 1)) { + ", d. " + } else { + " d. " + } + long(e) + if (dosources) { + call do_sources(e) + } + set(items, 1) + } + + /* spouse's burial info */ + if (e, burial(spvar)) { + if (eq(1, items)) { + ", bur. " + } else { + " bur. " + } + long(e) + if (dosources) { + call do_sources(e) + } + set(items, 1) + } + } + } else { + fullname(spvar, 0, 1, 128) + call rtf_italic(1) + " (see marriage to number " d(inum(spvar)) + ")" + call rtf_italic(0) + } + } + } + if (gt(cnt,0)) { + ".\n" + } + /* indi's remaining information */ + if (e, death(indi)) { + " " givens(indi) " died " long(e) + if (dosources) { + call do_sources(e) + } + if (e, burial(indi)) { + " and was buried " long(e) + if (dosources) { + call do_sources(e) + } + } + ".\n" + } elsif (e, burial(indi)) { + " " givens(indi) " was buried " long(e) + if (dosources) { + call do_sources(e) + } + ".\n" + } + /* + * all occupations are given if any are found. + */ + if (occupation) { + call do_occupation(indi) + } + /* if doing notes, make sure we get them now */ + if (donotes) { + call do_notes(indi, donotes, 0) + families(indi, famvar, spvar, cnt) { + if (spvar) { + call do_notes(spvar, donotes, 0) + } + } + } + /* + * now the children + * starting a table is a new paragraph. Keep it all together + * and put in a label cell in first row. Then dump + * each child into a row. + */ + call rtf_tstart(4) + call rtf_para_keepnext() + if (or(eq(nmarr, 1), not(childby))) { + call rtf_cstart() + call rtf_cstart() + call rtf_cstart() + call rtf_cstart() + " Children:" + call rtf_cend() + } + set(numchildren, 1) + set(tsize, totalchildren(indi)) + set(fcnt, 0) + families(indi, famvar, spvar, cnt) { + /* + * if childby is set, then put spouse info + * out to identify which family children + * came from. Skip families with no children + */ + if (and(childby, gt(nmarr, 1))) { + if (not(nchildren(famvar))) { + continue() + } + incr(fcnt) + if (gt(fcnt, 1)) { + call rtf_endrow() + call rtf_endrow() + } + call rtf_cstart() + call rtf_cstart() + call rtf_cstart() + call rtf_cstart() + " Children with " + fullname(spvar, 0, 1, 128) + ":" + call rtf_cend() + } + children (famvar, ch, num) { + /* want to know if this is someone to expand */ + set(ival, determine(ch, indi)) + call rtf_endrow() + if (lt(numchildren, tsize)) { + call rtf_para_keepnext() + } + /* note that nothing goes in cell 1 */ + call rtf_cstart() + /* start the cell where we do a number */ + call rtf_cstart() + call rtf_para_rightjust() + + /* if the indi is non-zero, then tag it */ + if (ne(ival, 0)) { + person_prefix d(ival) "." + } + + /* the roman numeral/child order cell */ + call rtf_cstart() + call rtf_para_rightjust() + roman(numchildren) "." + + /* the name and info cell */ + call rtf_cstart() + call rtf_para_leftjust() + fullname(ch, 0, 1, 128) + if (doindex) { + rtf_index(surname(ch), givens(ch), 0) + } + + /* we always give birth info */ + if (b, birth(ch)) { + if (gt(ival, 0)) { + if (strlen(date(b))) { + " b. " + date(b) + } + } else { + " b. " + long(b) + if (dosources) { + call do_sources(e) + } + } + } + + /* + * if a non-expanded indi, give more info + * such as death, marriages, etc. If + * expanded, don't since the full record + * will contain it. + */ + if (eq(ival, 0)) { + if (e, death(ch)) { + if (b) { "," } + " d. " long(e) + if (dosources) { + call do_sources(e) + } + } + set(nsp, nfamilies(ch)) + /* all known spouses */ + spouses(ch, sp, fm, cnt) { + "; m. " + if (gt(nsp, 1)) { + "(" d(cnt) ") " + } + if (e, marriage(fm)) { + long(e) + if (dosources) { + call do_sources(e) + } + ", " + } + fullname(sp, 0, 1, 128) + if (doindex) { + rtf_index(surname(sp), + givens(sp), 2) + } + } + ". " + if (donotes) { + call do_notes(ch, donotes, 1) + } + } else { + "." + } + call rtf_cend() + incr(numchildren) + } + } + call rtf_tend() + call rtf_pend() + } + call rtf_para_space(0, 0) +} + +/* + * next_indi(indi) + * find the next unique number for this individual + * the global curr_index keeps the current value + * the inum_set keeps track of the indi/number pairs + */ +proc next_indi(indi) +{ + set(curr_index, add(curr_index, 1)) + addtoset(inum_set, indi, curr_index) +} + +/* + * inum(indi) + * find the unique number for this indi + * if there is one it is in inum_set + * zero is returned if there isn't a mapping + */ +func inum(indi) +{ + forindiset(inum_set, indvar, inumval, cnt) { + if (eq(indvar, indi)) { + return (inumval) + } + } + return (0) +} + +/* + * find_fam(indi, spouse) + * find the family (fam) indi and spouse create + */ +func find_fam(indi, sps) +{ + spouses (indi, s, f, c) { + if (eq(sps, s)) { + return (f) + } + } +} + +/* + * check_marriages(indi) + * check to see if an individual has any marriages and return + * the inum of the first spouse that has one + */ +func check_marriages(indi) +{ + set(res, 0) + set(notyet, 0) + families (indi, f, s, c) { + if (x, check_prev(f)) { + incr(res) + } else { + incr(notyet) + } + } + if (and(res, not(notyet))) { + return (1) + } else { + return (0) + } +} + +/* + * check_prev(fam) + * check to see if a previous marriage and return non-zero + * if there was one and zero if none. + */ +func check_prev(fam) +{ + forlist(prev_fam_list, f, cnt) { + if (eq(fam, f)) { + return (cnt) + } + } + return (0) +} + +/* + * determine(indi, par) + * determine if the indi is one to expand. + * The par is the parent descended from so that + * female lines can be skipped if strictness is + * set. + */ +func determine(indi, par) +{ + if (and(eq(strictness, 2), female(indi))) { + /* strictest form doesn't follow female lines */ + return (0) + } + if (and(eq(strictness, 1), female(par))) { + /* modified form gives one generation from a female line */ + return (0) + } + set(nchil, 0) + families (indi, fm, sp, cnt) { + set(nchil, add(nchil, nchildren(fm))) + } + if (gt(nchil, 0)) { + enqueue(nextgen, indi) + call next_indi(indi) + return (inum(indi)) + } + return (0) +} + +/* + * do_notes(indi, where, type) + * where is inline vs. end + * type is in or out of table + */ +proc do_notes(indi, where, type) +{ + /* where == 1 is inline */ + if (eq(where, 1)) { + set(didpara, 0) + set(innote, 0) + set(root, inode(indi)) + traverse(root, node, level) { + if (and(innote, le(level, innote))) { + set(innote, 0) + } + if (eqstr(tag(node), "NOTE")) { + if (not(type)) { + call rtf_pstart(3) + } else { + call rtf_cpar() + } + set(innote, level) + call fixstring(value(node)) + set(didpara, 1) + } elsif (eqstr(tag(node), "CONT")) { + if (innote) { + if (eq(0, strlen(value(node)))) { + if (not(type)) { + call rtf_pstart(3) + } else { + call rtf_cpar() + } + } else { + " \n" + call fixstring(value(node)) + } + } + } + } + } elsif (eq(where, 2)) { /* where == 2 is at end */ + set(found, 0) + set(tagprefix, 0) + set(root, inode(indi)) + traverse(root, node, level) { + if (eqstr(tag(node), "NOTE")) { + if (not(found)) { + " [" + } else { + ", " + } + incr(found) + if (not(tagprefix)) { + set(tagprefix, tagname(indi)) + } + tagprefix d(found) + } + } + if (found) { + "]" + } + } +} + +/* + * fixstring(str) + * fix the string to not break RTF output + * Any {, }, or \ characters must be escaped. + * Then output the string + */ +proc fixstring(str) +{ + if (i, index(str, "{", 1)) { + call fixstring(substring(str, 1, i)) + "\\{" + incr(i) + call fixstring(substring(str, i, sub(strlen(str), i))) + } elsif (i, index(str, "}", 1)) { + call fixstring(substring(str, 1, i)) + "\\}" + incr(i) + call fixstring(substring(str, i, sub(strlen(str), i))) + } elsif (i, index(str, "\\", 1)) { + call fixstring(substring(str, 1, i)) + "\\\\" + incr(i) + call fixstring(substring(str, i, sub(strlen(str), i))) + } else { + str + } +} + +/* + * prevmarr(indi) + * determine if an indi had a previously output marriage. + */ +func prevmarr(indi) +{ + spouses (indi, s, f, c) { + forlist (prev_fam_list, fm, cnt) { + if (eq(f, fm)) { + return (cnt) + } + } + } + return (0) +} + +/* + * dotitle(author, title) + */ +proc dotitle(author, title) +{ + "\\titlepg" + "\\pvmrg\\posy2880\\qc\\fs48 " + title + "\\line\\line " + "\\fs32 by\\line " + author + "\\par\\sect\\pgnrestart\n" +} + +/* + * tagname(indi) + * from an indi, create a unique tag to use for notes references + * for endnote form. + */ +func tagname(indi) +{ + list(parts) + /* + * the algorithm is: + * first 3 letters of surname + * first letter of first and any middle name + * if conflict, try adding "a", "b", etc. until unique. + */ + extractnames(inode(indi), parts, nparts, surpart) + set(surnm, substring(getel(parts, surpart), 1, 3)) + set(firstp, substring(getel(parts, 1), 1, 1)) + if (gt(nparts, 2)) { + set(midp, substring(getel(parts, 2), 1, 1)) + if (not(strcmp(midp, "\""))) { + set(midp, substring(midp, 2, 2)) + } + } else { + set(midp, "") + } + set(tagvar, concat(surnm, firstp, midp)) + set(suffix, "") + set(v, 0) + while (lookup(endtags, concat(tagvar, suffix))) { + incr(v) + set(suffix, substring("abcdefghijklmnopqrstuvwxyz", + v, v)) + } + insert(endtags, tagvar, indi) + call sorttag(tagvar) + set(tagvar, concat(tagvar, suffix)) + return (tagvar) +} + +/* + * sorttag(str) + * do an insertion sort of str into the taglist list of notes + */ +proc sorttag(str) +{ + list(tmp) + set(done, 0) + set(any, 0) + while (l, dequeue(taglist)) { + set(any, 1) + if (not(done)) { + set(r, strcmp(str, l)) + if (le(r, 0)) { + set(done, 1) + enqueue(tmp, str) + } + if (ne(r, 0)) { + enqueue(tmp, l) + } + } else { + enqueue(tmp, l) + } + } + + if (or(not(any), not(done))) { + enqueue(tmp, str) + set(any, 1) + } + + /* set to null so we can copy the new list */ + list(taglist) + if (any) { + while (l, dequeue(tmp)) { + enqueue(taglist, l) + } + } +} + +/* + * endnotes() + * at end, dump the endnotes in a reasonable format + */ +proc endnotes() +{ + call rtf_newpage() + call rtf_para_indent(0, 0) + call rtf_pstart(1) + call rtf_hstart() + "Notes" + call rtf_hend() + call rtf_pend() + while (l, dequeue(taglist)) { + set(indi, lookup(endtags, l)) + if (indi) { + call dumpnote(indi, l) + } + } +} + +/* + * dumpnote(indi, tagstr) + * dump the notes for this indi, using tagstr as the prefix + */ +proc dumpnote(indi, tagstr) +{ + set(didpara, 0) + set(innote, 0) + set(root, inode(indi)) + set(which, 0) + traverse(root, node, level) { + if (and(innote, le(level, innote))) { + set(innote, 0) + } + if (nestr(tag(node), "NOTE")) { + call rtf_pstart(3) + call rtf_para_indent(neg(1440), 1440) + incr(which) + set(innote, level) + tagstr d(which) + rtf_tab(0) + value(node) + set(didpara, 1) + } elsif (nestr(tag(node), "CONT")) { + if (innote) { + if (eq(0, strlen(value(node)))) { + call rtf_pstart(3) + } else { + " \n" value(node) + } + } + } + } +} + +/* + * totalchildren(indi) + * count all the children this indi had + */ +func totalchildren(indi) +{ + set(total, 0) + families (indi, fam, sp, cnt) { + set(total, add(total, nchildren(fam))) + } + return (total) +} + +/* + * do_sources(e) + * find all the sources associated with the event + * and create the footnote reference. If dosources is + * greater than 1, just gather the footnotes to stick at + * the end of family rather than in-line for each event + * {mode 2 not implemented yet} + */ +proc do_sources(e) +{ + set(evlist, sources(e)) + list(taglist) + while (s, dequeue(evlist)) { + set(srcvar, fmt_source(s)) + set(taglist, source_process(srcvar)) + } + if (not(empty(taglist))) { + call rtf_super(1) + set(pre, "") + forlist(taglist, var, cnt) { + pre d(var) + set(pre, ", ") + } + call rtf_super(0) + } +} + +/* + * fmt_source(s) + * for a source node, traverse it and put into a normalized + * reference/footnote format. New forms should be added as + * necessary since there are lots of possibilities. + */ +func fmt_source(s) +{ + set(prefix, "") + set(cont, "") + set(result, "") + set(title,0) + set(sour, 0) + set(dt, 0) + set(text, 0) + set(publ, 0) + set(page, 0) + traverse (s, node, l) { + if (gt(l, 2)) { + continue() + } + if (reference(value(node))) { + set(indresult, fmt_source(dereference(value(node)))) + } else { + if (eq(l, 0)) { + continue() + } elsif (eqstr(tag(node), "SOUR")) { + set(sour, text_node(node)) + } elsif (eqstr(tag(node), "TEXT")) { + set(text, text_node(node)) + } elsif (eqstr(tag(node), "DATE")) { + set(dt, date(node)) + } elsif (eqstr(tag(node), "TITL")) { + set(title, text_node(node)) + } elsif (eqstr(tag(node), "PAGE")) { + set(page, concat("page ", value(node))) + } + } + } + set(result, "") + if (indresult) { + set(result, indresult) + set(prefix, ", ") + } + if (title) { + set(result, concat(result, prefix, title)) + set(prefix, ", ") + } + if (sour) { + set(result, concat(result, prefix, sour)) + set(prefix, ", ") + } + if (dt) { + set(result, concat(result, prefix, dt)) + set(prefix, ", ") + } + if (text) { + set(result, concat(result, prefix, text)) + set(prefix, ", ") + } + if (publ) { + set(result, concat(result, prefix, publ)) + set(prefix, ", ") + } + if (page) { + set(result, concat(result, prefix, page)) + set(prefix, ", ") + } + return (result) +} + +/* + * sources(e) + * for an event, look for all source nodes and make a list + * to return. + */ +func sources(ev) +{ + list(evs) + if (not(ev)) { + return (evs) + } + set(cnt, 0) + traverse(ev, node, lev) { + if (eqstr(tag(node), "SOUR")) { + enqueue(evs, node) + incr(cnt) + } + } + return (evs) +} + +/* + * source_process(src) + * look for the string src in the list of known sources + * if it exists, use that index. If it doesn't add to list + * and use the new index. Then remove duplicate entries + * and ultimately return the list of uniqe references. + */ +func source_process(src) +{ + list(taglist) + set(found,0) + forlist(all_sources, str, cnt) { + if (eqstr(str, src)) { + set(found, cnt) + break() + } + } + if (not(found)) { + enqueue(all_sources, src) + incr(cnt) + set(taglist, addtolist(taglist, cnt)) + } else { + set(taglist, addtolist(taglist, found)) + } + return (taglist) +} + +/* + * addtolist(lst, num) + * add the value "num" to the list "lst" if + * it isn't already there. + */ +func addtolist(lst, num) +{ + set(found, 0) + list(newlist) + forlist(lst, val, cnt) { + if (not(found)) { + if (eq(val, num)) { + return (lst) /* no change - a dup */ + } elsif (gt(val, num)) { + set(found, 1) + enqueue(newlist, num) + enqueue(newlist, val) + } + } else { + enqueue(newlist, val) + } + } + if (not(found)) { + enqueue(newlist, num) + } + return (newlist) +} +/* + * dump_sources() + * dump the entire list of reference sources with proper tags. + */ +proc dump_sources() +{ + if (not(empty(all_sources))) { + call rtf_pend() + call rtf_newpage() + call rtf_para_indent(0, 0) + call rtf_pstart(1) + call rtf_hstart() + "References" + call rtf_hend() + call rtf_pend() + forlist(all_sources, src, num) { + call rtf_pstart(3) + call rtf_para_indent(neg(540), 540) + d(num) + call rtf_tab(0) + src + call rtf_pend() + } + } +} + +/* + * text_node(node) + * convert a text type node (TEXT or SOUR) into a long + * string with CONT entries separated by space. + */ +func text_node(node) +{ + set(result, "") + set(prefix, "") + traverse(node, n, l) { + set(result, concat(result, prefix, value(n))) + set(prefix, " ") + } + return (result) +} + +/* + * do_occupation(ind) + * print out occupation(s) of the individual in + * a meaningful form. + */ +proc do_occupation(indi) +{ + list(occu) + set(count, 0) + traverse (inode(indi), node, lev) { + if (eqstr(tag(node), "OCCU")) { + /* have an occupation */ + enqueue(occu, value(node)) + incr(count) + } + } + if (not(empty(occu))) { + " " + pn(indi, 0) + " was a " + set(sep, "") + forlist(occu, item, cnt) { + item sep + if (eq(count, add(cnt, 1))) { + set(sep, ", and ") + } else { + set(sep, ", ") + } + } + ". " + } +} diff --git a/reports/register-tex.ll b/reports/register-tex.ll new file mode 100644 index 0000000..57b5047 --- /dev/null +++ b/reports/register-tex.ll @@ -0,0 +1,603 @@ +/* + * @progname register-tex.ll + * @version 2.1 of 2004-06-18 + * @author Wetmore, David Olsen (dko@cs.wisc.edu), Simms + * @category + * @output LaTeX + * @description + * + * This report prints, in book format, information about all descendants of a + * person and all of their spouses. It tries to understand as many different + * GEDCOM tags as possible. All source iformation (SOUR lines) is in the + * footnotes. + * The output is in LaTeX format. + * +** +** Version 2.1 18 Jun 2004 (Robert Simms) +** Version 2 24 Feb 1993 +** Version 1 Nov 1992 +** +** Requires LifeLines version 2.3.3 or later +** +** +** Robert Simms (rsimms@ces.clemson.edu) +** Render characters meaningful to the LaTeX system as if they were ordinary characters. +** +** David Olsen (dko@cs.wisc.edu) +** based on work originally done by Tom Wetmore (ttw@cbnews1.att.com). +** +** This report prints, in book format, information about all descendants of a +** person and all of their spouses. It tries to understand as many different +** GEDCOM tags as possible. All source iformation (SOUR lines) is in the +** footnotes. +** +** The output is in LaTeX format. Therefore, the name of the output file +** should end in ".tex". To print (assuming the name of the output file is +** "out.tex"): +** latex out < ignore lots of warnings about underfull \hboxes > +** dvips out +** lpr out.ps +** +** Indexing commands are placed within the LaTeX output. To include an index +** in the document do the following: +** latex out +** makeindex out < not all systems have makeindex available> +** < edit out.tex, uncomment (remove leading '%') from +** the line \input{out.ind} just before \end{document} > +** latex out +** dvips out +** lpr out.ps +** < the last three commands here may be replaced by > +** pdflatex out -- if you have 'pdflatex' and a PDF is +** the desired final product > +** +** I admit that this is lot of post-processing, but the results are worth it. +** +** NOTE ON PAPER SIZES: +** Paper sizes (A4 or letter) can be specified within the LaTeX output, +** but this requires editing by folks who don't like the default. +** +** Since dvips (a neccessary processing step) can take a paper-size +** argument on the command line, it's much simpler to let the user +** specify the desired page size when running dvips (outlined above) +** instead of editing the report/LaTeX output. +** +** Example: +** dvips -t letter out [ for US Letter-sized paper, 8.5x11" ] +** dvips -t a4 out [ for ISO/European A4-sized paper, 8.3x11.7" ] +** +*/ + +global(opt_xlat) +global(tex_xlat) + +proc main () +{ + getindi(indi) /* Get the individual to start with */ + + /* Print preamble. Feel free to change this to suit your tastes. */ + "\\documentstyle[twocolumn]{article}\n" + "\\usepackage{isolatin1}\n\n" + "\\pagestyle{myheadings}\n\n" + "% Shrink the margins to use more of the page.\n" + "% This is taken from fullpage.sty, which is on some systems.\n" + "\\topmargin 0pt\n" + "\\advance \\topmargin by -\\headheight\n" + "\\advance \\topmargin by -\\headsep\n" + "\\textheight 8.9in\n" + "\\oddsidemargin 0pt\n" + "\\evensidemargin \\oddsidemargin\n" + "\\textwidth 6.5in\n\n" + "\\newcounter{childnumber}\n\n" + "% The \\noname command is needed because TeX doesnt like underscores.\n" + "\\newcommand{\\noname}{\\underline{\\ \\ \\ \\ \\ }}\n\n" + "% Environment for printing the list of children.\n" + "\\newenvironment{childrenlist}" + "{\\begin{small}\\begin{list}{\\sc\\roman{childnumber}.}" + "{\\usecounter{childnumber}\\setlength{\\leftmargin}{0.5in}" + "\\setlength{\\labelsep}{0.07in}\\setlength{\\labelwidth}{0.43in}}}" + "{\\end{list}\\end{small}}\n\n" + "% The following commands are used to create the index.\n" + "\\newcommand{\\bold}[1]{{\\bf #1}}\n" + "\\newcommand{\\bfit}[1]{{\\bf\\it #1}}\n" + "\\newcommand{\\see}[2]{{\\it see #1}}\n\n" + "% Command to use at the beginning of each new generation.\n" + "\\newcommand{\\generation}[1]" + "{\\newpage\\begin{center}{\\huge\\bf Generation #1}\\end{center}" + "\\vspace{3ex}\\setcounter{footnote}{0}" + "\\markright{Descendants of " strxlat(tex_xlat, fullname(indi,0,1,40)) + "\\hfill Generation #1\\hfill\\ }}\n\n" + "\\makeindex\n\n" + "\\begin{document}\n\n" + "\\title{Descendants of " strxlat(tex_xlat, fullname(indi, 0, 1, 40)) "}\n" + + getstrmsg(author, "Enter the author(s) of this document:") + "\\author{" strxlat(tex_xlat, author) "}\n" + "\\date{\\today}\n" + "\\maketitle\n" + + getstrmsg(intro, "File that contains introduction (if any):") + if (ne(strcmp(intro, ""), 0)) { + "\\input{" intro "}\n" + } + + + list(ilist) /* List of individuals */ + list(glist) /* List of generation for each individual */ + table(stab) /* Table of numbers for each individual */ + indiset(idex) + + /* LaTeX interprets $, &, %, #, _, {, }, ~, ^, and \ as special characters. + A table is loaded here with the alternatives to make those special + characters appear in the final product. Any text from the database + sent to the LaTeX file to appear as text should be passed through + the function strxlat(). + */ + set(opt_xlat, 1) + table(tex_xlat) + insert(tex_xlat, "$", "\\$") + insert(tex_xlat, "&", "\\&") + insert(tex_xlat, "%", "\\%") + insert(tex_xlat, "#", "\\#") + insert(tex_xlat, "_", "\\_") + insert(tex_xlat, "{", "\\{") + insert(tex_xlat, "}", "\\}") + insert(tex_xlat, "~", "\\verb|~|") + insert(tex_xlat, "^", "\\verb|^|") + insert(tex_xlat, "\\", "\\verb|\\|") + + + enqueue(ilist, indi) + enqueue(glist, 1) + set(curgen, 0) + set(out, 1) + set(in, 2) + + while (indi, dequeue(ilist)) { + + set(thisgen, dequeue(glist)) + if (ne(curgen, thisgen)) { + print("Generation ") print(d(thisgen)) print("\n") + "\n\n\\generation{" d(thisgen) "}\n" + set(curgen, thisgen) + } + + print(d(out)) print(" ") print(name(indi)) print("\n") + + "\n\\vspace{3ex}\\ \\\\\\begin{center}{\\large\\bf " d(out) ".\\ " + name(indi) "}\\end{center}\n" + + insert(stab, save(key(indi)), out) + + call longvitals(indi, 1, 2) + + addtoset(idex, indi, 0) + set(out, add(out, 1)) + + families(indi, fam, spouse, nfam) { + "\n\n" + if (eq(0, nchildren(fam))) { + call texname(inode(indi), 0) "\\ and " + if (spouse) { + call texname(inode(spouse), 0) + } else { + "\\noname" + } + "\\ had no children.\n" + } elsif (and(spouse, lookup(stab, key(spouse)))) { + "Children of " call texname(inode(indi), 0) "\\ and " + call texname(inode(spouse), 0) "\\ are shown under " + call texname(inode(spouse), 0) + "\\ (" d(lookup(stab, key(spouse))) ").\n" + } else { + "Children of " call texname(inode(indi), 0) "\\ and " + if (spouse) { + call texname(inode(spouse), 0) + } else { + "\\noname" + } + ":\n\\begin{childrenlist}\n" + children(fam, child, nchl) { + set(haschild, 0) + families(child, cfam, cspou, ncf) { + if (ne(0, nchildren(cfam))) { set(haschild, 1) } + } + if (haschild) { + enqueue(ilist, child) + enqueue(glist, add(1, curgen)) + "\n\\item[{\\bf " d(in) "}\\ \\hfill" + "\\addtocounter{childnumber}{1}" + "{\\sc\\roman{childnumber}}.]" + set (in, add (in, 1)) + call shortvitals(child) + } else { + "\n\\item " + call longvitals(child, 0, 1) + addtoset(idex, child, 0) + } + } + "\\end{childrenlist}\n" + } + } + } + + set(basename, + save(substring(outfile(), 1, sub(index(outfile(), ".tex", 1), 1)))) + + "\n% remove percent-sign at the beginning of the line\n" + "% with the input command if you create the index file\n" + "% using 'makeindex'\n" + "% \\input{" basename ".ind}" + "\n\n\\end{document}\n" +} + + +/* shortvitals(indi): Displays the short form of the vital statistics (birth + and death only) of an individual. */ + +proc shortvitals(indi) +{ + call texname(inode(indi), 1) + set(b, birth(indi)) + set(d, death(indi)) + if (and(b, long(b))) { ", b.\\ " strxlat(tex_xlat, long(b)) } + if (and(d, long(d))) { ", d.\\ " strxlat(tex_xlat, long(d)) } + "\n" +} + + +/* longvitals(i, name_parents, name_type) + Prints out the complete vital statistics of the individual (i). If + name_parents is not 0, then the names of the parents of the individual will + be printed. The parameter name_type is passed to texname. The GEDCOM tags + are divided into ones that would likely occur before getting married and + ones that would likely occur after getting married. Within the two sets + they are printed in the order in which they appear in the database. I + haven't yet figured out a convenient way of indicating the sex. */ + +proc longvitals(i, name_parents, name_type) +{ + call texname(inode(i), name_type) "." call print_sources(inode(i)) "\n" + + set(dad, father(i)) + set(mom, mother(i)) + if (and(name_parents, or(dad, mom))) { + if ( male(i)) { "Son of " } + elsif (female(i)) { "Daughter of " } + else { "Child of " } + if (dad) { call texname(inode(dad), 0) } + if (and(dad, mom)) { "\nand " } + if (mom) { call texname(inode(mom), 0) } + ".\n" + } + + set(name_found, 0) + fornodes (inode(i), n) { + if (eq(strcmp(tag(n), "ADOP"), 0)) { + call process_event(n, "Adopted") + } + if (eq(strcmp(tag(n), "BAPL"), 0)) { + call process_event(n, "Baptized") + } + if (eq(strcmp(tag(n), "BAPM"), 0)) { + call process_event(n, "Baptized") + } + if (eq(strcmp(tag(n), "BARM"), 0)) { + call process_event(n, "Bar mitzvah") + } + if (eq(strcmp(tag(n), "BASM"), 0)) { + call process_event(n, "Bat mitzvah") + } + if (eq(strcmp(tag(n), "BIRT"), 0)) { + call process_event(n, "Born") + } + if (eq(strcmp(tag(n), "BLES"), 0)) { + call process_event(n, "Blessed") + } + if (eq(strcmp(tag(n), "CAST"), 0)) { + "Caste: " call valuec(n) "." + call print_sources(n) "\n" + } + if (eq(strcmp(tag(n), "CHR"), 0)) { + call process_event(n, "Christened") + } + if (eq(strcmp(tag(n), "CONF"), 0)) { + call process_event(n, "Confirmed") + } + if (eq(strcmp(tag(n), "CONL"), 0)) { + call process_event(n, "Confirmed") + } + if (eq(strcmp(tag(n), "GRAD"), 0)) { + call process_event(n, "Graduated") + } + if (eq(strcmp(tag(n), "NAME"), 0)) { + if (eq(name_found, 0)) { + set(name_found, 1) + } else { + "Also known as " call texname(n, 3) "." + call print_sources(n) "\n" + } + } + if (eq(strcmp(tag(n), "NAMR"), 0)) { + "Religious name: " call valuec(n) "." + call print_sources(n) "\n" + } + if (eq(strcmp(tag(n), "NATI"), 0)) { + "Nationality: " call valuec(n) "." + call print_sources(n) "\n" + } + if (eq(strcmp(tag(n), "ORDN"), 0)) { + call process_event(n, "Ordained") + } + if (eq(strcmp(tag(n), "RELI"), 0)) { + "Religious affiliation: " call valuec(n) "." + call print_sources(n) "\n" + } + if (eq(strcmp(tag(n), "TITL"), 0)) { + "Title: " value(n) "." + call print_sources(n) "\n" + } + } + if (eq(1, nfamilies(i))) { + families(i, f, s, n) { + "Married" call print_sources(fnode(f)) + call spousevitals(s, f) + } + } else { + families(i, f, s, n) { + "Married " ord(n) "," call print_sources(fnode(f)) + call spousevitals(s, f) + } + } + fornodes (inode(i), n) { + if (eq(strcmp(tag(n), "BURI"), 0)) { + call process_event(n, "Buried") + } + if (eq(strcmp(tag(n), "CENS"), 0)) { + call process_event(n, "Listed in census") + } + if (eq(strcmp(tag(n), "CHRA"), 0)) { + call process_event(n, "Christened (as an adult)") + } + if (eq(strcmp(tag(n), "DEAT"), 0)) { + call process_event(n, "Died") + } + /* One part of the GEDCOM standard says the tag should be DSCR, + another part says DESR. */ + if (eq(strcmp(tag(n), "DESR"), 0)) { + "Description: " call valuec(n) + call print_sources(n) "\n" + } + if (eq(strcmp(tag(n), "EVEN"), 0)) { + call process_event(n, value(n)) + } + if (eq(strcmp(tag(n), "NATU"), 0)) { + call process_event(n, "Naturalized") + } + if (eq(strcmp(tag(n), "OCCU"), 0)) { + "Occupation: " call valuec(n) "." + call print_sources(n) "\n" + } + if (eq(strcmp(tag(n), "PROB"), 0)) { + call process_event(n, "Will probated") + } + if (eq(strcmp(tag(n), "PROP"), 0)) { + "Possessions: " call valuec(n) "." + call print_sources(n) "\n" + } + if (eq(strcmp(tag(n), "RETI"), 0)) { + call process_event(n, "Retired") + } + if (eq(strcmp(tag(n), "WILL"), 0)) { + call process_event(n, "Will dated") + } + } + call print_notes(inode(i), "\n\n") +} + + +/* spousevitals (spouse, fam) + Prints out information about a marriage (fam) and about a spouse in the + marriage (spouse). */ + +proc spousevitals (spouse, fam) +{ + if (e, marriage(fam)) { + call print_event(e) "," call print_sources(e) " " + } + "\n" + if (spouse) { + call texname(inode(spouse), 3) + call print_sources(inode(spouse)) + set(bir, birth(spouse)) + set(chr, baptism(spouse)) + set(dea, death(spouse)) + set(bur, burial(spouse)) + set(dad, father(spouse)) + set(mom, mother(spouse)) + if (or(bir, chr, dea, bur, mom, dad)) { + "\n(" + if (bir) { + "born" call print_event(bir) + if (or(dea, bur, mom, dad)) { "," } + call print_sources(bir) + if (or(dea, bur, mom, dad)) { "\n" } + } + if (and(chr, not(bir))) { + "christened" call print_event(chr) + if (or(dea, bur, mom, dad)) { "," } + call print_sources(chr) + if (or(dea, bur, mom, dad)) { "\n" } + } + if (dea) { + "died" call print_event(dea) + if (or(mom, dad)) { "," } + call print_sources(dea) + if (or(mom, dad)) { "\n" } + } + if (and(bur, not(dea))) { + "buried" call print_event(bur) + if (or(mom, dad)) { "," } + call print_sources(bur) + if (or(mom, dad)) { "\n" } + } + if (or(mom, dad)) { + if ( male(spouse)) { "son of " } + elsif (female(spouse)) { "daughter of " } + else { "child of " } + if (dad) { call texname(inode(dad), 3) } + if (and(mom, dad)) { " and " } + if (mom) { call texname(inode(mom), 3) } + } + ")" + } + } else { + "\\noname" + } + ".\n" +} + + +/* texname (i, type) + Prints an individual's name in LaTeX format, with the surname in small caps. + For example, "David Kenneth /Olsen/ Jr." would be printed as + "David Kenneth {\sc Olsen} Jr.". The type argument determines how the name + will appear in the index. + type = 0: no index + type = 1: page number appears in bold + type = 2: page number appears in bold-italics + type = 3: page number appears in normal text + The parameter i can be either an INDI node (NOT an individial) or a + NAME node. */ + +proc texname (i, type) +{ + list(name_list) + + set(sname, "") + extractnames(i, name_list, num_names, surname_no) + forlist (name_list, nm, num) { + if (eq(num, surname_no)) { + if (eq(strcmp(nm, ""), 0)) { + " \\noname" + set(sname, "\\noname") + } else { + " {\\sc " strxlat(tex_xlat, save(nm)) "}" + set(sname, nm) + } + } else { + " " strxlat(tex_xlat, nm) + } + } + if (gt(type, 0)) { + "\\index{" strxlat(tex_xlat, sname) + if (gt(num_names, 1)) { "," } + forlist (name_list, nm, num) { + if (ne(num, surname_no)) { + " " strxlat(tex_xlat, nm) + } + } + if (eq(type, 1)) { "|bold"} + elsif (eq(type, 2)) { "|bfit"} + "}" + } +} + + +/* process_event (event_node, event_name) + Prints information about a particular event (event_node, which is a GEDCOM + node). event_name is verb form of the text describing the event (such as + "Born", "Died", etc.). */ + +proc process_event (event_node, event_name) +{ + event_name + call print_event(event_node) "." + call print_sources(event_node) + call print_notes(event_node, " ") "\n" +} + + +/* print_event (event_node): Prints the date and place of an event. */ + +proc print_event (event_node) +{ + if (date(event_node)) { " " strxlat(tex_xlat, date(event_node)) } + if (place(event_node)) { " at " strxlat(tex_xlat, place(event_node)) } +} + + +/* print_notes (root, sep): Prints all the notes (NOTE nodes) associated with + the GEDCOM line root, separated by the given separator. */ + +proc print_notes (root, sep) +{ + fornotes (root, note) { + sep strxlat(tex_xlat, note) " " + } +} + + +/* print_sources (root) + Prints all sources (SOUR lines) associated with the given GEDCOM line. The + sources are formated as LaTeX footnotes. This routine prints each SOUR line + as a separate footnote, which is not correct. This should be corrected so + that all sources are combined into a single footnote. */ + +proc print_sources (root) +{ + fornodes (root, n) { + if (eq(strcmp(tag(n), "SOUR"), 0)) { + "\\footnote{" call valuec(n) "}" + } + } +} + + +/* valuec(n): Prints the value of a GEDCOM node and the values of any CONT + lines associated with it. */ + +proc valuec(n) +{ + value(n) + fornodes (n, n1) { + if (eq(strcmp(tag(n1), "CONT"), 0)) { + "\n" strxlat(tex_xlat, value(n1)) + } + } +} + + +/* +** function: strxlat +** +** This idea was copied and/or adapted from Jim Eggert's modification +** to the ps-circ(le) program for LifeLines. +** A typical call would look like: +** set(str, strxlat(tex_xlat, name(person))) +** which would translate characters in person's name according to the +** table called tex_xlat -- which escapes the special characters being +** displayed as text via LaTeX. The output is assigned to str. +** The output of strxlat() can also be sent directly to output. +** +*/ + +func strxlat(xlat, string) +{ + if(opt_xlat) { + set(fixstring, "") + set(pos, 1) + while(le(pos, strlen(string))) { + set(char, substring(string, pos, pos)) + if(special, lookup(xlat, char)) { + set(fixstring, concat(fixstring, special)) + } else { + set(fixstring, concat(fixstring, char)) + } + incr(pos) + } + } else { + set(fixstring, string) + } + return(save(fixstring)) /* save() is for compatibilty with older LL */ +} diff --git a/reports/register1-dot.ll b/reports/register1-dot.ll new file mode 100644 index 0000000..219c6f5 --- /dev/null +++ b/reports/register1-dot.ll @@ -0,0 +1,111 @@ +/* + * @progname register1-dot + * @version 1.0 (14-May-2004) + * @author Marc Nozell (marc@nozell.com) + * @category + * @output dot format + * @description Use graphviz's dot to product multipage + * directed graphs of descendants. + * + * (dot is available from www.graphviz.com) + * $ dot -Tps -ofamily.ps family.dot + */ + + +proc main () +{ + getindi(indi) + list(ilist) + list(glist) + table(stab) + indiset(idex) + enqueue(ilist,indi) + enqueue(glist,1) + set(curgen,0) set(out,1) set(in,2) + + "digraph \"nozell family\" {" nl() + "ranksep=.75; "nl() + "page = \"8,5\";"nl() +/* + "size = \"10.5,8\";"nl() +*/ +/* If you want landscape mode. + "rotate = 90;"nl() +*/ + "\"" key(indi) "\" [label=\"" name(indi) "\"];" nl() + while (indi,dequeue(ilist)) { + print("OUT: ") print(d(out)) + print("# ") print(name(indi)) print(nl()) + set(thisgen,dequeue(glist)) + + insert(stab,save(key(indi)),out) + + addtoset(idex,indi,0) + set(out,add(out,1)) + + families(indi,fam,spouse,nfam) { + + if (spouse) { set(sname, save(name(spouse))) set (spousekey, save(key(spouse))) } + else { set(sname, "_____") set (spousekey, "IUNKNOWN") } + + if (eq(0,nchildren(fam))) { + nl() + } + elsif (and(spouse,lookup(stab,key(spouse)))) { + nl() + } + else { + "#Children of " name(indi) " and " sname":" nl() + + if (male(spouse)) { set(spousesexstyle, " ,shape=box,color=slateblue1 ") } + elsif (female(spouse)) { set(spousesexstyle, " ,shape=diamond,color=pink ")} + else { set(spousesexstyle, " ,shape=hexagon,color=yellow ") } + + + /* define the spouse... */ + "\"" spousekey "\" [label=\"" sname "\"" spousesexstyle "];" nl() + + /* Show the marriage by a different + arrow type, a higher weight and set + them at the same level */ + + "\"" key(indi) "\" -> \"" spousekey "\" [weight=10, arrowhead=dot, arrowtail=dot];" nl() + "\"" spousekey "\" -> \"" key(indi) "\" [weight=10, arrowhead=dot, arrowtail=dot];" nl() + + "{ rank = same; " key(indi) "; " spousekey "; }" nl() + + children(fam,child,nchl) { + set(haschild,0) + families(child,cfam,cspou,ncf) { + if (ne(0,nchildren(cfam))) { set(haschild,1) } + } + + if (male(child)) { set(sexstyle, " ,shape=box,color=slateblue1 ") } + elsif (female(child)) { set(sexstyle, " ,shape=diamond,color=pink ")} + else { set(sexstyle, " ,shape=hexagon,color=yellow ") } + + + /* define the child and their relationship to the parents */ + + "# KEYDEF \"" key(child) "\" [label=\"" name(child) "\"" sexstyle "];" nl() + "\"" key(child) "\" [label=\"" name(child) "\" sexstyle];" nl() + "\"" key(indi) "\"" " -> " "\"" key(child) "\";" nl() + "\"" spousekey "\"" " -> " "\"" key(child) "\";" nl() + + if (haschild) { + print("IN: ") print(d(in)) + print(" ") print(name(child)) print(nl()) + enqueue(ilist,child) + enqueue(glist,add(1,curgen)) + } + else { + addtoset(idex,child,0) + } + + + } + } + } + } + "}" +} diff --git a/reports/register1.ll b/reports/register1.ll new file mode 100644 index 0000000..bf57420 --- /dev/null +++ b/reports/register1.ll @@ -0,0 +1,239 @@ +/* + * @progname register1.ll + * @version 1.0 + * @author Wetmore + * @category + * @output nroff + * @description + * + * It will produce a report of all descendents of a person, + * and is presently designed for 12 pitch, HP laserjet III. + * All NOTE and CONT lines from data will be printed in the this report. + * This report will produce a paginated output. It is similiar + * to the report 'regvital1'. + * + * register1 + * + * This report does NOT have a footer and header + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1990, + * and it has been modified many times since. + * + * This report produces a nroff output, and to produce the + * output, use: nroff filename > filename.out + * + */ + + +proc main () +{ + getindi(indi) + ".de hd" nl() + "'sp .8i" nl() + ".." nl() + ".de fo" nl() + "'bp" nl() + ".." nl() + ".wh 0 hd" nl() + ".wh -.8i fo" nl() + ".de CH" nl() + ".sp" nl() + ".in 16n" nl() + ".ti 0" nl() + "\h'5n'\h'-\w'\\$1'u'\\$1\h'8n'\h'-\w'\\$2'u'\\$2\h'2n'" nl() + ".." nl() + ".de IN" nl() + ".sp" nl() + ".in 0" nl() + ".." nl() + ".de GN" nl() + ".br" nl() + ".ne 2i" nl() + ".sp 2" nl() + ".in 0" nl() + ".ce" nl() + ".." nl() + ".de P" nl() + ".sp" nl() + ".in 0" nl() + ".ti 5" nl() + ".." nl() + ".po 3" nl() + ".ll 7i" nl() + ".ls 1" nl() + ".na" nl() + list(ilist) list(glist) + table(stab) indiset(idex) + enqueue(ilist,indi) enqueue(glist,1) + set(curgen,0) set(out,1) set(in,2) + while (indi,dequeue(ilist)) { + print("OUT: ") print(d(out)) + print(" ") print(name(indi)) print(nl()) + set(thisgen,dequeue(glist)) + if (ne(curgen,thisgen)) { + ".GN" nl() "GENERATION " d(thisgen) nl() nl() + set(curgen,thisgen) + } + ".IN" nl() d(out) ". " + insert(stab,save(key(indi)),out) + call longvitals(indi) + addtoset(idex,indi,0) + set(out,add(out,1)) + families(indi,fam,spouse,nfam) { + ".P" nl() + if (spouse) { set(sname, save(name(spouse))) } + else { set(sname, "_____") } + if (eq(0,nchildren(fam))) { + name(indi) " and " sname + " had no children." nl() + } elsif (and(spouse,lookup(stab,key(spouse)))) { + "Children of " name(indi) " and " sname " are shown " + "under " sname " (" d(lookup(stab,key(spouse))) ")." nl() + } else { + "Children of " name(indi) " and " sname":" nl() + children(fam,child,nchl) { + set(haschild,0) + families(child,cfam,cspou,ncf) { + if (ne(0,nchildren(cfam))) { set(haschild,1) } + } + if (haschild) { + print("IN: ") print(d(in)) + print(" ") print(name(child)) print(nl()) + enqueue(ilist,child) + enqueue(glist,add(1,curgen)) + ".CH " d(in) " " roman(nchl) nl() + set (in, add (in, 1)) + call shortvitals(child) + } else { + ".CH " qt() qt() " " roman(nchl) nl() + call longvitals(child) + addtoset(idex,child,0) + } + } + } + } + } +} +proc shortvitals(indi) +{ + name(indi) + set(b,birth(indi)) set(d,death(indi)) + if (and(b,short(b))) { ", b. " short(b) } + if (and(d,short(d))) { ", d. " short(d) } nl() +} +proc longvitals(i) +{ + name(i) "." nl() + set(e,birth(i)) + if(and(e,long(e))) { "Born " long(e) "." nl() } + if (eq(1,nspouses(i))) { + spouses(i,s,f,n) { + "Married" + set(nocomma,1) + call spousevitals(s,f) + } + } else { + spouses(i,s,f,n) { + "Married " ord(n) "," + call spousevitals(s,f) + } + } + set(e,death(i)) + if(and(e,long(e))) { "Died " long(e) "." nl() } + fornotes(inode(i), note) { + note nl() + } +} + +proc spousevitals (spouse,fam) +{ + set(e,marriage(fam)) + if (and(e,long(e))) { nl() long(e) "," } + nl() name(spouse) + set(e,birth(spouse)) + if(and(e,long(e))) { "," nl() "born " long(e) } + set(e,death(spouse)) + if(and(e,long(e))) { "," nl() "died " long(e) } + set(dad,father(spouse)) + set(mom,mother(spouse)) + if (or(dad,mom)) { + "," nl() + if (male(spouse)) { "son of " } + elsif (female(spouse)) { "daughter of " } + else { "child of " } + } + if (dad) { name(dad) } + if (and(dad,mom)) { nl() "and " } + if (mom) { name(mom) } + "." nl() +} + + +/* Sample output of this report, it is paginated but I have not shown + that in this example. + + + GENERATION 1 + + 1. Fuller Ruben MANES. Born 19 Nov 1902, Union Valley, Sevier + Co, TN. Married 17 OCT 1936, Knoxville, TN, Edith Alberta MANIS, + born 8 APR 1914, Dandridge, Jefferson Co, TN, died 18 JUN 1992, + Knoxville, Knox Co, TN, daughter of William Loyd MANIS and Lillie + Caroline "Carolyn" NEWMAN. Died 20 Jun 1980, Knoxville, Knox Co, + TN. Fuller's first fifteen years were growing up on a farm. By + the time he was 10 years old, he had 9 other brothers and sisters + to help feed and care for, play with, and the many facets of work + which had to be done each day. "Clifford" and "Snowball" were + some of his nicknames. Pictures show him (many times) in a + three-piece suit and a man of many places. As most men, during + his youth, he was photographed in the presence with several + different females. He attended school at Harrison Chilhowee + Baptist Academy, which a walk of about 5 or 6 miles each way from + his home. He boarded at the school dormitory for an unknown + period of time. + + Children of Fuller Ruben MANES and Edith Alberta MANIS: + + i Ellsworth Howard MANIS. Born 11 MAR 1939, + Knoxville, Knox Co, TN. Died 13 MAR 1939, + Knoxville, TN,. Was the first born of twins, + birth two-forty PM, at Harrison-Henderson + Hospital. Ellsworth died at age 44 hours, was a + twin to Alda Clifford MANIS. Buried 13 Mar 1939 + at Seven Islands Cem, NE Knox County, TN (near + Jefferson and Sevier County line). + + 2 ii Alda Clifford MANIS, b. 1939, TN + + + GENERATION 2 + + + 2. Alda Clifford MANIS. Born 11 MAR 1939, Knoxville, Knox Co, + TN. Married first, 8 SEP 1962, Knoxville, Knox Co, TN, Joyce + Fern OWENS, born 1 APR 1942, Knoxville, Knox Co, TN, daughter of + Guy Hixon OWENS and Bertha Mae TURNER. Married second, 13 FEB + 1984, San Antonio, Texas, Marianne Florence KRAMER, born 19 MAY + 1943, Los Angeles, CA, daughter of Anthony Leo KRAMER and + Florence Rita BOSSO. Born at two-forty five PM, Harrison- + Henderson Hospital. Twin of Elsworth Howard MANIS. Clifford was + born second. + + Children of Alda Clifford MANIS and Joyce Fern OWENS: + + 3 i Gregory Scott MANIS, b. 1963, VA + + ii Sheila Ann MANIS. Born 7 APR 1968, Mexico City, + Mexico DF. + + Alda Clifford MANIS and Marianne Florence KRAMER had no + children. + + +*/ + +/* end of report */ diff --git a/reports/regvital.ll b/reports/regvital.ll new file mode 100644 index 0000000..4f808d8 --- /dev/null +++ b/reports/regvital.ll @@ -0,0 +1,452 @@ +/* + * @progname regvital.ll + * @version 3.0 + * @author Wetmore, Manis, Chandler + * @category + * @output nroff + * @description + +This program produces a report of all descendents of a given person, +and is presently designed for 12 pitch, HP laserjet III, for printing +a book about that person. All NOTE and CONT lines are included in the +report, along with the vital statistics, occupations, immigrations, +attributes, and wills. +At the end of the report is a sorted listing of names of everyone +mentioned, with reference numbers giving the first occurrences of all +the names. + + +regvital + +version 1 by Tom Wetmore +version 2 by Cliff Manis +version 3 by John Chandler, 1994 + +This program has paginated output with a footer and header. + +This report produces a nroff output, and to produce the +output, use: nroff filename > filename.out + or: troff -t filename | lpr -t + + */ + +global(bold) +global(idex) +global(srcs) +global(curref) +global(months) +global(dtform) +global(footn) +global(begnote) +global(endnote) + +proc main () { + +/* Customize the following: */ +set(head,"Family History") +/* set(foot,"your name and address or whatever") */ +set(foot,concat("Created ",stddate(gettoday())," by ", + getproperty("user.fullname"), " ",getproperty("user.email"))) +set(ll,"8.5i") /* line length for headers */ +set(dtform,0) /* date format: 0=dmy, 8=ymd, etc. */ +set(footn,1) /* if 1, then do footnote-style sources */ +set(fancy,0) /* if 1, then do superscript note refs */ +set(bold,0) /* if 1, use boldface for names */ + +list(months) +enqueue(months,"Jan") enqueue(months,"Feb") +enqueue(months,"Mar") enqueue(months,"Apr") +enqueue(months,"May") enqueue(months,"Jun") +enqueue(months,"Jul") enqueue(months,"Aug") +enqueue(months,"Sep") enqueue(months,"Oct") +enqueue(months,"Nov") enqueue(months,"Dec") + +if(fancy){ + set(begnote,"\\u\\s-2") /* or use left-bracket for ASCII version */ + set(endnote,"\\s0\\d") /* or use right-bracket */ +} else { + set(begnote,"[") + set(endnote,"]") +} +dateformat(dtform) +if(or(eq(dtform,0),eq(dtform,8))){dayformat(0) monthformat(4)} +elsif(eq(dtform,1)){dayformat(2) monthformat(4)} +else{dayformat(1) monthformat(1)} + +getindi(indi) +getintmsg(maxgen,"Enter max generations to include (0 if no limit)") +set(maxgen,sub(maxgen,1)) + +set(tday, gettoday()) +".de hd\n" /* header */ +".ev 1\n" +".sp 2\n" +".tl '" head "''%'\n" +".tl ''" stddate(tday) "''\n" +"\n" +"'sp 3\n" +".ev\n" +"..\n" +".de fo\n" /* footer */ +".ev 1\n" +".sp\n" +".tl '" foot "'''\n" +".sp\n" +".ev\n" +"'bp\n" +"..\n" +".wh 0 hd\n" +".wh -.8i fo\n" +".de CH\n" /* CHild number macro */ +".sp\n" +".in 14n\n" +".ti 0\n" +"\\h'5n'\\h'-\\w'\\\\$1'u'\\\\$1\\h'6n'\\h'-\\w'\\\\$2'u'\\\\$2\\h'2n'\n" +"..\n" +".de II\n" /* Index Item macro */ +".br\n" +"\\\\$1\\h'-\\w'\\\\$1'u'\\h'35n'" +"\\\\$2\\h'-\\w'\\\\$2'u'\\h'13n'" +"\\\\$3\\h'-\\w'\\\\$3'u'\\h'13n'" +"\\\\$4\n" +"..\n" +".de IN\n" /* Individual Number macro */ +".sp\n" +".in 0\n" +"..\n" +".de GN\n" /* Generation Number macro */ +".br\n" +".ne 2i\n" +".sp 2\n" +".in 0\n" +".ce\n" +"..\n" +".de P\n" /* Paragraph macro */ +".sp\n" +".in 0\n" +".ti 5n\n" /* indent 1st line */ +"..\n" +".ev 1\n" +".ll " ll nl() /* line length */ +".ev\n" +".po 9\n" /* left margin */ +".ls 1\n" +".na\n" +list(ilist) list(glist) +table(stab) indiset(idex) +enqueue(ilist,indi) enqueue(glist,1) +set(curgen,0) set(out,1) set(in,2) +if(footn) {list(srcs)} + +while (indi,dequeue(ilist)) { + print("OUT: ") print(d(out)) + print(" ") print(name(indi)) print(nl()) + set(thisgen,dequeue(glist)) + if (ne(curgen,thisgen)) { + if(or(lt(maxgen,0),gt(maxgen,1))){".GN\nGENERATION " d(thisgen) "\n\n"} + set(curgen,thisgen) + } + ".IN\n" d(out) ". " + insert(stab,save(key(indi)),out) + set(curref,out) + call longvitals(indi,curgen) + addtoset(idex,indi,curref) + set(out,add(out,1)) + families(indi,fam,spouse,nfam) { + ".P\n" + if (spouse) { set(sname, save(name(spouse))) } + else { set(sname, "_____") } + if(eq(0,strcmp("",sname))) { set(sname, "_____") } + if (eq(0,nchildren(fam))) { + name(indi) " and " sname + " had no children.\n" + } elsif (and(spouse,lookup(stab,key(spouse)))) { + "Children of " name(indi) " and " sname " are shown " + "under " sname " (" d(lookup(stab,key(spouse))) ").\n" + } else { + "Children of " name(indi) " and " sname ":\n" + children(fam,child,nchl) { + set(haschild,0) + families(child,cfam,cspou,ncf) { + if (ne(0,nchildren(cfam))) { set(haschild,1) } + } + if(and(haschild,or(gt(maxgen,curgen),lt(maxgen,0)))) { + print("IN: ") print(d(in)) + print(" ") print(name(child)) print(nl()) + enqueue(ilist,child) + enqueue(glist,add(1,curgen)) + ".CH " d(in) " " roman(nchl) nl() + set (in, add (in, 1)) + call shortvitals(child) + } else { + ".CH " qt() qt() " " roman(nchl) nl() + call longvitals(child,0) + addtoset(idex,child,curref) + } + } + } + } +} +if(and(footn,length(srcs))){ + "\n.in 0\n.sp 2\n---------------\n.sp\nSources of information:\n" + forlist(srcs,s,n){ if(gt(n,1)){";\n"} "[" d(n) "] " s } + ".\n" +} +if(or(lt(maxgen,0),gt(maxgen,1))){ + print("begin sorting\n") + namesort(idex) + print("done sorting\n") + ".bp\n" + ".in 0\n" + "Index of Persons in this Report (first occurrence)\n\n" + ".II Name Birth Death #\n\n" + forindiset(idex,indi,v,n) { + ".II " qt()fullname(indi,1,0,30)qt() + " " qt()stddate(birth(indi))qt() + " " qt()stddate(death(indi))qt() + " " d(v) nl() + print(".") + } + nl() + print(nl()) +}} + +proc shortvitals(indi){ +name(indi) +set(b,birth(indi)) set(d,death(indi)) +if (and(b,short(b))) { ", b. " short(b) } +if (and(d,short(d))) { ", d. " short(d) } +nl() +} + +proc longvitals(i,flag){ /* all data and notes for individual */ +if(not(footn)) {list(srcs)} +if (bold) { "\\f3" } +name(i) +if (bold) { "\\f1" } +set(e,birth(i)) +if(and(e,long(e))) { ",\nborn " call displong(e) } +if(not(and(e,place(e)))) { + set(e,baptism(i)) + if(and(e,long(e))) { ",\nbaptized " call displong(e) } +} +if(eq(flag,1)) { call printparents(i) } +".\n" +set(e,death(i)) +if(and(e,long(e))) { "Died " call displong(e) ".\n" } +if(not(and(e,place(e)))) { + set(e,burial(i)) + if(and(e,long(e))) {"Buried " call displong(e) ".\n"} +} +if (eq(1,nspouses(i))) { + spouses(i,s,f,n) { + if(e,marriage(f)) { + "Married" + } else { + /* "Lived with " */ + "Married" + } + set(nocomma,1) + call spousevitals(s,f) + } +} else { + set(j,1) + spouses(i,s,f,n) { + if(e,marriage(f)) { + "Married " ord(j) "," + set(j,add(j,1)) + } else { + "Married" + } + call spousevitals(s,f) + } +} +fornodes(inode(i), node) { + set(ntag, save(tag(node))) + if (eq(0,strcmp("FILE", ntag))) { + copyfile(value(node)) + } elsif (eq(0,strcmp("NOTE", ntag))) { + value(node) + fornodes(node, subnode) { + if (eq(0,strcmp("CONT", tag(subnode)))) { + nl() value(subnode) + } + } + call setsrc(node) nl() + } elsif (eq(0,strcmp("OCCU", ntag))) { + "Occupation: " value(node) + call setsrc(node) + ".\n" + } elsif (eq(0,strcmp("ATTR", ntag))) { + "Attributes: " value(node) + call setsrc(node) + ".\n" + } elsif (eq(0,strcmp("IMMI", ntag))) { + if(long(node)) { + "Immigrated " call displong(node) + fornodes(node, subnode) { + if(eq(0,strcmp("NOTE",tag(subnode)))) { + ",\n" value(subnode) + } + } + ".\n" + } + } elsif (eq(0,strcmp("WILL", ntag))) { + if(long(node)) { "Made a will " call displong(node) ".\n" } + } elsif (eq(0,strcmp("PROB", ntag))) { + if(long(node)) { "Will proved " call displong(node) ".\n" } + } +} +if(and(not(footn),length(srcs))){ + "\nSources of information:\n" + forlist(srcs,s,n){ if(gt(n,1)){";\n"} s } + ".\n" +}} + +proc displong(e) { /* display full date, place, and age for an event */ +/* long(e) */ +extractdate(e,da,mo,yr) +if(mod,date(e)){ + if(or(da,or(mo,yr))){ + set(mod,trim(mod,3)) + if(eq(0,strcmp(mod,"ABT"))) {"about "} + elsif(eq(0,strcmp(mod,"abo"))) {"about "} + elsif(eq(0,strcmp(mod,"AFT"))) {"after "} + elsif(eq(0,strcmp(mod,"aft"))) {"after "} + elsif(eq(0,strcmp(mod,"BEF"))) {"before "} + elsif(eq(0,strcmp(mod,"bef"))) {"before "} + elsif(eq(0,strcmp(mod,"BET"))) {"beginning "} + if(or(eq(1,dtform),le(8,dtform))){ + if(yr){ d(yr) if(mo){" "}} + if(mo){ getel(months,mo) if(da){" "d(da)}} + } else{ + if(da){ d(da) if(mo){" "}} + if(mo){ getel(months,mo) if(yr){" "}} + if(yr){d(yr)} + } + } else { mod } + if(place(e)){ ", "} +} +if(mod,place(e)) { mod } +fornodes(e,subnode) { + if(eq(0,strcmp("AGE",tag(subnode)))) { + ",\naged " value(subnode) + } +} +call setsrc(e) +} + +proc setsrc(node) { /* collect source reference, if any */ +fornodes(node,subnode){ + if(eq(0,strcmp("SOUR",tag(subnode)))){ + if(n,length(srcs)){ + set(i,0) + while(lt(i,n)){ + set(i,add(i,1)) + if(eq(0,strcmp(getel(srcs,i),value(subnode)))){ + set(n,i) set(skip,1) + } + } + } + if(not(skip)){ + enqueue(srcs,save(value(subnode))) + set(i,add(n,1)) + } + if(footn){ + if(not(started)){begnote set(started,1)} + else{","} + d(i)} + } +} +if(started){endnote} +} + +proc spousevitals (sp,fam) { +list(names) +addtoset(idex,sp,curref) +set(e,marriage(fam)) +if (and(e,long(e))) { nl() call displong(e) "," } +"\n" +if (bold) { "\\f3" } +if(strcmp("",name(sp))) {name(sp)} else {"_____"} +if (bold) { "\\f1" } +if(e){ + fornodes(e,subnode) { + if(eq(0,strcmp("NAME",tag(subnode)))){ + extractnames(subnode,names,n,s) + if(s) {"\n(under the name " getel(names,s) ")"} + } + } +} +set(e,birth(sp)) +if(and(e,long(e))) { ",\nborn " call displong(e) } +set(e,death(sp)) +if(and(e,long(e))) { ",\ndied " call displong(e) } +call printparents(sp) +} + +proc printparents(ind) { /* print only if non-blank */ +if(dad,father(ind)) {if(ndad,name(dad)) {set(nbld,strcmp("",ndad))}} +if(mom,mother(ind)) {if(nmom,name(mom)) {set(nblm,strcmp("",nmom))}} +if (or(nbld,nblm)) { + ",\n" + if (male(ind)) { "son of " } + elsif (female(ind)) { "daughter of " } + else { "child of " } +} +if (nbld) { name(dad) } +if (and(nbld,nblm)) { "\nand " } +if (nblm) { name(mom) } +".\n" +if (nbld) { addtoset(idex,dad,curref) } +if (nblm) { addtoset(idex,mom,curref) } +} + +/* Sample printout of the report, plus also prints a names index. + + Manes - Manis - Maness Family History + 14 Jan 1993 + + GENERATION 1 + + + 1. William Bowers MANES, born 6 Jan 1868, Hamblen Co, TN ?, died 5 + May 1933, Sevier Co, TN. Married 13 Apr 1892, White Pine, TN, + Cordelia "Corda" F. CANTER, born 7 Dec 1869, Jonesboro, Washington + Co, TN, died 18 Apr 1960, Knoxville, Knox Co, TN, daughter of James + H. CANTER and Martha Marie WHITEHORN. He died of pneumonia at his + homeplace in Union Valley, Sevier Co, TN He was buried at the Knob + Creek Baptist Church cemetery in Sevier County, TN. + + Children of William Bowers MANES and Cordelia "Corda" F. CANTER: + + 2 i Nellie V. MANES, b. 1893, TN, d. 1984, TN + + ii Emery H. MANES, born 24 Oct 1894, White Pine, + Jefferson Co, TN, died 26 Jul 1926, Knob Creek, + Sevier Co., TN. Died in auto accident, when he + and a brother were going in his truck with a load + of vegetables, and going to market in Knoxville. + He is buried at Knob Creek Cem. Sevier Co, TN. + + 3 iii Walter C. MANES, b. 1896, TN, d. 1989, TN + + 4 iv William Lee MANES, b. 1897, TN, d. 1969, TN + + v George MANES, born 29 Oct 1898, Union Valley, + Sevier Co, TN, died 17 Jun 1899, Knob Creek, + Sevier Co, TN. Single, died as a infant, and is + buried at Knob Creek Cem, Sevier Co, TN. + + 5 vi Fuller Ruben MANES, b. 1902, TN, d. 1980, TN + + 6 vii Mabel E. MANES, b. 1905, TN + + 7 viii Lena G. MANES, b. 1906, TN, d. 1987, TN + + 8 ix Wade Preston MANES, b. 1910, TN + + 9 x Newman Clarence MANES, b. 1912, TN + +//end of sample// */ + diff --git a/reports/relate.ll b/reports/relate.ll new file mode 100644 index 0000000..7dbc829 --- /dev/null +++ b/reports/relate.ll @@ -0,0 +1,108 @@ +/* + * @progname relate.ll + * @version 1.0 + * @author Wetmore + * @category + * @output Text + * @description + * + * Finds a shortest path between two persons in a LifeLines database. + * Inspiration from Jim Eggert's relation program. + + +relate - Finds a shortest path between two persons in a LifeLines + database. + by Tom Wetmore (ttw@petrel.att.com) + Inspiration from Jim Eggert's relation program + Version 1, 07 September 1993 +*/ + +proc main () +{ + getindimsg(from, "Please identify starting person.") + getindimsg(to, "Please identify ending person.") + if (and(from, to)) { + print("Computing relationship between:\n ") + print(name(from)) print(" and ") + print(name(to)) print(".\n\nThis may take awhile -- ") + print("each dot is a person.\n") + + set(fkey, save(key(from))) + set(tkey, save(key(to))) + call relate(tkey, fkey) + } else { + print("We're ready when you are.") + } +} + +global(links) +global(rels) +global(klist) + +proc relate (fkey, tkey) +{ + table(links) /* table of links back one person */ + table(rels) /* table of relationships back one person */ + list(klist) /* list of persons not linked back to */ + + insert(links, fkey, fkey) + insert(rels, fkey, ".") + enqueue(klist, fkey) + set(again, 1) + + while (and(again, not(empty(klist)))) { + set(key, dequeue(klist)) + set(indi, indi(key)) + call include(key, father(indi), ", father of") + call include(key, mother(indi), ", mother of") + families(indi, fam, spouse, num1) { + children(fam, child, num2) { + call include(key, child, ", child of") + } + if (spouse) { + call include(key, spouse, ", spouse of") + } + } + if (fam, parents(indi)) { + children(fam, child, num2) { + call include(key, child, ", sibling of") + } + } + if (key, lookup(links, tkey)) { + call foundpath(tkey) + set(again, 0) + } + } + if (again) { + print("They are not related to one another.") + } +} + +proc include (key, indi, tag) +{ + if (and(indi, not(lookup(links, key(indi))))) { + print(".") + set(new, save(key(indi))) + insert(links, new, key) + insert(rels, new, tag) + enqueue(klist, new) + } +} + +proc foundpath (key) +{ + print("\n\nA relationship between them was found:\n\n") + set(again, 1) + while (again) { + print(" ") + print(name(indi(key))) + print(lookup(rels, key)) + print("\n") + set(new, lookup(links, key)) + if (eq(0, strcmp(key, new))) { + set(again, 0) + } else { + set(key, new) + } + } +} diff --git a/reports/related_spouses.ll b/reports/related_spouses.ll new file mode 100644 index 0000000..5c12267 --- /dev/null +++ b/reports/related_spouses.ll @@ -0,0 +1,74 @@ +/* + * @progname related_spouses.ll + * @version 2.0 + * @author Eggert + * @category + * @output Text + * @description + +This program identifies spouses with known common ancestors. For each +marriage of related spouses, the spouses' names are printed, along +with the first common ancestor in each branch of the ancestry tree, +and the number of intervening generations for the husband and wife, +respectively. + +related_spouses - a LifeLines program to identify related spouses + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 31 March 1993 (first release) + Version 2, 15 March 1995 (use new set functions, generation numbers) + +*/ + +proc main() { + indiset(husb_ancestors) + indiset(wife_ancestors) + indiset(common_ancestors) + forfam(family,fnum) { + if (hubby,husband(family)) { + if (wifey,wife(family)) { +/* find common ancestors */ + indiset(oneset) + addtoset(oneset,hubby,0) + set(husb_ancestors,ancestorset(oneset)) + addtoset(husb_ancestors,hubby,0) + indiset(oneset) + addtoset(oneset,wifey,0) + set(wife_ancestors,ancestorset(oneset)) + addtoset(wife_ancestors,wifey,0) + set(common_ancestors,intersect(husb_ancestors,wife_ancestors)) + set(cnum,lengthset(common_ancestors)) + +/* find lowest common ancestors (common_ancestors - too_common_ancestors) */ + if (cnum) { +/* Make wife ancestor generation table wcat */ + indiset(wca) + set(wca,intersect(wife_ancestors,husb_ancestors)) + table(wcat) + forindiset(wca,person,wgen,wnum) { + insert(wcat,key(person),wgen) + } + + indiset(lowest_common_ancestors) + set(lowest_common_ancestors, + difference(common_ancestors, + ancestorset(common_ancestors))) + set(lca_length,lengthset(lowest_common_ancestors)) +/* print out lowest common ancestors */ + key(family) " " + key(husband(family)) " " name(husband(family)) + " and " + key(wife(family)) " " name(wife(family)) + "\n have " d(lca_length) + " lowest common ancestor" + if (gt(lca_length,1)) { "s" } + col(60) "hgen" col(70) "wgen\n" + forindiset(lowest_common_ancestors,lca,hgen,lnum) { + " " key(lca) " " name(lca) + col(60) d(hgen) + col(70) d(lookup(wcat,key(lca))) "\n" + } + } + } + } + } +} diff --git a/reports/relation.ll b/reports/relation.ll new file mode 100644 index 0000000..f95ea15 --- /dev/null +++ b/reports/relation.ll @@ -0,0 +1,255 @@ +/* + * @progname relation.ll + * @version 5.0 + * @author Eggert + * @category + * @output Text + * @description + +This program calculates the relationship between individuals in a +database. It does so in three modes. Mode 1 just does one pair of +individuals and then exits. Mode 2 does any number of pairs with a +common "from" person. Mode 3 does all pairs with a common "from" +person. In general, mode 1 is fastest for simple relationships, but +if you want one complicated relationship, you may as well do them all. + +relation - a LifeLines relation computing program + by Jim Eggert (eggertj@atc.ll.mit.edu) + Version 1, 21 November 1992 + Version 2, 23 November 1992 (completely revamped) + Version 3, (changed format slightly, modified code somewhat) + Version 4, 6 July 1993 (added English language) + Version 5, 6 September 1993 (generified language) + +Each computed relation is composed of the minimal combination of +parent (fm), sibling (bsS), child (zdC), and spouse (hw) giving the +relational path from the "from" person to the "to" person. Each +incremental relationship (or hop) is coded as follows, with the +capital letters denoting a person of unknown gender: + father f + mother m + parent P (not used) + brother b + sister s + sibling S + son z (sorry) + daughtr d + child C + husband h + wife w + spouse O (sorry again, but usually not possible) + +The report gives the steps required to go from the first person to +the second person. Thus the printout + I93 John JONES fmshwz I95 Fred SMITH +means that John Jones' father's mother's sister's husband's wife's son +is Fred Smith. Notice in this case, the sister's husband's wife is +not the same as the sister, and the husband's wife's son is not the +same as the husband's son. Thus in more understandable English, John +Jones' paternal grandmother's sister's husband's wife's son from +another marriage is Fred Smith. + +The program will do a trivial parsing of the path string. You can +change the language_table to have it print in different languages, as +long as the word order is unchanged. + +If there is no relation, the program says so. That at least should be +easy to explain. Mode 3 only prints out those individuals who are +related to the "from" individual. +*/ + +global(plist) +global(hlist) +global(mark) +global(keys) +global(found) +global(do_names) +global(language) +global(language_table) +global(token) +global(untoken) + +proc include(person,hops,keypath,path,pathend) +{ + if (and(person,eq(found,0))) { + set(pkey,key(person)) + if (entry,lookup(mark,pkey)) { + if (eq(strcmp(entry,"is not related to"),0)) { + set(found,1) + list(plist) + list(hlist) + insert(mark,pkey,concat(path,pathend)) + insert(keys,pkey,concat(concat(keypath,"@"),pkey)) + } + } + else { + enqueue(plist,pkey) + enqueue(hlist,hops) + insert(mark,pkey,concat(path,pathend)) + insert(keys,pkey,concat(concat(keypath,"@"),pkey)) + } + } +} + +proc get_token(input) { +/* Parse a token from the input string. + Tokens are separated by one or more "@"s. + Set global parameter token to the first token string. + Set global parameter untoken to the rest of the string after first token. +*/ +/* strip leading @s */ + set(untoken,input) + set(first_delim,index(untoken,"@",1)) + while (eq(first_delim,1)) { + set(untoken,substring(untoken,2,strlen(untoken))) + set(first_delim,index(untoken,"@",1)) + } +/* get token and untoken */ + if (not(first_delim)) { + set(token,untoken) + set(untoken,"") + } + else { + set(token,substring(untoken,1,sub(first_delim,1))) + set(untoken, + substring(untoken,add(first_delim,1),strlen(untoken))) + } +} + +proc parse_relation(relation,keypath) { + if (not(language)) { + " " relation + if (do_names) { + set(untoken,keypath) + call get_token(untoken) + while(strlen(untoken)) { + call get_token(untoken) + " " token " " name(indi(token)) + } + } + " " + } + else { + set(charcounter,1) + set(untoken,keypath) + call get_token(untoken) + while (le(charcounter,strlen(relation))) { + lookup(language_table,substring(relation,charcounter,charcounter)) + if (do_names) { + call get_token(untoken) + " " token " " name(indi(token)) + } + set(charcounter,add(charcounter,1)) + } + " is " + } +} + +proc main () +{ + table(mark) + table(keys) + list(plist) + list(hlist) + + table(language_table) + insert(language_table,"f","'s father") + insert(language_table,"m","'s mother") + insert(language_table,"P","'s parent") + insert(language_table,"b","'s brother") + insert(language_table,"s","'s sister") + insert(language_table,"S","'s sibling") + insert(language_table,"z","'s son") + insert(language_table,"d","'s daughter") + insert(language_table,"C","'s child") + insert(language_table,"h","'s husband") + insert(language_table,"w","'s wife") + insert(language_table,"O","'s spouse") + + getindimsg(from_person, + "Enter person to compute relation from:") + set(from_key,key(from_person)) + set(hopcount,0) + set(prev_hopcount,neg(1)) + set(found,0) + call include(from_person,hopcount,"","","") + getintmsg(mode,"Enter 1 for a single relation, 2 for several, 3 for all:") + getintmsg(language, + "Enter 0 for brief, 1 for English-language relationships:") + getintmsg(do_names, + "Enter 0 to omit, 1 to output names of all intervening relatives:") + if (eq(mode,1)) { + getindimsg(to_person, + "Enter one person to compute relation to:") + set(to_key,key(to_person)) + if (strcmp(from_key,to_key)) { + insert(mark,to_key,"is not related to") + } + else { + list(plist) + list(hlist) + } + } + while (pkey,dequeue(plist)) { + set(person,indi(pkey)) + set(hopcount,dequeue(hlist)) + set(path,lookup(mark,pkey)) + set(keypath,lookup(keys,pkey)) + if (ne(hopcount,prev_hopcount)) { + print(".") + set(prev_hopcount,hopcount) + } + set(hopcount,add(hopcount,1)) + call include(father(person),hopcount,keypath,path,"f") + call include(mother(person),hopcount,keypath,path,"m") + children(parents(person),child,cnum) { + if (male(child)) { set(pathend,"b") } + elsif (female(child)) { set(pathend,"s") } + else { set(pathend,"S") } + call include(child,hopcount,keypath,path,pathend) + } + families(person,fam,spouse,pnum) { + if (male(spouse)) { set(pathend,"h") } + elsif (female(spouse)) { set(pathend,"w") } + else { set(pathend,"O") } + call include(spouse,hopcount,keypath,path,pathend) + children(fam,child,cnum) { + if (male(child)) { set(pathend,"z") } + elsif (female(child)) { set(pathend,"d") } + else { set(pathend,"C") } + call include(child,hopcount,keypath,path,pathend) + } + } + } + if (eq(mode,1)) { + from_key " " name(indi(from_key)) + call parse_relation(lookup(mark,to_key),lookup(keys,to_key)) + to_key " " name(indi(to_key)) "\n" + } + if (eq(mode,2)) { + set(want_another,1) + while (want_another) { + getindimsg(to_person,"Enter person to compute relation to:") + set(to_key,key(to_person)) + from_key " " name(indi(from_key)) + if (path,lookup(mark,to_key)) { + call parse_relation(path,lookup(keys,to_key)) + } + else { " is not related to " } + to_key " " name(to_person) "\n" + getintmsg(want_another, + "Enter 0 if done, 1 if you want another to person:") + } + } + if (eq(mode,3)) { + from_key " " name(indi(from_key)) " --->\n" + forindi(to_person,num) { + set(to_key,key(to_person)) + if (path,lookup(mark,to_key)) { + call parse_relation(path,lookup(keys,to_key)) + to_key " " name(to_person) "\n" + } + } + } +} + diff --git a/reports/relink.ll b/reports/relink.ll new file mode 100644 index 0000000..346ec9b --- /dev/null +++ b/reports/relink.ll @@ -0,0 +1,74 @@ +/* + * @progname relink.ll + * @version 1995-06 + * @author J.F. Chandler + * @category + * @output GEDCOM + * @description + +LifeLines program to reconstruct pointers from persons to families when +these pointers are missing, but can be deduced from the corresponding +pointers from families to persons. Do this only for persons with no +pointers to families at all. Similarly, reconstruct pointers from +families to persons where necessary. + +The output is a GEDCOM file which includes only the individual and family +records from the database. Other record types must be recovered separately +because there is no iterator in the language for those record types. + +relink - J.F. Chandler - 1995 Jun +*/ + +proc main() { +"0 HEAD\n1 SOUR RELINK\n1 DEST ANY\n" +forindi(i,n) { + traverse(inode(i),node,level) { + d(level) " " + if(eq(level,0)) { "@" key(i) "@ " } + tag(node) + if(v,value(node)) { " " v } + nl() + } + if(not(or(nfamilies(i),parents(i)))) { + set(indk,save(key(i))) + forfam(f,k) { + if(or(eq(0,strcmp(indk,key(wife(f)))), + eq(0,strcmp(indk,key(husband(f)))))) { + "1 FAMS @" key(f) "@\n" + } elsif(nchildren(f)) { + children(f,child,l) { + if(eq(0,strcmp(indk,key(child)))) { + "1 FAMC @" key(f) "@\n" + break() + } + } + } + } + } +} +forfam(f,k) { + traverse(fnode(f),node,level) { + d(level) " " + if(eq(level,0)) { "@" key(f) "@ " } + tag(node) + if(v,value(node)) { " " v } + nl() + } + if(not(or(husband(f),wife(f),nchildren(f)))) { + set(famk,save(key(f))) + forindi(i,n) { + families(i,fam,spo,l) { + if(eq(0,strcmp(famk,key(fam)))) { + if(male(i)) {"1 HUSB @" key(i) "@\n"} + else {"1 WIFE @" key(i) "@\n"} + break() + } + } + if(eq(0,strcmp(famk,key(parents(i))))) { + "1 CHIL @" key(i) "@\n" + } + } + } +} +"0 TRLR\n" +} diff --git a/reports/rfc.ll b/reports/rfc.ll new file mode 100644 index 0000000..e7619bc --- /dev/null +++ b/reports/rfc.ll @@ -0,0 +1,777 @@ +/* + * @progname rfc.ll + * @version 1995-09-08 + * @author Paul B. McBride (pbm%cybvax0@uunet.uu.net) + * @category + * @output Text + * @description + + Royalty For Commoners format report + +Requirements: + LifeLines 3.0.2 or later (I hope) + sour.li - SOUR processing subroutine library + +Background: + +This report program generates a report in a format similar to that +used in the book "Royalty for Commoners", Stuart, 1992, which attempts +to list all of the "known" ancestors of John of Gaunt. In this book +the furtherest back generation has the highest number, and there is +an attempt to keep generation numbers relatively consistant in different +lines. + +The format is similar to that used in "Ancestral Roots of Certain +American colonists who came to America before 1700", Weis, 1992, except +that here the earliest generation in a line is generation number 1. + +I also use this report program to generate a report for a range of +people between an ancestor and a descendant when exchanging info +with other people. + +Prompts: + + Identify the ancestor (Optional) + + If you want a complete report of all of the ancestors + of a person, or if you don't want a complete + report, but the earliest ancestor has the same + surname as the descendant, then just press return + + Identify the descendant + + If you didn't enter the ancestor, then you must enter + the descendant to get a report. + + All ancestors (1 = yes, 0 = no) + + If you haven't entered the ancestor, then you will + be asked this question. If you answer 0 (no), then + the program will use the earliest ancestor in the + paternal line. + + Number of Generations + + If you haven't entered the descendant, then the program + will look for a descendant this many generations below. + + First Generation Number (default is 1) + + If you want generations to count upward as in "Anceatral + Roots..." then enter 1. + + If you want generations to count downward as in "Royalty + for Commoners", an educated guess is necessary here, + or you may end up with negative generation numbers. + An ancestorset() will be generated. This will contain + minimum generation numbers. The generation number + in the ancestor set will be used to adjust the generation + number upward if you enter a number which is too small, + but this may not be sufficient. For my database, I needed + to increase that number by 10. + + Generations count downward (1) or upward (0) + + You are only asked this question if the first generation + number is greater than 1. + +Tags processed by the report + + tag prefix + + TITL + NOTE + BIRT b. + CHR bp. + DEAT d. + BUR bur. + LIVE lv. + RESI r. + +SOUR record processing + + Source references are accumulated for each line and the + REFN's are reported at the end of the line. + At the end of the report all of the REFN's are listed + along with the source details. See my SOUR routine + library (sour.li) for more info. + +Future Development: + + - rather than specifying a single descendant, allow entry of + a group of descendants. + - allow optional reporting of more SOUR detail associated with tags. + - sort aliases + - sort reference keys + +Edit History: + +08-sep-95 Paul B. McBride (pbm%cybvax0@uunet.uu.net) +*/ + +include("sour.li") + +global(atable) +global(xtable) +global(aset) +global(xlen) +global(nalist) +global(nilist) +global(aliascnt) +global(indicnt) + +global(allsour_table) +global(allsour_list) + +global(allanc) +global(part) +global(gnum) +global(tset) + +proc main () +{ + table(allsour_table) + list(allsour_list) + + indiset(iset) + indiset(tset) + indiset(uset) + indiset(aset) + table(atable) + table(xtable) + list(nalist) + list(nilist) + set(xlen, 0) + set(aliascnt, 0) + set(indicnt, 0) + + getindimsg(ancestor, "Identify the ancestor (Optional)") + if(ancestor) { + getindimsg(descendant,"Identify the descendant (Optional)") + } + else { + getindimsg(descendant,"Identify the descendant (Required)") + } + set(allanc, 0) + if(and(ne(descendant,0),eq(ancestor,0))) { + getintmsg(allanc, "All Ancestors? (1 = yes, 0 = no)") + set(ancestor, descendant) + while(fath, father(ancestor)) { + set(ancestor, fath) + } + } + if(and(eq(descendant,0),ne(ancestor,0))) { + getintmsg(gcount, "Number of Generations") + set(descendant, ancestor) + while(gcount, sub(gcount,1)) { + set(cindi, 0) + set(dindi, 0) + families(descendant, fam, sps, fnum) { + if(gt(nchildren(fam),0)) { + children(fam, child, cnum) { + if(eq(cindi, 0)) { set(cindi, child) } + families(child, chfam, chsps, chfnum) { + if(gt(nchildren(chfam),0)) { + set(dindi, child) + break() + } + } + if(ne(dindi, 0)) { break() } + } + } + if(ne(dindi, 0)) { break() } + } + if(dindi) { set(descendant, dindi) } + elsif (cindi) { + set(descendant, cindi) + break() + } + else { break() } + } + } + if(and(ne(ancestor, 0),ne(descendant,0))) { + getintmsg(gnum, "First Generation Number (default is 1)") + if(le(gnum,0)) { set(gnum,1) } + set(down, 0) + if(gt(gnum,1)) { + getintmsg(down, "Generations count downward (1) or upward (0)") + } + set(firstgen, gnum) + if(descendant) { + /* output a line so that output file prompt will appear before + the ancestor set is generated because it can take a long + time. + */ + if(allanc) { + print("All Ancestors of ", name(descendant), nl()) + "All Ancestors of " name(descendant) nl() + } + else { + print("Descendants of ", name(ancestor), + " who are ancestors of ", name(descendant), nl()) + "Descendants of " call titledname(ancestor) nl() + " who are ancestors of " call titledname(descendant) nl() + } + /* find all the people of interest */ + print("Finding Ancestors... ") + addtoset(iset, descendant, 0) + set(tset, ancestorset(iset)) + deletefromset(iset, descendant, 1) + print(d(lengthset(tset)), nl()) + + if(allanc) { + set(uset, tset) + } + else { + print("Finding Descendants... ") + addtoset(iset, ancestor, 0) + set(uset, descendantset(iset)) + deletefromset(iset, ancestor, 1) + print(d(lengthset(uset)), nl()) + } + set(aset, intersect(tset, uset)) + addtoset(aset, ancestor, 0) + addtoset(aset, descendant, 0) + print("Generating Report for ", + d(lengthset(aset)), " people") + + list(ilist) + list(alist) + list(plist) + list(glist) + + set(part, 0) + set(acount, 0) + + while(1) { + if(allanc) { + set(maxgen, 0) + set(ancestor, 0) + forindiset(tset, indi, ival, icnt) { + if(or(eq(maxgen, 0),gt(ival,maxgen))) { + set(maxgen, ival) + set(ancestor, indi) + } + } + if(eq(ancestor, 0)) { break() } + + if(and(ne(down,0), le(firstgen, maxgen))) { + set(firstgen, add(maxgen, 1)) + } + set(gnum, findgen(ancestor, down, firstgen, eq(acount,0))) + print(nl(), name(ancestor), " ", d(add(part,1)),"-",d(gnum),". ", + d(lengthset(tset)), " remaining") + } + enqueue(alist, ancestor) + enqueue(plist, 0) + enqueue(glist, gnum) + set(acount, add(acount, 1)) + while(aindi, dequeue(alist)) { + print(".") + nl() + call sour_init() + set(pnum, dequeue(plist)) + set(part, add(part, 1)) + set(gnum, dequeue(glist)) + "Line " d(part) + if(pnum) { + " from Line " d(pnum) " above." + } + /* if we are doing all of the ancestors, then start each line + as far back as possible.. + */ + if(allanc) { + set(changed, 0) + while(1) { + if(fath, father(aindi)) { + if(lookup(atable, key(fath))) { break() } + if(moth, mother(aindi)) { + if(eq(lookup(atable, key(moth)),0)) { + if(and(eq(father(fath),0),eq(mother(fath),0))) { + if(or(ne(father(moth),0),ne(mother(moth),0))) { + set(fath, moth) + } + } + } + } + set(tindi, aindi) + set(aindi, fath) + } + elsif(moth, mother(aindi)) { + if(lookup(atable, key(moth))) { break() } + set(tindi, aindi) + set(aindi, moth) + } + else { break() } + print("+") + if(eq(changed, 0)) { + set(changed, 1) + " [" name(tindi) " " d(pnum) "-" d(gnum) "]" + } + if(down) { set(gnum, add(gnum,1)) } + else { set(gnum, sub(gnum,1)) } + } + } + nl() nl() + enqueue(ilist, aindi) + while(indi, dequeue(ilist)) { + /* upper(roman(gnum)) */ + call addtoindex(indi, part, gnum) + if(allanc) { deletefromset(tset, indi, 1) } + d(gnum) ". " call titledname(indi) nl() + set(tnum, lookup(atable, key(indi))) + if(ne(tnum,0)) { + " [See Line " d(div(tnum,1000)) + " Generation " d(mod(tnum,1000)) " above]" nl() + continue() + } + insert(atable, save(key(indi)), add(mul(part,1000), gnum)) + call sour_addind(indi) + call allnotes(indi, 8) + call allplaces(indi, 5) + /* set(bdate, "") + * set(ddate, "") + * if (eb, birth(indi)) { set(bdate,save(long(eb))) } + * if (ed, death(indi)) { set(ddate,save(long(ed))) } + * set(prefix, " ") + * if (strlen(bdate)) { prefix "b. " bdate nl() } + * if (strlen(ddate)) { prefix "d. " ddate nl() } + */ + set(desc, 0) + set(nfam, nfamilies(indi)) + families(indi, fam, sps, fnum) { + if(sps) { + call sour_addind(sps) + call addtoindex(sps, part, gnum) + if(allanc) { deletefromset(tset, sps, 1) } + if(eq(nfam,1)) { " m. " } + else { " m(" d(fnum) ") " } + call titledname(sps) + if (e, marriage(fam)) { " " long(e) } + nl() + set(bdate, "") + set(ddate, "") + if (eb, birth(sps)) { set(bdate,save(long(eb))) } + if (ed, death(sps)) { set(ddate,save(long(ed))) } + set(prefix, " ") + if (strlen(bdate)) { prefix "b. " bdate nl() } + if (strlen(ddate)) { prefix "d. " ddate nl() } + set(findi, father(sps)) + set(mindi, mother(sps)) + if(or(findi, mindi)) { + " " + if(male(sps)) { "son of " } + else { "daughter of " } + if(findi) { + call addtoindex(findi, part, gnum) + if(allanc) { deletefromset(tset, findi, 1) } + call titledname(findi) + call simplefam(findi, ne(mindi,0)) + if(mindi) { " and " } + } + if(mindi) { + call addtoindex(mindi, part, gnum) + if(allanc) { deletefromset(tset, mindi, 1) } + call titledname(mindi) + call simplefam(mindi, 0) + } + nl() + } + } + if(gt(nchildren(fam),0)) { + if(eq(nfam,1)) { " ch: " } + else { " ch(" d(fnum) ") " } + set(needindent, 0) + children(fam, child, cnum) { + set(altdesc,0) + set(mcnum,mod(sub(cnum,1),4)) + if(gt(cnum,1)) { + if(eq(mcnum,0)) { set(needindent,1) } + } + if(needindent) { + "," nl() " " + set(needindent,0) + } + else { + if(gt(mcnum,0)) { ", "} + } + /* mark each child which is an ancestor with a "*", + but only use the first at the next generation. + */ + set(seeabove, 0) + if(eq(child,descendant)) { + "*" + set(seeabove, lookup(atable, key(child))) + if(eq(seeabove, 0)) { + if(eq(desc,0)) { + enqueue(ilist, child) + set(desc,1) + } + } + } + else { + addtoset(iset, child, 0) + set(jset, intersect(aset, iset)) + if(ne(lengthset(jset),0)) { + "*" + set(seeabove, lookup(atable, key(child))) + if(eq(seeabove,0)) { + if(eq(desc,0)) { + enqueue(ilist, child) + set(desc,1) + } + else { + set(altdesc,1) + } + } + deletefromset(jset, child, 1) + } + deletefromset(iset, child, 1) + /* + forindiset(aset, ancestor, junkval, junknum) { + if(eq(child, ancestor)) { + "*" + if(eq(desc,0)) { + enqueue(ilist, child) + set(desc,1) + } + else { + set(altdesc,1) + } + break() + } + } + */ + } + if(ne(strcmp(surname(child), + surname(father(child))),0)) { + name(child) + } + else { givens(child) } + if(seeabove) { + call addtoindex(child, part, gnum) + " [See Line " d(div(seeabove,1000)) + " Generation " d(mod(seeabove,1000)) " above]" + set(needindent, 1) + } + if(eq(altdesc,1)) { + if(down) { set(tnum, sub(gnum, 1)) } + else { set(tnum, add(gnum, 1)) } + enqueue(alist, child) + enqueue(plist, part) + enqueue(glist, tnum) + set(acount, add(acount,1)) + " [See Line " d(acount) + " Generation " d(tnum) " below]" + set(needindent, 1) + } + } + nl() + } + } + if(down) { set(gnum, sub(gnum, 1)) } + else { set(gnum, add(gnum, 1)) } + } + if(sour_exists()) { + nl() "References: " + call sour_see(",", 70, 13) + call sour_save(allsour_table, allsour_list) + nl() + } + } + if(eq(allanc,0)) { break() } + } + } + /* list all references */ + call sour_restore(allsour_table, allsour_list) + if(sour_exists()) { + nl() "Key to References:" nl() nl() + call sour_ref(10) + } + /* generate an index */ + call reportindex() + call reportalias() + } +} + +/* report the index */ + +proc reportindex() +{ + print(nl(), "Index: ", d(lengthset(aset)), " people, ") + print(d(xlen), " entries...") + nl() "Index" nl() nl() + namesort(aset) + forindiset(aset, indi, ival, inum) { + if(xref, lookup(xtable, key(indi))) { + surname(indi) ", " givens(indi) + col(30) key(indi) + col(40) xref nl() + } + } +} + +/* add to the index */ + +proc addtoindex(indi, part, gnum) +{ + if(xref, lookup(xtable, key(indi))) { + set(xref, save(concat(xref, ",", save(d(part)), "-", save(d(gnum))))) + } + else { + set(xref, save(d(part))) + set(xref, save(concat(xref, "-", save(d(gnum))))) + set(xlen, add(xlen, 1)) + } + insert(xtable, save(key(indi)), xref) +} + +/* report all of a person's titles */ + +proc titles(i) +{ + fornodes (inode(i), n) { + if (eqstr(tag(n), "TITL")) { + value(n) " " + } + } +} + +proc titledname(i) +{ + fornodes (inode(i), n) { + if (eqstr(tag(n), "TITL")) { + if(or(eqstr(value(n), "Sir"), + eqstr(value(n),"Rev."))) { + value(n) " " + } + } + } + name(i) + fornodes (inode(i), n) { + if (eqstr(tag(n), "TITL")) { + if(not(or(eqstr(value(n), "Sir"), + eqstr(value(n),"Rev.")))) { + " " value(n) + } + } + } +} + +/* report all places */ + +proc allplaces(person, colnum) +{ + traverse(inode(person), node, lev) { + set(prefix, "") + if (eqstr(tag(node),"RESI")) { set(prefix, "r. ") } + elsif (eqstr(tag(node),"LIVE")) { set(prefix, "lv. ") } + elsif (eqstr(tag(node),"BIRT")) { set(prefix, "b. ") } + elsif (eqstr(tag(node),"CHR")) { set(prefix, "bp. ") } + elsif (eqstr(tag(node),"DEAT")) { set(prefix, "d. ") } + elsif (eqstr(tag(node),"BURI")) { set(prefix, "bur. ") } + if(gt(strlen(prefix), 0)) { + set(edate,save(long(node))) + if (strlen(edate)) { + if(gt(colnum, 0)) { col(colnum) } + prefix edate nl() + } + } + } +} + +/* report all notes */ + +proc allnotes(person, colnum) +{ + fornodes(inode(person), node) { + if (eq(0,strcmp("NOTE", tag(node)))) { + if(gt(colnum, 0)) { col(colnum) } + value(node) nl() + fornodes(node, subnode) { + if (eq(0,strcmp("CONT", tag(subnode)))) { + if(gt(colnum, 0)) { col(colnum) } + value(subnode) nl() + } + } + } + } +} + +/* report aliases */ + +proc reportalias() +{ + print(nl(), "Aliases...") + nl() "Alias" col(30) "Key" col(40) "Name" nl() nl() + + /* assume that the set is already sorted. see reportindex() */ + + forindiset(aset, indi, ival, inum) { + set(count, 0) + fornodes(inode(indi), subnode){ + if(eqstr(tag(subnode), "NAME")){ + incr(count) + if(ge(count, 2)){ + list(np) + extractnames(subnode, np, nc, sc) + /* process the surname first */ + if(sc) { + set(sn, getel(np, sc)) + if(eq(strlen(sn), 0)) { "____," } + else { sn "," } + } + else { "____," } + /* process the rest of the name */ + forlist(np, v, i) { + if(ne(i, sc)) { " " v } + } + col(30) key(indi) + col(40) + surname(indi) ", " givens(indi) + nl() + } + } + } + } +} + +/* output the parents of a person if it is a simple family where the + father and mother have only one family and this is their only + child, and their parents are not known. + */ + +proc simplefam(indi, indent) +{ + set(findi, father(indi)) + set(mindi, mother(indi)) + set(simple, or(ne(findi,0), ne(mindi,0))) + if(simple) { + if(findi) { + if(or(father(findi), mother(findi))) { set(simple,0) } + elsif(ne(nfamilies(findi),1)) { set(simple,0) } + else { + families(findi, fam, sps, fnum) { + if(ne(nchildren(fam),1)) { set(simple, 0) } + } + } + } + } + if(simple) { + if(mindi) { + if(or(father(mindi), mother(mindi))) { set(simple,0) } + elsif(ne(nfamilies(mindi),1)) { set(simple,0) } + else { + families(mindi, fam, sps, fnum) { + if(ne(nchildren(fam),1)) { set(simple, 0) } + } + } + } + } + if(simple) { + nl() " [" + if(male(indi)) { "son of " } + else { "daughter of " } + if(findi) { + call addtoindex(findi, part, gnum) + if(allanc) { deletefromset(tset, findi, 1) } + call titledname(findi) + if(mindi) { nl() " and " } + } + if(mindi) { + call addtoindex(mindi, part, gnum) + if(allanc) { deletefromset(tset, mindi, 1) } + call titledname(mindi) + } + "]" + if(indent) { nl() " " } + } +} + +/* find the generation number for an individual */ + +func findgen(aindi, down, maxgen, first) +{ + list(tilist) + indiset(tiset) + indiset(tjset) + + enqueue(tilist, aindi) + set(gnum, 0) + set(tnum, 0) + if(eq(first,0)) { + while(indi, dequeue(tilist)) { + set(tnum, lookup(atable, key(indi))) + if(ne(tnum,0)) { + call dumpindi("person", indi, tnum, gnum) + set(tnum, mod(tnum,1000)) + break() + } + set(desc, 0) + families(indi, fam, sps, fnum) { + if(sps) { + set(tnum, lookup(atable, key(sps))) + if(ne(tnum,0)) { + call dumpindi("spouse", sps, tnum, gnum) + set(tnum, mod(tnum,1000)) + break() + } + } + if(gt(nchildren(fam),0)) { + children(fam, child, cnum) { + set(tnum, lookup(atable, key(child))) + if(ne(tnum,0)) { + set(gnum, add(gnum, 1)) + call dumpindi("child", child, tnum, gnum) + set(tnum, mod(tnum,1000)) + break() + } + if(eq(desc,0)) { + addtoset(tiset, child, 0) + set(tjset, intersect(aset, tiset)) + deletefromset(tiset, child, 1) + if(ne(lengthset(tjset),0)) { + deletefromset(tjset, child, 1) + set(desc, 1) + enqueue(tilist, child) + } + } + } + } + if(tnum) { break() } + } + if (tnum) { break() } + set(gnum, add(gnum, 1)) + } + } + set(ngen, 0) + if(tnum) { + if(down) { + set(ngen, add(tnum, gnum)) + } + else { + set(ngen, sub(tnum, gnum)) + } + } + if(down) { + set(ogen, maxgen) + } + else { + set(ogen, 1) + } + if(eq(ngen, 0)) { set(ngen, ogen) } + return(ngen) +} + +/* dump a previously referenced individual to show basis of generation + number of new line + */ + +proc dumpindi(type, indi, tnum, gnum) +{ + nl() + "...The generation numbers of the next line are based on " type nl() + " " name(indi) + " " d(div(tnum,1000)) "-" d(mod(tnum,1000)) + " " d(gnum) " generations below" nl() +} diff --git a/reports/rllgen.ll b/reports/rllgen.ll new file mode 100644 index 0000000..ece757d --- /dev/null +++ b/reports/rllgen.ll @@ -0,0 +1,215 @@ +/* + * @progname rllgen.ll + * @version 1.0 + * @author Eggert + * @category + * @output RLL format + * @description + +A LifeLines report program to aid in the generation of +Roots Location List (RLL) submissions. +Given a person, this generates a RLL-like submission for that person and +his/her ancestors. The output will likely need considerable hand editing, +but that is how it is. If you need to know what the RLL is, I have enclosed +a description at the end of this file. + + +Version 1, 18 November 1994, by Jim Eggert, eggertj@ll.mit.edu + Requires LifeLines 3.0.1 or higher + +This program will work better if you follow strict placename +conventions. You should probably run the places report program first +to see if your placenames are in good shape. + +Here's what you will need to do by hand (you can consider this a list +of desired features for future versions of this report program): + +BEFORE YOU RUN THE PROGRAM: + +Change the routine write_rll_header() to use your submitter tag, name, +and address. You may also want to change the personset calculation in +the beginning of the main routine. + +AFTER YOU RUN THE PROGRAM: + +Sort the location portion of the output file. +Eliminate empty or useless location lines. +Use RLL-standard abbreviations for placenames. + - get FAMILY ABBREV as per instructions at end of this file. +Combine duplicate location lines where appropriate. +Check check check. +Send the final product to the RLL maintainer. + - see the end of this file. + +*/ + +global(placefirst) +global(placelast) +global(placelist) +global(submitter_tag) + +/* write_rll_header sets the submitter tag and + writes a little header for the RLL list maintainer + */ + +proc write_rll_header() { + set(submitter_tag,"jqpublic") + + "Roots Location List (RLL) submission of " date(gettoday()) + " by John Q. Public\n\n" + submitter_tag + col(12) "John Q. Public, jqpublic@my.node.address\n" + col(12) "1234 North Maple, Homesville, OX 12345-6789, USA\n\n" +} + + +proc addplace(node) { + set(placename,save(value(node))) + set(pyear,atoi(year(parent(node)))) + if (not(pyear)) { set(pyear,neg(1)) } + set(firstyear,lookup(placefirst,placename)) + if (and(gt(firstyear,0),gt(pyear,0))) { + set(lastyear,lookup(placelast,placename)) + if (lt(pyear,firstyear)) { insert(placefirst,placename,pyear) } + elsif (gt(pyear,lastyear)) { insert(placelast,placename,pyear) } + } + if (and(lt(firstyear,0),gt(pyear,0))) { + insert(placefirst,placename,pyear) + insert(placelast,placename,pyear) + } + if (eq(firstyear,0)) { + insert(placefirst,placename,pyear) + insert(placelast,placename,pyear) + enqueue(placelist,placename) + } +} + +/* write_rll_entry writes one line in the rll submission */ + +proc write_rll_entry(placename) { + list(tokenlist) + set(firstyear,lookup(placefirst,placename)) + set(lastyear,lookup(placelast,placename)) + extracttokens(placename,tokenlist,ntokens,",") + set(comma,0) + while(token,pop(tokenlist)) { + if(comma) { "," } + token + set(comma,1) + } + " " + if (gt(firstyear,0)) { + d(firstyear) + if (gt(lastyear,firstyear)) { "-" d(lastyear) } + " " + } + submitter_tag "\n" +} + + +proc main() { + table(placefirst) + table(placelast) + indiset(personset) + list(placelist) + + getindi(person) + print("Forming set...") + addtoset(personset,person,0) + set(personset,ancestorset(personset)) + addtoset(personset,person,0) + print("done\nComputing places...") + set(nextpnum,0) + + forindiset (personset, person, pval, pnum) { + if (ge(pnum,nextpnum)) { + print(" ",d(pnum)) + set(nextpnum,add(nextpnum,100)) + } + traverse (inode(person), node, level) { + + if (eq(strcmp(tag(node), "PLAC"), 0)) { call addplace(node) } + } + + families (person, fam, sp, fnum) { + if (or(not(husband(fam)), eq(person, husband(fam)))) { + + traverse (fnode(fam), node, level) { + + if (eq(strcmp(tag(node), "PLAC"), 0)) { + call addplace(node) + } + } + } + } + } + print(" done\nWriting places...") + call write_rll_header() + set(nextpnum,0) + forlist(placelist,placename,pnum) { + if (ge(pnum,nextpnum)) { + print(" ",d(pnum)) + set(nextpnum,add(nextpnum,100)) + } + call write_rll_entry(placename) + } +} + +/* +To: ROOTS-L Genealogy List +Subject: ROOTS LOCATION LIST, September, 1994 + +Next location list on 3rd Sunday in November. (Deadlines for +submissions are generally the preceding Friday.) + + ## WHAT IS THE ROOTS LOCATION LIST?## + +- The Roots Location List is compiled from locations e-mailed to me +by network people doing genealogical research in a particular +location and who are willing to exchange information. The idea is +that, if you had ancestors living in the same place in the same +period, it might be beneficial to compare notes -- maybe you and +the submitter are kinfolk or maybe you can help each other track +down unique sources dealing with the area. + + +-This list should not be confused with the ROOTS SURNAME LIST that +is maintained by Karen Isaacson in other files. If you are +confused, send a message to: listserv@vm1.nodak.edu In the body +of your message put: GET FAMILY INDEX. This will show you all of +the files in this part of the genealogy files. + + ## HOW CAN I PARTICIPATE IN THE ROOTS LOCATION LIST? ## + +- Send additions or corrections to me at AHCSBB@ukcc.uky.edu. Write +to me if you have general questions about the list. I will +acknowledge (or attempt to acknowledge) all submissions. + +Entries are formatted as follows: + +Location/Date1-Date2/nametag +Date1 is the earliest date for which the submitter has information. +Date2 is the most recent date. + + ## HOW DO I CONTACT SOMEONE ON THE LIST? ## + +- Write directly to the submitter if you would like to exchange +information. + +-To contact the submitter of the information, use the nametag to +find the address of the submitter in the address list - FAMILY +LOCADDR. The addresses of the submitters are in a separate file on +the listserver. To obtain them, send a one line message: GET +FAMILY LOCADDR + +A list of the abbreviations used is available directly from the +listserver: send e-mail to LISTSERV@vm1.nodak.edu or +LISTSERV@NDSUVM1, with a one-line message that states: + +GET FAMILY ABBREV + +Include no other text, and leave the subject line blank. The +listserver will return by e-mail the list of abbreviations. Or +you can use anonymous FTP to vm1.nodak.edu + +*/ diff --git a/reports/rootset.ll b/reports/rootset.ll new file mode 100644 index 0000000..1fec061 --- /dev/null +++ b/reports/rootset.ll @@ -0,0 +1,39 @@ +/* + * @progname rootset.ll + * @version 0.5 + * @author Robert Simms + * @category + * @output Text + * @description + + Given a list of surnames, finds the set of all people with those + surnames, then reports on the heads of each line within that set. +*/ +proc main() { + indiset(rootset) + indiset(tempset) + + getstr(surname, "Specify a surname") + while(nestr(surname, "")) { + genindiset(concat("*/", surname), tempset) + set(rootset, tempset) + getstr(surname, "Specify another surname [return if done]") + } + + set( tempset, childset(rootset)) + set( rootset, difference(rootset, tempset)) + call lprintset(rootset) + call printset(rootset) +} + +proc printset(x) { + forindiset(x, x_ind, y, x_n) { + key(x_ind) " - " name(x_ind) nl() + } +} + +proc lprintset(x) { + forindiset(x, x_ind, y, x_n) { + print(key(x_ind), " - ", name(x_ind), nl()) + } +} diff --git a/reports/rslgen.ll b/reports/rslgen.ll new file mode 100644 index 0000000..3b97378 --- /dev/null +++ b/reports/rslgen.ll @@ -0,0 +1,358 @@ +/* + * @progname rslgen.ll + * @version 1.1 + * @author Eggert + * @category + * @output RSL format + * @description Generate a Roots Surname List (RSL) submission + +rslgen - a LifeLines report program to aid in the generation of +Roots Surname List (RSL) submissions. + +Given a person, this generates a RSL-like submission for that person and +his/her ancestors. The output will likely need considerable hand editing, +but that is how it is. If you need to know what the RSL is, I have enclosed +a description at the end of this file. + +Here's what you will need to do by hand (you can consider this a list +of desired features for future versions of this report program): + +BEFORE YOU RUN THE PROGRAM: + +Change the routine write_rsl_header() to use your submitter tag, name, +and address. + +AFTER YOU RUN THE PROGRAM: + +Sort the surname portion of the output file. +Eliminate empty or useless surname lines. +Use RSL-standard abbreviations for placenames. + - get FAMILY ABBREV as per instructions at end of this file. +Combine duplicate surname lines where appropriate. +Check check check. +Send the final product to the RSL maintainer. + - see the end of this file. + +Version 1, 14 July 1994, by Jim Eggert, eggertj@ll.mit.edu + +*/ + +global(year_min) +global(year_max) +global(submitter_tag) +global(location) +global(last_location) +global(location_list) +global(location_table) +global(see_surname_table) +global(rsl_entry_count) + +/* write_rsl_header sets the submitter tag and + writes a little header for the RSL list maintainer + */ + +proc write_rsl_header(person) { + set(submitter_tag,"dummy_tag") + + "Roots Surname List (RSL) submission of " date(gettoday()) + " submitted by John Q. Public\n\n" + submitter_tag + col(12) "John Q. Public noname@nowhere.nohow\n" + col(12) "1234 56th Street, Anytown AM 54321\n\n" +} + + +proc main() { + list(ilist) + table(see_surname_table) + + getindi(person) + + call write_rsl_header(person) + set(rsl_entry_count,0) + + enqueue(ilist,person) + while (person,dequeue(ilist)) { + table(location_table) + list(location_list) + + set(year_min,9999) set(year_max,0) + call locations_and_years(person) + set(final_key,save(key(person))) + set(final_surname,save(surname(person))) + + if (m,mother(person)) { enqueue(ilist,m) } + + while (person,father(person)) { + if (m,mother(person)) { enqueue(ilist,m) } + call locations_and_years(person) + set(this_surname,surname(person)) + if (strcmp(this_surname,final_surname)) { + set(see_name,0) + if (other_surname,lookup(see_surname_table,this_surname)) { + if (strcmp(final_surname,other_surname)) { + set(see_name,1) + } + } + else { + set(see_name,1) + set(other_surname,final_surname) + } + if (see_name) { + this_surname " - see " final_surname + " (" submitter_tag ")\n" + insert(see_surname_table, + save(this_surname),save(other_surname)) + } + } + } + call write_rsl_entry(final_key) + } + if (gt(rsl_entry_count,100)) { + print("Warning: Number of lines produced (") + print(d(rsl_entry_count)) + print(")\nexceeds recommended submission limit (100)\n") + } +} + + +/* write_rsl_entry writes one line in the rsl submission */ + +proc write_rsl_entry(key_entry) { + if (key_entry) { + set(surname_entry,save(surname(indi(key_entry)))) + if (strlen(surname_entry)) { + if (strcmp(trim(surname_entry,1),"_")) { + set(rsl_entry_count,add(rsl_entry_count,1)) + set(not_first,0) + surname_entry col(14) d(year_min) + col(20) d(year_max) " " + while (loc,dequeue(location_list)) { + if (not_first) { ">" } else { set(not_first,1) } + loc + } + " " submitter_tag " " key_entry "\n" + } + } + } +} + + +/* locations_and_years figures out unique locations and min/max years + for a person with respect to other persons already figured. + Note that the events are processed in reverse chronological order, + because the ancestry is traced bottom up. Oh well... + */ + +proc locations_and_years(person) { + list(marriage_list) + + call one_location_and_year(burial(person)) + call one_location_and_year(death(person)) + families(person,family,spouse,fnum) { + push(marriage_list,marriage(family)) + } + while (event,pop(marriage_list)) { call one_location_and_year(event) } + call one_location_and_year(baptism(person)) + call one_location_and_year(birth(person)) +} + + +/* one_location_and_year appends the event location to the global + location list if it is new, and figures the event year into the + global min and max values. + */ + +proc one_location_and_year(event) { + if (event) { + set(loc,place(event)) + if (strlen(loc)) { + if (not(lookup(location_table,loc))) { + requeue(location_list,save(loc)) + insert(location_table,save(loc),1) + } + } + if (yr,atoi(year(event))) { + if (lt(yr,year_min)) { set(year_min,yr) } + if (gt(yr,year_max)) { set(year_max,yr) } + } + } +} + +/* + ### WHAT IS IT? ### + +The Roots Surname List (RSL) helps genealogical researchers share and +compare data. Genealogists with Internet access are welcome to submit +surnames that they are researching for inclusion in the Roots Surname +List if they are willing to share their data with others who may be +doing parallel research. Enough information should be provided so that +others can decide whether a link with their own lines is possible or +probable. The assumption is that you have SOME data to share. You +needn't be on the verge of writing the definitive genealogy for the +family in question. + +If you see a surname listed that interests you, contact the person who +submitted the surname. To do that, just look up their nametag (listed +at the end of each surname entry) in the list of submitters. The +FAMILY INDEX, described below, has instructions on how to obtain the +list of submitters. Unless the submitter happened to be me, I won't be +of much help. + +The =update= to the RSL is posted to ROOTS-L (the Internet genealogy mailing +list) and to soc.roots (the USENET genealogy newsgroup) +on the first Sunday of the month. At the same time, the entire +new RSL is stored on the listserver. See below for instructions on +obtaining a copy from the listserver or via mail if you don't have access +to the listserver. The update and sometimes the full RSL also propagates +after that to the genealogy libraries on CompuServe, GEnie, and Delphi. +Included in the posted update is contact information for the submitters of +the new and updated info. + + ### OBTAINING THE ENTIRE LIST ### + + +To obtain a copy of the full Roots Surname List (RSL) from the listserver, +the first step is to send e-mail to LISTSERV@vm1.nodak.edu or +LISTSERV@NDSUVM1, with the one-line message (not in the subject line): + + GET FAMILY INDEX + +You will receive by e-mail a list of the names of the various files +comprising the current RSL. The files named in FAMILY INDEX may change +each month, so be sure to use a current one! The files listed there may +be obtained in the same manner as you obtained FAMILY INDEX. (That is, by +sending e-mail to the LISTSERV address with the GET message.) If you have +access to FTP, you can instead use anonymous FTP to vm1.nodak.edu +(134.129.111.1) and do "cd ROOTS-L" then "get FAMILY.INDEX" to retrieve +the file. Don't FTP it in binary mode, but instead in text mode. + +If you are unable to retrieve the RSL via e-mail or via FTP, you can +receive a copy by sending $5 to: + Brian Leverich + 27991 Caraway Lane + Saugus, CA 91350 +Requests MUST include a description of the computer you use (DOS or Mac) +and the highest capacity diskette you can read (360kb, 720kb, 1.2mb, +1.44mb, etc.). If you need something other than DOS or Mac, inquire +first: if Brian can't handle your particular format, maybe someone else +here can. + + ### SUBMITTING NEW ENTRIES ### + +Please READ THIS SECTION ***CAREFULLY*** BEFORE SUBMITTING. I receive +submissions and handle correspondence about the RSL over long distance +telephone lines, and I cannot afford the time and money wasted by +improperly formatted or otherwise inappropriate submissions. + + ** BASIC GUIDELINES ** + +Send new entries to me at one of the addresses listed at the end of this +note. Entries received will be included in the next list. See below +for format information. PLEASE follow these guidelines: + + o Send ordinary text files. Please do not compress, zip, + uuencode, or MIME encode your file. + + o Be sure to submit "how to reach you" information as well as + surnames. + + o Do not submit more than 100 surnames. + + o Do =not= put your surnames in CAPS. + + o Follow the formatting rules below with religious fervor. + + o AND NO TINY TAFELS. They don't conform to the RSL format, and + they don't contain the sort of information needed for the RSL. + If you have a Tiny Tafel and want to put it to good use, I + believe Brian Mavrogeorge, will enter it in the Fidonet TMS + (Tafel Matching System) database if you post it to soc.roots + or Roots-L. (If you don't know what a Tiny Tafel is, you're + probably in no danger of sending me one accidentally.) + + ** FORMATTING YOUR "HOW TO REACH YOU" INFORMATION ** + +For each submitter, I must receive one or two lines of address +information which tell readers how they can reach the person who +submitted the entry. The format is fairly flexible, but must include a +short nametag (less than eight characters, all lower case) and should +typically include all your e-mail and postal addresses. (If you're +nervous about broadcasting your postal address to the universe, though, +feel free to leave it off.) If the nametag you select has already been +taken, I'll conjure up a new one for you. Or feel free to suggest +alternates at the time of your submission. + +The lines for karen (me) are: +karen Karen Isaacson, karen@rand.org, Prodigy: XRBV26B, GEnie: KRENA + 27991 Caraway Lane, Saugus, CA 91350 Delphi: KRENA + + ** FORMATTING YOUR SURNAME INFORMATION ** + +What should the surname entries look like? Don't worry too much about +format -- I end up reformatting them anyhow for my sort routine. But +please do conform to the general guidelines below. Also, despite all +genealogical advice to the contrary, DO NOT put the surnames all in +capital letters. The RSL does not use surnames in all CAPs. (Don't +put them all in lower case, either, though, just do them like in the +example below.) + +Each entry should be on one line, and consists of five parts: +1. The name of the family. +2. The earliest date for which you have information about the family. + (For instance, the birthdate of the founder of the family, or the year + he or she first showed up in the records.) +3. The latest date for which you have information about the family. (When + the last person with that surname died or skipped town, for instance. + Or "now" if you know people of this surname that are still around -- + yourself, for example. It's up to you whether a woman is considered + under her maiden surname, married surname, or both.) +4. The migration of the family. For instance, if my ancestors started out + in Virginia, moved to Kentucky, then on to Missouri, this would be + VA>KY>MO,USA. If the surname was common, and I still had room (remember, + all four fields should fit on one line), then I might add some county + information to further distinguish them: OrangeCo,VA>KY>GentryCo,MO,USA. + There is a list of most of the abbreviations that are in use. It is in + a file called FAMILY ABBREV, and can be obtained in the same manner as + FAMILY INDEX, discussed above. Or just spell out the location, and I'll + put in the proper abbreviation, if any. +5. The nametag of the submitter. This is so you can be found in the address + list. See discussion above for how to select one. + +The Roots Surname Index is rather oddly computerized. There aren't any +firm restrictions on the presentation of the data, but do try to use +something like the format suggested above and illustrated below. + +Here are a few (genuine!) sample entries (my own, funny thing): + + Bell 1780 1940 OrangeCo,VA>KY>GentryCo,MO,USA karen + Carr - see Kerr (karen) + Keithley c1750 1923 DEU>PA?>RowanCo,NC>BathCo,KY>FloydCo,IN,USA karen + Keithley c1750 1923 DEU>PA?>RowanCo,NC>KY>StCharlesCo,MO,USA karen + Kerr 1760 now HuntingdonCo,PA>VenangoCo,PA>IA,USA karen + Kicheli - see Keithley (karen) + + ** WHEN TO SUBMIT ** + +Try to get your additions or modifications in to me by the Thursday before +the first Sunday of each month, when the monthly update is published. +If you miss a deadline, not to worry: your surnames will have arrived in +time for the next deadline and will be included in the next month's list. + + ** WHERE TO SUBMIT ** + +How can I be reached? At one of the following addresses: + + Internet: karen@rand.org <- preferred + krena@genie.geis.com + xrbv26b@prodigy.com + bi254@cleveland.freenet.edu + kisaacson@mcimail.com + GEnie or Delphi: KRENA + Prodigy: XRBV26B + Postal: Karen Isaacson + 27991 Caraway Lane + Saugus, CA 91350 + + +*/ diff --git a/reports/rtflib.li b/reports/rtflib.li new file mode 100644 index 0000000..80dbd42 --- /dev/null +++ b/reports/rtflib.li @@ -0,0 +1,696 @@ +/* + * @progname rtflib.li + * @version 1.1 + * @author Doug McCallum + * @category + * @output RTF + * @description + * + * RTF functions for implementing RTF output + * this allows generating Word or other + * documents directly. + * + */ +global(rtf_termstring) +global(rtf_tcols) +global(rtf_row_width) +global(rtf_row_left) +global(rtf_set_cols) +global(rtf_col_sizes) +global(rtf_pointsize) +global(rtf_pstate) +global(rtf_curr_indent) +global(rtf_tstate) +global(rtf_cstate) +global(rtf_ccol) +global(twips) /* 20 points per inch */ +global(rtf_bspace) +global(rtf_aspace) +global(rtf_ftn_last_tag) /* last footnote tag */ +global(rtf_ftn_state) + +/* + * Initialize the RTF state machine and variables + */ + +/* + * rtf_init(font) + * initialize the RTF state. + * set font as the default font to use (not working yet) + */ +proc rtf_init(font) +{ + set(twips, 1440) + list(rtf_pointsize) + setel(rtf_pointsize, 1, 24) /* style 1 at 12pt */ + setel(rtf_pointsize, 2, 18) /* style 2 at 9pt */ + setel(rtf_pointsize, 3, 20) /* style 3 at 10pt */ + set(rtf_curr_indent, 0) /* no paragraph indent */ + + /* some table state */ + set(rtf_ccol, 0) + set(rtf_pstate, 0) + set(rtf_cstate, 0) + list(rtf_col_sizes) + set(rtf_set_cols, 0) + + /* all RTF files need this */ + "{\\rtf1\\ansi\\deff2{\\fonttbl{\\f10\\fnil " + font + ";}}\n" + "{\\stylesheet{\\fs20\\basedon222\\snext0\\f10 Normal;}\n" + "{\\s1\\fs24\\basedon0\\snext3\\f10\\b\\sb240\\sa60 Heading;}\n" + "{\\s2\\basedon1\\fs20\\f10\\up Footnote;}\n" + "{\\s3\\basedon222\\snext3\\f10\\fs20\\sb120\\sa10 Text;}\n" + /* you can add new styles here */ + "}\n" + set(rtf_termstring, "\n\\par}\n") + monthformat(4) + dayformat(0) + dateformat(5) /* nn-MON-yyyy */ +} + +/* + * rtf_open(file) + * just do some setup. If "file" defined, open it. + */ +proc rtf_open(file) +{ + if (file) { + newfile(file, 0) + } + call rtf_init("Palatino") +} + +/* + * rtf_close() + * closes open tables and paragraphs then + * adds the closing bracket for the document + */ +proc rtf_close() +{ + call rtf_tend() + call rtf_pend() + rtf_termstring +} + +/* + * rtf_set_page_size(height, width, left, right, top, bot) + * set the page size if non-standard size is desired. + * height and width are paper size + * left, right, top and bot are the margin sizes + * sizes in twips (20pts/inch :: 1440 == 1inch) + */ +proc rtf_set_page_size(height, width, left, right, top, bot) +{ + "\\paperw" d(width) + "\\paperh" d(height) + "\\margl" d(left) + "\\margr" d(right) + "\\margt" d(top) + "\\margb" d(bottom) nl() +} + +/* + * rtf_newpage() + * insert a forced pagebreak at this point + */ +proc rtf_newpage() +{ + "\\page " +} + +/* + * paragraph functions + * there are a number of options here + */ + +/* + * rtf_pstart(type) + * start a new paragraph with the style selected + */ +proc rtf_pstart(type) +{ + /* if in a paragraph, end it */ + if (eq(rtf_pstate, 1)) { + call rtf_pend() + } + set(rtf_pstate, 1) + "\\pard {\\s" d(type) + if (ps, getel(rtf_pointsize, type)) { + "\\fs" d(ps) " " + } + + call rtf_para_space(rtf_bspace, rtf_aspace) + + if (gt(rtf_curr_indent, 0)) { + /* "next" paragraph */ + call rtf_para_indent(0, rtf_curr_indent) + } +} + +/* + * rtf_pend() + * end the current paragraph + * this is for completeness but a new pstart will do it + * so it is optional + */ +proc rtf_pend() +{ + if (eq(1, rtf_pstate)) { + "\\par}\n" + set(rtf_pstate, 0) + } +} + +/* + * rtf_para_indent(first, all) + * tagged/indented paragraphs + * should be called right after a rtf_pstart() + * to select the indent of the first and remaining lines + * Note that the first line is also indented the same as + * all but can have more or less indent applied + * typical is to have first be the neg of the all + * a tab will make a hanging indent in that case + */ +proc rtf_para_indent(first, all) +{ + if (or(gt(first, 0), gt(all, 0))) { + "\\li" d(all) "\\fi" + d(first) + "\\tx" d(all) " " + } + set(rtf_curr_indent, all) +} + +/* + * rtf_para_space(before, after) + * amount of white space before and after a paragraph + */ +proc rtf_para_space(before, after) +{ + if (rtf_pstate) { + if (ne(before, 0)) { + "\\sb" d(before) + } else { + "\\sb" d(mul(getel(rtf_pointsize, 3), 5)) + } + if (ne(after, 0)) { + "\\sa" d(after) + } + } + set(rtf_bspace, before) + set(rtf_aspace, after) +} + +/* + * rtf_para_keepnext() + * causes current paragraph to be kept on same page as + * the next paragraph + */ +proc rtf_para_keepnext() +{ + "\\keepn " +} + +/* + * rtf_para_centered() + * make the current paragraph text be centered + */ +proc rtf_para_centered() +{ + "\\qc " +} + +/* + * rtf_para_leftjust() + * make the current paragraph text left justified + */ +proc rtf_para_leftjust() +{ + "\\ql " +} + +/* + * rtf_para_rightjust() + * make the current paragraph text right justified + */ +proc rtf_para_rightjust() +{ + "\\qr " +} + +/* + * rtf_para_keepintact() + * don't try to break this paragraph across pages + */ +proc rtf_para_keepintact() +{ + "\\keep " +} + +/* + * rtf_set_info(title, subject, author, operator, created) + * set the file's info section to have the values specified + */ +proc rtf_set_info(title, subject, author, operator, created) +{ + "{\\info\n" + if (title) { + "{\\title " title "}\n" + } + if (subject) { + "{\\subject " subject " }\n" + } + if (author) { + "{\\author " author "}\n" + } + if (operator) { + "{\\operator " operator "}\n" + } + if (created) { + + set(yr, save(substring(created, 1, 4))) + set(mo, save(substring(created, 6, 7))) + set(dy, save(substring(created, 9, 10))) + "{\\creatim\\yr" yr + "\\mo" mo + "\\dy" dy "}\n" + } + "{\\doccomm Document generated from LifeLines " + version() + " database " + database() "by register-rtf 1.1.}\n" + "}\n" +} + +/* + * table functions + * there are a number related to rows and cells + */ + +/* + * rtf_set_row_width(cols, wid) + * set the table row width and number of columns to expect + */ +proc rtf_set_row_width(cols, wid) +{ + set(rtf_tcols, cols) + set(rtf_row_width, sub(wid, mul(sub(rtf_tcols, 1), 108))) + set(rtf_row_left, rtf_row_width) +} + +/* + * rtf_set_col_width(wid) + * set the current column width + * called once for each column defined + */ +proc rtf_set_col_width(wid) +{ + if (lt(rtf_set_cols, rtf_tcols)) { + setel(rtf_col_sizes, one(rtf_set_cols), wid) + incr(rtf_set_cols) + set(rtf_row_left, sub(rtf_row_left, wid)) + set(i, rtf_set_cols) + while (lt(i, rtf_tcols)) { + setel(rtf_col_sizes, one(i), + div(rtf_row_left, sub(rtf_tcols, rtf_set_cols))) + incr(i) + } + } +} + +/* + * rtf_tstart(cells) + * start table with cells per row + */ +proc rtf_tstart(cells) +{ + if (eq(rtf_tstate, 1)) { + call rtf_tend() + } + call rtf_pend() + "\\trowd " + set(rtf_tstate, 1) + "\\trgaph" d(108) + "\\trleft" d(neg(108)) + set(i, 0) + set(cumwid, 0) + while (lt(i, cells)) { + if (gt(i, 0)) { + set(gap, 108) + } else { + set(gap, 0) + } + set(gap, add(gap, getel(rtf_col_sizes, one(i)))) + set(cumwid, add(cumwid, gap)) + "\\cellx" d(cumwid) "\n" + set(i, add(i, 1)) + } + set(rtf_tcols, cells) + "\\pard\\plain\\s3\\intbl " +} + +/* + * rtf_tend() + * end table + */ +proc rtf_tend() +{ + if (rtf_tstate) { + while (lt(rtf_ccol, rtf_tcols)) { + rtf_cend() + } + "\\intbl\\row\\pard\\s3 " + set(rtf_tstate, 0) + } +} + +/* + * rtf_cstart() + * start a cell in a table + */ +proc rtf_cstart() +{ + if (rtf_cstate) { + call rtf_cend() + } + call rtf_pend() + "\\fs" d(getel(rtf_pointsize, 3)) + set(rtf_cstate, 1) +} + +/* + * rtf_cend() + * end a cell + */ +proc rtf_cend() +{ + if (or(rtf_cstate, rtf_tstate)) { + set(rtf_cstate, 0) + "\n\\cell " + set(rtf_ccol, add(rtf_ccol, 1)) + } +} + +/* + * rtf_cpar() + * insert a paragraph break inside a cell + */ +proc rtf_cpar() +{ + "\\par " +} + +/* + * rtf_endrow() + * end a table row and get ready for next one + */ +proc rtf_endrow() +{ + if (rtf_tstate) { + while (lt(rtf_ccol, rtf_tcols)) { + call rtf_cend() + } + "\\pard\\s3\\inttbl\\row " + set(rtf_tstate, 0) + call rtf_tstart(rtf_tcols) + set(rtf_ccol, 0) + } +} + +/* heading handling */ + +/* + * rtf_hstart() + * start a heading + */ +proc rtf_hstart() +{ + "\\sb" d(mul(getel(rtf_pointsize, 1), 12)) + "\\sa" d(mul(getel(rtf_pointsize, 1), 6)) " " + "{\\tc\\s1\\b " +} + +/* + * rtf_hend() + * end a heading + */ +proc rtf_hend() +{ + "\\b0}\n" +} + +/* + * rtf_index(key, subkey, type) + * create an index entry + * if subkey is defined, a two level index is + * created. e.g. + * McCallum + * Charles 1 + * the type is plain = 0, bold = 1 and italic = 2 + */ +func rtf_index(key, subkey, type) +{ + if (eq(type, 0)) { + set(var, "}}\n") + } elsif (eq(type, 1)) { + set(var, "\\bxe}}\n") + } elsif (eq(type, 2)) { + set(var, "\\ixe}}\n") + } + set(ind, concat("{\\xe{\\v ", key)) + if (subkey) { + set(inds, concat("\\:", subkey)) + } else { + set(inds, "") + } + set(indy, concat(ind, inds, var)) + return (indy) +} + +/* + * rtf_header(type, page) + * create a header entry (as in header/footer) + * type is all pages = 0, left = 1 and right = 2 + * page is where to place the page number + * no page number = 0, left side = 1, center = 2 and right = 3 + */ +proc rtf_header(type, page) +{ + if (eq(page, 0)) { + set(pstr, "") + set(pastr, "") + } elsif (eq(page, 1)) { + set(pastr, "\\ql") + set(pstr, "\\chpgn") + } elsif (eq(page, 2)) { + set(pastr, "\\qc") + set(pstr, "\\chpgn") + } elsif (eq(page, 3)) { + set(pastr, "\\qr") + set(pstr, "\\chpgn") + } + if (eq(type, 0)) { + set(hstr, "\\header") + } elsif (eq(type, 1)) { + set(hstr, "\\headerl") + } elsif (eq(type, 2)) { + set(hstr, "\\headerr") + } + "{" hstr "\\pard\\plain\\s3" pastr "{\\plain " pstr "}\\par}\n" +} +/* + * rtf_footer(type, page) + * creates a footer. + * see rtf_header for details + */ +proc rtf_footer(type, page) +{ + if (eq(page, 0)) { + set(pstr, "") + set(pastr, "") + } elsif (eq(page, 1)) { + set(pastr, "\\ql") + set(pstr, "\\chpgn") + } elsif (eq(page, 2)) { + set(pastr, "\\qc") + set(pstr, "\\chpgn") + } elsif (eq(page, 3)) { + set(pastr, "\\qr") + set(pstr, "\\chpgn") + } + if (eq(type, 0)) { + set(hstr, "\\footer") + } elsif (eq(type, 1)) { + set(hstr, "\\footerl") + } elsif (eq(type, 2)) { + set(hstr, "\\footerr") + } + "{" hstr "\\pard\\plain\\s3" pastr "{\\plain " pstr "}\\par}\n" +} + +/* + * rtf_ftn_type(type, postype) + * define the type(s) of footnotes/endnotes to use + */ +proc rtf_ftn_type(type, postype) +{ + "\\fet" d(type) + if (eq(type, 1)) { + if (eq(postype, 0)) { + "\\enddoc\\aenddoc" + } elsif (eq(postype, 1)) { + "\\endnotes\\aendnotes" + } + } elsif (eq(type, 2)) { + if (eq(postype, 0)) { + "\\aenddoc" + } elsif (eq(postype, 1)) { + "\\aendnotes" + } + } + "\n" +} + +/* + * rtf_ftn_tag(tag) + * if tag is not null, it is a user defined tag + * if null, do an automatic generation of the tag + * In all cases, output it superscripted + */ +proc rtf_ftn_tag(tag) +{ + if (tag) { + set(rtf_ftn_last_tag, tag) + } else { + set(rtf_ftn_last_tag, "\\chftn") + } + "{\\up6 " rtf_ftn_last_tag "}" +} + +/* + * rtf_ftn_start(tag) + * start a possibly tagged footnote + * must be closed with rtf_ftn_end() + */ +proc rtf_ftn_start(tag) +{ + if (rtf_ftn_state) { + call rtf_ftn_end() + } + call rtf_ftn_tag(tag) + "{\*\footnote\\pard\\plain\\s3\\fs" + d(getel(rtf_pointsize, 3)) + "\\li-540\\fi540\\tx540 " + rtf_ftn_last_tag + "\tab " + set(rtf_ftn_state, 1) +} +/* + * rtf_ftn_end() + * close an open footnote. + */ +proc rtf_ftn_end() +{ + if (rtf_ftn_state) { + "}\n" + set(rtf_ftn_state, 0) + } +} + +/* + * rtf_tab(type) + * issue a tab of appropriate type + */ +proc rtf_tab(type) +{ + if (eq(type, 0)) { + "\\tab " + } elsif (eq(type, 1)) { + "\\tqr " + } elsif (eq(type, 2)) { + "\\tqc " + } +} + +/* + * rtf_bold(on) + * turn bold on/off + */ +proc rtf_bold(on) +{ + if (on) { + "\\b " + } else { + "\\b0 " + } +} + +/* + * rtf_italic(on) + * turn italic on/off + */ +proc rtf_italic(on) +{ + if (on) { + "\\i " + } else { + "\\i0 " + } +} + +/* + * rtf_underline(type) + * turn underline on/off + * if type == 0 off + * 1 == continuous, 2 == double, 3 == word, 4 == dotted + */ +proc rtf_underline(type) +{ + if (type) { + if (eq(type, 1)) { "\\ul " } + elsif (eq(type, 2)) { "\\uldb " } + elsif (eq(type, 3)) { "\\ulw " } + elsif (eq(type, 4)) { "\\uld " } + } else { + "\\ul0 " + } +} + +/* + * rtf_super(on) + * turn superscript on/off + */ +proc rtf_super(on) +{ + if (on) { + "{\\up6" + if (ps, getel(rtf_pointsize, 3)) { + set(ps, sub(ps, 3)) + "\\fs" d(ps) + } + " " + } else { + "}" + } +} + +/* + * rtf_toc_entry(level, text) + * enter text as a Table of Contents entry at level + */ +proc rtf_toc_entry(level, text) +{ + "{\\tc\\tcl" d(level) + "{\\v " text "}}" +} + +/* + * one(val) + * similar to incr() but returns the new value + */ +func one(val) +{ + return (add(val, 1)) +} diff --git a/reports/sealing_line.ll b/reports/sealing_line.ll new file mode 100644 index 0000000..1d36e69 --- /dev/null +++ b/reports/sealing_line.ll @@ -0,0 +1,46 @@ +/* + * @progname sealing_line.ll + * @version none + * @author Tom Wetmore + * @category + * @output function, and driver writing Text + * @description + +function sealing_line(). +You pass it a person, and it returns the person's +sealing line (if there is one) or nothing (if there isn't). The main +program is only used here to test it. You would call "sealing_line" in the +place you need it in your own program. Yes, it is a little complicated, +but that's why we have modules. Write it, stick it in some library +somewhere, and just call it when you need the info. + +Tom Wetmore + */ + +proc main () +{ + getindi(i) + if (not(i)) { return() } + if (l, sealing_line(i)) { + print("yes\n") + print(tag(l), " ", value(l), "\n") + } else { + print("no") + } +} + +func sealing_line (i) +{ + set(f, parents(i)) + if (not(f)) { return(0) } + set(ir, inode(i)) set(fr, fnode(f)) + fornodes(fr, s) { + if(and(eqstr("CHIL", tag(s)), eqstr(xref(ir), value(s)))) { + fornodes(s, ss) { + if(eqstr("SLGC", tag(ss))) { return(ss) } + } + return(0) + } + } + return (0) +} diff --git a/reports/search_source.ll b/reports/search_source.ll new file mode 100644 index 0000000..1881fed --- /dev/null +++ b/reports/search_source.ll @@ -0,0 +1,63 @@ +/* + * @progname search_source.ll + * @version 1.0 + * @author Stephen Dum + * @category + * @output text + * @description + +Search source records for a particular string. +Program prompts for the type of sub record to search +and then for string to search for. If no sub record type is +entered, all records are searched. Case is ignored in searches. + + by Stephen Dum (stephen.dum@verizon.net) + Version 1 July 2006 +*/ + +option("explicitvars") + +proc main() +{ + getstr(search,"Enter type of SOUR sub records searched(e.g. TITL, AUTH) for all") + set(search,upper(search)) + getstr(match,"Enter string to search for") + set(match,lower(match)) + + forsour(n,i){ + if (strlen(search)) { + /* only search children of this source where tag is search */ + fornodes(n,ch) { + if (eqstr(tag(ch),search)) { + set(v,value(ch)) + if (i,index(lower(v),match,1)) { + /* + print ("Found in ",xref(n)," ",v,"\n") + */ + print ("Found in ",xref(n),": ") + print (d(level(ch))," ") + if (strlen(xref(ch))) { + print (xref(ch)," ") + } + print(tag(ch)," ",lower(v),"\n") + } + } + } + } else { + traverse(n,ch,i) { + set(v,value(ch)) + if (i,index(lower(v),match,1)) { + /* + print ("Found in ",xref(n)," ",v,"\n") + */ + print ("Found in ",xref(n),": ") + print (d(level(ch))," ") + if (strlen(xref(ch))) { + print (xref(ch)," ") + } + print(tag(ch)," ",lower(v),"\n") + } + } + } + } +} diff --git a/reports/select.ll b/reports/select.ll new file mode 100644 index 0000000..874189d --- /dev/null +++ b/reports/select.ll @@ -0,0 +1,64 @@ +/* + * @progname select.ll + * @version 3 + * @author Wetmore, Groleau, McGee + * @category + * @output Custom + * @description + + Customizable report stub to do the following: + o Select a person with all ancestors and all descendents. + o Add to selection all other persons within a user-specified number of + links from any person in the first selection. + o Turn the selected set of persons into a list + o Call a report subprogram to process the list. + + WRITTEN BY TOM WETMORE, 21 Jul 1995 + minor mods by Wes Groleau, 25 Aug 1995 + Scott McGee fixed Wes's bug, 26 Aug 1995 :-) +*/ + + list(o) /* output list */ + + /* have user provide start person and link distance */ + + getindi(i, "Please identify start person.") + if (not(i)) { return() } + getint(n, "Please enter link distance.") + + /* create set with all ancestors and descendents */ + + indiset(s) addtoset(s, i, 1) + indiset(a) set(a, ancestorset(s)) /* could be made optional */ + indiset(d) set(d, descendentset(s)) /* could be made optional */ + set(s, union(s, union(a, d))) + + /* create set of additional, linked-to persons */ + + indiset(t) set(t, spouseset(s)) + set(n, sub(n, 1)) + while (gt(n, 0)) { + set(a, parentset(t)) + set(d, childset(t)) + set(b, siblingset(t)) + set(c, spouseset(t)) + set(t, union(t, union(a, union(d, union(b, c))))) + set(n, sub(n, 1)) + } + + /* create final set of all selected persons and generate the report */ + + set(s, union(s, t)) + + if(s){ + forindiset(s, j, n, m) { + enqueue(o, j) + } + } + + call do_list(o) /* your routine here */ +} + + + +proc do_list (o) { /* your routine here */ } diff --git a/reports/sgsgen.ll b/reports/sgsgen.ll new file mode 100644 index 0000000..1d34408 --- /dev/null +++ b/reports/sgsgen.ll @@ -0,0 +1,359 @@ +/* + * @progname sgsgen.ll + * @version 1 + * @author Jim Eggert (eggertj@ll.mit.edu) + * @category + * @output Text + * @description + +A LifeLines report program to aid in the generation of +soc.genealogy.surnames (sgs) submissions. + +Given a person, this generates a sgs-like submission for that person and +his/her ancestors. The output will likely need considerable hand editing, +but that is how it is. If you need to know what sgs is, I have enclosed +a description at the end of this file. + +Here's what you will need to do by hand (you can consider this a list +of desired features for future versions of this report program): + +BEFORE YOU RUN THE PROGRAM: + +Change the routines write_sgs_entry() and write_sgs_body() to +customize your address and standard message. + +AFTER YOU RUN THE PROGRAM: + +Eliminate or fix empty or useless surname lines. +Use sgs-standard abbreviations for placenames. + Get FAMILY ABBREV as per instructions at end of this file. +Combine duplicate surname lines where appropriate. +Check check check. Note I've put a checklist at the head of the + report. Until you edit the report by hand, it cannot be used for + autosubmission via the telnet command as below. +Send the final product to the sgs maintainer. To autosubmit, + telnet your.news.host 119 < checked.sgs.report + +Version 1, 13 January 1997, by Jim Eggert, eggertj@ll.mit.edu + +*/ + +global(year_min) +global(year_max) +global(submitter_tag) +global(location) +global(last_location) +global(location_list) +global(location_table) +global(see_surname_table) +global(sgs_entry_count) + +proc main() { + list(ilist) + table(see_surname_table) + + getindi(person) + + set(sgs_entry_count,0) + + enqueue(ilist,person) + + dayformat(1) monthformat(4) dateformat(5) + + "QUIT\n" + "------------ edit checklist\n" + "change placenames to rsl-type places in the subject lines\n" + "ensure countries exist in migration components in the subject lines\n" + "eliminate / in places in the subject lines\n" + "fix special characters as needed\n" + "look for repeated submissions\n" + "delete sensitive info if desired\n" + "delete this checklist, including the top QUIT command\n" + "------------ end of edit checklist\n" + + while (person,dequeue(ilist)) { + table(location_table) + list(location_list) + + set(year_min,9999) set(year_max,0) + call locations_and_years(person) + set(final_key,save(key(person))) + set(final_surname,save(surname(person))) + + if (m,mother(person)) { enqueue(ilist,m) } + + while (person,father(person)) { + if (m,mother(person)) { enqueue(ilist,m) } + call locations_and_years(person) + set(this_surname,surname(person)) + if (strcmp(this_surname,final_surname)) { + set(see_name,0) + if (other_surname,lookup(see_surname_table,this_surname)) { + if (strcmp(final_surname,other_surname)) { + set(see_name,1) + } + } + else { + set(see_name,1) + set(other_surname,final_surname) + } + if (see_name) { + insert(see_surname_table, + save(this_surname),save(other_surname)) + } + } + } + call write_sgs_entry(final_key) + } + if (gt(sgs_entry_count,100)) { + print("Warning: Number of lines produced (") + print(d(sgs_entry_count)) + print(")\nexceeds recommended submission limit (100)\n") + } + "QUIT\n" +} + + +/* write_sgs_entry writes one submission to soc.genealogy.surnames*/ + +proc write_sgs_entry(key_entry) { + if (key_entry) { + set(surname_entry,save(surname(indi(key_entry)))) + if (strlen(surname_entry)) { + if (strcmp(trim(surname_entry,1),"_")) { + if (father(indi(key_entry))) { + incr(sgs_entry_count) + set(not_first,0) + "POST\n" +/*---*/ "From: your@email.address\n" + "Newsgroups: soc.genealogy.surnames\n" + "Subject: " upper(surname_entry) "; " + while (loc,dequeue(location_list)) { + if (not_first) { ">" } else { set(not_first,1) } + loc + } + "; " d(year_min) "-" d(year_max) "\n" + "Message-ID: \n" + "\n" + "Organization: none\n" + call write_sgs_body(key_entry) + ".\n" + } + } + } + } +} + + +/* write_sgs_body writes the body of a message */ + +proc write_sgs_body(key_entry) { +/*---*/ + "I am offering information on the following paternal ancestral line,\n" + "and am soliciting the sharing of genealogical data with any interested\n" + "party. The numbers preceeding the person's name are the generation\n" + "number, counting from the most recent person. Further information\n" + "can be found in my web pages at\n" + " \n" + "Please direct any communications to your@email.address\n" +/*---*/ + + set(person, indi(key_entry)) + set(number,1) + while (person) { + call ahnenreport(person,number) + incr(number) + set(person,father(person)) + } +} + +proc ahnenreport(person,number) { + "\n" d(number) ". " fullname(person,0,1,80) "\n" + if (e, birth(person)) { " born: " long(e) "\n" } + if (e, baptism(person)) { "baptized: " long(e) "\n" } + set(nfam,nfamilies(person)) + families(person, fam, spouse, fnum) { + set(e, marriage(fam)) + if (or(e,spouse)) { + if (gt(nfam,1)) { + "married" d(fnum) ": " + } + else { " married: " } + } + if (e) { long(e) "\n" } + if (spouse) { " to " fullname(spouse,0,1,80) "\n" } + } + if (e, death(person)) { " died: " long(e) "\n" } + if (e, burial(person)) { " buried: " long(e) "\n" } +/* fornotes(inode(person), note) { + note "\n" + } + fornodes(inode(person),node) { + if (not(strcmp(tag(node),"REFN"))) { + "SOURCE: " value(node) "\n" + } + } +*/ +} + + +/* locations_and_years figures out unique locations and min/max years + for a person with respect to other persons already figured. + Note that the events are processed in reverse chronological order, + because the ancestry is traced bottom up. Oh well... + */ + +proc locations_and_years(person) { + list(marriage_list) + + call one_location_and_year(burial(person)) + call one_location_and_year(death(person)) + families(person,family,spouse,fnum) { + push(marriage_list,marriage(family)) + } + while (event,pop(marriage_list)) { call one_location_and_year(event) } + call one_location_and_year(baptism(person)) + call one_location_and_year(birth(person)) +} + + +/* one_location_and_year appends the event location to the global + location list if it is new, and figures the event year into the + global min and max values. + */ + +proc one_location_and_year(event) { + if (event) { + set(loc,place(event)) + if (strlen(loc)) { + if (not(lookup(location_table,loc))) { + requeue(location_list,save(loc)) + insert(location_table,save(loc),1) + } + } + if (yr,atoi(year(event))) { + if (lt(yr,year_min)) { set(year_min,yr) } + if (gt(yr,year_max)) { set(year_max,yr) } + } + } +} + +/* + +soc.genealogy.surnames + + +This FAQ is presently in draft form. It may change without notice. Last +modification: 25 Aug 1995. + +Other surname-related FAQs available here: + + Commonly Used Abbreviations + Commonly Used German Abbreviations + Examples of Queries: Good and Bad + WWW Surname Archive + + +Welcome to soc.genealogy.surnames. The intent of this newsgroup is to +help genealogists researching related families to contact each +other. All surname queries are welcome here. + +A surname query is in many ways like a classified ad in a +newspaper. You want to attract people who might be interested in +sharing information about your family to read and respond to your +post. To help readers in finding articles of interest, writers are +requested to follow some simple guidelines in the subject lines of +their articles. + +Articles in soc.genealogy.surnames fall into a few basic categories: + + 1.general surname queries + 2.tiny tafels + 3.address changes + 4.follow-up articles + 5.Roots Surname List (RSL) articles + 6.moderators' announcements + +1. General surname queries + +(Style suggestions can be found in a companion FAQ, Surname Queries: +Good and Bad. This document discusses only what is absolutely +necessary for a post to soc.genealogy.surnames.) + +General surname queries can be written in plain language, freely +formatted. The body of the article can include any information about a +family that you wish. We recommend including given names, spouses, +children, birth, death, and marriage dates and places, if you know +them. This will make your article more useful to people who might want +to contact you, as well as making it valuable to people who may find +your article in searching the surname archives later. Indicating what +additional information you are seeking is a good idea. Also include +how to contact you: e-mail address, snail-mail address, and phone +number, if you like. + +Each surname query should have a subject line that gives one or more +surnames (in all capital letters), at least one place (using an +abbreviation from the RSL list of abbreviations), and an indication of +the time frame of interest. Examples: + + Subject: MILLS; NY,USA; 1800-1915 + Subject: MILLS Samuel D.; Williamsburg,Kings Co,NY,USA; 1796-1863 + Subject: ZAHM/PICARD/STEIS; LOT,FRA; 1680-1840 + Subject: ZAHM / PICARD / STEIS; LOT,FRA; 1680-1840 + Subject: ZAHM; LOT,FRA>IN,USA>IL,USA>KS,USA; 1650- + Subject: ZAHM; LOT,FRA > IN,USA > KS,USA; 1650- + Subject: CLOVER John; Lincoln,LIN,ENG>IL,USA; -1860 + Subject: LEGGETT; anywhere; anytime + +The "anywhere anytime" indication should only be used by genealogists +who are making a comprehensive one-name study of everyone in the world +who bore that name in all of recorded history. If you are just +starting out in researching your family, do not use this form; please +read the first paragraph of this section on surname queries again, and +use one of the other examples. If you are making a comprehensive +world-wide collection, please tell us about the extent of your +database as a way to encourage people to share their research with +you. + +If you find you want to include queries about more names than will fit +in the subject line, you may wish to post several queries. + +Some of the abbreviations may seem unfamiliar at first. The advantage +of using standard abbreviations for place names is that it makes +searching the surname archives easier and more reliable. As an +example, consider searching the archives for Coles families in New +York. With standard abbreviations, you can look for subjects that +contain both "COLES" and "NY,USA" and be sure that you are finding all +the relevant archived queries. Without standardization, you'd have to +search for "NY" and "New York", and might miss articles that said +"Albany" or "Buffalo" but left out the state. Abbreviations also make +subject lines shorter, for writers whose software limits subject +length. + +The place abbreviations are the same as used for the Roots Surname +List (RSL). They include United States and Canadian two-letter postal +codes, Chapman codes, three-letter ISO codes for nations, some other +standard codes, and a few codes invented for the RSL. The list was +compiled by Karen Isaacson with help from Christian Carey. + +You may find more information on abbreviations that may be used in +soc.genealogy.surnames in the Commonly Used Abbreviations FAQ for +soc.genealogy.surnames. The complete list of codes is archived on +mail.eworld.com. To retrieve the file, send e-mail to +listserv@mail.eworld.com containing only the line: + + GET FAMILY ABBREV + +The computer will then e-mail you the list of abbreviations (unless +you are using a system that blocks e-mail to and from listservs). You +can also retrieve the file by anonymous ftp to vm1.nodak.edu, in the +ROOTS-L directory; the file is named family.abbrev. The dates should +indicate when you are interested in the family in the area listed in +the subject line. The dates could be the earliest birth and latest +death dates for known ancestors, or periods for which you have +information, or the time for which you want more information. The date +range is approximate; no need to add "circa" or "?" if you are not +sure of dates. + +*/ diff --git a/reports/shorten.li b/reports/shorten.li new file mode 100644 index 0000000..70514c6 --- /dev/null +++ b/reports/shorten.li @@ -0,0 +1,589 @@ +/* + * @progname shorten.li + * @version 2001-05-25 + * @author Paul Buckley + * @category + * @output string function values and table updates + * @description + * + * This is a library file which allows ps-anc to + * accommodate my habit of using long place names + * (such as "Ridgewood, Bergen, New Jersey, United States"). + * To use this code add include("shorten.li") to the defines, + * put the following 2 lines in main() + * table(abbvtab) + * call setupabbvtab() + * and call the function with a string using + * STRING shorten(STRING) + * + * Paul Buckley, May 25, 2001 + * + */ + +global (abbvtab) /*hold a table of abbreviations defined in proc setupabbvtab*/ + +func shorten (string) { + set(input,string) + set(output,"") + set(success,lookup(abbvtab,input)) + if(success) { + set(output,success) + } + else { + set(output,input) + } + return(output) +} + +proc setupabbvtab () { + +/* USA State Codes */ +/* See http://helpdesk.rootsweb.com/codes/ for other county codes */ + + insert(abbvtab, "Alabama", "AL") + insert(abbvtab, "Alaska", "AK") + insert(abbvtab, "American Samoa", "AS") + insert(abbvtab, "Arizona", "AZ") + insert(abbvtab, "Arkansas", "AR") + insert(abbvtab, "California", "CA") + insert(abbvtab, "Colorado", "CO") + insert(abbvtab, "Connecticut", "CT") + insert(abbvtab, "Delaware", "DE") + insert(abbvtab, "District of Columbia", "DC") + insert(abbvtab, "Federated States of Micronesia", "FM") + insert(abbvtab, "Florida", "FL") + insert(abbvtab, "Georgia", "GA") + insert(abbvtab, "Guam", "GU") + insert(abbvtab, "Hawaii", "HI") + insert(abbvtab, "Idaho", "ID") + insert(abbvtab, "Illinois", "IL") + insert(abbvtab, "Indiana", "IN") + insert(abbvtab, "Iowa", "IA") + insert(abbvtab, "Kansas", "KS") + insert(abbvtab, "Kentucky", "KY") + insert(abbvtab, "Louisiana", "LA") + insert(abbvtab, "Maine", "ME") + insert(abbvtab, "Marshall Islands", "MH") + insert(abbvtab, "Maryland", "MD") + insert(abbvtab, "Massachusetts", "MA") + insert(abbvtab, "Michigan", "MI") + insert(abbvtab, "Minnesota", "MN") + insert(abbvtab, "Mississippi", "MS") + insert(abbvtab, "Missouri", "MO") + insert(abbvtab, "Montana", "MT") + insert(abbvtab, "Nebraska", "NE") + insert(abbvtab, "Nevada", "NV") + insert(abbvtab, "New Hampshire", "NH") + insert(abbvtab, "New Jersey", "NJ") + insert(abbvtab, "New Mexico", "NM") + insert(abbvtab, "New York", "NY") + insert(abbvtab, "North Carolina", "NC") + insert(abbvtab, "North Dakota", "ND") + insert(abbvtab, "Northern Mariana Islands", "MP") + insert(abbvtab, "Ohio", "OH") + insert(abbvtab, "Oklahoma", "OK") + insert(abbvtab, "Oregon", "OR") + insert(abbvtab, "Palau", "PW") + insert(abbvtab, "Pennsylvania", "PA") + insert(abbvtab, "Puerto Rico", "PR") + insert(abbvtab, "Rhode Island", "RI") + insert(abbvtab, "South Carolina", "SC") + insert(abbvtab, "South Dakota", "SD") + insert(abbvtab, "Tennessee", "TN") + insert(abbvtab, "Texas", "TX") + insert(abbvtab, "Utah", "UT") + insert(abbvtab, "Vermont", "VT") + insert(abbvtab, "Virgin Islands", "VI") + insert(abbvtab, "Virginia", "VA") + insert(abbvtab, "Washington", "WA") + insert(abbvtab, "West Virginia", "WV") + insert(abbvtab, "Wisconsin", "WI") + insert(abbvtab, "Wyoming", "WY") + +/* Nation codes from http://userpage.chemie.fu-berlin.de/diverse/doc/ISO_3166.html */ +/* Three letter Country Codes (see below for two letter codes) */ + insert(abbvtab, "Afghanistan", "AFG") + insert(abbvtab, "Albania", "ALB") + insert(abbvtab, "Algeria", "DZA") + insert(abbvtab, "American Samoa", "ASM") + insert(abbvtab, "Andorra", "AND") + insert(abbvtab, "Angola", "AGO") + insert(abbvtab, "Anguilla", "AIA") + insert(abbvtab, "Antarctica", "ATA") + insert(abbvtab, "Antigua And Barbuda", "ATG") + insert(abbvtab, "Argentina", "ARG") + insert(abbvtab, "Armenia", "ARM") + insert(abbvtab, "Aruba", "ABW") + insert(abbvtab, "Australia", "AUS") + insert(abbvtab, "Austria", "AUT") + insert(abbvtab, "Azerbaijan", "AZE") + insert(abbvtab, "Bahamas", "BHS") + insert(abbvtab, "Bahrain", "BHR") + insert(abbvtab, "Bangladesh", "BGD") + insert(abbvtab, "Barbados", "BRB") + insert(abbvtab, "Belarus", "BLR") + insert(abbvtab, "Belgium", "BEL") + insert(abbvtab, "Belize", "BLZ") + insert(abbvtab, "Benin", "BEN") + insert(abbvtab, "Bermuda", "BMU") + insert(abbvtab, "Bhutan", "BTN") + insert(abbvtab, "Bolivia", "BOL") + insert(abbvtab, "Bosnia And Herzegowina", "BIH") + insert(abbvtab, "Botswana", "BWA") + insert(abbvtab, "Bouvet Island", "BVT") + insert(abbvtab, "Brazil", "BRA") + insert(abbvtab, "British Indian Ocean Territory", "IOT") + insert(abbvtab, "Brunei Darussalam", "BRN") + insert(abbvtab, "Bulgaria", "BGR") + insert(abbvtab, "Burkina Faso", "BFA") + insert(abbvtab, "Burundi", "BDI") + insert(abbvtab, "Cambodia", "KHM") + insert(abbvtab, "Cameroon", "CMR") + insert(abbvtab, "Canada", "CAN") + insert(abbvtab, "Cape Verde", "CPV") + insert(abbvtab, "Cayman Islands", "CYM") + insert(abbvtab, "Central African Republic", "CAF") + insert(abbvtab, "Chad", "TCD") + insert(abbvtab, "Chile", "CHL") + insert(abbvtab, "China", "CHN") + insert(abbvtab, "Christmas Island", "CXR") + insert(abbvtab, "Cocos (Keeling) Islands", "CCK") + insert(abbvtab, "Colombia", "COL") + insert(abbvtab, "Comoros", "COM") + insert(abbvtab, "Congo", "COG") + insert(abbvtab, "Cook Islands", "COK") + insert(abbvtab, "Costa Rica", "CRI") + insert(abbvtab, "Cote D'ivoire", "CIV") + insert(abbvtab, "Croatia (Local Name: Hrvatska)", "HRV") + insert(abbvtab, "Cuba", "CUB") + insert(abbvtab, "Cyprus", "CYP") + insert(abbvtab, "Czech Republic", "CZE") + insert(abbvtab, "Denmark", "DNK") + insert(abbvtab, "Djibouti", "DJI") + insert(abbvtab, "Dominica", "DMA") + insert(abbvtab, "Dominican Republic", "DOM") + insert(abbvtab, "East Timor", "TMP") + insert(abbvtab, "Ecuador", "ECU") + insert(abbvtab, "Egypt", "EGY") + insert(abbvtab, "El Salvador", "SLV") + insert(abbvtab, "Equatorial Guinea", "GNQ") + insert(abbvtab, "Eritrea", "ERI") + insert(abbvtab, "Estonia", "EST") + insert(abbvtab, "Ethiopia", "ETH") + insert(abbvtab, "Falkland Islands (Malvinas)", "FLK") + insert(abbvtab, "Faroe Islands", "FRO") + insert(abbvtab, "Fiji", "FJI") + insert(abbvtab, "Finland", "FIN") + insert(abbvtab, "France", "FRA") + insert(abbvtab, "France, Metropolitan", "FXX") + insert(abbvtab, "French Guiana", "GUF") + insert(abbvtab, "French Polynesia", "PYF") + insert(abbvtab, "French Southern Territories", "ATF") + insert(abbvtab, "Gabon", "GAB") + insert(abbvtab, "Gambia", "GMB") + insert(abbvtab, "Georgia", "GEO") + insert(abbvtab, "Germany", "DEU") + insert(abbvtab, "Ghana", "GHA") + insert(abbvtab, "Gibraltar", "GIB") + insert(abbvtab, "Greece", "GRC") + insert(abbvtab, "Greenland", "GRL") + insert(abbvtab, "Grenada", "GRD") + insert(abbvtab, "Guadeloupe", "GLP") + insert(abbvtab, "Guam", "GUM") + insert(abbvtab, "Guatemala", "GTM") + insert(abbvtab, "Guinea", "GIN") + insert(abbvtab, "Guinea-Bissau", "GNB") + insert(abbvtab, "Guyana", "GUY") + insert(abbvtab, "Haiti", "HTI") + insert(abbvtab, "Heard And Mc Donald Islands", "HMD") + insert(abbvtab, "Honduras", "HND") + insert(abbvtab, "Hong Kong", "HKG") + insert(abbvtab, "Hungary", "HUN") + insert(abbvtab, "Iceland", "ISL") + insert(abbvtab, "India", "IND") + insert(abbvtab, "Indonesia", "IDN") + insert(abbvtab, "Iran (Islamic Republic Of)", "IRN") + insert(abbvtab, "Iraq", "IRQ") + insert(abbvtab, "Ireland", "IRL") + insert(abbvtab, "Israel", "ISR") + insert(abbvtab, "Italy", "ITA") + insert(abbvtab, "Jamaica", "JAM") + insert(abbvtab, "Japan", "JPN") + insert(abbvtab, "Jordan", "JOR") + insert(abbvtab, "Kazakhstan", "KAZ") + insert(abbvtab, "Kenya", "KEN") + insert(abbvtab, "Kiribati", "KIR") + insert(abbvtab, "Korea, Democratic People's Republic Of", "PRK") + insert(abbvtab, "Korea, Republic Of", "KOR") + insert(abbvtab, "Kuwait", "KWT") + insert(abbvtab, "Kyrgyzstan", "KGZ") + insert(abbvtab, "Lao People's Democratic Republic", "LAO") + insert(abbvtab, "Latvia", "LVA") + insert(abbvtab, "Lebanon", "LBN") + insert(abbvtab, "Lesotho", "LSO") + insert(abbvtab, "Liberia", "LBR") + insert(abbvtab, "Libyan Arab Jamahiriya", "LBY") + insert(abbvtab, "Liechtenstein", "LIE") + insert(abbvtab, "Lithuania", "LTU") + insert(abbvtab, "Luxembourg", "LUX") + insert(abbvtab, "Macau", "MAC") + insert(abbvtab, "Macedonia, The Former Yugoslav Republic Of", "MKD") + insert(abbvtab, "Madagascar", "MDG") + insert(abbvtab, "Malawi", "MWI") + insert(abbvtab, "Malaysia", "MYS") + insert(abbvtab, "Maldives", "MDV") + insert(abbvtab, "Mali", "MLI") + insert(abbvtab, "Malta", "MLT") + insert(abbvtab, "Marshall Islands", "MHL") + insert(abbvtab, "Martinique", "MTQ") + insert(abbvtab, "Mauritania", "MRT") + insert(abbvtab, "Mauritius", "MUS") + insert(abbvtab, "Mayotte", "MYT") + insert(abbvtab, "Mexico", "MEX") + insert(abbvtab, "Micronesia, Federated States Of", "FSM") + insert(abbvtab, "Moldova, Republic Of", "MDA") + insert(abbvtab, "Monaco", "MCO") + insert(abbvtab, "Mongolia", "MNG") + insert(abbvtab, "Montserrat", "MSR") + insert(abbvtab, "Morocco", "MAR") + insert(abbvtab, "Mozambique", "MOZ") + insert(abbvtab, "Myanmar", "MMR") + insert(abbvtab, "Namibia", "NAM") + insert(abbvtab, "Nauru", "NRU") + insert(abbvtab, "Nepal", "NPL") + insert(abbvtab, "Netherlands", "NLD") + insert(abbvtab, "Netherlands Antilles", "ANT") + insert(abbvtab, "New Caledonia", "NCL") + insert(abbvtab, "New Zealand", "NZL") + insert(abbvtab, "Nicaragua", "NIC") + insert(abbvtab, "Niger", "NER") + insert(abbvtab, "Nigeria", "NGA") + insert(abbvtab, "Niue", "NIU") + insert(abbvtab, "Norfolk Island", "NFK") + insert(abbvtab, "Northern Mariana Islands", "MNP") + insert(abbvtab, "Norway", "NOR") + insert(abbvtab, "Oman", "OMN") + insert(abbvtab, "Pakistan", "PAK") + insert(abbvtab, "Palau", "PLW") + insert(abbvtab, "Panama", "PAN") + insert(abbvtab, "Papua New Guinea", "PNG") + insert(abbvtab, "Paraguay", "PRY") + insert(abbvtab, "Peru", "PER") + insert(abbvtab, "Philippines", "PHL") + insert(abbvtab, "Pitcairn", "PCN") + insert(abbvtab, "Poland", "POL") + insert(abbvtab, "Portugal", "PRT") + insert(abbvtab, "Puerto Rico", "PRI") + insert(abbvtab, "Qatar", "QAT") + insert(abbvtab, "Reunion", "REU") + insert(abbvtab, "Romania", "ROM") + insert(abbvtab, "Russian Federation", "RUS") + insert(abbvtab, "Rwanda", "RWA") + insert(abbvtab, "Saint Kitts And Nevis", "KNA") + insert(abbvtab, "Saint Lucia", "LCA") + insert(abbvtab, "Saint Vincent And The Grenadines", "VCT") + insert(abbvtab, "Samoa", "WSM") + insert(abbvtab, "San Marino", "SMR") + insert(abbvtab, "Sao Tome And Principe", "STP") + insert(abbvtab, "Saudi Arabia", "SAU") + insert(abbvtab, "Senegal", "SEN") + insert(abbvtab, "Seychelles", "SYC") + insert(abbvtab, "Sierra Leone", "SLE") + insert(abbvtab, "Singapore", "SGP") + insert(abbvtab, "Slovakia (Slovak Republic)", "SVK") + insert(abbvtab, "Slovenia", "SVN") + insert(abbvtab, "Solomon Islands", "SLB") + insert(abbvtab, "Somalia", "SOM") + insert(abbvtab, "South Africa", "ZAF") + insert(abbvtab, "South Georgia And The South Sandwich Islands", "SGS") + insert(abbvtab, "Spain", "ESP") + insert(abbvtab, "Sri Lanka", "LKA") + insert(abbvtab, "St. Helena", "SHN") + insert(abbvtab, "St. Pierre And Miquelon", "SPM") + insert(abbvtab, "Sudan", "SDN") + insert(abbvtab, "Suriname", "SUR") + insert(abbvtab, "Svalbard And Jan Mayen Islands", "SJM") + insert(abbvtab, "Swaziland", "SWZ") + insert(abbvtab, "Sweden", "SWE") + insert(abbvtab, "Switzerland", "CHE") + insert(abbvtab, "Syrian Arab Republic", "SYR") + insert(abbvtab, "Taiwan", "TWN") + insert(abbvtab, "Tajikistan", "TJK") + insert(abbvtab, "Tanzania, United Republic Of", "TZA") + insert(abbvtab, "Thailand", "THA") + insert(abbvtab, "Togo", "TGO") + insert(abbvtab, "Tokelau", "TKL") + insert(abbvtab, "Tonga", "TON") + insert(abbvtab, "Trinidad And Tobago", "TTO") + insert(abbvtab, "Tunisia", "TUN") + insert(abbvtab, "Turkey", "TUR") + insert(abbvtab, "Turkmenistan", "TKM") + insert(abbvtab, "Turks And Caicos Islands", "TCA") + insert(abbvtab, "Tuvalu", "TUV") + insert(abbvtab, "Uganda", "UGA") + insert(abbvtab, "Ukraine", "UKR") + insert(abbvtab, "United Arab Emirates", "ARE") + insert(abbvtab, "United Kingdom", "GBR") + insert(abbvtab, "United States", "USA") + insert(abbvtab, "United States Minor Outlying Islands", "UMI") + insert(abbvtab, "Uruguay", "URY") + insert(abbvtab, "Uzbekistan", "UZB") + insert(abbvtab, "Vanuatu", "VUT") + insert(abbvtab, "Vatican City State (Holy See)", "VAT") + insert(abbvtab, "Venezuela", "VEN") + insert(abbvtab, "Viet Nam", "VNM") + insert(abbvtab, "Virgin Islands (British)", "VGB") + insert(abbvtab, "Virgin Islands (U.S.)", "VIR") + insert(abbvtab, "Wallis And Futuna Islands", "WLF") + insert(abbvtab, "Western Sahara", "ESH") + insert(abbvtab, "Yemen", "YEM") + insert(abbvtab, "Yugoslavia", "YUG") + insert(abbvtab, "Zaire", "ZAR") + insert(abbvtab, "Zambia", "ZMB") + insert(abbvtab, "Zimbabwe", "ZWE") + + +/* Two Letter Country Codes (use one set or the other)*/ +/* + insert(abbvtab, "Afghanistan", "AF") + insert(abbvtab, "Albania", "AL") + insert(abbvtab, "Algeria", "DZ") + insert(abbvtab, "American Samoa", "AS") + insert(abbvtab, "Andorra", "AD") + insert(abbvtab, "Angola", "AO") + insert(abbvtab, "Anguilla", "AI") + insert(abbvtab, "Antarctica", "AQ") + insert(abbvtab, "Antigua And Barbuda", "AG") + insert(abbvtab, "Argentina", "AR") + insert(abbvtab, "Armenia", "AM") + insert(abbvtab, "Aruba", "AW") + insert(abbvtab, "Australia", "AU") + insert(abbvtab, "Austria", "AT") + insert(abbvtab, "Azerbaijan", "AZ") + insert(abbvtab, "Bahamas", "BS") + insert(abbvtab, "Bahrain", "BH") + insert(abbvtab, "Bangladesh", "BD") + insert(abbvtab, "Barbados", "BB") + insert(abbvtab, "Belarus", "BY") + insert(abbvtab, "Belgium", "BE") + insert(abbvtab, "Belize", "BZ") + insert(abbvtab, "Benin", "BJ") + insert(abbvtab, "Bermuda", "BM") + insert(abbvtab, "Bhutan", "BT") + insert(abbvtab, "Bolivia", "BO") + insert(abbvtab, "Bosnia And Herzegowina", "BA") + insert(abbvtab, "Botswana", "BW") + insert(abbvtab, "Bouvet Island", "BV") + insert(abbvtab, "Brazil", "BR") + insert(abbvtab, "British Indian Ocean Territory", "IO") + insert(abbvtab, "Brunei Darussalam", "BN") + insert(abbvtab, "Bulgaria", "BG") + insert(abbvtab, "Burkina Faso", "BF") + insert(abbvtab, "Burundi", "BI") + insert(abbvtab, "Cambodia", "KH") + insert(abbvtab, "Cameroon", "CM") + insert(abbvtab, "Canada", "CA") + insert(abbvtab, "Cape Verde", "CV") + insert(abbvtab, "Cayman Islands", "KY") + insert(abbvtab, "Central African Republic", "CF") + insert(abbvtab, "Chad", "TD") + insert(abbvtab, "Chile", "CL") + insert(abbvtab, "China", "CN") + insert(abbvtab, "Christmas Island", "CX") + insert(abbvtab, "Cocos (Keeling) Islands", "CC") + insert(abbvtab, "Colombia", "CO") + insert(abbvtab, "Comoros", "KM") + insert(abbvtab, "Congo", "CG") + insert(abbvtab, "Cook Islands", "CK") + insert(abbvtab, "Costa Rica", "CR") + insert(abbvtab, "Cote D'ivoire", "CI") + insert(abbvtab, "Croatia (Local Name: Hrvatska)", "HR") + insert(abbvtab, "Cuba", "CU") + insert(abbvtab, "Cyprus", "CY") + insert(abbvtab, "Czech Republic", "CZ") + insert(abbvtab, "Denmark", "DK") + insert(abbvtab, "Djibouti", "DJ") + insert(abbvtab, "Dominica", "DM") + insert(abbvtab, "Dominican Republic", "DO") + insert(abbvtab, "East Timor", "TP") + insert(abbvtab, "Ecuador", "EC") + insert(abbvtab, "Egypt", "EG") + insert(abbvtab, "El Salvador", "SV") + insert(abbvtab, "Equatorial Guinea", "GQ") + insert(abbvtab, "Eritrea", "ER") + insert(abbvtab, "Estonia", "EE") + insert(abbvtab, "Ethiopia", "ET") + insert(abbvtab, "Falkland Islands (Malvinas)", "FK") + insert(abbvtab, "Faroe Islands", "FO") + insert(abbvtab, "Fiji", "FJ") + insert(abbvtab, "Finland", "FI") + insert(abbvtab, "France", "FR") + insert(abbvtab, "France, Metropolitan", "FX") + insert(abbvtab, "French Guiana", "GF") + insert(abbvtab, "French Polynesia", "PF") + insert(abbvtab, "French Southern Territories", "TF") + insert(abbvtab, "Gabon", "GA") + insert(abbvtab, "Gambia", "GM") + insert(abbvtab, "Georgia", "GE") + insert(abbvtab, "Germany", "DE") + insert(abbvtab, "Ghana", "GH") + insert(abbvtab, "Gibraltar", "GI") + insert(abbvtab, "Greece", "GR") + insert(abbvtab, "Greenland", "GL") + insert(abbvtab, "Grenada", "GD") + insert(abbvtab, "Guadeloupe", "GP") + insert(abbvtab, "Guam", "GU") + insert(abbvtab, "Guatemala", "GT") + insert(abbvtab, "Guinea", "GN") + insert(abbvtab, "Guinea-Bissau", "GW") + insert(abbvtab, "Guyana", "GY") + insert(abbvtab, "Haiti", "HT") + insert(abbvtab, "Heard And Mc Donald Islands", "HM") + insert(abbvtab, "Honduras", "HN") + insert(abbvtab, "Hong Kong", "HK") + insert(abbvtab, "Hungary", "HU") + insert(abbvtab, "Iceland", "IS") + insert(abbvtab, "India", "IN") + insert(abbvtab, "Indonesia", "ID") + insert(abbvtab, "Iran (Islamic Republic Of)", "IR") + insert(abbvtab, "Iraq", "IQ") + insert(abbvtab, "Ireland", "IE") + insert(abbvtab, "Israel", "IL") + insert(abbvtab, "Italy", "IT") + insert(abbvtab, "Jamaica", "JM") + insert(abbvtab, "Japan", "JP") + insert(abbvtab, "Jordan", "JO") + insert(abbvtab, "Kazakhstan", "KZ") + insert(abbvtab, "Kenya", "KE") + insert(abbvtab, "Kiribati", "KI") + insert(abbvtab, "Korea, Democratic People's Republic Of", "KP") + insert(abbvtab, "Korea, Republic Of", "KR") + insert(abbvtab, "Kuwait", "KW") + insert(abbvtab, "Kyrgyzstan", "KG") + insert(abbvtab, "Lao People's Democratic Republic", "LA") + insert(abbvtab, "Latvia", "LV") + insert(abbvtab, "Lebanon", "LB") + insert(abbvtab, "Lesotho", "LS") + insert(abbvtab, "Liberia", "LR") + insert(abbvtab, "Libyan Arab Jamahiriya", "LY") + insert(abbvtab, "Liechtenstein", "LI") + insert(abbvtab, "Lithuania", "LT") + insert(abbvtab, "Luxembourg", "LU") + insert(abbvtab, "Macau", "MO") + insert(abbvtab, "Macedonia, The Former Yugoslav Republic Of", "MK") + insert(abbvtab, "Madagascar", "MG") + insert(abbvtab, "Malawi", "MW") + insert(abbvtab, "Malaysia", "MY") + insert(abbvtab, "Maldives", "MV") + insert(abbvtab, "Mali", "ML") + insert(abbvtab, "Malta", "MT") + insert(abbvtab, "Marshall Islands", "MH") + insert(abbvtab, "Martinique", "MQ") + insert(abbvtab, "Mauritania", "MR") + insert(abbvtab, "Mauritius", "MU") + insert(abbvtab, "Mayotte", "YT") + insert(abbvtab, "Mexico", "MX") + insert(abbvtab, "Micronesia, Federated States Of", "FM") + insert(abbvtab, "Moldova, Republic Of", "MD") + insert(abbvtab, "Monaco", "MC") + insert(abbvtab, "Mongolia", "MN") + insert(abbvtab, "Montserrat", "MS") + insert(abbvtab, "Morocco", "MA") + insert(abbvtab, "Mozambique", "MZ") + insert(abbvtab, "Myanmar", "MM") + insert(abbvtab, "Namibia", "NA") + insert(abbvtab, "Nauru", "NR") + insert(abbvtab, "Nepal", "NP") + insert(abbvtab, "Netherlands", "NL") + insert(abbvtab, "Netherlands Antilles", "AN") + insert(abbvtab, "New Caledonia", "NC") + insert(abbvtab, "New Zealand", "NZ") + insert(abbvtab, "Nicaragua", "NI") + insert(abbvtab, "Niger", "NE") + insert(abbvtab, "Nigeria", "NG") + insert(abbvtab, "Niue", "NU") + insert(abbvtab, "Norfolk Island", "NF") + insert(abbvtab, "Northern Mariana Islands", "MP") + insert(abbvtab, "Norway", "NO") + insert(abbvtab, "Oman", "OM") + insert(abbvtab, "Pakistan", "PK") + insert(abbvtab, "Palau", "PW") + insert(abbvtab, "Panama", "PA") + insert(abbvtab, "Papua New Guinea", "PG") + insert(abbvtab, "Paraguay", "PY") + insert(abbvtab, "Peru", "PE") + insert(abbvtab, "Philippines", "PH") + insert(abbvtab, "Pitcairn", "PN") + insert(abbvtab, "Poland", "PL") + insert(abbvtab, "Portugal", "PT") + insert(abbvtab, "Puerto Rico", "PR") + insert(abbvtab, "Qatar", "QA") + insert(abbvtab, "Reunion", "RE") + insert(abbvtab, "Romania", "RO") + insert(abbvtab, "Russian Federation", "RU") + insert(abbvtab, "Rwanda", "RW") + insert(abbvtab, "Saint Kitts And Nevis", "KN") + insert(abbvtab, "Saint Lucia", "LC") + insert(abbvtab, "Saint Vincent And The Grenadines", "VC") + insert(abbvtab, "Samoa", "WS") + insert(abbvtab, "San Marino", "SM") + insert(abbvtab, "Sao Tome And Principe", "ST") + insert(abbvtab, "Saudi Arabia", "SA") + insert(abbvtab, "Senegal", "SN") + insert(abbvtab, "Seychelles", "SC") + insert(abbvtab, "Sierra Leone", "SL") + insert(abbvtab, "Singapore", "SG") + insert(abbvtab, "Slovakia (Slovak Republic)", "SK") + insert(abbvtab, "Slovenia", "SI") + insert(abbvtab, "Solomon Islands", "SB") + insert(abbvtab, "Somalia", "SO") + insert(abbvtab, "South Africa", "ZA") + insert(abbvtab, "South Georgia And The South Sandwich Islands", "GS") + insert(abbvtab, "Spain", "ES") + insert(abbvtab, "Sri Lanka", "LK") + insert(abbvtab, "St. Helena", "SH") + insert(abbvtab, "St. Pierre And Miquelon", "PM") + insert(abbvtab, "Sudan", "SD") + insert(abbvtab, "Suriname", "SR") + insert(abbvtab, "Svalbard And Jan Mayen Islands", "SJ") + insert(abbvtab, "Swaziland", "SZ") + insert(abbvtab, "Sweden", "SE") + insert(abbvtab, "Switzerland", "CH") + insert(abbvtab, "Syrian Arab Republic", "SY") + insert(abbvtab, "Taiwan", "TW") + insert(abbvtab, "Tajikistan", "TJ") + insert(abbvtab, "Tanzania, United Republic Of", "TZ") + insert(abbvtab, "Thailand", "TH") + insert(abbvtab, "Togo", "TG") + insert(abbvtab, "Tokelau", "TK") + insert(abbvtab, "Tonga", "TO") + insert(abbvtab, "Trinidad And Tobago", "TT") + insert(abbvtab, "Tunisia", "TN") + insert(abbvtab, "Turkey", "TR") + insert(abbvtab, "Turkmenistan", "TM") + insert(abbvtab, "Turks And Caicos Islands", "TC") + insert(abbvtab, "Tuvalu", "TV") + insert(abbvtab, "Uganda", "UG") + insert(abbvtab, "Ukraine", "UA") + insert(abbvtab, "United Arab Emirates", "AE") + insert(abbvtab, "United Kingdom", "GB") + insert(abbvtab, "United States", "US") + insert(abbvtab, "United States Minor Outlying Islands", "UM") + insert(abbvtab, "Uruguay", "UY") + insert(abbvtab, "Uzbekistan", "UZ") + insert(abbvtab, "Vanuatu", "VU") + insert(abbvtab, "Vatican City State (Holy See)", "VA") + insert(abbvtab, "Venezuela", "VE") + insert(abbvtab, "Viet Nam", "VN") + insert(abbvtab, "Virgin Islands (British)", "VG") + insert(abbvtab, "Virgin Islands (U.S.)", "VI") + insert(abbvtab, "Wallis And Futuna Islands", "WF") + insert(abbvtab, "Western Sahara", "EH") + insert(abbvtab, "Yemen", "YE") + insert(abbvtab, "Yugoslavia", "YU") + insert(abbvtab, "Zaire", "ZR") + insert(abbvtab, "Zambia", "ZM") + insert(abbvtab, "Zimbabwe", "ZW") +*/ + +} diff --git a/reports/showlines1.ll b/reports/showlines1.ll new file mode 100644 index 0000000..cdbe82d --- /dev/null +++ b/reports/showlines1.ll @@ -0,0 +1,57 @@ +/* + * @progname showlines1.ll + * @version 1.0 + * @author Wetmore + * @category + * @output Text + * @description + + * This program will produce a report of all ancestors of a person, + * and is presently designed for 10 or 12 pitch, HP laserjet III. + + * showlines1 + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by Tom Wetmore, in 1991. + * + * + * Output is an ASCII file + * + */ + + +/* showlines */ +proc main () +{ + list(plist) + getindi(indi) + monthformat(4) + print("Each dot is an ancestor.") print(nl()) + "------------------------------------------------------------" nl() + "ANCESTRAL LINES OF -- " name(indi) nl() + enqueue(plist, indi) + while (indi, dequeue(plist)) { + call show_line(indi, plist) + } + print(nl()) +} + +proc show_line (indi, plist) +{ + "------------------------------------------------------------" nl() + while (indi) { + name(indi) col(32) stddate(birth(indi)) + col(45) stddate(death(indi)) nl() + print(".") + if (moth, mother(indi)) { + enqueue(plist, moth) + } + set(indi, father(indi)) + } +} + +/* End of Report */ + diff --git a/reports/simpleged.ll b/reports/simpleged.ll new file mode 100644 index 0000000..6fbe8a1 --- /dev/null +++ b/reports/simpleged.ll @@ -0,0 +1,113 @@ +/* + * @progname simpleged.ll + * @version 1.0 + * @author Wetmore + * @category + * @output GEDCOM + * @description + +This program generates a simple GEDCOM file from a database. It can +be modified to convert your own LifeLines database formats to other +GEDCOM formats. + +simpleged + +Written by Tom Wetmore, July 1993. +*/ + +proc main () +{ + "0 HEAD \n" + "1 SOUR LIFELINES\n" + forindi(indi, num) { + print("i") + call outindi(indi) + } + forfam(fam, num) { + print("f") + call outfam(fam) + } + "0 TRLR \n" +} + +proc outindi (indi) +{ + set(root, inode(indi)) + set(noname, 1) + set(nosex, 1) + set(nobirt, 1) + set(nobapt, 1) + set(nodeat, 1) + set(noburi, 1) + "0 " xref(root) " " tag(root) nl() + set(node, child(root)) + while (node) { + if (and(noname, not(strcmp("NAME", tag(node))))) { + "1 NAME " value(node) nl() + set(noname, 0) + } elsif (and(nosex, not(strcmp("SEX", tag(node))))) { + "1 SEX " value(node) nl() + set(nosex, 0) + } elsif (and(nobirt, not(strcmp("BIRT", tag(node))))) { + call outevent(node) + set(nobirt, 0) + } elsif (and(nobapt, not(strcmp("CHR", tag(node))))) { + call outevent(node) + set(nobapt, 0) + } elsif (and(nodeat, not(strcmp("DEAT", tag(node))))) { + call outevent(node) + set(nodeat, 0) + } elsif (and(noburi, not(strcmp("BURI", tag(node))))) { + call outevent(node) + set(noburi, 0) + } elsif (not(strcmp("FAMC", tag(node)))) { + "1 FAMC " value(node) nl() + } elsif (not(strcmp("FAMS", tag(node)))) { + "1 FAMS " value(node) nl() + } + set(node, sibling(node)) + } +} + +proc outfam (fam) +{ + set(nomarr, 1) + set(root, fnode(fam)) + "0 " xref(root) " " tag(root) nl() + set(node, child(root)) + while (node) { + if (not(strcmp("HUSB", tag(node)))) { + "1 HUSB " value(node) nl() + } elsif (not(strcmp("WIFE", tag(node)))) { + "1 WIFE " value(node) nl() + } elsif (not(strcmp("CHIL", tag(node)))) { + "1 CHIL " value(node) nl() + } elsif (and(nomarr, not(strcmp("MARR", tag(node))))) { + call outevent(node) + set(nomarr, 0) + } + set(node, sibling(node)) + } +} + +proc outevent (evt) +{ + set(nodate, 1) + set(noplac, 1) + set(nosour, 1) + "1 " tag(evt) "\n" + set(evt, child(evt)) + while (evt) { + if (and(nodate, not(strcmp("DATE", tag(evt))))) { + "2 DATE " value(evt) nl() + set(nodate, 0) + } elsif (and(noplac, not(strcmp("PLAC", tag(evt))))) { + "2 PLAC " value(evt) nl() + set(noplac, 0) + } elsif (and(nosour, not(strcmp("SOUR", tag(evt))))) { + "2 SOUR " value(evt) nl() + set(nosour, 0) + } + set(evt, sibling(evt)) + } +} diff --git a/reports/soundex-isfm.ll b/reports/soundex-isfm.ll new file mode 100644 index 0000000..6edac20 --- /dev/null +++ b/reports/soundex-isfm.ll @@ -0,0 +1,124 @@ +/* + * @progname soundex-isfm.ll + * @version 1.0 + * @author Wetmore, Manis, Eggert + * @category + * @output Text, 132 cols + * @description + * + * This program will produce a report of all the INDI's in the database, + * in the format as seen at end of report. May be sorted easily + * to see the Father or Mother column sorted report. + * + * soundex-isfm + * + * Code by Tom Wetmore, ttw@cbnewsl.att.com, 1991 + * Modifications by Cliff Manis, cmanis@csoftec.csf.com, 1992 + * Modifications by Jim Eggert, atc.ll.mit.edu!eggertj Fri Feb 26 1993 + * + * This report works only with the LifeLines Genealogy program + * + * This report can be used to output everyone in the database, + * or selected by a single soundex code. The soundex code + * can be entered either by knowing the code, or by selecting + * an individual and using his/her code. + * + * The report name come from: isfm (Indi Spouse Father Mother) + * It is designed for 16 pitch, HP laserjet III, 132 column, and + * also those who have X-Windows, 132 columns video. + * + * This report produces an ASCII output file. + */ + +proc main () +{ + indiset(idx) + getintmsg(smethod, + "0=all persons, 1=given Soundex, 2=Soundex of a given person") + if (eq(smethod,1)) { + getstrmsg(scode, + "Enter desired Soundex code (return=any, Z999=unknown)") + if (scode) { set(scode,save(upper(scode))) } + } + elsif (eq(smethod,2)) { + getindimsg(person,"Enter name of person with desired Soundex") + if (person) { + set(scode,save(soundex(person)) ) + } + } + if (scode) { print("Using Soundex code ") print(scode) print("\n") } + else { print("Using all persons in database\n") } + set(count,0) + forindi(indi,n) { + set(getit,1) + if (scode) { + if (strcmp(scode,soundex(indi))) { set(getit,0) } + } + if (getit) { + addtoset(idx,indi,n) + if (scode) { + set(count,add(count,1)) + print(d(count)) print("/") + } + print(d(n)) print(" ") + } + } + print("\nbegin sorting\n") + namesort(idx) + print("done sorting\n") + col(1) "INDEX OF ALL PERSONS IN DATABASE" + if (scode) { " WITH SOUNDEX CODE: " scode } + col(1) "Individual" + col(34) "Brth" + col(39) "Deat" + col(44) "First Spouse" + col(75) "Father" + col(106) "Mother" + col(1) "----------------------------------------" + "----------------------------------------" + "----------------------------------------" + forindiset(idx,indi,v,n) { + col(1) fullname(indi,1,0,29) + col(34) year(birth(indi)) + col(39) year(death(indi)) + if(gt(nspouses(indi), 0)) { + spouses(indi, spou, fam, n) { + if (eq(1,n)) { + col(44) fullname(spou,1,0,29) + } + } + } + if(fath,father(indi)) { + col(75) fullname(fath,1,0,29) + } + if(moth,mother(indi)) { + col(106) fullname(moth,1,0,29) + } + } + nl() + print(nl()) +} + + +/* Sample output of report (132 columns) + +INDEX OF ALL PERSONS IN DATABASE WITH SOUNDEX CODE: D340 + +Individual Brth Deat First Spouse Father Mother +------------------------------------------------------------------------------------------------------------------------ +DUDLEY, Alexander 1645 DUDLEY, Richard SEAWELL, Mary +DUDLEY, Ambrose 1665 DUDLEY, Wife_of Ambrose DUDLEY, Ambrose DUDLEY, Wife_of Col_Ambrose +DUDLEY, Ambrose 1649 DUDLEY, Wife_of Col_Ambrose DUDLEY, Richard SEAWELL, Mary +DUDLEY, Christopher 1715 1781 DUDLEY, Robert CURTIS, Elizabeth +DUDLEY, Dorcas 1704 1765 ROUNTREE, William DUDLEY, Ambrose DUDLEY, Wife_of Ambrose +DUDLEY, Edward 1605 1655 PRITCHARD, Elizabeth +DUDLEY, James 1645 1741 WELCH, Mary DUDLEY, Richard SEAWELL, Mary +DUDLEY, Richard 1623 1687 SEAWELL, Mary DUDLEY, Edward PRITCHARD, Elizabeth +DUDLEY, Robert 1647 1701 RANSOM, Elizabeth DUDLEY, Richard SEAWELL, Mary +DUDLEY, Robert 1691 1745 CURTIS, Elizabeth DUDLEY, Robert RANSOM, Elizabeth +DUDLEY, Wife_of Ambrose 1640 DUDLEY, Ambrose +DUDLEY, Wife_of Col_Ambrose 1645 DUDLEY, Ambrose +DUDLEY, William 1621 1672 CARY, Elizabeth DUDLEY, Edward PRITCHARD, Elizabeth + + -- end of sample +*/ diff --git a/reports/soundex1.ll b/reports/soundex1.ll new file mode 100644 index 0000000..ff3efcd --- /dev/null +++ b/reports/soundex1.ll @@ -0,0 +1,80 @@ +/* + * @progname soundex1.ll + * @version 1.0 + * @author Jones + * @category + * @output Text + * @description + * + * Produces a chart of all surnames in database with corresponding + * SOUNDEX codes. + * It is designed for 10 or 12 pitch, HP laserjet III, or any + * other printer. + * + * soundex1 + * + * Code by James P. Jones, jjones@nas.nasa.gov + * + * This report works only with the LifeLines Genealogy program + * + * version one of this report was written by James P. Jones, 28 Sep 1992 + * + * + * Output is an ASCII file. + * + * An example of the output may be seen at end of this report. + * + */ + +proc main () +{ + indiset(idx) + forindi(indi,n) { + addtoset(idx,indi,n) + print(".") + } + print(nl()) print("indexed ") print(d(n)) print(" persons.") + print(nl()) + print(nl()) + print("begin sorting") print(nl()) + namesort(idx) + print("done sorting") print(nl()) + + col(11) "SOUNDEX CODES OF ALL SURNAMES IN DATABASE" nl() + col(1) " " nl() + col(1) " " nl() + col(16) " Surname Soundex Code" nl() + col(16) " ------------- ------------" nl() + + set(last, " ") + forindiset(idx,indi,v,n) { + if(strcmp(surname(indi), last)) { + col(20) upper(surname(indi)) + col(36) soundex(indi) + } + set(last,surname(indi)) + print(".") + } + nl() + print(nl()) +} + +/* Sample output of this report: + + SOUNDEX CODES OF ALL SURNAMES IN DATABASE + + + Surname Soundex Code + ------------- ------------ + ABERNATHY A165 + AHMADVAND-S A531 + ANDERSON A536 + ANDREWS A536 + BAILEY B400 + BARBIE B610 + BENNET B530 + +*/ + +/* End of Report */ + diff --git a/reports/sour.li b/reports/sour.li new file mode 100644 index 0000000..e460003 --- /dev/null +++ b/reports/sour.li @@ -0,0 +1,252 @@ +/* + * @progname sour.li + * @version 1995-09-08 + * @author Paul B. McBride (pbm%cybvax0@uunet.uu.net) + * @category + * @output Text + * @description + + functions for handling SOURces. + +Requirements: + LifeLines 3.0.2 or later (I hope) + +See Examples of using the library routines below. + +Tags within SOUR definitions which are processed by sour_ref(): + + REFN see below + TITL title + AUTH author + DATE publication date + EDIT which edition, revision, etc + VOLU number of volumnes (e.g. 3 vols) + PAGE page numbers + PUBL publisher + PLAC place of publication + LOCA where did you saw this source + +The following describes how I use the REFN tag. This is not particularly +relevant, but here goes. + +There are some standard abbreviations that are often used: + MD Mayflower Descendant + NEHGR New England Historic Genealogical Society Register + TAG The Americant Genealogist + RFC Royalty for Commoners + AR7 Ancestral Roots... 7th edition +I use other REFN's which are a combination of the subject, or author +and a suffix: + WentworthG Wentworth Genealogy + HayesFH a Hayes family history + ScituateVR Scituate, MA Vital Records + HamptonTH Hampton, NH Town History + +When I am entering a source field I would then enter it as: + + 2 SOUR + +and it will get converted to + + 2 @Sxxx@ SOUR + +Examples: + + 1) Report references used in a set of individuals + + include("sour.ll") + ... + sour_init() / * initialize the current source list and table * / + ... / * create a set of individuals * / + sour_addset(a_set) / * add all sources referenced by set * / + "References: " + sour_ref(13) / * output sources in GEDCOM format * / + + 2) List references for groups of individuals, and then a master + list of all sources referenced: + + include("sour.ll") + ... + table(my_table) + list(my_list) + ...for each group of individuals + { sour_init() / * initialize the current source list and table * / + ...for each individual... + { sour_addind(an_indi) + if(sour_exists()) { + "References: " + sour_see(",", 70, 10) / * report REFN of each source * / + sour_save(my_table, my_list) / * add to master list * / + } + } + } + sour_restore(my_table, my_list) / * make master list the current one * / + if(sour_exists()) { + "Key to References:" nl() nl() + sour_ref(10) / * report details for all sources * / + } + + 3) Output all sources for a set of individuals in GEDCOM format: + + include("sour.ll") + ... + sour_init() / * initialize the current source list and table * / + ... / * create a set of individuals * / + sour_addset(a_set) / * add all sources referenced by set * / + sour_ged() / * output sources in GEDCOM format * / + +08-sep-95 Paul B. McBride (pbm%cybvax0@uunet.uu.net) +*/ + +global(sour_list) +global(sour_table) + +proc sour_init() +{ + table(sour_table) + list(sour_list) +} + +proc sour_save(t, l) +{ + forlist(sour_list, v, n) { + if (eq(0, lookup(t, v))) { + insert(t, v, 1) + enqueue(l, v) + } + } +} + +proc sour_restore(t, l) +{ + set(sour_table, t) + set(sour_list, l) +} + +/* sour_add() adds the sources referenced for this individual */ + +proc sour_addind(i) +{ + traverse(root(i), m, l) { + if (nestr("SOUR", tag(m))) { continue() } + set(v, value(m)) + if(reference(v)) { + if (ne(0, lookup(sour_table, v))) { continue() } + set(v, save(v)) + insert(sour_table, v, 1) + enqueue(sour_list, v) + } + } +} + +proc sour_addset(s) +{ + forindiset (s, i, a, n) { + call sour_addind(i) + } +} + +proc sour_see(sep, maxlen, indent) +{ + set(first, 1) + set(curlen, indent) + set(seplen, strlen(sep)) + forlist(sour_list, k, n) { + if(first) { set(first, 0) } + else { + sep + set(curlen, add(curlen, seplen)) + } + set(myrefn, sour_getfield(dereference(k), "REFN")) + set(mylen, add(add(strlen(myrefn), seplen),2)) + if(and(gt(maxlen, 0), gt(add(curlen, mylen), maxlen))) { + col(indent) + set(curlen, indent) + } + "<" myrefn ">" + set(curlen, add(curlen, mylen)) + } +} + +proc sour_ref(colnum) +{ + forlist(sour_list, k, n) { + set(n, dereference(k)) + "<" sour_getfield(n, "REFN") ">" col(colnum) + qt() + sour_repfield(n, "TITL", colnum) + qt() + if(sour_getfield(n, "AUTH")) { + "," nl() + col(colnum) + sour_repfield(n, "AUTH", colnum) + } + set(d, sour_getfield(n, "DATE")) + if(d) { ", " d } + set(d, sour_getfield(n, "EDIT")) + if(d) { ", " d } + set(d, sour_getfield(n, "VOLU")) + if(d) { ", " d } + set(d, sour_getfield(n, "PAGE")) + if(d) { ", " d } + set(d, sour_getfield(n, "PUBL")) + if(d) { ", " nl() d } + set(d, sour_getfield(n, "PLAC")) + if(d) { ", " d } + "." nl() + if(sour_getfield(n, "NOTE")) { + col(colnum) + sour_repfield(n, "NOTE", colnum) + nl() + } + } +} + +func sour_exists() +{ + return(ne(length(sour_list), 0)) +} + +func sour_getfield(r, t) +{ + traverse(r, s, l) { + if (eq(0, strcmp(t, tag(s)))) { return(value(s)) } + } + return(0) +} + +func sour_repfield(r, t, colnum) +{ + set(found, 0) + fornodes(r, node) { + if (eq(0,strcmp(t, tag(node)))) { + set(found, 1) + value(node) + fornodes(node, subnode) { + if (eq(0,strcmp("CONT", tag(subnode)))) { + nl() + if(gt(colnum, 0)) { col(colnum) } + value(subnode) + } + } + break() + } + } + return(found) +} + +/* sour_ged() outputs the current source list in GEDCOM format */ + +proc sour_ged() +{ + forlist(sour_list, k, n) { + set(r, dereference(k)) + traverse(r, s, l) { + d(l) + if (xref(s)) { " " xref(s) } + " " tag(s) + if (value(s)) { " " value(s) } + "\n" + } + } +} diff --git a/reports/sour2.li b/reports/sour2.li new file mode 100644 index 0000000..b9a54f5 --- /dev/null +++ b/reports/sour2.li @@ -0,0 +1,379 @@ +/* + * @progname sour2.li + * @version 4.1 + * @author Paul B. McBride (pbm%cybvax0@uunet.uu.net) + * @category + * @output Text + * @description + +report program subroutine library for handling SOURces. + +add the following lines to your source program to use this library of +routines: + + include("quicksort.ll") + include("compare.ll") [define your own compare if necessary] + include("sour.li") + include("html.ll") + +27-feb-96 v4.1 - Indent PUBL info properly. Set source to LDS-AF if AFN seen. +14-feb-96 v4 - Use quicksort() to sort sources by REFN value +08-feb-96 v3 - Support REPO records +24-jan-96 v1.2 - GEDCOM 5.5 support and compatibility notes + Correct processing of Sources without REFN tags +03-oct-95 v1.1 - sour_addset() now adds sources for families of individuals + +Requirements: + LifeLines 3.0.2 or later (I hope) + +Future modifications: + - Add routines to report sources as references to footnotes, and + list sources in foot notes. Also report source citation detail + (PAGE, NOTE). + - Add support for repository records (REPO) to replace non standard + location (LOCA) records. + +See Examples of using the library routines below. + +Tags within SOUR definitions which are processed by sour_ref(): + +GEDCOM Non Standard + 5.5 + +REFN see below +TITL title +AUTH author +PUBL publisher information + DATE publication date + EDIT which edition, revision, etc + VOLU number of volumnes (e.g. 3 vols) + PAGE page numbers + PLAC place of publication +REPO LOCA where you saw this source (repository) +NOTE notes +TEXT text quoted from document + +The GEDCOM 5.5 standard combines all of the publication related info +into the PUBL tag line with continuations (CONT). It introduces +a repository structure which includes the NAME and address (ADDR structure) +of the location where the source can be viewed. + +The following describes how I use the REFN tag. This is not particularly +relevant, but here goes. + +There are some standard abbreviations that are often used: + MD Mayflower Descendant + NEHGR New England Historic Genealogical Society Register + TAG The Americant Genealogist + RFC Royalty for Commoners + AR7 Ancestral Roots... 7th edition +I use other REFN's which are a combination of the subject, or author +and a suffix: + WentworthG Wentworth Genealogy + HayesFH a Hayes family history + ScituateVR Scituate, MA Vital Records + HamptonTH Hampton, NH Town History + +When I am entering a source field I would then enter it as: + + 2 SOUR + +and it will get converted to + + 2 @Sxxx@ SOUR + +Examples: + + 1) Report references used in a set of individuals + + include("sour.li") + ... + call sour_init() / * initialize the current source list and table * / + ... / * create a set of individuals * / + call sour_addset(a_set) / * add all sources referenced by set * / + "References: " nl() nl() + call sour_ref(10) / * report details of all sources * / + + 2) List references for groups of individuals, and then a master + list of all sources referenced: + + include("sour.li") + ... + table(my_table) + list(my_list) + ...for each group of individuals + { call sour_init() / * initialize the current source list and table * / + ...for each individual... + { call sour_addind(an_indi) + if(sour_exists()) { + "References: " + call sour_see(",", 70, 10) / * report REFN of each source * / + call sour_save(my_table, my_list) / * add to master list * / + } + } + } + / * make master list the current list of sources * / + call sour_restore(my_table, my_list) + if(sour_exists()) { + "Key to References:" nl() nl() + call sour_ref(10) / * report details for all sources * / + } + + 3) Output all sources for a set of individuals in GEDCOM format: + + include("sour.li") + ... + call sour_init() / * initialize the current source list and table * / + ... / * create a set of individuals * / + call sour_addset(a_set) / * add all sources referenced by set * / + call sour_ged() / * output sources in GEDCOM format * / + +08-sep-95 Paul B. McBride (pbm%cybvax0@uunet.uu.net) +*/ + +global(sour_list) +global(sour_table) + +proc sour_init() +{ + table(sour_table) + list(sour_list) +} + +proc sour_save(t, l) +{ + forlist(sour_list, v, n) { + if (eq(0, lookup(t, v))) { + insert(t, v, 1) + enqueue(l, v) + } + } +} + +proc sour_restore(t, l) +{ + set(sour_table, t) + set(sour_list, l) +} + +/* sour_add() adds the sources referenced for this individual. This + will also work for families + */ + +proc sour_addind(i) +{ + traverse(root(i), m, l) { + set(v, 0) + if (eqstr("AFN", tag(m))) { + set(v, "LDS-AF") + } + elsif (eqstr("SOUR", tag(m))) { + set(v, value(m)) + if(not(reference(v))) { set(v, 0) } + } + if(v) { + if (ne(0, lookup(sour_table, v))) { continue() } + set(v, save(v)) + insert(sour_table, v, 1) + enqueue(sour_list, v) + } + } +} + +proc sour_addset(s) +{ + forindiset (s, i, a, n) { + call sour_addind(i) + families(i, f, sp, m) { + call sour_addind(f) + } + } +} + +proc sour_see(sep, maxlen, indent) +{ + set(first, 1) + set(curlen, indent) + set(seplen, strlen(sep)) + forlist(sour_list, k, n) { + if(first) { set(first, 0) } + else { + sep + set(curlen, add(curlen, seplen)) + } + if(eqstr(k, "LDS-AF")) { set(myrefn, k) } + else { + set(myrefn, sour_getfield(dereference(k), "REFN")) + if(eq(myrefn, 0)) { set(myrefn, k) } + } + set(mylen, add(add(strlen(myrefn), seplen),2)) + if(and(gt(maxlen, 0), gt(add(curlen, mylen), maxlen))) { + col(indent) + set(curlen, indent) + } + call html_lt() /* < */ + if(eq(html_ext, 0)) { set(html_ext, ".html") } + call html_ahref("ref", html_ext, myrefn) + myrefn + call html_tag("/A", 0) + call html_gt() /* > */ + set(curlen, add(curlen, mylen)) + } + + if(and(HTML, eq(first,0))) { + call html_tag("P", 1) + } +} + +proc sour_ref(colnum) +{ + list(alist) + list(ilist) + + /* build list of reference keys */ + forlist(sour_list, k, n) { + if(eqstr(k, "LDS-AF")) { set(refn, k) } + else { + set(anode, dereference(k)) + set(refn, sour_getfield(anode, "REFN")) + if(eq(refn, 0)) { set(refn, k) } + } + enqueue(alist, save(refn)) + } + + /* sort the list */ + call quicksort(alist, ilist) + + /* report */ + call html_tag("UL", 0) + while(n, dequeue(ilist)) { + set(ldsaf, 0) + set(k, getel(sour_list, n)) + call html_tag("LI", 0) + call html_tag("PRE", 1) + if(eqstr(k, "LDS-AF")) { set(refn, k) set(ldsaf, 1) } + else { + set(anode, dereference(k)) + set(refn, sour_getfield(anode, "REFN")) + if(eq(refn, 0)) { set(refn, k) } + } + call html_lt() /* < */ + refn + call html_gt() /* > */ + col(colnum) + qt() + if(ldsaf) { "LDS Ancestral File" } + else {sour_repfield(anode, "TITL", colnum) } + qt() + if(HTML) { + call html_aname(refn) + } + if(ldsaf) { "." nl() } + else { + if(sour_getfield(anode, "AUTH")) { + "," nl() + col(colnum) + sour_repfield(anode, "AUTH", colnum) + } + set(d, sour_getfield(anode, "DATE")) + if(d) { ", " d } + set(d, sour_getfield(anode, "EDIT")) + if(d) { ", " d } + set(d, sour_getfield(anode, "VOLU")) + if(d) { ", " d } + set(d, sour_getfield(anode, "PAGE")) + if(d) { ", " d } + set(d, sour_getfield(anode, "PUBL")) + if(d) { ", " nl() col(colnum) d } + set(d, sour_getfield(anode, "PLAC")) + if(d) { ", " d } + "." nl() + if(html_urls(anode, colnum)) { nl() } + if(sour_getfield(anode, "NOTE")) { + col(colnum) + sour_repfield(anode, "NOTE", colnum) + nl() + } + if(sour_getfield(anode, "TEXT")) { + col(colnum) + sour_repfield(anode, "TEXT", colnum) + nl() + } + } + call html_tag("/PRE", 0) + call html_tag("/LI", 0) + } + call html_tag("/UL", 0) +} + +func sour_exists() +{ + return(ne(length(sour_list), 0)) +} + +func sour_getfield(r, t) +{ + traverse(r, s, l) { + if (eq(0, strcmp(t, tag(s)))) { return(value(s)) } + } + return(0) +} + +func sour_repfield(r, t, colnum) +{ + set(found, 0) + fornodes(r, node) { + if (eq(0,strcmp(t, tag(node)))) { + set(found, 1) + value(node) + fornodes(node, subnode) { + if (eq(0,strcmp("CONT", tag(subnode)))) { + nl() + if(gt(colnum, 0)) { col(colnum) } + value(subnode) + } + } + break() + } + } + return(found) +} + +/* sour_ged() outputs the current source list in GEDCOM format */ + +proc sour_ged() +{ + table(other_table) + list(other_list) + + forlist(sour_list, k, n) { + if(reference(k)) { + set(r, dereference(k)) + traverse(r, s, l) { + d(l) + if (xref(s)) { " " xref(s) } + " " tag(s) + if (v, value(s)) { + " " v + if(reference(v)) { + if (ne(0, lookup(other_table, v))) { continue() } + set(v, save(v)) + insert(other_table, v, 1) + enqueue(other_list, v) + } + } + "\n" + } + } + } + forlist(other_list, k, n) { + set(r, dereference(k)) + traverse(r, s, l) { + d(l) + if (xref(s)) { " " xref(s) } + " " tag(s) + if (v, value(s)) { " " v } + "\n" + } + } +} diff --git a/reports/sources.ll b/reports/sources.ll new file mode 100644 index 0000000..0bfc59c --- /dev/null +++ b/reports/sources.ll @@ -0,0 +1,83 @@ +/* + * @progname sources.ll + * @version 1.0 + * @author + * @category + * @output Text + * @description + * + * Print the sources associated with an individual. + */ +global(refn) /* root node of references record */ +global(reftab) /* table of reference keys reported on */ +global(ref1) + +proc main () +{ + getindi(refn, "Enter name of record that hold the references") + if (eq(refn, 0)) { + print("The references could not be found; program not run\n") + } else { + set(refn, inode(refn)) + call foundrefs() + } +} + +proc foundrefs () +{ + table(refs) + set(ref1, 0) + getindi(indi, "Enter a person to show sources for.") + while (indi) { + call showperson(indi) + "\n" + getindi(indi, "Enter another person to show sources for.") + } + print("Program over!\n") +} + +proc showperson (indi) +{ + call showvitals(indi) + call showsources(indi) +} + +proc showvitals (i) +{ + name(i) ".\n" + set(e,birth(i)) + if(and(e,long(e))) { "Born " long(e) ".\n" } + set(e,death(i)) + if(and(e,long(e))) { "Died " long(e) ".\n" } +} + +proc showsources (i) /* finds all SOUR lines in a record */ +{ + table(reftab) + set(ref1, 0) + traverse (inode(i), s, n) { + if (eq(0, strcmp("SOUR", tag(s)))) { + call showsource(value(s)) + } + } +} + +proc showsource (v) /* process each SOUR line in a record */ +{ + set(ref, 0) + fornodes (refn, s) { /* look at each REFN line in references */ + if (eq(0, strcmp(v, value(s)))) { /* found one with matching code! */ + set(ref, s) /* so set ref to this REFN node */ + } + } + if (ref) { /* non-null if matching code were found */ + if (not(lookup(reftab, v))) { /* and we hadn't seen it yet */ + if (not(ref1)) { /* Print "References:" before first one */ + "References:\n" + set(ref1, 1) + } + "\t" value(child(ref)) "\n" /* This could be much better! */ + insert(reftab, v, 1) /* So we won't show it again! */ + } + } +} diff --git a/reports/sources_bib.ll b/reports/sources_bib.ll new file mode 100644 index 0000000..a242ecf --- /dev/null +++ b/reports/sources_bib.ll @@ -0,0 +1,395 @@ +/* + * @progname sources_bib.ll + * @version 1999-02 + * @author Dennis Nicklaus (nicklaus@fnal.gov) + * @category + * @output LaTeX + * @description + + Lifelines report program. + Write out a LaTex bibliography entry line for each source referenced + by an indi or family record in the whole database. + This is pretty slow. + The bibliography printed out is useful for the html.dn programs + (if you first run it through my bib2html.c program) + or for a Latex document. + + The bibliography is pretty much the same as that generated as part of + the book-latex code. (But book-latex generates its own bibliography, + so you don't need this for that.) + + Most of the code for this report program was copied directly from book-latex. + + Deficiency?: May not generate an entry for a source which is only referenced + from within another source. I don't know. +*/ + +global (bibList) +global (bibTable) +global (sourceList) +global (gotValue) +global (gottenNode) +global (gottenValue) +global(sour_list) +global(sour_table) + +proc main () +{ + list (bibList) + table (bibTable) + list (sourceList) + table(sour_table) + list(sour_list) + + call sour_addset() + call sour_ged() + + while (b, dequeue (bibList)) { b } + +} + + + + +proc sour_addset() +{ + forindi(person, number) { + print(".") + traverse(root(person),m,l) { + call print_sources(m) + } + families(person, f, sp, m) { + traverse(root(f),m,l) { + call print_sources(m) + } + } + } + +} + +/* sour_ged() outputs the current source list in GEDCOM format */ + +proc sour_ged() +{ + table(other_table) + list(other_list) + + forlist(sour_list, k, n) { + set(r, dereference(k)) + traverse(r, s, l) { + d(l) + if (xref(s)) { " " xref(s) } + " " tag(s) + if (v, value(s)) { + " " v + if(reference(v)) { + if (ne(0, lookup(other_table, v))) { continue() } + if (ne(0, lookup(sour_table, v))) { continue() } + set(v, save(v)) + insert(other_table, v, 1) + enqueue(other_list, v) + } + } + "\n" + } + } + forlist(other_list, k, n) { + set(r, dereference(k)) + traverse(r, s, l) { + d(l) + if (xref(s)) { " " xref(s) } + " " tag(s) + if (v, value(s)) { " " v } + "\n" + } + } +} +/* print_sources (root) + Prints all sources (SOUR lines) associated with the given GEDCOM line. The + sources are formated as LaTeX footnotes. This routine prints each SOUR line + as a separate footnote, which is not correct. This should be corrected so + that all sources are combined into a single footnote. */ + +proc print_sources (root) +{ + enqueue(sourceList,root) + call sourceIt(sourceList) +} + +proc getValue (root, t) { + set (gotValue, 0) + if (root) { + fornodes (root, node) { + if (and (not (gotValue), not (strcmp (tag (node), t)))) { + set (gotValue, 1) + set (gottenNode, node) + set (gottenValue, save (value (node))) + } + } + } +} + +proc getValueCont (root, t) { + set (gotValue, 0) + if (root) { + fornodes (root, node) { + if (and (not (gotValue), not (strcmp (tag (node), t)))) { + set (gotValue, 1) + set (gottenNode, node) + set (gottenValue, save (value (node))) + fornodes (node, subnode) { + if (not (strcmp ("CONT", tag (subnode)))) { + if (strlen (value (subnode))) { + set (gottenValue, + save (concat (gottenValue, concat ("\n", value (subnode))))) + } + } elsif (not (strcmp ("CONC", tag (subnode)))) { + if (strlen (value (subnode))) { + set (gottenValue, + save (concat (gottenValue, value (subnode)))) + } + } + } + } + } + } +} + +proc getValueCommaCont (root, t) { + set (gotValue, 0) + if (root) { + fornodes (root, node) { + if (and (not (gotValue), not (strcmp (tag (node), t)))) { + set (gotValue, 1) + set (gottenNode, node) + set (gottenValue, save (value (node))) + fornodes (node, subnode) { + if (not (strcmp ("CONT", tag (subnode)))) { + if (strlen (value (subnode))) { + set (gottenValue, + save (concat (gottenValue, concat (",\n", value (subnode))))) + } + } elsif (not (strcmp ("CONC", tag (subnode)))) { + if (strlen (value (subnode))) { + set (gottenValue, + save (concat (gottenValue, value (subnode)))) + } + } + } + } + } + } +} + + + + +proc sourceIt (sourceList) { + list (cList) + list (fList) + while (root, dequeue (sourceList)) { + fornodes (root, node) { + if (not (strcmp (tag (node), "SOUR"))) { + set (footnote, 1) + set (val, value (node)) + if (val) { + if (reference(val)){ + call bibliographize (dereference(val)) + } + } + if (xref (node)) { + call bibliographize (node) + set (val, xref (node)) + } + if (val) { + set (a1, index (val, "@", 1)) + set (a2, index (val, "@", 2)) + if (and (eq (a1, 1), eq (a2, strlen (val)))) { + set (c, save (substring (val, 2, sub (strlen (val), 1)))) + enqueue (cList, c) + incr (cn) + set (footnote, 0) + } + } else { + set (subnodecount, 0) + fornodes (node, subnode) { + if (strcmp (tag (subnode), "SOUR")) { + incr (subnodecount) + } + } + if (eq (subnodecount, 0)) { + fornodes (node, subnode) { + set (val, value (subnode)) + /* With loadsources, this is needed here. It is technically + illegal gedcom. */ + if (xref (subnode)) { + call bibliographize (subnode) + set (val, xref (subnode)) + } + if (val) { + set (a1, index (val, "@", 1)) + set (a2, index (val, "@", 2)) + if (and (eq (a1, 1), eq (a2, strlen (val)))) { + set (c, save (substring (val, 2, sub (strlen (val), 1)))) + enqueue (cList, c) + incr (cn) + } + } + } + set (footnote, 0) + } + } + if (footnote) { + enqueue (fList, node) + } + } + } + } + while (cn) { + forlist (cList, c, n) { + if (and (ne (n, cn), not (strcmp (c, getel(cList, cn))))) { + setel (cList, cn, "") + } + } + decr (cn) + } +} + +proc bibliographize (root) { + set (val, xref (root)) + set (c, save (substring (val, 2, sub (strlen (val), 1)))) + + if (not (lookup (bibTable, c))) { + insert (bibTable, c, 1) + +/* call getValueCont (root, "TEXT") + if (figureFlag, gotValue) { + enqueue (figureCiteList, c) + enqueue (figureNodeList, gottenNode) + }*/ + set (cref, save (concat ("\\protect\\ref{", concat (c, "}")))) + set (pref, save (concat ("\\protect\\pageref{", concat (c, "}")))) + + set (b, "\\bibitem") + if (figureFlag) { + set (b, save (concat (b, concat ("[", concat (cref, "]"))))) + } + set (b, save (concat (b, concat ("{", concat (c, "} "))))) + call getValueCont (root, "TITL") + if (gotValue) { + set (b, save (concat (b, concat ("{\\em ", concat (gottenValue, "}, "))))) + } + call getValueCont (root, "AUTH") + if (gotValue) { + set (b, save (concat (b, concat (" ", concat (gottenValue, ", "))))) + } + call getValueCont (root, "PUBL") + if (gotValue) { + set(pubnode,gottenNode) + call getValueCont (pubnode, "NAME") + if (gotValue) { + set (b, save (concat (b, concat ("in {\\em ", concat (gottenValue, "}, "))))) + } + call getValueCommaCont (pubnode, "ADDR") + if (gotValue) { set (b, save (concat (b, concat (gottenValue, ": ")))) } + call getValueCont (pubnode, "PUBR") + if (gotValue) { set (b, save (concat (b, concat (gottenValue, ", ")))) } + call getValueCont (pubnode, "PHON") + if (gotValue) { set (b, save (concat (b, concat (gottenValue, ", ")))) } + call getValueCont (pubnode, "DATE") + if (gotValue) { set (b, save (concat (b, concat (gottenValue, ", ")))) } + call getValueCont (pubnode, "VOLU") + if (gotValue) { + set (word, "Volume ") + if (or (index (gottenValue, "-", 1), + or (index (gottenValue, ",", 1), + index (gottenValue, "and ", 1)))) { + set (word, "Volumes ") + } + set (b, save (concat (b, concat (word, concat (gottenValue, ", "))))) + } + call getValueCont (pubnode, "NUM") + if (gotValue) { + set (word, "Number ") + if (or (index (gottenValue, "-", 1), + or (index (gottenValue, ",", 1), + index (gottenValue, "and ", 1)))) { + set (word, "Numbers ") + } + set (b, save (concat (b, concat (word, concat (gottenValue, ", "))))) + } + call getValueCont (root, "LCCN") + if (gotValue) { + set (b, save (concat (b, concat ("Call Number ", concat (gottenValue, ", "))))) + } + + } + call getValueCont (root, "PAGE") + if (gotValue) { + set (word, "page ") + if (or (index (gottenValue, "-", 1), + or (index (gottenValue, ",", 1), + index (gottenValue, "and ", 1)))) { + set (word, "pages ") + } + set (b, save (concat (b, concat (word, concat (gottenValue, ", "))))) + } + call getValueCont (root, "FILM") + if (gotValue) { + set (b, save (concat (b, + concat ("Filmed by the Church of Jesus Christ of Latter Day Saints, Microfilm Number ", + concat (gottenValue, ", "))))) + } + call getValueCont (root, "FICH") + if (gotValue) { + set (b, save (concat (b, + concat ("Filmed by the Church of Jesus Christ of Latter Day Saints, Microfiche Number ", + concat (gottenValue, ", "))))) + } + call getValueCont (root, "REPO") + if (gotValue) { + set (b, save (concat (b, concat ("at ", concat (gottenValue, ", "))))) + } + + + if (index (b, ", ", 1)) { + set (b, save (concat (save (substring (b, 1, sub (strlen (b), 2))), "."))) + } + + call getValueCont (root, "NOTE") + if (gotValue) { set (b, save (concat (b, concat (" ", gottenValue)))) } + + call getValueCont (root, "TEXT") + if (gotValue) { set (b, save (concat (b, concat (" ", gottenValue)))) } + + call getValueCont (root, "SOUR") + if (gotValue) { + set (bb, "?") + if (gottenValue) { + set (a1, index (gottenValue, "@", 1)) + set (a2, index (gottenValue, "@", 2)) + if (and (eq (a1, 1), eq (a2, strlen (gottenValue)))) { + set (bb, + save (substring (gottenValue, 2, sub (strlen (gottenValue), 1)))) + } + } + set (b, save (concat (b, concat ("\\cite{", concat (bb, "}"))))) + } + + if (figureFlag) { + set (b, + save (concat (b, concat (" See figure on page~", concat (pref, "."))))) + } + + while (i, index (b, "\n", 1)) { + set (b, save (concat (substring (b, 1, sub (i, 1)), + concat (" ", + substring (b, add (i, 1), strlen (b)))))) + } + + enqueue (bibList, save (concat (b, "\n"))) + } +} + + + diff --git a/reports/span.ll b/reports/span.ll new file mode 100644 index 0000000..4530376 --- /dev/null +++ b/reports/span.ll @@ -0,0 +1,335 @@ +/* + * @progname span + * @version 1.1 + * @author Stephen Dum + * @category + * @output text + * @description + +Scan the database and report on the range of ages between birth to marriage, +birth of parent to birth of child, and age at death. Generates a histogram +of the results and reports minimum, maximum and average values. Designed +to be run with llexec, with a command like 'llexec database -x span'. + +Note, the resultant histogram will normally fit nicely in a 80 column window, +(except death range, which could take more like 132 columns) +if it doesn't it's usually because of some bogus dates (like seeing a mothers +age as -8 or 70 at the birth of a child.) This script contains added +complexity to identify the min and max cases, however, the script verify.ll +will report all the outlying cases in one pass. The average value is +indicated on the histogram by using asterisks (*). + +Also, you can disable the scripts using of dates that are estimates. +However, this is done by modifing the script rather than having the script +prompt for an answer, as this is expected to be a less likely case. + + Stephen Dum (stephen.dum@verizon.net) + Version 1, 2 November 2005 +*/ + +global(dohist) +global(estdate) + +proc main() +{ + set(dohist,1) /* generate histograms */ + set(estdate,0) /* skip estimated dates */ + /* we accumulate 4 statistics from the database and store them in + * the following lists + */ + list(hus_mar) /* marriage age of husband */ + list(wif_mar) /* marriage age of wife */ + list(hus_child) /* husbands age at birth of child */ + list(wif_child) /* wifes age at birth of child */ + list(death_ages) /* age at death */ + /* to assist in identifing the unusual extreme situations, + * (like where it reports a husband was married at 192 years old + * or at -46 years old + * we keep some auxilary data for these lists + */ + list(hus_mar_id) /* Family and husband keys */ + list(wif_mar_id) /* Family and wife keys */ + list(hus_child_id) /* Family, husband and child key */ + list(wif_child_id) /* Family, wife and child key */ + list(death_ages_id) /* Family, husband and child key */ + + forfam(fam, cnt) { + list(hus_dates) /* husband birth dates */ + list(wif_dates) /* wife birth dates */ + list(child_dates) /* child birth dates */ + list(hus_id) /* husband id */ + list(wif_id) /* wife id */ + list(child_id) /* child id */ + /* first process the family and get birth dates for husband, wife and + * children + */ + set(marr_date,get_marriage_date(fam)) + + fornodes(fam,node) { + if (eqstr(tag(node),"HUSB")) { + if (val, get_birth_date(indi(value(node)))) { + push(hus_dates,val) + push(hus_id,key(indi(value(node)))) + } + } elsif (eqstr(tag(node),"WIFE")) { + if (val, get_birth_date(indi(value(node)))) { + push(wif_dates,val) + push(wif_id,key(indi(value(node)))) + } + } elsif (eqstr(tag(node),"CHIL")) { + if (val, get_birth_date(indi(value(node)))) { + push(child_dates,val) + push(child_id,key(indi(value(node)))) + } + } + } + /* + print ("Length of hus_dates ",d(length(hus_dates)),nl()) + print ("Length of wif_dates ",d(length(wif_dates)),nl()) + print ("Length of child_dates ",d(length(child_dates)),nl()) + */ + /* we now have parents and children dates if any, see if + * we know enough to process them + * + * First - look at marriage date vs parents + */ + if (marr_date) { + forlist(hus_dates,val,cnt) { + push(hus_mar,sub(marr_date,val)) + push(hus_mar_id,concat(key(fam)," ",getel(hus_id,cnt))) + } + forlist(wif_dates,val,cnt) { + push(wif_mar,sub(marr_date,val)) + push(wif_mar_id,concat(key(fam)," ",getel(wif_id,cnt))) + } + } + + /* Second + for each parent - child pair + */ + forlist(hus_dates,val,cnt) { + forlist(child_dates,val1,cnt1) { + push(hus_child,sub(val1,val)) + push(hus_child_id, + concat(key(fam)," ",getel(hus_id,cnt)," ",getel(child_id,cnt1)) + ) + } + } + forlist(wif_dates,val,cnt) { + forlist(child_dates,val1,cnt1) { + push(wif_child,sub(val1,val)) + push(wif_child_id, + concat(key(fam)," ",getel(wif_id,cnt)," ",getel(child_id,cnt1)) + ) + } + } + } + forindi(indi,cnt) { + if (val, get_birth_date(indi)) { + if (val2,get_death_date(indi)) { + push(death_ages,sub(val2,val)) + push(death_ages_id,key(indi)) + } + } + } + print(nl()) + if (not(dohist)) { + print(" min ave max pairs keys of match",nl()) + } + call output(hus_mar,hus_mar_id, "Male Marriage Age ") + call output(wif_mar,wif_mar_id, "Female Marriage Age") + call output(hus_child,hus_child_id, "Husband-Child Age ") + call output(wif_child,wif_child_id, "Wife-Child Age ") + call output(death_ages,death_ages_id,"Death Age ") +} + +proc output(alist,idlist,title) +{ + list(hist) + if (length(alist)) { + set(min,getel(alist,1)) + set(max,min) + set(min_id,getel(idlist,1)) + set(max_id,min_id) + set(sum,0) + forlist(alist,val,cnt) { + /* compute histogram data */ + set(x,div(val,365)) + setel(hist,x,add(getel(hist,x),1)) + + if (gt(min,val)) { + set(min,val) + set(min_id,getel(idlist,cnt)) + } + if (lt(max,val)) { + set(max,val) + set(max_id,getel(idlist,cnt)) + } + incr(sum,val) + } + set(sum,div(sum,mul(365.0,length(alist)))) + set(min,div(min,365.0)) + set(max,div(max,365.0)) + + if (dohist) { + /* generate histogram */ + set(min,int(min)) + set(hmax,0) + forlist(hist,val,cnt) { + if (gt(val,hmax)) { + set(hmax,val) + } + } + set(hincr,div(add(hmax,9),10)) + set(cnt,10) + while(cnt) { + set(htar,add(mul(sub(cnt,1),hincr),1)) + if (or(eq(cnt,10),eq(cnt,7),eq(cnt,4),eq(cnt,1))) { + print(fl(d(htar),5),"+") + } else { + print(" |") + } + forlist(hist,val,cnt1) { + if (ge(cnt1,min)) { + if (ge(val,htar)) { + if (eq(cnt1,int(sum))) { + print("*") + } else { + print("x") + } + } else { + print(" ") + } + } + } + print (nl()) + + decr(cnt) + } + set(cnt1,min) + print( " ") + while(lt(cnt1,max)) { + incr(cnt1,5) + print("+----") + } + print(nl()) + print( " ") + set(cnt1,sub(min,1)) + while(lt(cnt1,max)) { + print(fr(d(cnt1),4)) + incr(cnt1,5) + } + print(" min ave max pairs keys of match",nl()) + } + print(title," ",fl(f(min),7),fl(f(sum),7),fl(f(max),8)) + print(fl(d(length(alist)),6)," ",min_id," :: ",max_id,nl()) + } else { + if (dohist) { + print(" min ave max pairs keys of match",nl()) + } + print(title," ",fl("-",7),fl("-",7),fl("-",8),nl()) + } + print(nl()) +} + +/* fl(str,len) + * insert spaces to right of str, to make it's length is at least len + */ +func fr(str,len) { + if (lt(strlen(str),len)) { + set(fil,sub(len,strlen(str))) + incr(fil) + } else { + set(fil,1) + } + return(concat(str,substring(" ",1,fil))) +} + +/* fl(str,len) + * insert spaces to left of str, to make it's length at least len + */ +func fl(str,len) { + if (lt(strlen(str),len)) { + set(fil,sub(len,strlen(str))) + } else { + set(fil,0) + } + return(concat(substring(" ",1,fil),str)) +} +func get_marriage_date(fam) +{ + if (m,marriage(fam)) { + if (strlen(date(m))) { + if (estdate) { + if (index(date(m),"EST",1)) { + return(0) + } + } + extractdate(m,day,month,year) + if (year) { + return(julian(day,month,year)) + } + } + } + return(0) +} +func get_birth_date(indi) +{ + if (b,birth(indi)) { + if (strlen(date(b))) { + if (estdate) { + if (index(date(b),"EST",1)) { + return(0) + } + } + extractdate(b,day,month,year) + if (year) { + return(julian(day,month,year)) + } + } + } + return(0) +} +func get_death_date(indi) +{ + if (b,death(indi)) { + if (strlen(date(b))) { + if (estdate) { + if (index(date(b),"EST",1)) { + return(0) + } + } + extractdate(b,day,month,year) + if (year) { + return(julian(day,month,year)) + } + } + } + return(0) +} + +/* + * The first day that the Gregorian calendar was used in the British Empire + * was Sep 14, 1752. The previous day was Sep 2, 1752 + * by the Julian Calendar. The year began at March 25th before this date. + * Computations not corrected for dates before Sep 14, 1752 nor necessarily + * for other countries. + */ + +func julian(day,mon,year) { + if (gt(mon,2)) { set(mon,sub(mon,3)) } + else { set(mon,add(mon,9)) decr(year) } + + set(c,div(year,100)) + set(ya, sub(year,mul(100,c))) + set(jd, add( div(mul(146097,c),4), + add(div(mul(1461,ya),4), + add(div(add(mul(153,mon),2),5), + add(day, 1721119))))) + /* for our usage this probably doesn't matter + if (lt(jd,2361222)) { + print("Warning, Attempt to compute date prior to Brittish use of Gregorian calendar\n") + } + */ + return(jd) +} diff --git a/reports/src-rtf.ll b/reports/src-rtf.ll new file mode 100644 index 0000000..8409691 --- /dev/null +++ b/reports/src-rtf.ll @@ -0,0 +1,62 @@ +/* + * @progname src-rtf.ll + * @version none + * @author Paul Buckely + * @category + * @output RTF + * @description + * + * List sources in RTF, a modification of src.ll . + * + */ + +/*include ("util.ll") for using nodetag(), which is much slower*/ + +proc main () +{ + set(i, 1) + set(errcnt, 1) + newfile(strconcat(database(),".src.rtf"),0) + dayformat(0) + monthformat(4) + dateformat(8) /* this is used so I can sort by numeric date*/ + "{\\rtf1\\ansicpg1000{\\fonttbl\\f0\\fnil Times-Roman;}\n" + "\\margl720\\margr720\\margt720\\margb720\\viewkind1\n" + "\\pard\\tx560\\tx2700\\tx4140\\tx5020\\f0\\b0\\i0\\fs20\\fi-5020\\li5020\\fc0\\cf0\ " + "\\ul Ref#\\ulnone \t\n" + "\\ul Key\\ulnone \t\n" + "\\ul Entered\\ulnone \t\n" + "\\ul Order\\ulnone \t\n" + "\\ul Title\\ulnone \\\n" + while(le(errcnt,100)) { + set(skey, concat("@S",d(i),"@")) + if(snode, dereference(skey)) { + set(mytitle, "") + set(myrefn, "") + set(mydate, "") + set(order, "") + fornodes(snode, anode) { + if(eqstr(tag(anode),"TITL")) { + set(mytitle, save(value(anode))) } + elsif(eqstr(tag(anode),"REFN")) { + set(myrefn, save(value(anode))) } + /*set(myrefn, nodetag(snode, "REFN")) this works but it's much slower*/ + set(mydate, stddate(snode)) + extractdate(snode, dy, mo, yr) + set(order, add(mul(100,mo),add(dy,mul(2,yr)))) + } + d(i) "\t" myrefn "\t" mydate "\t" d(order) "\t" mytitle"\\\n" + } + else { + set(errcnt, add(errcnt,1)) + } + set(i, add(i,1)) + } + "\\\n\\\n" + "References generated " + date(gettoday()) + " from " + concat(database(),".gedcom") + " using LifeLines genealogy software.\\\n" + nl() "}" +} diff --git a/reports/src.ll b/reports/src.ll new file mode 100644 index 0000000..4cca0bb --- /dev/null +++ b/reports/src.ll @@ -0,0 +1,32 @@ +/* +* @progname src.ll +* @version 2.0 +* @author McBride +* @category sample +* @output text +* @description +Here is a report program to list SOURces. The REFN and TITL +values are shown. Other tags can be added by duplicating +the lines that containing "myrefn" or "REFN" and replacing them +with the tag you want. + +To process tags that have CONTinuation lines, or tags with no +values you need something more complicated. + +"P. McBride" +*/ + +proc main () +{ + forsour(snode, i) { + set(mytitle, "") + set(myrefn, "") + fornodes(root(snode), anode) { + if(eqstr(tag(anode),"TITL")) { set(mytitle, save(value(anode))) } + elsif(eqstr(tag(anode),"REFN")) { + set(myrefn, save(value(anode))) + } + } + myrefn "\t" key(snode) "\t" mytitle nl() + } +} diff --git a/reports/ssdi-import.ll b/reports/ssdi-import.ll new file mode 100644 index 0000000..6008586 --- /dev/null +++ b/reports/ssdi-import.ll @@ -0,0 +1,417 @@ +/* + * @progname ssdi-import.ll + * @version 1994-11-12 + * @author Kurt Baudendistel (baud@research.att.com) + * @category + * @output GEDCOM + * @description + * + * Convert ssdi gedcom to lifelines-standard gedcom + * + * 12 NOV 1994 (3.0.1) baud@research.att.com + * Derived from import-igi. + */ + +proc main () +{ + getstrmsg (msg, "SSDI Version [default X/1992]?") + if (streq (msg, "")) { + set (ssdiversion, "X") + set (ssdidate, "1992") + } else { + if (i, index (msg, "/", 1)) { + set (ssdiversion, save (trim (msg, sub (i, 1)))) + set (ssdidate, save (cut (msg, add(i, 1)))) + } else { + set (ssdiversion, save (msg)) + set (ssdidate, "") + } + } + + "0 HEAD \n" + "1 SOUR LIFELINES\n" + "2 VER 3.0.1\n" + "2 NAME SSDI-IMPORT REPORT\n" + "1 DEST LIFELINES\n" + "2 VER 3.0.1\n" + "1 DATE " date (gettoday ()) "\n" + "1 COPR Copyright " date (gettoday ()) ". Permission is granted to repro" + "duce any subset\n2 CONT of the data contained herein under the condit" + "ion that this copyright\n2 CONT notice is preserved, that the origina" + "l source citations referenced\n2 CONT in the subset are included, and" + " that the submitter of this file is\n2 CONT credited with original au" + "thorship as appropriate.\n" + "1 CHAR ASCII\n" + + "0 @S1@ SOUR\n" + "1 NAME Social Security Death Index\n" + if (strlen (ssdiversion)) { + "1 VER " ssdiversion "\n" + } + if (strlen (ssdidate)) { + "1 DATE " ssdidate "\n" + } + + print ("Processing nodes ...\n") + forindi (indi, in) { + print ("i") + ssdiimport (indi) + } + + "0 TRLR \n" +} + +func ssdiimport (indi) +{ + set (number, 0) + set (residences, 0) + set (root, inode (indi)) + forlist (subnodes (root, "NOTE"), note, nn) { + if (streq (trim (value (note), 24), "Social Security Number: ")) { + set (number, save (cut (value (note), 25))) + } elsif (streq (value (note), "Death Residence Localities")) { + set (residences, localities (note)) + } + deletenode (note) + } + + reformatnames (root, "@S1@") + + if (number) { + set (ssn, createnode ("SSN", number)) + if (birthplace, subnode (birth (indi), "PLAC")) { + if (streq (value (birthplace), "Not Identified")) { + set (ssnsour, + createnodes ("SOUR", + concat ("Issued to ", + concat (fullname (indi, 0, 1, 999), + ", but no location of issuance was identified.")))) + } else { + set (ssnsour, + createnodes ("SOUR", + concat ("Issued in ", + concat (value (birthplace), + concat (" to ", + concat (fullname (indi, 0, 1, 999), ".")))))) + } + catnode (ssnsour, createnode ("SOUR", "@S1@")) + catnode (ssn, ssnsour) + } else { + catnode (ssn, createnode ("SOUR", "@S1@")) + } + addnode (ssn, root, subnode (root, "NAME")) + } + + if (birth (indi)) { + if (birthplace, subnode (birth (indi), "PLAC")) { + deletenode (birthplace) + } + catnode (birth (indi), createnode ("SOUR", "@S1@")) + } + + if (death (indi)) { + set (deathplace, subnode (death (indi), "PLAC")) + set (zip, "an unknown") + if (code, dequeue (residences)) { + if (streq (trim (code, 10), "Zip Code: ")) { + set (zip, save (concat ("the ", cut (code, 11)))) + } else { + requeue (residences, zip) + } + } + if (rn, residences) { + forlist (residences, res, rn) { + catnode (death (indi), createnode ("PLAC", res)) + if (and (deathplace, index (res, value (deathplace), 1))) { + deletenode (deathplace) + set (deathplace, 0) + } + } + } + if (and (deathplace, not (value (deathplace)))) { + deletenode (deathplace) + } + if (rn) { + if (eq (rn, 1)) { + set (trailer, " zip code.") + } else { + set (trailer, " zip code, which encompasses the named localities.") + } + set (sour, createnodes ("SOUR", + concat3 ("The residence at the time of death was in ", zip, trailer))) + catnode (sour, createnode ("SOUR", "@S1@")) + catnode (death (indi), sour) + } else { + catnode (death (indi), createnode ("SOUR", "@S1@")) + } + } + + gedcomnode (root) + return (0) +} + +func localities (root) { + list (residences) + if (root) { + fornodes (root, node) { + enqueue (residences, value (node)) + } + } + return (residences) +} + +/* common import/export functions */ + +func cond (x, a, b) { + if (x) { + return (a) + } else { + return (b) + } +} + +func gedcomnode (root) { + traverse (root, node, level) { + d (level) + if (x, xref (node)) { " " x } + if (x, tag (node)) { " " x } + if (x, value (node)) { " " x } + "\n" + } + return (0) +} + +func denull (alist) { + list (blist) + forlist (alist, a, an) { + if (a) { enqueue (blist, a) } + } + return (blist) +} + +func reformatdates (root) { + traverse (root, node, level) { + if (streq (tag (node), "DATE")) { + if (v, value (node)) { + if (and (eq (index (v, "<", 1), 1), + eq (index (v, ">", 1), strlen (v)))) { + replacenode + (createnode ("DATE", save (substring (v, 2, sub (strlen (v), 1)))), + subnode (node, "DATE")) + } + } + } + } + return (0) +} + +func reformatnames (root, sourcetext) { + list (namelist) + list (surnamelist) + list (choppedsurnamelist) + list (newchoppedsurnamelist) + if (namenode, subnode (root, "NAME")) { + extractnames (namenode, namelist, nameN, surnameN) + set (lastnamenode, namenode) + forlist (namelist, s, sn) { + set (s, strremove (s, ".")) + set (s, strremove (s, "_")) + setel (namelist, sn, s) + } + enqueue (surnamelist, getel (namelist, surnameN)) + while (surname, dequeue (surnamelist)) { + set (choppedsurnamelist, strchop (surname, " ")) + forlist (choppedsurnamelist, s, sn) { + if (streq ("VON", s)) { + enqueue (newchoppedsurnamelist, s) + } elsif (streq ("DER", s)) { + enqueue (newchoppedsurnamelist, s) + } elsif (and (eq (index (s, "(", 1), 1), + eq (index (s, ")", 1), strlen (s)))) { + enqueue (surnamelist, save (substring (s, 2, sub (strlen (s), 1)))) + } else { + enqueue (newchoppedsurnamelist, save (capitalize (lower (s)))) + } + } + set (newsurname, strjoin (newchoppedsurnamelist, " ")) + if (strlen (newsurname)) { + if (i, index (newsurname, "Mc ", 1)) { + set (newsurname, save (concat (trim (newsurname, add (i, 1)), + cut (newsurname, add (i, 3))))) + } + set (newsurname, save (concat3 ("/", newsurname, "/"))) + } + setel (namelist, surnameN, newsurname) + set (newnamenode, createnode ("NAME", strjoin (namelist, " "))) + addnode (newnamenode, parent (lastnamenode), lastnamenode) + if (sourcetext) { + catnode (newnamenode, createnode ("SOUR", sourcetext)) + } + set (lastnamenode, newnamenode) + } + deletenode (namenode) + } + return (0) +} + +func streq (x, y) { + return (not (strcmp (x, y))) +} + +func createnodes (tag, text) { + set (text, trimspaces (text)) + if (le (strlen (text), 72)) { + return (createnode (tag, text)) + } else { + list (textlist) + while (gt (strlen (text), 72)) { + set (n, 1) + if (i, index (text, " ", n)) { + set (j, i) + } else { + set (j, add (strlen (text), 1)) + } + while (and (i, lt (i, 73))) { + incr (n) + set (j, i) + set (i, index (text, " ", n)) + } + enqueue (textlist, save (trim (text, sub (j, 1)))) + set (text, save (cut (text, add (j, 1)))) + } + if (gt (strlen (text), 0)) { + enqueue (textlist, text) + } + set (root, createnode (tag, dequeue (textlist))) + set (lastnode, 0) + forlist (textlist, text, tn) { + set (node, createnode ("CONT", text)) + addnode (node, root, lastnode) + set (lastnode, node) + } + return (root) + } +} + +func trimspaces (text) { + set (ss, 0) + set (s0, 1) + set (sn, strlen (text)) + while (and (le (s0, sn), streq (substring (text, s0, s0), " "))) { + set (ss, 1) + incr (s0) + } + while (and (le (s0, sn), streq (substring (text, sn, sn), " "))) { + set (ss, 1) + decr (sn) + } + if (ss) { + return (save (substring (text, s0, sn))) + } else { + return (text) + } +} + +func catnode (root, newnode) { + if (root) { + set (lastnode, 0) + fornodes (root, node) { + set (lastnode, node) + } + addnode (newnode, root, lastnode) + } + return (0) +} + +func strchop (s, d) { + list (slist) + set (dn, strlen (d)) + if (strlen (s)) { + set (n, 1) + set (s0, 1) + while (sn, index (s, d, n)) { + enqueue (slist, save (substring (s, s0, sub (sn, 1)))) + set (s0, add (sn, dn)) + incr (n) + } + enqueue (slist, save (cut (s, s0))) + } + return (slist) +} + +func strjoin (slist, d) { + forlist (slist, s, sn) { + if (not (strlen (str))) { + set (str, s) + } elsif (strlen (s)) { + set (str, save (concat3 (str, d, s))) + } + } + return (str) +} + +func subnode (root, tag) { + if (root) { + fornodes (root, node) { + if (streq (tag (node), tag)) { + return (node) + } + } + } + return (0) +} + +func subnodes (root, tag) { + list (nodelist) + if (root) { + fornodes (root, node) { + if (streq (tag (node), tag)) { + enqueue (nodelist, node) + } + } + } + return (nodelist) +} + +func replacenode (newnode, oldnode) { + if (newnode) { + if (root, parent (oldnode)) { + addnode (newnode, root, oldnode) + deletenode (oldnode) + } + } + return (0) +} + +func concat3 (x, y, z) { + return (concat (x, concat (y, z))) +} + +func cut (s, n) { + return (substring (s, n, strlen (s))) +} + +func values (root) { + if (root) { + set (str, value (root)) + fornodes (root, node) { + if (not (str)) { + set (str, value (node)) + } elsif (strlen (value (node))) { + set (str, save (concat3 (str, " ", value (node)))) + } + } + return (str) + } else { + return (0) + } +} + +func strremove (s, d) { + if (strlen (s)) { + while (i, index (s, d, 1)) { + set (s, save (concat (trim (s, sub (i, 1)), cut (s, add (i, 1))))) + } + } + return (s) +} diff --git a/reports/ssdi-search-list.ll b/reports/ssdi-search-list.ll new file mode 100644 index 0000000..2233a03 --- /dev/null +++ b/reports/ssdi-search-list.ll @@ -0,0 +1,131 @@ +/* + * @progname ssdi-search-list.ll + * @version 1.0 + * @author Larry Soule (lsoule@ikos.com) + * @category + * @output Text + * @description + * + * This LifeLines report program searches for individuals in the database + * that are missing some birth or death information that may be in the + * social security death index (SSDI). Right now this searches for: + * 1. Deaths after 1960 that do not have locations + * 2. Births after 1880 with no death event + * + * These two sets of people are sorted by name and printed out in the + * report in ASCII. + * + * The first set of people, those with deaths after 1960 that do not + * have locations, is the most promising to search for. The second set + * right now contains many living people but also other possible + * entries in the SSDI. + * + * The social security death index is available at your local Family History + * Library or on-line at http://www.ancestry.com/ssdi/ + * + * Version 1.0 - November 1996, Larry Soule (lsoule@ikos.com) + * + * Sample report output (note: all spouses are listed for female individuals + * since they may be listed under their maiden name, or any other married name) + * + +2207 individuals in the database. +52 have known death dates but not locations. +331 have known birth dates but no death dates or locations. + +**** List of individuals with death dates but not locations +Charles Edwin ALBRIDGE b. 27 NOV 1915 Pennsylvania + d. 03 DEC 1981 + +Evelyn Carter ALBRIDGE b. 26 MAR 1905 Pennsylvania + d. 06 OCT 1982 + Married to Chester Goy RAVER +... + +**** List of individuals with birth dates but not death dates or location +Alice Alamanda ALBRIDGE b. 04 FEB 1902 Easton, Northampton Co., PA + d. +... + + */ + +/* These two sets are built up */ +global(missingDeathPlaceSet) +global(missingDeathEventSet) + +proc main() { + /* Generate the two sets of people */ + call generateSetToSearch() + + /* Now print the two sets */ + "**** List of individuals with death dates but not locations" nl() + call printSet(missingDeathPlaceSet) + + nl() nl() + "**** List of individuals with birth dates but not death dates or location" nl() + call printSet(missingDeathEventSet) +} + +/* + * Generate the two sets of individuals + */ +proc generateSetToSearch() { + indiset(missingDeathPlaceSet) + indiset(missingDeathEventSet) + + forindi(indi_v, count_v) { + set(deathEv, death(indi_v)) + set(birthEv, birth(indi_v)) + if (deathEV, death(indi_v)) { + /* + * A death record exists - see if the location is empty and + * the date is after 1960 + */ + if (and(eq(0, strlen(place(deathEv))), + gt(atoi(year(deathEv)), 1960))) { + addtoset(missingDeathPlaceSet, indi_v, 0) + } + } else { + /* + * No death record exists - see if the birth year + * is after 1880 + */ + if (birthEV, birth(indi_v)){ + if (gt(atoi(year(birthEv)), 1880)) { + addtoset(missingDeathEventSet, indi_v, 0) + } + } + } + } + + /* Output some statistics */ + d(count_v) " individuals in the database." nl() + d(lengthset(missingDeathPlaceSet)) " have known death dates but not locations." nl() + d(lengthset(missingDeathEventSet)) " have known birth dates but no death dates or locations." nl() nl() + + /* Sort the two sets by name */ + namesort(missingDeathPlaceSet) + namesort(missingDeathEventSet) +} + +/* + * Print the set of individuals passed in the argument printSet. + * This uses a simple name, birth, death format, followed by a list + * of spouses for females + */ +proc printSet(printSet) { + forindiset(printSet, personIndi, personValue, iteration) { + set(birthEv, birth(personIndi)) + set(deathEv, death(personIndi)) + fullname(personIndi, 1, 1, 30) col(30) " b. " date(birthEv) col(50) place(birthEv) + nl() col(30) " d. " date(deathEv) col(50) place(deathEv) nl() + if (female(personIndi)) { + if (gt(nspouses(personIndi), 0)) { + spouses(personIndi, spouse_v, fam_v, count) { + " Married to " name(spouse_v) nl() + } + } + } + nl() + } +} diff --git a/reports/ssdi_aid.ll b/reports/ssdi_aid.ll new file mode 100644 index 0000000..35bdf79 --- /dev/null +++ b/reports/ssdi_aid.ll @@ -0,0 +1,323 @@ +/* + * @progname ssdi_aid.ll + * @version 3 + * @author Jim Eggert (eggertj@ll.mit.edu) + * @category + * @output Text + * @description + +This LifeLines report program generates a text file that lists +people who are likely to be in the Social Security Death Index. +The SSDI starts in 1962 and is periodically updated to include +more recent years. This program guesses birth and death years +to make its determinations. If it finds a person likely to be +in the SSDI, it searches for the string SSDI in their notes to +indicate that an SSDI entry has already been found. If not, it +outputs a line about that person. + +The output persons are in database order. Women are output in +with their last married name. To alphabetize the names in the text +report, you can use Unix sort: + + sort -b +1 ss.out > ss.sort + +The program optionally generates HTML output with buttons to search +the Rootsweb online SSDI database. + +ssdi_aid - a LifeLines program to aid in the use of the U.S. Social + Security Death Index + by Jim Eggert (eggertj@ll.mit.edu) + Version 1, 28 June 1995 + Version 2, 22 November 1996 + Version 3, 11 January 2005 (changed to Rootsweb site) + +*/ + +global(byear_delta) +global(byear_est) +global(byear_est_delta) + +global(mother_age) +global(father_age) +global(years_between_kids) +global(oldage) + +proc main() { + indiset(pset) + + set(mother_age,23) /* assumed age of first motherhood */ + set(father_age,25) /* assumed age of first fatherhood */ + set(years_between_kids,2) /* assumed years between children */ + set(oldage,90) /* normal maximum death age */ + set(byearstart,1850) /* no one born before then can be in the SSDI */ + + set(unknownname,"<") /* for women, any spouse whose surname contains this + is considered to have an unknown surname */ + + getindi(person) + while(person) { + addtoset(pset,person,1) + getindi(person) + } + + getintmsg(minage,"Enter minimum age for listing:") + + getintmsg(html,"Enter 0 for text, 1 for html output:") + + if (html) { + getintmsg(includebyears,"Enter 1 to include birth years in database query") + "\n" + "\n" + " SSDI Aid Report \n" + "\n" + "\n" + "Press a button to query Rootsweb's online SSDI database + for that individual." + "
    \n" + } + + set(namewidth,50) /* change this value as needed */ + "key" col(8) "@LAST, First Middle [MAIDEN]" + set(bcol,add(8,namewidth)) + col(bcol) "Birthdate" + set(dcol,add(25,namewidth)) + col(dcol) "Death\n" + + print("Finding descendants") + set(pset,union(pset,spouseset(pset))) + set(pset,union(pset,descendantset(pset))) + print("' spouses") + set(pset,union(pset,spouseset(pset))) + print("' descendants") + set(pset,union(pset,descendantset(pset))) + print("... done.\n") + + set(thisyear,atoi(year(gettoday()))) + set(byearend,sub(thisyear,minage)) + + print("Traversing individuals...") + forindiset(pset,person,pval,pnum) { + set(star,1) + fornotes(inode(person),note) { + if (index(note,"SSDI:",1)) { set(star,0) } + } + if (star) { + set(byear,0) + set(bdate,"") + if (b,birth(person)) { + extractdate(b,bday,bmonth,byear) + set(bdate,date(b)) + } + if (not(byear)) { + if (b,baptism(person)) { + set(bdate,date(b)) + } + } + call estimate_byear(person) +/* set(byear,sub(byear_est,byear_est_delta)) */ + if(and(byear_est,not(strlen(bdate)))) { + set(bdate,save(concat("c ",d(byear_est)))) + } + + set(dyear,0) + if (d,death(person)) { + extractdate(d,dday,dmonth,dyear) + } + if (not(dyear)) { + if(d,burial(person)) { + extractdate(d,dday,dmonth,dyear) + } + } + if (dyear) { + if (or(index(date(d),"ABT",1),eq(dmonth,0))) { set(dyear,add(dyear,5)) } + if (index(date(d),"AFT",1)) { + set(oldyear,add(byear,oldage)) + if (gt(oldyear,dyear)) { set(dyear,oldyear) } + } + } + + if (or(ge(dyear,1940), + and(not(dyear),le(byear,byearend),ge(byear,byearstart)))) { + set(nfam,nfamilies(person)) + set(myname,fullname(person,1,0,namewidth)) + set(mysurname,surname(person)) + if (and(female(person),ne(nfam,0))) { + set(maidenname,save(concat(", ",fullname(person,1,1,100)))) + families(person,fam,spouse,famnum) { + if (spousesurname,surname(spouse)) { + if (strlen(spousesurname)) { + if (not(index(spousesurname,unknownname,1))) { + set(mysurname,spousesurname) + set(myname, + trim(concat(upper(spousesurname),maidenname),namewidth)) + if (ne(famnum,nfam)) { + set(myname, + trim(concat("+",myname),namewidth)) + } + } + } + } + } + } + if (html) { + "
    " + if (includebyears) { + if (lt(byear_est_delta,2)) { + "" + } + } + "" + } else { + key(person) col(8) + } + myname + if (html) { + " " bdate " " long(d) "
    " + } + else { + col(bcol) bdate col(dcol) long(d) + } + nl() + } + } + } + if (html) { + "\n" + "\n" + } +} + +proc estimate_byear(person) { + set(byear_est,0) + set(byear_est_delta,neg(1)) + if (byear,get_byear(person)) { + set(byear_est,byear) + set(byear_est_delta,byear_delta) + } + else { /* estimate from siblings */ + set(older,person) + set(younger,person) + set(yeardiff,0) + set(border,0) + set(this_uncertainty,1) + while (and(not(byear_est),or(older,younger))) { + set(older,prevsib(older)) + set(younger,nextsib(younger)) + set(yeardiff,add(yeardiff,years_between_kids)) + set(this_uncertainty,add(this_uncertainty,1)) + if (older) { + set(border,add(border,1)) + if (byear,get_byear(older)) { + set(byear_est,add(byear,yeardiff)) + set(byear_est_delta,this_uncertainty) + } + } + if (and(not(byear_est),younger)) { + if (byear,get_byear(younger)) { + set(byear_est,sub(byear,yeardiff)) + set(byear_est_delta,this_uncertainty) + } + } + } + } + if (not(byear_est)) { /* estimate from parents' marriage */ + if (m,marriage(parents(person))) { extractdate(m,bd,bm,my) } + if (my) { + set(byear_est,add(add(my,mul(years_between_kids,border)),1)) + set(byear_est_delta,add(border,1)) + } + } + if (not(byear_est)) { /* estimate from first marriage */ + families(person,fam,spouse,fnum) { + if (eq(fnum,1)) { + if (b,birth(spouse)) { extractdate(b,bd,bm,by) } + if (m,marriage(fam)) { extractdate(m,bd,bm,my) } + if (by) { + if (female(person)) { + set(byear_est,add(by,sub(father_age,mother_age))) + } + else { + set(byear_est,sub(by,sub(father_age,mother_age))) + } + set(byear_est_delta,5) + } + elsif (my) { + if (female(person)) { set(byear_est,sub(my,mother_age)) } + else { set(byear_est,sub(my,father_age)) } + set(byear_est_delta,5) + } + else { + children(fam,child,cnum) { + if (not(byear_est)) { + if (byear,get_byear(child)) { + if (female(person)) { + set(byear_est,sub(sub(byear, + mul(sub(cnum,1),years_between_kids)), + mother_age)) + } + else { + set(byear_est,sub(sub(byear, + mul(sub(cnum,1),years_between_kids)), + father_age)) + } + set(byear_est_delta,add(5,cnum)) + } + } + } + } + } + } + } + if (not(byear_est)) { /* estimate from parents' birthyear */ + if (byear,get_byear(mother(person))) { + set(byear_est,add(byear,mother_age)) + } + else { + if (byear,get_byear(father(person))) { + set(byear_est,add(byear,father_age)) + } + } + if (byear) { + set(byear_est_delta,5) + set(older,person) + while(older,prevsib(older)) { + set(byear_est,add(byear_est,years_between_kids)) + set(byear_est_delta,add(byear_est_delta,1)) + } + } + } +} + +func get_byear(person) { + set(byear,0) + if (person) { + if (b,birth(person)) { extractdate(b,day,month,byear) } + if (byear) { + set(byear_delta,0) + set(dstring,trim(date(b),3)) + if (not(strcmp(dstring,"BEF"))) { set(byear_delta,3) } + elsif (not(strcmp(dstring,"AFT"))) { set(byear_delta,3) } + elsif (not(strcmp(dstring,"ABT"))) { set(byear_delta,2) } + } + else { + if (b,baptism(person)) { extractdate(b,day,month,byear) } + if (byear) { + set(byear_delta,1) + set(dstring,trim(date(b),3)) + if (not(strcmp(dstring,"BEF"))) { set(byear_delta,3) } + elsif (not(strcmp(dstring,"AFT"))) { set(byear_delta,3) } + elsif (not(strcmp(dstring,"ABT"))) { set(byear_delta,2) } + } + } + } + return(byear) +} diff --git a/reports/st/.gitignore b/reports/st/.gitignore new file mode 100644 index 0000000..7928f8f --- /dev/null +++ b/reports/st/.gitignore @@ -0,0 +1,9 @@ +Makefile +Makefile.in +test_forindi.out +test_forfam.out +test_indi_it.out +test_fam_it.out +test_othr_it.out +st_all.out +st_all.stdout diff --git a/reports/st/Makefile.am b/reports/st/Makefile.am new file mode 100644 index 0000000..2160f84 --- /dev/null +++ b/reports/st/Makefile.am @@ -0,0 +1,92 @@ +# This makefile is for the lifelines reports + +AUTOMAKE_OPTIONS = no-dependencies + +# SELFTEST_REPORTS is to hold all parts of the self-test scripts +SELFTEST_REPORTS = st_all.ll \ + st_aux.li \ + st_collate.li \ + st_collate_8859-1.li \ + st_collate_UTF-8.li \ + st_convert.li \ + st_date.li \ + st_db.li \ + st_list.li \ + st_name.li \ + st_number.li \ + st_string.li \ + st_string_UTF-8.li \ + st_table.li \ + trigtest.ll +SELFTEST_REFERENCE = st_all.ref st_all_stdout.ref trigtest.ref +SELFTEST_OUTPUTS = st_all.out st_all.stdout + +TEST_ITER_REPORTS = test_forindi.ll test_forfam.ll test_indi_it.ll \ + test_fam_it.ll test_othr_it.ll +TEST_ITER_REFERENCE = test_forindi.ref test_forfam.ref test_indi_it.ref \ + test_fam_it.ref test_othr_it.ref +TEST_ITER_OUTPUTS = test_forindi.out test_forfam.out test_indi_it.out \ + test_fam_it.out test_othr_it.out +TEST_ITER_DB = ti.ged + +TEST_OUTPUTS = $(SELFTEST_OUTPUTS) $(TEST_ITER_OUTPUTS) + +TESTS = selftest +pkg_REPORTS = $(SELFTEST_REPORTS) $(SELFTEST_REFERENCE) \ + $(TEST_ITER_REPORTS) $(TEST_ITER_REFERENCE) $(TEST_ITER_DB) +CLEANFILES = $(TEST_OUTPUTS) errs.log llines.leak_log selftest + +subreportdir = $(pkgdatadir)/st +subreport_DATA = $(pkg_REPORTS) +dist_subreport_DATA = $(pkg_REPORTS) + +LLEXEC = ../../src/liflines/llexec +LLINES = ../../src/liflines/llines + +.PHONY: local test_iter st_all selftest +selftest: ti test_iter st_all + +local: $(TEST_ITER_DB) $(TEST_ITER_REPORTS) $(SELFTEST_REPORTS) + ln -fs /bin/true selftest + for i in $? ; do \ + dest=`basename $$i` ;\ + if [ $$dest != $$i ] ; then \ + cp $$i $$dest ; \ + fi ;\ + done + +ti: local ti.ged $(LLINES) + rm -rf ti + (echo yurti ; echo yyq) | $(LLINES) ./ti > /dev/null + +test_iter: $(TEST_ITER_REPORTS) $(TEST_ITER_REFERENCE) $(TEST_ITER_DB) $(LLEXEC) + @for i in $(TEST_ITER_REPORTS) ; do \ + this=`basename $$i .ll` ;\ + echo "$(LLEXEC) ./ti -x ./$$this.ll > $$this.out" ;\ + $(LLEXEC) ./ti -x ./$$this.ll > $$this.out;\ + if diff $$this.out $(srcdir)/$$this.ref >/dev/null ; then\ + : echo "ok" ; \ + else \ + echo "test $$i failed - to see failure execute" ; \ + echo "diff $$this.out $(srcdir)/$$this.ref" ; \ + ln -fs /bin/false selftest ;\ + fi \ + done + +st_all: $(SELFTEST_REPORTS) $(LLEXEC) + (echo 1; echo 1 ;echo 0 ; echo st_all.out) | \ + $(LLEXEC) ./ti -x ./st_all.ll > st_all.stdout + @if diff st_all.out $(srcdir)/st_all.ref >/dev/null ; then\ + : echo "test st_all output ok" ; \ + else \ + echo "test st_all output failed - to see failure execute" ; \ + echo "diff st_all.out $(srcdir)/st_all.ref" ; \ + ln -fs /bin/false selftest ;\ + fi + @if diff st_all.stdout $(srcdir)/st_all_stdout.ref >/dev/null ; then\ + : echo "test st_all stdout ok" ; \ + else \ + echo "test st_all failed - to see failure execute" ; \ + echo "diff st_all.stdout $(srcdir)/st_all_stdout.ref" ; \ + ln -fs /bin/false selftest ;\ + fi diff --git a/reports/st/st_all.ll b/reports/st/st_all.ll new file mode 100644 index 0000000..da7cc69 --- /dev/null +++ b/reports/st/st_all.ll @@ -0,0 +1,98 @@ +/* + * @progname st_all.ll + * @version 1.15 (2008-01-05) + * @author Perry Rapp + * @category self-test + * @output mixed + * @description + +calls all self-test modules, +Validates report language functions, +and optionally dumps various data to a file +(to exercise db functions). + +Perry is using this for a a regression test. + +TODO: more conversion tests +TODO: logic +TODO: non-ASCII dates +TODO: Flag date tests for gedcom legal vs illegal + +*/ + + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_string.li") +include("st_string_UTF-8.li") +include("st_collate.li") +include("st_date.li") +include("st_name.li") +include("st_number.li") +include("st_trig.li") +include("st_convert.li") +include("st_list.li") +include("st_table.li") +include("st_db.li") + +global(true) +global(dbuse) + +proc main() +{ + set(true,1) + + getint(alltests, "Run all tests ? (1=yes, 0=prompt)") + getint(dbuse, "Exercise db functions ? (0=no)") + getint(logout, "Output errors to file (0=no)") + + if (dostep(alltests, "Test collation ? (0=no)")) { + call testCollate() + } + if (dostep(alltests, "Test strings ? (0=no)")) { + call testStrings() + } + if (dostep(alltests, "Test lists ? (0=no)")) { + call testLists() + } + if (dostep(alltests, "Test tables ? (0=no)")) { + call testTables() + } + if (dostep(alltests, "Test UTF-8strings ? (0=no)")) { + call testStrings_UTF_8() + } + if (dostep(alltests, "Test numbers ? (0=no)")) { + call testNums() + } + if (dostep(alltests, "Test trig ? (0=no)")) { + call testTrig() + } + if (dostep(alltests, "Test names ? (0=no)")) { + call testNames() + } + if (dostep(alltests, "Test dates ? (0=no)")) { + call testDates() + } + if (dostep(alltests, "Test codeset conversion ? (0=no)")) { + call testConvert() + } + + if (dbuse) + { + call exerciseDb() + } +} + +/* should we perform this step ? prompt if not doing all */ +func dostep(alltests, prompt) +{ + if (alltests) { return(true) } + getint(doit, prompt) + return(doit) +} + + + + diff --git a/reports/st/st_all.ref b/reports/st/st_all.ref new file mode 100644 index 0000000..826d062 --- /dev/null +++ b/reports/st/st_all.ref @@ -0,0 +1,310 @@ +database: ti +version: 3.0.49 + + +*** PERSONS *** + +Henrich SCHMIDT 1 +Johan Joseph SCHMIDT 2 +name: Johan Joseph SCHMIDT +title: +key: I1 + +fullname(12): J J SCHMIDT +surname: Schmidt +givens: Johan Joseph +trimname(8): J Schmidt +birth: BIRT DATE 11 Oct 18600 @I1@ INDI +1 NAME Johan Joseph /Schmidt/ +1 SEX M +1 BIRT +2 DATE 11 Oct 1860 +1 FAMC @F1@ +0 @I2@ INDI +1 NAME Johan /Schmidt/ +1 SEX M +1 BIRT +2 DATE EST 1829 +2 PLAC +1 DEAT +2 DATE 4 Sep 1885 +2 PLAC +1 FAMC @F7@ +1 FAMS @F1@ +0 @I3@ INDI +1 NAME Maria Joseph /Saurborn/ +1 SEX F +1 BIRT +2 DATE 1 Aug 1826 +2 PLAC +1 DEAT +2 DATE +2 PLAC +1 FAMS @F1@ +0 @I4@ INDI +1 NAME Henrich Schmidt +1 FAMC @F1@ +0 @I6@ INDI +1 NAME Belmont Smith +1 FAMS @F2@ +0 @I7@ INDI +1 NAME Charlene Wilson +1 FAMS @F2@ +0 @I9@ INDI +1 NAME Abraham Belmont +1 FAMS @F2@ + +Live INDI: 7 +Dead INDI: 3 + + +*** FAMILIES *** + +0 @F1@ FAM +1 HUSB @I2@ +1 WIFE @I3@ +1 CHIL @I1@ +1 CHIL @I4@ +0 @F2@ FAM +1 HUSB @I6@ +1 WIFE @I7@ +1 HUSB @I9@ +1 CHIL @I11@ +0 @F5@ FAM +1 HUSB @I10@ +1 WIFE @I11@ +0 @F7@ FAM +1 WIFE @I12@ +1 WIFE @I11@ +1 CHIL @I2@ + +Live FAM: 4 +Dead FAM: 0 + + +*** SOURCES *** + +0 @S1@ SOUR +0 @S3@ SOUR + + +*** EVENTS *** + +0 @E1@ EVEN +1 INDI +2 ROLE event +0 @E3@ EVEN +1 INDI +2 ROLE event2 + + +*** OTHERS *** + +0 @X1@ NOTE +0 @X3@ NOTE + + +*** GENGEDCOM *** + +0 @I1@ INDI +1 NAME Johan Joseph /Schmidt/ +1 SEX M +1 BIRT +2 DATE 11 Oct 1860 +1 FAMC @F1@ +0 @I2@ INDI +1 NAME Johan /Schmidt/ +1 SEX M +1 BIRT +2 DATE EST 1829 +2 PLAC +1 DEAT +2 DATE 4 Sep 1885 +2 PLAC +1 SOUR +1 FAMS @F1@ +0 @I3@ INDI +1 NAME Maria Joseph /Saurborn/ +1 SEX F +1 BIRT +2 DATE 1 Aug 1826 +2 PLAC +1 DEAT +2 DATE +2 PLAC +1 SOUR +1 FAMS @F1@ +0 @I4@ INDI +1 NAME Henrich /Schmidt/ +1 SEX M +1 BIRT +2 DATE CAL 1900 +1 FAMC @F1@ +0 @I6@ INDI +1 NAME Belmont /Smith/ +1 SEX M +1 FAMS @F2@ +0 @I7@ INDI +1 NAME Charlene /Wilson/ +1 SEX F +1 FAMS @F2@ +0 @I9@ INDI +1 NAME Abraham /Belmont/ +1 SEX M +1 SOUR @S1@ +1 FAMS @F2@ +0 @F1@ FAM +1 HUSB @I2@ +1 WIFE @I3@ +1 MARR +2 DATE 15 Feb 1859 +2 PLAC +2 SOUR +1 CHIL @I1@ +1 CHIL @I4@ +0 @F2@ FAM +1 HUSB @I6@ +1 WIFE @I7@ +1 HUSB @I9@ +1 MARR +2 DATE +2 PLAC +2 SOUR +1 CHIL @I11@ + + +*** GENGEDCOMWEAK *** + +0 @I1@ INDI +1 NAME Johan Joseph /Schmidt/ +1 SEX M +1 BIRT +2 DATE 11 Oct 1860 +1 FAMC @F1@ +0 @I2@ INDI +1 NAME Johan /Schmidt/ +1 SEX M +1 BIRT +2 DATE EST 1829 +2 PLAC +1 DEAT +2 DATE 4 Sep 1885 +2 PLAC +1 SOUR +1 FAMS @F1@ +0 @I3@ INDI +1 NAME Maria Joseph /Saurborn/ +1 SEX F +1 BIRT +2 DATE 1 Aug 1826 +2 PLAC +1 DEAT +2 DATE +2 PLAC +1 SOUR +1 FAMS @F1@ +0 @I4@ INDI +1 NAME Henrich /Schmidt/ +1 SEX M +1 BIRT +2 DATE CAL 1900 +1 FAMC @F1@ +0 @I6@ INDI +1 NAME Belmont /Smith/ +1 SEX M +1 FAMS @F2@ +0 @I7@ INDI +1 NAME Charlene /Wilson/ +1 SEX F +1 FAMS @F2@ +0 @I9@ INDI +1 NAME Abraham /Belmont/ +1 SEX M +1 FAMS @F2@ +0 @F1@ FAM +1 HUSB @I2@ +1 WIFE @I3@ +1 MARR +2 DATE 15 Feb 1859 +2 PLAC +2 SOUR +1 CHIL @I1@ +1 CHIL @I4@ +0 @F2@ FAM +1 HUSB @I6@ +1 WIFE @I7@ +1 HUSB @I9@ +1 MARR +2 DATE +2 PLAC +2 SOUR + + +*** GENGEDCOMSTRONG *** + +0 @I1@ INDI +1 NAME Johan Joseph /Schmidt/ +1 SEX M +1 BIRT +2 DATE 11 Oct 1860 +1 FAMC @F1@ +0 @I2@ INDI +1 NAME Johan /Schmidt/ +1 SEX M +1 BIRT +2 DATE EST 1829 +2 PLAC +1 DEAT +2 DATE 4 Sep 1885 +2 PLAC +1 SOUR +1 FAMS @F1@ +0 @I3@ INDI +1 NAME Maria Joseph /Saurborn/ +1 SEX F +1 BIRT +2 DATE 1 Aug 1826 +2 PLAC +1 DEAT +2 DATE +2 PLAC +1 SOUR +1 FAMS @F1@ +0 @I4@ INDI +1 NAME Henrich /Schmidt/ +1 SEX M +1 BIRT +2 DATE CAL 1900 +1 FAMC @F1@ +0 @I6@ INDI +1 NAME Belmont /Smith/ +1 SEX M +1 FAMS @F2@ +0 @I7@ INDI +1 NAME Charlene /Wilson/ +1 SEX F +1 FAMS @F2@ +0 @I9@ INDI +1 NAME Abraham /Belmont/ +1 SEX M +1 SOUR @S1@ +1 FAMS @F2@ +0 @F1@ FAM +1 HUSB @I2@ +1 WIFE @I3@ +1 MARR +2 DATE 15 Feb 1859 +2 PLAC +2 SOUR +1 CHIL @I1@ +1 CHIL @I4@ +0 @F2@ FAM +1 HUSB @I6@ +1 WIFE @I7@ +1 HUSB @I9@ +1 MARR +2 DATE +2 PLAC +2 SOUR +0 @S1@ SOUR +1 NOTE a source diff --git a/reports/st/st_all_stdout.ref b/reports/st/st_all_stdout.ref new file mode 100644 index 0000000..df04f9a --- /dev/null +++ b/reports/st/st_all_stdout.ref @@ -0,0 +1,40 @@ +Program is running...Run all tests ? (1=yes, 0=prompt) +enter integer:Exercise db functions ? (0=no) +enter integer:Output errors to file (0=no) +enter integer:finnish_UTF-8 +strcmp([ydia],z) FAILED +strcmp([udia],z) FAILED +strcmp([eth],e) FAILED +polish_UTF-8 +strcmp(L,[Lstroke]) FAILED +spanish_UTF-8 +strcmp([Ntilde],O) FAILED +finnish_8859-1 +strcmp([ydia],z) FAILED +strcmp([udia],z) FAILED +strcmp([eth],e) FAILED +spanish_8859-1 +strcmp([Ntilde],O) FAILED +Passed 31/40 collate tests +ord(5) FAILED +Passed 38/39 string tests +Passed 28/28 list tests +Passed 9/9 table tests +upper(oe) FAILED +lower(oe) FAILED +Passed 20/22 string UTF-8 tests +Passed 27/27 number tests +Passed 10/10 name tests +Passed 598/598 date tests +convertcode(bytecode($C5$81,raw),UTF-8,ANSEL) <> bytecode($A1,raw) FAILURE +convertcode(bytecode($A1,raw),ANSEL,UTF-8) <> bytecode($C5$81,raw) FAILURE +convertcode(bytecode($C3$A6,raw),UTF-8,ANSEL) <> bytecode($B5,raw) FAILURE +convertcode(bytecode($B5,raw),ANSEL,UTF-8) <> bytecode($C3$A6,raw) FAILURE +convertcode(bytecode($C3$9E,raw),UTF-8,ISO-8859-1) <> bytecode($DE,raw) FAILURE +convertcode(bytecode($DE,raw),ISO-8859-1,UTF-8) <> bytecode($C3$9E,raw) FAILURE +convertcode(bytecode($C3$9E,raw),UTF-8,ANSEL) <> bytecode($A4,raw) FAILURE +convertcode(bytecode($A4,raw),ANSEL,UTF-8) <> bytecode($C3$9E,raw) FAILURE +Passed 28/36 convert tests +What is the name of the output file? +Default path: . +enter file name: Program was run successfully. diff --git a/reports/st/st_aux.li b/reports/st/st_aux.li new file mode 100644 index 0000000..5fa2d4b --- /dev/null +++ b/reports/st/st_aux.li @@ -0,0 +1,73 @@ +/* + * @progname st_aux.li + * @version 1.0 + * @author Perry Rapp + * @category self-test + * @output none + * @description + * + * auxiliary functions for all self-test modules + * + */ + +/* This file is all ASCII, so we don't need to choose a codeset */ +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ + + +global(testok) +global(testfail) +global(testskip) +global(logout) +global(section) + +/* report failure to screen, & to file if logging */ +proc reportfail(str) +{ + if (gt(strlen(section),0)) { + print(concat(section, nl())) + } + print(str) + print(nl()) + if (logout) { + if (gt(strlen(section),0)) { + section nl() + } + str nl() + } + set(section,"") + incr(testfail) +} + +/* clear counters at start of subsection */ +proc initSubsection() +{ + set(testok, 0) + set(testfail, 0) + set(testskip, 0) +} + +/* report results of just completed subsectioin (testok...) */ +proc reportSubsection(title) +{ + set(res, concat("Passed ", d(testok), "/", d(add(testok,testfail)), " ")) + if (gt(testskip, 0)) { + set(res, concat(res, "(skipped ", d(testskip), ") ")) + } + set(res, concat(res, title, "\n")) + print(res) + set(testok, 0) + set(testfail, 0) +} + +func set_and_check_locale(locstr, locname) +{ + set(res, setlocale(locstr)) + if (nestr(res, "C")) { + return(1) + } + call reportfail(concat("Locale missing: ", locstr, " (", locname, ")")) + return (0) +} diff --git a/reports/st/st_collate.li b/reports/st/st_collate.li new file mode 100644 index 0000000..4ad0a1b --- /dev/null +++ b/reports/st/st_collate.li @@ -0,0 +1,66 @@ +/* + * @progname st_collate.li + * @version 1.0 + * @author Perry Rapp + * @category self-test + * @output none + * @description + * + * validate collation + * + */ + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") +include("st_collate_UTF-8") +include("st_collate_8859-1") + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call testCollate() +} + +proc testCollate() +{ + call initSubsection() + call testCollate_UTF_8() + call testCollate_8859_1() + call reportSubsection("collate tests") +} + +proc check_collate2(str1, str2) +{ + if (ge(strcmp(str1,str2),0)) { + /* str1 might be of the form string:[name] */ + set(str1nam, str1) + set(i1, index(str1, ":", 1)) + if (gt(i1,0)) { + set(str1nam, substring(str1, add(i1,1), strlen(str1))) + set(str1, substring(str1, 1, sub(i1,1))) + } + /* str2 might be of the form string:[name] */ + set(str2nam, str2) + set(i2, index(str2, ":", 1)) + if (gt(i2,0)) { + set(str2nam, substring(str2, add(i2,1), strlen(str2))) + set(str2, substring(str2, 1, sub(i2,1))) + } + set(fstr, concat("strcmp(", str1nam,",",str2nam,") FAILED")) + call reportfail(fstr) + } else { incr(testok) } +} +proc check_collate3(str1, str2, str3) +{ + call check_collate2(str1, str2) + call check_collate2(str2, str3) +} + +proc set_section(name) +{ + set(section, name) +} + diff --git a/reports/st/st_collate_8859-1.li b/reports/st/st_collate_8859-1.li new file mode 100644 index 0000000..eebc823 --- /dev/null +++ b/reports/st/st_collate_8859-1.li @@ -0,0 +1,52 @@ +/* + * @progname st_collate_8859-1.li + * @version 1.0 + * @author Perry Rapp + * @category test + * @output mixed + * @description + * + * some collation tests written in ISO-8859-1 (Latin-1) + * + */ + +char_encoding("ISO-8859-1") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ + +proc finnish_8859_1() +{ + if (not(set_and_check_locale("fi_FI", "Finnish"))) { + return() + } + call set_section("finnish_8859-1") + /* sanity check */ + call check_collate3("A", "L", "Z") + /* Adia sorts between Z and Odia */ + call check_collate3("Z", ":[Adia]", ":[Odia]") + /* ydia & udia sort as y */ + call check_collate3("x", "y", "z") + call check_collate3("x", ":[ydia]", "z") + call check_collate3("x", ":[udia]", "z") + /* eth (lower=u00F0) sorts as d */ + call check_collate3("c", "d", "e") + call check_collate3("c", ":[eth]", "e") +} +proc spanish_8859_1() +{ + if (not(set_and_check_locale("es_ES", "Spanish"))) { + return() + } + call set_section("spanish_8859-1") + call check_collate3("A", "N", "Z") + call check_collate3("N", ":[Ntilde]", "O") +} +proc testCollate_8859_1() +{ + call finnish_8859_1() + call spanish_8859_1() + call set_section("") +} + + diff --git a/reports/st/st_collate_UTF-8.li b/reports/st/st_collate_UTF-8.li new file mode 100644 index 0000000..a33fd64 --- /dev/null +++ b/reports/st/st_collate_UTF-8.li @@ -0,0 +1,66 @@ +嚜/* + * @progname st_collate_UTF-8.li + * @version 1.0 + * @author Perry Rapp + * @category self-test + * @output none + * @description + * + * some collation tests written in UTF-8 + * + */ + +char_encoding("UTF-8") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ + + +proc finnish_UTF_8() +{ + if (not(set_and_check_locale("fi_FI", "Finnish"))) { + return() + } + call set_section("finnish_UTF-8") + /* sanity check */ + call check_collate3("A", "L", "Z") + /* Adia sorts between Z and Odia */ + call check_collate3("Z", ":[Adia]", ":[Odia]") + /* ydia & udia sort as y */ + call check_collate3("x", "y", "z") + call check_collate3("x", "藩:[ydia]", "z") + call check_collate3("x", "羹:[udia]", "z") + /* eth (lower=u00F0) sorts as d */ + call check_collate3("c", "d", "e") + call check_collate3("c", "簸:[eth]", "e") +} +proc polish_UTF_8() +{ + if (not(set_and_check_locale("pl_PL", "Polish"))) { + return() + } + call set_section("polish_UTF-8") + /* sanity check */ + call check_collate3("A", "L", "Z") + /* Lstroke is between L and M */ + call check_collate3("L", ":[Lstroke]", "M") +} +proc spanish_UTF_8() +{ + if (not(set_and_check_locale("es_ES", "Spanish"))) { + return() + } + call set_section("spanish_UTF-8") + /* sanity check */ + call check_collate3("A", "N", "Z") + /* ennay is between N and O */ + call check_collate3("N", ":[Ntilde]", "O") +} +proc testCollate_UTF_8() +{ + call finnish_UTF_8() + call polish_UTF_8() + call spanish_UTF_8() + call set_section("") +} + diff --git a/reports/st/st_convert.li b/reports/st/st_convert.li new file mode 100644 index 0000000..b4eea42 --- /dev/null +++ b/reports/st/st_convert.li @@ -0,0 +1,94 @@ +/* + * @progname st_convert.li + * @version 1.01 (2002-12-14) + * @author Perry Rapp + * @category self-test + * @output none + * @description + * + * validate codeset conversion + * + */ + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call testConvert() +} + +proc testConvert() +{ + call initSubsection() + call convert_tests() + call reportSubsection("convert tests") +} + +proc convert_tests() +{ + /* we have to use bytecodes, b/c any non-ascii will be + first converted by the report parser to internal codeset, + which depends on the current database :( */ + + /* trivial test */ + call checkconv("silver fox", "UTF-8", "silver fox", "ISO-8859-1") + call checkconv("silver fox", "UTF-8", "silver fox", "ISO-8859-2") + + /* LATIN SMALL LETTER N WITH TILDE u000F1 */ + call checkconv("$C3$B1", "UTF-8", "$F1", "ISO-8859-1") + + /* LATIN SMALL LETTER A WITH ACUTE u000E1 */ + call checkconv("$C3$A1", "UTF-8", "$E1", "ISO-8859-1") + call checkconv("$C3$A1", "UTF-8", "$E1", "ISO-8859-2") + call checkconv("$C3$A1", "UTF-8", "$E1", "ISO-8859-3") + call checkconv("$C3$A1", "UTF-8", "$E1", "ISO-8859-4") + call checkconv("$C3$A1", "UTF-8", "$E1", "ISO-8859-15") + + /* LATIN CAPITAL LETTER L WITH STROKE u00141 */ + call checkconv("$C5$81", "UTF-8", "$A3", "ISO-8859-2") + call checkconv("$C5$81", "UTF-8", "$A1", "ANSEL") + + /* LATIN SMALL LETTER S WITH CEDILLA u0015F */ + call checkconv("$C5$9F", "UTF-8", "$BA", "ISO-8859-2") + call checkconv("$C5$9F", "UTF-8", "$BA", "ISO-8859-3") + + /* LATIN SMALL LETTER G WITH CEDILLA u00123 */ + call checkconv("$C4$A3", "UTF-8", "$BB", "ISO-8859-4") + + /* LATIN SMALL LETTER AE u000E6 */ + call checkconv("$C3$A6", "UTF-8", "$E6", "ISO-8859-1") + call checkconv("$C3$A6", "UTF-8", "$B5", "ANSEL") + + /* LATIN CAPITAL LETTER N WITH CARON */ + call checkconv("$C5$87", "UTF-8", "$D2", "ISO-8859-2") + + /* LATIN CAPITAL LETTER THORN u000DE */ + call checkconv("$C3$9E", "UTF-8", "$DE", "ISO-8859-1") + call checkconv("$C3$9E", "UTF-8", "$A4", "ANSEL") +} + +/* test a conversion and its reverse */ +proc checkconv(bc1, cs1, bc2, cs2) +{ + call checkconv_1way(bc1, cs1, bc2, cs2) + call checkconv_1way(bc2, cs2, bc1, cs1) +} + +/* test a single conversion */ +proc checkconv_1way(bc1, cs1, bc2, cs2) +{ + set(str1, bytecode(bc1, "raw")) + set(str2, bytecode(bc2, "raw")) + if (ne(convertcode(str1, cs1, cs2), str2)) { + set(fstr, concat("convertcode(bytecode(", bc1 + , ",raw),", cs1, ",", cs2 + , ") <> bytecode(", bc2, ",raw) FAILURE")) + call reportfail(fstr) + } else { incr(testok) } +} + diff --git a/reports/st/st_date.li b/reports/st/st_date.li new file mode 100644 index 0000000..6df53ee --- /dev/null +++ b/reports/st/st_date.li @@ -0,0 +1,546 @@ +/* + * @progname st_date.li + * @version 1.42 (2007-12-24) + * @author Perry Rapp + * @category self-test + * @output none + * @description + * + * validate date functions + * + */ + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call testDates() +} + +/* + test some date functions with various GEDCOM dates + */ +proc testDates() +{ + call initSubsection() + + set_and_check_locale("en_US", "English") + +/* Test day of week function */ + call dodowtests() + +/* Test julian date functions */ + call dojdtests() + +/* Test parsing only */ + call tdparse("2 JAN 1953", 1953, 1, 2) + call tdparse("14 FEB 857", 857, 2, 14) + call tdparse("8/14/33", 33, 8, 14) + call tdparse("9/22/1", 1, 9, 22) + call tdparse("14 OCT 3 B.C.", 3, 10, 14) + call tdparse("14 OCT 3 BC", 3, 10, 14) + call tdparse("OCT 3 BC", 3, 10, 0) + call tdparse("3 BC", 3, 0, 0) + call tdparse("9/22/1", 1, 9, 22) + call tdparse("AFT 3 SEP 1630", 1630, 9, 3) + call tdparse("FROM 30 SEP 1630 TO 1700", 1630, 9, 30) + call tdparse("@#DJULIAN@ 5 MAY 1204", 1204, 5, 5) + call tdparse("@#DHEBREW@ 1 ADR 3011", 3011, 6, 1) + call tdparse("@#DFRENCH R@ 1 VEND 11", 11, 1, 1) + call tdparse("junk", 0, 0, 0) + call tdparse("15 ___ 1945", 1945, 0, 15) + call tdparse("__ ___ 1945", 1945, 0, 0) + call tdparse("_ ___ 1950", 1950, 0, 0) + call tdparse("_ ___ 90", 90, 0, 0) + call tdparse("2/3 JAN 1953", 1953, 1, 2) + call tdparse("2/3 JAN 1953/4", 1953, 1, 2) + call tdparse("2/3 JAN 1953/54", 1953, 1, 2) + call tdparse("2/3 JAN 1953/954", 1953, 1, 2) + call tdparse("FROM 2/3 JAN 1953/954 TO 2004", 1953, 1, 2) + call tdparse("2 JAN 1950s", 1950, 1, 2) + call tdparse("2-5 JAN 1950-1970", 1950, 1, 2) + call tdparse("2-13 OCT 1880-87", 1880, 10, 2) + call tdparse("1930-11-24", 1930, 11, 24) + + +/* NB: We do not test all possible format combinations, as there are quite a lot + (3 day formats, 11 month formats, 3 year formats, 14 combining formats, + 9 era formats -- multiply out to over thousands of combinations for stddate + and times 6 cmplx formats for each complex date) */ + + + datepic(0) +/* test simple 4 digit year dates */ + /* test different day formats */ + call tdfb("2 JAN 1953", 0, 0, 0, 0, 0, 1, " 2 1 1953", "*") + call tdfb("2 JAN 1953", 1, 0, 0, 0, 0, 1, "02 1 1953", "*") + call tdfb("2 JAN 1953", 2, 0, 0, 0, 0, 1, "2 1 1953", "*") + /* test different month formats */ + call tdfb("2 JAN 1953", 2, 1, 0, 0, 0, 1, "2 01 1953", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 0, 0, 1, "2 1 1953", "*") + call tdfb("2 JAN 1953", 2, 3, 0, 0, 0, 1, "2 JAN 1953", "*") + call tdfb("2 JAN 1953", 2, 4, 0, 0, 0, 1, "2 Jan 1953", "*") + call tdfb("2 JAN 1953", 2, 5, 0, 0, 0, 1, "2 JANUARY 1953", "*") + call tdfb("2 JAN 1953", 2, 6, 0, 0, 0, 1, "2 January 1953", "*") + call tdfb("2 JAN 1953", 2, 7, 0, 0, 0, 1, "2 jan 1953", "*") + call tdfb("2 JAN 1953", 2, 8, 0, 0, 0, 1, "2 january 1953", "*") + call tdfb("2 JAN 1953", 2, 9, 0, 0, 0, 1, "2 JAN 1953", "*") + call tdfb("2 JAN 1953", 2,10, 0, 0, 0, 1, "2 i 1953", "*") + call tdfb("2 JAN 1953", 2,11, 0, 0, 0, 1, "2 I 1953", "*") + /* test different era formats */ + call tdfb("2 JAN 1953", 2, 2, 0, 0, 2, 1, "2 1 1953 A.D.", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 0, 12, 1, "2 1 1953 AD", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 0, 22, 1, "2 1 1953 C.E.", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 0, 32, 1, "2 1 1953 CE", "*") + /* test different date (ymd) formats */ + call tdfb("2 JAN 1953", 2, 2, 0, 1, 32, 1, "1 2, 1953 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 2, 32, 1, "1/2/1953 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 3, 32, 1, "2/1/1953 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 4, 32, 1, "1-2-1953 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 5, 32, 1, "2-1-1953 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 6, 32, 1, "121953 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 7, 32, 1, "211953 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 8, 32, 1, "1953 1 2 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 9, 32, 1, "1953/1/2 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 10, 32, 1, "1953-1-2 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 11, 32, 1, "195312 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 12, 32, 1, "1953", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 13, 32, 1, "2/1 1953 CE", "*") + call tdfb("2 JAN 1953", 2, 2, 0, 14, 32, 1, "2 JAN 1953", "*") + /* test custom date pic */ + datepic("%d.%m.%y") + call tdfb("2 JAN 1953", 2, 2, 0, 10, 32, 1, "2.1.1953 CE", "*") + datepic("%d of %m, %y") + call tdfb("2 JAN 1953", 2, 4, 0, 10, 1, 1, "2 of Jan, 1953", "*") + datepic("%y.%m.%d") + call tdfb("2 JAN 1953", 2, 10, 2, 10, 1, 1, "1953.i.2", "*") + datepic(0) + /* test missing day or month (legal in GEDCOM) */ + call tdfb("2 JAN 1953", 1, 1, 1, 2, 2, 1, "01/02/1953 A.D.", "*") + call tdfb("JAN 1953", 1, 1, 1, 2, 2, 1, "01/ /1953 A.D.", "*") + call tdfb("1953", 1, 1, 1, 2, 2, 1, " / /1953 A.D.", "*") + +/* test Italian months */ + if (not(set_and_check_locale("it_IT", "Italian"))) { + set(testskip, add(testskip, 6)) + } else { + call tdfb("2 JAN 1953", 2, 3, 0, 0, 0, 1, "2 GEN 1953", "*") + call tdfb("2 JAN 1953", 2, 4, 0, 0, 0, 1, "2 Gen 1953", "*") + call tdfb("2 JAN 1953", 2, 5, 0, 0, 0, 1, "2 GENNAIO 1953", "*") + call tdfb("2 JAN 1953", 2, 6, 0, 0, 0, 1, "2 Gennaio 1953", "*") + call tdfb("2 JAN 1953", 2, 7, 0, 0, 0, 1, "2 gen 1953", "*") + call tdfb("2 JAN 1953", 2, 8, 0, 0, 0, 1, "2 gennaio 1953", "*") + set_and_check_locale("en_US", "English") + } + +/* test Swedish months */ + if (not(set_and_check_locale("sv_SE", "Swedish"))) { + set(testskip, add(testskip, 6)) + } else { + call tdfb("2 OCT 1953", 2, 3, 0, 0, 0, 1, "2 OKT 1953", "*") + call tdfb("2 OCT 1953", 2, 4, 0, 0, 0, 1, "2 Okt 1953", "*") + call tdfb("2 OCT 1953", 2, 5, 0, 0, 0, 1, "2 OKTOBER 1953", "*") + call tdfb("2 OCT 1953", 2, 6, 0, 0, 0, 1, "2 Oktober 1953", "*") + call tdfb("2 OCT 1953", 2, 7, 0, 0, 0, 1, "2 okt 1953", "*") + call tdfb("2 OCT 1953", 2, 8, 0, 0, 0, 1, "2 oktober 1953", "*") + set_and_check_locale("en_US", "English") + } + +/* test roman numeral months */ + call tdfb("2 JAN 1953", 2,10, 0, 0, 0, 1, "2 i 1953", "*") + call tdfb("2 JAN 1953", 2,11, 0, 0, 0, 1, "2 I 1953", "*") + call tdfb("2 FEB 1953", 2,10, 0, 0, 0, 1, "2 ii 1953", "*") + call tdfb("2 FEB 1953", 2,11, 0, 0, 0, 1, "2 II 1953", "*") + call tdfb("2 MAR 1953", 2,10, 0, 0, 0, 1, "2 iii 1953", "*") + call tdfb("2 MAR 1953", 2,11, 0, 0, 0, 1, "2 III 1953", "*") + call tdfb("2 APR 1953", 2,10, 0, 0, 0, 1, "2 iv 1953", "*") + call tdfb("2 APR 1953", 2,11, 0, 0, 0, 1, "2 IV 1953", "*") + call tdfb("2 MAY 1953", 2,10, 0, 0, 0, 1, "2 v 1953", "*") + call tdfb("2 MAY 1953", 2,11, 0, 0, 0, 1, "2 V 1953", "*") + call tdfb("2 JUN 1953", 2,10, 0, 0, 0, 1, "2 vi 1953", "*") + call tdfb("2 JUN 1953", 2,11, 0, 0, 0, 1, "2 VI 1953", "*") + call tdfb("2 JUL 1953", 2,10, 0, 0, 0, 1, "2 vii 1953", "*") + call tdfb("2 JUL 1953", 2,11, 0, 0, 0, 1, "2 VII 1953", "*") + call tdfb("2 AUG 1953", 2,10, 0, 0, 0, 1, "2 viii 1953", "*") + call tdfb("2 AUG 1953", 2,11, 0, 0, 0, 1, "2 VIII 1953", "*") + call tdfb("2 SEP 1953", 2,10, 0, 0, 0, 1, "2 ix 1953", "*") + call tdfb("2 SEP 1953", 2,11, 0, 0, 0, 1, "2 IX 1953", "*") + call tdfb("2 OCT 1953", 2,10, 0, 0, 0, 1, "2 x 1953", "*") + call tdfb("2 OCT 1953", 2,11, 0, 0, 0, 1, "2 X 1953", "*") + call tdfb("2 NOV 1953", 2,10, 0, 0, 0, 1, "2 xi 1953", "*") + call tdfb("2 NOV 1953", 2,11, 0, 0, 0, 1, "2 XI 1953", "*") + call tdfb("2 DEC 1953", 2,10, 0, 0, 0, 1, "2 xii 1953", "*") + call tdfb("2 DEC 1953", 2,11, 0, 0, 0, 1, "2 XII 1953", "*") + call tdfb("@#DHEBREW@ 2 ELL 1953", 2,10, 0, 0, 0, 1, "2 xiii 1953 HEB", "*") + call tdfb("@#DHEBREW@ 2 ELL 1953", 2,11, 0, 0, 0, 1, "2 XIII 1953 HEB", "*") + +/* test simple 3 digit year dates */ + call tdfb("11 MAY 812", 0, 0, 0, 0, 0, 1, "11 5 812", "*") + call tdfb("11 MAY 812", 0, 1, 0, 0, 0, 1, "11 05 812", "*") + call tdfb("11 MAY 812", 0, 2, 0, 0, 0, 1, "11 5 812", "*") + call tdfb("11 MAY 812", 0, 3, 0, 0, 0, 1, "11 MAY 812", "*") + call tdfb("11 MAY 812", 0, 4, 0, 0, 0, 1, "11 May 812", "*") + call tdfb("11 MAY 812", 0, 5, 0, 0, 0, 1, "11 MAY 812", "*" ) + call tdfb("11 MAY 812", 0, 6, 0, 0, 0, 1, "11 May 812", "*") + call tdfb("11 MAY 812", 1, 6, 0, 0, 0, 1, "11 May 812", "*") + call tdfb("11 MAY 812", 2, 6, 0, 0, 0, 1, "11 May 812", "*") + /* test missing day or month (legal in GEDCOM) */ + call tdfb("11 MAY 812", 1, 1, 1, 2, 2, 1, "05/11/0812 A.D.", "*") + call tdfb("MAY 812", 1, 1, 1, 2, 2, 1, "05/ /0812 A.D.", "*") + call tdfb("812", 1, 1, 1, 2, 2, 1, " / /0812 A.D.", "*") + +/* test simple 2 digit year dates */ + call tdfb("2 JAN 53", 0, 0, 0, 0, 0, 1, " 2 1 53", "*") + call tdfb("2 JAN 53", 1, 0, 0, 0, 0, 1, "02 1 53", "*") + call tdfb("2 JAN 53", 2, 0, 0, 0, 0, 1, "2 1 53", "*") + call tdfb("2 JAN 53", 2, 1, 0, 0, 0, 1, "2 01 53", "*") + call tdfb("2 JAN 53", 2, 1, 1, 0, 0, 1, "2 01 0053", "*") + call tdfb("2 JAN 53", 2, 1, 2, 0, 0, 1, "2 01 53", "*") + /* test missing day or month (legal in GEDCOM) */ + call tdfb("2 JAN 53", 1, 1, 1, 2, 2, 1, "01/02/0053 A.D.", "*") + call tdfb("JAN 53", 1, 1, 1, 2, 2, 1, "01/ /0053 A.D.", "*") + call tdfb("53", 1, 1, 1, 2, 2, 1, " / /0053 A.D.", "*") + +/* test simple 1 digit year dates */ + call tdfb("2 JAN 3", 0, 0, 0, 0, 0, 1, " 2 1 3", "*") + call tdfb("2 JAN 3", 1, 0, 0, 0, 0, 1, "02 1 3", "*") + call tdfb("2 JAN 3", 2, 0, 0, 0, 0, 1, "2 1 3", "*") + call tdfb("2 JAN 3", 2, 1, 0, 0, 0, 1, "2 01 3", "*") + call tdfb("2 JAN 3", 2, 1, 1, 0, 0, 1, "2 01 0003", "*") + call tdfb("2 JAN 3", 2, 1, 2, 0, 0, 1, "2 01 3", "*") + /* test missing day or month (legal in GEDCOM) */ + call tdfb("2 JAN 3", 1, 1, 1, 2, 2, 1, "01/02/0003 A.D.", "*") + call tdfb("JAN 3", 1, 1, 1, 2, 2, 1, "01/ /0003 A.D.", "*") + call tdfb("3", 1, 1, 1, 2, 2, 1, " / /0003 A.D.", "*") + +/* test slash years */ + call tdfb("24 FEB 1956/7", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("24 FEB 1956/57", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("24 FEB 1956/957", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("24 FEB 1956/1957", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + +/* test simple BC dates */ + call tdfb("15 MAR 30 B.C.", 0, 0, 0, 0, 0, 1, "15 3 30", "*") + call tdfb("15 MAR 30 B.C.", 0, 0, 0, 0, 1, 1, "15 3 30 B.C.", "*") + call tdfb("15 MAR 30 B.C.", 0, 0, 1, 0, 1, 1, "15 3 0030 B.C.", "*") + call tdfb("15 MAR 30 B.C.", 0, 0, 2, 0, 1, 1, "15 3 30 B.C.", "*") + call tdfb("15 MAR 30 B.C.", 0, 0, 2, 0, 2, 1, "15 3 30 B.C.", "*") + call tdfb("15 MAR 30 B.C.", 0, 0, 2, 0, 11, 1, "15 3 30 BC", "*") + call tdfb("15 MAR 30 B.C.", 0, 0, 2, 0, 21, 1, "15 3 30 B.C.E.", "*") + call tdfb("15 MAR 30 B.C.", 0, 0, 2, 0, 31, 1, "15 3 30 BCE", "*") + call tdfb("15 MAR 30 (B.C.)", 0, 0, 0, 0, 0, 1, "15 3 30", "*") + call tdfb("15 MAR 30 (B.C.)", 0, 0, 0, 0, 1, 1, "15 3 30 B.C.", "*") + call tdfb("15 MAR 30 (B.C.)", 0, 0, 1, 0, 1, 1, "15 3 0030 B.C.", "*") + call tdfb("15 MAR 30 (B.C.)", 0, 0, 2, 0, 1, 1, "15 3 30 B.C.", "*") + call tdfb("15 MAR 30 (B.C.)", 0, 0, 2, 0, 2, 1, "15 3 30 B.C.", "*") + call tdfb("15 MAR 30 (B.C.)", 0, 0, 2, 0, 11, 1, "15 3 30 BC", "*") + call tdfb("15 MAR 30 (B.C.)", 0, 0, 2, 0, 21, 1, "15 3 30 B.C.E.", "*") + call tdfb("15 MAR 30 (B.C.)", 0, 0, 2, 0, 31, 1, "15 3 30 BCE", "*") + +/* test simple dates in non-GEDCOM format */ + /* It tries to handle 3 numbers, *if* it can find unambiguous interpretation */ + call tdfb("1932/11/24", 0, 0, 0, 0, 0, 1, "24 11 1932", "*") + call tdfb("1932 11 24", 0, 0, 0, 0, 0, 1, "24 11 1932", "*") + call tdfb("1932.11.24", 0, 0, 0, 0, 0, 1, "24 11 1932", "*") + call tdfb("1932-11-24", 0, 0, 0, 0, 0, 1, "24 11 1932", "*") + call tdfb("11/24/1932", 0, 0, 0, 0, 0, 1, "24 11 1932", "*") + call tdfb("24/11/1932", 0, 0, 0, 0, 0, 1, "24 11 1932", "*") + call tdfb("1956/7 FEB 24", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/57 FEB 24", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/957 FEB 24", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/1957 FEB 24", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/7 24 2", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/57 24 2", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/957 24 2", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/1957 24 2", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/7 24 2", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/57 24 2", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/957 24 2", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + call tdfb("1956/1957 24 2", 2, 2, 0, 10, 0, 0, "1956-2-24", "*") + +/* Complex tests */ + complexpic(4, 0) + call tdfb("AFT 3 SEP 1630", 0, 0, 0, 0, 0, 1, " 3 9 1630", "after 3 9 1630") + call tdfb("AFT 3 SEP 1630", 0, 0, 0, 0, 0, 3, " 3 9 1630", "AFT 3 9 1630") + call tdfb("AFT 3 SEP 1630", 0, 0, 0, 0, 0, 4, " 3 9 1630", "Aft 3 9 1630") + call tdfb("AFT 3 SEP 1630", 0, 0, 0, 0, 0, 5, " 3 9 1630", "AFTER 3 9 1630") + call tdfb("AFT 3 SEP 1630", 0, 0, 0, 0, 0, 6, " 3 9 1630", "After 3 9 1630") + call tdfb("AFT 3 SEP 1630", 0, 0, 0, 0, 0, 7, " 3 9 1630", "aft 3 9 1630") + call tdfb("AFT 3 SEP 1630", 0, 0, 0, 0, 0, 8, " 3 9 1630", "after 3 9 1630") + complexpic(4, ">%1") + call tdfb("AFT 3 SEP 1630", 0, 0, 0, 0, 0, 8, " 3 9 1630", "> 3 9 1630") + complexpic(4, 0) + complexpic(3, 0) + call tdfb("BEF 3 SEP 1630", 0, 0, 0, 0, 0, 1, " 3 9 1630", "before 3 9 1630") + call tdfb("BEF 3 SEP 1630", 0, 0, 0, 0, 0, 3, " 3 9 1630", "BEF 3 9 1630") + call tdfb("BEF 3 SEP 1630", 0, 0, 0, 0, 0, 4, " 3 9 1630", "Bef 3 9 1630") + call tdfb("BEF 3 SEP 1630", 0, 0, 0, 0, 0, 5, " 3 9 1630", "BEFORE 3 9 1630") + call tdfb("BEF 3 SEP 1630", 0, 0, 0, 0, 0, 6, " 3 9 1630", "Before 3 9 1630") + call tdfb("BEF 3 SEP 1630", 0, 0, 0, 0, 0, 7, " 3 9 1630", "bef 3 9 1630") + call tdfb("BEF 3 SEP 1630", 0, 0, 0, 0, 0, 8, " 3 9 1630", "before 3 9 1630") + complexpic(3, "<%1") + call tdfb("BEF 3 SEP 1630", 0, 0, 0, 0, 0, 8, " 3 9 1630", "< 3 9 1630") + complexpic(3, 0) + complexpic(5, 0) + call tdfb("BET 3 SEP 1630 AND OCT 1900", 0, 0, 0, 0, 0, 1, " 3 9 1630", "between 3 9 1630 and 10 1900") + complexpic(5, "%1/%2") + call tdfb("BET 3 SEP 1630 AND OCT 1900", 2, 2, 0, 5, 0, 1, "3-9-1630", "3-9-1630/-10-1900") + complexpic(5, 0) + complexpic(6, 0) + call tdfb("FROM 3 SEP 1630", 0, 0, 0, 0, 0, 1, " 3 9 1630", "from 3 9 1630") + complexpic(7, 0) + call tdfb("TO 3 SEP 1630", 0, 0, 0, 0, 0, 1, " 3 9 1630", "to 3 9 1630") + complexpic(8, 0) + call tdfb("FROM 3 SEP 1630 TO 1700", 0, 0, 0, 0, 0, 1, " 3 9 1630", "from 3 9 1630 to 1700") + call tdfb("FROM 3 SEP 1630 TO 1700", 0, 0, 0, 0, 0, 3, " 3 9 1630", "FR 3 9 1630 TO 1700") + call tdfb("FROM 3 SEP 1630 TO 1700", 0, 0, 0, 0, 0, 4, " 3 9 1630", "Fr 3 9 1630 To 1700") + call tdfb("FROM 3 SEP 1630 TO 1700", 0, 0, 0, 0, 0, 5, " 3 9 1630", "FROM 3 9 1630 TO 1700") + call tdfb("FROM 3 SEP 1630 TO 1700", 0, 0, 0, 0, 0, 6, " 3 9 1630", "From 3 9 1630 To 1700") + call tdfb("FROM 3 SEP 1630 TO 1700", 0, 0, 0, 0, 0, 7, " 3 9 1630", "fr 3 9 1630 to 1700") + call tdfb("FROM 3 SEP 1630 TO 1700", 0, 0, 0, 0, 0, 8, " 3 9 1630", "from 3 9 1630 to 1700") + complexpic(8, "%1=>%2") + call tdfb("FROM 3 SEP 1630 TO 1700", 2, 2, 0, 9, 0, 8, "1630/9/3", "1630/9/3=>1700//") + complexpic(8, 0) + complexpic(1, 0) + call tdfb("ABT 3 SEP 890", 0, 0, 0, 0, 0, 1, " 3 9 890", "about 3 9 890") + call tdfb("EST 3 SEP 890", 0, 0, 0, 0, 0, 1, " 3 9 890", "estimated 3 9 890") + call tdfb("EST 3 SEP 890", 0, 0, 0, 0, 0, 3, " 3 9 890", "EST 3 9 890") + call tdfb("EST 3 SEP 890", 0, 0, 0, 0, 0, 4, " 3 9 890", "Est 3 9 890") + call tdfb("EST 3 SEP 890", 0, 0, 0, 0, 0, 5, " 3 9 890", "ESTIMATED 3 9 890") + call tdfb("EST 3 SEP 890", 0, 0, 0, 0, 0, 6, " 3 9 890", "Estimated 3 9 890") + call tdfb("EST 3 SEP 890", 0, 0, 0, 0, 0, 7, " 3 9 890", "est 3 9 890") + call tdfb("EST 3 SEP 890", 0, 0, 0, 0, 0, 8, " 3 9 890", "estimated 3 9 890") + complexpic(1, "~%1") + call tdfb("EST 3 SEP 890", 0, 0, 0, 0, 0, 1, " 3 9 890", "~ 3 9 890") + complexpic(1, 0) + complexpic(2, 0) + call tdfb("CAL 3 SEP 890", 2, 2, 2, 10, 0, 1, "890-9-3", "calculated 890-9-3") + call tdfb("CAL 3 SEP 890", 2, 2, 2, 10, 0, 3, "890-9-3", "CAL 890-9-3") + call tdfb("CAL 3 SEP 890", 2, 2, 2, 10, 0, 4, "890-9-3", "Cal 890-9-3") + call tdfb("CAL 3 SEP 890", 2, 2, 2, 10, 0, 5, "890-9-3", "CALCULATED 890-9-3") + call tdfb("CAL 3 SEP 890", 2, 2, 2, 10, 0, 6, "890-9-3", "Calculated 890-9-3") + call tdfb("CAL 3 SEP 890", 2, 2, 2, 10, 0, 7, "890-9-3", "cal 890-9-3") + call tdfb("CAL 3 SEP 890", 2, 2, 2, 10, 0, 8, "890-9-3", "calculated 890-9-3") + complexpic(2, "^%1") + call tdfb("CAL 3 SEP 890", 2, 2, 2, 10, 0, 1, "890-9-3", "^890-9-3") + complexpic(2, "^") + call tdfb("CAL 3 SEP 890", 2, 2, 2, 10, 0, 1, "890-9-3", "^") + complexpic(2, "^%1^%1") + call tdfb("CAL 3 SEP 890", 2, 2, 2, 10, 0, 1, "890-9-3", "^890-9-3^890-9-3") + complexpic(2, 0) + +/* Complex tests with bad input */ + call tdfb("24 SEP 811 TO 29 SEP 811", 0, 0, 0, 0, 0, 1, "24 9 811", "from 24 9 811 to 29 9 811") + + +/* Calendar tests */ + call tdfb("@#DGREGORIAN@ 1 JAN 1953", 2, 6, 0, 0, 0, 1, "1 January 1953", "*") + call tdfb("@#DJULIAN@ 1 JAN 1953", 2, 6, 0, 0, 0, 1, "1 January 1953J", "*") + +/* French Republic Calendar tests */ + call tdfb("@#DFRENCH R@ 1 VEND 11", 2, 0, 2, 0, 0, 1, "1 1 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 VEND 11", 2, 1, 2, 0, 0, 1, "1 01 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 VEND 11", 2, 2, 2, 0, 0, 1, "1 1 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 VEND 11", 2, 3, 2, 0, 0, 1, "1 VEND 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 VEND 11", 2, 4, 2, 0, 0, 1, "1 Vend 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 VEND 11", 2, 5, 2, 0, 0, 1, "1 VENDEMIAIRE 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 VEND 11", 2, 6, 2, 0, 0, 1, "1 Vendemiaire 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 VEND 11", 2, 7, 2, 0, 0, 1, "1 vend 11 FR", "1 vend 11 FR") + call tdfb("@#DFRENCH R@ 1 VEND 11", 2, 8, 2, 0, 0, 1, "1 vendemiaire 11 FR", "1 vendemiaire 11 FR") + call tdfb("@#DFRENCH R@ 1 BRUM 11", 2, 8, 2, 0, 0, 1, "1 brumaire 11 FR", "1 brumaire 11 FR") + call tdfb("@#DFRENCH R@ 1 FRIM 11", 2, 8, 2, 0, 0, 1, "1 frimaire 11 FR", "1 frimaire 11 FR") + call tdfb("@#DFRENCH R@ 1 NIVO 11", 2, 8, 2, 0, 0, 1, "1 nivose 11 FR", "1 nivose 11 FR") + call tdfb("@#DFRENCH R@ 1 PLUV 11", 2, 8, 2, 0, 0, 1, "1 pluviose 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 VENT 11", 2, 8, 2, 0, 0, 1, "1 ventose 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 GERM 11", 2, 8, 2, 0, 0, 1, "1 germinal 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 FLOR 11", 2, 8, 2, 0, 0, 1, "1 floreal 11 FR", "*") + call tdfb("@#DFRENCH R@ 1 PRAI 11", 2, 8, 2, 0, 0, 1, "1 prairial 11 FR", "*") + call tdfb("BET @#DFRENCH R@ 1 PRAI 11 AND @#DFRENCH R@ 2 BRUM 12", 2, 8, 2, 0, 0, 1 + , "1 prairial 11 FR", "between 1 prairial 11 FR and 2 brumaire 12 FR") + call tdfb("BET @#DFRENCH R@ 1 PRAI 11 AND @#DFRENCH R@ 2 BRUM 12", 2, 2, 2, 10, 0, 7 + , "11-9-1 FR", "bet 11-9-1 FR and 12-2-2 FR") + +/* Hebrew Calendar tests */ + call tdfb("@#DHEBREW@ 1 TSH 3011", 2, 0, 0, 0, 0, 1, "1 1 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 TSH 3011", 2, 1, 0, 0, 0, 1, "1 01 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 TSH 3011", 2, 2, 0, 0, 0, 1, "1 1 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 TSH 3011", 2, 3, 0, 0, 0, 1, "1 TSH 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 TSH 3011", 2, 4, 0, 0, 0, 1, "1 Tsh 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 TSH 3011", 2, 5, 0, 0, 0, 1, "1 TISHRI 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 TSH 3011", 2, 6, 0, 0, 0, 1, "1 Tishri 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 TSH 3011", 2, 7, 0, 0, 0, 1, "1 tsh 3011 HEB", "1 tsh 3011 HEB") + call tdfb("@#DHEBREW@ 1 TSH 3011", 2, 8, 0, 0, 0, 1, "1 tishri 3011 HEB", "1 tishri 3011 HEB") + call tdfb("@#DHEBREW@ 1 ADS 3011", 2, 0, 0, 0, 0, 1, "1 7 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ADS 3011", 2, 1, 0, 0, 0, 1, "1 07 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ADS 3011", 2, 2, 0, 0, 0, 1, "1 7 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ADS 3011", 2, 3, 0, 0, 0, 1, "1 ADS 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ADS 3011", 2, 4, 0, 0, 0, 1, "1 Ads 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ADS 3011", 2, 5, 0, 0, 0, 1, "1 ADAR SHENI 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ADS 3011", 2, 6, 0, 0, 0, 1, "1 Adar Sheni 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ADS 3011", 2, 7, 0, 0, 0, 1, "1 ads 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ADS 3011", 2, 8, 0, 0, 0, 1, "1 adar sheni 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 CSH 3011", 2, 1, 0, 0, 0, 1, "1 02 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 KSL 3011", 2, 1, 0, 0, 0, 1, "1 03 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 TVT 3011", 2, 1, 0, 0, 0, 1, "1 04 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 SHV 3011", 2, 1, 0, 0, 0, 1, "1 05 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ADR 3011", 2, 1, 0, 0, 0, 1, "1 06 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ADS 3011", 2, 1, 0, 0, 0, 1, "1 07 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 NSN 3011", 2, 1, 0, 0, 0, 1, "1 08 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 IYR 3011", 2, 1, 0, 0, 0, 1, "1 09 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 SVN 3011", 2, 1, 0, 0, 0, 1, "1 10 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 TMZ 3011", 2, 1, 0, 0, 0, 1, "1 11 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 AAV 3011", 2, 1, 0, 0, 0, 1, "1 12 3011 HEB", "*") + call tdfb("@#DHEBREW@ 1 ELL 3011", 2, 1, 0, 0, 0, 1, "1 13 3011 HEB", "*") + + /* ROMAN would presumably be in AUC, and days counted before K,N,I */ + + call reportSubsection("date tests") +} + +/* + (Worker routine for testDates) + Test parsing & formatting simultaneously + Using specified formats, check stddate(src) against dests + and complexdate(src) against destc + tdfb = test date format both (simple & complex) + If destc="*", then we'll test complexdate result against dests + */ +proc tdfb(src, dayfmt, monfmt, yrfmt, sfmt, ofmt, cfmt, dests, destc) +{ + dayformat(dayfmt) + monthformat(monfmt) + yearformat(yrfmt) + dateformat(sfmt) + eraformat(ofmt) + set(result, stddate(src)) + if (ne(result, dests)) + { + set(orig, concat(src,", ", d(dayfmt), ", ", d(monfmt))) + set(orig, concat(orig, ", ", d(yrfmt), ", ",d(sfmt))) + set(orig, concat(orig, ", ", d(ofmt))) + call reportfail(concat("stddate failure: '", dests, "'<>'", result, "'", " from ", orig)) + } else { + incr(testok) + } + complexformat(cfmt) + if (eq(destc,"*")) + { + set(destc, dests) + } + set(result, complexdate(src)) + if (ne(result, destc)) + { + set(orig, concat(src,", ", d(dayfmt), ", ", d(monfmt))) + set(orig, concat(orig, ", ", d(yrfmt), ", ",d(sfmt))) + set(orig, concat(orig, ", ", d(ofmt))) + call reportfail(concat("complexdate failure: '", destc, "'<>'", result, "'", " from ", orig)) + } else { + incr(testok) + } +} + +/* + Test parsing only, using year(), month(), and day() functions + src is the string to parse + yr,mo,da is the correct output against which to test + */ +proc tdparse(src, yr, mo, da) +{ + set(result, strtoint(year(src))) + if (ne(result, yr)) + { + call reportfail(concat("year(", src, ") failure: ", d(yr), "<>", d(result))) + } else { + incr(testok) + } + extractdatestr(modvar, dvar, mvar, yvar, ystvar, src) + if (ne(yvar, yr)) + { + call reportfail(concat("extractdatestr(", src, ").yr failure: ", d(yr), "<>", d(yvar))) + } else { + incr(testok) + } + if (ne(mvar, mo)) + { + call reportfail(concat("extractdatestr(", src, ").mo failure: ", d(mo), "<>", d(mvar))) + } else { + incr(testok) + } + if (ne(dvar, da)) + { + call reportfail(concat("extractdatestr(", src, ").da failure: ", d(da), "<>", d(dvar))) + } else { + incr(testok) + } +} + +/* + Check dayofweek() with a series of sample tests + */ +proc dodowtests() +{ + call testdow("2 JAN 1953", "Friday") + call testdow("6 JUN 2006", "Tuesday") + call testdow("5 MAY 1862", "Monday") +} + +/* + Perform one test of function dayofweek() + src is the date (as string) to parse + adow is the correct answer + */ +proc testdow(src, adow) +{ + set(result, dayofweek(src)) + if (ne(result, adow)) + { + call reportfail(concat("dayofweek(", src, ") failure: ", adow, "<>", result)) + } else { + incr(testok) + } +} + +/* + Check dayofweek() with a series of sample tests + */ +proc dojdtests() +{ + call testjd("2 JAN 1953", "3 JAN 1953") + call testjd("15 MAR 1582", "16 MAR 1582") +} + +/* + Using one sample date, test the julian date functions + jdstring is the date to test + jdnext is the day after (to test adding one to the julian date number) + NB: All dates must be passed to stddate before comparison, + including jdstring and jdnext, so all are formatted the same. + */ +proc testjd(jdstring, jdnext) +{ + set(orig, stddate(jdstring)) + set(jdnum, date2jd(jdstring)) + set(jdeven, jd2date(jdnum)) + set(result, stddate(jdeven)) + if (ne(orig, result)) + { + call reportfail(concat("jd2date(date2jd(", jdstring, ")) failure: ", orig, "<>", result)) + } else { + incr(testok) + } + set(jdnum1, add(jdnum, 1)) + set(result, stddate(jd2date(jdnum1))) + set(desired, stddate(jdnext)) + if (ne(desired, result)) + { + call reportfail(concat("stddate(date2jd(", jdstring, ")+1) failure: ", desired, "<>", result)) + } else { + incr(testok) + } + +} diff --git a/reports/st/st_db.li b/reports/st/st_db.li new file mode 100644 index 0000000..f2b6a8d --- /dev/null +++ b/reports/st/st_db.li @@ -0,0 +1,328 @@ +/* + * @progname st_db.li + * @version 1.26 [of 2005-02-01] + * @author Perry Rapp + * @category self-test + * @output none + * @description + * + * Exercise some database functions. + * Dumps some of each type of record, followed by all 3 gengedcoms. + * + */ + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") + +global(dead) +global(cutoff_yr) + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call exerciseDb() +} + +proc exerciseDb() +{ + + "database: " database() nl() + "version: " version() nl() + + set(cutoff_yr, 1900) /* assume anyone born before this is dead */ + + set(N, 5) /* output this many of each type of record */ + + set(living,0) + set(dead,0) + + /* count up # of living & dead indis, and output first N of each */ + nl() nl() "*** PERSONS ***" nl() nl() + indiset(iset) + forindi (person, pnum) + { + /* exercise indi stuff with the first person */ + if (lt(add(living,dead),1)) + { + call exerciseIndi(person) + } + /* output the first N living & first N dead people */ + if (isLivingPerson(person)) + { + set(living,add(living,1)) + if (lt(living,N)) + { + call outputLivingIndi(person) + addtoset(iset,person,1) + } + } + else + { + set(dead,add(dead,1)) + if (lt(dead,N)) + { + call outputRec(person) + addtoset(iset,person,0) + } + } + } + nl() "Live INDI: " d(living) nl() + "Dead INDI: " d(dead) nl() + + set(living,0) + set(dead,0) + /* count up # of living & dead fams, and output first N of each */ + + nl() nl() "*** FAMILIES ***" nl() nl() + forfam (fam, fnum) + { + /* output the first N living & first N dead families */ + if (isLivingFam(fam)) + { + set(living,add(living,1)) + if (lt(living,N)) + { + call outputLivingFam(fam) + } + } + else + { + set(dead,add(dead,1)) + if (lt(dead,N)) + { + call outputRec(fam) + } + } + } + nl() "Live FAM: " d(living) nl() + "Dead FAM: " d(dead) nl() + + nl() nl() "*** SOURCES ***" nl() nl() + forsour (sour,snum) + { + if (lt(snum,N)) + { + call outputRec(sour) + } + } + + nl() nl() "*** EVENTS ***" nl() nl() + foreven (even,enum) + { + if (lt(enum,N)) + { + call outputRec(even) + } + } + + nl() nl() "*** OTHERS ***" nl() nl() + forothr (othr,onum) + { + if (lt(onum,N)) + { + call outputRec(othr) + } + } + + nl() nl() "*** GENGEDCOM *** " nl() nl() + gengedcom(iset) + nl() nl() "*** GENGEDCOMWEAK *** " nl() nl() + gengedcomweak(iset) + nl() nl() "*** GENGEDCOMSTRONG *** " nl() nl() + gengedcomstrong(iset) +} + +/* Output entire record, except filter out SOUR & NOTE sections */ +proc outputRec(record) +{ + traverse (root(record), node, level) + { + if (or(eq(level,0),and(ne(tag(node),"SOUR"),ne(tag(node),"NOTE")))) + { + d(level) " " xref(node) " " tag(node) " " value(node) + nl() + } + } +} + +proc outputLivingIndi(indi) +{ + "0 @" key(indi) "@ INDI" nl() + "1 NAME " fullname(indi,0,1,50) nl() + fornodes(inode(indi), node) + { + if (isFamilyPtr(node)) + { + "1 " xref(node) " " tag(node) " " value(node) + nl() + } + } +} + +proc outputLivingFam(fam) +{ + "0 @" key(fam) "@ FAM" nl() + fornodes(root(fam), node) + { + if (isMemberPtr(node)) + { + "1 " xref(node) " " tag(node) " " value(node) + nl() + } + } +} + +func isLivingFam(fam) +{ + fornodes(root(fam), node) + { + if (isMemberPtr(node)) + { + if (isLivingPerson(indi(value(node)))) { return (1) } + } + } + return (0) +} + +func isLivingPerson(indi) +{ + if (death(indi)) { return (0) } + if (birth(indi)) + { + list(placelist) + extractplaces(birth(indi), placelist, count) + extractdate(birth(indi),day,mon,yr) + if (and(gt(yr,300),lt(yr,cutoff_yr))) { return (0) } + } + return (1) +} + + +func isFamilyPtr (node) +{ + if (eq(tag(node),"FAMC")) { return (1) } + if (eq(tag(node),"FAMS")) { return (1) } + return (0) +} + +func isMemberPtr (node) +{ + if (eq(tag(node),"HUSB")) { return (1) } + if (eq(tag(node),"WIFE")) { return (1) } + if (eq(tag(node),"CHIL")) { return (1) } + return (0) +} + +/* Uses a lot of function calls */ +proc exerciseIndi(indi) +{ + list(lst) + set(em, empty(lst)) + enqueue(lst, indi) + push(lst, father(indi)) + requeue(lst, mother(indi)) + set(junk,pop(lst)) + setel(lst, 1, nextsib(indi)) + forlist(lst, el, count) + { + name(el) " " d(count) nl() + } + table(tbl) + insert(tbl, "bob", indi) + set(thing, lookup(tbl, "bob")) + indiset(iset) + addtoset(iset,indi,"bob") + set(iset,union(iset,parentset(iset))) + addtoset(iset,indi,"jerry") + addtoset(iset,father(indi), "dad") + addtoset(iset,mother(indi), "mom") + addtoset(iset,nextsib(indi), "bro") + spouses(indi,spouse,fam,num) + { + addtoset(iset,spouse,fam) + "spouse: " fullname(spouse, true, true, 20) nl() + } + families(indi,fam,spouse,num) + { + addtoset(iset,spouse,num) + "family: " key(fam) nl() + children(fam, chil, chilnum) + { + addtoset(iset, chil, chilnum) + "child: " key(chil) nl() + } + } + addtoset(iset,nextindi(indi),"next") + addtoset(iset,previndi(indi),"prev") + set(ichildren, childset(iset)) + set(isiblings, siblingset(iset)) + set(ispouses, spouseset(iset)) + set(iancestors, ancestorset(iset)) + set(idescendants, descendentset(iset)) + uniqueset(iancestors) + indiset(jset) + addtoset(jset, indi, "first") + if (inset(jset, indi)) { + addtoset(jset, indi, "second") + } + deletefromset(jset, indi, 0) + namesort(iancestors) + valuesort(iancestors) + keysort(iancestors) + set(kset, intersect(iset,iancestors)) + set(kset, difference(iset,iancestors)) + set(p,99) + "name: " name(indi) nl() + "title: " title(indi) nl() + "key: " key(indi) nl() + parents(indi) nl() + "fullname(12): " fullname(indi,true,true,12) nl() + "surname: " surname(indi) nl() + "givens: " givens(indi) nl() + "trimname(8): " trimname(indi,8) nl() + lock(indi) + call dumpnode("birth", birth(indi)) + call dumpnodetr("death", death(indi)) + unlock(indi) + fornotes(inode(indi), notetext) { /* exercise fornotes */ + set(currentext, notetext) + } +} + +proc dumpnode(desc, node) +{ + if (node) + { + desc ": " xref(node) " " tag(node) " " value(node) + fornodes(node, child) + { + call dumpnode2(child) + } + } +} + +proc dumpnode2(node) +{ + xref(node) " " tag(node) " " value(node) + fornodes(node, child) + { + call dumpnode2(child) + } +} + +proc dumpnodetr(desc, node) +{ + if (node) + { + desc ": " xref(node) " " tag(node) " " value(node) nl() + traverse(node, child,lvl) + { + xref(node) " " tag(node) " " value(node) nl() + } + } +} + + diff --git a/reports/st/st_list.li b/reports/st/st_list.li new file mode 100644 index 0000000..4571725 --- /dev/null +++ b/reports/st/st_list.li @@ -0,0 +1,250 @@ +/* + * @progname st_list.li + * @version 1.16 (2007-05-06) + * @author Perry Rapp + * @category self-test + * @output none + * @description validate list functions +*/ + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call testLists() +} + +/* + test some list functions + */ +proc testLists() +{ + call initSubsection() + + list(li) + if (not(empty(li))) { + call reportfail("empty FAILED") + } + else { incr(testok) } + if (inlist(li,4)) { + call reportfail("inlist(empty) FAILED") + } + else { incr(testok) } + enqueue(li, 1) + if (empty(li)) { + call reportfail("not empty FAILED") + } + else { incr(testok) } + if (not(inlist(li,1))) { + call reportfail("inlist(1) in list with 1 FAILED") + } + else { incr(testok) } + if (inlist(li,4)) { + call reportfail("inlist(4) in list without 4 FAILED") + } + else { incr(testok) } + set(te, dequeue(li)) + if (ne(te, 1)) { + call reportfail("dequeue(1) FAILED") + } + else { incr(testok) } +/* enqueue & dequeue */ + enqueue(li, 100) + enqueue(li, 200) + set(te, dequeue(li)) + if (ne(te, 100)) { + call reportfail("dequeue(100) FAILED") + } + else { incr(testok) } + set(te, dequeue(li)) + if (ne(te, 200)) { + call reportfail("dequeue(200) FAILED") + } + else { incr(testok) } + if (not(empty(li))) { + call reportfail("empty (enqueue & dequeue) FAILED") + } + else { incr(testok) } +/* requeue */ + enqueue(li, 10) + enqueue(li, 20) + set(te, dequeue(li)) + if (ne(te, 10)) { + call reportfail("dequeue(10) FAILED") + } + else { incr(testok) } + requeue(li, 8) + set(te, dequeue(li)) + if (ne(te, 8)) { + call reportfail("dequeue(8) FAILED") + } + else { incr(testok) } + dequeue(li) + if (not(empty(li))) { + call reportfail("empty (requeue) FAILED") + } + else { incr(testok) } +/* push & pop */ + push(li, 1) + push(li, 2) + set(te, pop(li)) + if (ne(te, 2)) { + call reportfail("pop(2) FAILED") + } + else { incr(testok) } + set(te, pop(li)) + if (ne(te, 1)) { + call reportfail("pop(1) FAILED") + } + else { incr(testok) } + if (not(empty(li))) { + call reportfail("empty (push&pop) FAILED") + } + else { incr(testok) } +/* getel & setel */ + enqueue(li, 1) + enqueue(li, 2) + set(te, getel(li, 2)) + if (ne(te, 2)) { + call reportfail("getel(,2)==2 FAILED") + } + else { incr(testok) } + setel(li, 4, 4) /* put a 4th element (3rd will be zero-filled) */ +/* forlist & length */ + set(te2,0) + set(te3,0) + set(te4,0) + forlist(li, te, n) { + set(te1, te2) + set(te2, te3) + set(te3, te4) + set(te4, te) + set(max, n) + } + if(ne(max,length(li))) {call reportfail("length FAILED")} + else {incr(testok)} + if(ne(te1,1)) {call reportfail("forlist#1 FAILED")} else {incr(testok)} + if(ne(te2,2)) {call reportfail("forlist#2 FAILED")} else {incr(testok)} + if(ne(te3,0)) {call reportfail("forlist#3 FAILED")} else {incr(testok)} + if(ne(te4,4)) {call reportfail("forlist#4 FAILED")} else {incr(testok)} +/* continue getel & setel */ + set(te, dequeue(li)) + if (ne(te, 1)) { + call reportfail("dequeue(1) from setel FAILED") + } + else { incr(testok) } + set(te, dequeue(li)) + if (ne(te, 2)) { + call reportfail("dequeue(2) from setel FAILED") + } + else { incr(testok) } + set(te, dequeue(li)) + if (ne(te, 0)) { + /* the 3rd was uninitialized created by setel */ + call reportfail("dequeue(3) from setel FAILED") + } + else { incr(testok) } + set(te, dequeue(li)) + if (ne(te, 4)) { + call reportfail("dequeue(4) from setel FAILED") + } + else { incr(testok) } + if (not(empty(li))) { + call reportfail("empty (getel & setel) FAILED") + } + else { incr(testok) } + enqueue(li, "harry") + enqueue(li, 3) + call testFreeList(li) +/* sort & rsort */ + list(li) + push(li, "aardvark") + push(li, "coon") + push(li, "bear") + push(li, "eel") + push(li, "dog") + /* sort on li */ + /* so we expect words to come out in order */ + sort(li) + if (or( + ne(getel(li, 1), "aardvark") + ,ne(getel(li, 2), "bear") + ,ne(getel(li, 3), "coon") + ,ne(getel(li, 4), "dog") + ,ne(getel(li, 5), "eel") + )) { + call reportfail("sort FAILED") + } else { incr(testok) } + /* rsort on li */ + /* so we expect words to come out in reverse order */ + rsort(li) + if (or( + ne(getel(li, 1), "eel") + ,ne(getel(li, 2), "dog") + ,ne(getel(li, 3), "coon") + ,ne(getel(li, 4), "bear") + ,ne(getel(li, 5), "aardvark") + )) { + call reportfail("rsort FAILED") + } else { incr(testok) } + + /* test sorting on 2nd argument */ + list(li) + list(li2) + push(li, "bush") + push(li2, "hsub") + push(li, "grass") + push(li2, "ssarg") + push(li, "shrub") + push(li2, "burhs") + push(li, "tree") + push(li2, "eert") + push(li, "marsh") + push(li2, "hsram") + push(li, "benz") + push(li2, "zneb") + /* sort on li2, which is words backwards */ + /* so we expect words to come out in order of each word backwards */ + /* eg, shrub is first because it ends with b */ + sort(li,li2) + if (or( + ne(getel(li, 1), "shrub") + ,ne(getel(li, 2), "tree") + ,ne(getel(li, 3), "marsh") + ,ne(getel(li, 4), "bush") + ,ne(getel(li, 5), "grass") + ,ne(getel(li, 6), "benz") + )) { + call reportfail("sort on 2 args FAILED") + } else { incr(testok) } + /* rsort on li2, which is words backwards */ + /* so we expect words to come out in reverse order of each word backwards */ + /* eg, benz is first because it ends with z */ + rsort(li, li2) + if (or( + ne(getel(li, 1), "benz") + ,ne(getel(li, 2), "grass") + ,ne(getel(li, 3), "bush") + ,ne(getel(li, 4), "marsh") + ,ne(getel(li, 5), "tree") + ,ne(getel(li, 6), "shrub") + )) { + call reportfail("rsort on 2 args FAILED") + } else { incr(testok) } + + call reportSubsection("list tests") +} + +proc testFreeList(li) +{ + free(li) + if (ne(li, 0)) { + call reportfail("free list FAILED") + } + else { incr(testok) } +} diff --git a/reports/st/st_name.li b/reports/st/st_name.li new file mode 100644 index 0000000..aeaf004 --- /dev/null +++ b/reports/st/st_name.li @@ -0,0 +1,68 @@ +/* + * @progname st_name.li + * @version 1.0 + * @author Perry Rapp + * @category self-test + * @output none + * @description validate name functions +*/ + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call testNames() +} + + +/* + test some name functions + */ +proc testNames() +{ + set(testok, 0) + set(testfail, 0) + + set(namestr, "Fyodor Nikolaievich Medvedev") + call testExtract(namestr, 3, 0) + + set(namestr, "Jose Antonio Martinez de Garcia") + call testExtract(namestr, 5, 0) + + set(namestr, "Jose Antonio /Martinez/ de Garcia") + call testExtract(namestr, 5, 3) + + set(namestr, "Kara /Hattersley-Smith/") + call testExtract(namestr, 2, 2) + + set(namestr, "L. /Vitellius/ Tancinus Cives Hisp. Caurie[n]sis") + call testExtract(namestr, 6, 2) + + call reportSubsection("name tests") +} + +/* test extractnames on passed string */ +proc testExtract(namestr, fragcount, surn) +{ + set(node, createnode("NAME", namestr)) + list(namelist) + extractnames(node, namelist, count, surna) + + if (ne(count, fragcount)) { + call reportfail(concat("extractnames failed count " + , d(count), "<>", d(fragcount), " on ", namestr)) + } + else { incr(testok) } + + if (ne(surna, surn)) { + call reportfail(concat("extractnames failed surname " + , d(surna), "<>", d(surn), " on ", namestr)) + } + else { incr(testok) } +} + diff --git a/reports/st/st_number.li b/reports/st/st_number.li new file mode 100644 index 0000000..5b06c5e --- /dev/null +++ b/reports/st/st_number.li @@ -0,0 +1,182 @@ +/* + * @progname st_number.li + * @version 1.0 + * @author Perry Rapp + * @category self-test + * @output none + * @description + * + * validate numeric functions + * + */ + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call testNums() +} + +/* + test some numeric functions + */ +proc testNums() +{ + set(testok, 0) + set(testfail, 0) + + set(one,1) + set(two,add(one,one)) + if (ne(two,2)) { + call reportfail("1+1 FAILED") + } + else { incr(testok) } + + if (eq(two,one)) { + call reportfail("1==2 FAILED") + } + else { incr(testok) } + + if (ne(add(two,two,two,two,two),10)) { + call reportfail("2+2+2+2+2 FAILED") + } + else { incr(testok) } + + if (ne(sub(two,one),1)) { + call reportfail("2-1 FAILED") + } + else { incr(testok) } + + if (ne(sub(890,30),860)) { + call reportfail("890-30 FAILED") + } + else { incr(testok) } + + if (ne(mul(3,4),12)) { + call reportfail("3*4 FAILED") + } + else { incr(testok) } + + if (ne(mul(3,-4),-12)) { + call reportfail("3*(-4) FAILED") + } + else { incr(testok) } + + if (ne(mul(-3,-4),12)) { + call reportfail("(-3)*(-4) FAILED") + } + else { incr(testok) } + + if (ne(mul(.5,.5),.25)) { + call reportfail(".5*.5 FAILED") + } + else { incr(testok) } + + if (ne(mul(2,.5),1)) { + call reportfail("2*.5 FAILED") + } + else { incr(testok) } + + if (gt(.5, .7)) { + call reportfail(".5>.7 FAILED") + } + else { incr(testok) } + + if (lt(-.4,-.5)) { + call reportfail("-.4<-.5 FAILED") + } + else { incr(testok) } + + if (ge(15,18)) { + call reportfail("15>=18 FAILED") + } + else { incr(testok) } + + if (le(-.4,-.5)) { + call reportfail("-.4<=-.5 FAILED") + } + else { incr(testok) } + + if (not(le(-.4,-.4))) { + call reportfail("-.4<=-.4 FAILED") + } + else { incr(testok) } + + if (not(le(-1,-.4))) { + call reportfail("-1<=-.4 FAILED") + } + else { incr(testok) } + + if (not(le(-1.1,-1))) { + call reportfail("-1.1<=-1 FAILED") + } + else { incr(testok) } + + if (ne(div(20, 4), 5)) { + call reportfail("20/4==5 FAILED") + } + else { incr(testok) } + + if (ne(mod(22, 7), 1)) { + call reportfail("22 % 7==1 FAILED") + } + else { incr(testok) } + + if (ne(exp(2, 10), 1024)) { + call reportfail("2 ^10 ==1024 FAILED") + } + else { incr(testok) } + + if (ne(exp(.5, 2), .25)) { + call reportfail(".5 ^2 ==.25 FAILED") + } + else { incr(testok) } + + set(bubba,34) + incr(bubba) + if (ne(bubba,35)) { + call reportfail("incr(34) == 35 FAILED") + } + else { incr(testok) } + + set(bubba,45) + decr(bubba) + if (ne(bubba,44)) { + call reportfail("decr(45) == 44 FAILED") + } + else { incr(testok) } + + set(bubba,45.3) + decr(bubba) + if (ne(bubba,44.3)) { + call reportfail("decr(45.3) == 44.3 FAILED") + } + else { incr(testok) } + + set(bubba,34.3) + incr(bubba) + if (ne(bubba,35.3)) { + call reportfail("incr(34.3) == 35.3 FAILED") + } + else { incr(testok) } + + set(bubba,45.6) + decr(bubba) + if (ne(bubba,44.6)) { + call reportfail("decr(45.6) == 44.6 FAILED") + } + else { incr(testok) } + + if (ne(neg(52), -52)) { + call reportfail("neg(52) == -52 FAILED") + } + else { incr(testok) } + + call reportSubsection("number tests") +} + diff --git a/reports/st/st_string.li b/reports/st/st_string.li new file mode 100644 index 0000000..c5ae697 --- /dev/null +++ b/reports/st/st_string.li @@ -0,0 +1,265 @@ +/* + * @progname st_string.li + * @version 1.2 of 2005-01-12 + * @author Perry Rapp + * @category self-test + * @output none + * @description validate string functions +*/ + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") + +global(undef) /* variable with no set value, used in string tests */ + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call testStrings() +} + +/* + test some string functions against defined & undefined strings + */ +proc testStrings() +{ + call initSubsection() + + set(str,"hey") + set(str2,upper(str)) + if (ne(str2,"HEY")) { + call reportfail("upper FAILED") + } + else { incr(testok) } + + set(str4,capitalize(str)) + if (ne(str4,"Hey")) { + call reportfail("capitalize FAILED") + } + else { incr(testok) } + + set(str4,titlecase(str)) + if (ne(str4,"Hey")) { + call reportfail("titlecase FAILED") + } + else { incr(testok) } + + set(str6,concat(str2,str4)) + if (ne(str6,"HEYHey")) { + call reportfail("concat FAILED") + } + else { incr(testok) } + + set(str3,upper(undef)) + set(str5,capitalize(undef)) + set(str5,titlecase(undef)) + set(str7,concat(str3,str5)) + if (ne(str7,"")) { + call reportfail("concat FAILED on undefs") + } + else { incr(testok) } + + set(str7,strconcat(str3,str5)) + if (ne(str7,"")) { + call reportfail("strconcat FAILED on undefs") + } + else { incr(testok) } + + set(str8,lower(str4)) + if (ne(str8,"hey")) { + call reportfail("lower FAILED") + } + else { incr(testok) } + + set(str9,lower(undef)) + if (ne(str9,undef)) { + call reportfail("lower FAILED on undef") + } + else { incr(testok) } + + set(str10,alpha(3)) + if(ne(str10,"c")) { + call reportfail("alpha(3) FAILED") + } + else { incr(testok) } + + set(str10,roman(4)) + if(ne(str10,"iv")) { + call reportfail("roman(4) FAILED") + } + else { incr(testok) } + + set(str11,d(43)) + if(ne(str11,"43")) { + call reportfail("d(43) FAILED") + } + else { incr(testok) } + + set(str12,card(4)) + if(ne(str12,"four")) { + call reportfail("card(4) FAILED") + } + else { incr(testok) } + + set(str13,ord(5)) + if(ne(str13,"fifth")) { + call reportfail("ord(5) FAILED") + } + else { incr(testok) } + + /* 2003-08-06 - MTE - modified to ensure that titlecase() */ + /* doesn't lowercase strings first */ + set(str14,titlecase("big brown 1MEAN horse")) + if(ne(str14,"Big Brown 1MEAN Horse")) { + call reportfail("titlecase FAILED") + } + else { incr(testok) } + + /* 2003-08-06 - MTE - added to ensure that capitalize() */ + /* doesn't lowercase strings first */ + set(str15,capitalize("lower UPPER lower")) + if(ne(str15,"Lower UPPER lower")) { + call reportfail("capitalize FAILED") + } + else { incr(testok) } + + if (ge(strcmp("alpha","beta"),0)) { + call reportfail("strcmp(alpha,beta) FAILED") + } + else { incr(testok) } + + if (le(strcmp("gamma","delta"),0)) { + call reportfail("strcmp(gamma,delta) FAILED") + } + else { incr(testok) } + + if (ne(strcmp("zeta","zeta"),0)) { + call reportfail("strcmp(zeta,zeta) FAILED") + } + else { incr(testok) } + + if (ne(strcmp(undef,""),0)) { + call reportfail("strcmp(undef,) FAILED") + } + else { incr(testok) } + + if (ne(substring("considerable",2,4),"ons")) { + call reportfail("substring(considerable,2,4) FAILED") + } + else { incr(testok) } + + if (ne(substring(undef,2,4),0)) { + call reportfail("substring(undef,2,4) FAILED") + } + else { incr(testok) } + + if (ne(rjustify("hey",5), " hey")) { + call reportfail("rjustify(hey,5) FAILED") + } + else { incr(testok) } + + if (ne(rjustify("heymon",5), "heymo")) { + call reportfail("rjustify(heymon,5) FAILED") + } + else { incr(testok) } + + /* eqstr returns bool, which may be compared to 0 but no other number */ + if (ne(eqstr("alpha","beta"),0)) { + call reportfail("eqstr(alpha,beta) FAILED") + } + else { incr(testok) } + + if (not(eqstr("alpha","alpha"))) { + call reportfail("eqstr(alpha,alpha) FAILED") + } + else { incr(testok) } + + if (ne(strtoint("4"), 4)) { + call reportfail("strtoint(4) FAILED") + } + else { incr(testok) } + + if (ne(strsoundex("pat"),strsoundex("pet"))) { + call reportfail("soundex(pat) FAILED") + } + else { incr(testok) } + + if (ne(strlen("pitch"),5)) { + call reportfail("strlen(pitch) FAILED") + } + else { incr(testok) } + + set(str14,"the cat in the hat put the sack on the rat and the hat on the bat ") + if (ne(index(str14,"at",1),6)) { + call reportfail("index(str14,at,1) FAILED") + } + else { incr(testok) } + + if (ne(index(str14,"at",2),17)) + { + call reportfail("index(str14,at,2) FAILED") + } + else { incr(testok) } + + if (ne(index(str14,"at",3),41)) + { + call reportfail("index(str14,at,3) FAILED") + } + else { incr(testok) } + + if (ne(index(str14,"at",4),53)) + { + call reportfail("index(str14,at,4) FAILED") + } + else { incr(testok) } + + if (ne(index(str14,"at",5),64)) + { + call reportfail("index(str14,at,5) FAILED") + } + else { incr(testok) } + + if (ne(strlen(str14),66)) + { + call reportfail("strlen(str14) FAILED") + } + else { incr(testok) } + + set(str15,strconcat(str14,str14)) + if (ne(strlen(str15),132)) + { + call reportfail("strlen(str15) FAILED") + } + else { incr(testok) } + + if (ne(index(str15,"at",10),130)) + { + call reportfail("index(str15,at,10) FAILED") + } + else { incr(testok) } + + set(str16,strconcat(str15,str15)) + if (ne(strlen(str16),264)) + { + call reportfail("strlen(str16) FAILED") + } + else { incr(testok) } + + if (ne(index(str16,"at",20),262)) + { + call reportfail("index(str16,at,20) FAILED") + } + else { incr(testok) } + + if (ne(substring(str16,260,262)," ba")) + { + call reportfail("substring(str16,260,262) FAILED") + } + else { incr(testok) } + + call reportSubsection("string tests") +} + diff --git a/reports/st/st_string_UTF-8.li b/reports/st/st_string_UTF-8.li new file mode 100644 index 0000000..54c7e94 --- /dev/null +++ b/reports/st/st_string_UTF-8.li @@ -0,0 +1,65 @@ +/* + * @progname st_string_UTF-8.li + * @version 1.1 + * @author Perry Rapp + * @category self-test + * @output none + * @description validate string functions on UTF-8 +*/ + +char_encoding("UTF-8") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call testStrings_UTF_8() +} + +/* + test some string functions against defined & undefined strings + */ +proc testStrings_UTF_8() +{ + call initSubsection() + + call testBothWays_UTF_8("瓣", "", "adia") /* u+00E4, u+00C4 */ + call testBothWays_UTF_8("繹", "", "odia") /* u+00F6, u+00D6 */ + call testBothWays_UTF_8("疆", "", "ae") /* u+00E6, u+00C6 */ + call testBothWays_UTF_8("Х", "Ф", "ae_acute") /* u+01FD, u+01FC */ + call testBothWays_UTF_8("簸", "", "eth") /* u+00F0, u+00D0 */ + call testBothWays_UTF_8("臘", "", "thorn") /* u+00FE, u+00DE */ + call testBothWays_UTF_8("繪", "", "o_stroke") /* u+00F8, u+00D8 */ + call testBothWays_UTF_8("", "", "oe") /* u+0153, u+0152 */ + call testBothWays_UTF_8("", "", "l_stroke") /* u+0142, u+0141 */ + call testBothWays_UTF_8("帤", "", "delta") /* u+03B4, u+0394 */ + call testBothWays_UTF_8("", "虼", "Cyrillic_sha") /* u+0448, u+0428 */ + + /* special cases */ +/* + Special handling of Greek lower sigma is not implemented + Currently lifelines uses Unicode character properties + from UnicodeDataExcerpt.txt +*/ +/* call testBothWays_UTF_8("帢", "峉峉", "Greek sas") */ + + /* TODO: add German special case when implemented */ + + call reportSubsection("string UTF-8 tests") +} + +proc testBothWays_UTF_8(slo, shi, sname) +{ + if (ne(upper(slo), shi)) { + call reportfail(concat("upper(", sname, ") FAILED")) + } + else { incr(testok) } + + if (ne(lower(shi), slo)) { + call reportfail(concat("lower(", sname, ") FAILED")) + } + else { incr(testok) } +} diff --git a/reports/st/st_table.li b/reports/st/st_table.li new file mode 100644 index 0000000..9345fe0 --- /dev/null +++ b/reports/st/st_table.li @@ -0,0 +1,83 @@ +/* + * @progname st_table.li + * @version 1.0 (2005-02-01) + * @author Perry Rapp + * @category self-test + * @output none + * @description validate table functions +*/ + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call testTables() +} + +/* + test some table functions + */ +proc testTables() +{ + call initSubsection() + + table(tbl) +/* empty table tests */ + if (not(empty(tbl))) { + call reportfail("empty FAILED") + } + else { incr(testok) } + if (ne(length(tbl), 0)) { + call reportfail("length(table)==0 FAILED") + } + else { incr(testok) } +/* single element table tests */ + insert(tbl, "alpha", 1) + if (empty(tbl)) { + call reportfail("not empty FAILED") + } + else { incr(testok) } + set(el, lookup(tbl, "alpha")) + if (ne(el, 1)) { + call reportfail("lookup(alpha) FAILED") + } + else { incr(testok) } + if (ne(length(tbl), 1)) { + call reportfail("length(table)==1 FAILED") + } + else { incr(testok) } + insert(tbl, "alpha", 2) + set(el, lookup(tbl, "alpha")) + if (ne(el, 2)) { + call reportfail("lookup(alpha) FAILED") + } + else { incr(testok) } + if (ne(length(tbl), 1)) { + call reportfail("length(table)==1 FAILED") + } + else { incr(testok) } +/* two element table tests */ + insert(tbl, "bravo", 2) + if (ne(length(tbl), 2)) { + call reportfail("length(table)==2 FAILED") + } + else { incr(testok) } + + call testFreeTable(tbl) + + call reportSubsection("table tests") +} + +proc testFreeTable(tbl) +{ + free(tbl) + if (ne(tbl, 0)) { + call reportfail("free table FAILED") + } + else { incr(testok) } +} diff --git a/reports/st/st_trig.li b/reports/st/st_trig.li new file mode 100644 index 0000000..8329794 --- /dev/null +++ b/reports/st/st_trig.li @@ -0,0 +1,58 @@ +/* + * @progname st_trig.li + * @version 0.9 (2008-01-05) + * @author Perry Rapp + * @category self-test + * @output none + * @description validate trig functions +*/ + +char_encoding("ASCII") + +require("lifelines-reports.version:1.3") +option("explicitvars") /* Disallow use of undefined variables */ +include("st_aux") + +/* entry point in case not invoked via st_all.ll */ +proc main() +{ + call testTrig() +} + +/* + return true if values match to specified deviation + */ +func matchx(val1, val2, dev) +{ + if (or(gt(val1, add(val2, dev)), gt(val2, add(val1, dev)))) { + return(0) + } else { + return(1) + } +} +/* + test some list functions + */ +proc testTrig() +{ + call initSubsection() + + if (not(matchx(sin(45), 0.7071, 0.0001))) { + call reportfail("sin(45) FAILED") + } else { incr(testok) } + if (not(matchx(cos(45), 0.7071, 0.0001))) { + call reportfail("cos(45) FAILED") + } else { incr(testok) } + if (not(matchx(tan(45), 1.0, 0.0001))) { + call reportfail("tan(45) FAILED") + } else { incr(testok) } + + if (not(matchx(sin(0), 0, 0.0001))) { + call reportfail("sin(0) FAILED") + } else { incr(testok) } + if (not(matchx(cos(0), 1, 0.0001))) { + call reportfail("cos(0) FAILED") + } else { incr(testok) } + + call reportSubsection("trig tests") +} diff --git a/reports/st/test_fam_it.ll b/reports/st/test_fam_it.ll new file mode 100644 index 0000000..5f5be82 --- /dev/null +++ b/reports/st/test_fam_it.ll @@ -0,0 +1,28 @@ +/* + * @progname test_fam_it + * @version 1 + * @author Stephen Dum + * @category self-test + * @output text + * @description + * + * test family iterators: forfam, children and spouses + * Iterate over some data, printing results, so we can + * compare the output with exected results. + */ + + +proc main() { + print(nl()) + forfam(f,c) { + print(d(c),": ",key(f),nl()) + print(" children\n") + children(f,i,c2) { + print(" ",d(c2),": ",key(i),nl()) + } + print(" spouses\n") + spouses(f,s,c2) { + print(" ",d(c2),": ",key(s),nl()) + } + } +} diff --git a/reports/st/test_fam_it.ref b/reports/st/test_fam_it.ref new file mode 100644 index 0000000..abe3bc4 --- /dev/null +++ b/reports/st/test_fam_it.ref @@ -0,0 +1,27 @@ +Program is running... +1: F1 + children + 1: I1 + 2: I4 + spouses + 1: I2 + 2: I3 +2: F2 + children + 1: I11 + spouses + 1: I6 + 2: I7 + 3: I9 +3: F5 + children + spouses + 1: I10 + 2: I11 +4: F7 + children + 1: I2 + spouses + 1: I12 + 2: I11 +Program was run successfully. diff --git a/reports/st/test_forfam.ll b/reports/st/test_forfam.ll new file mode 100644 index 0000000..153a595 --- /dev/null +++ b/reports/st/test_forfam.ll @@ -0,0 +1,16 @@ +/* + * @progname test_forfam_it + * @version 1 + * @author Stephen Dum + * @category self-test + * @output text + * @description + * + * test family iterator: forfam + * Iterate over some data, printing results, so we can + * compare the output with exected results. + */ +proc main() { + print(nl()) + forfam(f,c) { print(d(c),": ",key(f),nl()) } +} diff --git a/reports/st/test_forfam.ref b/reports/st/test_forfam.ref new file mode 100644 index 0000000..435288d --- /dev/null +++ b/reports/st/test_forfam.ref @@ -0,0 +1,6 @@ +Program is running... +1: F1 +2: F2 +3: F5 +4: F7 +Program was run successfully. diff --git a/reports/st/test_forindi.ll b/reports/st/test_forindi.ll new file mode 100644 index 0000000..b0fb61e --- /dev/null +++ b/reports/st/test_forindi.ll @@ -0,0 +1,16 @@ +/* + * @progname test_forindi_it + * @version 1 + * @author Stephen Dum + * @category self-test + * @output text + * @description + * + * test indi iterator: forindi + * Iterate over some data, printing results, so we can + * compare the output with exected results. + */ +proc main() { + print(nl()) + forindi(i,c) { print(d(c),": ",key(i),nl()) } +} diff --git a/reports/st/test_forindi.ref b/reports/st/test_forindi.ref new file mode 100644 index 0000000..b0f64ae --- /dev/null +++ b/reports/st/test_forindi.ref @@ -0,0 +1,12 @@ +Program is running... +1: I1 +2: I2 +3: I3 +4: I4 +5: I6 +6: I7 +7: I9 +8: I10 +9: I11 +10: I12 +Program was run successfully. diff --git a/reports/st/test_indi_it.ll b/reports/st/test_indi_it.ll new file mode 100644 index 0000000..690ee47 --- /dev/null +++ b/reports/st/test_indi_it.ll @@ -0,0 +1,39 @@ +/* + * @progname test_indiit + * @version 1 + * @author Stephen Dum + * @category self-test + * @output text + * @description + * + * test indi iterators: forindi, Parents, families, spouses, mothers, fathers + * Iterate over some data, printing results, so we can + * compare the output with exected results. + */ + +proc main() { + print(nl()) + forindi(i,c) { + print(d(c),": ",key(i),nl()) + print(" Parents\n") + Parents(i,f,c2) { + print(" ",d(c2),": ",key(f),nl()) + } + print(" families\n") + families(i,f,s,c2) { + print(" ",d(c2),": ",key(f)," ",key(s),nl()) + } + print(" spouses\n") + spouses(i,s,f,c2) { + print(" ",d(c2),": ",key(s)," ",key(f),nl()) + } + print(" mothers\n") + mothers(i,m,f,c2) { + print(" ",d(c2),": ",key(m)," ",key(f),nl()) + } + print(" fathers\n") + fathers(i,fa,f,c2) { + print(" ",d(c2),": ",key(fa)," ",key(f),nl()) + } + } +} diff --git a/reports/st/test_indi_it.ref b/reports/st/test_indi_it.ref new file mode 100644 index 0000000..13d31db --- /dev/null +++ b/reports/st/test_indi_it.ref @@ -0,0 +1,93 @@ +Program is running... +1: I1 + Parents + 1: F1 + families + spouses + mothers + 1: I3 F1 + fathers + 1: I2 F1 +2: I2 + Parents + 1: F7 + families + 1: F1 I3 + spouses + 1: I3 F1 + mothers + 1: I12 F7 + fathers +3: I3 + Parents + families + 1: F1 I2 + spouses + 1: I2 F1 + mothers + fathers +4: I4 + Parents + 1: F1 + families + spouses + mothers + 1: I3 F1 + fathers + 1: I2 F1 +5: I6 + Parents + families + 1: F2 I7 + 2: F2 I9 + spouses + 1: I7 F2 + 2: I9 F2 + mothers + fathers +6: I7 + Parents + families + 1: F2 I6 + 2: F2 I9 + spouses + 1: I6 F2 + 2: I9 F2 + mothers + fathers +7: I9 + Parents + families + 1: F2 I6 + 2: F2 I7 + spouses + 1: I6 F2 + 2: I7 F2 + mothers + fathers +8: I10 + Parents + families + 1: F5 I11 + spouses + 1: I11 F5 + mothers + fathers +9: I11 + Parents + 1: F2 + families + 1: F5 I10 + spouses + 1: I10 F5 + mothers + 1: I7 F2 + fathers + 1: I6 F2 +10: I12 + Parents + families + spouses + mothers + fathers +Program was run successfully. diff --git a/reports/st/test_othr_it.ll b/reports/st/test_othr_it.ll new file mode 100644 index 0000000..e103e36 --- /dev/null +++ b/reports/st/test_othr_it.ll @@ -0,0 +1,27 @@ +/* + * @progname test_othr_it + * @version 1 + * @author Stephen Dum + * @category self-test + * @output text + * @description + * + * test iterators: forsour, foreven, forothr + * Iterate over some data, printing results, so we can + * compare the output with exected results. + */ +proc main() { + print(nl()) + print("forsour\n") + forsour(s,c) { + print(d(c),": ",key(s),nl()) + } + print("foreven\n") + foreven(e,c) { + print(d(c),": ",key(e),nl()) + } + print("forothr\n") + forothr(s,c) { + print(d(c),": ",key(s),nl()) + } +} diff --git a/reports/st/test_othr_it.ref b/reports/st/test_othr_it.ref new file mode 100644 index 0000000..eb5fa1a --- /dev/null +++ b/reports/st/test_othr_it.ref @@ -0,0 +1,11 @@ +Program is running... +forsour +1: S1 +2: S3 +foreven +1: E1 +2: E3 +forothr +1: X1 +2: X3 +Program was run successfully. diff --git a/reports/st/ti.ged b/reports/st/ti.ged new file mode 100644 index 0000000..a40ae05 --- /dev/null +++ b/reports/st/ti.ged @@ -0,0 +1,109 @@ +0 HEAD +1 SOUR LIFELINES 3.0.49 +1 DEST ANY +1 DATE 24 NOV 2005 +2 TIME 19:55 +1 SUBM +1 GEDC +2 VERS 5.5 +2 FORM LINEAGE-LINKED +1 CHAR ASCII +0 @E1@ EVEN +1 INDI +2 ROLE event +0 @E3@ EVEN +1 INDI +2 ROLE event2 +0 @F1@ FAM +1 HUSB @I2@ +1 WIFE @I3@ +1 MARR +2 DATE 15 Feb 1859 +2 PLAC +2 SOUR +1 CHIL @I1@ +1 CHIL @I4@ +0 @F2@ FAM +1 HUSB @I6@ +1 HUSB @I9@ +1 WIFE @I7@ +1 MARR +2 DATE +2 PLAC +2 SOUR +1 CHIL @I11@ +0 @F5@ FAM +1 HUSB @I10@ +1 WIFE @I11@ +0 @F7@ FAM +1 WIFE @I12@ +1 WIFE @I11@ +1 CHIL @I2@ +0 @I1@ INDI +1 NAME Johan Joseph /Schmidt/ +1 SEX M +1 BIRT +2 DATE 11 Oct 1860 +1 FAMC @F1@ +0 @I2@ INDI +1 NAME Johan /Schmidt/ +1 SEX M +1 BIRT +2 DATE EST 1829 +2 PLAC +1 DEAT +2 DATE 4 Sep 1885 +2 PLAC +1 SOUR +1 FAMC @F7@ +1 FAMS @F1@ +0 @I3@ INDI +1 NAME Maria Joseph /Saurborn/ +1 SEX F +1 BIRT +2 DATE 1 Aug 1826 +2 PLAC +1 DEAT +2 DATE +2 PLAC +1 SOUR +1 FAMS @F1@ +0 @I4@ INDI +1 NAME Henrich /Schmidt/ +1 SEX M +1 BIRT +2 DATE CAL 1900 +1 FAMC @F1@ +0 @I6@ INDI +1 NAME Belmont /Smith/ +1 SEX M +1 FAMS @F2@ +0 @I7@ INDI +1 NAME Charlene /Wilson/ +1 SEX F +1 FAMS @F2@ +0 @I9@ INDI +1 NAME Abraham /Belmont/ +1 SEX M +1 SOUR @S1@ +1 FAMS @F2@ +0 @S1@ SOUR +1 NOTE a source +0 @S3@ SOUR +1 NOTE another source +0 @X1@ NOTE +1 NOTE a note +0 @X3@ NOTE +1 NOTE another note +0 @I10@ INDI +1 NAME Abraham /Wilson/ +1 SEX M +1 FAMS @F5@ +0 @I11@ INDI +1 NAME Charlene /Smith/ +1 SEX F +1 FAMC @F2@ +1 FAMS @F5@ +0 @I12@ INDI +1 NAME Mary /Jones/ +0 TRLR diff --git a/reports/st/trigtest.ll b/reports/st/trigtest.ll new file mode 100644 index 0000000..c122c6c --- /dev/null +++ b/reports/st/trigtest.ll @@ -0,0 +1,139 @@ +/* + * @progname trigtest.ll + * @version 1.0 + * @author Matt Emmerton + * @category + * @output Text + * @description Tests functionality of trig-related functions. + * + * Test trig and spherical distance calculations + * + */ + +options("explicitvars") + +proc main() +{ + print("Simple Sine/Cosine/Tangent operations (degree->value)", nl()) + print(nl()) + + set(angle1,0) + set(angle2,45) + set(angle3a,89.99) + set(angle3b,90) + set(angle3c,90.01) + set(angle4,135) + set(angle5,180) + set(angle6,225) + set(angle7a,269.99) + set(angle7b,270) + set(angle7c,270.01) + set(angle8,315) + set(angle9,360) + + print("angle\tsin\tcos\ttan", nl()) + print(f(angle1), "\t", f(sin(angle1)), "\t", f(cos(angle1)), "\t", f(tan(angle1)), nl()) + print(f(angle2), "\t", f(sin(angle2)), "\t", f(cos(angle2)), "\t", f(tan(angle2)), nl()) + print(f(angle3a), "\t", f(sin(angle3a)), "\t", f(cos(angle3a)), "\t", f(tan(angle3a)), nl()) + print(f(angle3b), "\t", f(sin(angle3b)), "\t", f(cos(angle3b)), "\t", "N/A", nl()) + print(f(angle3c), "\t", f(sin(angle3c)), "\t", f(cos(angle3c)), "\t", f(tan(angle3c)), nl()) + print(f(angle4), "\t", f(sin(angle4)), "\t", f(cos(angle4)), "\t", f(tan(angle4)), nl()) + print(f(angle5), "\t", f(sin(angle5)), "\t", f(cos(angle5)), "\t", f(tan(angle5)), nl()) + print(f(angle6), "\t", f(sin(angle6)), "\t", f(cos(angle6)), "\t", f(tan(angle6)), nl()) + print(f(angle7a), "\t", f(sin(angle7a)), "\t", f(cos(angle7a)), "\t", f(tan(angle7a)), nl()) + print(f(angle7b), "\t", f(sin(angle7b)), "\t", f(cos(angle7b)), "\t", "N/A", nl()) + print(f(angle7c), "\t", f(sin(angle7c)), "\t", f(cos(angle7c)), "\t", f(tan(angle7c)), nl()) + print(f(angle8), "\t", f(sin(angle8)), "\t", f(cos(angle8)), "\t", f(tan(angle8)), nl()) + print(f(angle9), "\t", f(sin(angle9)), "\t", f(cos(angle9)), "\t", f(tan(angle9)), nl()) + print(nl()) + + print("Simple ArcSine/ArcCosine/ArcTangent operations (value->degree)", nl()) + print(nl()) + + set(value1,-1) + set(value2,-0.707) + set(value3,-0.3535) + set(value4,0.0) + set(value5,0.3535) + set(value6,0.707) + set(value7,1.0) + + print("value\tarcsin\tarccos\tarctan", nl()) + print(f(value1), "\t", f(arcsin(value1)), "\t", f(arccos(value1)), "\t", f(arctan(value1)), nl()) + print(f(value2), "\t", f(arcsin(value2)), "\t", f(arccos(value2)), "\t", f(arctan(value2)), nl()) + print(f(value3), "\t", f(arcsin(value3)), "\t", f(arccos(value3)), "\t", f(arctan(value3)), nl()) + print(f(value4), "\t", f(arcsin(value4)), "\t", f(arccos(value4)), "\t", f(arctan(value4)), nl()) + print(f(value5), "\t", f(arcsin(value5)), "\t", f(arccos(value5)), "\t", f(arctan(value5)), nl()) + print(f(value6), "\t", f(arcsin(value6)), "\t", f(arccos(value6)), "\t", f(arctan(value6)), nl()) + print(f(value7), "\t", f(arcsin(value7)), "\t", f(arccos(value7)), "\t", f(arctan(value7)), nl()) + print(nl()) + + print("Reflexive operations (arcOP(OP(degree)) == degree)", nl()) + print("NOTE: Due to the periodic nature of these functions, output degree values may be",nl()) + print("different than the input degree values.", nl()) + print("NOTE: Due to roundoff, values may be out by a value of one in the least significant place.", nl()) + print(nl()) + + print("angle\t\tarcsin(sin)\tarccos(cos)\tarctan(tan)", nl()) + print(f(angle1), "\t\t", f(arcsin(sin(angle1))), "\t\t", f(arccos(cos(angle1))), "\t\t", f(arctan(tan(angle1))), nl()) + print(f(angle2), "\t\t", f(arcsin(sin(angle2))), "\t\t", f(arccos(cos(angle2))), "\t\t", f(arctan(tan(angle2))), nl()) + print(f(angle3a), "\t\t", f(arcsin(sin(angle3a))), "\t\t", f(arccos(cos(angle3a))), "\t\t", f(arctan(tan(angle3a))), nl()) + print(f(angle3c), "\t\t", f(arcsin(sin(angle3c))), "\t\t", f(arccos(cos(angle3c))), "\t\t", f(arctan(tan(angle3c))), nl()) + print(f(angle4), "\t\t", f(arcsin(sin(angle4))), "\t\t", f(arccos(cos(angle4))), "\t\t", f(arctan(tan(angle4))), nl()) + print(f(angle5), "\t\t", f(arcsin(sin(angle5))), "\t\t", f(arccos(cos(angle5))), "\t\t", f(arctan(tan(angle5))), nl()) + print(f(angle6), "\t\t", f(arcsin(sin(angle6))), "\t\t", f(arccos(cos(angle6))), "\t\t", f(arctan(tan(angle6))), nl()) + print(f(angle7a), "\t\t", f(arcsin(sin(angle7a))), "\t\t", f(arccos(cos(angle7a))), "\t\t", f(arctan(tan(angle7a))), nl()) + print(f(angle7c), "\t\t", f(arcsin(sin(angle7c))), "\t\t", f(arccos(cos(angle7c))), "\t\t", f(arctan(tan(angle7c))), nl()) + print(f(angle8), "\t\t", f(arcsin(sin(angle8))), "\t\t", f(arccos(cos(angle8))), "\t\t", f(arctan(tan(angle8))), nl()) + print(f(angle9), "\t\t", f(arcsin(sin(angle9))), "\t\t", f(arccos(cos(angle9))), "\t\t", f(arctan(tan(angle9))), nl()) + print(nl()) + + print("Decimal Degrees to DMH Conversions", nl()) + print(nl()) + + set(deg1,44) + set(min1,17) + set(sec1,29) + + dms2deg(deg1,min1,sec1,dec1) + print(d(deg1), " degrees, ", d(min1), " minutes and ", d(sec1), " seconds = ", f(dec1), " degrees.", nl()) + + deg2dms(dec1,deg1,min1,sec1) + print(f(dec1), " degrees = ", d(deg1), " degrees, ", d(min1), " minutes and ", d(sec1), " seconds.", nl()) + print(nl()) + + print("Spherical Distance Calculations", nl()) + print(nl()) + + /* 43.410815 / 43^24'38" is my house (lat) */ + set(deg1,43) + set(min1,24) + set(sec1,38) + dms2deg(deg1,min1,sec1,dec1) + + /* -80.508982 / -80^30'32" is my house (lon) */ + set(deg2,-80) + set(min2,30) + set(sec2,32) + dms2deg(deg2,min2,sec2,dec2) + + /* 44.101825 / 44^06'06" is my cottage (lat) */ + set(deg3,44) + set(min3,06) + set(sec3,06) + dms2deg(deg3,min3,sec3,dec3) + + /* -81.721931 / -81^43'18" is my cottage (lon) */ + set(deg4,-81) + set(min4,43) + set(sec4,18) + dms2deg(deg4,min4,sec4,dec4) + + print("House Lat: ", d(deg1), " degrees, ", d(min1), " minutes and ", d(sec1), " seconds = ", f(dec1), " degrees.", nl()) + print("House Lon: ", d(deg2), " degrees, ", d(min2), " minutes and ", d(sec2), " seconds = ", f(dec2), " degrees.", nl()) + print("Cottage Lat: ", d(deg3), " degrees, ", d(min3), " minutes and ", d(sec3), " seconds = ", f(dec3), " degrees.", nl()) + print("Cottage Lon: ", d(deg4), " degrees, ", d(min4), " minutes and ", d(sec4), " seconds = ", f(dec4), " degrees.", nl()) + + print("House to Cottage: ", f(spdist(dec1,dec2,dec3,dec4)), nl()) + print("House to Cottage (via roads, suggested by Google Maps: ", f(138.2)) +} diff --git a/reports/st/trigtest.ref b/reports/st/trigtest.ref new file mode 100644 index 0000000..06a9172 --- /dev/null +++ b/reports/st/trigtest.ref @@ -0,0 +1,59 @@ +Program is running...Simple Sine/Cosine/Tangent operations (degree->value) + +angle sin cos tan +0.00 0.00 1.00 0.00 +45.00 0.71 0.71 1.00 +89.99 1.00 0.00 5728.35 +90.00 1.00 0.00 N/A +90.01 1.00 -0.00 -5728.35 +135.00 0.71 -0.71 -1.00 +180.00 0.00 -1.00 -0.00 +225.00 -0.71 -0.71 1.00 +269.99 -1.00 -0.00 5723.99 +270.00 -1.00 -0.00 N/A +270.01 -1.00 0.00 -5723.99 +315.00 -0.71 0.71 -1.00 +360.00 0.00 1.00 0.00 + +Simple ArcSine/ArcCosine/ArcTangent operations (value->degree) + +value arcsin arccos arctan +-1.00 -90.00 180.00 -45.00 +-0.71 -44.99 134.99 -35.26 +-0.35 -20.70 110.70 -19.47 +0.00 0.00 90.00 0.00 +0.35 20.70 69.30 19.47 +0.71 44.99 45.01 35.26 +1.00 90.00 0.00 45.00 + +Reflexive operations (arcOP(OP(degree)) == degree) +NOTE: Due to the periodic nature of these functions, output degree values may be +different than the input degree values. +NOTE: Due to roundoff, values may be out by a value of one in the least significant place. + +angle arcsin(sin) arccos(cos) arctan(tan) +0.00 0.00 0.00 0.00 +45.00 45.00 45.00 45.00 +89.99 90.00 89.99 89.99 +90.01 90.00 90.01 -89.99 +135.00 45.00 135.00 -45.00 +180.00 0.00 180.00 -0.00 +225.00 -45.00 135.00 45.00 +269.99 -90.00 90.01 89.99 +270.01 -90.00 89.99 -89.99 +315.00 -45.00 45.00 -45.00 +360.00 0.00 0.00 0.00 + +Decimal Degrees to DMH Conversions + +44 degrees, 17 minutes and 29 seconds = 44.29 degrees. +44.29 degrees = 44 degrees, 17 minutes and 29 seconds. + +Spherical Distance Calculations + +House Lat: 43 degrees, 24 minutes and 38 seconds = 43.41 degrees. +House Lon: -80 degrees, 30 minutes and 32 seconds = -80.51 degrees. +Cottage Lat: 44 degrees, 6 minutes and 6 seconds = 44.10 degrees. +Cottage Lon: -81 degrees, 43 minutes and 18 seconds = -81.72 degrees. +House to Cottage: 124.24 +House to Cottage (via roads, suggested by Google Maps: 138.20Program was run successfully. diff --git a/reports/stats.ll b/reports/stats.ll new file mode 100644 index 0000000..28a103f --- /dev/null +++ b/reports/stats.ll @@ -0,0 +1,766 @@ +/* + * @progname stats.ll + * @version 10.0 + * @author Jim Eggert + * @category + * @output Text + * @description Compute statistics on dates, ages, counts in the DB. + +This LifeLines report program computes mean statistics of various +quantities binned over other quantities. The quantities it knows +about are ages at and dates of birth, christening, first and last +marriage, first and last child's birth, death, burial, and today; the +number of children, siblings, and marriages; and sex, surname, first +name, soundex, and any simple GEDCOM tag. These can be combined +nearly arbitrarily and evaluated over the whole database, or +restricted to ancestors or descendants of a chosen individual or to +members of a predetermined set. Further restrictions on the +individuals included in the statistics can be based on any quantity +that the program knows about. The program will optionally print out +the names of all the individuals included in the statistics. + +For example, you can produce statistics of + the age at death of as a function of birth year, + dage vs byear + the number of children of females named Smith as a + function of year of first marriage, + kids vs myear | sex = F & surname = Smith + the number of spouses for male vs female blacksmiths, + families vs sex | occu = blacksmith + the age at last childbirth as a function of place of marriage. + qage vs mplace + the names of all Joneses who lived to be greater than 80 + unity vs unity | surname = Jones & dage > 80 +All this without writing any programs of your own. + +If a particular statistic for an individual is unavailable, and if the +global variable not_strict is nonzero (as it is in the distribution +version of this report, then certain guesses are allowed as to the +value of that statistic. So far, these guesses are few. Birth year +and month are guessed from baptismal date, and death year and month +are guessed from burial date. + +The user is prompted for what quantity to plot vs what to bin over. +Each is to be given as a specification string of the form + e