/*
@(#) chartrep 1.37 LifeLines report program 95/07/10 21:46:36 @(#)
Copyright \(co 1995 by John S. Quarterman <jsq@tic.com>

This report generator produces input for the chart program,
which draws descendant charts in PostScript.
It detects intermarriages and prints each person only once.
The user may select a certain number of generations, or all.

*/

global(gens)
global(oneline)
global(doplaces)
global(dosnt)
global(dosources)
global(donotes)
global(dotext)
global(mainpre)
global(indentpre)
global(lastlevel)

global(perseen)
global(spouseseen)
global(perimar)
global(spouseimar)
global(marprinted)
global(spouseprinted)

global(cancont)
global(nsour)
global(dobb)
global(doevent)
global(isfound)
global(gotnode)

proc main () {
	table(perseen)
	table(spouseseen)
	table(perimar)
	table(spouseimar)
	table(marprinted)
	table(spouseprinted)
	set(nm, 0)
	while(not(nm)) {
		getindi(nm)		/* get individual */
	}
	getintmsg (gens, "How many generations (0 for all)?")
	getintmsg (oneline, "One line per person (0 for no, 1 for yes)?")
	call dosetplaces()
	call dosetnotes()
	set(cancont, 0)
	set(nsour, 0)
	monthformat(4)
	set(mainpre, "  ")
	set(indentpre, "   ")
	set(lastlevel, 0)
	call printtitle(nm)
	call seeper(nm, 1)
	call marry(nm, 1)
	call dofam(nm,"",1)	/* start with first person */
}

proc dosetplaces() {
	set(doplaces, 0) set(dobb, 0) set(doevent, 0)
	getstrmsg (g,
	"Dates plus (any of p for PLAC; b for CHR, BAPT, BURI; e for EVEN)?")
	if (index(g, "1", 1)) { set(doplaces, 1) }	/* backwards compat. */
	if (index(g, "p", 1)) { set(doplaces, 1) }
	if (index(g, "c", 1)) { set(dobb, 1) }	/* probable user typo */
	if (index(g, "b", 1)) { set(dobb, 1) }
	if (index(g, "e", 1)) { set(doevent, 1) }
}

proc dosetnotes() {
	set(dosnt, 0)
	set(dosources, 0) set(donotes, 0) set(dotext, 0)
	getstrmsg (s,
	"Print other (any of s for SOUR; n for NOTE; t for TEXT)?")
	if(index(s, "s", 1)) { set(dosources, 1) set(dosnt, 1) }
	if(index(s, "n", 1)) { set(donotes, 1) set(dosnt, 1) }
	if(index(s, "t", 1)) { set(dotext, 1) set(dosnt, 1) }
}

proc shortyp(e)
{
	if (dy, year(e)) { dy }
	else { if (dp, place(e)) { dp } }
	set(isfound, 1)
}

proc getbapt(nm) {
	traverse (inode(nm), node, nlev) {
		if(eqstr(tag(node), "BAPT")) {
			set(isfound, 1)
			set(gotnode, node)
			return()
		}
	}
}

/* Title of chart, based on ancestor's name. */
proc printtitle(nm) {
	"!"
	if (eq(gens, 0)) {
		"All "
	}
	"Descendants "
	if (ne(gens, 0)) {
		"to " capitalize(card(gens)) " Generations "
	}
	"of "
	if(title, title(nm)) {
		title " "
	}
	traverse (inode(nm), node, nlev) {
		if(eq(strcmp(tag(node), "TITLE"), 0)) {
			value(node) " "
		}
	}
	fullname(nm, 0, 1, 128)
	" ("
	set(isfound, 0)
	if (e, birth(nm)) { call shortyp(e) }
	if (eq(isfound, 0)) { if(e, baptism(nm)) { "bapt. " call shortyp(e) } }
	if (eq(isfound, 0)) { call getbapt(nm)
		if (ne(isfound, 0)) { "bapt. " call shortyp(gotnode) }
	}
	" - "
	set(isfound, 0)
	if (e, death(nm)) { call shortyp(e) }
	if (eq(isfound, 0)) { if(e, burial(nm)) { "buri. " call shortyp(e) } }
	")"
	traverse (inode(nm), node, nlev) {
		if(eq(strcmp(tag(node), "OCCU"), 0)) {
			", " value(node)
		}
	}
	nl()
}

