home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / progs / geddump.icn < prev    next >
Text File  |  2000-07-29  |  3KB  |  124 lines
  1. ############################################################################
  2. #
  3. #    File:     geddump.icn
  4. #
  5. #    Subject:  Program to dump contents of GEDCOM file
  6. #
  7. #    Author:   Gregg M. Townsend
  8. #
  9. #    Date:     July 3, 1998
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #    usage:  geddump [file]
  18. #
  19. #    This program prints the genealogical information contained
  20. #    in a GEDCOM file.  Individuals are printed alphabetically,
  21. #    with sequence numbers to assist cross-referencing.
  22. #
  23. #    Marriages are noted for both partners.  Children are listed
  24. #    under the father, or under the mother if no father is known.
  25. #
  26. ############################################################################
  27. #
  28. #  Links:  gedcom
  29. #
  30. ############################################################################
  31.  
  32. link gedcom
  33.  
  34. record person(n, k, r)    # number, sort key, gedrec node
  35.  
  36.  
  37. global ptab        # person number table, indexed by gedrec node
  38.  
  39.  
  40. procedure main(args)
  41.    local f, g, i, n, p, r, plist, fam, husb, sp, b, d, byr, dyr
  42.  
  43.    if *args > 0 then
  44.       f := open(args[1]) | stop("can't open ", args[1])
  45.    else
  46.       f := &input
  47.  
  48.    g := gedload(f)
  49.    close(f)
  50.  
  51.    plist := []
  52.    ptab := table()
  53.    every r := !g.ind do
  54.       put(plist, ptab[r] := person(0, sortkey(r), r))
  55.  
  56.    plist := sortf(plist, 2)
  57.  
  58.    n := 0
  59.    every (!plist).n := (n +:= 1)
  60.  
  61.    every p := !plist do {
  62.       b := gedsub(p.r, "BIRT") | &null
  63.       d := gedsub(p.r, "DEAT") | &null
  64.  
  65.       write()
  66.       writes("[", p.n, "] ", gedlnf(p.r))
  67.       byr := gedyear(\b) | &null
  68.       dyr := gedyear(\d) | &null
  69.       if \byr | \dyr then 
  70.          writes("  (", byr, " - ", dyr, ")")
  71.       write()
  72.  
  73.       if fam := gedref(p.r, "FAMC") then {
  74.          refto("father", gedref(fam, "HUSB"))
  75.          refto("mother", gedref(fam, "WIFE"))
  76.          }
  77.  
  78.       event("b.", \b)
  79.  
  80.       r := &null
  81.       every fam := gedref(p.r, "FAMS") do {        # for every family
  82.          r := event("m.", gedsub(fam, "MARR"))
  83.          r := refto("  husb", p.r ~=== gedref(fam, "HUSB"))
  84.          r := refto("  wife", p.r ~=== gedref(fam, "WIFE"))
  85.          # if had earlier kids and did not indicate remarriage, do so now
  86.          if \r then
  87.             write("   m.")
  88.          # print children under husband, or under wife if no husband
  89.          if (p.r === gedref(fam, "HUSB")) | (not gedref(fam, "HUSB")) then {
  90.             every r := gedref(fam, "CHIL") do {
  91.                case (gedval(r, "SEX") | "") of {
  92.                   "M":        refto("   son", r)
  93.                   "F":        refto("   dau", r)
  94.                   default:    refto(" child", r)
  95.                   }
  96.                }
  97.             }
  98.          }
  99.  
  100.       event("d.", \d)
  101.       }
  102. end
  103.  
  104. procedure event(label, r)
  105.    local date, place
  106.  
  107.    date := ("" ~== geddate(r))
  108.    place := ("" ~== gedval(r, "PLAC"))
  109.    if /place then
  110.       write("   ", label, " ", \date)
  111.    else
  112.       write("   ", label, " ", \date | "            ", "  ", place)
  113.    return
  114. end
  115.  
  116. procedure refto(label, r)
  117.    write("   ", label, " [", ptab[r].n, "] ", gedfnf(r))
  118.    return
  119. end
  120.  
  121. procedure sortkey(r)
  122.    return map(gedlnf(r))
  123. end
  124.