/*
**  ps-anc3, 1 December 1995, by Dennis Nicklaus (nicklaus@wishep.physics.wisc.edu)
**  this contains my improvements to:
**  ps-anc2, 16 August 1994, by Fred Wheeler (wheeler@ipl.rpi.edu)
**  
**  GETTING THIS FILE
**  
**  This file is available via anonymous ftp from ftp.cac.psu.edu
**  All the comments below are by the original ps-anc2 author,
**  except for the CHANGES I have noted.  Dennis Nicklaus.
**  
**  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 supress 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 of 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
**    Tabs converted to spaces and all lines made < 80 chars
**
**  CHANGES BY Dennis Nicklaus (nicklaus@wishep.physics.wisc.edu) 1995
**  1. Added additional date/place styles
**  2. Added ability to put birth & death info on same line as name
**     or separate lines, or same line, separate from name.         
**  3. Like Gedchart does, ps-anc3 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.
**
**  4. ps-anc2 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.
**  5. I changed the placement algorithm slightly to conserve a little
**     vertical space so more people can squeeze onto a page (desc. charts).
**     See the generation_height variable.

**  CREDITS
**
**  Code improvements recieved from:
**    Vincent Broman (broman@Np.nosc.mil)
**
**  Helpful comments recieved 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
**

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

global (high_pos_gen)     /* array, highest so far in each generation */
global (high_pos_all)     /* highest position so far for any generation */

global (name_height)      /* height of name text on chart */
global (generation_height) /* space from parent to child on desc. chart */
global (last_child_pos)   /* place where last child was enqueued 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 */
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)   /* gedchart tagged notes */

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

/*
**  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, 3)
  }

/*
**  QUESTION: How many lines per person.
*/
  if (1)  {
    getintmsg (all_same_line,
               "birth & death lines: 0=Sep.;1= with name;2= same line,name sep.")
  }  else  {
    set (all_same_line, 1)
  }

/*
**  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, 999)
    }

  }

/*
**  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 (0)  {
    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 (1)  {
    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, 4)
    set (dateplace_death, 4)
    set (dateplace_marriage, 4)
  }

/*
**  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 ()
      "showpage" nl()

      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: 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, "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)
{

  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 (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 
	  }
  }
  ")"

  if(eq(all_same_line,0)){
	  /* print birth date, if it exists */
	  call dateplace (birth (person), dateplace_birth)
	  if (dateplace_return)  {
	    " (b. " dateplace_return ")"
	  }  else  {
	    " ()"
	  }
  }
  else{
    " ("
    if(eq(all_same_line,2)){
      call dateplace (birth (person), dateplace_birth)
      if (dateplace_return)  {
	    "b. " dateplace_return 
      }
      call dateplace (death (person), dateplace_death)
      if (dateplace_return)  {
	 " d. " dateplace_return 
      }
    }
    ")"
  }
  /* print marriage date, if it exists */
  if (mdate)  {
    " (m. " mdate ")"
  }  else  {
    " ()"
  }


  " ("
  if (noteprint)  { /* make sure it exists */
	noteprint
  }
  ")"

  if(eq(all_same_line,0)){
	  /* print death date, if it exists */
	  call dateplace (death (person), dateplace_death)
	  if (dateplace_return)  {
	    " (d. " dateplace_return ")"
	  }  else  {
	    " ()"
	  }
  }
  else{
   "()"
  }

  /* print generation, 0=youngest */
  " " d (sub (depth, 1))

  /* print vertical position */
  " " call print_thousandths (pos)

  /* extra height, not used or understood */
  " 1"

  /* 1=direct ancestor, 0=sibling */
  " " d (line)

  /* duplicate individual, not used */
  " 0"

  /* call postscript function to process and print this data */
  " i"

  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)
{
  d (sub (depth, 1))
  " " call print_thousandths (low)
  " " call print_thousandths (high)
  " l" nl()
}

