#! /usr/bin/perl -w

# Script for producing the Index for the Exim manual from the output of the
# SGCAL run. This is copied from the script for the Exim book.


##############################################################################
# Patterns for matching things to be removed from the sort keys

# This was copied from the Exim book processor, but we have now found a
# better way of doing this. Leave the code until I am quite sure...

# $pat[0]  = qr/ \(\\\*see also\*\\[^)]+\)/;
# $pat[1]  = qr/(?<!@)\/\//;                     # //
# $pat[2]  = qr/(?<!@)\/\\/;                     # /\
# $pat[3]  = qr/(?<!@)\\\//;                     # \/
# $pat[4]  = qr/(?<!@) \\                        # non-@ \, followed by one of
#                             (?:
#                             [\.\/] |           # dot or slash
#                             !- |               # !-
#                             !\+ |              # !+
#                             !\. |              # !.
#                             "\+ |              # "+
#                             \([.\/]? |         # ( and optional . or slash
#                             [[\$\\%?!-"] |     # [ $ \ % ! " or -
#                             \*{1,2} |          # * or **
#                             \^{1,2}\/?         # ^ or ^^ and optional slash
#                             )/x;
# $pat[5]  = qr/(?: []\$\\%)?!"] |               # ] $ \ % ) ? " or ! )
#                   \*{1,2}  |                   # * or **            ) optional
#                   \^{1,2})?                    # ^ or ^^            )
#                   \\/x;                        # then \
# $pat[6]  = qr/(?<!@)::/;
# $pat[7]  = qr/\sR[FS]\b/;
# $pat[8]  = qr/``/;
# $pat[9]  = qr/''/;
# $pat[10] = qr/`/;
# $pat[11] = qr/'/;
# $pat[12] = qr/,/;
# $pat[13] = qr/\(e?s\)/;


# Other patterns

# $keysplit = qr/^(.*?)(\|\|.*?)?\s(R[AZ])?\s?(\d+)$/;

$keysplit = qr/^(.*?)(\@\|\@\|.*?)?\s(R[AZ])?\s?(\d+)$/;


# The sort function

sub cf {
my($x,$y) = ($a,$b);

############old#############
#foreach $pattern (@pat)    # Remove strings by pattern
#  {
#  $x =~ s/$pattern//g;
#  $y =~ s/$pattern//g; 
#  } 
##########################


# Turn || into @|@|

$x =~ s/\|\|/@|@|/g;
$y =~ s/\|\|/@|@|/g;

# Remove all special characters, except those preceded by @

$x =~ s/(?<!\@)[^\w\@\s]//g;
$y =~ s/(?<!\@)[^\w\@\s]//g;

# Remove the escaping @s

#$x =~ s/\@(.)/$1/g;
#$y =~ s/\@(.)/$1/g;


  
################old ########################
#$x =~ s/:(\w+):/$1/g;      # :fail: etc => fail
#$y =~ s/:(\w+):/$1/g;

#$x =~ s/^\@[^a-z]+/\@/i;   # Make keys starting with @ 
#$y =~ s/^\@[^a-z]+/\@/i;   # sort on @ followed by the first letter
##############################################3


$x =~ s/\@_/\x7f/g;        # Make underscore sort late (option names)
$y =~ s/\@_/\x7f/g; 
   
# Split up to sort on individual parts

my($xp,$xs,$xr,$xn) = $x =~ /$keysplit/;
my($yp,$ys,$yr,$yn) = $y =~ /$keysplit/;

$xr = "" if !defined $xr;
$yr = "" if !defined $yr;

$xs = "" if !defined $xs;
$ys = "" if !defined $ys;

if ($show_keys)
  {
  print "a=$a\n  x=$x\n  xp=$xp\n  xs=$xs\n  xr=$xr\n  xn=$xn\n";
  print "b=$b\n  y=$y\n  yp=$yp\n  ys=$ys\n  yr=$yr\n  yn=$yn\n";
  } 

my ($c) = "\L$xp" cmp "\L$yp";        # Caseless, primary text only
$c = $xp cmp $yp if $c == 0;          # Caseful, primary text only
$c = "\L$xs" cmp "\L$ys" if $c == 0;  # Caseless, secondary text only
$c = $xs cmp $ys if $c == 0;          # Caseful, secondary text only
$c = $xn <=> $yn if $c == 0;          # Compare the numbers
$c = $xr cmp $yr if $c == 0;          # Sort RA before RZ
return $c;
}



