#!@PERL@
# makevpl
# (C) A. J. C. Duggan 1993
# Mix and match TeX's PL and VPL files
#
# FONTDIMEN actions are ---
#    -replacefd <range> | -addfd <range>
#
# CHARACTER actions are ---
#    -replace[ch|ic|wd|ht|dp|map] <range> |
#    -add[ch|ic|wd|ht|dp|map] <range>
# (ch = character (all), ic = italic correction, wd = width, ht = height,
#  dp = depth, map = character map)
#
# mapfont FONTAT actions are ---
#    -normal | -at <size>
#
# default actions are:
#    -addfd - -replacech - -normal

# v1.1 20/9/93 AJCD
# Fixed problems with scaling, removed redundant MAPFONTs
#
# v1.2 23/9/93 AJCD
# Split into reusable packages

($prog) = ($0 =~ /([^\/]*)$/);

unshift(@INC, "@PERLLIBDIR@");	# set perl include directory

require 'paths.pl';
require 'parseenc.pl';
require 'parsepl.pl';

###############################################################################
# Auxiliary routines
###############################################################################

# fatal(...)
# causes a fatal error with the arguments given
sub fatal {
   print STDERR "$prog: ";
   printf STDERR @_;
   print STDERR "\n";
   exit 1;
}

# inrange(num, range)
# tests if number is in the range given
# range = num[,range] | [num]-[num][,range] | []
sub inrange {
   local($number, $range) = @_;
   foreach (split(/,/, $range)) {
      if (/^(0x?[\da-fA-F]+)/) {
	 next if $number < oct($1);
      } elsif (/^(\d+)/) {
	 next if $number < $1;
      }
      if (/(0x?[\da-fA-F]+)$/) {
	 next if $number > oct($1);
      } elsif (/(\d+)$/) {
	 next if $number > $1;
      }
      return 1;
   }
   0;
}

# normalise(number)
# return real normalised to design units of font
sub normalise {
   local($string) = @_;
   $dunits = $designunits if !defined($dunits);
   $dsize = $designsize if !defined($dsize);
   $string = sprintf('R %.5f', &number($string)*$designsize*$dunits/($designunits*$dsize))
      if $dsize*$designunits != $designsize*$dunits;
   $string;
}

###############################################################################
# Property list manipulation routines
###############################################################################

# PL property functions
# called by getpl with normal arguments as parameters

sub checksum {			# put checksum in MAPFONT
   local($name, $number) = @_;
   $fontprop{$fontname,0,FONTCHECKSUM} = "(FONTCHECKSUM $number)"
      if !defined($fontprop{$fontname,0,FONTCHECKSUM});
   undef;
}

sub designunits {		# save designunits
   local($name, $number) = @_;
   $designunits = &number($number);
   undef;
}

sub designsize {		# save designsize
   local($name, $number) = @_;
   $fontprop{$fontname,0,FONTDSIZE} = "(FONTDSIZE $number)"
      if !defined($fontprop{$fontname,0,FONTDSIZE});
   $designsize = &number($number);
   undef;
}

sub codingscheme {		# keep original codingscheme
   local($name, $string) = @_;
   $fcoding = $string if !defined($fcoding);
   undef;
}

sub family {			# keep original family
   local($name, $string) = @_;
   $ffamily = $string if !defined($ffamily);
   undef;
}

sub face {			# keep original face
   local($name, $number) = @_;
   $fface = &number($number) if !defined($fface);
   undef;
}

sub header {			# keep original header
   local($name, $byte, $value) = @_;
   local($index) = &number($byte);
   $header[$index] = "$byte $value" if !defined($header[$index]);
   undef;
}

# mapfont properties
sub mapfontprop {		# MAPFONT sub-properties
   join(' ', @_);
}

sub fontat {			# fontat property is relative to designunits
   local($name, $number) = @_;
   $dunits = $designunits if !defined($dunits);
   $dsize = $designsize if !defined($dsize);
   if (!$scale) {
      $number = sprintf('R %.5f', &number($number)*$dunits/$designunits)
	 if $dunits != $designunits;
   } else {
      local($fontat) = $scale*$dunits/$dsize;
      $number = sprintf('R %.5f', $fontat)
	 if $fontat != $dunits;
   }
   "($name $number)";
}

