#!/afs/athena/contrib/perl5/perl -w
# This script "decapsulates" EPS files, showing them on one page.

use strict;
use IO::File;
use POSIX qw( floor ceil );
use Getopt::Long;


my (%unit) = (pt => 1,
	      in => 72,
	      mm => 72/25.4,
	      cm => 72/2.54);

sub units (@) {
  my @dim = grep length $_, map split(/[\s,]+(?![\s,A-Za-z])/, $_), @_;
  foreach (@dim) { s/^(.*?)\s*([A-Za-z]+)$/$1 * $unit{$2}/e; }
  @dim;
}

my (%paper) = (letter => '8.5 in, 11 in',
	       a4 =>     '209.903 mm, 297.039 mm');

my %param = ( paper => 'letter', margins => '.5in' );

GetOptions( \%param, 'center!', 'scale=f', 'paper=s', 'margins=s')
  or die <<"EndOfUsage";
Usage: $0 [options] file [file...]
Options:
  -c  -center
          Center the EPSF image on the page.  Otherwise, the image is placed
          in the lower left corner of the viewable area.
  -s  -scale=<float>
          Force the specified scaling factor.  By default, the EPSF file is
          scaled as large as the viewable area will permit.
  -p  -paper=(letter|a4)
          Specify a standard paper size for the PostScript output.
      -paper=<width>,<height>
          Specify a non-standard paper size for the output.  The dimensions
          can be specified as any of: 792, 792pt, 11in, 279.4mm, 27.94cm.
  -m  -margins=<size>
      -margins=<left/right>,<top/bot>
      -margins=<left>,<right>,<top>,<bot>
          Select the margin size for the viewable area.  The default is 1/2in.
EndOfUsage

use vars qw( @VIEW );
{
  my $PAPER = $param{paper};

  my @PAGEBOX = units( exists $paper{$PAPER} ? $paper{$PAPER} : $PAPER );
  @PAGEBOX == 2 or die "Invalid paper specification '$PAPER'";

  my $MARGIN = $param{margins};

  my @MARGINS = units $MARGIN;
  @MARGINS == 1 and @MARGINS = @MARGINS[0,0];
  @MARGINS == 2 and @MARGINS = @MARGINS[0,0,1,1];
  @MARGINS == 4 or die "Invalid margin specification '$MARGIN'";

  @PAGEBOX = (0,0,@PAGEBOX);
  @MARGINS = @MARGINS[0,3,1,2];   # reorder to left,bot,right,top

  @VIEW = ( int($PAGEBOX[0]+$MARGINS[0]),
	    int($PAGEBOX[1]+$MARGINS[1]),
	    int($PAGEBOX[2]-$MARGINS[2]),
	    int($PAGEBOX[3]-$MARGINS[3]) );
}

sub parse_headers ($) {
  my ($name) = @_;
  my $FILE = new IO::File $name, '<'
    or die "Can't open $name: $!";

  local ($_);
  my %hdr;

  while (<$FILE>) {
    last unless /^%/;
    $hdr{bbox} = [split /\s+/, $1, 4]
      if /^%%boundingbox:\s*(.*)\s*$/i;
    $hdr{hrbbox} = [split /\s+/, $1, 4]
      if /^%%hiresboundingbox:\s*(.*)\s*$/i;
    $hdr{title} = $1
      if /^%%title:\s*(.*)\s*$/i;
  }

  exists $hdr{bbox}
    || die "EPSF bounding box was not supplied, aborting";
  @{$hdr{bbox}}
    || die "EPSF bounding box data is missing, aborting";
  $hdr{bbox}[0] =~ /\(atend\)/
    && die "(atend) bounding boxes are not supported yet, aborting";
  @{$hdr{bbox}} == 4
    || die "Invalid bounding box (@{$hdr{bbox}}) encountered";

  $hdr{title} = 'unknown EPSF document'
    unless exists $hdr{title};

  \%hdr;
}

