#!/usr/bin/perl -w
# HOWTO:
#  $ cat gmr.xml | $0 > word_list.xml

use strict;
use XML::LibXML;
use IO::Handle;
use IO::File;
use Sys::Hostname;
use Getopt::Std;
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";

###############################################################################
# RCS keyword
###############################################################################
my $ID = '$Id: list.pl,v 1.14 2010/11/28 13:43:03 asdrury Exp $' ;

###############################################################################
# defaults
###############################################################################
defined $ENV{'DOMX_HOME'} or die "\$DOMX_HOME not defined. See setenv.sh" ;
my $DEFAULT_SOURCE_FILE_ = "$ENV{'DOMX_HOME'}/xml/gmr.xml" ;
my $DEFAULT_TITLE_ = "Word List from Ordo Missae" ;
my $DEFAULT_FORMAT_ = "HTML" ;

###############################################################################
# usage
###############################################################################
my $USAGE_=<<EOM;
 \$ cat ${DEFAULT_SOURCE_FILE_} | $0 [-F format] [-t title] [-vh] > list.xml
  F: XML or HTML format; default = ${DEFAULT_FORMAT_}
  t: Document title; default = ${DEFAULT_TITLE_}
  v: verbose
  h: this message
EOM

###############################################################################
# getopts
###############################################################################
my %opts ;
getopts('F:t:vh', \%opts) ;
print $USAGE_ and exit 0 if (defined $opts{'h'});
my $format = ((defined $opts{'F'}) ? $opts{'F'} : $DEFAULT_FORMAT_) ;
my $title_ = ((defined $opts{'t'}) ? $opts{'t'} : $DEFAULT_TITLE_) ;
my $verbose_ = ((defined $opts{'v'}) ? 1 : 0) ;

###############################################################################
# data structures
###############################################################################
my %terms = ();

###############################################################################
# XML parser
###############################################################################
my $parser = new XML::LibXML;

###############################################################################
# Timestamp and hostname for <version/>
###############################################################################
my ($date, $time) = &time_stamp() ;
my $login = getlogin || getpwuid($<) || "Kilroy";
my $host = hostname();
my $who = "$login\@$host" ;