/*
**  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 (div (n, 1000)) "."
  set(wholepart,mul(div (n, 1000),1000))
  set(fracpart,sub(n,wholepart))

  set (t, d (mod (n, 1000)))
  if (eq (strlen (t), 1))  {
    "00" t
  }
  if (eq (strlen (t), 2))  {
    "0" t
  }
  if (eq (strlen (t), 3))  {
    t
  }

}

/*
**  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)
{
  "%!PS-Adobe-2.0 EPSF-1.2" nl()
  "%%BoundingBox:0 0 612 792" nl()
  "/#copies 1 def" nl()
  "/xpages " d (xn) " def" nl()
  "/ypages " d (yn) " def" nl()
  "/xpage " d (xi) " def" nl()
  "/ypage " d (yi) " def" nl()
  "/maxlevel " d (ml) " def" nl()
  "/mirror false def" nl()
  "/maxpos " call print_thousandths (mp)  nl()
  "0.02 ypages div 1.0 add mul def" nl()
  "/color " ctf " def" nl()
  "/bold false def" nl()
  "/indent 3.00 def" nl()
  "/linwidf 1.000 def" nl()
  "/font_adjust 1.000 def" nl()
  "/offset_name 0.000 def" nl()
  "% Put PostScript code here to print a label on the chart" nl()
  "/inch {72 mul} def" nl()
  "/chart_label {" nl()
  "  .15 inch .15 inch moveto" nl()
  "  fontname findfont 7 scalefont setfont" nl()
  "  (" cl ") show" nl()
  "} def" 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()
  "/lmr 0 def /lmg 1 def /lmb 1 def" nl()
  "/Lmr 0 def /Lmg 0 def /Lmb 1 def" nl()
  "/tmr 0 def /tmg 0 def /tmb 0 def" nl()
  "/Tmr 0 def /Tmg 0 def /Tmb 0 def" nl()
  "/fontname /" fn " def" nl()
  "/encvec [" nl()
  "16#80 /Ccedilla" nl()
  "16#81 /udieresis" nl()
  "16#82 /eacute" nl()
  "16#83 /acircumflex" nl()
  "16#84 /adieresis" nl()
  "16#85 /agrave" nl()
  "16#86 /aring" nl()
  "16#87 /ccedilla" nl()
  "16#88 /ecircumflex" nl()
  "16#89 /edieresis" nl()
  "16#8a /egrave" nl()
  "16#8b /idieresis" nl()
  "16#8c /icircumflex" nl()
  "16#8d /igrave" nl()
  "16#8e /Adieresis" nl()
  "16#8f /Aring" nl()
  "16#90 /Eacute" nl()
  "16#91 /ae" nl()
  "16#92 /AE" nl()
  "16#93 /ocircumflex" nl()
  "16#94 /odieresis" nl()
  "16#95 /ograve" nl()
  "16#96 /ucircumflex" nl()
  "16#97 /ugrave" nl()
  "16#98 /ydieresis" nl()
  "16#99 /Odieresis" nl()
  "16#9a /Udieresis" nl()
  "16#9b /cent" nl()
  "16#9c /sterling" nl()
  "16#9d /yen" nl()
  "16#9f /florin" nl()
  "16#a0 /aacute" nl()
  "16#a1 /iacute" nl()
  "16#a2 /oacute" nl()
  "16#a3 /uacute" nl()
  "16#a4 /ntilde" nl()
  "16#a5 /Ntilde" nl()
  "16#a6 /ordfeminine" nl()
  "16#a7 /ordmasculine" nl()
  "16#a8 /questiondown" nl()
  "16#aa /logicalnot" nl()
  "16#ab /onehalf" nl()
  "16#ac /onequarter" nl()
  "16#ad /exclamdown" nl()
  "16#ae /guillemotleft" nl()
  "16#af /guillemotright" nl()
  "16#f8 /degree" nl()
  "16#f9 /bullet" nl()
  "16#fa /periodcentered" nl()
  "] def" nl()
  "% Copyright (c) 1991-1993 Thomas P. Blumer." nl()
  "% All Rights Reserved." nl()
  "% Permission granted to use in LifeLines report generation." nl()
  "/border true def" nl()
  nl()
  "color {" 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" nl()
  "    /textcolr1 {tr tg tb tk setcmykcolor} bind def" nl()
  "    /lincolr0 {Lr Lg Lb Lk setcmykcolor} bind def" nl()
  "    /lincolr1 {lr lg lb lk setcmykcolor} bind def" nl()
  "  } {" nl()
  "    /textcolr0 {Tr Tg Tb setrgbcolor} bind def" nl()
  "    /textcolr1 {tr tg tb setrgbcolor} bind def" nl()
  "    /lincolr0 {Lr Lg Lb setrgbcolor} bind def" nl()
  "    /lincolr1 {lr lg lb setrgbcolor} bind def" nl()
  "  } ifelse" nl()
  "} {" nl()
  "  /textcolr0 {} bind def" nl()
  "  /textcolr1 {} bind def" nl()
  "  /lincolr0 {} bind def" nl()
  "  /lincolr1 {} bind def" nl()
  "} ifelse" nl()
  nl()
  "% table of how to get bold fonts" nl()
  "/bolddict 25 dict def" nl()
  "bolddict begin" nl()
  nl()
  "% default table entry is that boldfontname = fontname" nl()
  "fontname fontname def" nl()
  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-Oblique /Helvetica-BoldOblique def" nl()
  "/Bookman-Light /Bookman-Demi def" nl()
  "/Bookman-LightItalic /Bookman-DemiItalic def" nl()
  "/Palatino-Roman /Palatino-Bold def" nl()
  "/Palatino-Italic /Palatino-BoldItalic def" nl()
  "/AvantGarde-Book /AvantGarde-Demi def" nl()
  "/AvantGarde-BookOblique /AvantGarde-DemiOblique def" nl()
  "/Helvetica-Narrow /Helvetica-Narrow-Bold def" nl()
  "/Helvetica-Narrow-Oblique /Helvetica-Narrow-BoldOblique def" nl()
  "/Helvetica-Condensed /Helvetica-Condensed-Bold def" nl()
  "/Helvetica-Condensed-Oblique /Helvetica-Condensed-BoldObl def" nl()
  "/NewCenturySchlbk-Roman /NewCenturySchlbk-Bold def" nl()
  "/NewCenturySchlbk-Italic /NewCenturySchlbk-BoldItalic def" nl()
  "/ZapfChancery /ZapfChancery-Bold def" nl()
  "end" nl()
  nl()
  "/boldfontname fontname def" nl()
  "/boldfontname bolddict fontname get def" nl()
  nl()
  "% get printable area" nl()
  "clippath pathbbox newpath" nl()
  "/ury exch def /urx exch def" nl()
  "/lly exch def /llx exch def" nl()
  nl()
  "% 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()
  "% set portrait mode, get width and height" nl()
  "/wp urx llx sub def" nl()
  "/hp ury lly sub def" nl()
  "/w wp xpages mul def" nl()
  "/h hp ypages mul def" nl()
  "wp hp lt {" nl()
  "  % portrait mode" nl()
  "  llx lly translate" nl()
  "} {" nl()
  "  % landscape mode" nl()
  "   /tmp hp def" nl()
  "  /hp wp def" nl()
  "  /wp tmp def" nl()
  "   /tmp h def" nl()
  "  /h w def" nl()
  "  /w tmp def" nl()
  "  urx lly translate 90 rotate" nl()
  "} ifelse" nl()
  nl()
  "% multi page output" nl()
  "xpages 1 ne ypages 1 ne or {" nl()
  "  1 xpage sub wp mul  1 ypage sub hp mul  translate" nl()
  "} if" nl()
  nl()
  "% decorative border" nl()
  "border {" nl()
  "  /bwid1 2.5 def" nl()
  "  /gapwid 1.5 def" nl()
  "  /bwid2 0.7 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()
  nl()
  "  bwid1 setlinewidth" nl()
  "  lincolr0" nl()
  "  bwid1 2 div  dup  w bwid1 sub  h bwid1 sub  rect" nl()
  nl()
  "  bwid2 setlinewidth" nl()
  "  bwid1 gapwid bwid2 2 div add add  dup" nl()
  "  w bwid1 2 mul sub gapwid 2 mul sub bwid2 sub " nl()
  "  h bwid1 2 mul sub gapwid 2 mul sub bwid2 sub rect" nl()
  nl()
  "  % cut the border out of the imageable area" nl()
  "  /tmp bwid1 gapwid bwid2 gapwid add add add def" nl()
  "  tmp tmp translate" nl()
  "  /w w tmp 2 mul sub def" nl()
  "  /h h tmp 2 mul sub def" nl()
  "} if" nl()
  nl()
  "% for multi page: only label bottom left page" nl()
  "/chart_label where xpage 1 eq ypage 1 eq and and {" nl()
  "  pop" nl()
  "  gsave" nl()
  "  % set up coordinate system for custom chart label" nl()
  "  clippath pathbbox newpath pop pop translate" nl()
  "  chart_label" nl()
  "  grestore" nl()
  "} if" nl()
  nl()
  "% Reencode the font for IBMPC set of international chars" nl()
  "/encdict 12 dict def" nl()
  "/reenc {" nl()
  "  encdict begin" nl()
  "  /newenc exch def" nl()
  "  /nfont exch def" nl()
  "  /ofont exch def" nl()
  "  /ofontdict ofont findfont def" nl()
  "  /newfont ofontdict maxlength 1 add dict def" nl()
  "  ofontdict {" nl()
  "    exch dup /FID ne {" nl()
  "      dup /Encoding eq" nl()
  "       {exch dup length array copy newfont 3 1 roll put}" nl()
  "       {exch newfont 3 1 roll put} ifelse" nl()
  "    }" nl()
  "    {pop pop}" nl()
  "    ifelse" nl()
  "  } forall" nl()
  "  newfont /Fontname nfont put" nl()
  "  newenc aload pop" nl()
  "  newenc length 2 idiv" nl()
  "  { newfont /Encoding get 3 1 roll put}" nl()
  "  repeat" nl()
  "  nfont newfont definefont pop" nl()
  "  end" nl()
  "} def" nl()
  nl()
  "fontname /gedfont encvec reenc" nl()
  "/fontname /gedfont def" nl()
  "% end font reencoding" nl()
  nl()
  "/rl w maxlevel div def" nl()
  "/posunit h maxpos div def" nl()
  nl()
  "/posname 1.0 def" nl()
  "/posdate 0.75 def" nl()
  "/posmarg 0.3 def" nl()
  "/posbase posname posmarg 2 div add def" nl()
  nl()
  "/top h posunit posbase mul sub def" nl()
  nl()
  "% calculate base font size from segment length" nl()
  "/fntsize rl 9.0 div def" nl()
  nl()
  "% space for one individual" nl()
  "fntsize posunit gt {" nl()
  "  /fntsize posunit def" nl()
  "} if" nl()
  nl()
  "% font adjustment" nl()
  "/fntsize fntsize font_adjust mul def" nl()
  nl()
  "% font for birth/death dates" nl()
  "/fntsize2 fntsize posdate mul def" nl()
  nl()
  "fontname findfont fntsize scalefont setfont" nl()
  "/space ( ) stringwidth pop def" nl()
  nl()
  "% calc line width from segment length - .24 pts = 1 pixel" nl()
  "/linwid fntsize .1 mul .6 mul def" nl()
  "/linwid linwid linwidf mul def" nl()
  "linwid setlinewidth" nl()
  "/namey0 linwid fntsize 16.0 div add offset_name add def" nl()
  nl()
  "/dashwid rl 72 div def" nl()
  nl()
  "2 setlinecap" nl()
  nl()
  "% name string length for all generations" nl()
  "/len1 rl space indent 1 add mul sub def" nl()
  nl()
  "% show string given as argument" nl()
  "% select font size so that string fits in available length" nl()
  "/wshow {" nl()
  "  /s exch def" nl()
  "  /len exch def" nl()
  "  /fntsiz exch def" nl()
  "  bold direct and {" nl()
  "    boldfontname findfont fntsiz scalefont setfont" nl()
  "  } {" nl()
  "    fontname findfont fntsiz scalefont setfont" nl()
  "  } ifelse" nl()
  "  s stringwidth pop dup len lt {" nl()
  "    pop" nl()
  "  } {" nl()
  "    % compute new font size for exact fit" nl()
  "    len exch div fntsiz mul /fsize exch def" nl()
  "    bold direct and {" nl()
  "      boldfontname findfont fsize scalefont setfont" nl()
  "    } {" nl()
  "      fontname findfont fsize scalefont setfont" nl()
  "    } ifelse" nl()
  "  } ifelse" nl()
  "  direct {textcolr0} {textcolr1} ifelse" nl()
  "  s show" nl()
  "} bind def" nl()
  nl()
  "% called once for each individual on chart" nl()
  "/i {" nl()
  "  /duplic exch 1 eq def  % true for duplicate individual" nl()
  "  /direct exch 1 eq def  % true for direct ancestor" nl()
  "  /xhgt exch def         % extra height - not used here" nl()
  "  /pos exch def          % vertical position" nl()
  "  /level exch def        % generation level, 0 = youngest" nl()
  "  /marriage exch def     % marriage date" nl()
  "  /tagnote exch def      % tagged note from PAF" nl()
  "  /death exch def        % death date" nl()
  "  /birth exch def        % birth date" nl()
  "  /name exch def         % name" nl()
  nl()
  "  % x1 = left edge, x2 = right edge" nl()
  "  mirror {" nl()
  "    /x1 maxlevel level sub 1 sub rl mul def" nl()
  "    /x x1 space add def" nl()
  "  } {" nl()
  "    /x1 level rl mul def" nl()
  "    /x x1 space indent mul add def" nl()
  "  } ifelse" nl()
  "  /x2 x1 rl add def" nl()
  nl()
  "  /y top pos posunit mul sub def" nl()
  nl()
  "  direct {lincolr0} {lincolr1} ifelse" nl()
  nl()
  "  /namey namey0 def" nl()
  "  direct {" nl()
  "    bold {linwid 2.0 mul setlinewidth" nl()
  "          /namey namey linwid add def} if" nl()
  "    duplic {[dashwid dup currentlinewidth add] 0 setdash} if" nl()
  "    x1 y moveto x2 y lineto stroke" nl()
  "    duplic {[] 0 setdash} if" nl()
  "    bold {linwid setlinewidth} if" nl()
  "  } {" nl()
  "    duplic {[dashwid dup currentlinewidth add] 0 setdash} if" nl()
  "    mirror {" nl()
  "      x1 y moveto x2 space indent mul sub y lineto stroke" nl()
  "    } {" nl()
  "      x y moveto x2 y lineto stroke" nl()
  "    } ifelse" nl()
  "    duplic {[] 0 setdash} if" nl()
  "  } ifelse" nl()
  nl()
  "  % print name, birth date, death date" nl()
  "  x y namey add moveto" nl()
  "  fntsize len1 name wshow" nl()
  nl()
  "  birth length 0 gt {" nl()
  "    /y y fntsize2 sub def" nl()
  "    x y moveto" nl()
  "    fntsize2 len1 birth wshow" nl()
  "  } if" nl()
  "  death length 0 gt {" nl()
  "    /y y fntsize2 sub def" nl()
  "    x y moveto" nl()
  "    fntsize2 len1 death wshow" nl()
  "  } if" nl()
  "  tagnote length 0 gt {" nl()
  "    /y y fntsize2 sub def" nl()
  "    x y moveto" nl()
  "    fntsize2 len1 tagnote wshow" nl()
  "  } if" nl()
  "  marriage length 0 gt {" nl()
  "    /y y fntsize2 sub def" nl()
  "    x y moveto" nl()
  "    fntsize2 len1 marriage wshow" nl()
  "  } if" nl()
  "} bind def" nl()
  nl()
  "/l {" nl()
  "  /parent exch def" nl()
  "  /pos exch def" nl()
  "  /level exch def" nl()
  nl()
  "  mirror {" nl()
  "    /x maxlevel level sub 1 sub rl mul def" nl()
  "  } {" nl()
  "    /x level 1 add rl mul def" nl()
  "  } ifelse" nl()
  "  /y1 top pos posunit mul sub def" nl()
  "  /y2 top parent posunit mul sub def" nl()
  "  lincolr0" nl()
  "  bold {linwid 2.0 mul setlinewidth} if" nl()
  "  x y1 moveto x y2 lineto stroke" nl()
  "  bold {linwid setlinewidth} if" nl()
  "} bind def" nl()
}