 ;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Make-PS-File
;;;
;;; The function Make-PS-File generates postscript files from Garnet windows.
;;; The resulting files may be sent directly to a postscript printer or
;;; included in larger Scribe and LaTex documents.
;;;
;;; Designed and implemented by Andrew Mickish
;;;
;;; Change Log:
;;; 08/29/92 Andrew Mickish -  Added EPSF 2.0 comment for Pagemaker
;;; 08/26/92 Andrew Mickish -  Ignore objects drawn with :no-op
;;; 07/17/92 Andrew Mickish -  Modified DrawArc and opal:arc :ps-object method
;;;            to draw arcs entirely inside the bounding box (consistent with
;;;            recent change made to :draw method of opal:arc).
;;; 07/03/92 Andrew Mickish -  Added ability to specify a list of windows;
;;;            used ~A when calling Format-Int-or-FP.
;;; 06/23/92 Andrew Mickish -  Renamed variable "lt" to "thickness"
;;; 06/10/92 Ed Pervin - Print pixmaps (only purely black pixels).
;;; 06/04/92 Andrew Mickish -  Now white objects are printed with a white
;;;            halftone instead of a white color
;;; 06/02/92 Andrew Mickish -  Added :ps-object and :ps-register-fn methods
;;;            to print cursors of cursor-text and cursor-multi-text
;;; 05/01/92 Andrew Mickish -  Restored pushnew call in bitmap :ps-register-fn,
;;; 04/28/92 Ed Pervin      -  Implemented :justification of multi-text.
;;; 04/15/92 Andrew Mickish -  Moved multifont-text stuff to ps-multifont.lisp
;;; 04/13/92 Rich McDaniel  -  New Multifont-text
;;; 04/03/92 Andrew Mickish -  Changed DOLIST to DO in trailer-comments
;;; 03/31/92 Andrew Mickish -  Added comment at top of PS file announcing
;;;            whether the file uses real color or not.
;;; 03/25/92 Andrew Mickish -  Added background window color
;;; 01/03/92 Andrew Mickish -  Roundtangle method will not draw singularities
;;; 10/16/91 Andrew Mickish -  Added Format-Int-or-FP so that integers are
;;;            printed as integers and floats are printed as floats.
;;; 10/15/91 Andrew Mickish -  Added :ps-register-fn for opal:oval.  Now PS
;;;            pays attention to the :border-width of windows.
;;; 10/11/91 Andrew Mickish -  Backslashes in strings are now duplicated
;;;            before writing the string to the file.  Text can now have a
;;;            filled background.
;;; 10/11/91 Andrew Mickish - Split Make-PS-File so that all writing to the
;;;            file is done at the end of the function, using Write-PS-To-File.
;;;            BoundingBox information now appears both at the top and at
;;;            the end of the PS file.
;;; 08/29/91 Andrew Mickish - Fixed bitmap method and PS function to allow
;;;            transparent bitmaps.  Added check of :visible slot before
;;;            drawing subwindows.
;;; 08/05/91 Andrew Mickish - Put gsave and grestore around ps-window call
;;;            on subwindows.
;;; 08/04/91 Andrew Mickish - Added more 'pop' calls in StrokeShape to clean
;;;            unused parameters off the stack.
;;; 08/02/91 Andrew Mickish - Added subwindows to the first pass search for
;;;            registering needed postscript functions.  Added :ps-object
;;;            method for opal:multi-text.  Make-PS-File now returns T.
;;; 07/26/91 Andrew Mickish - Created
;;;

