#!/usr/bin/perl
#  A filter to scale and translate XTAL contour plot postscript to the 
#  lower left corner of the page. Also the bounding box is adjusted to the
#  new scaled and translated postscript figure. This is necessary for direct 
#  porting to the Macintosh for use in Microsoft Word documents. 
#  It also enables ready inclusion in a FrameMaker 
#  anchored  or floating frame of dimensions  $2 (width) $3 (height) in
#  units of pt (points - 72 per inch).   
#
#  Its free. 
#  Use it, abuse it, but don't run to me when it trashes your filesystem.
#                                             Doug du Boulay (15/6/99).

#
# process command line args
# -------------------------
#
$progname = $0 ;
if ( $#ARGV < 2 ) {                    # not enuf arguments so quit 
  print STDERR "$progname: A filter for XTAL3.6 postscript CONTOUR plots. It\n" ;
  print STDERR "         scales and translates a vector PS image to the lower \n" ;
  print STDERR "         left corner and optimises the bounding box.\n" ;
  print STDERR " \n" ;
  print STDERR "Usage:  $progname infile width(pt) height(pt) linewidth(optional)\n" ;
  exit 1 ;
}

$psfile = $ARGV[0] ;
$width  = $ARGV[1] ;
$height = $ARGV[2] ;
if ( $ARGV[3] ) { $linewidth = $ARGV[3] ;   # does absolutely nothing !
} else          { $linewidth = 3 ;  }

#
# Open the input file and test if it's a PS file 
# ----------------------------------------------
#

unless (open PSFILE, $psfile) {
         print STDERR "can't open $psfile: $!\n";
         return;
}
print STDERR "opened $psfile for reading.\n" ;
$lines=0; @file= () ;               # initialize an empty array
while (<PSFILE>) {                  # slurp in the whole postscript file
    if (/^\s*[.\d]*\s*[.\d]*\s*DOCUMENT\s*$/) {$document=$lines;}#  save the last header line
    if (/ BEGINPAGE\s*$/) {         # get the xscal and y scal
           @Fld = split(' ', $_, 9999);  # split line on fields
           $xscal = $Fld[1]; $yscal = $Fld[2]; 
           $beginpage = $lines;     # save the line number
    }
    if ( /\%\%BoundingBox\:\s*[\d.]+s*/ ) { $bbox   = $lines; } 
    $file[$lines++] = $_  ;         # save file contents in one dirty big array
} 
close PSFILE ;                      # close the opened file

if ( $file[0] =~ /^\%\!/ ) {        # test for magic postscript number
         print STDERR " $psfile is a poscript file. $lines lines \n"  ;
} else  {
         print STDERR " $psfile is not a poscript file.\n"  ;
         exit 1 ;
}

#
#   Parse the file  looking for the contour plot bounding box
#   ---------------------------------------------------------
#