##############################################################################
# Function for getting the next line from the @lines vector, using the global
# index $1. If the next pair of lines specifies a range of pages, combine them.
# That's why $linenumber has to be global - so we can increment it. If there's
# a range error, return "".

sub getnextentry {
my($line) = $lines[$linenumber];
my($aa,$zz,$tline,$nextline,$tnextline);

if ($line =~ / RA (\d+)/)
  {
  $aa = $1; 
  $nextline = $lines[++$linenumber];
  if ($nextline =~ / RZ (\d+)/) 
    { 
    $zz = $1;
    }
  else    
    {
    print STDERR "** Bad range data (1)\n";
    print STDERR "   $line\n";
    print STDERR "   $nextline\n";
    return "";
    }  
    
  $tline = $line;
  $tnextline = $nextline; 
   
  $tline =~ s/ RA \d+//; 
  $tnextline =~ s/ RZ \d+//;
  
  if ($tline ne $tnextline)
    {
    print STDERR "** Bad range data (2)\n";
    print STDERR "   $line\n";
    print STDERR "   $nextline\n";
    return "";
    }  

  $line = ($aa eq $zz)? "$tline $aa" : "$tline $aa--$zz";
  }   
  
elsif ($line =~ / RZ (\d+)/)
  {
  print STDERR "** Bad range data (RZ without RA)\n";
  print STDERR "   $line\n";
  return "";
  } 

return $line
}




##############################################################################
# Function for outputting a line, checking for the current primary
# and indenting a bit for secondaries. We also need a newpar
# before each item, because the main indent is set to a largish indent
# for long reference lists, but the parindent is set to counter this.
# This is where we handle the break between letters. We know that any non-
# alphamerics at the start of lines are markup, except for @. A reference
# value of 99999 is for the "see also" lines. Suppress it.

sub outline {
my($text,$ref) = ($_[0],$_[1]);
my ($letter) = $text =~ /^[^A-Za-z0-9\@]*(.)/;

return if $text =~ /^\s*$/;

if ($ref eq "99999")    # dummy for see also
  {
  $ref = "" 
  } 
else
  {
  $ref = "#$ref";       # prepend space
  }    

if ($letter =~ /\d/) { $letter = "0"; } else { $letter = "\U$letter"; } 

print OUT ".newpar\n";

if ($letter ne $currentletter && $letter ge "A")
  {
  print OUT ".newletter\n"; 
  $currentletter = $letter;   
  } 
    
$text =~ s/\@'/\$'/g;   # Turns @' into $' so that it prints a non-curly quote

if ($text =~ /^(.+)\|\|(.*)$/)
  {
  my($primary,$secondary) = ($1,$2);
 
  if ($primary ne $lastprimary)
    {
    print OUT ".primary $primary\n"; 
    $lastprimary = $primary;
    }
 
  $primary =~ s/"/""/g;
  $secondary =~ s/"/""/g;   
   
  my($contprim) = $primary;
  $contprim =~ s/ \(\\\*see also\*\\[^)]+\)//; 

  print OUT ".secondary \"$primary\" \"$secondary$ref\" \"$contprim\"\n";
  } 

# Not a two-part item; insert @ if the first char is a dot

else
  {
  print OUT "@" if $text =~ /^\./; 
  print OUT "$text$ref\n";
  $lastprimary = $text; 
  } 
}





##############################################################################
# The main script

$save_sorted = 0;
$test_index = 0;
$show_keys = 0;