(in-package "OPAL" :use '("LISP" "KR"))

(export '(Make-PS-File))


;;;  POSTSCRIPT NOTES
;;;    When passing parameters, a value of -1 corresponds to NIL in Lisp.
;;;

; Clip future drawing to this rectangular area
;
(defparameter *clip-fn*
  "
/ClipDict 2 dict def
/ClipToRectangle
   {    % stack: left, top, width, height
        ClipDict begin
	/height exch def  /width exch def
        newpath
	  moveto		% Go to the left,top corner
	  width 0 rlineto	% top side
	  0 height neg rlineto	% right side
	  width neg 0 rlineto	% bottom side
	  closepath		% left side
	gsave 1 setgray fill grestore
	clip newpath
        end
   } def")

(defparameter *fillshape-fn*
  "
/FillShape
   {	% stack: fill-halftone, red, green, blue, color-p
        %   Color-p should be true or false - false means ignore the three vals
        %   Use -1 for fill-halftone to mean NIL, 0 = black, 1 = white
        %   Use -2 for fill-halftone to indicate there is an arbitrary filling
        % style on the stack
        gsave
        { setrgbcolor fill pop }
	{ pop pop pop 
	  dup 0 ge
	    % if fill-halftone >= 0, then fill the shape with a halftone
	    { setgray fill}
            % else, if there is an arbitrary filling style, then fill
            { -2 eq
              {SetPattern fill} if
            } ifelse } ifelse
        grestore
   } def")


(defparameter *strokeshape-fn*
  "
/StrokeShape
   {	% stack: line-halftone, red, green, blue, color-p,
        %        line-cap, line-join, dash-pattern, line-thickness
	% If no line is desired, pass -1 for line-thickness
        % Halftones: 0 = black, 1 = white
	dup 0 ge
	  % if line-thickness >= 0, then draw the outline
	  {gsave
	   setlinewidth 0 setdash setlinejoin setlinecap
             { setrgbcolor pop }
             { pop pop pop setgray } ifelse
	   stroke
	   grestore}
	  {pop pop pop pop pop pop pop pop pop newpath} ifelse
   } def")

(defparameter *line-fn*
  "
/DrawLine
   {    % stack: line-halftone, red, green, blue, color-p,
        %        line-cap, line-join, dash-pattern, line-thickness
        %        x2, y2, x1, y1
        newpath
          moveto
          lineto
          StrokeShape
   } def")

(defparameter *roundtangle-fn*
  "
/RoundtanglePath
   {    % stack: left, top, width, height, radius
        /r exch def  /h exch def  /w exch def  /t exch def  /l exch def
        /right l w add def  /bottom t h sub def
          l r add t moveto                         % origin
          right t right t r sub r arcto            % top side
          right bottom right r sub bottom r arcto  % right side
          l bottom l bottom r add r arcto          % bottom side
          l t l r add t r arcto                    % left side
          16 {pop} repeat  % each arcto accumulates 4 stack parameters
   } def

/RoundtangleDict 27 dict def
/DrawRoundtangle
   {    % stack: left, top, width, height, radius, line-halftone,
        %        line-red, line-green, line-blue, line-color-p,
        %        line-cap, line-join, dash-pattern, line-thickness,
        %        fill-halftone, fill-red, fill-green, fill-blue, fill-color-p
        
        RoundtangleDict begin
        /fill-color-p exch def  /fill-blue exch def  /fill-green exch def
        /fill-red exch def  /fill-halftone exch def  /thickness exch def
        /dash-pattern exch def  /line-join exch def  /line-cap exch def
        /line-color-p exch def  /line-blue exch def  /line-green exch def
        /line-red exch def  /line-halftone exch def  /radius exch def
        /height exch def  /width exch def  /top exch def  /left exch def
        /thickness-by-2 thickness 2 div def
        % Draw filling
        newpath
          left thickness-by-2 add  top thickness-by-2 sub
          width thickness sub  height thickness sub
          radius thickness sub RoundtanglePath
          fill-halftone fill-red fill-green fill-blue fill-color-p FillShape
        % Draw border
        newpath
          left top width height radius thickness-by-2 sub RoundtanglePath
          line-halftone line-red line-green line-blue line-color-p
          line-cap line-join dash-pattern thickness StrokeShape
        end
   } def")

(defparameter *rectangle-fn*
  "
/RectanglePath
   {    % stack: left, top, width, height
        /h exch def  /w exch def
	moveto		        % Go to the left,top corner
	w 0 rlineto	        % top side
	0 h neg rlineto		% right side
	w neg 0 rlineto		% bottom side
	closepath		% left side
   } def

/RectangleDict 21 dict def
/DrawRectangle
   {	% stack: left, top, width, height, line-halftone, line-red, line-green,
        %        line-blue, line-color-p,
        %        line-cap, line-join, dash-pattern, line-thickness,
        %        fill-halftone, fill-red, fill-green, fill-blue, fill-color-p
        RectangleDict begin
        /fill-color-p exch def  /fill-blue exch def  /fill-green exch def
        /fill-red exch def /fill-halftone exch def  /thickness exch def
        /dash-pattern exch def  /line-join exch def  /line-cap exch def
        /line-color-p exch def  /line-blue exch def  /line-green exch def
        /line-red exch def  /line-halftone exch def  /height exch def
        /width exch def  /top exch def  /left exch def
        /thickness-by-2 thickness 2 div def
        % Draw filling
        newpath
          left thickness-by-2 add  top thickness-by-2 sub
          width thickness sub  height thickness sub
          RectanglePath
	  fill-halftone fill-red fill-green fill-blue fill-color-p FillShape
        % Draw border
        newpath
          left top width height RectanglePath
          line-halftone line-red line-green line-blue line-color-p
          line-cap line-join dash-pattern thickness StrokeShape
        end
   } def")


;   This function for drawing ellipses (circles, arcs, and ovals) is based
; on the example "Elliptical Arcs" in the blue postscript Tutorial and
; Cookbook.
;
(defparameter *ellipse-fn*
  "
/EllipseDict 23 dict def
EllipseDict /mtrx matrix put
/DrawEllipse
   {    EllipseDict begin
        /fill-color-p exch def  /fill-blue exch def  /fill-green exch def
        /fill-red exch def  /fill-halftone exch def  /thickness exch def
        /dash-pattern exch def  /line-join exch def  /line-cap exch def
        /line-color-p exch def  /line-blue exch def  /line-green exch def
        /line-red exch def  /line-halftone exch def  /endangle exch def
        /startangle exch def  /yrad exch def  /xrad exch def  /y exch def
        /x exch def  /savematrix mtrx currentmatrix def
        /thickness-by-2 thickness 2 div def
        % Draw the filling
        newpath
	  x y translate
          gsave
	    xrad thickness-by-2 sub  yrad thickness-by-2 sub scale
            0 0 1 startangle endangle arc
            savematrix setmatrix
	    fill-halftone fill-red fill-green fill-blue fill-color-p FillShape
          grestore
        % Draw the border
        newpath
          xrad yrad scale
          0 0 1 startangle endangle arc
	  savematrix setmatrix
          line-halftone line-red line-green line-blue line-color-p
          line-cap line-join dash-pattern thickness StrokeShape
        end
   } def")

(defparameter *arc-fn*
  "
/ArcDict 23 dict def
ArcDict /mtrx matrix put
/DrawArc
   {
        ArcDict begin
        /fill-color-p exch def  /fill-blue exch def  /fill-green exch def
        /fill-red exch def  /fill-halftone exch def  /thickness exch def
        /dash-pattern exch def  /line-join exch def  /line-cap exch def
        /line-color-p exch def  /line-blue exch def  /line-green exch def
        /line-red exch def  /line-halftone exch def  /endangle exch def
        /startangle exch def  /yrad exch def  /xrad exch def  /y exch def
        /x exch def  /savematrix mtrx currentmatrix def
        /thickness-by-2 thickness 2 div def
        newpath
	  x y translate
          % Fill the arc
          gsave
	    xrad thickness-by-2 sub  yrad thickness-by-2 sub scale
            newpath
            0 0 moveto  0 0 1 startangle endangle arc  closepath
            fill-halftone fill-red fill-green fill-blue fill-color-p FillShape
          grestore
          % Draw the border
	  xrad yrad scale
          newpath
            0 0 1 startangle endangle arc
            savematrix setmatrix
            line-halftone line-red line-green line-blue line-color-p
            line-cap line-join dash-pattern thickness StrokeShape
        end
   } def")

(defparameter *polyline-fn*
  "
/PolylineDict 15 dict def
/DrawPolyline
   {	% stack: x1, y1, ..., xn, yn, n, line-halftone, line-red, line-blue,
        %        line-green, line-join, line-cap, dash-pattern,
        %        line-thickness, fill-halftone
        PolylineDict begin
        /fill-color-p exch def  /fill-blue exch def  /fill-green exch def
        /fill-red exch def  /fill-halftone exch def  /thickness exch def
        /dash-pattern exch def  /line-join exch def  /line-cap exch def
        /line-color-p exch def  /line-blue exch def  /line-green exch def
        /line-red exch def  /line-halftone exch def  /num-points exch 4 sub def
	newpath
	  moveto
	  num-points -2 0 {pop lineto} for
	  fill-halftone fill-red fill-green fill-blue fill-color-p FillShape
          line-halftone line-red line-green line-blue line-color-p
          line-cap line-join dash-pattern thickness StrokeShape
        end
   } def")



(defparameter *text-fn*
  "
/TextDict 19 dict def
/DrawText
   {	% stack: left top base-y opal-width height line-halftone fill-p
        %        fore-red fore-green fore-blue fore-color-p
        %        back-red back-green back-blue back-color-p
        %        string size font-name
        TextDict begin
        gsave
	findfont exch scalefont setfont
	/s exch def
        /back-color-p exch def  /back-blue exch def  /back-green exch def
        /back-red exch def  /fore-color-p exch def  /fore-blue exch def
        /fore-green exch def  /fore-red exch def  /fill-p exch def
        /line-halftone exch def /height exch def  /opal-width exch def
        /base-y exch def  /top exch def  /left exch def

        % Calculate distance to add between each character, based on the width
        % expected by Opal, the width expected by postscript, and the number
        % of characters to distribute the change over
	/x-dist opal-width s stringwidth pop sub s length div def

        % Draw background of text if appropriate
        fill-p
        { gsave
            newpath
            left top opal-width height RectanglePath
            1 back-red back-green back-blue back-color-p
            FillShape
          grestore } if

        % Draw text in the appropriate color
	newpath
          fore-color-p
          { fore-red fore-green fore-blue setrgbcolor }
          { line-halftone setgray } ifelse
	  left base-y moveto
	  x-dist 0 s ashow
        grestore
        end
   } def")


(defparameter *bitmap-fn*
  "
/BitmapDict 9 dict def
/DrawBitmap
   {    % stack: left top width height pattern transparent-p
        %        red green blue color-p
        BitmapDict begin
        /picstr 256 string def
	/color-p exch def  /blue exch def  /green exch def /red exch def
        /transparent-p exch def
        /pattern exch def  /height exch def  /width exch def
        gsave
          translate
          width height scale
	  color-p {red green blue setrgbcolor} if
          transparent-p
	  % The case where the background is not drawn
	  { width height false
            [ width 0 0 height 0 height ]
            {pattern} imagemask }
	  % The case where the background is drawn
          { width height 1
            [ width 0 0 height 0 height ]
            {pattern} image } ifelse
        grestore
        end
   } def")
        



;   This set of postscript functions for printing arbitrary filling styles
; is based on the example "Filling an Area with a Pattern" in the blue
; postscript Tutorial and Cookbook.  The function SetPattern is the top-level
; function for this set.
;   The implementation is as follows:  When an object is found to have an
; arbitrary filling style (i.e., not a standard opal halftone), then the
; parameters for SetPattern are written to the file, followed by the left,
; top, etc. that would otherwise be written out anyway.  Note that SetPattern
; is not called explicitly at this time.  When the graphic qualities for
; the object are printed out, a -2 value for the filling-style tells FillShape
; that there is a filling style sitting on the stack, and FillShape calls
; SetPattern.
; 
(defparameter *arbitrary-fill-fn*
  "
/SetUserScreenDict 22 dict def
SetUserScreenDict begin
  /tempctm matrix def
  /temprot matrix def
  /tempscale matrix def
  /ConcatProcs
   {/proc2 exch cvlit def
    /proc1 exch cvlit def
    /newproc proc1 length proc2 length add
      array def
    newproc 0 proc1 putinterval
    newproc proc1 length proc2 putinterval
    newproc cvx
   } def
  /resmatrix matrix def
  /findresolution
   { 72 0 resmatrix defaultmatrix dtransform
     /yres exch def /xres exch def
     xres dup mul yres dup mul add sqrt
   } def
end

/SetUserScreen
  { SetUserScreenDict begin
    /spotfunction exch def
    /cellsize exch def
    /m tempctm currentmatrix def
    /rm 0 temprot rotate def
    /sm cellsize dup tempscale scale def
    sm rm m m concatmatrix m concatmatrix pop
    1 0 m dtransform /y1 exch def /x1 exch def
    /veclength x1 dup mul y1 dup mul add sqrt def
    /frequency findresolution veclength div def
    /newscreenangle y1 x1 atan def
    m 2 get m 1 get mul m 0 get m 3 get mul sub
     0 gt
     { { neg } /spotfunction load ConcatProcs
         /spotfunction exch def
     } if
    frequency newscreenangle /spotfunction load setscreen
  end
} def

/SetPatternDict 18 dict def
SetPatternDict begin
  /bitison
   { /ybit exch def /xbit exch def
     /bytevalue bstring ybit bwidth mul xbit 8 idiv
       add get def
     /mask 1 7 xbit 8 mod sub bitshift def
     bytevalue mask and 0 ne
    } def
end

/BitPatternSpotFunction
  { SetPatternDict begin
     /y exch def /x exch def
     /xindex x 1 add 2 div bpside mul cvi def
     /yindex y 1 add 2 div bpside mul cvi def
     xindex yindex bitison
      { /onbits onbits 1 add def 1 }
      { /offbits offbits 1 add def 0 }
      ifelse
    end
  } def

/SetPattern
  { SetPatternDict begin
    /cellsz exch def
    /bwidth exch def
    /bpside exch def
    /bstring exch def
    /onbits 0 def /offbits 0 def
    cellsz /BitPatternSpotFunction load
     SetUserScreen
    {} settransfer
    offbits offbits onbits add div setgray
    end
  } def")


(defparameter *required-ps-fns* NIL)
(defparameter *font-list* NIL)
(defparameter *image-list* NIL)
(defparameter *image-cnt* 0)
(defparameter *file-uses-color-p* NIL)
(defvar *temp-win* NIL)
(defvar *color-p* T)
(defvar *page-width*)
(defvar *page-height*)
(defvar *print-area-width*)
(defvar *print-area-height*)
(defvar *bounding-box*)
(defvar *1-inch* 72)
(defvar *2-inches* 144)

;;;
;;;  Utiltity Functions
;;;

(defun convert-y (y)
  (- *print-area-height* y))
(Defun convert-angle (x)
  (round (* 180 (/ x (coerce PI 'short-float)))))
(defun format-int-or-fp (x)
  ; If x is float, format with two decimal places.  Else, format as integer.
  (format NIL "~:[~1@*~?~;~*~{~A~}~]" (integerp x) "~,2F" `(,x)))
(defun ps-rotate (angle)
  (format t "~S rotate~%" angle))
(defun scale (scale-x scale-y)
  (format T "~S ~S scale~%" scale-x scale-y))
(defun translate (left top)
  (format T "~S ~S translate~%" left top))
(defun gsave ()
  (format T "gsave~%"))
(defun grestore ()
  (format T "grestore~%~%"))

;;;
;;;  Functions for printing comments and the prolog
;;;

(defun bbox-comment ()
  (format t (concatenate 'string
	      "%%BoundingBox: " *bounding-box* "~%")))

(defun header-comments (title creator for)
  (format t "%!PS-Adobe-2.0 EPSF 2.0~%")
  (format t (concatenate 'string "%%Title: " title "~%"))
  (format t (concatenate 'string "%%Creator: " creator "~%"))
  (format t (concatenate 'string "%%CreationDate: "
			 (inter::time-to-string) "~%"))
  (format t (concatenate 'string "%%For: " for "~%"))
  (format t (if *file-uses-color-p*
		"%%This file uses real color~%"
		"%%This file does not use real color~%"))
  (format t "%%DocumentFonts: (atend)~%")
  (bbox-comment)
  (format t "%%Pages: 1~%")
  (format t "%%EndComments~%~%"))

(defun prolog ()
  (dolist (fn *required-ps-fns*)
    (format t fn) (terpri))
  (terpri)
  (dolist (pair *image-list*)
    (let ((image (car pair)) (image-name (cdr pair)))
      (format t image-name) (terpri)
      (print-image-info image)
      (format t "def~%~%")))
  (terpri)
  (format t "%%EndProlog~%")
  (format t "%%Page: 1 1~%~%"))

(defun trailer-comments ()
  (terpri)
  (format T "showpage~%")
  (format T "%%Trailer~%")
  (format T "%%DocumentFonts: ")
  (if *font-list*
      (do ((fonts *font-list* (cdr fonts)))
	  ((null fonts))
	(format T (car fonts)) (format T " ")))
  (terpri)
  (bbox-comment))



;;;
;;; Functions for setting the *required-ps-fns* list
;;;

(defun make-image-name ()
  (concatenate 'string "/image-" (prin1-to-string (incf *image-cnt*))))

;   Only those ps functions that are needed by the objects in the window
; will be printed out to the file.  So this function is iterated over every
; component in a top-level aggregate in a first pass to register which
; functions will be needed for this window.
;   If there are arbitrary fill patterns in any of the objects, then define
; them at the top of the file and dereference them when they are needed in
; a function call.
;
(defun Register-Fns-In-Win (win subwindows-p)
  (opal:do-all-components (g-value win :aggregate)
    #'(lambda (comp)
	(kr-send comp :ps-register-fn comp)
	(when (arbitrary-fill-p comp)
	  (pushnew *arbitrary-fill-fn* *required-ps-fns*)
	  (let ((image (g-value comp :filling-style :stipple :image)))
	    (unless (assoc image *image-list*)
	      (push (cons image (make-image-name)) *image-list*))))))
  (when subwindows-p
    (dolist (sub-win (g-value win :child))
      (Register-Fns-In-Win sub-win subwindows-p))))

(defun set-control-lists (win clip-p subwindows-p)
  (setf *required-ps-fns* (list *fillshape-fn* *strokeshape-fn*))
  (setf *image-list* NIL)
  (setf *image-cnt* 0)
  (when clip-p (pushnew *clip-fn* *required-ps-fns*))
  (pushnew *rectangle-fn* *required-ps-fns*)
  (Register-Fns-In-Win win subwindows-p))

;; Check-FS-Color and Check-LS-Color are used to determine whether the
;; PS file will require a real color when it is printed.  A "real color"
;; is a color where the red, green, and blue values are not all equal
;; (i.e., a non-gray color).  A comment is printed at the top of the file
;; announcing whether the file uses a real color.
;;
(defun check-fs-color (obj)
  (let ((fs (g-value obj :filling-style)))
    (if fs
	(let ((foreground-color (g-value fs :foreground-color)))
	  (if (and foreground-color
		   (not (= (g-value foreground-color :red)
			   (g-value foreground-color :green)
			   (g-value foreground-color :blue))))
	      (setf *file-uses-color-p* T)
	      (let ((background-color (g-value fs :background-color)))
		(if (and background-color
			 (not (= (g-value background-color :red)
				 (g-value background-color :green)
				 (g-value background-color :blue))))
		    (setf *file-uses-color-p* T))))))))

(defun check-ls-color (obj)
  (let ((ls (g-value obj :line-style)))
    (if ls
	(let ((foreground-color (g-value ls :foreground-color)))
	  (if (and foreground-color
		   (not (= (g-value foreground-color :red)
			   (g-value foreground-color :green)
			   (g-value foreground-color :blue))))
	      (setf *file-uses-color-p* T)
	      (let ((background-color (g-value ls :background-color)))
		(if (and background-color
			 (not (= (g-value background-color :red)
				 (g-value background-color :green)
				 (g-value background-color :blue))))
		    (setf *file-uses-color-p* T))))))))

;   These methods are executed on a "first pass" through the aggregate tree
; in order to find out which postscript functions will be used by the objects.
; 
(define-method :ps-register-fn OPAL:TEXT (obj)
  (pushnew *text-fn* *required-ps-fns*)
  (and *color-p* (or *file-uses-color-p* (check-ls-color obj))))
(define-method :ps-register-fn OPAL:CURSOR-TEXT (obj)
  (call-prototype-method obj)
  (pushnew *line-fn* *required-ps-fns*))
(define-method :ps-register-fn OPAL:CURSOR-MULTI-TEXT (obj)
  (call-prototype-method obj)
  (pushnew *line-fn* *required-ps-fns*))
(define-method :ps-register-fn OPAL:LINE (obj)
  (pushnew *line-fn* *required-ps-fns*)
  (and *color-p* (or *file-uses-color-p* (check-ls-color obj))))
(define-method :ps-register-fn OPAL:ARC (obj)
  (pushnew *arc-fn* *required-ps-fns*)
  (and *color-p*
       (or *file-uses-color-p* (check-ls-color obj) (check-fs-color obj))))
(define-method :ps-register-fn OPAL:CIRCLE (obj)
  (pushnew *ellipse-fn* *required-ps-fns*)
  (and *color-p*
       (or *file-uses-color-p* (check-ls-color obj) (check-fs-color obj))))
(define-method :ps-register-fn OPAL:OVAL (obj)
  (pushnew *ellipse-fn* *required-ps-fns*)
  (and *color-p*
       (or *file-uses-color-p* (check-ls-color obj) (check-fs-color obj))))
(define-method :ps-register-fn OPAL:ROUNDTANGLE (obj)
  (pushnew *roundtangle-fn* *required-ps-fns*)
  (and *color-p*
       (or *file-uses-color-p* (check-ls-color obj) (check-fs-color obj))))
(define-method :ps-register-fn OPAL:RECTANGLE (obj)
  (pushnew *rectangle-fn* *required-ps-fns*)
  (and *color-p*
       (or *file-uses-color-p* (check-ls-color obj) (check-fs-color obj))))
(define-method :ps-register-fn OPAL:POLYLINE (obj)
  (pushnew *polyline-fn* *required-ps-fns*)
  (and *color-p*
       (or *file-uses-color-p* (check-ls-color obj) (check-fs-color obj))))
(define-method :ps-register-fn OPAL:BITMAP (obj)
  (pushnew *bitmap-fn* *required-ps-fns*)
  (let ((image (g-value obj :image)))
    (unless (assoc image *image-list*)
      (push (cons image (make-image-name)) *image-list*)))
  (and *color-p*
       (or *file-uses-color-p* (check-ls-color obj))))
(define-method :ps-register-fn OPAL:VIRTUAL-AGGREGATE (obj)
  (let ((dummy-item (g-value obj :dummy-item)))
    (when dummy-item
      (kr-send dummy-item :ps-register-fn dummy-item)
      (and *color-p*
	   (or *file-uses-color-p*
	       (check-ls-color dummy-item)
	       (check-fs-color dummy-item))))))



;; All computations for position, dimension, and scaling are performed
;; before anything is written out to the file.  Then, everything is
;; written out to the file at once, at the bottom of Make-PS-File
;;
(defun Make-PS-File (win file-name
		     &key left top scale-x scale-y landscape-p
		          (position-x :center) (position-y :center)
		          (left-margin *1-inch*) (right-margin *1-inch*)
			  (top-margin *1-inch*) (bottom-margin *1-inch*)
		          (borders-p T) (subwindows-p T) (clip-p T) (color-p T)
			  (background-color opal:white)
			  (title (if (schema-p win) (g-value win :title)))
			  (creator (concatenate 'string
				     "Make-PS-File -- Garnet Version "
				     user::Garnet-Version-Number))
			  (for "") )

  ; When the user supplies a list of windows, create a new temporary "window"
  ; and make them its children.  We never update or do anything else to the
  ; temporary window -- it just provides a standard structure we can analyze.
  (if (listp win)
      (let (region-left region-top right bottom region-width region-height)
	(cond
	  ((listp clip-p)
	   (setq region-left (first clip-p))
	   (setq region-top (second clip-p))
	   (setq region-width (third clip-p))
	   (setq region-height (fourth clip-p))
	   (setq clip-p T)) ; Since the temp window has the same dimensions
	                    ; as the clip region, just clip to the window
	  (t
	   (setq region-left opal:*screen-width*)
	   (setq region-top opal:*screen-height*)
	   (setq right 0) (setq bottom 0)
	   (dolist (w win)
	     (setf region-left (min region-left (g-value w :left)))
	     (setf right (max right (+ (g-value w :left) (g-value w :width)))))
	   (setf region-width (- right region-left))
	   (dolist (w win)
	     (setf region-top (min region-top (g-value w :top)))
	     (setf bottom (max bottom (+ (g-value w :top)
					 (g-value w :height)))))
	   (setf region-height (- bottom region-top))))
	;; We call *temp-win* a "window", but it is really just a KR object
	;; that has the same slots as a window.
	(setf *temp-win* (create-schema NIL 
			   (:left region-left) (:top region-top)
			   (:width region-width) (:height region-height)
			   (:background-color background-color)
			   (:border-width 2)
			   (:child win)
			   (:aggregate (create-schema NIL
					 (:left 0) (:top 0)
					 (:width region-width)
					 (:height region-height)))))
	(setf win *temp-win*)))

  (setf *color-p* color-p)
  (set-control-lists win clip-p subwindows-p)
  (setf *font-list* NIL)
  (cond (landscape-p (setf *page-width* 792)
		     (setf *page-height* 612))
	(t (setf *page-width* 612)
	   (setf *page-height* 792)))
      
  ; Adjust margins
  (setf *print-area-width* (- *page-width* left-margin right-margin))
  (setf *print-area-height* (- *page-height* top-margin bottom-margin))

  ; Center window (or clipping region) on page by default
  ; If not clipping, then look at the top-level aggregate instead of window
  (let* ((win-width (g-value win :width))
	 (win-height (g-value win :height))
	 (agg (g-value win :aggregate))
	 (width (if clip-p
		    (if (listp clip-p)
			(MIN (third clip-p) (- win-width (first clip-p)))
			win-width)
		    (MAX win-width
			 (+ (g-value agg :left) (g-value agg :width)))))
	 (height (if clip-p
		     (if (listp clip-p)
			 (MIN (fourth clip-p) (- win-height (second clip-p)))
			 win-height)
		     (MAX win-height
			  (+ (g-value agg :top) (g-value agg :height))))))
    (unless (and scale-x scale-y)
      (cond (scale-x
	     (setf scale-y (if (> height *print-area-height*)
			       (float (/ *print-area-height* height))
			       1)))
	    (scale-y
	     (setf scale-x (if (> width *print-area-width*)
			       (float (/ *print-area-width* width))
			       1)))
	    (t (setf scale-x (min 1 (float (/ *print-area-width* width))
				  (float (/ *print-area-height* height)))
		     scale-y scale-x))))

    ; Adjust print area dimensions since it is getting scaled, too
    (setf *print-area-width* (round (/ *print-area-width* scale-x)))
    (setf *print-area-height* (round (/ *print-area-height* scale-y)))
    (unless left
      (setf left (case position-x
		   (:left (setf left 0))
		   (:center (setf left (round (- *print-area-width* width) 2)))
		   (:right (setf left (- *print-area-width* width))))))
    (unless top
      (setf top (case position-y
		  (:top (setf top 0))
		  (:center (setf top (round (- *print-area-height*
					       height) 2)))
		  (:bottom (setf top (- *print-area-height* height))))))
    ;; Compute boundingbox  llx = lower-left-x, urx = upper-right-x
    (let* ((llx (+ left-margin (* left scale-x)))
	   (lly (+ bottom-margin (* (convert-y (+ top height)) scale-y)))
	   (urx (+ llx (* width scale-x)))
	   (ury (+ lly (* height scale-y))))
      (setf *bounding-box*
	    (format NIL "~S ~S ~S ~S"
		    (round llx) (round lly) (round urx) (round ury))))
    ; Now write everything to the file
    (Write-PS-To-File win file-name left top width height scale-x scale-y
		      landscape-p left-margin bottom-margin borders-p
		      subwindows-p clip-p title creator for))
  ; Reset color variable
  (setf *file-uses-color-p* NIL)
  
  ; Clean up temporary window if one was allocated
  (when *temp-win*
    (s-value *temp-win* :child NIL)
    (opal:destroy (g-value *temp-win* :aggregate))
    (opal:destroy *temp-win*)
    (setf *temp-win* NIL))
  T)

;; This function handles all of the file output.
;;
(defun Write-PS-To-File (win file-name left top width height scale-x scale-y
			 landscape-p left-margin bottom-margin borders-p
			 subwindows-p clip-p title creator for)
  (with-open-file (*standard-output* file-name :direction :output
				     :if-exists :supersede)
    (header-comments title creator for)
    (prolog)
    (gsave)
    (when landscape-p
      (translate *page-height* 0)
      (ps-rotate 90))
    (translate left-margin bottom-margin)
    (scale scale-x scale-y)
    (ps-window win left top width height borders-p subwindows-p clip-p)
    (grestore)
    (trailer-comments)))


(defun ps-window (win left top width height borders-p subwindows-p clip-p)
  (let ((top-agg (g-value win :aggregate)))
    (format t "~%%~%% Begin new window~%%~%")
    ; Position this window relative to the top-level window
    (if (and *temp-win* (member win (g-value *temp-win* :child)))
	(translate (- left (g-value *temp-win* :left))
		   (- (g-value *temp-win* :top) top))
	(translate left (- top)))
    (gsave)
    ; Clip everything in this window (including subwindows) into the window
    (when clip-p
      (format T "0 ~S ~S ~S ClipToRectangle~%"
	      (convert-y 0) width height))
    ; Translate stuff inside window according to clipping dimensions
    (let ((clipped-left (if (and clip-p (listp clip-p)) (first clip-p) 0))
	  (clipped-top (if (and clip-p (listp clip-p)) (second clip-p) 0)))
      (translate (- clipped-left) clipped-top))
    ; Print the meat of the window
    (gsave)
    (print-window-background win)
    (kr-send top-agg :ps-object top-agg)
    (grestore)
    ; Print subwindows
    (setf clip-p (if clip-p T NIL))
    (when subwindows-p
      (dolist (child (g-value win :child))
	(when (g-value child :visible)
	  (gsave)
	  (ps-window child (g-value child :left) (g-value child :top)
		     (g-value child :width) (g-value child :height)
		     borders-p subwindows-p clip-p)
	  (grestore))))
    (grestore)
    ; Draw border of window with dimensions (0,0,width,height)
    ; Line-thickness 1, Line-halftone black, Fill-halftone white
    (when borders-p
      (let ((border-width (g-value win :border-width)))
	(when (plusp border-width)
	  (format T "0 ~S ~S ~S 0 0 0 0 false 0 0 [] ~S -1 0 0 0 false DrawRectangle~%"
		  (convert-y 0) width height border-width))))))

;;;
;;; Utility functions
;;;

;    A special function to consider the background-color of the window
;
(defun print-window-background (win)
  (let ((background-color (g-value win :background-color)))
    (if background-color
	(format t "0 ~S ~S ~S 0 0 0 0 false 0 0 [] -1 0 ~A ~A ~A true DrawRectangle~%"
		(convert-y 0) (g-value win :width) (g-value win :height)
		(format-int-or-fp (g-value background-color :red))
		(format-int-or-fp (g-value background-color :green))
		(format-int-or-fp (g-value background-color :blue))))))

;    A filling-style is called 'arbitrary' if it is not one of the pre-defined
; opal halftones like opal:gray-fill.  Opal:diamond-fill is considered an
; arbitrary filling-style.
;
(defun arbitrary-fill-p (obj)
  (let ((filling-style (g-value obj :filling-style)))
    (when filling-style
      (let ((stipple (g-value filling-style :stipple)))
	(when stipple
	  (not (g-value stipple :percent)))))))


;    This function is called to put an arbitrary filling style on the stack,
; which will be used to fill the next shape drawn.  The filling style has
; been defined with its image-name at the top of the postscript file, and
; here it is just dereferenced.
;
(defun handle-arbitrary-fill (obj)
  (when (arbitrary-fill-p obj)
    (let* ((image (g-value obj :filling-style :stipple :image))
	   (image-name (string-trim "/" (cdr (assoc image *image-list*))))
	   (width (xlib:image-width image))
	   (bwidth (ceiling width 8))  ; Min bytes needed for one row
	   (cellsz (float (/ 72 (/ 300 (* 32 bwidth))))))
      (format T image-name)
      (format T " ~S ~S ~,2F~%" width bwidth cellsz))))
			  

;    This function looks at the image in the filling-style of the object.
; When the filling-style was created, a two-dimensional array was stored with
; it (called A below).  This function goes through the array of 1's and 0's
; and generates corresponding hex numbers.
;    The hex numbers are generated with respect to a full-byte representation
; of the array.  That is, zeroes are filled in at the end of an array row if
; the width is not an integral number of bytes.  This is required by the
; postscript function that will be called with the data.
;
(defun print-image-info (image)
  ; Need to have z-type images to get information from
  (let* ((flip-p (unless (xlib:image-z-p image)
		   (setq image (xlib:copy-image image
						:result-type 'xlib:image-z))))
	 (width (xlib:image-width image))
	 (height (xlib:image-height image))
	 (a (xlib:image-z-pixarray image))
	 (power 0) (digit 0)
	 (bwidth (ceiling width 8))  ; Min bytes needed for one row
	 (max-col (- width 1))  ; dotimes is 0-based
	 (max-row (- height 1)) ; dotimes is 0-based
	 (digits-in-array-row (+ 1 (* 2 bwidth)))
	 (cols-before-newline (MAX 1 (floor 78 digits-in-array-row)))
	 (cbn-1 (- cols-before-newline 1)))
    (format T "<")
    (dotimes (row height)
      (setf power 0) (setf digit 0)
      (dotimes (col (* bwidth 8))
	(setf power (case power (0 3) (t (1- power))))
	(setf digit (+ digit (* (if (> col max-col)
				    0
				    (if flip-p 
				        (aref a (- max-row row) col)
					(if (eq (aref a (- max-row row) col) *black*)
					    0 1)))
				(expt 2 power))))
	(when (eq 0 power)
	  (format T "~1X" (if flip-p (- #xf digit) digit))
	  (setf digit 0)))
      (unless (eq row max-row)
	(if (eq cbn-1 (mod row cols-before-newline))
	    (terpri)
	    (format t " "))))
    (format t ">~%")))


    
; Parameters:  red, green, blue, color-p
; Works for either filling-styles or line-styles
(defun print-color-info (style)
  (if (and *color-p* style)
      (let ((color (g-value style :foreground-color)))
	(if (or (eq color opal:white) (eq color opal:black))
	    ;; Take care of black and white colors using halftones at a
	    ;; higher level (like in print-line-qualities).
	    (format t "0 0 0 false ")
	    (format t "~A ~A ~A true "
		    (format-int-or-fp (g-value color :red))
		    (format-int-or-fp (g-value color :green))
		    (format-int-or-fp (g-value color :blue)))))
      (format t "0 0 0 false ")))

; Parameters:  red, green, blue, color-p
; Works for either filling-styles or line-styles
(defun print-background-color-info (style)
  (if (and *color-p* style)
      (let ((color (g-value style :background-color)))
	(if (eq color opal:white)
	    (format t "0 0 0 false ")
	    (format t "~A ~A ~A true "
		    (format-int-or-fp (g-value color :red))
		    (format-int-or-fp (g-value color :green))
		    (format-int-or-fp (g-value color :blue)))))
      (format t "0 0 0 false ")))

; Parameters: line-halftone, red, green, blue, color-p, line-cap,
;             line-join, dash-pattern, line-thickness
; Line-thickness of -1 means don't draw a line
; Halftones: 0 = black, 1 = white
(defun print-line-qualities (obj)
  (let ((line-style (g-value obj :line-style)))
    (if line-style
	(let* ((line-thickness (let ((lt (g-value line-style :line-thickness)))
				 (if (eq lt 0) 1 lt)))
	       (stipple (g-value line-style :stipple))
	       (foreground-color (g-value line-style :foreground-color))
	       (line-halftone (if stipple
				  (- 1 (float (/ (g-value stipple :percent)
						 100)))
				  ;; Assuming no stipple, then if we have a
				  ;; white line, use stipple 1.  Else, use
				  ;; stipple 0 with whatever color it is.
				  (if (eq foreground-color opal:white) 1 0)))
	       (line-cap (case (g-value line-style :cap-style)
			   (:butt 0) (:round 1) (:projecting 2)))
	       (line-join (case (g-value line-style :join-style)
			    (:miter 0) (:round 1) (:bevel 2)))
	       (dash-pattern (let ((dp (g-value line-style :dash-pattern)))
			       (if dp
				   (substitute #\[ #\(
				     (substitute #\] #\)
				       (concatenate 'string
					 (prin1-to-string dp) " ")))
				   "[] "))))
	  (format t "~A " (format-int-or-fp line-halftone))
	  (print-color-info line-style)
	  (format T "~S ~S " line-cap line-join)
	  (format T dash-pattern)
	  (format T "~S " line-thickness))
	;; Don't draw a line
	(format T "0 0 0 0 false 0 0 [] -1 "))))

; Halftones: 0 = black, 1 = white, -2 = arbitrary (like diamond-fill)
(defun print-graphic-qualities (obj)
  (print-line-qualities obj)
  (let ((filling-style (g-value obj :filling-style)))
    ; Print fill-halftone
    (if (arbitrary-fill-p obj)
	(format T "-2 ")
	(if filling-style
	    (let* ((stipple (g-value filling-style :stipple))
		   (percent (if stipple
				(g-value stipple :percent)
				100)))
	      (format T "~A " (format-int-or-fp (- 1 (/ percent 100)))))
	    (format T "-1 ")))
    ; Print color info
    (print-color-info filling-style)))


;;;
;;; Aggregate
;;;

(define-method :ps-object OPAL:AGGREGATE (obj)
  (dovalues (comp obj :components)
    (if (and (g-value comp :visible)
	     (not (eq :no-op (g-value comp :draw-function))))
	(kr-send comp :ps-object comp))))

;;;
;;; Text (plain)
;;;

;; Add-Font-To-List will put the font-name in a global list which is
;; printed out at the end of the postscript file.
;;
(defun add-font-to-list (font-name)
  (pushnew font-name *font-list* :test #'string=))

(defun remove-left (string)
  (let ((index (position #\( string)))
    (if index
	(let ((part1 (subseq string 0 index))
	      (part2 (subseq string (1+ index))))
	  ; The double-\\ turn into single-\ when formatted
	  (concatenate 'string part1 "\\050" (remove-left part2)))
	string)))

(defun remove-right (string)
  (let ((index (position #\) string)))
    (if index
	(let ((part1 (subseq string 0 index))
	      (part2 (subseq string (1+ index))))
	  ; The double-\\ turn into single-\ when formatted
	  (concatenate 'string part1 "\\051" (remove-right part2)))
	string)))

;; Since postscript uses parentheses as quote marks, we have to convert
;; parens in the string to \050 and \051.
;;
(defun convert-parentheses (string)
  (if (or (find #\( string) (find #\) string))
      (remove-left (remove-right string))
      string))

;; Double each occurrence of a backslash.  When we see a \ in the string,
;; we have to replace it with \\\\.  The \\\\ becomes \\ when it is formatted
;; in lisp, and that \\ becomes \ when it is printed in PostScript.
;;
(defun double-backslashes (string)
  (let ((index (position #\\ string)))
    (if index
	(let ((part1 (subseq string 0 index))
	      (part2 (subseq string (1+ index))))
	  (concatenate 'string part1 "\\\\" (double-backslashes part2)))
	string)))

(define-method :ps-object OPAL:TEXT (obj)
  (let ((string (convert-parentheses
		 (double-backslashes (g-value obj :string))))
	(line-style (g-value obj :line-style)))
    (unless (or (null string) (null line-style) (string= string ""))
      (let* ((font (g-value obj :font))
	     (xfont (opal::font-to-xfont font opal::*default-x-display*))
	     (left (g-value obj :left))
	     (top (convert-y (g-value obj :top)))
	     (base-y (+ (- top
			   (xlib:max-char-ascent xfont))
			(if (g-value obj :actual-heightp)
			    (xlib:max-char-descent xfont) 0)))
	     (opal-width (g-value obj :width))
	     (height (g-value obj :height))
	     (foreground-color (g-value line-style :foreground-color))
	     (line-halftone (let ((stipple (g-value line-style :stipple)))
			      (if stipple
				  (- 1 (float (/ (g-value stipple :percent)
						 100)))
				  ;; Assuming no stipple, then if we have a
				  ;; white line, use stipple 1.  Else, use
				  ;; stipple 0 with whatever color it is.
				  (if (eq foreground-color opal:white) 1 0))))
	     (font-name (g-value font :ps-font-name))
	     (font-size (g-value font :ps-font-size)))
	(add-font-to-list font-name)
	(format t "~S ~S ~S ~S ~S ~A " left top base-y opal-width height
		(format-int-or-fp line-halftone))
	(if (g-value obj :fill-background-p)
	    (format t "true ")
	    (format t "false "))
	(print-color-info line-style)
	(print-background-color-info line-style)
	(format t "(~A) ~A ~A DrawText~%"
		string (prin1-to-string font-size) font-name)))))


(define-method :ps-object OPAL:CURSOR-TEXT (obj)
  ;; Print the text
  (call-prototype-method obj)
  ;; Print the cursor (as a line)
  (let ((font (g-value obj :font)))
    (if (and (g-value obj :cursor-index)
	     (g-value obj :line-style)
	     font)
	(let ((xfont (opal::font-to-xfont font opal::*default-x-display*))
	      (left (g-value obj :left))
	      (top (g-value obj :top))
	      (height (g-value obj :height))
	      (width (g-value obj :width))
	      (substring (g-value obj :x-substr))
	      (text-extents (g-value obj :text-extents))
	      cursor-offset)
	  (setq cursor-offset (- (xlib:text-width xfont substring)
				 (the-left-bearing text-extents)
				 1))
	  (setq cursor-offset (min cursor-offset
				   (- width (ceiling *cursor-width* 2))))
	  (setq cursor-offset (max cursor-offset (floor *cursor-width* 2)))

	  ;; Parameters: line-halftone, line-cap, line-join, dash-pattern,
	  ;;             line-thickness, x2, y2, x1, y1
	  (print-line-qualities obj)
	  (format T "~S ~S ~S ~S " (+ left cursor-offset)
		  (convert-y top)
		  (+ left cursor-offset)
		  (convert-y (+ top height)))
	  (format T "DrawLine~%")))))


;;;
;;;  Multi-Text
;;;

(define-method :ps-object OPAL:MULTI-TEXT (obj)
  (let ((line-style (g-value obj :line-style))
	(cut-strings (g-value obj :cut-strings)))
    (if (and line-style cut-strings)
	(let* ((foreground-color (g-value line-style :foreground-color))
	       (line-halftone (let ((stipple (g-value line-style :stipple)))
			       (if stipple
				   (- 1 (float (/ (g-value stipple :percent)
						  100)))
				   (if (eq foreground-color opal:white) 1 0))))
	       (font (g-value obj :font))
	       (xfont (opal::font-to-xfont font opal::*default-x-display*))
	       (font-size (g-value font :ps-font-size))
	       (font-name (g-value font :ps-font-name))
	       (justification (g-value obj :justification))
	       (left (g-value obj :left)) (top (convert-y (g-value obj :top)))
	       (height (opal:string-height font "X"))
	       (max-line-width (g-value obj :width))
	       (ascent (xlib:max-char-ascent xfont)))
	  (add-font-to-list font-name)
	  (dotimes (i (length cut-strings))
	    (let* ((cut-string (nth i cut-strings))
		   (string-top (- top (* i height)))
		   (base-y (- string-top ascent))
		   (opal-width (cut-string-width cut-string))
		   (string (convert-parentheses
			    (cut-string-string cut-string))))
	      (unless (string= string "")
		(format t "~S ~S ~S ~S ~S ~A "
			(+ left
			   (case justification
			     (:right (- max-line-width opal-width))
			     (:center (floor (- max-line-width opal-width) 2))
			     (t 0)))
			string-top base-y opal-width height
			(format-int-or-fp line-halftone))
		(if (g-value obj :fill-background-p)
		    (format t "true ")
		    (format t "false "))
		(print-color-info line-style)
		(print-background-color-info line-style)
		(format t "(~A) ~A ~A DrawText~%"
			string (prin1-to-string font-size) font-name))))))))

		
(define-method :ps-object OPAL:CURSOR-MULTI-TEXT (obj)
  ;; Print the text
  (call-prototype-method obj)
  ;; Print the cursor (as a line)
  (let ((font (g-value obj :font))
	(cursor-index-aux (g-value obj :cursor-index)))
    (if (and cursor-index-aux
	     (g-value obj :line-style)
	     font)
	(let* ((xfont (opal::font-to-xfont font opal::*default-x-display*))
	       (left (g-value obj :left))
	       (top (g-value obj :top))
	       (max-line-width (g-value obj :width))
	       (justification (g-value obj :justification))
	       (cut-strings (g-value obj :cut-strings))
	       (cursor-index
		(max 0 (min cursor-index-aux
			    (length (g-value obj :string)))))
	       (line-number (cursor-index-to-line-number
			     cut-strings cursor-index))
	       (cut-string (nth line-number cut-strings))
	       (line-height (+ (xlib:max-char-ascent xfont)
			       (xlib:max-char-descent xfont)))
	       (line-left-bearing (cut-string-left-bearing cut-string))
	       (line-width (cut-string-width cut-string))
	       (substring (g-value obj :x-substr))
	       (cursor-offset (+ (case justification
				   (:right (- max-line-width line-width))
				   (:center (floor (- max-line-width line-width) 2))
				   (t 0))
				 (xlib:text-width xfont substring)
				 (- line-left-bearing)
				 -1)))
	  (setq cursor-offset (min cursor-offset
				   (- max-line-width
				      (ceiling *cursor-width* 2))))
	  (setq cursor-offset (max cursor-offset (floor *cursor-width* 2)))

	  ;; Parameters: line-halftone, line-cap, line-join, dash-pattern,
	  ;;             line-thickness, x2, y2, x1, y1
	  (print-line-qualities obj)
	  (format T "~S ~S ~S ~S " (+ left cursor-offset)
		  (convert-y (+ top (* line-number line-height)))
		  (+ left cursor-offset)
		  (convert-y (+ top (* (1+ line-number) line-height))))
	  (format T "DrawLine~%")))))


;;;
;;;  Lines
;;;

(define-method :ps-object OPAL:LINE (obj)
  ; Parameters: line-halftone, line-cap, line-join, dash-pattern,
  ;             line-thickness, x2, y2, x1, y1
  (when (g-value obj :line-style)
    (print-line-qualities obj)
    (format T "~S ~S ~S ~S " (g-value obj :x2)
	                     (convert-y (g-value obj :y2))
			     (g-value obj :x1)
			     (convert-y (g-value obj :y1)))
    (format T "DrawLine~%")))

;;;
;;;  Circles, Arcs, Ovals
;;;

;; This method should really be split into two - one method for ARCs and
;; one method for CIRCLEs.
;;
(define-method :ps-object OPAL:ARC (obj)
  (when (or (g-value obj :line-style) (g-value obj :filling-style))
    (let ((left (g-value obj :left))
	  (opal-top (g-value obj :top))
	  (width (g-value obj :width))
	  (height (g-value obj :height)))
      (handle-arbitrary-fill obj)
      (let* ((circle-p (or (is-a-p obj opal:circle)
			   (is-a-p obj opal:oval))) ; If not arc, ignore angles
	     (line-style (g-value obj :line-style))
	     (line-thickness (if line-style
				 (g-value line-style :line-thickness) 0))
	     (lt/2 (float (/ line-thickness 2)))
	     (radius-x (- (float (/ width 2)) lt/2))
	     (radius-y (- (float (/ height 2)) lt/2))
	     (center-x (+ left radius-x lt/2))
	     (center-y (convert-y (+ opal-top radius-y lt/2)))
	     (angle1 (if circle-p 0 (convert-angle (g-value obj :angle1))))
	     (angle2 (if circle-p 360
			 (+ angle1
			    (convert-angle (g-value obj :angle2))))))
	; Parameters: center-x, center-y, radius-x, radius-y, angle1, angle2,
        ;             line-thickness, line-halftone, fill-halftone
	(format T "~S ~S ~S ~S ~S ~S " center-x center-y radius-x radius-y
		                       angle1 angle2)
	(print-graphic-qualities obj)
	(if circle-p
	    (format T "DrawEllipse~%")
	    (format T "DrawArc~%"))))))

;;;
;;;  Roundtangles
;;;

(define-method :ps-object OPAL:ROUNDTANGLE (obj)
  ; Parameters: left, top, width, height, radius, line-thickness,
  ; line-halftone, line-cap, line-join, dash-pattern, fill-halftone
  (when (or (g-value obj :line-style) (g-value obj :filling-style))
    (handle-arbitrary-fill obj)
    (let* ((line-style (g-value obj :line-style))
	   (offset (if line-style
		       (let ((lt (g-value line-style :line-thickness)))
			 (if (eq lt 1) 0 lt))
		       0))
	   (offset/2 (round offset 2))
	   (left (+ (g-value obj :left) offset/2))
	   (top (convert-y (+ (g-value obj :top) offset/2)))
	   (width (- (g-value obj :width) offset))
	   (height (- (g-value obj :height) offset))
	   (radius (g-value obj :draw-radius)))
      (when (and (plusp width) (plusp height) (plusp radius))
	(format T "~S ~S ~S ~S ~S " left top width height radius)
	(print-graphic-qualities obj)
	(format T "DrawRoundtangle~%")))))
  
;;;
;;;  Rectangles
;;;

(define-method :ps-object OPAL:RECTANGLE (obj)
  ; Parameters: left, top, width, height,
  ;             line-thickness, line-halftone, fill-halftone
  (when (or (g-value obj :line-style) (g-value obj :filling-style))
    (handle-arbitrary-fill obj)
    (let* ((line-style (g-value obj :line-style))
	   (offset (if line-style
		       (let ((lt (g-value line-style :line-thickness)))
			 (if (eq lt 1) 0 lt))
		       0))
	   (offset/2 (round offset 2))
	   (left (+ (g-value obj :left) offset/2))
	   (top (convert-y (+ (g-value obj :top) offset/2)))
	   (width (- (g-value obj :width) offset))
	   (height (- (g-value obj :height) offset)))
      (format T "~S ~S ~S ~S " left top width height))
    (print-graphic-qualities obj)
    (format T "DrawRectangle~%")))

;;;
;;;  Polylines
;;;

(define-method :ps-object OPAL:POLYLINE (obj)
  ; Parameters: x1, y1, ..., xn, yn, n
  (when (or (g-value obj :line-style) (g-value obj :filling-style))
    (handle-arbitrary-fill obj)
    (let ((point-list (g-value obj :point-list))
	  (counter 0))
      ; Convert all the y-coordinates while printing
      (dolist (point point-list)
	(if (evenp counter)
	    (format T "~S " point)
	    (format T "~S " (convert-y point)))
	(incf counter))
      (format T "~S " (length point-list))
      (print-graphic-qualities obj)
      (format T "DrawPolyline~%"))))

;;
;; Bitmaps
;;

(define-method :ps-object OPAL:BITMAP (obj)
  (let ((filling-style (g-value obj :filling-style)))
    (when filling-style
      (let* ((image (g-value obj :image))
	     (image-name (string-trim "/" (cdr (assoc image *image-list*))))
	     (transparent-p (eq :stippled
				(g-value filling-style :fill-style))))
	(format t "~S ~S ~S ~S "
		(g-value obj :left) (convert-y (g-value obj :top))
		(g-value obj :width) (g-value obj :height))
	(format t image-name)
	(format t (if transparent-p " true " " false "))
	(print-color-info filling-style)
	(format t "DrawBitmap~%")))))


;;
;; Virtual Aggregate
;;
(define-method :ps-object OPAL:VIRTUAL-AGGREGATE (gob)
  (let* ((dummy (g-value gob :dummy-item))
	 (update-info (g-value dummy :update-info))
	 (item-array (g-value gob :item-array)))
    (dotimes (n (g-value gob :next-available-rank))
      (s-value dummy :rank n)
      (s-value dummy :item-values (aref item-array n))
      (opal::update-slots-values-changed dummy 0 update-info)
      (when (and (aref item-array n) (g-value dummy :visible))
	(kr-send dummy :ps-object dummy)))))