proc seeper(nm,level) {
	insert(perseen, save(key(nm)), 1)
	if (or(eq(gens,0),le(level,gens))) {   /* enough generations? */
		set(level,add(level,1))
		families(nm, fam, spouse, num) {   /* do for each family */
			if (sk, key(spouse)) {
			        if (lookup(spouseseen, sk)) {
					insert(spouseimar, save(sk), 1)
				} else {
					insert(spouseseen, save(sk), 1)
				}
			}
			children(fam, child, num2) {   /* for each child ... */
				call seeper(child, level)
			}
		}
	}
}

proc marry(nm,level) {
        if (lookup(spouseseen, key(nm))) {
		insert(perimar, save(key(nm)), 1)
	}
	if (or(eq(gens,0),le(level,gens))) {   /* enough generations? */
		set(level,add(level,1))
		families(nm, fam, spouse, num) {   /* do for each family */
			children(fam, child, num2) {   /* for each child ... */
				call marry(child, level)
			}
		}
	}
}


/* 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) {
	set(pre,mainpre)
	set(newpre,concat(prefix,pre))
	nl()
	/* always print person as child */
	call printpers(nm,newpre,0,0,0)
	if (or(eq(gens,0),le(level,gens))) {   /* enough generations? */
		set(level,add(level,1))
		set(spousenum,1)
		families(nm, fam, spouse, num) {   /* do for each family */
	/* marriage record goes near first spouse printed */
			set(kf, key(fam))
		        if (not(lookup(marprinted, kf))) {
				call domar(newpre, nm, fam, spouse, spousenum)
			}
			set(spousenum,add(spousenum,1))
			if(ks, key(spouse)) {	/* spouse is known */
	/* if intermarriage, person is always printed as child, not spouse */
		        	if (not(lookup(perimar, ks))) {
	/* but spouse can marry more than one relative without being one */
			        	if (not(lookup(spouseprinted, ks))) {
        					if (lookup(spouseimar, ks)) {
							nl()
						}
						call printpers(spouse,newpre,1,nm,fam)
					}
					insert(spouseprinted, save(ks), 1)
				}
			}
	/* children go with the (first) marriage record, not the spouse */
		        if (not(lookup(marprinted, kf))) {
				call printchildren(fam, newpre, prefix, level)
			}
			insert(marprinted, save(kf), 1)
		}
	}
}


/* 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, isspouse, spouse, fam) {
	prefix "0 @" key(nm) "@ INDI" nl()
	prefix "1 NAME " fullname(nm,0,1,128) nl()
	prefix "1 SEX " sex(nm) nl()
	if (eq(isspouse, 1)) {
		prefix "1 FAMS @" key(fam) "@" nl()
	} else {
		prefix "1 FAMC @" key(parents(nm)) "@" nl()
	}
	prefix fullname(nm, 0, 1, 128)
	call nlornot("")
	set(isfound, 0)
	if(e, birth(nm)) { call doeven(prefix, "b. ", e) }
	if (or(eq(isfound, 0), dobb)) {
		if (e, baptism(nm)) { call doeven(prefix, "bapt. ", e) }
		if (eq(isfound, 0)) { call getbapt(nm)
			if (ne(isfound, 0)) {
				call doeven(prefix, "bapt. ", gotnode)
			}
		}
	}
	if (ne(isfound, 0)) { call nlornot("") }
	if (eq(doevent, 1)) {
		traverse (inode(nm), node, nlev) {
			if(eqstr(tag(node), "EVEN")) {
				set(savenote, donotes)
				set(savesnt, dosnt)
				set(donotes, 1)
				set(dosnt, 1)
				call doeven(prefix, "EVEN ", node)
				call nlornot("")
				set(donotes, savenote)
				set(dosnt, savesnt)
			}
		}
	}
	set(isfound, 0)
	if(e, death(nm)) { call doeven(prefix, "d. ", e) }
	if (or(eq(isfound, 0), dobb)) {
		if (e, burial(nm)) { call doeven(prefix, "buri. ", e) }
	}
	nl()
}

proc doeven(prefix, evenpre, e)
{ /* print("doeven\n") */
	if (eqstr(long(e), "")) { return() }
	prefix evenpre
	if (eq(1, doplaces)) { long(e) } else { date(e) }
	if (ne(0, dosnt)) { call printnote(prefix, e) }
	set(isfound, 1)
}

