#!@PERL@
# spacevpl
# (C) A. J. C. Duggan 1993
# Alter sizes at sidebearings of VPL files
#
# actions are ---
#    -ht expr -wd expr -dp expr -ic expr -hs expr -vs expr
# (ic = italic correction, wd = width, ht = height, dp = depth,
#  hs = horizontal shift, vs = vertical shift)
# exprs combine these dimensions and constants with *, /, +, -

# v1.2 23/9/93 AJCD
# Created at vplutils release level 1.2

($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;
}

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

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

sub printprop {			# print a property
   &expand(&property(@_));
   undef;
}

sub printlist {			# print a property list
   &expand(&list(@_));
   undef;
}

sub mapfont {			# print a property list with one previous param
   local($first) = join(' ', shift, shift);
   $mapfont = 1;
   &expand(&list($first, @_));
   undef;
}

sub vtitle {
   &expand(&property("COMMENT", @_));
   undef;
}

sub checksum {			# save checksum
   local($name, $number) = @_;
   push(@fontprops, "(FONTCHECKSUM $number)");
   &expand(&property($name, $number));
   undef;
}

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

sub designsize {		# save designsize
   local($name, $number) = @_;
   push(@fontprops, "(FONTDSIZE $number)");
   $designsize = &number($number);
   &expand(&property($name, $number));
   undef;
}

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

sub charprop {
   local($name, $number) = @_;
   $charprop{$name} = &number($number)*$designsize/$designunits;
   undef;
}

sub moveright {
   local($name, $number) = @_;
   if ($charprop{CHARHS} || $charprop{MARKED}) {
      &property(@_);
   } else {
      $charprop{CHARHS} = &number($number)*$designsize/$designunits;
      undef;
   }
}

sub moveleft {
   local($name, $number) = @_;
   if ($charprop{CHARHS} || $charprop{MARKED}) {
      &property(@_);
   } else {
      $charprop{CHARHS} = -&number($number)*$designsize/$designunits;
      undef;
   }
}

sub moveup {
   local($name, $number) = @_;
   if ($charprop{CHARVS} || $charprop{MARKED}) {
      &property(@_);
   } else {
      $charprop{CHARVS} = &number($number)*$designsize/$designunits;
      undef;
   }
}

sub movedown {
   local($name, $number) = @_;
   if ($charprop{CHARVS} || $charprop{MARKED}) {
      &property(@_);
   } else {
      $charprop{CHARVS} = -&number($number)*$designsize/$designunits;
      undef;
   }
}

sub mark {			# MAP property which makes a mark
   $charprop{MARKED} = 1;
   &property(@_);
}

sub map {			# deal with MAP lists
   shift;
   @thismap = @_;
   undef;
}

sub character {			# add or replace character properties
   local($name) = shift;
   local($number) = shift;
   local($value) = &number($number);
   local(%props) = %charprop;

   if (!$mapfont) {
      &expand("(MAPFONT D 0", @fontprops, ")");
      $mapfont = 1;
   }

   if (&inrange($value, $range)) { # adjust values
      print STDERR "Altering properties for character $number\n" if $debug;
      foreach (CHARWD, CHARHT, CHARDP, CHARIC, CHARHS, CHARVS) {
	 $props{$_} = eval $expr{$_}
	    if defined($expr{$_});
      }
   }
   foreach (CHARWD, CHARHT, CHARDP, CHARIC) {
      if ($props{$_}) {
	 push(@_, sprintf("($_ R %.5f)", $props{$_}*$designunits/$designsize));
      }
   }
   push(@thismap, "(SETCHAR $number)") # add default map if necessary
      if !@thismap && ($props{CHARHS} || $props{CHARVS});
   if ($props{CHARHS} > 0) {
      unshift(@thismap, sprintf("(MOVERIGHT R %.5f)",
				$props{CHARHS}*$designunits/$designsize));
   } elsif ($props{CHARVS} < 0) {
      unshift(@thismap, sprintf("(MOVELEFT R %.5f)",
				-$props{CHARHS}*$designunits/$designsize));
   }
   if ($props{CHARVS} > 0) {
      unshift(@thismap, sprintf("(MOVEUP R %.5f)",
				$props{CHARVS}*$designunits/$designsize));
   } elsif ($props{CHARVS} < 0) {
      unshift(@thismap, sprintf("(MOVEDOWN R %.5f)",
				-$props{CHARVS}*$designunits/$designsize));
   }

   @thismap = ("(MAP", @thismap, ")")
      if @thismap;

   &expand("(CHARACTER $number", @_, @thismap, ")");

   %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, printprop,
	   FAMILY, printprop, FACE, printprop, SEVENBITSAFEFLAG, ignore,
	   HEADER, printprop, BOUNDARYCHAR, printprop,
	   VTITLE, vtitle, COMMENT, printprop,
	   FONTDIMEN, printlist, # FONTDIMEN properties follow
	   SLANT, property, SPACE, property, STRETCH, property,
	   SHRINK, property, XHEIGHT, property, QUAD, property,
	   EXTRASPACE, property, NUM1, property, NUM2, property,
	   NUM3, property, DENOM1, property, DENOM2, property,
	   SUP1, property, SUP2, property, SUP3, property,
	   SUB1, property, SUB2, property, SUPDROP, property,
	   SUBDROP, property, DELIM1, property, DELIM2, property,
	   AXISHEIGHT, property, DEFAULTRULETHICKNESS, property,
	   BIGOPSPACING1, property, BIGOPSPACING2, property,
	   BIGOPSPACING3, property, BIGOPSPACING4, property,
	   BIGOPSPACING5, property, PARAMETER, property,
	   LIGTABLE, printlist,	# LIGTABLE properties follow
	   LABEL, property, KRN, property, STOP, property,
	   SKIP, property, LIG, property, '/LIG', property,
	   '/LIG>', property, 'LIG/', property, 'LIG/>', property,
	   '/LIG/', property, '/LIG/>', property,
	   '/LIG/>>', property,
	   MAPFONT, mapfont,	# MAPFONT properties follow
	   FONTDSIZE, property, FONTNAME, property, FONTAREA, property,
	   FONTCHECKSUM, property, FONTAT, property,
	   CHARACTER, character, # CHARACTER properties follow
	   CHARWD, charprop, CHARHT, charprop, CHARDP, charprop,
	   CHARIC, charprop, NEXTLARGER, property,
	   VARCHAR, list,	# VARCHAR properties follow
	   TOP, property, MID, property, BOT, property, REP, property,
	   MAP, map,		# MAP properties follow
	   SELECTFONT, property, SETCHAR, mark,
	   SETRULE, mark, PUSH, mark, POP, mark,
	   MOVERIGHT, moveright, MOVELEFT, moveleft, MOVEUP, moveup,
	   MOVEDOWN, movedown, SPECIAL, mark, SPECIALHEX, mark
	   );

