[mcclim-cvs] CVS update: mcclim/Backends/PostScript/graphics.lisp mcclim/Backends/PostScript/sheet.lisp

[Christophe Rhodes]

Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript
In directory common-lisp.net:/tmp/cvs-serv3468/Backends/PostScript

Modified Files:
	graphics.lisp sheet.lisp 
Log Message:
Postscript backend fixes, from Tim Daly's "typos and postscript backend"
message on free-clim 2005-12-23.  (wow, this is almost timely)

Date: Fri Dec 30 19:02:40 2005
Author: crhodes

Index: mcclim/Backends/PostScript/graphics.lisp
diff -u mcclim/Backends/PostScript/graphics.lisp:1.14 mcclim/Backends/PostScript/graphics.lisp:1.15
--- mcclim/Backends/PostScript/graphics.lisp:1.14	Mon Oct 31 11:21:14 2005
+++ mcclim/Backends/PostScript/graphics.lisp	Fri Dec 30 19:02:39 2005
@@ -68,7 +68,7 @@
 
 (defvar *extra-entries* 0)
 
-(defun write-postcript-dictionary (stream)
+(defun write-postscript-dictionary (stream)
   ;;; FIXME: DSC
   (format stream "~&%%BeginProlog~%")
   (format stream "/~A ~D dict def ~2:*~A begin~%"


Index: mcclim/Backends/PostScript/sheet.lisp
diff -u mcclim/Backends/PostScript/sheet.lisp:1.10 mcclim/Backends/PostScript/sheet.lisp:1.11
--- mcclim/Backends/PostScript/sheet.lisp:1.10	Mon Oct 31 11:21:14 2005
+++ mcclim/Backends/PostScript/sheet.lisp	Fri Dec 30 19:02:39 2005
@@ -89,7 +89,7 @@
                 (format file-stream "%%Pages: (atend)~%")))
              (format file-stream "%%DocumentNeededResources: (atend)~%")
              (format file-stream "%%EndComments~%~%")
-             (write-postcript-dictionary file-stream)
+             (write-postscript-dictionary file-stream)
              (dolist (text-style (device-fonts (sheet-medium stream)))
                (write-font-to-postscript-stream (sheet-medium stream) text-style))
              (start-page stream)
@@ -107,20 +107,44 @@
         (finish-output file-stream))
       (destroy-port port))))
 
+
 (defun start-page (stream)
   (with-slots (file-stream current-page transformation) stream
-      (format file-stream "%%Page: ~D ~:*~D~%" (incf current-page))
-      (format file-stream "~A begin~%" *dictionary-name*)))
+    (format file-stream "%%Page: ~D ~:*~D~%" (incf current-page))
+    (format file-stream "~A begin~%" *dictionary-name*)))
+
+;;; We define a new output-record class and a method on
+;;; replay-output-record so that we can record calls to new-page.
+;;;
+;;; FIXME: I (CSR) think that this works because we stuff this in a
+;;; sequence-output-record, so that the output records are replayed
+;;; in order.  That's fine, but if someone ever gets round to implementing
+;;; R-trees or similar, this method for storing the order of events might
+;;; stop working.  CSR, 2005-12-30
+(defclass new-page-record (climi::basic-output-record)
+  ())
+
+(defmethod replay-output-record ((record new-page-record) stream
+				 &optional (region nil) (x-offset 0) (y-offset 0))
+  (declare (ignore region x-offset y-offset))
+  (new-page stream))
 
 (defun new-page (stream)
-  ;; FIXME: it is necessary to do smth with GS -- APD, 2002-02-11
-  (let ((medium (sheet-medium stream)))
-    (postscript-restore-graphics-state medium)
+  (when (stream-recording-p stream)
+    (stream-add-output-record stream (make-instance 'new-page-record)))
+  (when (stream-drawing-p stream)
+    ;; FIXME: it is necessary to do smth with GS -- APD, 2002-02-11
+    ;; FIXME^2:  what do you mean by that? -- TPD, 2005-12-23
+    (postscript-restore-graphics-state stream)
     (format (postscript-stream-file-stream stream) "end~%showpage~%")
     (start-page stream)
-    (postscript-save-graphics-state medium))
-  (clear-output-record (stream-output-history stream))
-  (setf (stream-cursor-position stream) (values 0 0)))
+    (postscript-save-graphics-state stream)
+    ;; If we call clear-output-record here, it wipes all remaining
+    ;; output, so all pages after the first are blank.  But I don't
+    ;; know quite what the original purpose of the call was, so,
+    ;; FIXME.  -- TPD 2005-12-23
+    ;; (clear-output-record (stream-output-history stream))
+    (setf (stream-cursor-position stream) (values 0 0))))
 
 
 ;;;; Output Protocol