#!/usr/bin/perl -w

use strict;
use lib "$ENV{'HOME'}/lib/perl";
require 'http.pl';

use vars qw(%gChild %gMarriage %gParent %gPerson);

sub children ($$);
sub fmt ($$);
sub Main ();
sub name ($$);

my $opt_v = ($0 =~ /\/private\//);
my $dir = $ENV{'HOME'}.'/etc/genea/';
my $mod_time = (stat("${dir}person.db"))[9];
my $slfmt = '<br><font size="-1">%s</font>';
my $spfmt = q(<p><font size="-1">%s</font></p>);

Main;

# children $generation, $id
# 
# list descendants of person $id who is in generation $generation

sub children ($$) { my($generation, $id) = @_;
  my (%mData);
  my (@rows); # return value

  if (defined $gMarriage{$id}) {
    for my $s (split(/\n/, $gMarriage{$id})) {
      my @f = split(/\|/, $s);
      my $spouse = shift @f;
      $mData{$spouse} = '' unless defined $mData{$spouse};
      my $i = "$f[0] $f[1]";
      $mData{$spouse} .= sprintf($slfmt, "m. $i") if length($i) > 1;
      $i = "$f[2] $f[3]";
      $mData{$spouse} .= sprintf($slfmt, "div. $i") if $i !~ /^(not)? $/;
      }
    }
  else { %mData = (); }

  if (defined $gChild{$id}) {
    my $s = $gChild{$id};
    my $lastOtherParent = -1;
    my $otherParentIndex = $id % 2;
    my $nFullSibs = 0;
    for my $kid (split(/\|/, $s)) {
      my $nKidRows = 1;
      my $thisOtherParent = (split(/\|/, $gParent{$kid}))[$otherParentIndex];
      {
	my $s = fmt -2*($generation+1), $kid;
	if ($generation < 1) {
	  my @kidrows = children $generation+1, $kid;
	  $nKidRows = $#kidrows + 1;
	  if ($nKidRows > 0) {
	    $kidrows[0] = "<td rowspan=$nKidRows>$s$kidrows[0]";
	    push(@rows, @kidrows);
	    }
	  else { $nKidRows = 1; push(@rows, qq(<td>$s)); }
	  }
	else { 
	  push(@rows, qq(<td>$s)); 
	  }
      }
      if ($thisOtherParent == $lastOtherParent) { $nFullSibs += $nKidRows; }
      else {
	if ($lastOtherParent != -1) {
	  my $s = "<td rowspan=$nFullSibs>" 
	    . (fmt -2*$generation-1, $lastOtherParent);
	  if (defined $mData{$lastOtherParent}) {
 	    $s .= $mData{$lastOtherParent};
	    delete $mData{$lastOtherParent};
	    }
	  $rows[$#rows + 1 - $nFullSibs - $nKidRows] =~ s/^/$s/;
	  }
	$lastOtherParent = $thisOtherParent;
	$nFullSibs = $nKidRows;
	}
      }
    {
      my $s = "<td rowspan=$nFullSibs>" 
        . (fmt -2*$generation-1, $lastOtherParent);
      if (defined $mData{$lastOtherParent}) {
 	$s .= $mData{$lastOtherParent}; # should really go above name
	delete $mData{$lastOtherParent};
	}
      $rows[$#rows + 1 - $nFullSibs] =~ s/^/$s/;
    }
    }
  else { @rows = (); }
  for my $spouse (keys %mData) {
    push(@rows, '<td>' . (fmt -2*$generation-1, $spouse) . $mData{$spouse});
    }
  @rows;
  }

sub fmt ($$) { my($level, $id) = @_;
  my $out = '?';
  if ($id) {
    my @p = split(/\|/, $gPerson{$id}, 12);
    $out = name 1,$id;
    my $alevel = abs($level);

    # add title
    if ($alevel <= 2) {
      $out .= sprintf($slfmt, $p[2]) if length($p[2]);
      }
    # add dates
    if ($alevel == 3) {
      if ($opt_v || $p[5] !~ /alive/i) {
	my $s = "$p[3]-$p[5]";
	$out .= sprintf($slfmt, $s) if length($s) > 1;
	}
      }
    elsif ($alevel < 3) { # birth and death information
      my @termini;
      for my $i (3,5) { $p[$i] =~ s/ /&nbsp;/g; }
      if ($opt_v || $p[5] !~ /alive/i) {
	my $s = "*$p[3] $p[4]";
        push(@termini, $s) if length($s) > 2;
	}
      if ($p[5] !~ /alive/i) {
	my $s = "+$p[5] $p[6]";
	push(@termini, $s) if length($s) > 2;
	}
      $out .= sprintf($spfmt, join('<br>', @termini)) if $#termini >= 0;
      }
    # add notes
    if (($alevel <= 2 || $level == -3) && length($p[7])) {
      my $notes = $p[7];
      $notes =~ s!<p>(.*?)</p>!<p><font size="-1">$1</font></p>!g
        || ($notes = sprintf($spfmt, $notes));
      $out .= $notes;
      }
    # add reference counts
    {
      my $refs = '';
      $refs .= qq(<font color="#808080">$id);
      if ($level > 0) {
	# descendants
	$refs .= " &lt;$p[10]:$p[11]" if $gChild{$id} =~ /\|/;
	# ancestors
	$refs .= " &gt;$p[8]:$p[9]" if $level == 4 && $p[8] > 0;
	}
      elsif ($level < 0) {
	# ancestors
	$refs .= " &lt;$p[8]:$p[9]" if $level % 2 && $p[8] > 0;
	# descendants
	$refs .= " &gt;$p[10]:$p[11]" if $level == -4 && $p[10] > 0;
	}
      $refs .= qq(</font>);
      $out .= sprintf($level > 2 ? $slfmt : $spfmt, $refs);
    }
    }
  $out;
# $out . " ($level)";
  }

# name $v, $id
#   return formatted string representing name corresponding to ID $id
#   $v - include <a> tags pointing to person's page
#   $id - genealogical ID of subject
sub name ($$) {
  my ($v, $id) = @_;
  return '?' unless (defined $id) && defined $gPerson{$id};
  my (@f) = split(/\|/, $gPerson{$id});
  my $n = join(' ', @f[1,0]);
  $v ? "<a href=\"genea2.pl?$id\">$n</a>" : $n;
  }

sub Main () {
  my $id = shift @ARGV;

  if (defined $ENV{'HTTP_IF_MODIFIED_SINCE'}) {
    my $ims_time = $ENV{'HTTP_IF_MODIFIED_SINCE'};
    $ims_time =~ s/;.*//;
    if (&http'canon_time($mod_time) 
      le &http'parse_http_time($ims_time)) {
      print &http'format_http_header(304, 'Not Modified', undef, '');
      warn "http cache hit\n";
      exit 0;
      }
    }

  if (!defined $id) {
    print &http'format_http_reply(400, 'Missing search key', undef, '',
      'Error: missing search key', 
      '<h2>Error:</h2>This URL requires a search key');
    }
  elsif ($id !~ /^\d+$/) {
    print &http'format_http_reply(400, 'Bad search key', undef, '',
      'Error: bad search key', 
      '<h2>Error:</h2>'.
      "`$id' is not a valid search key for this genealogical database.");
    }
  else {
    dbmopen(%gPerson, "${dir}person", 0600);
    dbmopen(%gParent, "${dir}parent", 0600);
    dbmopen(%gChild, "${dir}child", 0600);
    dbmopen(%gMarriage, "${dir}marriage", 0600);

    if (!defined $gPerson{$id}) {
      print &http'format_http_reply(400, 'Unknown person', undef, '',
	'Error: unknown person', 
	'<h2>Error:</h2>'.
	"`$id' does not identify any known person in this database.");
      }
    else {
      my @ancs = ($id);
      my $title = "Genealogical Record: " . &name(0, $id);
      for my $i (0..15) { 
        @ancs[$i+$i+1, $i+$i+2] = (split(/\|/, $gParent{$ancs[$i]}),0,0)[0..1]; 
	}
      my $kids = '';
      {
	my @rows = &children(0, $id);
	if ($#rows >= 0) {
	  $kids = 
	    '<table border=1><tr>'.
	    '<th>Spouse<th>Children<th>Children-in-Law<th>Grandchildren<tr>'.
	    join('<tr>', @rows).
	    '</table>';
	  }
      }
   
      print &http'format_http_reply(200, 'Ok', $mod_time, '',
	$title, "<h2>$title</h2>" .
	"<table border=1>".
	"<tr><th>Self<th>Parents<th>Grandparents<th>GGParents<th>GGGParents".
	"<tr><td rowspan=16>". &fmt(0,$ancs[0]) .  "<td rowspan=8>". &fmt(1,$ancs[1]) . "<td rowspan=4>". &fmt(2,$ancs[3]) .  "<td rowspan=2>". &fmt(3,$ancs[7]) . "<td>". &fmt(4,$ancs[15]) . 
	"<tr><td>". &fmt(4,$ancs[16]) .  "<tr><td rowspan=2>".  &fmt(3,$ancs[8]) . "<td>" . &fmt(4,$ancs[17]) . 
	"<tr><td>". &fmt(4,$ancs[18]) .
	"<tr><td rowspan=4>".  &fmt(2,$ancs[4]) .  "<td rowspan=2>" . &fmt(3,$ancs[9]) . "<td>" . &fmt(4,$ancs[19]) .
	"<tr><td>". &fmt(4,$ancs[20]) .
	"<tr><td rowspan=2>".  &fmt(3,$ancs[10]) . "<td>" . &fmt(4,$ancs[21]) .
	"<tr><td>". &fmt(4,$ancs[22]) .
	"<tr><td rowspan=8>". &fmt(1,$ancs[2]) . "<td rowspan=4>".&fmt(2,$ancs[5]).  "<td rowspan=2>".  &fmt(3,$ancs[11]) . "<td>" . &fmt(4,$ancs[23]) .
	"<tr><td>". &fmt(4,$ancs[24]) .
	"<tr><td rowspan=2>".  &fmt(3,$ancs[12]) . "<td>" . &fmt(4,$ancs[25]) .
	"<tr><td>". &fmt(4,$ancs[26]) .
	"<tr><td rowspan=4>".  &fmt(2,$ancs[6]) .  "<td rowspan=2>" . &fmt(3,$ancs[13]) . "<td>" . &fmt(4,$ancs[27]) .
	"<tr><td>". &fmt(4,$ancs[28]) .
	"<tr><td rowspan=2>".  &fmt(3,$ancs[14]) . "<td>" . &fmt(4,$ancs[29]) .
	"<tr><td>". &fmt(4,$ancs[30]) .
	'</table><p>'.
	$kids);
      }
    }
  exit 0;
  }