sub mapfont {			# MAPFONT property
   local($name, $number, @map) = @_;
   local($value) = &number($number);
   foreach (@map) {		# put MAPFONT properties into fontprops
      $fontprop{$fontname,$value,$1} = $_
	 if /^\((\w+)/;
   }
   undef;
}

# ligtable properties
sub ligprop {
   join(' ', @_);
}

# addligs(left, skip, ligtable)
# put entries into current font's ligtable for left-side character after
# skipping given number of ligs & kerns
sub addligs {
   local($left) = shift;
   local($skip) = shift;
   local($lastlabel) = !$skip;
   local($number);
   return if $lastlabel && defined($kernslike{$fontname,$left});
   while ($skip && ($_ = shift)) {
      $skip-- if /KRN/ || /LIG/;
   }
   while (@_) {
      $_ = shift;
      last if (/STOP/);
      if (/SKIP (\S \S+)/) {
	 &addligs($left, &number($1), @_);
	 last;
      } elsif (/(\/?LIG\/?>?>?) (\S \S+) (\S \S+)/) {
	 foreach $ligto (&mapsto(&number($2))) {
	    if (!defined($ligtable{$fontname,$left,$ligto})) {
	       ($number) = &mapsto(&number($3));
	       $ligtable{$fontname,$left,$ligto} =
		  sprintf("($1 %s %s)", &charnum($ligto), &charnum($number))
		     if defined($number);
	       print STDERR "$ligtable{$fontname,$left,$ligto}\n" if $debug;
	    }
	 }
	 $lastlabel = 0;
      } elsif (/(KRN) (\S \S+) (\S \S+)/) {
	 foreach $krnto (&mapsto(&number($2))) {
	    if (!defined($ligtable{$fontname,$left,$krnto})) {
	       $ligtable{$fontname,$left,$krnto} =
		  sprintf("($1 %s %s)", &charnum($krnto), &normalise($3));
	       print STDERR "$ligtable{$fontname,$left,$krnto}\n" if $debug;
	    }
	 }
	 $lastlabel = 0;
      } elsif (/LABEL BOUNDARYCHAR/) {
	 $kernslike{$fontname,BOUNDARYCHAR} = $left
	    if ($lastlabel);
      } elsif (/LABEL (\S \S+)/) {
	 if ($lastlabel) {
	    foreach (&mapsto(&number($1))) {
	       $kernslike{$fontname,$_} = $left;
	    }
	 }
      }
   }
}

sub ligtable {			# merge ligtables
   local($name) = shift;
   print STDERR '(Building ligature table...' if !$quiet;
   while (@_) {			# run through program, putting LABELs in
      $_ = shift;
      if (/LABEL BOUNDARYCHAR/) {
	 &addligs(BOUNDARYCHAR, 0, @_);
      } elsif (/LABEL (\S \S+)/) {
	 foreach (&mapsto(&number($1))) { # add lig table for each remapping
	    &addligs($_, 0, @_);
	 }
      }
   }
   print STDERR 'done)' if !$quiet;
}

sub boundarychar {		# keep original boundarychar
   local($name, $char) = @_;
   ($fbchar) = &mapsto(&number($char)) if !defined($fbchar);
   undef;
}

# list of fontdimen names -> fontdimen numbers
%fontdimen = (SLANT, 1, SPACE, 2, STRETCH, 3, SHRINK, 4, XHEIGHT, 5, QUAD, 6,
	      EXTRASPACE, 7, NUM1, 8, NUM2, 9, NUM3, 10, DENOM1, 11,
	      DENOM2, 12, SUP1, 13, SUP2, 14, SUP3, 15, SUB1, 16, SUB2, 17,
	      SUPDROP, 18, SUBDROP, 19, DELIM1, 20, DELIM2, 21, AXISHEIGHT, 22,
	      DEFAULTRULETHICKNESS, 8, BIGOPSPACING1, 9, BIGOPSPACING2, 10,
	      BIGOPSPACING3, 11, BIGOPSPACING4, 12, BIGOPSPACING5, 13
	      );

# fontdimen properties
sub fontdimen {
   local($name, $number) = @_;
   local($index) = $fontdimen{$name};
   $fontdimen[$index] = '('.join(' ', $name, &normalise($number)).')'
      if (!defined($fontdimen[$index]) && &inrange($index, $add{fd})) ||
	 &inrange($index, $sub{fd}); 
   undef;
}

sub parameter {
   local($name, $indexstr, $number) = @_;
   local($index) = &number($indexstr);
   $fontdimen[$index] = join(' ', "($name", $indexstr, &normalise($number)).')'
      if (!defined($fontdimen[$index]) && &inrange($index, $add{fd})) ||
	 &inrange($index, $sub{fd}); 
   undef;
}

# character properties
%charprop = @thismap = ();

sub charprop {
   local($name, $number) = @_;
   $charprop{$name} = "($name ".&normalise($number).')';
   undef;
}

sub nextlarger {		# deal with NEXTLARGER lists
   local($name, $number) = @_;
   print STDERR "$name $number : " if $debug;
   ($charprop{NEXTLARGER}) = &mapsto(&number($number));
   undef $charprop{VARCHAR};	# mutually exclusive
}

sub varprop {			# deal with VARCHAR lists
   local($name, $number) = @_;
   print STDERR "$name $number :" if $debug;
   ($charprop{$name}) = &mapsto(&number($number));
   undef $charprop{NEXTLARGER};	# mutually exclusive
}

sub mapprop {			# MAP sub-properties
   local($name) = shift;
   join(' ', "($name", @_).')'; # return property
}

sub mappropn {			# normalised MAP sub-properties
   local($name) = shift;
   foreach (@_) {
      $_ = &normalise($_);
   }
   join(' ', "($name", @_).')'; # return property
}

sub map {			# deal with MAP lists
   local($name);
   ($name, @thismap) = @_;
   undef;
}

sub character {			# add or replace character properties
   local($name, $number) = @_;
   local($position) = &number($number);
   local($lastsel, $lastfont, $font) = 0;
   foreach $ch (&mapsto($position)) {
      $charic[$ch] = $charprop{CHARIC}
	 if (!defined($charic[$ch]) && &inrange($position, $add{ic})) ||
	    &inrange($position, $sub{ic});
      $charwd[$ch] = $charprop{CHARWD}
	 if (!defined($charwd[$ch]) && &inrange($position, $add{wd})) ||
	    &inrange($position, $sub{wd});
      $charht[$ch] = $charprop{CHARHT}
	 if (!defined($charht[$ch]) && &inrange($position, $add{ht})) ||
	    &inrange($position, $sub{ht});
      $chardp[$ch] = $charprop{CHARDP}
	 if (!defined($chardp[$ch]) && &inrange($position, $add{dp})) ||
	    &inrange($position, $sub{dp});
      if ((!defined($charmap[$ch]) && &inrange($position, $add{map})) ||
	  &inrange($position, $sub{map})) {
	 @thismap = ("(SETCHAR $number)") if !@thismap;	# make default MAP
	 $charmap[$ch] = join("\n", '(MAP', @thismap, ')');
	 $charfrom[$ch] = $fontname;
	 $nextlarger[$ch] = $charprop{NEXTLARGER}
 	    if defined($charprop{NEXTLARGER});
	 foreach $varprop (TOP, MID, BOT, REP) {
	    $varchar{$ch,$varprop} = $charprop{$varprop}
 	       if defined($charprop{$varprop});
	 }
      }
   }
   %charprop = @thismap = ();
   undef;
}

###############################################################################
# Parsing and tokenisation
###############################################################################

# list of property -> parameters_action
#    (N=number, S=string, P=property list, L=label or number)
&plactions(CHECKSUM, checksum, DESIGNSIZE, designsize,
	   DESIGNUNITS, designunits, CODINGSCHEME, codingscheme,
	   FAMILY, family, FACE, family, SEVENBITSAFEFLAG, ignore,
	   HEADER, header, BOUNDARYCHAR, boundarychar,
	   VTITLE, ignore, COMMENT, ignore,
	   FONTDIMEN, ignore,	# FONTDIMEN properties follow
	   SLANT, fontdimen, SPACE, fontdimen, STRETCH, fontdimen,
	   SHRINK, fontdimen, XHEIGHT, fontdimen, QUAD, fontdimen,
	   EXTRASPACE, fontdimen, NUM1, fontdimen, NUM2, fontdimen,
	   NUM3, fontdimen, DENOM1, fontdimen, DENOM2, fontdimen,
	   SUP1, fontdimen, SUP2, fontdimen, SUP3, fontdimen,
	   SUB1, fontdimen, SUB2, fontdimen, SUPDROP, fontdimen,
	   SUBDROP, fontdimen, DELIM1, fontdimen, DELIM2, fontdimen,
	   AXISHEIGHT, fontdimen, DEFAULTRULETHICKNESS, fontdimen,
	   BIGOPSPACING1, fontdimen, BIGOPSPACING2, fontdimen,
	   BIGOPSPACING3, fontdimen, BIGOPSPACING4, fontdimen,
	   BIGOPSPACING5, fontdimen, PARAMETER, parameter,
	   LIGTABLE, ligtable,	# LIGTABLE properties follow
	   LABEL, ligprop, KRN, ligprop, STOP, ligprop,
	   SKIP, ligprop, LIG, ligprop, '/LIG', ligprop,
	   '/LIG>', ligprop, 'LIG/', ligprop, 'LIG/>', ligprop,
	   '/LIG/', ligprop, '/LIG/>', ligprop,
	   '/LIG/>>', ligprop,
	   MAPFONT, mapfont,	# MAPFONT properties follow
	   FONTDSIZE, mapfontprop, FONTNAME, mapfontprop,
	   FONTAREA, mapfontprop, FONTCHECKSUM, mapfontprop,
	   FONTAT, fontat,
	   CHARACTER, character, # CHARACTER properties follow
	   CHARWD, charprop, CHARHT, charprop, CHARDP, charprop,
	   CHARIC, charprop, NEXTLARGER, nextlarger,
	   VARCHAR, ignore,	# VARCHAR properties follow
	   TOP, varprop, MID, varprop, BOT, varprop, REP, varprop,
	   MAP, map,		# MAP properties follow
	   SELECTFONT, mapprop, SETCHAR, mapprop,
	   SETRULE, mappropn, PUSH, mapprop, POP, mapprop,
	   MOVERIGHT, mappropn, MOVELEFT, mappropn, MOVEUP, mappropn,
	   MOVEDOWN, mappropn, SPECIAL, mapprop, SPECIALHEX, mapprop
	   );

sub getpl {
   local($fontname) = &fontname(@_);
   $fontprop{$fontname,0,FONTNAME} = "(FONTNAME $fontname)";
   &parsepl(@_);
   if ($scale && !defined($fontprop{$fontname,0,FONTAT})) {
      $dunits = $designunits if !defined($dunits);
      $dsize = $designsize if !defined($dsize);
      local($fontat) = $scale*$dunits/$dsize;
      $fontprop{$fontname,0,FONTAT} = sprintf("(FONTAT R %.5f)", $fontat)
	 if $fontat != $dunits;
   }
}

###############################################################################
# output routines
###############################################################################

# output VPL variables
@charic = ();			# italic corrections
@charwd = ();			# character widths
@charht = ();			# character heights
@chardp = ();			# character depths
@charmap = ();			# character map
@nextlarger = ();		# nextlarger lists
%varchar = ();			# number,property -> number
%ligtable = ();			# font,left,right -> lig/kern property
%kernslike = ();		# font,number -> number
@fontdimen = ();		# array of number -> property
%mapfont = ();			# number,property -> property
%fontprop = ();			# name,select,propname -> property
@header = ();			# header byte -> value
@charfrom = ();			# number -> font

$mapfont = 0;			# current MAPFONT number

# fontmapsto(file, select)
# maps a font selection number to the final output number and outputs MAPFONT
sub fontmapsto {		# return final MAPFONT of fontname,selectnum
   local($fn, $select) = @_;
   local($fontname) = $fontprop{$fn,$select,FONTNAME};
   local($fontarea) = $fontprop{$fn,$select,FONTAREA};
   local($fontat) = $fontprop{$fn,$select,FONTAT};
   if (!defined($mapfont{$fontname,$fontarea,$fontat})) {
      local(@mapfont);
      foreach (FONTNAME, FONTAREA, FONTCHECKSUM, FONTAT, FONTDSIZE) {
	 push(@mapfont, $fontprop{$fn,$select,$_})
	    if defined($fontprop{$fn,$select,$_});
      }
      &expand("(MAPFONT D $mapfont", @mapfont, ')');
      $mapfont{$fontname,$fontarea,$fontat} = $mapfont++;
   }
   $mapfont{$fontname,$fontarea,$fontat};
}

# remap(file, map)
# remaps font selections to the final output font
sub remap {			# remap fontmap to output fonts
   local($fn) = shift;
   local($lastsel, $lastfont, $font) = (0, 0);
   foreach (@_) {
      if (/\(SELECTFONT (.*)\)/) {
	 $font = &fontmapsto($fn, $lastsel = &number($1));
	 if ($font != $lastfont) { # substitute mapped font
	    $_ = "(SELECTFONT D $font)";
	 } else {	# font same as last selected, and can be ignored
	    $_ = '';
	 }
	 $lastfont = $font;
      } elsif (/SETCHAR/) {
	 $font = &fontmapsto($fn, $lastsel);
	 $_ = "(SELECTFONT D $font)\n$_"
	    if ($font != $lastfont); # substitute mapped font
	 $lastfont = $font;
      }
   }
   join("\n", @_);
}

# makevpl()
# print out tidied up vpl file
sub makevpl {
   local(@proplist, $index, $temp);
   local($font, $right, $left, %outlig); # for ligtable construction

   print STDERR "Creating virtual property list\n" if !$quiet;

   print STDERR "...writing header\n" if !$quiet;
   print "(VTITLE created by $vtitle)\n",
         "(COMMENT $prog is (C) A. J. C. Duggan 1993)\n";

   printf "(DESIGNSIZE R %.5f)\n", $dsize if defined($dsize);
   printf "(DESIGNUNITS R %.5f)\n", $dunits if defined($dunits);
   print "(FAMILY $ffamily)\n" if defined($ffamily);
   printf "(FACE O %o)\n", $fface if defined($fface);
   print "(CODINGSCHEME $fcoding)\n" if defined($fcoding);

   for ($index = 0; $index < @header; $index++) { # output header bytes
      print "(HEADER $header[$index])\n" if defined $header[$index];
   }

   print STDERR "...writing font dimensions\n" if !$quiet;
   &expand('(FONTDIMEN', grep($_ ne undef, @fontdimen), ')')
      if @fontdimen;		# output fontdimens

   print STDERR "...writing font mappings\n" if !$quiet;
   for ($index = 0; $index < 256; $index++) { # remap fonts
      $charmap[$index] = &remap($charfrom[$index],
				split("\n", $charmap[$index]))
	 if defined($charmap[$index]);
   }

   print STDERR "...writing ligature table\n" if !$quiet;
   printf "(BOUNDARYCHAR %s)\n", &charnum($fbchar) if defined($fbchar);
   while (($_, $temp) = each %ligtable) { # ligtable mangling
      ($font, $left, $right) = split($;);
      $outlig{$left} .= "$temp\n"
	 if ($left eq BOUNDARYCHAR || $charfrom[$left] eq $font) &&
	    ((defined($fbchar) && $right == $fbchar) ||
	     $charfrom[$right] eq $font);
   }
   @proplist = ();		# clear output LIGTABLE
   foreach (keys(%outlig)) {
      while (($left, $right) = each %kernslike) {
	 ($font, $left) = split($;, $left);
	 if ($right eq $_ &&
	     ($left eq BOUNDARYCHAR || $charfrom[$left] eq $font)) {
	    if ($left eq BOUNDARYCHAR) {
	       push(@proplist, "(LABEL $left)");
	    } else {
	       push(@proplist, sprintf("(LABEL %s)", &charnum($left)));
	    }
	 }
      }
      if ($_ eq BOUNDARYCHAR) {
	 push(@proplist, "(LABEL $_)");
      } else {
	 push(@proplist, sprintf("(LABEL %s)", &charnum($_)));
      }
      push(@proplist, split("\n", $outlig{$_}));
      push(@proplist, '(STOP)');
   }
   &expand('(LIGTABLE', @proplist, ')')
      if @proplist;		# output ligtable
   
   print STDERR "...writing characters\n" if !$quiet;
   for ($index = 0; $index < 256; $index++) { # only output chars with MAPs
      @proplist = ();
      foreach (TOP, MID, BOT, REP) {
	 push(@proplist, sprintf("($_ %s)", &charnum($temp)))
	    if defined($temp = $varchar{$index,$_}) &&
	       defined($charmap[$temp]);
      }
      &expand(sprintf("(CHARACTER %s", &charnum($index)),
	      sprintf("(COMMENT %s)", &encodeto($index)),
	      $charwd[$index], $charht[$index],
	      $chardp[$index], $charic[$index],
	      defined($temp = $nextlarger[$index]) &&
	      defined($charmap[$temp]) ?
	      sprintf("(NEXTLARGER %s)", &charnum($temp)) : '',
	      @proplist ? ('(VARCHAR', @proplist, ')') : '',
	      $charmap[$index], ')')
	 if defined($charmap[$index]);
   }
   print STDERR "...done\n" if !$quiet;
}

###############################################################################
# Actions
###############################################################################

# default actions
%add = (fd, '-');		# additions
%sub = (wd, '-', ht, '-', dp, '-', ic, '-', map, '-'); # substitutions
$scale = 0;			# scale

###############################################################################
# Argument processing
###############################################################################

$vtitle = join(' ', $prog, @ARGV); # set VTITLE to arguments
$defaultenc = 'standard';	# default encoding

while (@ARGV) {
   $_ = shift;
 ARGSW:
   {
      /^-quiet$/ && ($quiet = 1, last ARGSW);
      /^-defenc$/ && ($defaultenc = shift, last ARGSW);
      /^-enc$/ && (&getencoding(shift, &pathexpand($ENV{ENCPATH},
						   '.:@ENCODINGDIR@')),
		   last ARGSW);
      /^-debug$/ && ($debug = 1, last ARGSW);
      /^-at$/ && ($scale = shift, last ARGSW);
      /^-normal$/ && ($scale = 0, last ARGSW);
      /^-replacech$/ &&
	 ($sub{wd} = $sub{ht} = $sub{dp} = $sub{ic} = $sub{map} = shift,
	  $add{wd} = $add{ht} = $add{dp} = $add{ic} = $add{map} = '',
	  last ARGSW);
      /^-addch$/ &&
	 ($sub{wd} = $sub{ht} = $sub{dp} = $sub{ic} = $sub{map} = '',
	  $add{wd} = $add{ht} = $add{dp} = $add{ic} = $add{map} = shift,
	  last ARGSW);
      /^-replace(ic|wd|ht|dp|fd|map)$/ &&
	 ($sub{$1} = shift, $add{$1} = '', last ARGSW);
      /^-add(ic|wd|ht|dp|fd|map)$/ &&
	 ($sub{$1} = '', $add{$1} = shift, last ARGSW);
      /^-size$/ && ($dsize = shift, last ARGSW);
      /^-units$/ && ($dunits = shift, last ARGSW);
      /^-family$/ && ($ffamily = shift, last ARGSW);
      /^-face$/ && ($fface = shift, last ARGSW);
      /^-coding$/ && ($fcoding = shift, last ARGSW);
      if (/^-/) {
	 /^-v$/ && print STDERR "$prog release @RELEASE@\n";
	 print STDERR join("\n",
			   "Usage: $prog [-quiet] [-defenc defaultenc] [-enc enc] [-at size] [-normal]",
			   "        [-addxx range|-replacexx range, xx=ch,fd,wd,ht,dp,ic,map]",
			   "        [-size num] [-units num] [-family str] [-face num] [-coding scheme]",
			   "        filename[:encoding]...\n");
	 exit 1;
      } else {			# filename[:encoding]
	 %defaultadd = %add if !defined(%defaultadd); # set default actions
	 %defaultsub = %sub if !defined(%defaultsub);
	 $defaultscale = $scale if !defined($defaultscale);
	 ($file, $encoding) = split(/:/);
	 &getencoding($encoding eq '' ? $defaultenc : $encoding,
		      &pathexpand($ENV{ENCPATH}, '.:@ENCODINGDIR@'));
	 &getpl($file);		# process PL file
	 %add = %defaultadd;	# restore default actions
	 %sub = %defaultsub;
	 $scale = $defaultscale;
      }
   }
}

&fatal('no property list files specified') if !defined($file);

&makevpl;			# build and print final PL

exit 0;				# good termination