diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /fonts/utilities/vplutils/makevpl.pl |
Initial commit
Diffstat (limited to 'fonts/utilities/vplutils/makevpl.pl')
-rw-r--r-- | fonts/utilities/vplutils/makevpl.pl | 628 |
1 files changed, 628 insertions, 0 deletions
diff --git a/fonts/utilities/vplutils/makevpl.pl b/fonts/utilities/vplutils/makevpl.pl new file mode 100644 index 0000000000..d0812ccf10 --- /dev/null +++ b/fonts/utilities/vplutils/makevpl.pl @@ -0,0 +1,628 @@ +#!@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 |