$FS = ' ';		# set field separator
$str1 = ''; $str2 = ''; $str3 = ''; 
$llx=0 ; $lly=0 ; $urx=0 ; $ury = 0; #   Set preliminary bounding box values
#
$lin = -1;
linex: while ( $lin++ <$lines ) {
    $_ = $file[$lin] ;           #get next line
    chop;	                  #strip record separator
    $str1 = $str2; $str2 = $str3; $str3 = $_;
    $k = -1;
    $strin = $str1 . ' ' . $str2 . ' ' . $str3 ;
    $len = (@p = split(' ', $strin, 9999));
    while ($len - $k >= 17 ) {
        $x1 = $p[$k + 1] ; $y1 = $p[$k + 2] ; 
        if ($x1 eq 'L' || $y1 eq 'L') {$k++; } 
        elsif ($x1 eq $p[$k +  4] && $x1 eq $p[$k + 13] && $x1 eq $p[$k + 16] &&
	       $y1 eq $p[$k +  5] && $y1 eq $p[$k +  8] && $y1 eq $p[$k + 17] ) {
               # actually this test may not be strict enough !
	          $llx = $p[$k + 1]; $lly = $p[$k + 2]; $urx = $p[$k +7]; $ury = $p[$k + 11];
	      last linex; last;
	}
	else { $k++; }
    }
}
#
#   hopefully got the  bounding box
#   -------------------------------
#
if ($urx == 0 or $ury == 0 ) {     # nope - then try for filled mode contours
       print STDERR " Wasn't an unfilled contour PS fig.\n"  ;
       print STDERR " Searching for a filled contour PS fig.\n"  ;

$str1 = ''; $str2 = ''; $str3 = ''; $str4 = ''; 
$lin = -1;
$llx=0 ; $lly=0 ; $urx=0 ; $ury = 0; #   Set preliminary bounding box values
line2: while ( $lin++ <$lines ) {
    $_ = $file[$lin] ;           #get next line
    chop;	                  #strip record separator
    $str1 = $str2; $str2 = $str3; $str3 = $str4; $str4 = $_;
    $k = -1;
    $strin = $str1 . ' ' . $str2 . ' ' . $str3 . ' ' . $str4;
    $len = (@p = split(' ', $strin, 9999));
    while ($len - $k >= 38) {
        $x1 = $p[$k + 1] ; $y1 = $p[$k + 2] ;
	if ($x1 eq $p[$k +  4] && $x1 eq $p[$k + 27] && $x1 eq $p[$k + 31] &&
	    $x1 eq $p[$k + 34] && $x1 eq $p[$k + 37] &&
	    $y1 eq $p[$k +  5] && $y1 eq $p[$k +  8] && $y1 eq $p[$k + 12] &&
            $y1 eq $p[$k + 15] && $y1 eq $p[$k + 38] ) { 
	      $llx = $p[$k + 1]; $lly = $p[$k + 2]; $urx = $p[$k + 7]; $ury = $p[$k + 18];
	      last line2; last;
	}
	else { $k++; }
    }
}

   if ($urx == 0 or $ury == 0 ) {
       print STDERR " Couldn't locate the map border. Quiting.\n"  ;
       exit 1; 
   }
}
#
#   calculate scales and offsets
#   ----------------------------
#

printf STDERR " %s   %s   %s   %s  %s  %s \n", $llx, $lly, $urx, $ury, $xscal, $yscal;

$pptx = $xscal * ($urx - $llx);
$ppty = $yscal * ($ury - $lly);
$nxs  = $xscal * ($width  - $width  * .025) / $pptx;
$nys  = $yscal * ($height - $height * .025) / $ppty;
if ($nxs > $nys) { $nxs = $nys; }      # preserve aspect ratio
$xtra = -$nxs * $llx + 2;
$ytra = -$nxs * $lly + 2;
$bburx = $nxs * ($urx - $llx) + 8;
$bbury = $nxs * ($ury - $lly) + 8;

#printf STDERR " %-4.0f %-4.0f translate %-1.3f %-1.3f scale \n", $xtra, $ytra, $nxs, $nxs;
#
#   Write out a new contour plot
#   ----------------------------
#
$lin = -1;

while ( $lin++ <$lines ) {

   if      ($lin == 0 ) {
       printf "\%\!PS-Adobe-3.0 EPSF-3.0\n" ; # ensure its encapsulated

   } elsif ($lin == $bbox ) {             # set new bounding box
       printf "\%\%BoundingBox: 0 0 %-4.0f %-4.0f \n", $bburx, $bbury;

   } elsif ($lin == $document ) {         # fudge the printing clippath
       printf "0 0 moveto %-5.0f 0 lineto %-5.0f %-5.0f lineto 0 %-5.0f lineto closepath clip\n",
             $bburx, $bburx, $bbury, $bbury ;
                                          # change document size
       printf " %-5.0f  %-5.0f DOCUMENT \n", $bburx, $bbury ;

   } elsif ($lin == $beginpage ) { 
       printf "save  %f %f  %-5.0f  %-5.0f 0 BEGINPAGE \n",$nxs,$nxs, $bburx, $bbury ;
       printf " %-5.0f %-5.0f translate\n", -$llx, -$lly;

   } else  {  
       print  $file[$lin] ;               # default printing of all other lines
   }
}