Module:       postscript-duim
Synopsis:     DUIM postscript backend
Author:       Scott McKay, Andy Armstrong
Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
              All rights reserved.
License:      Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND

/// PostScript ports

// This does not conform to the conventions described under Appendix C:
// Structuring Conventions of the PostScript Language Reference Manual.
// Part of the reason for non-conformance is the maybe-send-feature
// hack.  Were it possible for this implementation to send more than
// one page to the printer, then the stuff downloaded using the
// maybe-send-feature hack would be associated with a single page
// rather than with the whole document and reordering of the pages by
// some other tool could cause features which were first generated by
// one page and later referenced by another to become undefined if
// those pages were reordered.  The %% comments do conform except for
// %%Page and the feature reordering problem.

// Pen widths currently use "1 setlinewidth" for minimum line thickness.
// This can produce a line 2 pixels wide since there can be 2 pixels that
// are less than or equal to 1/2 away from the line.  "0 setlinewidth"
// means to use the minimum for the resolution of the device.  At least
// now, for the case of pen width of 1 (normal), this will use "0 setlinewidth"
// for output to the Apple Laser Writer.


// Estimation of % baseline to bottom.
define variable *ps-magic-baseline-factor* :: <single-float> = 0.2;

// 1 "average" pixel is about 1.2 points
define variable *1-pixel=points* :: <single-float> = 1.2;


// Convert CLIM units ("pixels") to (printers') points
define macro pixels-to-points
  { pixels-to-points () }
    => { }
  { pixels-to-points (?x:expression, ?more:*) }
    => { ?x := ?x * *1-pixel=points*;
         pixels-to-points(?more); }
end macro;

define macro points-to-pixels
  { points-to-pixels () }
    => { }
  { points-to-pixels (?x:expression, ?more:*) }
    => { ?x := as(<single-float>, ?x / *1-pixel=points*);
         points-to-pixels(?more); }
end macro;


/// Basic PostScript ports

define open class <postscript-port> (<basic-port>)
  sealed slot %font-map :: <stretchy-object-vector> = make(<stretchy-vector>);
  sealed slot %device-units-per-inch = 72;
  sealed slot %x-resolution, init-keyword: x-resolution:;
  sealed slot %y-resolution, init-keyword: y-resolution:;
  sealed slot %page-width, init-keyword: page-width:;
  sealed slot %page-height, init-keyword: page-height:;
  sealed slot %x-indent, init-keyword: x-indent:;
  sealed slot %y-indent, init-keyword: y-indent:;
end class <postscript-port>;