###############################################################################
# Open filehandle, parse and transform GMR XML file
###############################################################################
print STDERR "Parsing Ordo Missae XML data from STDIN...\n" if $verbose_ ;
my $fh = new IO::Handle;
if( $fh->fdopen( fileno( STDIN ), "r" )) {

    my $doc = $parser->parse_fh( $fh );
    my $root = $doc->getDocumentElement;

    my @verba = $root->getElementsByTagName('verbum'); print STDERR "\@verba=" . @verba . "\n" if $verbose_ ;
    foreach my $verbum (@verba) {
        my $part = (defined $verbum->getAttribute('part')) ? $verbum->getAttribute('part') : "flark" ;
        if ( "N" eq $part) { ## noun
            my $decl = "UNK"; $decl = $verbum->getAttribute('declension') if (defined $verbum->getAttribute('declension')) ; print STDERR "\$decl=$decl\n" if $verbose_ ;
            my $tkey = "N" . $decl ;
            my @nouns = $verbum->getElementsByTagName('noun'); print STDERR "\@nouns=" . @nouns . "\n" if $verbose_ ;
            foreach my $noun (@nouns) {
                my $prop_name = $verbum->getAttribute('proper_name');
                my $is_name = (defined($prop_name) and ("true" eq $prop_name)); print STDERR "\$is_name=" . $is_name . "\n" if defined($prop_name) and $verbose_ ;
                my $nom = "UNK"; $nom = $noun->getAttribute('nominative') if (defined $noun->getAttribute('nominative'))   ; print STDERR "\$nom=$nom\n" if $verbose_ ;
                my $gen = "UNK"; $gen = $noun->getAttribute('genitive') if (defined $noun->getAttribute('genitive'))  ; print STDERR "\$gen=$gen\n" if $verbose_ ;
                if (not ("UNK" eq "$nom" and "UNK" eq "$gen")) {
                    my $gpl = "&nbsp;"; $gpl = $noun->getAttribute('genitive_plural') if (defined $noun->getAttribute('genitive_plural'))  ; print STDERR "\$gpl=$gpl\n" if $verbose_ ;
                    my $gnd = "UNK"; $gnd = $noun->getAttribute('gender') if (defined $noun->getAttribute('gender'))  ; print STDERR "\$gnd=$gnd\n" if $verbose_ ;
                    my $key = "${decl}${gnd}${nom}${gen}${gpl}" ; print STDERR "\$key=$key\n" if $verbose_ ;
                    if (not $is_name) {
                        my %decl_nouns ;
                        %decl_nouns = @{ $terms{$tkey} } if (exists($terms{$tkey})) ; 
                        my $cnt = $decl_nouns{$key}{'cnt'} ; $cnt = 0 if (not defined $cnt ) ; print STDERR "\$cnt=$cnt\n" if $verbose_ ;
                        $decl_nouns{$key} = { part=>'N', decl=>$decl, nom=>$nom, gen=>$gen, gnd=>$gnd, gpl=>$gpl, cnt=>++$cnt } ;
                        $terms{$tkey} = [ %decl_nouns ] ;
                    } else {
                        my %proper_nouns ;
                        %proper_nouns = @{ $terms{$tkey} } if (exists($terms{$tkey})) ; 
                        my $cnt = $proper_nouns{$key}{'cnt'} ; $cnt = 0 if (not defined $cnt ) ; print STDERR "\$cnt=$cnt\n" if $verbose_ ;
                        $proper_nouns{$key} = { part=>'PN', decl=>$decl, nom=>$nom, gen=>$gen, gnd=>$gnd, gpl=>$gpl, cnt=>++$cnt } ;
                        $terms{$tkey} = [ %proper_nouns ] ;
                    }
                } else {
                    #print STDERR "\$radix=" . ((defined $verbum->getAttribute('radix')) ? $verbum->getAttribute('radix') : 'radix') . "\n" if "UNK" eq $nom and "UNK" eq $gen ;
                }
            }
        }
        elsif ( "ADJ" eq $part) { ## adjective
            my $decl = "UNK"; $decl = $verbum->getAttribute('declension') if (defined $verbum->getAttribute('declension')) ; print STDERR "\$decl=$decl\n" if $verbose_ ;
            my $tkey = "ADJ" . $decl ;
            my @adjs = $verbum->getElementsByTagName('adjective'); print STDERR "\@adjs=" . @adjs . "\n" if $verbose_ ;
            foreach my $adj (@adjs) {
                my $mas = "UNK"; $mas = $adj->getAttribute('masculine') if (defined $adj->getAttribute('masculine'))   ; print STDERR "\$mas=$mas\n" if $verbose_ ;
                my $fem = "UNK"; $fem = $adj->getAttribute('feminine') if (defined $adj->getAttribute('feminine'))  ; print STDERR "\$fem=$fem\n" if $verbose_ ;
                my $neu = "UNK"; $neu = $adj->getAttribute('neuter') if (defined $adj->getAttribute('neuter'))  ; print STDERR "\$neu=$neu\n" if $verbose_ ;
                my $gen = "&nbsp;"; $gen = $adj->getAttribute('genitive') if (defined $adj->getAttribute('genitive'))  ; print STDERR "\$gen=$gen\n" if $verbose_ ;
                my $com = "&nbsp;"; $com = $adj->getAttribute('comparative') if (defined $adj->getAttribute('comparative'))  ; print STDERR "\$com=$com\n" if $verbose_ ;
                my $key = "${decl}${mas}${fem}${neu}" ; print STDERR "\$key=$key\n" if $verbose_ ;
                my %decl_adjs ;
                %decl_adjs = @{ $terms{$tkey} } if (exists($terms{$tkey})) ; 
                my $cnt = $decl_adjs{$key}{'cnt'} ; $cnt = 0 if (not defined $cnt ) ; print STDERR "\$cnt=$cnt\n" if $verbose_ ;
                $decl_adjs{$key} = { part=>'ADJ', decl=>$decl, mas=>$mas, fem=>$fem, neu=>$neu, gen=>$gen, com=>$com, cnt=>++$cnt } ;
                $terms{$tkey} = [ %decl_adjs ] ;
            }
        }
        elsif ( "V" eq $part or "VT" eq $part or "VDEP" eq $part or "VSDEP" eq $part or "VPAR" eq $part or "VPPL" eq $part) { ## verb
            my $conj = "UNK" ; $conj = $verbum->getAttribute('conjugation') if (defined $verbum->getAttribute('conjugation')) ; print STDERR "\$conj=$conj\n" if $verbose_ ;
            my $tkey = "V" . $conj ;
            my @verbs = $verbum->getElementsByTagName('verb'); print STDERR "\@verbs=" . @verbs . "\n" if $verbose_ ;
            foreach my $verb (@verbs) {
                my $first = "UNK"; $first = $verb->getAttribute('first') if (defined $verb->getAttribute('first'))   ; print STDERR "\$first=$first\n" if $verbose_ ;
                my $second = "UNK"; $second = $verb->getAttribute('second') if (defined $verb->getAttribute('second'))  ; print STDERR "\$second=$second\n" if $verbose_ ;
                my $third = "UNK"; $third = $verb->getAttribute('third') if (defined $verb->getAttribute('third'))  ; print STDERR "\$third=$third\n" if $verbose_ ;
                my $fourth = "UNK"; $fourth = $verb->getAttribute('fourth') if (defined $verb->getAttribute('fourth'))  ; print STDERR "\$fourth=$fourth\n" if $verbose_ ;
                my $key = "${conj}${first}${second}${third}${fourth}" ;  print STDERR "\$key=$key\n" if $verbose_ ;
                my %conj_verbs ;
                %conj_verbs = @{ $terms{$tkey} } if (exists($terms{$tkey})) ;
                my $cnt = $conj_verbs{$key}{'cnt'} ; $cnt = 0 if (not defined $cnt ) ; print STDERR "\$cnt=$cnt\n" if $verbose_ ;
                $conj_verbs{$key} = { part=>'V', conj=>$conj, first=>$first, second=>$second, third=>$third, fourth=>$fourth, cnt=>++$cnt } ;
                $terms{$tkey} = [ %conj_verbs ] ;
            }
        }
        elsif ( "PREP" eq $part ) { ## preposition
            my $case = "UNK" ; $case = $verbum->getAttribute('case') if (defined $verbum->getAttribute('case')) ; print STDERR "\$case=$case\n" if $verbose_ ;
            my $tkey = "PREP" . $case ;
            my @preps = $verbum->getElementsByTagName('preposition'); print STDERR "\@preps=" . @preps . "\n" if $verbose_ ;
            foreach my $prep (@preps) {
                my $term = "UNK" ; $term = $prep->getAttribute('term') if (defined $prep->getAttribute('term')) ; print STDERR "\$term=$term\n" if $verbose_ ;
                my $key = "${case}${term}" ;  print STDERR "\$key=$key\n" if $verbose_ ;
                my %case_preps ;
                %case_preps = @{ $terms{$tkey} } if (exists($terms{$tkey})) ;
                my $cnt = $case_preps{$key}{'cnt'} ; $cnt = 0 if (not defined $cnt ) ; print STDERR "\$cnt=$cnt\n" if $verbose_ ;
                $case_preps{$key} = { part=>'PREP', term=>$term, case=>$case, cnt=>++$cnt } ;
                $terms{$tkey} = [ %case_preps ] ;
            }
        }
        elsif ( "ADV" eq $part ) { ## adverbs
            my $tkey = "ADV" ;
            my @advs = $verbum->getElementsByTagName('adverb'); print STDERR "\@advs=" . @advs . "\n" if $verbose_ ;
            foreach my $adv (@advs) {
                my $term = "UNK" ; $term = $adv->getAttribute('term') if (defined $adv->getAttribute('term')) ; print STDERR "\$term=$term\n" if $verbose_ ;
                my $key = "${term}" ;  print STDERR "\$key=$key\n" if $verbose_ ;
                my %case_advs ;
                %case_advs = @{ $terms{$tkey} } if (exists($terms{$tkey})) ;
                my $cnt = $case_advs{$key}{'cnt'} ; $cnt = 0 if (not defined $cnt ) ; print STDERR "\$cnt=$cnt\n" if $verbose_ ;
                $case_advs{$key} = { part=>'ADV', term=>$term, cnt=>++$cnt } ;
                $terms{$tkey} = [ %case_advs ] ;
            }
        }
    }
}

