#!/usr/bin/env perl
# Albert Danial July 20 2002
# Frame layout based on Paul Kienzle's octave-forge web documentation.
use strict;
use Text::Wrap qw(wrap);
# use Data::Dumper::Simple;

my @Docs = qw( newman.doc automan.doc appman.doc manual.doc );

$Text::Wrap::columns = 70;
$| = 1; # flush STDOUT

my $location = `pwd`;
my $PATH     = "";
if ($location =~ m{^(.*)/admin$}) {
    $PATH = "$1/doc";
} elsif ($location =~ m{^(.*)/tops$}) {
    $PATH = "$1/tops/doc";
} else {
    die "Run $0 from tops home directory or tops/admin\n";
}
my $BODY       = get_body();  # color scheme for background, links, text
my %entry      = ();
my %files      = ();
my %anchors    = ();
my %categories = ();
foreach my $F (@Docs) {
    get_entries("$PATH/$F",  # in
               \%entry,      # out
               \%categories, # out
               \%files,      # out
               \%anchors);   # out
}
# die Dumper(\%entry);

my %missing = ();
get_missing(\%entry,       # in
            \%missing);    # out

my $a_to_z_nav_line = "";
write_entries($PATH, 
             \%entry, 
             \$a_to_z_nav_line,
             \%missing,
             \%categories,
             \%files,
             \%anchors);

write_framed_index($PATH,
                   $a_to_z_nav_line,
                  \%categories,
                  \%files);