while (@ARGV > 0)
  {
  my($arg) = shift @ARGV;
  if    ($arg eq "-k") { $show_keys = 1; }
  elsif ($arg eq "-s") { $save_sorted = 1; }
  elsif ($arg eq "-t") { $test_index = $save_sorted = 1; }
  else  { die "Unknown option $arg\n"; }  
  } 

if ($test_index)
  {
  open(IN, "z-testindex") || die "Can't open z-testindex\n";
  }
else
  {   
  open(IN, "z-rawindex") || die "Can't open z-rawindex\n";
  }

open(OUT, ">z-index")  || die "Can't open z-index\n";

# Extract index lines ($e lines are contents). Until we hit the first
# $e line, we are dealing with "see also" index lines, for which we want
# to turn the line number into 99999.

$#lines = -1;
$prestuff = 1;

while (<IN>)
  {
  s/\n$//; 
  if (/\$e/)
    {
    $prestuff = 0; 
    }
  else
    {
    s/(\D)$/$1 99999/ if $prestuff;          # No number in "see also"
    push(@lines, $_);
    } 
  $index_pagenumber = $1 if /^Index\$e(\d+)/;
  } 
close(IN);

# Sort, ignoring markup

print STDERR "Sorting ...\n";
@lines = sort cf @lines;

# Keep a copy of the sorted data, for reference

if ($save_sorted)
  {
  open(X, ">z-indexsorted") || die "Can't open z-indexsorted\n";
  foreach $line (@lines)
   {
   print X "$line\n";
   }
  close(X);     
  } 

# Heading for the index file

print OUT <<"EOF";
.library "a4ps"
.linelength ~~sys.linelength + 16.0

.include "markup.sg"

.indent 3em
.parspace 0
.parindent -3em
.justify left
.
.foot
\$c [~~sys.pagenumber]
.endfoot
.
.cancelflag #
.flag # "\$S*1"
.set INDEX true
.
.macro primary "text"
.if ~~sys.leftonpage < 2ld
.newcolumn
.fi
~~1
.newpar
.endm
.
.macro secondary "prim" "sec" "contprim"
.if ~~sys.leftonpage < 1ld
.newcolumn
.newpar
~~3 \$it\{(continued)\}
.newpar
.fi
##~~2
.endm
.
.macro newletter
.if ~~sys.leftonpage < 4ld
.newcolumn
.else
.space 1ld
.fi
.newpar
.endm
.
.set chapter -1
.page $index_pagenumber
.chapter Index
.columns 2
.newpar
.
EOF

# Process the lines and output the result.
# Note that $linenumber is global, and is changed by getnextentry() for
# pairs of lines that represent ranges.

$lastprimary = "";
$lastref = "";
$currenttext = $currentref = "";
$currentletter = "";
$badrange = 0;

print STDERR "Processing ...\n";

for ($linenumber = 0; $linenumber < @lines; $linenumber++) 
  { 
  $line = &getnextentry();
  
  if ($line eq "")   # Bad range data - but carry on to get all of it
    {
    $badrange = 1;
    next;
    }   
    
  # Split off the text and reference
  
  ($text,$ref) = $line =~ /^(.*)\s+([\d-]+)$/;

  # If same as current text, just add the new reference, unless its a duplicate

  if ($text eq $currenttext)
    {
    if ($ref ne $lastref)
      {  
      $currentref .= ", $ref"; 
      $lastref = $ref;
      }  
    next;
    }
    
  # Not the same as the current text. Output the current text, then 
  # set up a new current. 
    
  &outline($currenttext, $currentref);
   
  $currenttext = $text; 
  $currentref = $lastref = $ref; 
  }
  
# Output the final line and close the file

&outline($currenttext, $currentref);
close(OUT);

die "** Aborted\n" if $badrange;

# Format the index

system("sgcal z-index -to zi-gcode -index /dev/null");
system("sgtops zi-gcode -to zi-ps");
print "PostScript in zi-ps\n";

# End