###############################################################################
# Expression checking
###############################################################################

# compileexpr(expr)
# sanitise and convert expression to do-form
sub compileexpr {
   local($expr) = shift;
   local($paren, $operand, $newexpr) = (0, 1);
   foreach (split(/([-()\/*+])/, $expr)) {
      s/\s*//g;			# drop spaces
      next if /^$/;		# ignore empty lines
      if ($operand) {		# operand expected
	 if (/^\d+$/ || /^\d*\.\d+$/) { # constant
	    $newexpr .= $_;
	    $operand = 0;
	 } elsif (/^wd$/ || /^ht$/ || /^dp$/ || /^ic$/ || /^hs$/ || /^vs$/) {
	    tr/a-z/A-Z/;		# uppercase
	    $newexpr .= "\$charprop{CHAR$_}"; # character property
	    $operand = 0;
	 } elsif (/^ds$/) {	# designsize
	    $newexpr .= "\$designsize";
	    $operand = 0;
	 } elsif (/\(/) {	# open parenthesis
	    $newexpr .= $_;
	    $paren++;
	 } elsif (/-/) {	# unary negation
	    $newexpr .= $_;
	 } else {
	    &fatal("Operand expected, got $_ in $expr\n");
	 }
      } else {			# operator expected
	 if (/[-+*\/]/) {	# operator found
	    $newexpr .= $_;
	    $operand = 1;
	 } elsif (/\)/) {	# close parenthesis
	    $newexpr .= $_;
	    &fatal("Unmatched ) in $expr\n") if --$paren < 0;
	 } else {
	    &fatal("Operator expected, got $_ in $expr\n");
	 }
      }	 
   }
   &fatal("Unmatched ( in $expr\n") if $paren;
   print STDERR "Compiled $expr to $newexpr\n" if $debug;
   $newexpr;
}

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

$vtitle = join(' ', $prog, @ARGV); # set VTITLE to arguments
%expr = ();			# property -> expression
$range = '-';			# character range

while (@ARGV) {
   $_ = shift;
 ARGSW:
   {
      /^-quiet$/ && ($quiet = 1, last ARGSW);
      /^-debug$/ && ($debug = 1, last ARGSW);
      /^-range$/ && ($range = shift, last ARGSW);
      /^-(ic|wd|ht|dp|hs|vs)$/ &&
	 (($prop = "CHAR$1") =~ tr/a-z/A-Z/,
	  $expr{$prop} = &compileexpr(shift), last ARGSW);
      if (/^-/) {
	 /^-v$/ && print STDERR "$prog release @RELEASE@\n";
	 print STDERR join("\n",
			   "Usage: $prog [-quiet] [-defenc defaultenc] [-wd expr] [-ht expr] [-dp expr]",
			   "        [-hs expr] [-vs expr] filename\n");
	 exit 1;
      } else {			# filename
	 &fatal('too many property list files specified') if defined($file);
	 $file = $_;
      }
   }
}

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

print "(VTITLE created by $vtitle)\n",
      "(COMMENT $prog is (C) A. J. C. Duggan 1993)\n";

@fontprops = ("(FONTNAME ".&fontname($file).")");

&parsepl($file);		# process PL file

exit 0;				# good termination