sub get_body { # {{{1
    return '<body bgcolor="#FEFDE8" text="#000000" leftmargin="0" topmargin="0"
 link="#B70801" vlink="#12233A" alink="#9CA4A7">';
} # 1}}}
sub write_framed_index { # {{{1
    my ($DIR     ,    # in
        $A_to_Z  ,    # in
        $rha_cat ,    # in category{cat name} = [list of words]
        $rhh_file,    # in  file{ word|cat }{ word or cat name } = name of
                      #     file containing this word or category entry
       ) = @_;
    my $file = "index.html";
    open (OUT, ">$DIR/$file") or die "Cannot write $DIR/$file  $!\n";
    print OUT '<HTML><HEAD>
<TITLE>Tops Documentation</TITLE>
</HEAD>
<FRAMESET rows="50, *">
  <FRAME src="top_panel.html" noresize frameborder="0">
  <FRAMESET cols="25%, 75%">
    <FRAME name=navbar src="categorical.html">
    <FRAMESET rows="58, *">
      <FRAME src="alphabetic.html">
      <FRAME name=content src="intro.html">
    </FRAMESET>
  </FRAMESET>
<NOFRAMES>
<center>
<BIG>Tops</BIG>
</center>
    
<H1>Tops Words</H1>
<ul>
<li><A HREF="categorical.html">Categorical index</a>
<li><A HREF="alphabetic.html">Alphabetic index</a>
</ul>
</NOFRAMES>
</FRAMESET>
</HTML>
';
    close OUT;

    my $file = "intro.html";
    open (OUT, ">$DIR/$file") or die "Cannot write $DIR/$file  $!\n";
    print OUT "<HTML><HEAD><title>Welcome to Tops</title></head>\n";
    print OUT "<base target=content>$BODY\n";
    print OUT "<center><br><br><br>\n";
# begin drw 10-13-02 by the team
    print OUT "tops<br><br>by Project tops developers, copyright 2002";
#   print OUT "tops<br><br>by Dale Williamson, copyright 2002";
# end drw 10-13-02
    print OUT "</center>\n";
    print OUT "</body></html>\n";
    close OUT;

    my $file = "top_panel.html";
    open (OUT, ">$DIR/$file") or die "Cannot write $DIR/$file  $!\n";
    print OUT "<HTML><HEAD><title>Welcome to Tops</title></head>\n";
    print OUT "<base target=content>$BODY\n";
    print OUT "<center><big><big><b>Tops Words</b></big></big></center>\n";
    print OUT "</body></html>\n";
    close OUT;

    my $file = "alphabetic.html";
    open (OUT, ">$DIR/$file") or die "Cannot write $DIR/$file  $!\n";
    print OUT "<HTML><HEAD><title>Tops Alphabetical Word List</title></head>\n";
    print OUT "<base target=content>$BODY\n";
    print OUT $A_to_Z;
    print OUT "</body></html>\n";
    close OUT;

    my $file = "categorical.html";
    open (OUT, ">$DIR/$file") or die "Cannot write $DIR/$file  $!\n";
    print OUT "<HTML><HEAD><title>Tops Categorical Word List</title></head>\n";
    print OUT "<base target=content>$BODY\n";
    my $indent_level = 0;
    foreach my $C (sort keys %{$rhh_file->{cat}}) {
        my $show_label = $C;
        if ($C =~ /^(.*);;(.*?)$/) { # is a sub-category
            my $header  = $1;
            $show_label = $2;
            my $n_indent = 1 + ($header =~ s/;;/;;/g);
            if ($indent_level < $n_indent) {
                my $subheader = $header;
                   $subheader =~ /^(.*);;(.*?)$/;
                   $subheader = $1;
                my $subcat    = $2;
# warn "$indent_level < $n_indent C=$C  header=$1  subheader=$subheader  subcat=$subcat\n";
                print OUT '&nbsp; &nbsp; &nbsp; ' x $indent_level, 
                          "<tt>", $subcat , "</tt><br>\n",
                    unless defined $rhh_file->{cat}{"${subheader};;${subcat}"};
            }
            $indent_level = $n_indent;
            print OUT '&nbsp; &nbsp; &nbsp; ' x $n_indent;
        }
        print OUT '<a href="', $rhh_file->{cat}{$C}, '.html"><tt>', 
                  $show_label, "</tt></a><br>\n";
    }
    print OUT "</body></html>\n";
    close OUT;

} # 1}}}
sub get_entries {  # {{{1
    my ($file,        # in
        $rhh_entry,   # out entry{word}{doc|stk|syn|rel|def|cat} = value(s)
        $rha_cat,     # out category{cat name} = [list of words]
        $rhh_file,    # out file{ word|cat }{ word or cat name } = name of
                      #     file containing this word or category entry
        $rhh_anchor,  # out anchor{ word|cat }{ word or cat name } = name of
                      #     html anchor pointing to this word or category entry
       ) = @_;

    open(IN, $file) or die "Cannot read $file:  $!\n";
    while (<IN>) {
        next unless /^(\S+)\s+(\S+.*?)$/;
        my $word = $1;
        my $def  = $2;
        if (!defined $rhh_entry->{$word}) {
              $rhh_entry->{$word}{doc}  = "";  # main documentation
              $rhh_entry->{$word}{stk}  = "";  # stack diagram
              $rhh_entry->{$word}{def}  = "";  # location where defined
            @{$rhh_entry->{$word}{syn}} = ();  # list of synonyms
            @{$rhh_entry->{$word}{rel}} = ();  # list of related words
            @{$rhh_entry->{$word}{cat}} = ();  # list of categories
        }
        if      ($def =~ /^\(/) {
            $def =~ s/\b<\b/&lt;/g;
            $def =~ s/\b>\b/&gt;/g;
            $rhh_entry->{$word}{doc} .= $def;

        } elsif ($def =~ /^use\b/) {
            $def =~ s/\b<\b/&lt;/g;
            $def =~ s/\b>\b/&gt;/g;
            $rhh_entry->{$word}{doc} .= $def . "\n";

        } elsif ($def =~ /^synonym\b:?\s+(.*?)$/) {
            push @{$rhh_entry->{$word}{syn}}, comma_list($1);

        } elsif ($def =~ /^related\s+for\s+c\s+code\b:?\s+(.*?)$/i) {
            $rhh_entry->{$word}{def} .= $1;

        } elsif ($def =~ /^related\b:?\s+(.*?)$/) {
            push @{$rhh_entry->{$word}{rel}}, comma_list($1);

        } elsif ($def =~ /^category\b:?\s+(.*?)$/) {
#print "[$word] cat=[$1]\n";
            # newer browsers don't like html file names with embedded
            # :: replace these with =:
            (my $category = $1) =~ s/::/=:/g;
            push @{$rhh_entry->{$word}{cat}}, comma_list($category);

        } elsif ($def =~ /^defined\b:?\s+(.*?)$/) {
            $rhh_entry->{$word}{def} .= $1;

        } else {
            $rhh_entry->{$word}{doc} .= $def . "\n";
        }
    }
    close IN;

    #
    # determine html file names and anchors for each word
    #
    foreach my $word (sort keys %{$rhh_entry}) {
        my $unmangled = unmangle($word); # replace unusual char's w/ASCII #
        if ($unmangled =~ /^\d{3}-/) {
            $rhh_file->{word}{$word} = "special";
        } else {
            $rhh_file->{word}{$word} = uc substr($unmangled, 0, 1); # 1st letter
        }
        $rhh_anchor->{word}{$word} = $unmangled;
    }

    #
    # extract stack diagram from main documentation; fill the categories hash
    #
    foreach my $word (sort keys %{$rhh_entry}) {
        if ($rhh_entry->{$word}{doc}) {
            if ($rhh_entry->{$word}{doc} =~ m/^\s*(\(.*?\))\s*(.*?)/) {
                # then a stack diagram exists
                $rhh_entry->{$word}{doc} =~ s/^\s*(\(.*?\))\s*(.*?)/$2/; 
                # $1 should have the stack diagram
                $rhh_entry->{$word}{stk} = $1;
            }
        }
        if (defined $rhh_entry->{$word}{cat}) {
            # loop over all the categories this word belongs to
            foreach my $C (@{$rhh_entry->{$word}{cat}}) {
                push @{$rha_cat->{ $C }}, $word;
            }
        }
    }
    foreach my $C (sort keys %{$rha_cat}) {
        my $file = $C;
        $file =~ s/\s+/_/g;
        $rhh_file->{cat}{$C}   = $file; # replace unusual char's
        $rhh_anchor->{cat}{$C} = unmangle($C);
    }
} # 1}}}
sub get_missing {  # {{{1
    my ($rhh_entry,  # in   entry{word}{doc|stk|syn|rel|def|cat} = value(s)
        $rha_missing # out  missing{ missing word } = [list of related from's]
       ) = @_;

    foreach my $word (sort keys %{$rhh_entry}) {
        foreach my $related (@{$rhh_entry->{$word}{rel}}) {
#printf "get_missing %-12s : %-12s ", $word, $related;
            push @{$rha_missing->{$word}}, $related
                unless defined $rhh_entry->{$related}{doc};
        }
    }

    if (%{$rha_missing}) {
        print "The following ", scalar keys %{$rha_missing},
              " words do not have man entries:\n";
        my $n = 0;
        foreach (sort keys %{$rha_missing}) {
            printf "%3d. %-16s (related from %s)\n", 
                   ++$n, $_, join(", ", @{$rha_missing->{$_}});
        }
        print scalar keys %{$rha_missing}, " missing cross references\n",
            if scalar keys %{$rha_missing};
    }
}
# 1}}}
sub comma_list { # {{{1
    my ($line) = @_;
    $line =~ s/^\s+//g;
    $line =~ s/\s+$//g;
    $line =~ s/\s*,\s*/,/g;
    $line =~ s/\s+/ /g;
    return split(',', $line);
} # 1}}}
sub write_entries { # {{{1
    my ($DIR,         # in  directory to write files to
        $rhh_entry,   # in  entry{word}{doc|stk|syn|rel|def|cat} = value(s)
        $rs_A_Z   ,   # out string for html navigation by alphabetical ordering
        $rha_missing, # out missing{ missing word } = [list of related from's]
        $rha_cat,     # in  category{cat name} = [list of words]
        $rhh_file,    # in  file{ word|cat }{ word or cat name } = name of
                      #     file containing this word or category entry
        $rhh_anchor,  # in  anchor{ word|cat }{ word or cat name } = name of
                      #     html anchor pointing to this word or category entry
       ) = @_;

    my %all_files       = (); # all_files{word|cat}{ filename } = 1
    my %words_this_file = (); # words_this_file{word|cat}{file} = [word list]
    foreach my $word (sort keys %{$rhh_entry}) {
        $all_files{word}{$rhh_file->{word}{$word}} = 1;
        push @{$words_this_file{word}{ $rhh_file->{word}{$word} }}, $word;
        if (defined @{$rhh_entry->{$word}{cat}}) {
            foreach my $C (@{$rhh_entry->{$word}{cat}}) {
                $all_files{cat}{ $rhh_file->{cat}{$C} } = 1;
                push @{$words_this_file{cat}{  $rhh_file->{cat}{ $C} }}, $word;
            }
        }
    }

    # make single index file with every single word in it
    write_all_in_one($DIR, 
                     $rhh_entry, 
                     $rhh_file->{word}, 
                     $rhh_anchor->{word});

    ${$rs_A_Z} = make_nav_line(\%{$all_files{word}});

    #
    # put words in html files according to the word's first character
    #
    foreach my $file (sort keys %{$all_files{word}}) {
        write_html_file("$DIR/$file",
                      \@{$words_this_file{word}{ $file }}, 
                       $rhh_file,  
                       $rhh_anchor, 
                       $rhh_entry, 
                      \%missing);
    }
    #
    # put words in html files according to the word's category
    #
    foreach my $file (sort keys %{$all_files{cat}}) {
        write_html_file("$DIR/$file",
                      \@{$words_this_file{cat}{ $file }}, 
                       $rhh_file,  
                       $rhh_anchor, 
                       $rhh_entry, 
                      \%missing);
    }

    print ' ' x 80;
    printf "\nWrote entries to %d words in %d alphabetical files, %d category files\n", 
        scalar keys %{$rhh_entry}, scalar(keys(%{$all_files{word}})),
                                   scalar(keys(%{$all_files{cat}}));

} # 1}}}
sub write_html_file { # {{{1
    my ($file,       # in  the html file to create or append to
        $ra_word,    # in  list of words for this file
        $rhh_file,   # in  the entire file{word} hash
        $rhh_anchor, # in  anchor{word} = unmangled name prefix
        $rhh_entry,  # in  entry{word}{doc|stk|syn|rel|def|cat} = value(s)
        $rha_missing,# in  missing{w} = [words related from ]
       ) = @_;
#     $rh_entry->{$word}{doc}   main documentation
#     $rh_entry->{$word}{stk}   stack diagram
#     $rh_entry->{$word}{def}   location where defined
#   @{$rh_entry->{$word}{syn}}  list of synonyms
#   @{$rh_entry->{$word}{rel}}  list of related words
#   @{$rh_entry->{$word}{cat}}  list of categories

    my $header  = '<html><head><title>man entry: ' . $file . '</title>' .
                  "</head>$BODY\n";
    my $trailer = "</body></html>\n";

    $file .= ".html";
    open (OUT, ">$file") or die "Cannot write $file  $!\n";
    print OUT $header;

    foreach my $w (sort @{$ra_word}) {
        # the word in bold and cross referenced w/anchor:
        printf OUT "<h2><tt><a name=\"%s\">%s</a></tt></h2>\n", 
            $rhh_anchor->{word}{$w}, $w; 
        printf OUT "<h2><tt>%s</tt></h2><br>\n", 
            replace_html_metachars($rhh_entry->{$w}{stk})
            if $rhh_entry->{$w}{stk};
        printf OUT "<pre>%s</pre>\n", 
            replace_html_metachars(wrap("", "", $rhh_entry->{$w}{doc}));

        printf OUT "Defined: \&nbsp; %s<br>\n", $rhh_entry->{$w}{def} 
            if $rhh_entry->{$w}{def};

# begin drw 10-13-02 revise to give link to Synonym

#       foreach my $x (@{$rhh_entry->{$w}{syn}}) {
#           printf OUT "Synonym: \&nbsp;  <tt>%s</tt><br>\n", 
#                   replace_html_metachars($x);
#       }

        if (defined @{$rhh_entry->{$w}{syn}}) {
            print OUT 'Synonym: &nbsp; ';
            foreach my $x (@{$rhh_entry->{$w}{syn}}) {
                if (defined @{$rha_missing->{$x}}) {
                    print OUT '<tt>' .
                               replace_html_metachars($x) .
                              "</tt>" .  '&nbsp; ', "\n";
                } else {
                    print OUT '<a href="' .
                               $rhh_file->{word}{$x} . '.html#' .
                               $rhh_anchor->{word}{$x} . '">' .
                              '<tt>' .
                               replace_html_metachars($x) .
                              "</tt></a>" .
                              '&nbsp; ', "\n";
                }
            }
            printf OUT "<br>\n";
        }
# end drw 10-13-02 

        if (defined @{$rhh_entry->{$w}{rel}}) {
            printf OUT "Category: \&nbsp; %-14s\n";
            foreach my $C (@{$rhh_entry->{$w}{cat}}) {
                print OUT '<a href="' . 
                           $rhh_file->{cat}{$C} . '.html">' . 
                          '<tt>' . $C . "</tt></a>" .
                          '&nbsp; ', "\n";
            }
            printf OUT "<br>\n";
        }

        if (defined @{$rhh_entry->{$w}{rel}}) {
            print OUT 'Related: &nbsp; ';
            foreach my $x (@{$rhh_entry->{$w}{rel}}) {
                if (defined @{$rha_missing->{$x}}) {
                    print OUT '<tt>' . 
                               replace_html_metachars($x) . 
                              "</tt>" .  '&nbsp; ', "\n";
                } else {
                    print OUT '<a href="' . 
                               $rhh_file->{word}{$x} . '.html#' . 
                               $rhh_anchor->{word}{$x} . '">' .
                              '<tt>' . 
                               replace_html_metachars($x) . 
                              "</tt></a>" .
                              '&nbsp; ', "\n";
                }
            }
        }
        print OUT "<hr>\n";
        my $L;
        if (length($file) > 12) {
            $L = length($file) + length($w) + 1;
        } else {
            $L = 12            + length($w) + 1;
        }
        $w = substr($w, 0, 30) if length($w) > 30;
        printf "%-12s %s%s\r", $file, $w, ' ' x (80 - $L);
    }
    print OUT $trailer;
    close(OUT);

} # 1}}}
sub write_all_in_one { # {{{1
    my ($DIR,         # in
        $rhh_entry,   # in  entry{word}{doc|stk|syn|rel|def|cat} = value(s)
        $rh_filename, # in  filename{word} = prefix of filename for this word
        $rh_anchor,   # in  anchor{word}   = unmangled name prefix
       ) = @_;

    my $header  = '<html><head><title>Tops Man Entries -- ' .
                  'Table of Contents</title>' .
                  "</head>$BODY\n";
    my $trailer = "</body></html>\n";

    my $file = "all_words.html";
    open (OUT, ">$DIR/$file") or die "Cannot write $DIR/$file  $!\n";
    print OUT $header;

    foreach my $word (sort keys %{$rhh_entry}) {
        print OUT '<a href="' . $rh_filename->{$word} . ".html#" . 
                   $rh_anchor->{$word} .  '">' . 
                   $word . '</a> &nbsp; ' . "\n";
    }

    print OUT $trailer;
    close(OUT);
} # 1}}}
sub unmangle { # {{{1
    my ($in) = @_;
    # If the input has non-word characters, ie, outside [a-zA-Z0-9_]
    # replace the characters with numeric ASCII code.
    # Eg.:   in = "*by"     returns "042-by"

    if ($in =~ /\W/) {
        my @char = split('', $in);
        my $out  = "";
        for (my $i = 0; $i < scalar @char; $i++) {
            if ($char[$i] =~ /[a-zA-Z0-9_]/o) {
                $out .= $char[$i];
            } else {
                $out .= sprintf("%03d-", ord($char[$i]));
            }
        }
        return $out;
    } else {
        return $in;
    }
} # 1}}}
sub make_nav_line { # {{{1
    my ($rh_files) = @_;

    my $out = '<center><a href="all_words.html"><i>All Words</i></a> ' .
              ' &nbsp; ' . "\n";
    foreach my $F (sort keys %{$rh_files}) {
        $out .= sprintf "<a href=\"%s.html\">%s</a> \&nbsp;\n", $F, $F;
        $out .= sprintf "<br>\n" if $F eq "J";
    }
    $out .= '</center>';
    return $out;
} # 1}}}
sub replace_html_metachars { # {{{1
    my ($text) = @_;
    $text =~ s/\&/&amp;/g;  # has to come first!
    $text =~ s/</&lt;/g;
    $text =~ s/>/&gt;/g;
    return $text;
} # 1}}}
