#!/usr/contrib/bin/perl -w
# $Id: fontprep,v 1.6 1997/02/20 01:34:52 tjchol01 Exp tjchol01 $

=head1 NAME

urw_inst - Install TeX virtual fonts corresponding to URW Type1 fonts.

=head1 SYNOPSIS

B<urw_inst> I<family> [I<afmfile>...]

=head1 DESCRIPTION

B<urw_inst> given a set of AFM files grouped in a common directory
creates:

=over 4

=item *

B<font>I<family>B<.tex> - L<fontinst> input file

=item *

B<test>I<family>B<.tex> - L<latex> test input file

=item *

B<psfonts.map> - L<dvips> font alias file

=back

B<family> is a string of exactly three letters
describing a foundry and font family according to the Karl Berry
convention (see F<http://www.tug.org/fontname/>).

B<afmfile>... is an optional list of file names of a set of AFM files
belonging to one family.  If not specified all B<*.afm>s from the current
directory and from its B<afm> subdirectory will be used.

For example a command:

    urw_inst uaq u003*.afm

will create B<fontuaq.tex>, B<testuaq.tex>, B<psfonts.map> files based
on files from the current directory matching the pattern B<u003*.afm>.

URW font families often contain both Regular and Medium (or Book and
Regular) weights which leads to conflicts during assigning them LaTeX
NFSS weights.  In general this problem is solved by assigning the `B<m>'
weight to the font having the most variants and `B<sl>' or `B<sb>' to
the remaining fonts.  This heuristic approach is not very robust and
sometimes there can arise a need to edit resulting fontinst and test
files.

=head1 NOTES

This program is very similar in concept to B<vfinst> by Alan Hoenig.
The difference lies in better ``weight management,'' specialization for
URW fonts and in that it does not attempt to generate any fake (oblique,
unslanted, etc.) fonts.

=cut

#---------------------------------------------------------------------
require 5.000;
use strict;
use integer;

require $ENV{HOME} . "/bin/urw.common";

my $DMODE = 0755;

my @expansions =
    (
     ["UltraCondensed", "uc", "o"],
     ["ExtraCondensed", "ec", "o"],
     ["SemiCondensed", "sc", "n"],
     ["Condensed", "c", "c"],          # at the end
     ["Narrow", "c", "n"],
     ["Compressed", "sc", "n"],
     ["SemiExpanded", "sx", "e"],
     ["ExtraExpanded", "ex", "e"],
     ["UltraExpanded", "ux", "e"],
     ["Expanded", "x", "e"],           # at the end

     ["Extended", "x", "x"],
     ["Wide", "x", "w"],
     );

my @nfss_weights = qw (ul el l sl m sb b eb ub);

my @nfss_weight_map = (0, 1, 2, 4, 4, 4, 5, 5, 6, 7, 7, 8, 8);

my @weights =
    (
     ["UltraLight|Thin", 0, "t"],
     ["ExtraLight", 1, "i"],
     ["Light", 2, "l"],

     ["Book", 3, "k"],
     ["Regular", 4, "r"],
     ["Medium|Normal", 5, "m"],

     ["Demi", 6, "d"],				# match before Bold
     ["Semi", 7, "s"],

     ["ExtraBold|Compact", 9, "x"],
     ["Heavy", 10, "h"],
     ["Black", 11, "c"],
     ["Ultra", 12, "u"],

     ["Bold", 8, "b"],				# match last
     );

my @variants =
    (
     ["SC|SmallCaps", "sc", "c"],
     ["Display|Titling|Caption|Headline|TallCaps|Swash(Caps)?|Lombardic(Caps)?", "", "d"],
     ["Engraved|Copperplate|Elite", "", "e"],
     ["Fraktur|Gothic|OldEnglish|Handtooled", "", "f"],
     ["SmallText", "", "g"],
     ["Shadow(ed)?", "sh", "h"],
     ["Ital(ic)?|Kursiv", "it", "i"],
     ["Outline|OpenFace|Blanks", "ol", "l"],
     ["Informal|Fashion|Schlbk", "", "n"],
     ["Obl(ique)?|Slanted", "sl", "o"],
     ["Ornaments", "", "p"],
     ["Gothic|Sans", "", "s"],
     ["Monospace|Typewriter", "", "t"],
     ["Unslanted", "ui", "u"],
     ["Script|Handwritten|Swash|Calligraphy|Cursive|Tango", "", "w"],
     );


die "Usage: urw_inst family [afmfile...]\n" if ($#ARGV < 0);
my $family = shift @ARGV;

die "Family name length must be exactly three characters (was `$family')\n"
    if (length ($family) != 3);

if ($#ARGV < 0) {
    opendir (DIR, ".");                         # scan current directory
    @ARGV = grep (/^.+\.afm$/, readdir (DIR));
    closedir (DIR);
    opendir (DIR, "./afm");                     # scan afm subdirectory
    push (@ARGV, map ("./afm/" . $_, grep (/^.+\.afm$/, readdir (DIR))));
    closedir (DIR);
}

if (!-d "./dvips") {
    mkdir ("./dvips", $DMODE) || die "Cannot create `./dvips' subdirectory: $!\n";
}
open (MAP, ">./dvips/$family.map") || die "Cannot create `./dvips/$family.map' file: $!\n";
open (DVIPS, ">./dvips/config.$family") || die "Cannot create `./dvips/config.$family' file: $!\n";
print DVIPS "p +$family.map\n";
close DVIPS;

open (FONT, ">font$family.tex") || die "Cannot create `font$family.tex' file: $!\n";
print FONT '\\input fontinst.sty
\\def\\urwfont#1#2#3#4#5{
  \\immediate\\write16{Installing #3/#4/#5 from #2 as #1.}
  \\installfont{#1}{#2,latin}{T1}{T1}{#3}{#4}{#5}{}
}
\\installfonts
';
print FONT "\\installfamily{T1}{$family}{}\n";


open (TEST, ">test$family.tex") || die "Cannot create `test$family.tex' file: $!\n";
print TEST '\\documentclass{article}

\\usepackage[T1]{polski}
\\prefixing

\\setlength{\\textwidth}{7.5in}
\\setlength{\\textheight}{9.0in}
\\setlength{\\topmargin}{0in}
\\setlength{\\oddsidemargin}{-0.5in}

\\def\\fhead#1{%
  \\centerline{\\normalfont\\Huge\textbf{#1}}
  \\vspace*{1ex}
}

\\def\\ftest#1#2#3#4{%
\\noindent
\\parbox{\textwidth}{\\noindent
  \\centerline{\\textbf{#4:} #1//#2//#3}\\\\
  \\fontsize{24}{28}\\usefont{T1}{#1}{#2}{#3}%
  \\strut abcdefghijklmnopqrstuvwxyz/a/c/e/l/n/o/s/x/z\\\\
  \\strut ABCDEFGHIJKLMNOPQRSTUVWXYZ\\\\
  \\strut 1234567890.,:;,,``\'\'\\guillemotleft\\guillemotright !?\\&*%
          /A/C/E/L/N/O/S/X/Z\\\\[0.5ex]
  \\normalsize
  The quick brown dog jumps over the lazy dog.
  Zw\"olf s\"u\ss{}e Boxer jagten Eva k\"ampfend quer durch Vinyl,
  portez ce vieux whiskey au juge blond qui fume.}%
  \\vspace*{0.2in}%
}
\\pagestyle{empty}
\\begin{document}
';

my ($file, $basefile);
my @fontlist = ();
my %weight_cnts = ();
my $firstfont = 1;				# print family name only once

foreach $file (@ARGV) {
    my ($ps_name, $fullname, $familyname, $weight,
	$encoding, $italicangle, $monowidth) = @{&get_afm_data ($file)};

    die "No FontName in $file.\n" unless $ps_name;

    $file =~ s/\.afm$//i;			# remove possible extension
    $basefile = $file;
    $basefile =~ s/^.*\///i;			# remove possible path
    print MAP "$basefile $ps_name <$basefile.pfb\n";
    if ($firstfont) {
	$familyname =~ s/\s+|SC|EE$//g;		# remove spaces
	$familyname =~ s/^URW/URW /;		# restore space after URW
	print TEST "\\fhead{$familyname}\n";
	$firstfont = 0;
    }


# NFSS components
    my $nfss_expansion = "";
    my $nfss_weight_index = -1;			# not found
    my $nfss_shape = "";			# normal

# Karl Berry font name components
    my $kb_expansion = "";
    my $kb_weight = "";				# regular
    my $kb_variants = "";

    if ($ps_name =~ /\w+-(\w+)/) {		# only variants in the family name
	my $fname = $1;
#	study $fname;
        match_properties (\@expansions, $fname, \$nfss_expansion, \$kb_expansion, 0);
        match_properties (\@weights, $fname, \$nfss_weight_index, \$kb_weight, 0);
    }
    match_properties (\@variants, $ps_name, \$nfss_shape, \$kb_variants, 1);

    $nfss_weight_index = 4 if $nfss_weight_index < 0; # medium is default
    $nfss_shape = "n" unless $nfss_shape;        # normal

    $kb_weight = "r" unless $kb_weight;
# conflicts in KB have to be resolved by hand
    my $kb_name = $family . $kb_weight . $kb_variants . "q" . $kb_expansion;

    $weight_cnts{$nfss_weight_index}++;

    push (@fontlist, [$ps_name, $file, $basefile, $kb_name, $nfss_weight_index, $nfss_expansion, $nfss_shape]);

}


# heuristic weight conflict solver
my @wlist = sort {$a <=> $b} keys %weight_cnts;
print "@wlist, @nfss_weight_map\n";
print "@nfss_weight_map[@wlist]\n";
my $i;

sub wmap {
    my ($j) = @_;
    \$nfss_weight_map[$wlist[$j]]
}

for ($i = 0; $i < $#wlist; $i++) {
    my $j = $i;
    while ( ${&wmap ($j)} >= ${&wmap ($j + 1)} && $j >= 0 && $j < $#wlist) {
	print "--- $j\n";
	if ($wlist[$j] >= 4) {				# more than Book
	    $j++;
	    ${&wmap ($j)} = MIN ($#nfss_weights, ${&wmap ($j)} + 1);
	} else {
	    ${&wmap ($j)} = MAX (0, ${&wmap ($j)} - 1);
	    $j--;
	}
    }
}
print "@wlist, @nfss_weight_map\n";
print "@nfss_weight_map[@wlist]\n";

# sort fonts by weight, then by length of PS name
{
    no strict "vars";
    sub fontsort {
	$$a[4] <=> $$b[4] || length ($$a[0]) <=> length ($$b[0]);
    }
    @fontlist = sort fontsort @fontlist;
}

my $did_warn = 0;
my %kb_all = ();
my %nfss_all = ();

my $fset;
foreach $fset (@fontlist) {
    my ($ps_name, $file, $basefile, $kb_name, $nfss_weight_index,
        $nfss_expansion, $nfss_shape) = @$fset;

    my $nfss_weight = $nfss_weights[ $nfss_weight_map[$nfss_weight_index] ];

    my $nfss_series = $nfss_weight . $nfss_expansion;
    $nfss_series = "m" unless $nfss_series;      # medium medium
    my $nfss_name = "$family/$nfss_series/$nfss_shape";

    print "$nfss_weight_index: $file -> $ps_name -> $kb_name -> $nfss_name\n";

    my $warnings = "";
    if ($kb_all{$kb_name}++) {
        warn "*** Warning: KB name conflict for $kb_name.\n";
        $warnings .= " % KB";
    }
    if ($nfss_all{$nfss_name}++) {
        warn "*** Warning: NFSS name conflict for $nfss_name.\n";
        $warnings .= " % NFSS";
    }
    $did_warn = 1 if ($warnings);

    print FONT "\\urwfont{$kb_name}{$basefile}{$family}{$nfss_series}{$nfss_shape}$warnings\n";
    print TEST "\\ftest{$family}{$nfss_series}{$nfss_shape}{$ps_name}$warnings\n";
}

print FONT "\\endinstallfonts\\bye\n";
close (FONT);

print TEST "\\end{document}\n";
close (TEST);

close (MAP);

exit $did_warn;

#------------------------------------------------------------
sub match_properties {
    my ($plist, $fname, $p1, $p2, $many) = @_;
    my $w;
    foreach $w (@$plist) {
        if ($fname =~ /$$w[0]/) {
	    if ($many) {			# allow several variants
		$$p1 .= $$w[1];
		$$p2 .= $$w[2];
	    } else {
		$$p1 = $$w[1];
		$$p2 = $$w[2];
		last;
	    }
        }
    }
};

sub MIN {
    my ($min, $foo) = @_;
    $min = $foo if $min > $foo;
}

sub MAX {
    my ($max, $foo) = @_;
    $max = $foo if $max < $foo;
}