diff options
author | Karl Berry <karl@freefriends.org> | 2009-04-10 23:37:36 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2009-04-10 23:37:36 +0000 |
commit | c1d46af88c872513681359f3318adf75eff204e6 (patch) | |
tree | 202d1e8a757550ae18d69a6dafe5e79d9a3b072e /Master/texmf-dist/doc/fonts/accfonts | |
parent | 62492735ac0c6382dbfb0dcfc2c5480eaa295b37 (diff) |
accfonts scripts in scripts/ (report from Robin Fairbairns, 10 Apr 2009 10:16:31)
git-svn-id: svn://tug.org/texlive/trunk@12685 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/texmf-dist/doc/fonts/accfonts')
-rwxr-xr-x | Master/texmf-dist/doc/fonts/accfonts/mkt1font | 1012 | ||||
-rwxr-xr-x | Master/texmf-dist/doc/fonts/accfonts/vpl2ovp | 1085 | ||||
-rwxr-xr-x | Master/texmf-dist/doc/fonts/accfonts/vpl2vpl | 994 |
3 files changed, 0 insertions, 3091 deletions
diff --git a/Master/texmf-dist/doc/fonts/accfonts/mkt1font b/Master/texmf-dist/doc/fonts/accfonts/mkt1font deleted file mode 100755 index 966ba5932d9..00000000000 --- a/Master/texmf-dist/doc/fonts/accfonts/mkt1font +++ /dev/null @@ -1,1012 +0,0 @@ -#!/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; - }; - } - } -} diff --git a/Master/texmf-dist/doc/fonts/accfonts/vpl2ovp b/Master/texmf-dist/doc/fonts/accfonts/vpl2ovp deleted file mode 100755 index eb88bfd3dda..00000000000 --- a/Master/texmf-dist/doc/fonts/accfonts/vpl2ovp +++ /dev/null @@ -1,1085 +0,0 @@ -#!/usr/bin/perl - -# Vpl2ovp: a program to generate accented virtual fonts for Omega -# Copyright (C) 2008 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: vpl2ovp -d definition-file [-s shrink-factor] - [-c candrabindu-adjustment] [-b] vpl-file - -Vpl2ovp creates new Omega virtual fonts based on existing TeX -fonts or virtual fonts (\"input fonts\"). A successful run will -read a pl (Property List) or vpl (Virtual Property List) file -and a definition file, and will generate a new ovp (Omega -Virtual Property List) file on standard output. The input font -is assumed to adhere to the standard TeX encoding for text -fonts unless it was created with either of the programs afm2pl -or afm2tfm, in which case it is assumed to conform to -(respectively) the Adobe Standard Encoding or the encoding -specified in the file dvips.enc. In either case, the name of -the input font is assumed to be the name of the input file -without its .vpl or .pl extension: it must conform to normal -TeX conventions for naming fonts, as vpl2ovp attempts to draw -conclusions from it about the kind of font it is dealing with. - -A typical complete sequence of commands to create a new virtual -font might therefore be - tftopl cmr10.tfm cmr10.pl - vpl2ovp -d Unicode1.def cmr10.pl >cmr10-uni1.ovp - ovp2ovf cmr10-uni1.ovp cmr10-uni1.ovf cmr10-uni1.ofm -for a Computer Modern font, or - afm2pl Times-Roman.afm rptmr.pl - pltotf rptmr.pl rptmr.tfm - vpl2ovp -d Unicode1.def rptmr.pl >ptmr-uni1.ovp - ovp2ovf ptmr-uni1.ovp ptmr-uni1.ovf ptmr-uni1.ofm -for a PostScript font. - -Another approach for a PostScript font is to use afm2tfm: - afm2tfm Times-Roman.afm -t dvips.enc -v ptmr rptmr - vpl2ovp -d Unicode1.def ptmr.vpl >ptmr-uni1.ovp - ovp2ovf ptmr-uni1.ovp ptmr-uni1.ovf ptmr-uni1.ofm --- but this is now deprecated, as afm2tfm generates incorrect -values for the heights of some characters, and this can lead to -bad accent placing. - -In order to keep the whole of the character range \"F0-\"FF free for -the requirements of the encoding specified in the definition file, -certain modifications are made to input fonts following the dvips.enc -encoding to bring them into greater conformity with the TeX norm. In -particular, the characters dotaccent and hungarumlaut are placed in -the positions assigned by TeX (\"5F, \"7D), not those enforced by -dvips.enc (\"C7, \"CD). The f-ligatures, double quotes and dashes are -also moved from the upper half of the original 8-bit character set to -their normal TeX positions. As a result, the following characters are -not found in the lower half of the character set: quotesingle, -quotedbl, backslash, underscore, braceleft, bar, braceright. These -characters can, however, be assigned positions in the output font if -they are needed. (Indeed, they could all be explicitly restored to -their dvips.enc positions if this were desired.) - -Options: - - -d should refer to a font definition file. This file (which could - usefully be named, e.g., \"Unicode1.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\". - - Note that all accents used in defining accented characters must - themselves be defined in the .def file. Those which exist in the - source font should simply be referenced by name in their - appropriate Unicode position (e.g. \"0x0304 macron\"); those - which do not should be defined as the character \"space\" - followed by the name of the accent (e.g. \"0x0310 space - candrabindu\"). - - 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 \"\#\"). - - -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. A coordinate scheme using - \"DESIGNUNITS R 1000\" is assumed. - - -b may optionally be specified to block the use of predefined - accented characters, forcing vpl2ovp to define its own - versions. This may be useful to secure a consistent appearance - in cases where a font designer does not share vpl2ovp's views - on where accents should be placed. - - -h prints this help. -"; -#------------------------------------------------------------------------# - -######################## -# Packages and constants -######################## -# -use File::Basename; -use Getopt::Std; -$cmdline = basename($0) . " " . join " ", @ARGV; -getopts('d:s:c:bh'); -if ($opt_h or !$opt_d or $#ARGV != 0) { - print STDERR $description; - exit 1; -} - -$filename = $ARGV[0]; -$dummycodepoint = 0xF8FF; -($fontname = $filename) =~ s/\..*$//; -($encname = basename($opt_d)) =~ s/\..*$//; -$vtitle = "(VTITLE Font $fontname modified for $encname encoding by vpl2ovp"; -$vtitle .= " v. $version" if $version; -$vtitle .= ")\n(COMMENT Command line: $cmdline)"; -$vtitle .= "\n(OFMLEVEL H 0)"; - -# -# Flags for bold and small caps. These are probably a bit iffy, but -# there's not much that can be done about it. -# -if ($fontname =~ /(^p.*b[oi]?[c]?$|^[^p].*bx[a-z]*[0-9]+$)/) { $bold = 1 } -if ($fontname =~ /(^p.*c$|^[^p].*csc[a-z]*[0-9]+$)/) { $scaps = 1 } -if ($opt_s) { $shrink = $opt_s / 1000 } else { $shrink = 1 } - -# -# Array to convert from number to vpl representation -# -foreach $i (0 .. 0xFFFF) { - $nv[$i] = (chr($i) =~ /[0-9A-Za-z]/ ? "C " . chr $i : sprintf("H %04lX", $i)); -} - -# -# Now the encoding vectors. -# -@TeXenc = ( - "Gamma", "Delta", "Theta", "Lambda", - "Xi", "Pi", "Sigma", "Upsilon", - "Phi", "Psi", "Omega", "ff", - "fi", "fl", "ffi", "ffl", - "dotlessi", "dotlessj", "grave", "acute", - "caron", "breve", "macron", "ring", - "cedilla", "germandbls", "ae", "oe", - "oslash", "AE", "OE", "Oslash", - "space", "exclam", "quotedblright", "numbersign", - "dollar", "percent", "ampersand", "quoteright", - "parenleft", "parenright", "asterisk", "plus", - "comma", "hyphen", "period", "slash", - "zero", "one", "two", "three", - "four", "five", "six", "seven", - "eight", "nine", "colon", "semicolon", - "exclamdown", "equal", "questiondown", "question", - "at", "A", "B", "C", - "D", "E", "F", "G", - "H", "I", "J", "K", - "L", "M", "N", "O", - "P", "Q", "R", "S", - "T", "U", "V", "W", - "X", "Y", "Z", "bracketleft", - "quotedblleft", "bracketright", "circumflex", "dotaccent", - "quoteleft", "a", "b", "c", - "d", "e", "f", "g", - "h", "i", "j", "k", - "l", "m", "n", "o", - "p", "q", "r", "s", - "t", "u", "v", "w", - "x", "y", "z", "endash", - "emdash", "hungarumlaut", "tilde", "dieresis" -); - -@dvipsenc = ( - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", "quotesingle", "exclamdown", "questiondown", - "dotlessi", "dotlessj", "grave", "acute", - "caron", "breve", "macron", "ring", - "cedilla", "germandbls", "ae", "oe", - "oslash", "AE", "OE", "Oslash", - "space", "exclam", "quotedbl", "numbersign", - "dollar", "percent", "ampersand", "quoteright", - "parenleft", "parenright", "asterisk", "plus", - "comma", "hyphen", "period", "slash", - "zero", "one", "two", "three", - "four", "five", "six", "seven", - "eight", "nine", "colon", "semicolon", - "less", "equal", "greater", "question", - "at", "A", "B", "C", - "D", "E", "F", "G", - "H", "I", "J", "K", - "L", "M", "N", "O", - "P", "Q", "R", "S", - "T", "U", "V", "W", - "X", "Y", "Z", "bracketleft", - "backslash", "bracketright", "circumflex", "underscore", - "quoteleft", "a", "b", "c", - "d", "e", "f", "g", - "h", "i", "j", "k", - "l", "m", "n", "o", - "p", "q", "r", "s", - "t", "u", "v", "w", - "x", "y", "z", "braceleft", - "bar", "braceright", "tilde", "dieresis", - "asciicircum", "asciitilde", "Ccedilla", "Iacute", - "Icircumflex", "atilde", "edieresis", "egrave", - "scaron", "zcaron", "Eth", "ff", - "ffi", "ffl", ".notdef", ".notdef", - ".notdef", ".notdef", "Scaron", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - "Ydieresis", ".notdef", "Zcaron", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", "cent", "sterling", - "fraction", "yen", "florin", "section", - "currency", "copyright", "quotedblleft", "guillemotleft", - "guilsinglleft", "guilsinglright", "fi", "fl", - "degree", "endash", "dagger", "daggerdbl", - "periodcentered", ".notdef", "paragraph", "bullet", - "quotesinglbase", "quotedblbase", "quotedblright", "guillemotright", - "ellipsis", "perthousand", ".notdef", ".notdef", - "Agrave", "Aacute", "Acircumflex", "Atilde", - "Adieresis", "Aring", ".notdef", "dotaccent", - "Egrave", "Eacute", "Ecircumflex", "Edieresis", - "Igrave", "hungarumlaut", "ogonek", "Idieresis", - "emdash", "Ntilde", "Ograve", "Oacute", - "Ocircumflex", "Otilde", "Odieresis", ".notdef", - ".notdef", "Ugrave", "Uacute", "Ucircumflex", - "Udieresis", "Yacute", "Thorn", ".notdef", - "agrave", "aacute", "acircumflex", "ordfeminine", - "adieresis", "aring", ".notdef", "ccedilla", - "Lslash", "eacute", "ecircumflex", "ordmasculine", - "igrave", "iacute", "icircumflex", "idieresis", - ".notdef", "ntilde", "ograve", "oacute", - "ocircumflex", "otilde", "odieresis", ".notdef", - "lslash", "ugrave", "uacute", "ucircumflex", - "udieresis", "yacute", "thorn", "ydieresis" -); - -@adobeenc=( - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - "space", "exclam", "quotedbl", "numbersign", - "dollar", "percent", "ampersand", "quoteright", - "parenleft", "parenright", "asterisk", "plus", - "comma", "hyphen", "period", "slash", - "zero", "one", "two", "three", - "four", "five", "six", "seven", - "eight", "nine", "colon", "semicolon", - "less", "equal", "greater", "question", - "at", "A", "B", "C", - "D", "E", "F", "G", - "H", "I", "J", "K", - "L", "M", "N", "O", - "P", "Q", "R", "S", - "T", "U", "V", "W", - "X", "Y", "Z", "bracketleft", - "backslash", "bracketright", "asciicircum", "underscore", - "quoteleft", "a", "b", "c", - "d", "e", "f", "g", - "h", "i", "j", "k", - "l", "m", "n", "o", - "p", "q", "r", "s", - "t", "u", "v", "w", - "x", "y", "z", "braceleft", - "bar", "braceright", "asciitilde", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", "exclamdown", "cent", "sterling", - "fraction", "yen", "florin", "section", - "currency", "quotesingle", "quotedblleft", "guillemotleft", - "guilsinglleft", "guilsinglright", "fi", "fl", - ".notdef", "endash", "dagger", "daggerdbl", - "periodcentered", ".notdef", "paragraph", "bullet", - "quotesinglbase", "quotedblbase", "quotedblright", "guillemotright", - "ellipsis", "perthousand", ".notdef", "questiondown", - ".notdef", "grave", "acute", "circumflex", - "tilde", "macron", "breve", "dotaccent", - "dieresis", ".notdef", "ring", "cedilla", - ".notdef", "hungarumlaut", "ogonek", "caron", - "emdash", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", "AE", ".notdef", "ordfeminine", - ".notdef", ".notdef", ".notdef", ".notdef", - "Lslash", "Oslash", "OE", "ordmasculine", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", "ae", ".notdef", ".notdef", - ".notdef", "dotlessi", ".notdef", ".notdef", - "lslash", "oslash", "oe", "germandbls", - ".notdef", ".notdef", ".notdef", ".notdef" -); - -############### -# 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 VPL file -############### -# -# File header -# -$vplhead = <> or exit 1; -unless ($vplhead =~ /^\((VTITLE|FAMILY) /) { - die "$filename is not a vpl file: giving up\n" -} -do { - $_ = <>; - $vplhead .= $_; -} until ($_ =~ /^\(LIGTABLE$/ or eof); -if (eof) { - die "$filename does not seem to be a text font (no LIGTABLE): giving up\n"; -} -if ($vplhead =~ s/\A\(VTITLE(.*)$/$vtitle\n(COMMENT Old vtitle:$1/m) { - $vplhead =~ s/\n\(COMMENT Please edit that VTITLE .*\)$//m; - @enc = @dvipsenc; - $dvips = 1; -} -elsif ($vplhead =~ /\A\(FAMILY.*\)\n\(CODINGSCHEME ADOBESTANDARDENCODING\)$/m) { - $vplhead =~ s/\A/$vtitle\n/m; - @enc = @adobeenc; - $dvips = 0; -} -else { - $vplhead =~ s/\A/$vtitle\n/m; - @enc = @TeXenc; - $dvips = 0; -} -if ($vplhead =~ /^\(CODINGSCHEME TEX MATH SYMBOLS/m) { - die "$filename is a TeX math font: giving up\n"; -} -unless ($vplhead =~ s/^(\(CODINGSCHEME .*\+\s?)(\S+)\)$/$1$encname)/m) { - $vplhead =~ s/^(\(CODINGSCHEME .*)\)$/$1 + $encname)/m; -} -if ($vplhead =~ s/^\(DESIGNUNITS R (.+)\)\n//m) { $scale = $1 } -else { $scale = 1 } -$vplhead =~ s/^\(COMMENT.*DESIGNSIZE.*\)\n//gm; -$vplhead =~ s/^\(BOUNDARYCHAR.*\)\n//gm; -if ($vplhead =~ /^ \(SLANT R (.+)\)/m) { $slant = $1 } -if ($vplhead =~ /^ \(XHEIGHT [DR] (.+)\)/m) { $xheight = $1 } -unless ($vplhead =~ /^\(MAPFONT /m) { - if ($vplhead =~ /^\(DESIGNSIZE R (.*)\)$/m) { $dsize = $1 *$scale } - $mapfont = "\n(MAPFONT D 0\n (FONTNAME $fontname)\n (FONTDSIZE R $dsize)\n )"; - $vplhead =~ s/\n\(LIGTABLE\Z/$mapfont$&/m; -} -$vplhead =~ s/^(\(FONTDIMEN)/(SEVENBITSAFEFLAG FALSE)\n$1/m; -if ($opt_s) { - $vplhead =~ s[^(\(MAPFONT D )0(.*?)( \))] - [$&\n${1}1$2 (FONTAT R ${ \($shrink * $scale) })\n$3]ms; -} -@vplhead = split /^/, $vplhead; -foreach (@vplhead) { - s[(?<!(IGNSIZE|MAPFONT)) [RD] (-?)([0-9.]+)\)] - [" R " . $2 . $3/$scale . ")"]ge -} - -# -# Ligatures and kerns -# -do { - $_ = <>; - s/ \(comment .*$//i; - s/^( \((?:LABEL|KRN) )O ([0-7]+)(.*)$/$1 . sprintf("H %04lX", oct $2) . $3/e; -if (/ \(LIG /) { - s/O ([0-7]+)/sprintf("H %04lX", oct $1)/ge; - } - $ligs .= $_; -} until $_ =~ /^ \)/; -# -# Now build a hash to convert from vpl representation to char name -# and use it to make ligtable readable -# -foreach $i (0 .. 255) { $vc{$nv[$i]} = $enc[$i] } -$ligs =~ s/^( \((?:LABEL|KRN) )(\S+ \S+)(.*\))$/$1$vc{$2}$3/gm; -$ligs =~ s/^( \(LIG )(\S+ \S+) (\S+ \S+)\)$/$1$vc{$2} $vc{$3})/gm; -# -# Character definitions: store "encoded" defs in @chars, store *all* -# defs in %allchars -# -$_ = <>; -do { - if (/^\(CHARACTER/) { - $character = $_; - do { - $_ = <>; - $character .= $_; - } until $_ =~ /^ \)/; - storeinfo($character); - $_ = <>; - } -} until eof; -foreach $i (0 .. $#chars) { - if ($chars[$i] and $enc[$i] ne ".notdef") { - $allchars{$enc[$i]} = $chars[$i]; - } -} - -################## -# 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 = 0.230; # depth of "under" accs -$underddp = 0.213; # depth of underdot -if ($bold) { $thk = 0.072 } else { $thk = 0.052 } # thickness and -$underbdp = 0.082 + $thk; # depth of underbar -$capheight = $allchars{"X"}{ht}; -$accheight = $allchars{"macron"}{ht}; -$accdepth = $accheight - $thk * $scale; # probable approx. "depth" of macron -$v1 = $accheight - $xheight; # vertical offset for double accents -$v2 = $capheight - $xheight; # vertical offset for accented caps etc -if ($scaps) { # accented small caps - $scoffset = $allchars{"x"}{ht} - $xheight; - $v1 += $scoffset; -} -if ($opt_c) { # candrabindu - ($cbx, $cby) = $opt_c =~ /^(.*),(.*)$/; - $cbx += ($allchars{"breve"}{wd} - $allchars{"dotaccent"}{wd}) / 2; - $cbx /= 1000; - $cby /= 1000; -} - -###################### -# Build the characters -###################### -# -# First normalise dvips.enc encoding quirks -# -if ($dvips) { - chmove("fi", 014); - chmove("fl", 015); - chmove("quotedblright", 042); - chmove("quotedblleft", 0134); - chmove("dotaccent", 0137); - chmove("endash", 0173); - chmove("emdash", 0174); - chmove("hungarumlaut", 0175); -} -# -# Now 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]+?|\.notdef)(?:\s+([a-zA-Z]+))?$/) { - ($num, $char, $acc) = ($1, $2, $3); - $num = oct $num if $num =~ /^0/; - if ($num > 0xFFFF) { die "Bad definition (number out of range): $_\n" } - $def = {}; - $def->{qdef} = $_; - $def->{num} = $num; - $def->{char} = $char; - $def->{acc} = $acc; - if ($char eq "space") { $def->{nchar} = $acc } - else { $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 (!$allchars{$char} and $char ne ".notdef") { - if (grep /^$char$/, @nchars) { - unless (++$def->{requeue} > 5) { - push @defs, $def; - next; - } - } - else { die "Bad definition (no such character): $qdef\n" } - } - if ($acc and !$allchars{$acc} and $acc !~ /^$accents$/) { - if (grep /^$acc$/, @nchars) { - unless (++$def->{requeue} > 5) { - push @defs, $def; - next; - } - } - else { die "Bad definition (no such accent): $qdef\n" } - } - # - # Remove any existing claims on $num - # - @{ $allchars{$chars[$num]{id}}{num} } = grep !/$num/, - @{ $allchars{$chars[$num]{id}}{num} }; - # - # First deal with .notdef - # - if ($nchar eq ".notdef") { - undef $chars[$num]; - } - # - # Next look among existing chars (unless blocked by -b) - # - elsif (!($acc and $opt_b) and $allchars{$nchar}) { - push( @{ $allchars{$nchar}{num} }, $num); - $chars[$num] = $allchars{$nchar}; - } - # - # 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"; - undef $chars[$num]; - } - # - # Now build the char - # - else { - # - # First get rid of predefined/duplicated ligtable statements - # and character definitions; also synonyms - # - $ligs =~ s/\n \((LABEL|KRN|LIG) ($nchar .*|.*$nchar)\)$//gm; - $allchars{$nchar} = (); - if ($acc eq "overdot") { - $nchar2 = $char . "dotaccent"; - $ligs =~ s/\n \((LABEL|KRN|LIG) ($nchar2 .*|.*$nchar2)\)$//gm; - delete $allchars{$nchar2}; - } - # - # Store the info that will be needed to have the character - # linked into the LIGTABLE - # - push @newligs, "$char: (LIG $acc $nchar)"; - # - # 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); - } - } -} - -################### -# Sort out ligtable -################### -# -# Pull in the newly created ligatures -# -foreach $newlig (@newligs) { - $newlig =~ s/^(.+)://; - $newelm1 = $1; - unless ($ligs =~ s/(^ \(LABEL $newelm1\)\n)/$1$newlig\n/m) { - $ligs =~ s[^( \)\n)] - [ \(LABEL $newelm1\)\n$newlig\n \(STOP\)\n$1]m - } -} -# -# Convert to vpl representation, eliminating statements invoking -# "unencoded" characters -# -@liglist = split /\n/, $ligs; -$ligs = ""; -foreach (@liglist) { - if (/^( \(LIG \S+ )(\S+)\)$/) { - if ($n = ${ $allchars{$2}{num} }[0]) { - s/^( \(LIG \S+ )(\S+)\)$/$1$nv[$n])/; - } - else { next } - } - if (/^( \((?:LABEL|LIG|KRN) )([^ )]+)(.*)$/) { - ($one, $two, $three) = ($1, $2, $3); - foreach $n (@{ $allchars{$two}{num} }) { - $ligs .= "$one$nv[$n]$three\n"; - } - } - else { $ligs .= "$_\n" } -} -# -# Eliminate sequences orphaned by elimination of a LABEL -# -@liglist = split / \(STOP\)\n/, $ligs; -$ligs = ""; -foreach (@liglist) { - if (/^ \(LABEL /m) { $ligs .= "$_ (STOP)\n" } - elsif (/^ \)$/m) { $ligs .= $_ } -} -# -# Eliminate empty statements -# -$ligs =~ s/(^ \(LABEL .*\)\n)+ \(STOP\)\n//gm; -@ligs = split /^/, $ligs; -foreach (@ligs) { - s/ [RD] (-?)([0-9.]+)\)/" R " . $1 . $2\/$scale . ")"/ge -} - -#################### -# Output the results -#################### -# -print @vplhead, @ligs; -foreach $i (0 .. 0xFFFF) { if (defined $chars[$i]{id}) { printchar($i) } } - -##################### -# End of main program -##################### - -sub storeinfo { - # - # Extract info from a character definition and store it in @chars - # - my $char = shift; - my $num; - if ($char =~ /\A\(CHARACTER O ([0-7]+)/m) { $num = oct $1 } - elsif ($char =~ /\A\(CHARACTER C (.)/m) { $num = ord $1 } - $chars[$num]{id} = $enc[$num]; - push( @{ $chars[$num]{num} }, $num); - if ($char =~ /^ \(CHARWD R (.*?)\)$/m) { $chars[$num]{wd} = $1 } - if ($char =~ /^ \(CHARHT R (.*?)\)$/m) { $chars[$num]{ht} = $1 } - if ($char =~ /^ \(CHARDP R (.*?)\)$/m) { $chars[$num]{dp} = $1 } - if ($char =~ /^ \(CHARIC R (.*?)\)$/m) { $chars[$num]{ic} = $1 } - if ($char =~ /^ \(MAP\n((.|\n)*)^ \)/m) { $chars[$num]{map} = $1 } - else { $chars[$num]{map} = " (SETCHAR $nv[$num])\n" } - $chars[$num]{map} =~ s[(\(SETCHAR )O ([0-7]+)\)] - [$1 . sprintf("H %04lX", oct $2) . ")"]gme -} - -sub printchar { - # - # Extract info from @chars and build it into a character definition - # - my $num = shift; - my @ch; - push @ch, "(CHARACTER "; - if (chr($num) =~ /[0-9A-Za-z]/) { push @ch, "C " . chr($num) } - else { - push @ch, sprintf("H %04lX", $num); - push @ch, " (COMMENT " . $chars[$num]{id} . ")"; - } - push @ch, "\n"; - push @ch, " (CHARWD R " . $chars[$num]{wd} . ")\n" - if defined $chars[$num]{wd}; - push @ch, " (CHARHT R " . $chars[$num]{ht} . ")\n" - if defined $chars[$num]{ht}; - push @ch, " (CHARDP R " . $chars[$num]{dp} . ")\n" if $chars[$num]{dp}; - push @ch, " (CHARIC R " . $chars[$num]{ic} . ")\n" if $chars[$num]{ic}; - push @ch, " (MAP\n"; - push @ch, $chars[$num]{map}; - push @ch, " )\n"; - push @ch, " )\n"; - foreach (@ch) { - s/(?<!SELECTFONT) [RD] (-?)([0-9.]+)\)/" R " . $1 . $2\/$scale . ")"/ge - } - print @ch -} - -sub chmove { - # - # Move a character - # - my ($char, $num) = @_; - my $i; - foreach $i (@{ $allchars{$char}{num} }) { undef $chars[$i] } - @{ $allchars{$char}{num} } = (); - @{ $allchars{$chars[$num]{id}}{num} } = grep !/$num/, - @{ $allchars{$chars[$num]{id}}{num} }; - push( @{ $allchars{$char}{num} }, $num); - $chars[$num] = $allchars{$char}; -} - -sub max { - # - # Return greater of two values - # - my ($a, $b) = @_; - return $a > $b ? $a : $b; -} - -sub subacc { - # - # Subscript accents - # - my ($num, $char, $acc, $id) = @_; - my ($h, $s1, $s2, $s3); - $allchars{$id}{wd} = $allchars{$char}{wd}; - $allchars{$id}{ht} = $allchars{$char}{ht}; - $allchars{$id}{dp} = $allchars{$acc}{dp}; - $allchars{$id}{ic} = $allchars{$char}{ic}; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - $s1 = $allchars{$char}{map}; - $s1 =~ s/\A (.*)\n\Z/(PUSH) $1 (POP)/s; - $h = sprintf("%.3f", ($allchars{$char}{wd} - $allchars{$acc}{wd}) / 2); - if ($h > 0) { $s2 = " (MOVERIGHT R $h) " } - elsif ($h < 0) { - $h = -$h; - $s2 = " (MOVELEFT R $h) "; - } - else { $s2 = " " } - $s3 = $allchars{$acc}{map}; - $s3 =~ s/\A.*(\(SETCHAR . .+?\)).*\Z/$1/s; - $allchars{$id}{map} = " $s1\n$s2$s3\n"; - $chars[$num] = $allchars{$id}; -} - -sub supacc { - # - # Superscript accents - # - my ($num, $char, $acc, $id) = @_; - my ($cb, $h, $hadj, $tallchar, $ic, $s1, $s2, $s3); - if ($char eq "i" and $allchars{"dotlessi"}) { $char = "dotlessi" } - if ($char eq "j" and $allchars{"dotlessj"}) { $char = "dotlessj" } - if ($acc eq "overdot") { $acc = "dotaccent" } - if ($acc eq "candrabindu") { - $acc = "breve"; - ($cb = $allchars{"dotaccent"}{map}) =~ s/\A.*(\(SETCHAR . .+?\)).*\Z/$1/s; - } - $allchars{$id}{wd} = $allchars{$char}{wd}; - $allchars{$id}{ht} = $allchars{$acc}{ht}; - $allchars{$id}{dp} = $allchars{$char}{dp}; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - $s1 = $allchars{$char}{map}; - $s1 =~ s/\A (.*)\n\Z/(PUSH) $1 (POP)/s; - if ($scaps and $char =~ /^[a-z]/) { # accented small caps - $tallchar = 1; - if ($char =~ /$supacc$/ - and $char !~ /under$supacc$/) { # double accs - $s2 = " (MOVEUP R $v1)"; - $allchars{$id}{ht} += $v1; - $hadj = sprintf("%.3f", $v1 * $slant); - $ic = $allchars{$char}{ic}; - } - else { # single accs - $s2 = " (MOVEUP R $scoffset)"; - $allchars{$id}{ht} += $scoffset; - $hadj = sprintf("%.3f", $scoffset * $slant); - $ic = $allchars{$acc}{ic} + $hadj; - } - } - elsif ($allchars{$char}{ht} >= ($accheight + $v2)) { # double accs - $tallchar = 1; # on caps etc. - $s2 = " (MOVEUP R ${ \($v1 + $v2) })"; - $allchars{$id}{ht} += ($v1 + $v2); - $hadj = sprintf("%.3f", ($v1 + $v2) * $slant); - $ic = $allchars{$char}{ic}; - } - elsif ($allchars{$char}{ht} > 1.15 * $xheight) { - $tallchar = 1; - if ($char =~ /$supacc$/ - and $char !~ /under$supacc$/) { # double accs - $s2 = " (MOVEUP R $v1)"; - $allchars{$id}{ht} += $v1; - $hadj = sprintf("%.3f", $v1 * $slant); - $ic = $allchars{$char}{ic}; - } - else { # caps etc. - $s2 = " (MOVEUP R $v2)"; - $allchars{$id}{ht} += $v2; - $hadj = sprintf("%.3f", $v2 * $slant); - $ic = $allchars{$char}{ic}; - } - } - else { # single accs - $s2 = " "; - $ic = $allchars{$acc}{ic}; - } - $h = sprintf("%.3f", ($allchars{$char}{wd} - $allchars{$acc}{wd}) / 2); - unless ($tallchar) { $ic -= $h } - $allchars{$id}{ic} = $ic unless $ic < 0; - $h += $hadj; - if ($h > 0) { $s2 .= " (MOVERIGHT R $h) " } - elsif ($h < 0) { - $h = -$h; - $s2 .= " (MOVELEFT R $h) "; - } - else { $s2 .= " " } - $s3 = $allchars{$acc}{map}; - $s3 =~ s/\A.*(\(SETCHAR . .+?\)).*\Z/$1/s; - if ($cb) { # candrabindu - $cb = $s2 . $cb; - if ($cbx) { - unless (($cb =~ s/(MOVERIGHT R )([0-9.]+)/$1 . ($2 + $cbx * $scale)/e) - or ($cb =~ s/(MOVELEFT R )([0-9.]+)/$1 . ($2 - $cbx * $scale)/e)) { - $cb =~ s/^( +)/"$1(MOVERIGHT R " . ($cbx * $scale) . ") "/e; - } - } - if ($cby) { - unless ($cb =~ s/(MOVEUP R )([0-9.]+)/$1 . ($2 + $cby * $scale)/e) { - $cb =~ s/^( +)/"$1(MOVEUP R " . ($cby * $scale) . ") "/e; - } - } - $cb .= "\n"; - $s1 = "(PUSH) " . $s1; - $s3 .= " (POP)"; - } - $allchars{$id}{map} = " $s1\n$s2$s3\n$cb"; - $chars[$num] = $allchars{$id}; -} - -sub underacc { - # - # Dropped accents - # - my ($num, $char, $acc, $id) = @_; - my ($h, $v, $s1, $s2, $s3); - $acc =~ s/^under//; - if ($acc eq "dot") { $acc = "period" } - if ($acc eq "candrabindu") { die "Bad definition (no such accent): $qdef\n" } - $allchars{$id}{wd} = $allchars{$char}{wd}; - $allchars{$id}{ht} = $allchars{$char}{ht}; - $allchars{$id}{ic} = $allchars{$char}{ic}; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - if ($acc =~ /^$supacc$/) { - $v = $allchars{$id}{dp} = $underadp * $scale * $shrink; - $v += ($accdepth * $shrink); - } - else { - $v = $allchars{$id}{dp} = $underddp * $scale + $allchars{$acc}{dp}; - } - $s1 = $allchars{$char}{map}; - $s1 =~ s/\A (.*)\n\Z/(PUSH) $1 (POP)/s; - if ($acc =~ /^$supacc$/) { - $h = ($allchars{$char}{wd} - ($allchars{$acc}{wd} * $shrink)) / 2 - $v * $slant; - if ($opt_s) { $s2 = " (SELECTFONT D 1)\n" } - } - else { - $h = ($allchars{$char}{wd} - $allchars{$acc}{wd}) / 2 - $v * $slant; - } - $h = sprintf("%.3f", $h); - if ($h > 0) { - $s2 .= " (MOVEDOWN R $v) (MOVERIGHT R $h) "; - } - elsif ($h < 0) { - $h = -$h; - $s2 .= " (MOVEDOWN R $v) (MOVELEFT R $h) "; - } - else { $s2 = " (MOVEDOWN R $v) " } - $s3 = $allchars{$acc}{map}; - $s3 =~ s/\A.*(\(SETCHAR . .+?\)).*\Z/$1/s; - if ($opt_s and $acc =~ /^$supacc$/) { $s3 .= "\n (SELECTFONT D 0)" } - $allchars{$id}{map} = " $s1\n$s2$s3\n"; - $chars[$num] = $allchars{$id}; -} - -sub underb { - # - # Underbar - # - my ($num, $char, $id) = @_; - my ($h, $w, $dp, $s1, $s2, $s3); - $allchars{$id}{wd} = $allchars{$char}{wd}; - $allchars{$id}{ht} = $allchars{$char}{ht}; - $allchars{$id}{dp} = $dp = $underbdp * $scale; - $allchars{$id}{ic} = $allchars{$char}{ic}; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - $s1 = $allchars{$char}{map}; - $s1 =~ s/\A (.*)\n\Z/(PUSH) $1 (POP)/s; - $h = sprintf("%.3f", ($allchars{$id}{wd} / 10 - $dp * $slant)); - $w = sprintf("%.3f", ($allchars{$id}{wd} * 8 / 10)); - if ($h > 0) { - $s2 = " (MOVEDOWN R $dp) (MOVERIGHT R $h) "; - } - elsif ($h < 0) { - $h = -$h; - $s2 = " (MOVEDOWN R $dp) (MOVELEFT R $h) "; - } - else { $s2 .= " (MOVEDOWN R $dp) " } - $s3 = "(SETRULE R ${ \($thk) } R $w)"; - $allchars{$id}{map} = " $s1\n$s2$s3\n"; - $chars[$num] = $allchars{$id}; - # - # If the character to be underscored is a digraph, fix up the LIGTABLE - # - if (grep /^$char$/, @digraphs) { - pop @newligs; - dummychar(0x035F, "uni035F") unless defined $allchars{uni035F}; - $char =~ /^(.)(.)$/; - ($one, $two) = ($1, $2); - $one_ = $one . "_uni035F"; - dummychar($dummycodepoint--, $one_) unless defined $allchars{$one_}; - push @newligs, "$one: (LIG uni035F $one_)" - unless (grep /^$one: \(LIG uni035F $one_\)$/, @newligs); - push @newligs, "$one_: (LIG $two $id)"; - } -} - -sub digraph { - # - # Make a new character consisting of two existing characters - # - my ($num, $char, $acc, $id) = @_; - my ($one, $two, $kern, $s1, $s2, $charZWJ); - # - # Remove the ligature info -- we don't want every occurrence of - # e.g."kh" to be converted into a digraph. - # - pop @newligs; - # - # List all digraphs for future reference - # - push @digraphs, $id; - if ($ligs =~ /^ \(LABEL $char\)\n(.*?)\n \(KRN $acc R (-?[0-9.]+)\)\n/ms) { - ($one, $two) = ($1, $2); - } - $kern = $two if $one !~ /^ \(STOP\)$/m; - $allchars{$id}{wd} = $allchars{$char}{wd} + $allchars{$acc}{wd}; - $allchars{$id}{wd} += $kern; - $allchars{$id}{ht} = max($allchars{$char}{ht}, $allchars{$acc}{ht}); - $allchars{$id}{dp} = max($allchars{$char}{dp}, $allchars{$acc}{dp}); - $allchars{$id}{ic} = $allchars{$acc}{ic}; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - $s1 = $allchars{$char}{map}; - chomp ($s2 = $allchars{$acc}{map}); - $s1 =~ s/(\(SETCHAR .*?\))/$1\n$s2/; - if ($kern) { - if ($kern < 0) { - $kern = -$kern; - $s1 =~ s/(\(SETCHAR .*?\))/$1 (MOVELEFT R $kern)/; - } - else { $s1 =~ s/(\(SETCHAR .*?\))/$1 (MOVERIGHT R $kern)/ } - } - $allchars{$id}{map} = $s1; - $chars[$num] = $allchars{$id}; -} - -sub dummychar { - # - # Make a new dummy character - # - my ($num, $id) = @_; - $allchars{$id}{wd} = 0; - $allchars{$id}{ht} = 0; - $allchars{$id}{dp} = 0; - $allchars{$id}{ic} = 0; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - $allchars{$id}{map} = " (SETCHAR H 0020)\n"; - $chars[$num] = $allchars{$id}; -} - -sub fixkerns { - # - # Generalise the kerning info contained in the vpl 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 ($olabel, $nlabel, @liglist, $lchar, $rchar); - return if $char eq "space"; - if ($acc =~ /^$accents$/) { $lchar = $rchar = $char } - else { - $lchar = $char; - $rchar = $acc; - } - unless ($char =~ /^[a-z]/ and $acc =~ /^$supacc$/) { - $ligs =~ s[(\n \(LABEL )$rchar\)(?!\n \(LIG.*$)] - [$&$1$char$acc)]gm - unless $ligs =~ /\n \(LABEL $char$acc\)$/m; - $ligs =~ s[(\n \(LABEL )$rchar\)(\n \(LIG.*$)+(?!\n \(STOP\))] - [$&$1$char$acc)]gm - unless $ligs =~ /\n \(LABEL $char$acc\)$/m; - $ligs =~ s[(\n \(KRN )$lchar( .*)$] - [$&$1$char$acc$2]gm; - } - else { - if ($ligs =~ /\n \(LABEL $char\).*?\(STOP\)/s) { - $nlabel = $olabel = $&; - $nlabel =~ s/(\n \(LABEL $char)\)/$1$acc)/ - unless $ligs =~ /\n \(LABEL $char$acc\)/m; - $nlabel =~ s/\n \(LIG .*\)$//gm; - $nlabel =~ s/\n \(LABEL (?!$char$acc).*\)$//gm; - $nlabel =~ s/\n \(KRN ([A-Z]|quote).*\)$//gm; - $ligs =~ s/(\n \(LABEL )$char\).*?\(STOP\)/$olabel$nlabel/s; - } - @liglist = split /\n \(STOP\)/, $ligs; - foreach (@liglist) { - unless (/\n \(LABEL ([A-Zf]|quote).*\)$/m) { - s/(\n \(KRN $char)( .*\))$/$&$1$acc$2/gm; - } - } - $ligs = join("\n (STOP)", @liglist); - } -} diff --git a/Master/texmf-dist/doc/fonts/accfonts/vpl2vpl b/Master/texmf-dist/doc/fonts/accfonts/vpl2vpl deleted file mode 100755 index 65ded28ce59..00000000000 --- a/Master/texmf-dist/doc/fonts/accfonts/vpl2vpl +++ /dev/null @@ -1,994 +0,0 @@ -#!/usr/bin/perl - -# Vpl2vpl: a program to generate accented virtual fonts for TeX -# 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: vpl2vpl -d definition-file [-s shrink-factor] - [-c candrabindu-adjustment] [-b] vpl-file - -Vpl2vpl creates new TeX virtual fonts based on existing fonts or -virtual fonts (\"input fonts\"). A successful run will read a pl -(Property List) or vpl (Virtual Property List) file and a definition -file, and will generate a new vpl (Virtual Property List) file on -standard output. The input font is assumed to adhere to the standard -TeX encoding for text fonts unless it was created with either of the -programs afm2pl or afm2tfm, in which case it is assumed to conform to -(respectively) the Adobe Standard Encoding or the encoding specified -in the file dvips.enc. In either case, the name of the input font is -assumed to be the name of the input file without its .vpl or .pl -extension: it must conform to normal TeX conventions for naming fonts, -as vpl2vpl attempts to draw conclusions from it about the kind of font -it is dealing with. - -A typical complete sequence of commands to create a new virtual -font might therefore be - tftopl cmr10.tfm cmr10.pl - vpl2vpl -d ISO-Latin1.def cmr10.pl >cmr10_isol1.vpl - vptovf cmr10_isol1.vpl cmr10_isol1.vf cmr10_isol1.tfm -for a Computer Modern font, or - afm2pl Times-Roman.afm rptmr.pl - pltotf rptmr.pl rptmr.tfm - vpl2vpl -d ISO-Latin1.def rptmr.pl >ptmr-isol1.vpl - vptovf ptmr-isol1.vpl ptmr-isol1.vf ptmr-isol1.tfm -for a PostScript font. - -Another approach for a PostScript font is to use afm2tfm: - afm2tfm Times-Roman.afm -t dvips.enc -v ptmr rptmr - vpl2vpl -d ISO-Latin1.def ptmr.vpl >ptmr-isol1.vpl - vptovf ptmr-isol1.vpl ptmr-isol1.vf ptmr-isol1.tfm --- but this is now deprecated, as afm2tfm generates incorrect -values for the heights of some characters, and this can lead to -bad accent placing. - -In order to keep the whole upper half of the character set free for -the requirements of the encoding specified in the definition file, -certain modifications are made to input fonts following the -dvips.enc encoding to bring them into greater conformity with the -TeX norm. In particular, the characters dotaccent and hungarumlaut -are placed in the positions assigned by TeX (\"5F, \"7D), not those -enforced by dvips.enc (\"C7, \"CD). The f-ligatures, double quotes -and dashes are also moved from the upper half of the character set -to their normal TeX positions. As a result, the following characters -are not found in the lower half of the character set: quotesingle, -quotedbl, backslash, underscore, braceleft, bar, braceright. These -characters can, however, be assigned positions in the output font if -they are needed. (Indeed, they could all be explicitly restored to -their dvips.enc positions if this were desired.) - -Options: - - -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 \"\#\"). - - -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. A coordinate scheme using - \"DESIGNUNITS R 1000\" is assumed. - - -b may optionally be specified to block the use of predefined - accented characters, forcing vpl2vpl to define its own - versions. This may be useful to secure a consistent appearance - in cases where a font designer does not share vpl2vpl's views - on where accents should be placed. - - -h prints this help. -"; -#------------------------------------------------------------------------# - -######################## -# Packages and constants -######################## -# -use File::Basename; -use Getopt::Std; -$cmdline = basename($0) . " " . join " ", @ARGV; -getopts('d:s:c:bh'); -if ($opt_h or !$opt_d or $#ARGV != 0) { - print STDERR $description; - exit 1; -} - -$filename = $ARGV[0]; -($fontname = $filename) =~ s/\..*$//; -($encname = basename($opt_d)) =~ s/\..*$//; -$vtitle = "(VTITLE Font $fontname modified for $encname encoding by vpl2vpl"; -$vtitle .= " v. $version" if $version; -$vtitle .= ")\n(COMMENT Command line: $cmdline)"; - -# -# Flags for bold and small caps. These are probably a bit iffy, but -# there's not much that can be done about it. -# -if ($fontname =~ /(^p.*b[oi]?[c]?$|^[^p].*bx[a-z]*[0-9]+$)/) { $bold = 1 } -if ($fontname =~ /(^p.*c$|^[^p].*csc[a-z]*[0-9]+$)/) { $scaps = 1 } -if ($opt_s) { $shrink = $opt_s / 1000 } else { $shrink = 1 } - -# -# Array to convert from number to vpl representation -# -foreach $i (0 .. 255) { - $nv[$i] = (chr($i) =~ /[0-9A-Za-z]/ ? "C " . chr $i : sprintf("O %lo", $i)); -} - -# -# Now the encoding vectors. -# -@TeXenc = ( - "Gamma", "Delta", "Theta", "Lambda", - "Xi", "Pi", "Sigma", "Upsilon", - "Phi", "Psi", "Omega", "ff", - "fi", "fl", "ffi", "ffl", - "dotlessi", "dotlessj", "grave", "acute", - "caron", "breve", "macron", "ring", - "cedilla", "germandbls", "ae", "oe", - "oslash", "AE", "OE", "Oslash", - "space", "exclam", "quotedblright", "numbersign", - "dollar", "percent", "ampersand", "quoteright", - "parenleft", "parenright", "asterisk", "plus", - "comma", "hyphen", "period", "slash", - "zero", "one", "two", "three", - "four", "five", "six", "seven", - "eight", "nine", "colon", "semicolon", - "exclamdown", "equal", "questiondown", "question", - "at", "A", "B", "C", - "D", "E", "F", "G", - "H", "I", "J", "K", - "L", "M", "N", "O", - "P", "Q", "R", "S", - "T", "U", "V", "W", - "X", "Y", "Z", "bracketleft", - "quotedblleft", "bracketright", "circumflex", "dotaccent", - "quoteleft", "a", "b", "c", - "d", "e", "f", "g", - "h", "i", "j", "k", - "l", "m", "n", "o", - "p", "q", "r", "s", - "t", "u", "v", "w", - "x", "y", "z", "endash", - "emdash", "hungarumlaut", "tilde", "dieresis" -); - -@dvipsenc = ( - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", "quotesingle", "exclamdown", "questiondown", - "dotlessi", "dotlessj", "grave", "acute", - "caron", "breve", "macron", "ring", - "cedilla", "germandbls", "ae", "oe", - "oslash", "AE", "OE", "Oslash", - "space", "exclam", "quotedbl", "numbersign", - "dollar", "percent", "ampersand", "quoteright", - "parenleft", "parenright", "asterisk", "plus", - "comma", "hyphen", "period", "slash", - "zero", "one", "two", "three", - "four", "five", "six", "seven", - "eight", "nine", "colon", "semicolon", - "less", "equal", "greater", "question", - "at", "A", "B", "C", - "D", "E", "F", "G", - "H", "I", "J", "K", - "L", "M", "N", "O", - "P", "Q", "R", "S", - "T", "U", "V", "W", - "X", "Y", "Z", "bracketleft", - "backslash", "bracketright", "circumflex", "underscore", - "quoteleft", "a", "b", "c", - "d", "e", "f", "g", - "h", "i", "j", "k", - "l", "m", "n", "o", - "p", "q", "r", "s", - "t", "u", "v", "w", - "x", "y", "z", "braceleft", - "bar", "braceright", "tilde", "dieresis", - "asciicircum", "asciitilde", "Ccedilla", "Iacute", - "Icircumflex", "atilde", "edieresis", "egrave", - "scaron", "zcaron", "Eth", "ff", - "ffi", "ffl", ".notdef", ".notdef", - ".notdef", ".notdef", "Scaron", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - "Ydieresis", ".notdef", "Zcaron", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", "cent", "sterling", - "fraction", "yen", "florin", "section", - "currency", "copyright", "quotedblleft", "guillemotleft", - "guilsinglleft", "guilsinglright", "fi", "fl", - "degree", "endash", "dagger", "daggerdbl", - "periodcentered", ".notdef", "paragraph", "bullet", - "quotesinglbase", "quotedblbase", "quotedblright", "guillemotright", - "ellipsis", "perthousand", ".notdef", ".notdef", - "Agrave", "Aacute", "Acircumflex", "Atilde", - "Adieresis", "Aring", ".notdef", "dotaccent", - "Egrave", "Eacute", "Ecircumflex", "Edieresis", - "Igrave", "hungarumlaut", "ogonek", "Idieresis", - "emdash", "Ntilde", "Ograve", "Oacute", - "Ocircumflex", "Otilde", "Odieresis", ".notdef", - ".notdef", "Ugrave", "Uacute", "Ucircumflex", - "Udieresis", "Yacute", "Thorn", ".notdef", - "agrave", "aacute", "acircumflex", "ordfeminine", - "adieresis", "aring", ".notdef", "ccedilla", - "Lslash", "eacute", "ecircumflex", "ordmasculine", - "igrave", "iacute", "icircumflex", "idieresis", - ".notdef", "ntilde", "ograve", "oacute", - "ocircumflex", "otilde", "odieresis", ".notdef", - "lslash", "ugrave", "uacute", "ucircumflex", - "udieresis", "yacute", "thorn", "ydieresis" -); - -@adobeenc=( - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - "space", "exclam", "quotedbl", "numbersign", - "dollar", "percent", "ampersand", "quoteright", - "parenleft", "parenright", "asterisk", "plus", - "comma", "hyphen", "period", "slash", - "zero", "one", "two", "three", - "four", "five", "six", "seven", - "eight", "nine", "colon", "semicolon", - "less", "equal", "greater", "question", - "at", "A", "B", "C", - "D", "E", "F", "G", - "H", "I", "J", "K", - "L", "M", "N", "O", - "P", "Q", "R", "S", - "T", "U", "V", "W", - "X", "Y", "Z", "bracketleft", - "backslash", "bracketright", "asciicircum", "underscore", - "quoteleft", "a", "b", "c", - "d", "e", "f", "g", - "h", "i", "j", "k", - "l", "m", "n", "o", - "p", "q", "r", "s", - "t", "u", "v", "w", - "x", "y", "z", "braceleft", - "bar", "braceright", "asciitilde", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", "exclamdown", "cent", "sterling", - "fraction", "yen", "florin", "section", - "currency", "quotesingle", "quotedblleft", "guillemotleft", - "guilsinglleft", "guilsinglright", "fi", "fl", - ".notdef", "endash", "dagger", "daggerdbl", - "periodcentered", ".notdef", "paragraph", "bullet", - "quotesinglbase", "quotedblbase", "quotedblright", "guillemotright", - "ellipsis", "perthousand", ".notdef", "questiondown", - ".notdef", "grave", "acute", "circumflex", - "tilde", "macron", "breve", "dotaccent", - "dieresis", ".notdef", "ring", "cedilla", - ".notdef", "hungarumlaut", "ogonek", "caron", - "emdash", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", "AE", ".notdef", "ordfeminine", - ".notdef", ".notdef", ".notdef", ".notdef", - "Lslash", "Oslash", "OE", "ordmasculine", - ".notdef", ".notdef", ".notdef", ".notdef", - ".notdef", "ae", ".notdef", ".notdef", - ".notdef", "dotlessi", ".notdef", ".notdef", - "lslash", "oslash", "oe", "germandbls", - ".notdef", ".notdef", ".notdef", ".notdef" -); - -############### -# 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 VPL file -############### -# -# File header -# -$vplhead = <> or exit 1; -unless ($vplhead =~ /^\((VTITLE|FAMILY) /) { - die "$filename is not a vpl file: giving up\n" -} -do { - $_ = <>; - $vplhead .= $_; -} until ($_ =~ /^\(LIGTABLE$/ or eof); -if (eof) { - die "$filename does not seem to be a text font (no LIGTABLE): giving up\n"; -} -if ($vplhead =~ s/\A\(VTITLE(.*)$/$vtitle\n(COMMENT Old vtitle:$1/m) { - $vplhead =~ s/\n\(COMMENT Please edit that VTITLE .*\)$//m; - @enc = @dvipsenc; - $dvips = 1; -} -elsif ($vplhead =~ /\A\(FAMILY.*\)\n\(CODINGSCHEME ADOBESTANDARDENCODING\)$/m) { - $vplhead =~ s/\A/$vtitle\n/m; - @enc = @adobeenc; - $dvips = 0; -} -else { - $vplhead =~ s/\A/$vtitle\n/m; - @enc = @TeXenc; - $dvips = 0; -} -if ($vplhead =~ /^\(CODINGSCHEME TEX MATH SYMBOLS/m) { - die "$filename is a TeX math font: giving up\n"; -} -unless ($vplhead =~ s/^(\(CODINGSCHEME .*\+\s?)(\S+)\)$/$1$encname)/m) { - $vplhead =~ s/^(\(CODINGSCHEME .*)\)$/$1 + $encname)/m; -} -if ($vplhead =~ /^\(DESIGNUNITS R (.+)\)/m) { $scale = $1 } -else {$scale = 1 } -if ($vplhead =~ /^ \(SLANT R (.+)\)/m) { $slant = $1 } -if ($vplhead =~ /^ \(XHEIGHT [DR] (.+)\)/m) { $xheight = $1 } -unless ($vplhead =~ /^\(MAPFONT /m) { - if ($vplhead =~ /^\(DESIGNSIZE R (.*)\)$/m) { $dsize = $1 } - $mapfont = "\n(MAPFONT D 0\n (FONTNAME $fontname)\n (FONTDSIZE R $dsize)\n )"; - $vplhead =~ s/\n\(LIGTABLE\Z/$mapfont$&/m; -} -if ($opt_s) { - $vplhead =~ s[^(\(MAPFONT D )0(.*?)( \))] - [$&\n${1}1$2 (FONTAT R ${ \($shrink * $scale) })\n$3]ms; -} - -# -# Ligatures and kerns -# -do { - $_ = <>; - s/ \(comment .*$//i; - $ligs .= $_; -} until $_ =~ /^ \)/; -# -# Now build a hash to convert from vpl representation to char name -# and use it to make ligtable readable -# -foreach $i (0 .. 255) { $vc{$nv[$i]} = $enc[$i] } -$ligs =~ s/^( \((?:LABEL|KRN) )(\S+ \S+)(.*\))$/$1$vc{$2}$3/gm; -$ligs =~ s/^( \(LIG )(\S+ \S+) (\S+ \S+)\)$/$1$vc{$2} $vc{$3})/gm; - -# -# Character definitions: store "encoded" defs in @chars, store *all* -# defs in %allchars -# -$_ = <>; -do { - if (/^\(CHARACTER/) { - $character = $_; - do { - $_ = <>; - $character .= $_; - } until $_ =~ /^ \)/; - storeinfo($character); - $_ = <>; - } -} until eof; -foreach $i (0 .. $#chars) { - if ($chars[$i] and $enc[$i] ne ".notdef") { - $allchars{$enc[$i]} = $chars[$i]; - } -} - -################## -# 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 = 0.230; # depth of "under" accs -$underddp = 0.213; # depth of underdot -if ($bold) { $thk = 0.072 } else { $thk = 0.052 } # thickness and -$underbdp = 0.082 + $thk; # depth of underbar -$capheight = $allchars{"X"}{ht}; -$accheight = $allchars{"macron"}{ht}; -$accdepth = $accheight - $thk * $scale; # probable approx. "depth" of macron -$v1 = $accheight - $xheight; # vertical offset for double accents -$v2 = $capheight - $xheight; # vertical offset for accented caps etc -if ($scaps) { # accented small caps - $scoffset = $allchars{"x"}{ht} - $xheight; - $v1 += $scoffset; -} -if ($opt_c) { # candrabindu - ($cbx, $cby) = $opt_c =~ /^(.*),(.*)$/; - $cbx += ($allchars{"breve"}{wd} - $allchars{"dotaccent"}{wd}) / 2; - $cbx /= 1000; - $cby /= 1000; -} - -###################### -# Build the characters -###################### -# -# First normalise dvips.enc encoding quirks -# -if ($dvips) { - chmove("fi", 014); - chmove("fl", 015); - chmove("quotedblright", 042); - chmove("quotedblleft", 0134); - chmove("dotaccent", 0137); - chmove("endash", 0173); - chmove("emdash", 0174); - chmove("hungarumlaut", 0175); -} -# -# Now 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]+?|\.notdef)(?:\s+([a-zA-Z]+))?$/) { - ($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 (!$allchars{$char} and $char ne ".notdef") { - if (grep /^$char$/, @nchars) { - unless (++$def->{requeue} > 5) { - push @defs, $def; - next; - } - } - else { die "Bad definition (no such character): $qdef\n" } - } - if ($acc and !$allchars{$acc} and $acc !~ /^$accents$/) { - if (grep /^$acc$/, @nchars) { - unless (++$def->{requeue} > 5) { - push @defs, $def; - next; - } - } - else { die "Bad definition (no such accent): $qdef\n" } - } - # - # Remove any existing claims on $num - # - @{ $allchars{$chars[$num]{id}}{num} } = grep !/$num/, - @{ $allchars{$chars[$num]{id}}{num} }; - # - # First deal with .notdef - # - if ($nchar eq ".notdef") { - undef $chars[$num]; - } - # - # Next look among existing chars (unless blocked by -b) - # - elsif (!($acc and $opt_b) and $allchars{$nchar}) { - push( @{ $allchars{$nchar}{num} }, $num); - $chars[$num] = $allchars{$nchar}; - } - # - # 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"; - undef $chars[$num]; - } - # - # Now build the char - # - else { - # - # First get rid of predefined/duplicated ligtable statements - # and character definitions; also synonyms - # - $ligs =~ s/\n \((LABEL|KRN|LIG) ($nchar .*|.*$nchar)\)$//gm; - $allchars{$nchar} = (); - if ($acc eq "overdot") { - $nchar2 = $char . "dotaccent"; - $ligs =~ s/\n \((LABEL|KRN|LIG) ($nchar2 .*|.*$nchar2)\)$//gm; - delete $allchars{$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); - } - } -} - -################### -# Sort out ligtable -################### -# -# Convert to vpl representation, eliminating statements invoking -# "unencoded" characters -# -@liglist = split /\n/, $ligs; -$ligs = ""; -foreach (@liglist) { - if (/^( \(LIG \S+ )(\S+)\)$/) { - if ($n = ${ $allchars{$2}{num} }[0]) { - s/^( \(LIG \S+ )(\S+)\)$/$1$nv[$n])/; - } - else { next } - } - if (/^( \((?:LABEL|LIG|KRN) )([^ )]+)(.*)$/) { - ($one, $two, $three) = ($1, $2, $3); - foreach $n (@{ $allchars{$two}{num} }) { - $ligs .= "$one$nv[$n]$three\n"; - } - } - else { $ligs .= "$_\n" } -} -# -# Eliminate sequences orphaned by elimination of a LABEL -# -@liglist = split / \(STOP\)\n/, $ligs; -$ligs = ""; -foreach (@liglist) { - if (/^ \(LABEL /m) { $ligs .= "$_ (STOP)\n" } - elsif (/^ \)$/m) { $ligs .= $_ } -} -# -# Eliminate empty statements -# -$ligs =~ s/(^ \(LABEL .*\)\n)+ \(STOP\)\n//gm; - -#################### -# Output the results -#################### -# -print $vplhead, $ligs; -foreach $i (0 .. 255) { if (defined $chars[$i]{id}) { printchar($i) } } - -##################### -# End of main program -##################### - -sub storeinfo { - # - # Extract info from a character definition and store it in @chars - # - my $char = shift; - my $num; - if ($char =~ /\A\(CHARACTER O ([0-7]+)/m) { $num = oct $1 } - elsif ($char =~ /\A\(CHARACTER C (.)/m) { $num = ord $1 } - $chars[$num]{id} = $enc[$num]; - push( @{ $chars[$num]{num} }, $num); - if ($char =~ /^ \(CHARWD R (.*?)\)$/m) { $chars[$num]{wd} = $1 } - if ($char =~ /^ \(CHARHT R (.*?)\)$/m) { $chars[$num]{ht} = $1 } - if ($char =~ /^ \(CHARDP R (.*?)\)$/m) { $chars[$num]{dp} = $1 } - if ($char =~ /^ \(CHARIC R (.*?)\)$/m) { $chars[$num]{ic} = $1 } - if ($char =~ /^ \(MAP\n((.|\n)*)^ \)/m) { $chars[$num]{map} = $1 } - else { $chars[$num]{map} = " (SETCHAR $nv[$num])\n" } -} - -sub printchar { - # - # Extract info from @chars and build it into a character definition - # - my $num = shift; - print "(CHARACTER "; - if (chr($num) =~ /[0-9A-Za-z]/) { print "C " . chr($num) } - else { - printf "O %lo", $num; - print " (COMMENT " . $chars[$num]{id} . ")"; - } - print "\n"; - print " (CHARWD R " . $chars[$num]{wd} . ")\n" if $chars[$num]{wd}; - print " (CHARHT R " . $chars[$num]{ht} . ")\n" if $chars[$num]{ht}; - print " (CHARDP R " . $chars[$num]{dp} . ")\n" if $chars[$num]{dp}; - print " (CHARIC R " . $chars[$num]{ic} . ")\n" if $chars[$num]{ic}; - print " (MAP\n"; - print $chars[$num]{map}; - print " )\n"; - print " )\n"; -} - -sub chmove { - # - # Move a character - # - my ($char, $num) = @_; - my $i; - foreach $i (@{ $allchars{$char}{num} }) { undef $chars[$i] } - @{ $allchars{$char}{num} } = (); - @{ $allchars{$chars[$num]{id}}{num} } = grep !/$num/, - @{ $allchars{$chars[$num]{id}}{num} }; - push( @{ $allchars{$char}{num} }, $num); - $chars[$num] = $allchars{$char}; -} - -sub max { - # - # Return greater of two values - # - my ($a, $b) = @_; - return $a > $b ? $a : $b; -} - -sub subacc { - # - # Subscript accents - # - my ($num, $char, $acc, $id) = @_; - my ($h, $s1, $s2, $s3); - $allchars{$id}{wd} = $allchars{$char}{wd}; - $allchars{$id}{ht} = $allchars{$char}{ht}; - $allchars{$id}{dp} = $allchars{$acc}{dp}; - $allchars{$id}{ic} = $allchars{$char}{ic}; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - $s1 = $allchars{$char}{map}; - $s1 =~ s/\A (.*)\n\Z/(PUSH) $1 (POP)/s; - $h = sprintf("%.3f", ($allchars{$char}{wd} - $allchars{$acc}{wd}) / 2); - if ($h > 0) { $s2 = " (MOVERIGHT R $h) " } - elsif ($h < 0) { - $h = -$h; - $s2 = " (MOVELEFT R $h) "; - } - else { $s2 = " " } - $s3 = $allchars{$acc}{map}; - $s3 =~ s/\A.*(\(SETCHAR . .+?\)).*\Z/$1/s; - $allchars{$id}{map} = " $s1\n$s2$s3\n"; - $chars[$num] = $allchars{$id}; -} - -sub supacc { - # - # Superscript accents - # - my ($num, $char, $acc, $id) = @_; - my ($cb, $h, $hadj, $tallchar, $ic, $s1, $s2, $s3); - if ($char eq "i" and $allchars{"dotlessi"}) { $char = "dotlessi" } - if ($char eq "j" and $allchars{"dotlessj"}) { $char = "dotlessj" } - if ($acc eq "overdot") { $acc = "dotaccent" } - if ($acc eq "candrabindu") { - $acc = "breve"; - ($cb = $allchars{"dotaccent"}{map}) =~ s/\A.*(\(SETCHAR . .+?\)).*\Z/$1/s; - } - $allchars{$id}{wd} = $allchars{$char}{wd}; - $allchars{$id}{ht} = $allchars{$acc}{ht}; - $allchars{$id}{dp} = $allchars{$char}{dp}; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - $s1 = $allchars{$char}{map}; - $s1 =~ s/\A (.*)\n\Z/(PUSH) $1 (POP)/s; - if ($scaps and $char =~ /^[a-z]/) { # accented small caps - $tallchar = 1; - if ($char =~ /$supacc$/ - and $char !~ /under$supacc$/) { # double accs - $s2 = " (MOVEUP R $v1)"; - $allchars{$id}{ht} += $v1; - $hadj = sprintf("%.3f", $v1 * $slant); - $ic = $allchars{$char}{ic}; - } - else { # single accs - $s2 = " (MOVEUP R $scoffset)"; - $allchars{$id}{ht} += $scoffset; - $hadj = sprintf("%.3f", $scoffset * $slant); - $ic = $allchars{$acc}{ic} + $hadj; - } - } - elsif ($allchars{$char}{ht} >= ($accheight + $v2)) { # double accs - $tallchar = 1; # on caps etc. - $s2 = " (MOVEUP R ${ \($v1 + $v2) })"; - $allchars{$id}{ht} += ($v1 + $v2); - $hadj = sprintf("%.3f", ($v1 + $v2) * $slant); - $ic = $allchars{$char}{ic}; - } - elsif ($allchars{$char}{ht} > 1.15 * $xheight) { - $tallchar = 1; - if ($char =~ /$supacc$/ - and $char !~ /under$supacc$/) { # double accs - $s2 = " (MOVEUP R $v1)"; - $allchars{$id}{ht} += $v1; - $hadj = sprintf("%.3f", $v1 * $slant); - $ic = $allchars{$char}{ic}; - } - else { # caps etc. - $s2 = " (MOVEUP R $v2)"; - $allchars{$id}{ht} += $v2; - $hadj = sprintf("%.3f", $v2 * $slant); - $ic = $allchars{$char}{ic}; - } - } - else { # single accs - $s2 = " "; - $ic = $allchars{$acc}{ic}; - } - $h = sprintf("%.3f", ($allchars{$char}{wd} - $allchars{$acc}{wd}) / 2); - unless ($tallchar) { $ic -= $h } - $allchars{$id}{ic} = $ic unless $ic < 0; - $h += $hadj; - if ($h > 0) { $s2 .= " (MOVERIGHT R $h) " } - elsif ($h < 0) { - $h = -$h; - $s2 .= " (MOVELEFT R $h) "; - } - else { $s2 .= " " } - $s3 = $allchars{$acc}{map}; - $s3 =~ s/\A.*(\(SETCHAR . .+?\)).*\Z/$1/s; - if ($cb) { # candrabindu - $cb = $s2 . $cb; - if ($cbx) { - unless (($cb =~ s/(MOVERIGHT R )([0-9.]+)/$1 . ($2 + $cbx * $scale)/e) - or ($cb =~ s/(MOVELEFT R )([0-9.]+)/$1 . ($2 - $cbx * $scale)/e)) { - $cb =~ s/^( +)/"$1(MOVERIGHT R " . ($cbx * $scale) . ") "/e; - } - } - if ($cby) { - unless ($cb =~ s/(MOVEUP R )([0-9.]+)/$1 . ($2 + $cby * $scale)/e) { - $cb =~ s/^( +)/"$1(MOVEUP R " . ($cby * $scale) . ") "/e; - } - } - $cb .= "\n"; - $s1 = "(PUSH) " . $s1; - $s3 .= " (POP)"; - } - $allchars{$id}{map} = " $s1\n$s2$s3\n$cb"; - $chars[$num] = $allchars{$id}; -} - -sub underacc { - # - # Dropped accents - # - my ($num, $char, $acc, $id) = @_; - my ($h, $v, $s1, $s2, $s3); - $acc =~ s/^under//; - if ($acc eq "dot") { $acc = "period" } - if ($acc eq "candrabindu") { die "Bad definition (no such accent): $qdef\n" } - $allchars{$id}{wd} = $allchars{$char}{wd}; - $allchars{$id}{ht} = $allchars{$char}{ht}; - $allchars{$id}{ic} = $allchars{$char}{ic}; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - if ($acc =~ /^$supacc$/) { - $v = $allchars{$id}{dp} = $underadp * $scale * $shrink; - $v += ($accdepth * $shrink); - } - else { - $v = $allchars{$id}{dp} = $underddp * $scale + $allchars{$acc}{dp}; - } - $s1 = $allchars{$char}{map}; - $s1 =~ s/\A (.*)\n\Z/(PUSH) $1 (POP)/s; - if ($acc =~ /^$supacc$/) { - $h = ($allchars{$char}{wd} - ($allchars{$acc}{wd} * $shrink)) / 2 - $v * $slant; - if ($opt_s) { $s2 = " (SELECTFONT D 1)\n" } - } - else { - $h = ($allchars{$char}{wd} - $allchars{$acc}{wd}) / 2 - $v * $slant; - } - $h = sprintf("%.3f", $h); - if ($h > 0) { - $s2 .= " (MOVEDOWN R $v) (MOVERIGHT R $h) "; - } - elsif ($h < 0) { - $h = -$h; - $s2 .= " (MOVEDOWN R $v) (MOVELEFT R $h) "; - } - else { $s2 = " (MOVEDOWN R $v) " } - $s3 = $allchars{$acc}{map}; - $s3 =~ s/\A.*(\(SETCHAR . .+?\)).*\Z/$1/s; - if ($opt_s and $acc =~ /^$supacc$/) { $s3 .= "\n (SELECTFONT D 0)" } - $allchars{$id}{map} = " $s1\n$s2$s3\n"; - $chars[$num] = $allchars{$id}; -} - -sub underb { - # - # Underbar - # - my ($num, $char, $id) = @_; - my ($h, $w, $dp, $s1, $s2, $s3); - $allchars{$id}{wd} = $allchars{$char}{wd}; - $allchars{$id}{ht} = $allchars{$char}{ht}; - $allchars{$id}{dp} = $dp = $underbdp * $scale; - $allchars{$id}{ic} = $allchars{$char}{ic}; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - $s1 = $allchars{$char}{map}; - $s1 =~ s/\A (.*)\n\Z/(PUSH) $1 (POP)/s; - $h = sprintf("%.3f", ($allchars{$id}{wd} / 10 - $dp * $slant)); - $w = sprintf("%.3f", ($allchars{$id}{wd} * 8 / 10)); - if ($h > 0) { - $s2 = " (MOVEDOWN R $dp) (MOVERIGHT R $h) "; - } - elsif ($h < 0) { - $h = -$h; - $s2 = " (MOVEDOWN R $dp) (MOVELEFT R $h) "; - } - else { $s2 .= " (MOVEDOWN R $dp) " } - $s3 = "(SETRULE R ${ \($thk * $scale) } R $w)"; - $allchars{$id}{map} = " $s1\n$s2$s3\n"; - $chars[$num] = $allchars{$id}; -} - -sub digraph { - # - # Make a new character consisting of two existing characters - # - my ($num, $char, $acc, $id) = @_; - my ($one, $two, $kern, $s1, $s2); - if ($ligs =~ /^ \(LABEL $char\)\n(.*?)\n \(KRN $acc R (-?[0-9.]+)\)\n/ms) { - ($one, $two) = ($1, $2); - } - $kern = $two if $one !~ /^ \(STOP\)$/m; - $allchars{$id}{wd} = $allchars{$char}{wd} + $allchars{$acc}{wd}; - $allchars{$id}{wd} += $kern; - $allchars{$id}{ht} = max($allchars{$char}{ht}, $allchars{$acc}{ht}); - $allchars{$id}{dp} = max($allchars{$char}{dp}, $allchars{$acc}{dp}); - $allchars{$id}{ic} = $allchars{$acc}{ic}; - $allchars{$id}{id} = $id; - push( @{ $allchars{$id}{num} }, $num); - $s1 = $allchars{$char}{map}; - chomp ($s2 = $allchars{$acc}{map}); - $s1 =~ s/(\(SETCHAR .*?\))/$1\n$s2/; - if ($kern) { - if ($kern < 0) { - $kern = -$kern; - $s1 =~ s/(\(SETCHAR .*?\))/$1 (MOVELEFT R $kern)/; - } - else { $s1 =~ s/(\(SETCHAR .*?\))/$1 (MOVERIGHT R $kern)/ } - } - $allchars{$id}{map} = $s1; - $chars[$num] = $allchars{$id}; -} - -sub fixkerns { - # - # Generalise the kerning info contained in the vpl 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 ($olabel, $nlabel, @liglist, $lchar, $rchar); - if ($acc =~ /^$accents$/) { $lchar = $rchar = $char } - else { - $lchar = $char; - $rchar = $acc; - } - unless ($char =~ /^[a-z]/ and $acc =~ /^$supacc$/) { - $ligs =~ s[(\n \(LABEL )$rchar\)(?!\n \(LIG.*$)] - [$&$1$char$acc)]gm - unless $ligs =~ /\n \(LABEL $char$acc\)$/m; - $ligs =~ s[(\n \(LABEL )$rchar\)(\n \(LIG.*$)+(?!\n \(STOP\))] - [$&$1$char$acc)]gm - unless $ligs =~ /\n \(LABEL $char$acc\)$/m; - $ligs =~ s[(\n \(KRN )$lchar( .*)$] - [$&$1$char$acc$2]gm; - } - else { - if ($ligs =~ /\n \(LABEL $char\).*?\(STOP\)/s) { - $nlabel = $olabel = $&; - $nlabel =~ s/(\n \(LABEL $char)\)/$1$acc)/ - unless $ligs =~ /\n \(LABEL $char$acc\)/m; - $nlabel =~ s/\n \(LIG .*\)$//gm; - $nlabel =~ s/\n \(LABEL (?!$char$acc).*\)$//gm; - $nlabel =~ s/\n \(KRN ([A-Z]|quote).*\)$//gm; - $ligs =~ s/(\n \(LABEL )$char\).*?\(STOP\)/$olabel$nlabel/s; - } - @liglist = split /\n \(STOP\)/, $ligs; - foreach (@liglist) { - unless (/\n \(LABEL ([A-Zf]|quote).*\)$/m) { - s/(\n \(KRN $char)( .*\))$/$&$1$acc$2/gm; - } - } - $ligs = join("\n (STOP)", @liglist); - } -} |