Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory common-lisp.net:/tmp/cvs-serv32722/Backends/PostScript Modified Files: class.lisp graphics.lisp paper.lisp sheet.lisp Log Message: Add support for EPS output in the postscript backend. Essentially this is done by using output recording; we draw to a recording stream, measure the bounding box, then replay the output record. There's a currently unused (and undefined) hook for outputing device fonts, which we are using locally in the tablature editor; however, our implementation of device fonts sucks utterly majorly. Also add rudimentary test file. Date: Mon Oct 31 11:21:14 2005 Author: crhodes Index: mcclim/Backends/PostScript/class.lisp diff -u mcclim/Backends/PostScript/class.lisp:1.6 mcclim/Backends/PostScript/class.lisp:1.7 --- mcclim/Backends/PostScript/class.lisp:1.6 Thu Jul 4 08:57:43 2002 +++ mcclim/Backends/PostScript/class.lisp Mon Oct 31 11:21:14 2005 @@ -37,7 +37,8 @@ ;;;; Medium (defclass postscript-medium (basic-medium) - ()) + ((device-fonts :initform nil + :accessor device-fonts))) (defmacro postscript-medium-graphics-state (medium) `(first (slot-value (medium-sheet ,medium) 'graphics-state-stack))) @@ -84,7 +85,9 @@ *default-postscript-title*)) (for (or (getf header-comments :for) *default-postscript-for*)) - (region (paper-region device-type orientation)) + (region (case device-type + ((:eps) +everywhere+) + (t (paper-region device-type orientation)))) (transform (make-postscript-transformation device-type orientation))) (make-instance 'postscript-stream :file-stream file-stream Index: mcclim/Backends/PostScript/graphics.lisp diff -u mcclim/Backends/PostScript/graphics.lisp:1.13 mcclim/Backends/PostScript/graphics.lisp:1.14 --- mcclim/Backends/PostScript/graphics.lisp:1.13 Mon Aug 1 18:50:43 2005 +++ mcclim/Backends/PostScript/graphics.lisp Mon Oct 31 11:21:14 2005 @@ -169,23 +169,25 @@ "Native transformation") ;;; Postscript output utilities -(defmacro with-graphics-state ((medium) &body body) - `(invoke-with-graphics-state ,medium +(defmacro with-graphics-state ((stream) &body body) + `(invoke-with-graphics-state ,stream (lambda () ,@body))) -(defun postscript-save-graphics-state (medium) - (push (copy-list (postscript-medium-graphics-state medium)) - (slot-value (medium-sheet medium) 'graphics-state-stack)) - (format (postscript-medium-file-stream medium) "gsave~%")) - -(defun postscript-restore-graphics-state (medium) - (pop (slot-value (medium-sheet medium) 'graphics-state-stack)) - (format (postscript-medium-file-stream medium) "grestore~%")) +(defun postscript-save-graphics-state (stream) + (push (copy-list (first (slot-value stream 'graphics-state-stack))) + (slot-value stream 'graphics-state-stack)) + (when (stream-drawing-p stream) + (format (postscript-stream-file-stream stream) "gsave~%"))) + +(defun postscript-restore-graphics-state (stream) + (pop (slot-value stream 'graphics-state-stack)) + (when (stream-drawing-p stream) + (format (postscript-stream-file-stream stream) "grestore~%"))) -(defun invoke-with-graphics-state (medium continuation) - (postscript-save-graphics-state medium) +(defun invoke-with-graphics-state (stream continuation) + (postscript-save-graphics-state stream) (funcall continuation) - (postscript-restore-graphics-state medium)) + (postscript-restore-graphics-state stream))  ;;; Postscript path functions @@ -346,8 +348,8 @@ ;; does only one level of saving graphics state, so we can restore ;; and save again GS to obtain an initial CP. It is ugly, but I see ;; no other way now. -- APD, 2002-02-11 - (postscript-restore-graphics-state medium) - (postscript-save-graphics-state medium) + (postscript-restore-graphics-state (medium-sheet medium)) + (postscript-save-graphics-state (medium-sheet medium)) (postscript-set-clipping-region stream (medium-clipping-region medium))) @@ -494,7 +496,7 @@ (let ((*transformation* (sheet-native-transformation (medium-sheet medium)))) (let ((file-stream (postscript-medium-file-stream medium))) (postscript-actualize-graphics-state file-stream medium :color :text-style) - (with-graphics-state (medium) + (with-graphics-state ((medium-sheet medium)) #+ignore (when transform-glyphs ;; Index: mcclim/Backends/PostScript/paper.lisp diff -u mcclim/Backends/PostScript/paper.lisp:1.2 mcclim/Backends/PostScript/paper.lisp:1.3 --- mcclim/Backends/PostScript/paper.lisp:1.2 Fri May 31 04:32:10 2002 +++ mcclim/Backends/PostScript/paper.lisp Mon Oct 31 11:21:14 2005 @@ -55,6 +55,9 @@ (make-rectangle* 0 0 width height))) (defun make-postscript-transformation (paper-size-name orientation) + (when (eq paper-size-name :eps) + (return-from make-postscript-transformation + (make-reflection-transformation* 0 0 1 0))) (multiple-value-bind (width height) (paper-size paper-size-name) (case orientation (:portrait (make-3-point-transformation* @@ -63,4 +66,4 @@ (:landscape (make-3-point-transformation* 0 0 0 width height 0 width height 0 height width 0)) - (t (error "Unknown orientation"))))) \ No newline at end of file + (t (error "Unknown orientation"))))) Index: mcclim/Backends/PostScript/sheet.lisp diff -u mcclim/Backends/PostScript/sheet.lisp:1.9 mcclim/Backends/PostScript/sheet.lisp:1.10 --- mcclim/Backends/PostScript/sheet.lisp:1.9 Thu Apr 1 06:26:46 2004 +++ mcclim/Backends/PostScript/sheet.lisp Mon Oct 31 11:21:14 2005 @@ -58,29 +58,45 @@ orientation header-comments))) (unwind-protect (progn + (with-output-recording-options (stream :record t :draw nil) + (with-graphics-state (stream) + ;; we need at least one level of saving -- APD, 2002-02-11 + (funcall continuation stream))) (with-slots (file-stream title for orientation paper) stream - (format file-stream "%!PS-Adobe-3.0~%") + (format file-stream "%!PS-Adobe-3.0~@[ EPSF-3.0~*~]~%" + (eq device-type :eps)) (format file-stream "%%Creator: McCLIM~%") (format file-stream "%%Title: ~A~%" title) (format file-stream "%%For: ~A~%" for) (format file-stream "%%LanguageLevel: 2~%") - (multiple-value-bind (width height) - (paper-size paper) - (format file-stream "%%BoundingBox: 0 0 ~A ~A~%" width height) - (format file-stream "%%DocumentMedia: ~A ~A ~A 0 () ()~%" - paper width height)) - (format file-stream "%%Orientation: ~A~%" - (ecase orientation - (:portrait "Portrait") - (:landscape "Landscape"))) - (format file-stream "%%Pages: (atend)~%") + (case paper + ((:eps) + (let ((record (stream-output-history stream))) + (multiple-value-bind (lx ly ux uy) (bounding-rectangle* record) + (format file-stream "%%BoundingBox: ~A ~A ~A ~A~%" + (floor lx) (- (ceiling uy)) + (ceiling ux) (- (floor ly)))))) + (t + (multiple-value-bind (width height) + (paper-size paper) + (format file-stream "%%BoundingBox: 0 0 ~A ~A~%" width height) + (format file-stream "%%DocumentMedia: ~A ~A ~A 0 () ()~%" + paper width height)) + (format file-stream "%%Orientation: ~A~%" + (ecase orientation + (:portrait "Portrait") + (:landscape "Landscape"))) + (format file-stream "%%Pages: (atend)~%"))) (format file-stream "%%DocumentNeededResources: (atend)~%") (format file-stream "%%EndComments~%~%") (write-postcript-dictionary file-stream) - (start-page stream)) - (with-graphics-state ((sheet-medium stream)) - ;; we need at least one level of saving -- APD, 2002-02-11 - (funcall continuation stream))) + (dolist (text-style (device-fonts (sheet-medium stream))) + (write-font-to-postscript-stream (sheet-medium stream) text-style)) + (start-page stream) + (let ((record (stream-output-history stream))) + (with-output-recording-options (stream :draw t :record nil) + (with-graphics-state (stream) + (replay record stream)))))) (with-slots (file-stream current-page) stream (format file-stream "end~%showpage~%~%") (format file-stream "%%Trailer~%")