sub pick_val ($$) {
  my ($param, $hdr) = @_;
  my %val;

  if (exists $param->{title}) {
    $val{title} = $param->{title};
  } else {
    $val{title} = $hdr->{title};
    $val{title} =~ s/(\)?)\s*$/ -- stand-alone PostScript$1/;
  }

  $val{date} = exists $param->{date} ? $param->{date} : localtime;

  my ($llx,  $lly,  $urx,  $ury) = @{$hdr->{bbox}};
  my ($vllx, $vlly, $vurx, $vury) = @VIEW;
  my $scale;

  if (exists $param->{scale}) {
    $scale = $param->{scale};
  } else {
    my $ixscale = ($urx-$llx)/($vurx-$vllx);  # this is 1/scale
    my $iyscale = ($ury-$lly)/($vury-$vlly);  # this is 1/scale
    my $iscale = (abs($ixscale) > abs($iyscale)) ? $ixscale : $iyscale;
    $iscale = 1 if $iscale == 0;
    $scale = 1/$iscale;
  }

  $val{scale} = $scale;

  if ($param->{center}) {
    $val{xlate} = [ floor(($vurx + $vllx - $scale * ($urx + $llx)) / 2),
		    floor(($vury + $vlly - $scale * ($ury + $lly)) / 2) ];
  } else {
    $val{xlate} = [ $vllx - floor($scale * $llx),
		    $vllx - floor($scale * $lly) ];
  }

  $val{bbox} = [ $val{xlate}[0] + floor($scale * $llx),
		 $val{xlate}[1] + floor($scale * $lly),
		 $val{xlate}[0] + ceil($scale * $urx),
		 $val{xlate}[1] + ceil($scale * $ury) ];

  \%val;
}

sub spew_ps ($$$) {
  my ($epsf, $val, $ps) = @_;
  my $EPSF = new IO::File $epsf, '<'
    or die "Can't open $epsf: $!";
  my $PS = new IO::File $ps, '>'
    or die "Can't open $ps: $!";

  my $bbox = $val->{bbox};

  print $PS "%!PS-Adobe-3.0\n";
  print $PS "%%BoundingBox: @$bbox\n";
  print $PS "%%Title: $val->{title}\n";
  print $PS "%%CreationDate: $val->{date}\n";

  print $PS <<'EndOfPS_1';
%%Creator: epsf2ps.pl (EPSF "decapsulation" script)
%%Pages: 1
%%EndComments

%%BeginProlog
/mkrect { %   x1 y1 x2 y2 => -		add a rectangle to the current path
  dup 4 index exch moveto 1 index exch lineto 1 index lineto lineto closepath
} bind def
%%EndProlog

%%Page: 1 1
% prepare for the EPS file
/_epsf_save save def			% Save state for cleanup
/_epsf_dict_count countdictstack def	% Save size of dictstack...
/_epsf_op_count count 1 sub def		% Count objects on op stack
userdict begin		% Make userdict current dict
/showpage {} def	% Redefine showpage to be null (removed by restore)
0 setgray 0 setlinecap 1 setlinewidth 0 setlinejoin
10 setmiterlimit [ ] 0 setdash newpath
% If level not equal to 1 then reset strokeadjust and overprint
/languagelevel where {
  pop languagelevel 1 ne
  { false setstrokeadjust false setoverprint } if
} if

EndOfPS_1

  print $PS "@$bbox mkrect clip newpath	% Set the clipping path\n";
  print $PS "@{$val->{xlate}} translate	% Position the EPS file\n";
  print $PS "$val->{scale} dup scale	% Scale to desired size\n";

  print $PS "%%BeginDocument: $epsf\n";
  local ($_);
  while (<$EPSF>) { print $PS $_; }

  print $PS <<'EndOfPS_2';
%%EndDocument

% clean up after EPS file
count _epsf_op_count sub { pop } repeat			% clean stack
countdictstack _epsf_dict_count sub { end } repeat	% clean dict stack
_epsf_save restore
showpage
%%EndPage
%%EOF
EndOfPS_2
}

sub name_epsf2ps ($) {
  my ($name) = @_;
  ($name =~ s/\.epsf?$/.ps/i)
    || ($name .= '.ps');
  $name;
}

for my $epsf (@ARGV) {
  my $ps = name_epsf2ps $epsf;

  my $hdr = parse_headers $epsf;
  my $val = pick_val \%param, $hdr;
  spew_ps $epsf, $val, $ps;
}