#!/usr/contrib/bin/perl -w
# Remove bitmap fonts and enable replacing them with Postscript versions.

# $Log: fontstrip,v $
# Revision 1.3  1996/11/07 22:55:54  tjchol01
# Line breaking in rf, cleaned.
#
# Revision 1.2  1996/11/07 17:46:32  tjchol01
# Converting width data from df to rf format.
#
# Revision 1.1  1996/11/07 15:16:59  tjchol01
# Initial revision

# TODO:
# don't calc @chars for every font
# resolution
# font size

my $texpspro = "/usr/contrib/lib/texmf/dvips/texps.pro";
my $fonts300 = "/usr1/tjchol01/texput.dps";

my $mainsize = "41.666668";

my $progname = "fontstrip";

$| = 1;						# output buffering off


use strict;
#no strict "refs";

my $verbose = 0;

while ($_ = $ARGV[0], /^-/) {			# process options
    shift;
    last if /^--$/;
    if (/^-D(.*)/) {
#	$debug = $1;
    } elsif (/^-v/) {
	$verbose++;
    } else {
	print "Usage: $progname [-v] file.ps\n";
	exit 1;
    }
}


open (PROLOG, $texpspro) or die "File not found: $a.\n";
my $sign = <PROLOG>;
chop $sign;					# get rid of the first line
die "Postscript file expected (found $sign).\n" unless $sign =~ "^%!";



my @fonts = ("unknown", "cmti10", "cmmi9", "cmr9", "cmbx10", "cmbx12", "cmcsc10", "cmsl10", "cmsy8", "cmmi8", "cmr12", "cmr8", "cmsy10", "cmsy7", "cmsy5", "cmmi10", "cmmi7", "cmmi5", "cmr10", "cmr7", "cmr5", "cmex10", "x", "x");

#my @fonts = ("unknown", "cmr17", "cmr10", "cmr12", "cmr9", "cmbx9", "cmsl9");

my @chars;
my @hashes;

my @argv_save = @ARGV;
@ARGV = ($fonts300);
my %fhash = ();
anafile (1);

@ARGV = @argv_save;
anafile (0);

exit 0;