// The initargs PAGE-WIDTH,: PAGE-HEIGHT,: X-INDENT,: and Y-INDENT: get passed
// in as inches, and gets converted here into PostScript printer points.
define method initialize (_port :: <postscript-port>, #key server-path)
  ignore(server-path);
  next-method();
  port-default-palette(_port) := make-palette(_port);
  let upi = _port.%device-units-per-inch;
  _port.%page-width  := _port.%page-width * upi;
  _port.%page-height := _port.%page-height * upi;
  _port.%x-indent := _port.%x-indent * upi;
  _port.%y-indent := _port.%y-indent * upi
end method initialize;

define method port-type (_port :: <postscript-port>) => (type :: <symbol>)
  #"postscript"
end method port-type;

define method port-name (_port :: <postscript-port>) => (name :: false-or(<string>))
  #f
end method port-name;

define method make-medium
    (_port :: <postscript-port>, sheet :: <sheet>)
 => (medium :: <postscript-medium>)
  make(<postscript-medium>, port: _port, sheet: sheet)
end method make-medium;

define method restart-port (_port :: <postscript-port>) => ()
  // We don't need no stinking events...
end method restart-port;

define method mirror-origin
    (_port :: <postscript-port>, sheet :: <sheet>) => (origin)
  #"south-west"
end method mirror-origin;

define method normal-pen-width (_port :: <postscript-port>, thickness)
  if (thickness = 1)
    0
  else
    0.5 * thickness * _port.%device-units-per-inch / _port.%x-resolution
  end
end method normal-pen-width;


//--- Eventually do better than this
define sealed class <postscript-palette> (<basic-palette>)
end class <postscript-palette>;

define method make-palette
    (_port :: <postscript-port>, #key)
 => (palette :: <postscript-palette>)
  make(<postscript-palette>, port: _port, color?: #t, dynamic?: #f)
end method make-palette;


// Some people need to be able to specialize this
define method postscript-device-prologue
    (_port :: <postscript-port>, printer-stream)
  ignore(printer-stream)
end method postscript-device-prologue;

// Some people need to be able to specialize this, too
define method postscript-device-epilogue
    (_port :: <postscript-port>, printer-stream)
  ignore(printer-stream)
end method postscript-device-epilogue;


/// Font Hacking

// How the font hackery works:

// For each CLIM text style used in the output, a corresponding scaled
// font must exist in the PostScript engine.  (The PostScript books
// recommend that for efficiency you cache the results of operations
// like scalefont).  There is one <POSTSCRIPT-FONT> structure
// created for each CLIM text style used.  These structures are stored
// in the FONT-MAP slot of POSTSCRIPT-MEDIUM streams.
// Inside the PostScript engine there is a corresponding array named
// fontarray, whose i'th element contains the scaled postscript font
// object described by the i'th element of FONT-MAP.

// The function FIND-POSTSCRIPT-FONT is used to find the
// <POSTSCRIPT-FONT> object corresponding to a CLIM text style.
// The first time a CLIM text style is encounterred,
// FIND-POSTSCRIPT-FONT creates a <POSTSCRIPT-FONT> object for it,
// stores it in FONT-MAP and generates postscript code to construct the
// corresponding scaled postscript font and store it in fontarray
// using the postscript estfont procedure defined in the preamble.

// CONVERT-TEXT-STYLE-TO-PS-FONT converts a CLIM text style, eg.
// (:serif :bold :large) to a postscript font description, eg. ("Times"
// :bold 12).   When estfont is used, it interns a font "Times-Bold" of
// size 12 as the appropriate element of fontarray.

// This structure is used to represent a PostScript font masquerading as a
// CLIM-world entity.  They populate the font-map array of the stream.
define sealed class <postscript-font> (<object>)
  // index into stream's array
  sealed slot psfont-index, required-init-keyword: index:;
  // a text style object
  sealed slot psfont-text-style, required-init-keyword: text-style:;
  // ("Times" :normal :italic 6[pts]), e.g.
  sealed slot psfont-font, required-init-keyword: font:;
  sealed slot psfont-points, required-init-keyword: points:;
  sealed slot psfont-height;		// equivalent size in CLIM "pixels"
  sealed slot psfont-ascent;		// top-to-baseline, "pixels"
  sealed slot psfont-descent;		// baseline-to-bottom 
  sealed slot psfont-width-table;	// width array or integer
  sealed slot psfont-established = #f;	// #t ==> written to the printer
end class <postscript-font>;


// Each element is ((family weight slant) name width-or-width-table height ascent descent)
define variable *char-width-tables* :: <stretchy-object-vector> = make(<stretchy-vector>);

// Each element is composed of:
//      - a text family keyword,
//      - the name of a font to use for that family,
//      - a list of point sizes corresponding to the text size keywords
//        in the corresponding positions in *psftd-keywords*.
// We should be able to phjase this out since we have a
// STANDARDIZE-STYLE method for postscript devices.
define variable *postscript-font-translate-data*
    = #[#[#"fix",        "Courier",   #[4, 6, 7,  9, 11, 14, 18]],
	#[#"sans-serif", "Helvetica", #[5, 7, 8, 10, 12, 16, 20]],
	#[#"serif",      "Times",     #[5, 7, 8, 10, 12, 16, 20]],
	#[#"symbol",     "Symbol",    #[5, 7, 8, 10, 12, 16, 20]]];

define variable *psftd-keywords*
    = #[#"tiny", #"very-small", #"small", #"normal", #"large", #"very-large", #"huge"];

define method make-postscript-font (text-style, index)
  let (font, points) = convert-text-style-to-ps-font(text-style);
  let font = make(<postscript-font>,
		  index: index,
		  text-style: text-style,
		  font: font,
		  points: points);
  initialize-postscript-font(font);
  font
end method make-postscript-font;

define method convert-text-style-to-ps-font (style) => (font, points)
  if (style == $undefined-text-style)
    //--- Probably pointless to issue any sort of warning here
    values("Courier", 4)
  else
    let (points, font) = point-size-for-text-style(style);
    values(font, points)
  end
end method convert-text-style-to-ps-font;

// Misnomer -- returns two values
define method point-size-for-text-style (style)
  let (family, weight, slant, size) = text-style-components(style);
  ignore(weight, slant);
  let famdat
    = find-pair(*postscript-font-translate-data*, family)
      | error("There is no PostScript font for family %=", family);
  let points
    = if (instance?(size, <number>))
	size
      else
	let sizes = famdat[2];
	let i = position(*psftd-keywords*, size)
	        | error("There is no PostScript font for family %= with size %=",
			family, size);
	sizes[i]
      end;
  let psname = famdat[1];
  values(points, psname)
end method point-size-for-text-style;

define method initialize-postscript-font (font) => ()
  let (family, weight, slant) = text-style-components(font.psfont-text-style);
  let points = font.psfont-points;
  let key = list(family, weight, slant);
  let metrics = find-pair(*char-width-tables*, key, test: \=);
  unless (metrics)
    error("No font metrics for %=", key)
  end;
  destructuring-let ((name, width-table, height, ascent, descent) = tail(metrics))
    // Convert the width table from relative widths to actual widths
    // for this points size
    if (instance?(width-table, <number>))
      width-table := (points * width-table) / *1-pixel=points*
    else
      width-table := copy-sequence(width-table);
      for (i :: <integer> from 0 below size(width-table))
	when (instance?(width-table[i], <number>))
	  width-table[i] := (points * width-table[i]) / *1-pixel=points*
	end;
      end
    end;
  font.psfont-ascent  := points * ascent;
  font.psfont-descent := points * descent;
  font.psfont-height  := points * height;
  font.psfont-width-table := width-table;
  font.psfont-font := name
  end
end method initialize-postscript-font;

define method find-postscript-font
    (_port :: <postscript-port>, medium :: <medium>, text-style :: <text-style>)
  let cache = port-font-mapping-cache(_port);
  let font
    = if (text-style == head(cache))
        tail(cache)
      else
        find-postscript-font-1(_port, text-style)
      end;
  when (font
        & medium
        & begin
            let sheet = medium-sheet(medium);
            #t //---*** ~output-recording-sheet?(sheet) | sheet-drawing?(sheet)
          end
        & ~font.psfont-established)
    format(medium.%printer-stream, "%d %d /%s estfont\n",
           font.psfont-index, font.psfont-points, font.psfont-font);
    font.psfont-established := #t
  end;
  head(cache) := #f;		// ensure nobody sees a valid cache...
  tail(cache) := font;
  head(cache) := text-style;
  font
end method find-postscript-font;

//---*** Kludge to get around Webster typist bug.
define method find-postscript-font-1
    (_port :: <postscript-port>, text-style :: <text-style>)
  let font-map = _port.%font-map;
  let nfonts = size(font-map);
  block (return)
    for (i :: <integer> = 0 then i + 1, until: i >= nfonts)
      let font = font-map[i];
      when (font & text-style == font.psfont-text-style)
        return(font)
      end;
    finally
      let font = make-postscript-font(text-style, i);
      add!(font-map, font);
      return(font)
    end
  end
end method find-postscript-font-1;

define method standardize-text-style
    (_port :: <postscript-port>, style :: <text-style>, #key character-set)
 => (style :: <text-style>)
  ignore(character-set);
  let size = text-style-size(style);
  if (instance?(size, <number>))
    style
  else
    let family = text-style-family(style);
    let weight = text-style-weight(style);
    let slant = text-style-slant(style);
    let sizes = find-pair(*postscript-font-translate-data*, family)[2];
    let position = position(*psftd-keywords*, size);
    let new-size = position & sizes[position];
    case
      new-size =>
        make(<text-style>,
             family: family, weight: weight, slant: slant, size: new-size);
      family == #"stand-in-for-undefined-style" =>
        make(<text-style>, 
             family: family, weight: weight, slant: slant, size: 10);
      otherwise =>
        cerror
          ("Use the undefined text style stand-in instead",
           "This display device does not know how to map the logical text style size %= in %=",
           size, style);
        $undefined-text-style
    end
  end
end method standardize-text-style;


/// Postscript medium classes

define sealed class <postscript-medium> (<basic-medium>)
  sealed slot %printer-stream, init-keyword: stream:;
  sealed slot %orientation, init-keyword: orientation:;
  sealed slot %destination, init-keyword: destination:;
  sealed slot %current-color = #f;
  sealed slot %features-sent :: <stretchy-object-vector> = make(<stretchy-vector>);
  sealed slot %curfont = #f;
  sealed slot %ch1buf = make(<string>, size: 1);
end class <postscript-medium>;

define method implementation-pixels-per-point (medium :: <postscript-medium>)
  as(<single-float>, *1-pixel=points*)
end method implementation-pixels-per-point;

define method force-display (medium :: <postscript-medium>) => ()
  force-output(medium.%printer-stream)
end method force-display;

define method synchronize-display (medium :: <postscript-medium>) => ()
  synchronize-output(medium.%printer-stream)
end method synchronize-display;


/// Support routines

define macro making-ps-array
  { making-ps-array (?stream:expression) ?:body end }
    => { begin
	   write(?stream, " [ ");
	   ?body;
	   write(?stream, " ] ")
	 end }
end macro making-ps-array;

define macro making-ps-hex-string
  { making-ps-hex-string (?stream:expression) ?:body end }
    => { begin
	   write(?stream, "<");
	   ?body;
	   write(?stream, ">")
	 end }
end macro making-ps-hex-string;

define macro with-postscript-gsave
  { with-postscript-gsave (?medium:name) ?:body end }
    => { begin
           let gsave-body = method () ?body end;
           do-with-postscript-gsave(?medium, gsave-body)
         end }
end macro;

define method do-with-postscript-gsave
    (medium :: <postscript-medium>, continuation :: <function>) => (#rest values)
  let printer-stream = medium.%printer-stream;
  block ()
    format(printer-stream, " gsave\n");
    continuation()
  cleanup
    format(printer-stream, " grestore\n")
  end
end method do-with-postscript-gsave;

define method maybe-send-feature
    (medium :: <postscript-medium>, feature-name, code)
  unless (member?(feature-name, medium.%features-sent))
    write(medium.%printer-stream, code);
    add!(medium.%features-sent, feature-name)
  end
end method maybe-send-feature;

define method ps-pos-op (medium :: <postscript-medium>, op, x, y, #rest args)
  dynamic-extent(args);
  let printer-stream = medium.%printer-stream;
  let orientation = medium.%orientation;
  let _port = port(medium);
  pixels-to-points(x, y);
  write(printer-stream, " ");
  ps-optimal-flonize(_port.%x-indent + x, printer-stream);
  write(printer-stream, " ");
  ps-optimal-flonize
    ((if (orientation == #"landscape") _port.%page-width else _port.%page-height end)
       - y + _port.%y-indent,
     printer-stream);
  for (arg in args)
    write(printer-stream, " ");
    if (instance?(arg, <number>))
      ps-optimal-flonize(arg, printer-stream)
    else
      format(printer-stream, "%=", arg)
    end;
  end;
  write(printer-stream, " ");
  write(printer-stream, op);
  if (string-equal?(op, "m"))
    write(printer-stream, " ")
  else
    write(printer-stream, "\n")
  end
end method ps-pos-op;

define method ps-rel-pos-op
    (medium :: <postscript-medium>, op, x, y, #rest args)
  dynamic-extent(args);
  pixels-to-points(x, y);
  let printer-stream = medium.%printer-stream;
  write(printer-stream, " ");
  ps-optimal-flonize(x, printer-stream);
  write(printer-stream, " ");
  ps-optimal-flonize(-y, printer-stream);
  for (arg in args)
    write(printer-stream, " ");
    if (instance?(arg, <number>))
      ps-optimal-flonize(arg, printer-stream)
    else
      format(printer-stream, "%=", arg)
    end;
  end;
  write(printer-stream, " ");
  write(printer-stream, op);
  write(printer-stream, "\n")
end method ps-rel-pos-op;

define method ps-prim-op
    (medium :: <postscript-medium>, op, x, y, #rest args)
  dynamic-extent(args);
  let printer-stream = medium.%printer-stream;
  write(printer-stream, " ");
  ps-optimal-flonize(x, printer-stream);
  write(printer-stream, " ");
  ps-optimal-flonize(y, printer-stream);
  for (arg in args)
    write(printer-stream, " ");
    if (instance?(arg, <number>))
      ps-optimal-flonize(arg, printer-stream)
    else
      format(printer-stream, "%=", arg)
    end;
  end;
  write(printer-stream, " ");
  write(printer-stream, op);
  write(printer-stream, "\n")
end method ps-rel-pos-op;

define variable *optimal-flonize-count* = 8;

define thread variable *optimal-flonize-buffer* :: false-or(<string>) = #f;

// The software that drives the LGP2 (SYS:HARDCOPY;POSTSCRIPT.LISP)
// uses LGP:FAST-PRINT-NUM except for writing transformation matrices,
// for which it uses
//   (prin1 (if (fixp elem) elem (as <single-float> elem)) output-stream)
// and also some cases of FORMAT %d.
define method ps-optimal-flonize (n, stream)
  // Lifted from definition of LGP:FAST-PRINT-NUM in SYS:HARDCOPY;POSTSCRIPT.LISP
  if (~zero?(n) & (-1 < n & n < 1))
    format(stream, "%=", as(<single-float>, n))
  else
    let (integer, frac)
      = select (n by instance?)
          <integer> =>
            values(abs(n), 0);
          <float> =>
            truncate/(abs(n) * 100, 100);
          <rational> =>
            truncate/(abs(n) * 100, 100)
        end;
    if (integer >= 10000)
      if (integral?(n))
        format(stream, "%d", n)
      else
        format(stream, "%=", n)
      end
    else
      let from = *optimal-flonize-count*;
      let neg? = #f;
      when (negative?(n))
        neg? := #t
      end;
      let string = *optimal-flonize-buffer*;
      local method add-char (char)
	      string[dec!(from)] := char
	    end method;
      if (frac ~= 0)
	let (frac1, frac2) = truncate/(frac, 10);
	when (frac2 ~= 0)
	  add-char(as(<character>, as(<integer>, '0') + frac2))
	end;
	add-char(as(<character>, as(<integer>, '0') + frac1));
        add-char('.')
      end;
      begin
        let digit = 0;
        block (return)
          while (#t)
	    let (_integer, _digit) = truncate/(integer, 10);
	    integer := _integer;
	    digit := _digit;
            add-char(as(<character>, as(<integer>, '0') + digit));
            when (zero?(integer))
              return()
            end
          end
        end
      end;
      when (neg?)
        add-char('-')
      end;
      write(stream, string, start: from);
      n
    end
  end
end method ps-optimal-flonize;


// "Not suitable for ritual use."
define variable *ps-ellipse-code*
  = "/emtrx matrix def\n"
    "/elpd 8 dict def\n"
    "/ellipse  {{arc} ellipsei} def\n"
    "/ellipsen {{arcn} ellipsei} def\n"
    "/ellipsei\n"
      "{elpd begin /arcp exch def /ea exch def /sa exch def\n"
      "/yra exch def /xra exch def\n"
      "/y exch def /x exch def\n"
      "emtrx currentmatrix\n"
      "x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def\n";

// For drawing filled patterns
define variable *pattern-code*
  = "/imgdict 12 dict def\n"
    "%%'draw-image'\n"
    "%%One source pixel to one user space unit.\n"
    "%%Args are: width width-rounded-up height\n"
    "/img { imgdict begin\n"
      "[/height /bitwidth /width ] {exch def} forall\n"
      "/nbits bitwidth height mul def\n"
      "/str 100 string def\n"
      "nbits 0 ne {\n"
        "gsave width height scale\n"
	"bitwidth height true [bitwidth 0 0 height neg 0 height] \n"
	"{   nbits 800 ge {/nbits nbits 800 sub def str} \n"
	"{nbits 8 idiv string /nbits 0 def}\n"
	"ifelse \n"
	"currentfile exch readhexstring pop}\n"
	"imagemask grestore\n"
       "} if end\n"
      "} def\n"
    "/fmod { 2 copy div floor mul sub } bind def\n"
    "%%'draw-patterned-rectangle'\n"
    "%%One source pixel to scale device units (ignoring user scale).\n"
    "%%Args are: width height pattern scale\n"
    "/pat { imgdict begin gsave\n"
      "[/scal /patseq ] {exch def} forall\n"
      "/patheight patseq length def\n"
      "/patwidth patseq 0 get length 8 mul def\n"
      "%%Back up to an even phase boundary\n"
      "/pswidth patwidth scal mul def\n"
      "/psheight patheight scal mul def\n"
      "pswidth psheight idtransform\n"
      "0 0 transform psheight fmod neg exch pswidth fmod neg exch idtransform\n"
      "3 -1 roll exch dup 0 gt {add} {exch pop} ifelse\n"
      "3 1 roll dup 0 gt {add} {exch pop} ifelse exch 2 copy translate\n"
      "3 -1 roll exch abs add 3 1 roll abs add exch dtransform\n"
      "psheight div abs ceiling cvi patheight mul /height exch def\n"
      "pswidth div abs ceiling cvi patwidth mul /width exch def\n"
      "width 0 ne { height 0 ne {\n"
      "/scanline -1 def /linebits 0 def\n"
      "width height idtransform abs scale scal dup scale\n"
      "width height true [width 0 0 height neg 0 height] \n"
      "{ linebits 0 le { /linebits width def\n"
        "/scanline scanline 1 add patheight mod def\n"
        "/linepat patseq scanline get def\n"
        "} if\n"
      "/linebits linebits patwidth sub def linepat }\n"
      "imagemask } if } if grestore end\n"
      "} def\n"
    "%%Draws a pattern in all of visible area.\n"
    "%%Args are: pattern scale opaque-p\n"
    "/patfill1 { initmatrix clippath\n"
    "%%condition-case for nocurrentpoint, returning empty rectangle\n"
      "errordict begin\n"
      "/nocurrentpoint dup dup load exch { pop 0 0 0 0 } def \n"
      "pathbbox\n"
      "6 -2 roll def end\n"
      "4 2 roll 2 copy translate 4 -2 roll\n"
      "3 -1 roll sub 3 1 roll exch sub exch\n"
      "3 -1 roll { 2 copy gsave 1 setgray newpath\n"
        "0 0 moveto 0 exch lineto 0 rlineto currentpoint pop 0 lineto\n"
        "closepath fill grestore } if\n"
      "4 -2 roll pat } def\n"
    "%%Like 'fill', etc. but with pattern, scale and opaque-p options.\n"
    "/patfill { gsave clip patfill1 grestore newpath } def\n"
    "/pateofill { gsave eoclip patfill1 grestore newpath } def\n"
    "/patstroke { gsave strokepath clip patfill1 grestore newpath } def\n";

define variable *postscript-prologue*
  = "statusdict /waittimeout 30 put\n"
    "/fontarray 30 array def\n"
    "/f {fontarray exch get setfont} def\n"
    "/estfont {findfont exch scalefont fontarray 3 1 roll put} def\n"
    "/m {moveto} def\n";

define variable *postscript-new-matrix*
  = "/new-matrix {0 format-y-translation translate\n"
      "format-rotation rotate\n"
      "format-scale format-scale scale} def\n"
    "/new-page {showpage new-matrix} def\n";


define method postscript-prologue
    (medium :: <postscript-medium>,
     #key scale-factor, orientation = #"portrait",
          clip-carefully? = #t, header-comments = #[])
  let printer-stream = medium.%printer-stream;
  let destination = medium.%destination;
  let _port = port(medium);
  case
    member?(destination, #[#"document", #"document-inclusion"]) =>
      format(printer-stream, "%%!PS-Adobe-2.0 EPSF-2.0\n");
      let (left, top, right, bottom)
        = postscript-bounding-box-edges(medium-sheet(medium));
      format
        (printer-stream, "%%%%BoundingBox: %d %d %d %d\n",
         as(<single-float>, left), as(<single-float>, top),
         as(<single-float>, right), as(<single-float>, bottom));
    otherwise =>
      format(printer-stream, "%%!PS-Adobe-2.0\n")
  end;
  format(printer-stream, "%%Creator: CLIM 2.0\n");
  let title = get-property(header-comments, title:);
  when (title)
    format(printer-stream, "%%Title: %s\n", title)
  end;
  let whom = get-property(header-comments, for:);
  when (whom)
    format(printer-stream, "%%For: %s\n", whom)
  end;
  let date = current-date();
  let (sec, minute, hour, date, month, year)
    = values(date-seconds(date),
	     date-minutes(date),
	     date-hours(date),
	     date-day(date),
	     date-month(date),
	     date-year(date));
  format(printer-stream, "%%%%CreationDate: %d-%s-%d ~2,'0D:~2,'0D:~2,'0D\n",
	 date, #["Jan", "Feb", "Mar", "Apr", "May", "Jun",
		 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"][month - 1],
	 year, hour, minute, sec);
  format(printer-stream, "%%%%DocumentFonts: (atend)\n");
  format(printer-stream, "%%%%EndComments\n");
  write(printer-stream, *postscript-prologue*);
  select (orientation)
    #"portrait" =>
      format(printer-stream,
	     "/format-rotation 0 def \n/format-y-translation 0 def\n");
    #"landscape" =>
      format(printer-stream,
	     "/format-rotation -90 def \n/format-y-translation %d def\n",
	     as(<single-float>, _port.%page-height))
  end;
  format(printer-stream, "/format-scale %d def\n",
	 as(<single-float>, scale-factor | 1));
  format(printer-stream, *postscript-new-matrix*);
  when (clip-carefully?)
    // Be sure the printer gets clipped to an honest page!
    format(printer-stream, " \nnewpath\n");
    ps-prim-op(medium, "moveto", _port.%x-indent, _port.%y-indent);
    ps-prim-op(medium, "rlineto", 0, _port.%page-height);
    ps-prim-op(medium, "rlineto", _port.%page-width, 0);
    ps-prim-op(medium, "neg rlineto", 0, _port.%page-height);
    format(printer-stream, " closepath clip\n")
  end;
  postscript-device-prologue(_port, printer-stream);
  format(printer-stream, "\nnew-matrix\n");
  format(printer-stream, "%%%%EndProlog\n\n");
end method postscript-prologue;

define method postscript-epilogue (medium :: <postscript-medium>)
  let printer-stream = medium.%printer-stream;
  let destination = medium.%destination;
  let _port = port(medium);
  let font-map = _port.%font-map;
  unless (member?(destination, #[#"document", #"document-inclusion"]))
    // Don't do a showpage if this output is going to be included in
    // some other document
    format(printer-stream, "showpage\n")
  end;
  postscript-device-epilogue(_port, printer-stream);
  format(printer-stream, "\n%%%%Trailer\n");
  let font-names-used :: <stretchy-object-vector> = make(<stretchy-vector>);
  for (index :: <integer> from 0 below size(font-map))
    let font = font-map[index];
    when (font)
      add-new!(font-names-used, font.psfont-font, test: string-equal?)
    end;
  end;
  //---*** This format string is all messed up
  format(printer-stream, "%%%%DocumentFonts:~{~^ %s~}\n", font-names-used)
end method postscript-epilogue;


define method send-pattern (medium, printer-stream, pattern)
  maybe-send-feature(medium, #"pattern-program", *pattern-code*);
  making-ps-array(printer-stream)
    let height = dimension(pattern, 0);
    let width = dimension(pattern, 1);
    for (j :: <integer> from 0 below height)
      making-ps-hex-string(printer-stream)
        send-raster(printer-stream, pattern, 0, j, width, j + 1, newline?: #f)
      end
    end
  end;
  write(printer-stream, "\n");
  write(printer-stream, " 4 true ")
end method send-pattern;

define method send-raster
    (printer-stream, raster, left, top, right, bottom, #key newline? = #t)
  /*
  //---*** Fix this
  assert(bottom = top + 1);
  unless (zero?(remainder(right, 8)))
    error("Sorry, can't hack right /= 0 (mod 8); you have %d", right)
  end;
  with-stack-object (arr :: <simple-object-vector>, size: array-total-size(raster))
    with-temporary-string (buf = 100)
      let bytes-per-row = truncate/(dimension(raster, 1), 8);
      let bytes-per-raster = ceiling/(right - left, 8);
      let toprow = top * bytes-per-row;
      let botrow = bottom * bytes-per-row;
      let bigend-digit-char = "084c2a6e195d3b7f";
      let j = 0;
      local method force-buf ()
	      buf.size := j;
	      with-temporary-substring (subbuf = buf, 0, j)
		write(printer-stream, subbuf);
	        when (terpri)
		  write(printer-stream, "\n")
	        end
	      end
            end method;
      block (return)
	for (index :: <integer> = botrow - bytes-per-row then index - bytes-per-row,
	     until: index < toprow)
	  let i = index;
	  for (_i :: <integer> from 0 below bytes-per-raster)
	    let byte = arr[i];
	    buf[j] := bigend-digit-char[ldb(byte(4, 0), byte)];
	    buf[j + 1] := bigend-digit-char[ldb(byte(4, 4), byte)];
	    inc!(i);
	    inc!(j, 2);
	    when (j > 80)
	      force-buf()
	    end;
	  end;
	end
      end;
      when (j > 0)
	force-buf()
      end
    end
  end
  */
end method send-raster;


define method ps-fill (medium, printer-stream, brush)
  case
    brush?(brush) & brush-tile(brush) =>
      error("The PostScript port doesn't support patterns other than stipples");
    brush?(brush) & brush-stipple(brush) =>
      let (array, width, height) = decode-pattern(brush-stipple(brush));
      ignore(width, height);
      send-pattern(medium, printer-stream, array);
      format(printer-stream, " patfill\n");
    otherwise =>
      format(printer-stream, " fill\n")
  end
end method ps-fill;

define method ps-stroke (medium, printer-stream, brush)
  case
    brush?(brush) & brush-tile(brush) =>
      error("The PostScript port doesn't support patterns other than stipples");
    brush?(brush) & brush-stipple(brush) =>
      let (array, width, height) = decode-pattern(brush);
      ignore(width, height);
      send-pattern(medium, printer-stream, array);
      format(printer-stream, " patstroke\n");
    otherwise =>
      format(printer-stream, " stroke\n")
  end
end method ps-stroke;


/// Specific kinds of devices

define sealed class <apple-laser-writer> (<postscript-port>)
  inherited slot %x-resolution = 300;
  inherited slot %y-resolution = 300;
  inherited slot %page-width = 7.5;
  inherited slot %page-height = 10.5;
  inherited slot %x-indent = 0.5;
  inherited slot %y-indent = 0.15;
end class <apple-laser-writer>;

define sideways method class-for-make-port
    (type == #"apple-laser-writer", #rest initargs, #key)
 => (class :: <class>, initargs :: false-or(<sequence>))
  ignore(initargs);
  values(<apple-laser-writer>, #f)
end method class-for-make-port;

define method initialize (_port :: <apple-laser-writer>, #key server-path)
  ignore(server-path);
  next-method();
  //--- Set the "undefined" text style mapping to "Courier"
end method initialize;


define sealed class <apple-laser-writer-legal> (<apple-laser-writer>)
  inherited slot %page-height = 13.5;
end class <apple-laser-writer-legal>;

define sideways method class-for-make-port
    (type == #"apple-laser-writer-legal", #rest initargs, #key)
 => (class :: <class>, initargs :: false-or(<sequence>))
  ignore(initargs);
  values(<apple-laser-writer-legal>, #f)
end method class-for-make-port;

define method postscript-device-prologue
    (_port :: <apple-laser-writer-legal>, printer-stream)
  //---*** This format string is all messed up
  format(printer-stream,
	 "userdict /%s known {%s} ifn\n
statusdict /%stray known {statusdict begin %stray end} ifn",
	 #"legal", #"legal", #"legal", #"legal")
end method postscript-device-prologue;


/// PostScript sheets

define sealed class <postscript-sheet>
    (<permanent-medium-mixin>, <top-level-sheet>)
  sealed slot %multi-page? = #f, init-keyword: multi-page?:;
  sealed slot %scale-to-fit? = #f, init-keyword: scale-to-fit?:;
  sealed slot %viewport-region = #f;
  sealed slot sheet-device-transform :: <transform> = $identity-transform;
end class <postscript-sheet>;

/*
//--- Nope, not needed
define method close (stream :: <postscript-sheet>, #key abort?)
  unless (abort?)
    postscript-epilogue(sheet-medium(stream))
  end
end method close;
*/

define method postscript-bounding-box-edges (sheet :: <postscript-sheet>)
  let (left, top, right, bottom) = box-edges(sheet);
  pixels-to-points(left, top, right, bottom);
  fix-box(left, top, right, bottom)
end method postscript-bounding-box-edges;

define method sheet-viewport-region
    (sheet :: <postscript-sheet>) => (box :: <bounding-box>)
  sheet.%viewport-region
  | begin
      let _port = port(sheet);
      let orientation = sheet-medium(sheet).%orientation;
      let (width, height)
        = values
            (as(<single-float>,
                if (orientation == #"landscape") _port.%page-height else _port.%page-width end
		  / *1-pixel=points*),
             as(<single-float>,
                if (orientation == #"landscape") _port.%page-width else _port.%page-height end
		  / *1-pixel=points*));
      //--- Can this give a better answer when MULTI-PAGE?: #t
      sheet.%viewport-region := make-bounding-box(0, 0, width, height)
    end
end method sheet-viewport-region;

define macro with-output-to-postscript-sheet
  { with-output-to-postscript-sheet
        (?sheet:name = ?file-stream:expression, #rest ?options:expression)
      ?:body
    end }
    => { begin
           let postscript-body = method (?sheet) ?body end;
           do-with-output-to-postscript-sheet(?file-stream, postscript-body, ?options)
         end }
end macro;

// This could really be WITH-OPEN-STREAM, but that isn't going to call CLIM:CLOSE.
// Fixed in the CLOS stream system.
define method do-with-output-to-postscript-sheet
    (file-stream, continuation :: <function>,
     #key device-type = #"apple-laser-writer", sheet-type = <postscript-sheet>,
          multi-page?, clip-carefully? = #t,
          header-comments = #[], destination = #"printer", orientation = #"portrait")
 => (#rest values)
  check-type(orientation,
	     one-of(#"landscape", #"portrait"));
  check-type(destination,
	     one-of(#"printer", #"document", #"document-inclusion"));
  let server-path
    = if (instance?(device-type, <list>))
	device-type
      else
	list(device-type)
      end;
  let _port = find-port(server-path: server-path);
  let sheet
    = make(sheet-type,
           port: _port,
           multi-page?: multi-page?);
  //--- Yet another sign that the PS port is implemented kludgily...
  sheet.%port := _port;
  note-sheet-attached(sheet);
  let medium = sheet-medium(sheet);
  dynamic-bind (*optimal-flonize-buffer*
		  = make(<string>, size: *optimal-flonize-count*))
    medium.%printer-stream := file-stream;
    medium.%orientation := orientation;
    medium.%destination := destination;
    block ()
      postscript-prologue(medium,
			  scale-factor: 1, 
			  orientation: orientation,
			  clip-carefully?: clip-carefully?,
			  header-comments: header-comments);
      continuation(sheet)
    cleanup
      postscript-epilogue(medium);
      reset-postscript-port(_port)
    end
  end
end method do-with-output-to-postscript-sheet;

define method reset-postscript-port (_port :: <postscript-port>)
  // Since we can reuse the port later, we have to clobber the font
  // so that the port doesn't think we've done an estfont next time
  let font-map = _port.%font-map;
  let nfonts :: <integer> = size(font-map);
  for (i :: <integer> = 0 then i + 1, until: i >= nfonts)
    let font = font-map[i];
    when (font)
      font.psfont-established := #f
    end;
  end;
  let cache = port-font-mapping-cache(_port);
  head(cache) := #f;
  tail(cache) := #f
end method reset-postscript-port;


/*

/// PostScript streams

define sealed class <postscript-stream>
  (<graphics-output-recording>,
   <output-recording-mixin>,
   <postscript-sheet>)
end class <postscript-stream>;

define method postscript-bounding-box-edges (stream :: <postscript-stream>)
  let (left, top, right, bottom) = box-edges(stream-output-history(stream));
  pixels-to-points(left, top, right, bottom);
  fix-box(left, top, right, bottom)
end method postscript-bounding-box-edges;

define method stream-ensure-cursor-visible
    (stream :: <postscript-stream>, #key x, y)
  ignore(x, y);
  #f
end method stream-ensure-cursor-visible;

define method stream-move-for-line-height-change
    (stream :: <postscript-stream>, movement, old-height, cursor-x, cursor-y)
  ignore(movement, old-height, cursor-x, cursor-y)
end method stream-move-for-line-height-change;

// Replay some PostScript output, breaking it into multiple pages
define method stream-replay (stream :: <postscript-stream>, region)
  let _port = port(stream);
  let medium = sheet-medium(stream);
  let printer-stream = medium.%printer-stream;
  let multi-page? = stream.%multi-page?;
  let orientation = medium.%orientation;
  let output-record = stream-output-history(stream);
  when (stream-drawing?(stream))
    when (output-record)
      dynamic-bind (stream-recording?(stream) = #f)
        if (~everywhere?(region) | ~multi-page?)
          replay(output-record, stream, region | $everywhere)
        else
          let (left, top, right, bottom) = box-edges(output-record);
	  let page-width
	    = floor/(_port.%page-width, *1-pixel=points*);
	  let page-height
	    = floor/(_port.%page-height, *1-pixel=points*);
	  let first-page = #t;
	  let viewport-x = 0;
	  let viewport-y = 0;
	  when (orientation == #"landscape")
	    let _value = page-width;
	    page-width := page-height;
	    page-height := _value;
	    #f
	  end;
	  // Draw each chunk of output on its own page
	  block (return)
	    for (y = top then y + page-height, until: y > bottom)
	      for (x = left then x + page-width, until: x > right)
		if (first-page)
		  first-page := #f
		else
		  format(printer-stream, "gsave new-page grestoren")
		end;
		let region
		  = make-bounding-box(x, y, x + page-width, y + page-height);
		sheet-device-transform(stream)
		  := make-translation-transform(-viewport-x, -viewport-y);
		replay(output-record, stream, region);
		inc!(viewport-x, page-width);
	      end;
	      viewport-x := 0;
	      inc!(viewport-y, page-height);
	    end
	  end
	end
      end
    end
  end
end method stream-replay;

//---*** macro with-output-to-postscript-stream
//---*** method do-with-output-to-postscript-stream

*/