my $i = 1 ;
if ("XML" eq $format) {
 print '<?xml version="1.0" encoding="utf-8"?>' . "\n" ;
 print '<nouns>' . "\n" ;
 foreach my $d (sort keys %terms) {
    my %decl_nouns = @{ $terms{$d} } ;
    foreach my $key (sort keys %decl_nouns) {
        if (defined $decl_nouns{$key}{'nom'}) {
            print "<noun id=\"" . $i++ . "\" count=\"" . $decl_nouns{$key}{'cnt'} . "\" declension=\"" . $decl_nouns{$key}{'decl'} . "\" nominative=\"" . $decl_nouns{$key}{'nom'} . "\" genitive=\"" . $decl_nouns{$key}{'gen'} . "\" gender=\"" . $decl_nouns{$key}{'gnd'} . "\"/>" . "\n" ;
        }
    }
 }
 print '</nouns>' . "\n" ;
} elsif ("HTML" eq $format) {
 print '<!doctype html public "-//W3C//DTD HTML 4.0 Transitional//EN">' . "\n" ;
 print "<!--Ad Majorem Dei Gloriam-->\n" ;
 print "<html>\n" ;
 print "<head>\n" ;
 print "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">\n" ;
 print "<base href=\"http://gmr.sourceforge.net\">\n" ;
 print "<link rel=stylesheet href=\"css/drurynet.css\">\n" ;
 print "<link rel=\"shortcut icon\" href=\"images/favicon.ico\">\n" ;
 print "<link rel=\"icon\" type=\"image/ico\" href=\"images/favicon.ico\">\n" ;
 print "<meta name=\"author\" content=\"A.S.Drury\">\n" ;
 print "<meta name=\"description\" content=\"Latin word count from Traditional Latin Mass 1962\">\n" ;
 print "<meta name=\"keywords\" content=\"Latin word count, Traditional Latin Mass 1962 with grammatical information, Latin language study aid, learning guide, dictionary, glossary, Ecclesiastical Latin, Ordo Missae Missale Romanum, Ordinary of the Mass Traditional Roman Catholic Latin Mass, Extraordinary Form, Gregorian Rite, Motu Proprio Summum Pontificum, William Whitaker's WORDS\"/>\n" ;
 print "<meta http-equiv=\"pragma\" content=\"no-cache\"/>\n" ;
 print "<meta http-equiv=\"expires\" content=\"0\"/>\n" ;
 print "<meta http-equiv=\"expires\" content=\"Mon, 01 Jan 2001 00:00:00 GMT\"/>\n" ;
 print "<title>TLM Word Count</title>\n" ;
 print "</head>\n" ;
 print "<body bgcolor=\"white\">\n" ;
 print "<h3>Word count Ordo Miss&#0230; 1962</h3>\n" ;
 print "<p>How many times does each word appear in the Mass? For example, how many times is <em>sacrifice</em> mentioned? " ;
 print "According to my count, as often as <em>peace</em>, <em>holy</em> &amp; <em>heaven</em>!</p>" ;
 print "<p>Here's a simplified list of words from the Ordo Miss&#0230; 1962.</p>\n" ;
 print "<p><font size=\"-4\" color=\"gray\">\$Id\$</font></p>\n" ;
 print "<p><font size=\"-4\" color=\"gray\">Generated by " . &get_id_ . "</font></p>\n" ;
 print "<p><a title=\"Grammar of Missale Romanum 1962 (GMR)\" href=\"index.html\">Home</a></p>\n" ;
 print "<p>Some browsers can render <a title=\"Grammar of Missale Romanum 1962 (GMR)\" href=\"xml/gmr.xml\">xml source</a>.\n" ;
 print "   The most recent version of this document is always available <a title=\"TLMWord Count\" href=\"http://gmr.sourceforge.net/html/word_list.html\">here</a>.</p>\n" ;

 ## Nouns
 print "<table border='1' cellspacing='1' cellpadding='3'>" . "\n" ;
 print "<caption>Word Count: Latin Nouns Ordo Miss&#0230; 1962</caption>\n" ;
 print "<tr><th>&nbsp;</th><th>Declension</th><th>Count</th><th>Nominative</th><th>Genitive</th><th>Genitive pl</th><th>Gender</th></tr>\n";
 foreach my $d (sort keys %terms) {
    my %decl_nouns = @{ $terms{$d} } ;
    foreach my $key (sort keys %decl_nouns) {
        if ('N' eq $decl_nouns{$key}{'part'}) {
            print "<tr><td>" . $i++ . "</td><td>" . 
                  $decl_nouns{$key}{'decl'} . "</td><td>" . 
                  $decl_nouns{$key}{'cnt'}  . "</td><td>" . 
                  $decl_nouns{$key}{'nom'}  . "</td><td>" . 
                  $decl_nouns{$key}{'gen'}  . "</td><td>" . 
                  $decl_nouns{$key}{'gpl'}  . "</td><td>" . 
                  $decl_nouns{$key}{'gnd'}  . "</td></tr>" . "\n" ;
        }
    }
 }
 print "</table><br/><br/>\n" ;

 ## Proper names
 print "<table border='1' cellspacing='1' cellpadding='3'>" . "\n" ;
 print "<caption>Word Count: Proper Names Ordo Miss&#0230; 1962</caption>\n" ;
 print "<tr><th>&nbsp;</th><th>Declension</th><th>Count</th><th>Nominative</th><th>Genitive</th><th>Genitive pl</th><th>Gender</th></tr>\n";
 foreach my $d (sort keys %terms) {
    my %proper_nouns = @{ $terms{$d} } ;
    foreach my $key (sort keys %proper_nouns) {
        if ('PN' eq $proper_nouns{$key}{'part'}) {
            print "<tr><td>" . $i++ . "</td><td>" . 
                  $proper_nouns{$key}{'decl'} . "</td><td>" . 
                  $proper_nouns{$key}{'cnt'}  . "</td><td>" . 
                  $proper_nouns{$key}{'nom'}  . "</td><td>" . 
                  $proper_nouns{$key}{'gen'}  . "</td><td>" . 
                  $proper_nouns{$key}{'gpl'}  . "</td><td>" . 
                  $proper_nouns{$key}{'gnd'}  . "</td></tr>" . "\n" ;
        }
    }
 }
 print "</table><br/><br/>\n" ;

 ## Adjectives
 print "<table border='1' cellspacing='1' cellpadding='3'>" . "\n" ;
 print "<caption>Word Count: Latin Adjectives Ordo Miss&#0230; 1962</caption>\n" ;
 print "<tr><th>&nbsp;</th><th>Declension</th><th>Count</th><th>Masculine</th><th>Feminine</th><th>Neuter</th><th>Genitive</th><th>Comparative</th></tr>\n";
 $i = 1 ;
 foreach my $d (sort keys %terms) {
    my %decl_adjs = @{ $terms{$d} } ;
    foreach my $key (sort keys %decl_adjs) {
        if ('ADJ' eq $decl_adjs{$key}{'part'}) {
            print "<tr><td>" . $i++ . "</td><td>" . 
                  $decl_adjs{$key}{'decl'} . "</td><td>" . 
                  $decl_adjs{$key}{'cnt'}  . "</td><td>" . 
                  $decl_adjs{$key}{'mas'}  . "</td><td>" . 
                  $decl_adjs{$key}{'fem'}  . "</td><td>" . 
                  $decl_adjs{$key}{'neu'}  . "</td><td>" .
                  $decl_adjs{$key}{'gen'}  . "</td><td>" .
                  $decl_adjs{$key}{'com'}  . "</td></tr>" . "\n" ;
        }
    }
 }
 print "</table><br/><br/>\n" ;

 ## Verbs
 print "<table border='1' cellspacing='1' cellpadding='3'>" . "\n" ;
 print "<caption>Word Count: Latin Verbs Ordo Miss&#0230; 1962</caption>\n" ;
 print "<tr><th>&nbsp;</th><th>Conjugation</th><th>Count</th><th>First</th><th>Second</th><th>Third</th><th>Fourth</th></tr>\n";
 $i = 1 ;
 foreach my $d (sort keys %terms) {
    my %conj_verbs = @{ $terms{$d} } ;
    foreach my $key (sort keys %conj_verbs) {
        if ('V' eq $conj_verbs{$key}{'part'}) {
            print "<tr><td>" . $i++ . "</td><td>" . 
                  $conj_verbs{$key}{'conj'} . "</td><td>" . 
                  $conj_verbs{$key}{'cnt'}  . "</td><td>" . 
                  $conj_verbs{$key}{'first'}  . "</td><td>" . 
                  $conj_verbs{$key}{'second'}  . "</td><td>" . 
                  $conj_verbs{$key}{'third'}  . "</td><td>" .
                  $conj_verbs{$key}{'fourth'}  . "</td></tr>" . "\n" ;
        }
    }
 }
 print "</table>\n" ;

 ## Prepositions
 print "<table border='1' cellspacing='1' cellpadding='3'>" . "\n" ;
 print "<table border='1' cellspacing='1' cellpadding='3'>" . "\n" ;
 print "<caption>Word Count: Latin Prepositions Ordo Miss&#0230; 1962</caption>\n" ;
 print "<tr><th>&nbsp;</th><th>Governed Case</th><th>Count</th><th>Term</th></tr>\n";
 $i = 1 ;
 foreach my $d (sort keys %terms) {
    my %case_preps = @{ $terms{$d} } ;
    foreach my $key (sort keys %case_preps) {
        if ('PREP' eq $case_preps{$key}{'part'}) {
            print "<tr><td>" . $i++ . "</td><td>" . 
                  $case_preps{$key}{'case'} . "</td><td>" .
                  $case_preps{$key}{'cnt'}  . "</td><td>" . 
                  $case_preps{$key}{'term'} . "</td></tr>" . "\n" ;
        }
    }
 }
 print "</table>\n" ;

 ## Adverbs
 print "<table border='1' cellspacing='1' cellpadding='3'>" . "\n" ;
 print "<table border='1' cellspacing='1' cellpadding='3'>" . "\n" ;
 print "<caption>Word Count: Latin Adverbs Ordo Miss&#0230; 1962</caption>\n" ;
 print "<tr><th>&nbsp;</th><th>Count</th><th>Term</th></tr>\n";
 $i = 1 ;
 foreach my $d (sort keys %terms) {
    my %case_advs = @{ $terms{$d} } ;
    foreach my $key (sort keys %case_advs) {
        if ('ADV' eq $case_advs{$key}{'part'}) {
            print "<tr><td>" . $i++ . "</td><td>" . 
                  $case_advs{$key}{'cnt'}  . "</td><td>" . 
                  $case_advs{$key}{'term'} . "</td></tr>" . "\n" ;
        }
    }
 }
 print "</table>\n" ;

 print "</body>\n</html>\n" ;
}


###############################################################################
# $date = 2005-08-10
# $time = 08:15:32
###############################################################################
sub time_stamp {
  my ($d,$t);
  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);

  $year += 1900;
  $mon++;
  $d = sprintf("%4d-%2.2d-%2.2d",$year,$mon,$mday);
  $t = sprintf("%2.2d:%2.2d:%2.2d",$hour,$min,$sec);

  return($d,$t);
}

###############################################################################
# get stripped RCS key word to embed in output
###############################################################################
sub get_id_ {
    my $x = $ID ;
    $x =~ s/\$// ;
    $x =~ s/^\s+// ;
    $x =~ s/\s+$// ;
    return $x ;
}

#vim: encoding=utf-8 fileencoding=utf-8
