[mcclim-cvs] CVS update: mcclim/Backends/PostScript/class.lisp mcclim/Backends/PostScript/graphics.lisp mcclim/Backends/PostScript/paper.lisp mcclim/Backends/PostScript/sheet.lisp
Christophe Rhodes
crhodes at common-lisp.net
Mon Oct 31 10:21:17 UTC 2005
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 () , at 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~%")
More information about the Mcclim-cvs
mailing list