JezK
Edit File: mkt1font
#!/usr/bin/perl # Mkt1font: a program to generate accented Type 1 PostScript fonts # Copyright (C) 1997 John D. Smith # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. $version = 0.25; #-----------------------------------------------------------------------------# $description = "Syntax: mkt1font -n fontname -d definition-file -a afm-file -f font-file [-s shrink-factor] [-c candrabindu-adjustment] [-b] Mkt1font creates new Type 1 PostScript fonts based on existing fonts (\"input fonts\"). In order to do this it makes use of I. Lee Hetherington's programs t1asm and t1disasm, which must be present on the system. A successful run will generate an AFM file and a PFB file, as well as a DIS file containing a disassembled version of the PFB file (including useful comments). Four options must be specified on the command line, as follows: -n should name the font it is intended to generate. Avoid names such as \"myfont\", as both mkt1font and other programs attempt to draw conclusions from the name; better would be something like \"Utopia_French-BoldItalic\". The generated font files will also use this for their basename. -d should refer to a font definition file. This file (which could usefully be named, e.g., \"French.def\") should consist of lines of character definitions, in the form \"number\" \"character\" or \"number\" \"character\" \"accent\" Here \"number\" represents the character's position in the new encoding and may be expressed in decimal, octal or hex; \"character\" names the character (e.g. \"comma\", \"eight\", \"A\") or consists of the word \".notdef\" (indicating that the specified number's \"slot\" in the new encoding is to be empty); and \"accent\" optionally names an accent to be placed on the character. In addition to the standard accents available in PostScript fonts, \"underbar\" and \"underdot\" are also available, as are \"under\" versions of all the normal superscript accents (\"underdieresis\", \"underring\", etc.). The Indian accent \"candrabindu\" may also be specified: it is formed by overprinting a breve with a dotaccent. Finally, \"overdot\" may be used as a synonym for \"dotaccent\". If the character named in the \"accent\" position is not in fact a valid accent character, the program interprets the definition as a request for a digraph formed from the \"character\" and the \"accent\". A digraph consisting of, say, \"k\" and \"h\" will be indistinguishable from the letters \"k\" and \"h\" printed consecutively, but the digraph \"kh\" can itself receive accents like any other character: see next paragraph. A new character (such as \"amacron\" or \"kh\") may be freely used in the \"character\" position of a further definition (such as \"amacron breve\" or \"kh underbar\"). There is no constraint on the ordering of definitions within a definition file. The definition of \"a macron\" does not have to precede that of \"amacron breve\": requests for \"impossible\" characters are deferred until their constituents have had a chance to come into being. \"Slots\" for which no new definition is given retain the definition they have in the input font. The definition file may also contain blank lines and comments (introduced by \"\#\"). -a should refer to the AFM (Adobe Font Metrics) file for the input font. -f should refer to the binary font file (PFB) for the input font. (In fact the equivalent ASCII file (PFA) is also acceptable for input, but the output font is always in PFB format.) -s may optionally give the factor, expressed as a per-thousand value, by which normally superscript accents (such as dieresis, ring) should be shrunk when they are used as subscript accents (such as underdieresis, underring). Values of around 800 may be found useful. -c may optionally give two comma-separated numerical values to adjust the x and y coordinates of the dotaccent placed within a breve to form the candrabindu accent. -b may optionally be specified to block the use of predefined accented characters, forcing mkt1font to define its own versions. This may be useful to secure a consistent appearance in cases where a font designer does not share mkt1font's views on where accents should be placed. The -h option prints this help. "; #-----------------------------------------------------------------------------# ######################## # Packages and constants ######################## # use File::Basename; use Getopt::Std; $cmdline = basename($0) . " " . join " ", @ARGV; getopts('n:d:a:f:c:s:bh'); if ($opt_h or !($opt_n && $opt_d && $opt_a && $opt_f) or ($#ARGV >= 0)) { print STDERR $description; exit 1; } ($enc = basename($opt_d)) =~ s/\..*$//; if ($opt_n =~ /\s/) { die "Font name cannot contain whitespace\n" } ($famname = $opt_n) =~ s/^(.*)-.*?$/$1/; if ($opt_s) { $shrink = $opt_s / 1000 } else { $shrink = 1 } @months = ( "January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December" ); @lt = localtime; $date = "$months[$lt[4]] $lt[3], ${ \($lt[5] + 1900) }"; if ($opt_c) { ($cbx, $cby) = $opt_c =~ /^(.*),(.*)$/ } # candrabindu ############### # Read DEF file ############### # open DEF, $opt_d or die "Cannot open $opt_d: $!\n"; while (<DEF>) { next if (/^\s*$/ || /^\#/); s/\s*(\#.*)?$//; push @deflines, $_; } close DEF; ############### # Read AFM file ############### # # File header # open AFM, $opt_a or die "Cannot open $opt_a: $!\n"; while (<AFM>) { if (/^StartFontMetrics/) { $afmhead = $_; do { $_ = <AFM>; $afmhead .= $_; } until $_ =~ /^StartCharMetrics \d+\r?$/; $afmhead =~ s/\r//gm; # Might be DOS file $afmhead =~ /^FontName (.*)$/m; $ofname = $1; $afmbanner = "\nComment Based on $ofname; modified for $enc encoding"; $afmbanner .= "\nComment by John Smiths's program mkt1font "; $afmbanner .= "(v. $version) " if $version; $afmbanner .= "on $date"; $afmbanner .= "\nComment Command line: $cmdline"; $afmhead =~ s/(\n^FontName )(.*)$/$1$opt_n/m; $afmhead =~ s/(\n^FullName )(.*)$/$1$opt_n/m; $afmhead =~ s/(\n^FamilyName )(.*)$/$1$famname/m; $afmhead =~ s/\n^Comment /$afmbanner$&/m; $afmhead =~ s/(\n^EncodingScheme ).*$/$1FontSpecific/m; if ($afmhead =~ /\n^ItalicAngle (.*)$/m) { $italangle = $1 } if ($afmhead =~ /\n^CapHeight (.*)$/m) { $capheight = $1 } if ($afmhead =~ /\n^XHeight (.*)$/m) { $xheight = $1 } if ($afmhead =~ /\n^FontBBox -?\d+ (-?\d+) (-?\d+) (-?\d+)$/m) { ($maxdp, $maxrs, $maxht) = ($1, $2, $3); } } # # Encoded chars # if (/(^C (\d+) ; WX \d+ ; N ([a-zA-Z_][a-zA-Z0-9_.]*|\.notdef) ; B .* ;( L .* ;)?)\r?$/) { $metrics_enc[$2] = "$1\n"; } # # Unencoded chars # elsif (/(^C -1 ; WX \d+ ; N ([a-zA-Z_][a-zA-Z0-9_.]*|\.notdef) ; B .* ;( L .* ;)?)\r?$/) { $metrics_unenc .= "$1\n"; } # # Kerns etc. # if (/^EndCharMetrics\r?$/) { $afmtail = $_; do { $_ = <AFM>; $afmtail .= $_; } until eof(AFM); $afmtail =~ s/[\r\cZ]//gm; # Might be DOS file } } if ($afmtail =~ /(\A(?:.|\n)*^StartKernPairs )\d+\n((?:.|\n)*)(^EndKernPairs(?:.|\n)*\Z)/m) { ($kstart, $kdefs, $kend) = ($1, $2, $3); } close AFM; ############################### # Read and disassemble PFB file ############################### # open PFB, $opt_f or die "Cannot open $opt_f: $!\n"; $_ = <PFB>; unless (/%!/) { die "File $opt_f is not a PostScript font\n" } close PFB; $disfile1 = "mkt1font$$.dis"; system "t1disasm $opt_f >$disfile1 2>/dev/null"; open DIS, $disfile1 or die "Cannot open disassembled font file: $!\n"; while (<DIS>) { # # Locate crucial definitions # if (/^\/(.*?) ?{ ?noaccess def ?} ?executeonly def$/) { $nd = $1; ($rend = $nd) =~ s/\|/\\|/g; # Regexp version next; } if (/^\/(.*?) ?{ ?noaccess put ?} ?executeonly def$/) { $np = $1; ($renp = $np) =~ s/\|/\\|/g; # Regexp version next; } if (/^\/Subrs (\d+) array/) { $subrsnum = $1; do { # # Store subroutine definitions in @subrs # $l = $_ = <DIS>; if (/^dup (\d+) {$/) { $subrnum = $1; $subrdef = $_; do { $_ = <DIS>; $subrdef .= $_; } until /^\t} ?$renp$/; } # # "correct" t1disasm output so t1asm will accept it as input # $subrdef =~ s/^(\t})($rend|$renp)$/$1 $2/m; $subrs[$subrnum] = $subrdef; } until ($l !~ /^dup \d+ {$/); next; } if (/^2 index \/CharStrings (\d+) dict dup begin/) { # # do *not* use "$" to anchor the end of this line, because # it may end with an invisible trailing space! # $chdefsnum = $1; do { # # Store character definitions in %chstrings # $l = $_ = <DIS>; if (/^\/([a-zA-Z_][a-zA-Z0-9_.]*|\.notdef|\.null) {$/) { $chname = $1; $chdef = $_; do { $_ = <DIS>; $chdef .= $_; } until /^\t} ?$rend$/; } # #"correct" t1disasm output so t1asm will accept it as input # $chdef =~ s/^(\t})($rend|$renp)$/$1 $2/m; $chstrings{$chname} = $chdef; } until ($l !~ /^\/([a-zA-Z_][a-zA-Z0-9_.]*|\.notdef|\.null) {$/); # # File tail # if (/^end/) { $distail = $_; do { $_ = <DIS>; $distail .= $_; } until eof(DIS); } } } close DIS; unless ($nd) { die "Cannot find \"noaccess def\" definition\n" } unless ($np) { die "Cannot find \"noaccess put\" definition\n" } unless ($subrsnum) { die "Cannot find size of Subrs array\n" } unless ($chdefsnum) { die "Cannot find size of CharStrings dict\n" } ################## # Set up constants ################## # $subacc = "(cedilla|ogonek|commaaccent)"; $supacc = "(grave|acute|circumflex|tilde|macron|breve|dotaccent|overdot|dieresis|ring|hungarumlaut|caron|candrabindu)"; $underacc = "(underdot|under$supacc)"; $accents = "($subacc|$supacc|$underacc|underbar)"; $underadp = -230; # depth of "under" accs $underddp = -213; # depth of underdot if ($opt_n =~ /Bold/) { $thk = 72 } else { $thk = 52 } # thickness and $underbdp = -(82 + $thk); # depth of underbar getcharinfo("macron"); $accheight = $chht{macron}; # height of macron $accdepth = $chdp{macron}; # "depth" of macron $v1 = $accheight - $xheight; # vertical offset for double accents $v2 = $capheight - $xheight; # vertical offset for accented caps etc # # Italic adjustment: tan(angle) # $itadj = sin($italangle * 3.14159 / 180) / cos($italangle * 3.14159 / 180); ########################### # Create uni0237 (dotlessj) ########################### # $chstrings{uni0237} = $chstrings{j} . "\n"; $chstrings{uni0237} =~ /\A(.*?)(\t[-0-9 ]+?[rvh]moveto)(\n.+)(\n\t.*?(-?\d+) [rv]moveto)(.*?)(\n\tendchar.*?)\Z/ms; ($one, $two, $three, $four, $five, $six, $seven) = ($1, $2, $3, $4, $5, $6, $7); if ($five > 0) { $chstrings{uni0237} = $one . $two . $three . $seven } else { findend("j1", ($two . $three)); $j1end = "\t$hend{j1} $vend{j1} rmoveto"; $chstrings{uni0237} = $one . $j1end . $four . $six . $seven } $chstrings{uni0237} =~s/\A\/j /\/uni0237 /m; getcharinfo("j"); getcharinfo("dotlessi"); $metrics_unenc .= "C -1 ; WX $chwd{j} ; N uni0237 ; B $chls{j} $chdp{j} $chrs{j} $chht{dotlessi} ;\n"; # ###################### # Build the characters ###################### # # First build a list of definitions supplied by user # for (@deflines) { if (/^\s*(\d+|0[0-7]+|0x[0-9a-fA-F]+)\s+([a-zA-Z_][a-zA-Z0-9_.]*?|\.notdef)(?:\s+([a-zA-Z_][a-zA-Z0-9_.]*))?$/) { ($num, $char, $acc) = ($1, $2, $3); $num = oct $num if $num =~ /^0/; if ($num > 255) { die "Bad definition (number out of range): $_\n" } $def = {}; $def->{qdef} = $_; $def->{num} = $num; $def->{char} = $char; $def->{acc} = $acc; $def->{nchar} = $char . $acc; push @nchars, $def->{nchar}; push @defs, $def; } else { die "Bad definition: $_\n" } } # # Work through the list # while (@defs) { $def = shift @defs; $qdef = $def->{qdef}; $num = $def->{num}; $char = $def->{char}; $acc = $def->{acc}; $nchar = $def->{nchar}; # # If we can't handle $char/$acc yet, but believe we will be able # to later, send the definition to the back of the queue. In case # it later turns out we were wrong, allow only five loops before # giving up. # if (!grep / ; N $char ; /, @metrics_enc and $metrics_unenc !~ / ; N $char ; /m) { if (grep /^$char$/, @nchars) { unless (++$def->{requeue} > 5) { push @defs, $def; next; } } else { die "Bad definition (no such character): $qdef\n" } } if ($acc and !grep / ; N $acc ; /, @metrics_enc and $metrics_unenc !~ / ; N $acc ; /m and $acc !~ /^$accents$/) { if (grep /^$acc$/, @nchars) { unless (++$def->{requeue} > 5) { push @defs, $def; next; } } else { die "Bad definition (no such accent): $qdef\n" } } # # First deal with .notdef # if ($nchar eq ".notdef") { ($old = $metrics_enc[$num]) =~ s/^C $num/C -1/; $metrics_unenc .= $old unless $metrics_unenc =~ /$old/m; undef $metrics_enc[$num]; } # # Now look for new char among existing encoded chars (unless blocked by -b) # else { if (!($acc and $opt_b) and @foundit = grep / ; N $nchar ; /, @metrics_enc) { ($foundit = shift @foundit) =~ s/^C (\d+)/C $num/; $prevnum = $1; unless ($prevnum == $num) { ($old = $metrics_enc[$num]) =~ s/^C $num/C -1/; $metrics_unenc .= $old unless $metrics_unenc =~ /$old/m; $metrics_enc[$num] = $foundit; } fixkerns($char, $acc); } # # Next look among existing unencoded chars (unless blocked by -b) # elsif (!($acc and $opt_b) and $metrics_unenc =~ s/^C -1 ; WX \d+ ; N $nchar ; B .* ;( L .* ;)?\n//m) { ($foundit = $&) =~ s/^C -1/C $num$1/m; $old = $metrics_enc[$num]; if ($old) { $old =~ s/^C $num/C -1/; $metrics_unenc .= $old unless $metrics_unenc =~ /$old/m; } $metrics_enc[$num] = $foundit; fixkerns($char, $acc); } # # If it can't be built from sub-elements, issue a warning and move on # elsif (!$acc) { warn "No such character - ignoring definition: $qdef\n" } # # Now build the char # else { # # First get rid of predefined afm entries and synonyms # $metrics_unenc =~ s/^C -1 ; WX \d+ ; N $nchar ; B .* ;( L .* ;)?\n//m; $kdefs =~ s/\nKPX .*$nchar .*$//gm; if ($acc eq "overdot") { $nchar2 = $char . "dotaccent"; $metrics_unenc =~ s/^C -1 ; WX \d+ ; N $nchar2 ; B .* ;( L .* ;)?\n//m; $kdefs =~ s/\nKPX .*$nchar2 .*$//gm; delete $chstrings{$nchar2}; } # # Go! # if ($acc =~ /^$subacc$/) { subacc($num, $char, $acc, $nchar); fixkerns($char, $acc); } elsif ($acc =~ /^$supacc$/) { supacc($num, $char, $acc, $nchar); fixkerns($char, $acc); } elsif ($acc =~ /^$underacc$/) { underacc($num, $char, $acc, $nchar); fixkerns($char, $acc); } elsif ($acc =~ /^underbar$/) { underb($num, $char, $nchar); fixkerns($char, $acc); } else { digraph($num, $char, $acc, $nchar); fixkerns($char, $acc); } } } } ################ # Write AFM file ################ # open OUTAFM, ">$opt_n.afm"; foreach (@metrics_enc) { # Avoid duplicate entries ($chname) = /( ; N [a-zA-Z_][a-zA-Z0-9_.]* ; )/; $metrics_unenc =~ s/^C -1 .*$chname.*\n//gm if $chname; } $chmetricnum = split(/\n/, $metrics_unenc); $chmetricnum += grep /^C /, @metrics_enc; $afmhead =~ s/^(FontBBox -?\d+ )-?\d+ -?\d+ -?\d+$/$1$maxdp $maxrs $maxht/m; $afmhead =~ s/^(StartCharMetrics )\d+$/$1$chmetricnum/m; $encoding = "/Encoding 256 array\n0 1 255 {1 index exch /.notdef put} for\n"; print OUTAFM $afmhead; for $i (0 .. 255) { $line = $metrics_enc[$i]; if ($line) { print OUTAFM $line; if ($line =~ /^C \d+ ; WX \d+ ; N ([a-zA-Z_][a-zA-Z0-9_.]*) ; /) { $encoding .= "dup $i /$1 put\n"; } } } $encoding .= "readonly def\n"; print OUTAFM $metrics_unenc; # # Tidy up kerns # if ($kdefs) { $kdefs = join("\n", sort split /\n/, $kdefs); # sort $kdefs .= "\n"; $kdefs =~ s/((^KPX .*?)-?\d+$)\n\2.*$/$1/gm; # remove duplicates $kdefs =~ s/^\s*\n//gm; # and blank lines $knum = split(/\n/, $kdefs); $afmtail = $kstart . $knum . "\n" . $kdefs . $kend; } # # Eliminate composite character definitions # $afmtail =~ s/\n(Start|End)Composites.*$//gm; $afmtail =~ s/\nCC .*;$//gm; print OUTAFM $afmtail; close OUTAFM; ######################### # Write DIS and PFB files ######################### # $disfile2 = "$opt_n.dis"; open OUTDIS, ">$disfile2"; $disbanner = "% Based on $ofname; modified for $enc encoding\n"; $disbanner .= "% by John Smiths's program mkt1font "; $disbanner .= "(v. $version) " if $version; $disbanner .= "on $date\n"; $disbanner .= "% Command line: $cmdline"; open DIS, $disfile1; while (<DIS>) { # get header s/^(%!.*: ).*$/$1$opt_n\n$disbanner/; s/(\/FullName \().*(\).*)$/$1$opt_n$2/; s/(\/FamilyName \().*(\).*)$/$1$famname$2/; s/(\/FontName \/).*?( .*)$/$1$opt_n$2/; s/(\/FontBBox {-?\d+ )-?\d+ -?\d+ -?\d+/$1$maxdp $maxrs $maxht/m; if (/^\/Encoding /) { print OUTDIS $encoding; next; } next if (/\/UniqueID .*$/); s /(\/BlueValues \[.*)(\] def)$/$1 $accheight $accheight$2/; if (/(\/Subrs )\d+( array)$/) { print OUTDIS "$1$subrsnum$2\n"; last; } else { print OUTDIS } } close DIS; unlink $disfile1; foreach $subrdef (@subrs) { print OUTDIS $subrdef } $chdefsnum = scalar(keys(%chstrings)); print OUTDIS "$nd\n2 index /CharStrings $chdefsnum dict dup begin\n"; foreach (sort values %chstrings) { print OUTDIS } print OUTDIS $distail; close OUTDIS; system "t1asm -b $disfile2 >$opt_n.pfb 2>/dev/null"; ##################### # End of main program ##################### sub subacc { # # Subscript accents # my ($num, $char, $acc, $nchar) = @_; my ($old, $astr, $h, $H, $V, $chdef, $acdef, $pstr); ($old = $metrics_enc[$num]) =~ s/^C $num/C -1/; $metrics_unenc .= $old unless $metrics_unenc =~ /$old/m; getcharinfo($char) unless defined $chwd{$char}; getcharinfo($acc) unless defined $chwd{$acc}; $astr = "C $num ; WX $chwd{$char} ; N $nchar ; B $chls{$char} "; $astr .= "$chdp{$acc} $chrs{$char} $chht{$char} ;\n"; $metrics_enc[$num] = $astr; $h = round(($chwd{$char} - $chwd{$acc}) / 2 + $chls{$acc}); unless (defined $hend{$char}) { findend($char, $chstrings{$char}) } $H = $h - $hend{$char} - $chls{$char}; $V = -$vend{$char}; $chstrings{$char} =~ /^\/$char {\n(\t.+?hsbw\n(.|\n)*?)\tendchar\n\t} $rend\n/m; $chdef = $1; $chstrings{$acc} =~ /^\/$acc {\n\t.+? .+?hsbw\n((.|\n)+?\t} $rend\n)/m; $acdef = $1; $acdef = fixhints($nchar, $acc, $acdef, $h, 0); $pstr = "/$nchar {\n$chdef % $nchar: start of $acc\n"; $pstr .= "\t$H $V rmoveto\n$acdef"; $chstrings{$nchar} = $pstr; } sub supacc { # # Superscript accents # my ($num, $char, $acc, $nchar) = @_; my ($old, $cb, $astr, $h, $v, $H, $V, $it, $chdef, $acdef, $pstr, $newchar); ($old = $metrics_enc[$num]) =~ s/^C $num/C -1/; $metrics_unenc .= $old unless $metrics_unenc =~ /$old/m; if ($char eq "i") { $char = "dotlessi" } if ($char eq "j") { $char = "uni0237" } if ($acc eq "overdot") { $acc = "dotaccent" } if ($acc eq "candrabindu") { $acc = "breve"; $chstrings{"dotaccent"} =~ /^\/dotaccent {\n\t.+? .+?hsbw\n((.|\n)+?\t} $rend\n)/m; $cb = $1; } getcharinfo($char) unless defined $chwd{$char}; getcharinfo($acc) unless defined $chwd{$acc}; $astr = "C $num ; WX $chwd{$char} ; N $nchar ; B "; $astr .= "$chls{$char} $chdp{$char} $chrs{$char} "; $v = $chht{$acc}; if ($chht{$char} >= $accheight + $v2) { # double accs $v += ($v1 + $v2); # on caps etc. $it = ($v1 + $v2) * $itadj; } elsif ($chht{$char} > 1.15 * $xheight) { if ($char =~ /$supacc$/ and $char !~ /under$supacc$/) { $v += $v1; # double accents $it = $v1 * $itadj; } else { $v += $v2; # accented caps etc. $it = $v2 * $itadj; } } else { $it = 0 } if ($v > $maxht) { $maxht = $v } $astr .= "$v ;\n"; $metrics_enc[$num] = $astr; $v -= $chht{$acc}; $h = round(($chwd{$char} - $chwd{$acc}) / 2 + $chls{$acc} - $it); unless (defined $hend{$char}) { findend($char, $chstrings{$char}) } $H = $h - $hend{$char} - $chls{$char}; $V = $v - $vend{$char}; $chstrings{$char} =~ /^\/$char {\n(\t.+?hsbw\n(.|\n)*?)\tendchar\n\t} $rend\n/m; $chdef = $1; $chstrings{$acc} =~ /^\/$acc {\n\t.+? .+?hsbw\n((.|\n)+?\t} $rend\n)/m; $acdef = $1; $acdef = fixhints($nchar, $acc, $acdef, $h, $v); $pstr = "/$nchar {\n$chdef % $nchar: start of $acc\n"; $pstr .= "\t$H $V rmoveto\n$acdef"; if ($cb) { # candrabindu getcharinfo("dotaccent") unless defined $chwd{dotaccent}; $h = round(($chwd{$char} - $chwd{dotaccent}) / 2 + $chls{dotaccent} - $it); $h += $cbx; $v += $cby; $cb = fixhints($nchar, "dotaccent", $cb, $h, $v); $newchar = $char . $acc; unless (defined $hend{$newchar}) { findend($newchar, $pstr) } $H = $h - $hend{$newchar} - $chls{$char}; $V = $v - $vend{$newchar}; $pstr =~ s/\tendchar\n\t} $rend\n\Z//m; $pstr .= " % $nchar: start of dotaccent\n\t$H $V rmoveto\n$cb"; } $chstrings{$nchar} = $pstr; } sub underacc { # # Dropped accents # # The Fontographer hack below is necessary because Fontographer (which # I have had to use to build TrueType and Macintosh versions of fonts) # seems not to respect the depths for characters specified in afm files # it has imported: it sets the depth to the lowest point in the path, # whether or not a mark was made there. So it is not possible to # implement (e.g.) underring by diving down low and then printing a # ring at its normal height. # my ($num, $char, $acc, $nchar) = @_; my ($old, $acname, $astr, $h, $v, $H, $V, $chdef, $acdef, $begin, $line, $end, $pstr); ($old = $metrics_enc[$num]) =~ s/^C $num/C -1/; $metrics_unenc .= $old unless $metrics_unenc =~ /$old/m; $acc =~ s/^under//; $acname = $acc; if ($acc eq "dot") { $acc = "period" } if ($acc eq "candrabindu") { die "Bad definition (no such accent): $qdef\n" } getcharinfo($char) unless defined $chwd{$char}; getcharinfo($acc) unless defined $chwd{$acc}; if ($acc =~ /^$supacc$/) { $v = round($underadp + ($chdp{$acc} - $accdepth) * $shrink); } else { $v = $underddp + $chdp{$acc} } if ($v < $maxdp) { $maxdp = $v } $astr = "C $num ; WX $chwd{$char} ; N $nchar ; B $chls{$char} "; $astr .= "$v $chrs{$char} $chht{$char} ;\n"; $metrics_enc[$num] = $astr; if ($acc =~ /^$supacc$/) { $h = round(($chwd{$char} - ($chwd{$acc} * $shrink)) / 2 + $chls{$acc} * $shrink - ($v - $accdepth * $shrink) * $itadj); } else { $h = round(($chwd{$char} - $chwd{$acc}) / 2 + $chls{$acc} - $v * $itadj); } unless (defined $hend{$char}) { findend($char, $chstrings{$char}) } $H = $h - $hend{$char} - $chls{$char}; if ($acc =~ /^$supacc$/) { $V = $underadp - $vend{$char} } else { $V = $v - $chdp{$acc} - $vend{$char} } # # Adjustment for smaller, therefore lower, shrunken accent defs # if ($acc =~ /^$supacc$/) { $V += round($chdp{$acc} * (1 - $shrink) / $shrink); } $chstrings{$char} =~ /^\/$char {\n(\t.+?hsbw\n(.|\n)*?)\tendchar\n\t} $rend\n/m; $chdef = $1; $chstrings{$acc} =~ /^\/$acc {\n\t.+? .+?hsbw\n((.|\n)+?\t} $rend\n)/m; $acdef = $1; if ($acc =~ /^$supacc$/ and $opt_s) { $acdef = fixshrink($acc, $acdef) } if ($acc =~ /^$supacc$/) { $acdef = fixhints($nchar, $acc, $acdef, $h, $underadp); } else { $acdef = fixhints($nchar, $acc, $acdef, $h, $underddp) } # # Bloody Fontographer! We can't just say # if ($acc =~ /^$supacc$/) { $V -= $accdepth } # Instead we have to go through the following rigmarole: # if ($acc =~ /^$supacc$/) { if ($acdef =~ /^(.*moveto)$/m) { ($begin, $line, $end) = ($`, $1, $'); if ($line =~ /^\t(-?\d+) (-?\d+)( rmoveto)$/) { $acdef = "$begin\t$1 " . ($2 - $accdepth) . $3 . $end; } elsif ($line =~ /^\t(-?\d+)( vmoveto)$/) { $acdef = "$begin\t" . ($1 - $accdepth) . $2 . $end; } elsif ($line =~ /\t(-?\d+) hmoveto$/) { $acdef = "$begin\t$1 " . (-$accdepth) . "rmoveto" . $end; } } else { $acdef =~ s/\A/\t-$accdepth vmoveto\n/m } } $pstr = "/$nchar {\n$chdef % $nchar: start of $acname\n"; $pstr .= "\t$H $V rmoveto\n$acdef"; $chstrings{$nchar} = $pstr; } sub underb { # # Underbar # my ($num, $char, $nchar) = @_; my ($old, $astr, $l, $h, $v, $H, $V, $bdef, $chdef, $acdef, $pstr); ($old = $metrics_enc[$num]) =~ s/^C $num/C -1/; $metrics_unenc .= $old unless $metrics_unenc =~ /$old/m; $v = $underbdp + $thk; getcharinfo($char) unless defined $chwd{$char}; $h = round(0.1 * $chwd{$char} - $underbdp * $itadj); $l = round(0.8 * $chwd{$char}); $astr = "C $num ; WX $chwd{$char} ; N $nchar ; B $chls{$char} "; $astr .= "$underbdp $chrs{$char} $chht{$char} ;\n"; $metrics_enc[$num] = $astr; unless (defined $hend{$char}) { findend($char, $chstrings{$char}) } $H = $h - $hend{$char} - $chls{$char}; $V = -$vend{$char}; $bdef = "\t$underbdp $thk hstem\n\t$v vmoveto\n\t-$thk vlineto\n\t"; $bdef .= "$l hlineto\n\t$thk vlineto\n\tclosepath\n"; $chstrings{$char} =~ /^\/$char {\n(\t.+?hsbw\n(.|\n)*?)\tendchar\n\t} $rend\n/m; $chdef = $1; $acdef = fixhints($nchar, "underbar", $bdef, $h, 0); $pstr = "/$nchar {\n$chdef % $nchar: start of $acc\n"; $pstr .= "\t$H $V rmoveto\n$acdef\tendchar\n\t} $nd\n"; $chstrings{$nchar} = $pstr; } sub digraph { # # Make a new character consisting of two existing characters # my ($num, $char, $acc, $nchar) = @_; my ($old, $kern, $w, $newrs, $astr, $H, $V, $chdef, $acdef, $pstr); ($old = $metrics_enc[$num]) =~ s/^C $num/C -1/; $metrics_unenc .= $old unless $metrics_unenc =~ /$old/m; getcharinfo($char) unless defined $chwd{$char}; getcharinfo($acc) unless defined $chwd{$acc}; if ($kdefs =~ /^KPX $char $acc (-?\d+)$/m) { $kern = $1 }; $w = $chwd{$char} + $chwd{$acc} + $kern; $newrs = $chrs{$char} + $chwd{$acc} + $kern; if ($newrs > $maxrs) { $maxrs = $newrs } $astr = "C $num ; WX " . $w . " ; N $nchar ; B $chls{$char} "; $astr .= (min($chdp{$char}, $chdp{$acc})) . " $newrs "; $astr .= (max($chht{$char}, $chht{$acc})) . " ;\n"; $metrics_enc[$num] = $astr; unless (defined $hend{$char}) { findend($char, $chstrings{$char}) } $H = $chwd{$char} + $chls{$acc} + $kern - $hend{$char}; $V = -$vend{$char}; $chstrings{$char} =~ /^\/$char {\n(\t.+?hsbw\n(.|\n)*?)\tendchar\n\t} $rend\n/m; ($chdef = $1) =~ s/-?\d+( hsbw\n)/$w$1/m; $chstrings{$acc} =~ /^\/$acc {\n\t.+? .+?hsbw\n((.|\n)+?\t} $rend\n)/m; $acdef = $1; $acdef = fixhints($nchar, $acc, $acdef, ($chwd{$char} + $kern), 0); $pstr = "/$nchar {\n$chdef % $nchar: start of $acc\n"; $pstr .= "\t$H $V rmoveto\n$acdef"; $chstrings{$nchar} = $pstr; } sub max { # # Return greater of two values # my ($a, $b) = @_; return $a > $b ? $a : $b; } sub min { # # Return lesser of two values # my ($a, $b) = @_; return $a > $b ? $b : $a; } sub round { # # Return nearest integer value # my ($num) = shift; my $n1, $n2; if ($num < 0) { $n1 = (0 - $num) } else { $n1 = $num } $n2 = int($n1); if (($n1 - $n2) >= 0.5) { $n2++ } if ($num < 0) { return (0 - $n2) } else { return $n2 } } sub getcharinfo { # # Store character metric information # my $char = shift; my $foundit; my $metrics_all = join("", @metrics_enc) . $metrics_unenc; if ($metrics_all =~ /^.* ; N $char ; .*$/m) { $foundit = $& } else { die "Bad definition (no such character/accent): $char\n" } $foundit =~ /^C (-?\d+) ; WX (\d+) ; N $char ; B (.+?) (.+?) (.+?) (.+?) ;/; ($chnum{$char}, $chwd{$char}, $chls{$char}, $chdp{$char}, $chrs{$char}, $chht{$char}) = ($1, $2, $3, $4, $5, $6); } sub fixkerns { # # Generalise the kerning info contained in the afm file by applying # it to new accented chars. Do not kern lower-case chars bearing # superscript accents with capitals, quotes or a preceding "f". # my ($char, $acc) = @_; my ($lchar, $rchar); if ($acc =~ /^$accents$/) { $lchar = $rchar = $char } else { $lchar = $char; $rchar = $acc; } if ($char =~ /^[a-z]/ and $acc =~ /^$supacc$/) { if ($kdefs =~ /^(KPX $char)(( (?:[a-pr-z][a-zA-Z]*|q(?!uote).*?) )-?\d+)$/m) { ($one, $three) = ($1, $3); $kdefs =~ s[^(KPX $char)(( (?:[a-pr-z][a-zA-Z]*|q(?!uote).*?) )-?\d+)$] [$&\n$1$acc$2]gm unless $kdefs =~ /^$one$acc$three/m; } if ($kdefs =~ /^(KPX (?:[a-eg-pr-z][a-zA-Z]*|q(?!uote).*?) $char)( -?\d+)$/m) { $one = $1; $kdefs =~ s[^(KPX (?:[a-eg-pr-z][a-zA-Z]*|q(?!uote).*?) $char)( -?\d+)$] [$&\n$1$acc$2]gm unless $kdefs =~ /^$one$acc /m; } } else { if ($kdefs =~ /^(KPX )$rchar(( [a-zA-Z]+ )-?\d+)$/m) { ($one, $three) = ($1, $3); $kdefs =~ s[^(KPX )$rchar(( [a-zA-Z]+ )-?\d+)$] [$&\n$1$char$acc$2]gm unless $kdefs =~ /^$one$char$acc$three/m; } if ($kdefs =~ /^(KPX [a-zA-Z]+ )$char( -?\d+)$/m) { $one = $1; $kdefs =~ s[^(KPX [a-zA-Z]+ )$char( -?\d+)$] [$&\n$1$char$acc$2]gm unless $kdefs =~ /^$one$char$acc /m; } } } sub fixshrink { # # Multiply all coordinates in a character definition by $shrink, # creating new subroutines as necessary. # my ($ch, $chdef) = @_; my (@chdef, $line, $snum, $subrdef); @chdef = split(/\n/, $chdef); $chdef = ""; foreach $line (@chdef) { if ($line =~ /^\t(\d+) .*call(other)?subr$/) { $snum = $1; $subrdef = $subrs[$snum]; $subrdef = fixshrink($ch, $subrdef); $subrdef =~ s/^(dup )$snum \{$/$1$subrsnum {\n % $nchar: shrink $ch/m; $subrs[$subrsnum] = $subrdef; $line =~ s/^\t$snum/\t$subrsnum/; $subrsnum++; } else { $line =~ s/-?\d+/int($& * $shrink)/ge unless $line =~ /^dup / } $chdef .= "$line\n"; } return $chdef; } sub fixhints { # # First adjust any Flex "0 callsubr" lines for horizontal and # vertical offset. Then collect the hints from the accent definition, # remove them, adjust for horizontal and vertical offset, and # place them in a numbered subroutine. Have the definition call # the subroutine. # my ($nchar, $acc, $acdef, $h, $v) = @_; my $subrdef; $acdef =~ s[^(\t-?\d+ )(-?\d+) (-?\d+)( 0 callsubr)$] [$1 . ($2 + $h) . " " . ($3 + $v) . $4]gme; if ($subrdef = join("\n", grep /^\t.*[hv]stem$/, split(/\n/, $acdef))) { $acdef = join("\n", grep !/^\t.*[hv]stem$/, split(/\n/, $acdef)) . "\n"; } elsif ($acdef =~ s/\A(?:\t(\d+) callsubr\n)((?:.|\n)*)\Z/$2/m) { $subrdef = $subrs[$1]; $subrdef = join("\n", grep /^\t.*[hv]stem$/, split(/\n/, $subrdef)) } $subrdef =~ s/^(\t)(-?\d+)( .*hstem)$/$1 . ($2 + $v) . $3/gme; $subrdef =~ s/^(\t)(-?\d+)( .*vstem)$/$1 . ($2 + $h) . $3/gme; if ($subrdef) { $subrs[$subrsnum] = "dup $subrsnum {\n % $nchar: hints for $acc\n"; $subrs[$subrsnum] .= "$subrdef\n\treturn\n\t} $np\n"; $acdef = "\t$subrsnum 1 3 callothersubr\n\tpop\n\tcallsubr\n" . $acdef; $subrsnum++; } return $acdef; } sub findend { # # Calculate the current point reached at the end of the character # definition. Place the horizontal offset in $hend{$char}, the # vertical offset in $vend{$char}. # my ($char, $def) = @_; my $line; foreach $line (split /\n/, $def) { SWITCH: { $line =~ /^\t(-?\d+) h(line|move)to$/ && do { $hend{$char} += $1; last SWITCH; }; $line =~ /^\t(-?\d+) v(line|move)to$/ && do { $vend{$char} += $1; last SWITCH; }; $line =~ /^\t(-?\d+) (-?\d+) r(line|move)to$/ && do { $hend{$char} += $1; $vend{$char} += $2; last SWITCH; }; $line =~ /^\t(-?\d+) (-?\d+) (-?\d+) (-?\d+) hvcurveto$/ && do { $hend{$char} += ($1 + $2); $vend{$char} += ($3 + $4); last SWITCH; }; $line =~ /^\t(-?\d+) (-?\d+) (-?\d+) (-?\d+) vhcurveto$/ && do { $hend{$char} += ($2 + $4); $vend{$char} += ($1 + $3); last SWITCH; }; $line =~ /^\t(-?\d+) (-?\d+) (-?\d+) (-?\d+) (-?\d+) (-?\d+) rrcurveto$/ && do { $hend{$char} += ($1 + $3 + $5); $vend{$char} += ($2 + $4 + $6); last SWITCH; }; $line =~ /^\t(\d+) callsubr$/ && do { findend($char, $subrs[$1]); last SWITCH; }; $line =~ /^\t-?\d+ (-?\d+) (-?\d+) 0 callsubr$/ # Flex && do { $hend{$char} = $1; $vend{$char} = $2; last SWITCH; }; } } }