sub anafile {
    my ($init) = @_;
    my $sign = <>;
    exit 1 if (!$sign);				# file not found?
    if ($sign !~ "^%!") {
	chop $sign;
	die "Postscript file expected (found $sign).\n";
    }
    if (!$init) {
	print "$sign";				# print %! back in place
    }

    my $creator = 0;
    my $procset = 0;
    my $flines = "";
    my $seq;
    my ($key, $val);

    if (!$init && $verbose) {
	print STDERR "   @fonts\n";
    }
    while (<>) {
	if (!$creator && /^%%Creator: (.*)$/) {
	    die "Can work only on dvips files (found $1).\n" unless $1 =~ /dvips/;
#	    print "%%DocumentFonts: $mainfont\n";	# insert before %%Creator
	    $creator = 1;
	} elsif (!$init && !$procset && /^%%EndProcSet/) {
	    print;
	    print "%%BeginProcSet: texps.pro\n"; # include texps.pro
	    print <PROLOG>;
	    print "%%EndProcSet\n";
	    $procset = 1;
	} elsif ($seq = /\@start\s+\/[FG].\s+\d+\s+\d+\s+df/../E\s+end/) { # bitmap font definitions area
	    $flines .= $_;				# accumulate lines
	    if ($seq =~ /E0/) {			# last line -> analyze
		my %fontdefs;
		my $pre = "";
		my $post = "";

		my $curfont = 1;		# start at first known font
		# for all bitmap fonts
		while ($flines =~ /(\/([FG].)\s+\d+\s+\d+\s+df.*?[DI]\s+E\s+)/sg) {
		    if (!$pre) {
			$pre = $`;
		    }
		    my $fontdef = $1;
		    my $fontname = $2;
		    $post = $';			# a bit abusive

		    &anafont ($fontdef, $init);

		    if ($init) {
			map (push (@{$fhash{$_}}, $curfont), @hashes); # store hashes
#			while (($key, $val) = each %fhash) { # changes order
#			    print STDERR "$key: ", @$val, "\n";
#			}

		    } else {
#			print STDERR "XXXX $fontname: @hashes\n";
			my @x = map (0, @fonts);
			my @y = map (defined ($fhash{$_}) ? @{$fhash{$_}} : (0), @hashes); # unknown hash -> undefined font
			map ($x[$_]++, @y);
			my $charcnt = ($#chars + 1) / 2;
			my ($max, $maxpos, $max2, $max2pos, $i);
			$max = $max2 = -1;
			for ($i = 0; $i <= $#x; $i++) {
			    my $a = $x[$i];
			    if ($a > $max) {
				$max2 = $max;
				$max2pos = $maxpos;
				$max = $a;
				$maxpos = $i;
			    } elsif ($a > $max2) {
				$max2 = $a;
				$max2pos = $i;
			    }
			}
			$max /= $charcnt;	# normalize
			$max2 /= $charcnt;
			if ($maxpos > 0 && $max - $max2 > 0.2) {
			    if ($max < 0.9 || $max2 > 0.3) {
				print STDERR "Dubious      ";
			    }
			    if ($verbose > 0) {
				print STDERR "$fontname: @x, $fonts[$maxpos]\n";
			    }
			    $fontdefs{$fontname} = [@chars, $fonts[$maxpos]]; # store old bitmap

			} else {
			    warn "Unrecognized $fontname: @x\n";
			    $fontdefs{$fontname} = [@chars, $fontdef]; # store old bitmap
			}


		    }

		    $curfont++;
		} # while $flines

		if (!$init) {
		    print "$pre";		# prefix for untouched definitions
		    while (($key, $val) = each %fontdefs) { # changes order
			if (length ($$val[-1]) > 20) { # long = bitmap
			    print $$val[-1], "\n"; # to avoid exceeding 72 columns
			} else {
			    my $psname = pop (@chars);
			    print "% -----------------------------------\n"; # mark beginning of insert
			    print "% $progname: $key converted to $psname\n";
			    print "/$key ";		# Postscript font stub
			    &putrf (@chars);
			    print " $mainsize /$psname rf\n";
			}
		    }
		    print "$post\n";
		}

	    } # if $seq
	} else {
	    if (!$init) {
		print;					# normal line
	    }
	}
    } # while <>
    if (!$creator) {
	warn "%%Creator line not found -- suspect non-dvips file.\n";
	exit 1 if ($init);
    }
    if (!$flines) {
	warn "No bitmap font definitions found -- suspect a document with Postscript fonts.\nNo changes made.\n";
	exit 1 if ($init);
    }
}


# set @chars and @hashes
sub anafont {
    my ($fontdef, $init) = @_;

    @chars = ();
    @hashes = ();
    my $lastchar = -1;		# default when 'I' is first
    while ($fontdef =~ /<([0-9A-F\s]+)>\s*(([\d.]+\s+){4})?(I|(\d+)\s+D)/sg) {
	die "Parameters of the 'D' command are not supported.\n" if ($2);
	my $chdata = $1;

	if ($5) {
	    $lastchar = $5;
	} else {
	    $lastchar++;
	}
	$chdata =~ s/\s//g;		# get rid of whitespace
	my $h = &hash ($lastchar, $chdata);
	push (@hashes, $h);

	if (!$init) {
	    my $dx = hex (substr ($chdata, -2));
	    push (@chars, ($lastchar, $dx)); # stack widths
	}
    }
}

sub hash {
    my ($char, $data) = @_;
    if (length ($data) > 16) {
	$data = substr ($data, 16);		# pos and last 3 bytes
    }
    return ($char + 100 * hex ($data)) % 30011;
}


sub putrf {
    my @chars = @_;

    my $charcnt = ($#chars + 1) / 2;
    my $lastchar = 256;
    my $linewi = 0;
    while ($#chars > 0) {
	my $width = pop (@chars);		# get a pair
	my $char = pop (@chars);
	if ($char < $lastchar - 1) {
	    print $lastchar - $char - 1, "[";
	}
	print $width, " ";
	print "\n" if ($linewi++ % 10 == 0); # avoid too long lines
	$lastchar = $char;
    }
    if ($lastchar > 1) {		# go down to 0
	print $lastchar, "[";
    }
    print "{}$charcnt";
}