kennethreitz/context
1
0
Fork 0
mirror of https://github.com/kennethreitz/context.git synced 2026-06-05 06:46:18 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
context/_reports/fami-grps.ll
T
kennethreitz d06e6ed40b reports
2019-09-28 10:14:18 -04:00

410 lines
9.1 KiB
LLVM
Raw Permalink Blame History

/*
* @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)))))
}
Reference in New Issue View Git Blame Copy Permalink