proc domar(newpre, nm, fam, spouse, spousenum)
{ /* print("domar\n") */
        if (lookup(spouseimar, key(spouse))) {
		nl()
	}
	if (eq(spousenum,1)) {
		if (eq(nspouses(nm), 1)) {
			nl() newpre "m. "
		} else {
			nl() newpre "m1 "
		}
	} else {
		nl() newpre "m" d(spousenum) " "
	}
	if(e, marriage(fam)) {
		if (eq(1, doplaces)) { long(e) } else { date(e) }
		if (ne(0, dosnt)) { call printnote(newpre, e) }
	}
	nl()
	newpre "0 @" key(fam) "@ FAM" nl()
	if (eq(strcmp(sex(nm), "M"), 0)) {
		newpre "1 HUSB @" key(nm) "@" nl()
		if (ks, key(spouse)) {
			newpre "1 WIFE @" ks "@" nl()
		}
	} else {
		newpre "1 WIFE @" key(nm) "@" nl()
		if (ks, key(spouse)) {
			newpre "1 HUSB @" ks "@" nl()
		}
	}
}

proc printchildren(fam, newpre, prefix, level)
{
	set(haschild, 0)
	children(fam, child, num2) {   /* for each child ... */
		if (eq(haschild, 0)) {
			nl()
			newpre "[" d(level) nl()
		}
		call dofam(child, /* ... call recursively */
			concat(prefix, indentpre),level)
		set(haschild,1)
	}
	if (eq(haschild, 1)) {
		nl()
		newpre "]" d(level) nl()
	}
}

proc nlornot(prefix) {
	if (ne(oneline, 1)) { nl() prefix }
	else { " " }
}

proc printnote(prefix, nm) {
/* print("printnote\n") */
	if (not(nm)) { return() }
	set(pntoplev, 100)
	traverse (nm, node, nlev) {
		if (eq(100, pntoplev)) {
			set(pntoplev, nlev)
		} else {
			if (le(nlev, pntoplev)) { return() }
		}
		set(ntag, tag(node))
		if (and(eq(1, cancont), eq(strcmp(ntag, "CONT"), 0))) {
			if (s, value(node)) { call nlornot(prefix) s }
					continue()
		}
		set(cancont, 0)
		if(eq(1, donotes)) {
			if(eq(strcmp(ntag, "NOTE"), 0)) {
				if (s, value(node)) {
					call nlornot(prefix) s
				}
				set(cancont, 1)
				continue()
			}
		}
		if(eq(1, dotext)) {
			if(eq(strcmp(ntag, "TEXT"), 0)) {
				if (s, value(node)) {
					call nlornot(prefix) s
				}
				set(cancont, 1)
				continue()
			}
		}
		if(eq(1, dosources)) {
			if(eq(strcmp(ntag, "SOUR"), 0)) {
				if (s, value(node)) {
					call nlornot(prefix)
					set(nsour,add(nsour, 1))
					"S" d(nsour) ". " s
				}
				set(cancont, 1)
				continue()
			}
		}
	}
}