Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv31595
Modified Files: decls.lisp frames.lisp graphics.lisp recording.lisp stream-output.lisp utils.lisp Log Message:
Hammered on with-room-for-graphics. It should now leave the cursor in the right place and do the right thing with respect to recording options.
Changed with-drawing-options to not rebind its medium argument at all.
Added :label and :scroll-bars arguments to with-menu which are currently ignored.
Date: Wed Feb 2 12:33:59 2005 Author: tmoore
Index: mcclim/decls.lisp diff -u mcclim/decls.lisp:1.30 mcclim/decls.lisp:1.31 --- mcclim/decls.lisp:1.30 Thu Dec 30 11:09:40 2004 +++ mcclim/decls.lisp Wed Feb 2 12:33:58 2005 @@ -111,6 +111,13 @@ (defgeneric invoke-with-drawing-options (medium continuation &rest drawing-options &key &allow-other-keys))
+;;;; 10.2.1 +(defgeneric invoke-with-identity-transformation (medium continuation)) + +;;;; 10.2.2 +(defgeneric invoke-with-local-coordinates (medium continuation x y)) + +(defgeneric invoke-with-first-quadrant-coordinates (medium continuation x y))
;;;; 14.5 (defgeneric draw-design
Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.104 mcclim/frames.lisp:1.105 --- mcclim/frames.lisp:1.104 Tue Jan 11 14:14:18 2005 +++ mcclim/frames.lisp Wed Feb 2 12:33:58 2005 @@ -1394,6 +1394,37 @@ (frob pointer-button-press-event presentation-button-press-handler) (frob pointer-button-release-event presentation-button-release-handler))
+(defun make-drag-bounding (old-highlighting new-highlighting + old-presentation new-presentation) + (let (x1 y1 x2 y2) + (flet ((union-with-bounds (rect) + (cond ((null rect) + nil) + ((null x1) + (setf (values x1 y1 x2 y2) (bounding-rectangle* rect))) + (t (with-bounding-rectangle* (r-x1 r-y1 r-x2 r-y2) + rect + (setf (values x1 y1 x2 y2) + (bound-rectangles x1 y1 x2 y2 + r-x1 r-y1 r-x2 r-y2))))))) + (union-with-bounds old-highlighting) + (union-with-bounds new-highlighting) + (union-with-bounds old-presentation) + (union-with-bounds new-presentation) + (values x1 y1 x2 y2)))) + +(defun make-drag-and-drop-feedback-function (from-presentation) + (multiple-value-bind (record-x record-y) + (output-record-position from-presentation) + (let ((current-to-presentation nil) + (current-from-higlighting nil)) + (lambda (frame from-presentation to-presentation initial-x initial-y + x y event) + (let ((dx (- record-x initial-x)) + (dy (- record-y initial-y))) + (typecase event + (null + ())))))))
(defun frame-drag (translator-name command-table object presentation context-type frame event window x y) @@ -1416,5 +1447,5 @@ (tracking-pointer (window :context-type drag-c-type :highlight nil) (:pointer-motion (&key event x y) (multiple-value-bind (presentation translator) - (find-innermost-presentation-context drag-context window - x y :event event))))))) + (find-innermost-presentation-match drag-context window + x y :event event)))))))
Index: mcclim/graphics.lisp diff -u mcclim/graphics.lisp:1.49 mcclim/graphics.lisp:1.50 --- mcclim/graphics.lisp:1.49 Tue Jan 11 14:35:18 2005 +++ mcclim/graphics.lisp Wed Feb 2 12:33:58 2005 @@ -20,6 +20,38 @@
(in-package :clim-internals)
+;;; Work in progress that reduces consing of rest arguments and keyword +;;; processing. +(defmacro with-medium-and-options ((sheet + &key ink clipping-region transformation + line-unit line-thickness + line-style line-style-p + line-dashes dashes-p + line-joint-shape line-cap-shape + text-style text-style-p + text-family text-family-p + text-face text-face-p + text-size text-size-p) + (medium) + &body body) + (with-gensyms (continuation sheet-medium) + `(flet ((,continuation (,medium) + ,@body)) + (declare (dynamic-extent #',continuation)) + (with-sheet-medium (,sheet-medium ,sheet) + (do-graphics-with-options-internal-1 + ,sheet-medium #'continuation + ,ink ,clipping-region ,transformation + ,line-unit ,line-thickness + ,line-style ,line-style-p + ,line-dashes ,dashes-p + ,line-joint-shape ,line-cap-shape + ,text-style ,text-style-p + ,text-family ,text-family-p + ,text-face ,text-face-p + ,text-size ,text-size-p)))) + ) + (defmethod do-graphics-with-options ((sheet sheet) func &rest options) (with-sheet-medium (medium sheet) (apply #'do-graphics-with-options-internal medium sheet func options))) @@ -130,15 +162,15 @@ (apply #'do-graphics-with-options ,sheet #'graphics-op ,args)))
(defmacro with-drawing-options ((medium &rest drawing-options) &body body) - (when (eq medium t) - (setq medium '*standard-output*)) - (check-type medium symbol) - (let ((gcontinuation (gensym))) - `(flet ((,gcontinuation (,medium) - ,@body)) - #-clisp (declare (dynamic-extent #',gcontinuation)) - (apply #'invoke-with-drawing-options - ,medium #',gcontinuation (list ,@drawing-options))))) + (setq medium (stream-designator-symbol medium '*standard-output*)) + (with-gensyms (gcontinuation cont-arg) + `(flet ((,gcontinuation (,cont-arg) + (declare (ignore ,cont-arg)) + ,@body)) + #-clisp (declare (dynamic-extent #',gcontinuation)) + (apply #'invoke-with-drawing-options + ,medium #',gcontinuation (list ,@drawing-options))))) +
(defmethod invoke-with-drawing-options ((medium medium) continuation &rest drawing-options @@ -151,8 +183,8 @@
(defmethod invoke-with-drawing-options ((sheet sheet) continuation &rest drawing-options) (with-sheet-medium (medium sheet) - (with-medium-options (medium drawing-options) - (funcall continuation sheet)))) + (with-medium-options (medium drawing-options) + (funcall continuation medium))))
;;; Compatibility with real CLIM (defmethod invoke-with-drawing-options ((sheet t) continuation @@ -160,11 +192,23 @@ (declare (ignore drawing-options)) (funcall continuation sheet))
-(defmethod invoke-with-identity-transformation (medium cont) - (with-drawing-options (medium - :transformation (invert-transformation - (medium-transformation medium))) - (funcall cont medium))) +(defmethod invoke-with-identity-transformation + ((sheet sheet) continuation) + (with-sheet-medium (medium sheet) + (letf (((medium-transformation medium) +identity-transformation+)) + (funcall continuation sheet)))) + + +(defmethod invoke-with-identity-transformation + ((destination pixmap) continuation) + (with-pixmap-medium (medium destination) + (letf (((medium-transformation medium) +identity-transformation+)) + (funcall continuation destination)))) + +(defmethod invoke-with-identity-transformation + ((medium medium) continuation) + (letf (((medium-transformation medium) +identity-transformation+)) + (funcall continuation medium)))
(defmethod invoke-with-local-coordinates (medium cont x y) ;; For now we do as real CLIM does. @@ -653,6 +697,13 @@ (copy-area (sheet-medium stream) from-x from-y width height to-x to-y) (error "COPY-AREA on a stream is not implemented")))
+;;; XXX The modification of the sheet argument to hold the pixmap medium seems +;;; completely incorrect here; the description of the macro in the spec says +;;; nothing about that. On the other hand, the spec talks about "medium-var" +;;; when that is clearly meant to be a stream (and an output-recording stream +;;; at that, if the example in the Franz user guide is to be believed). What a +;;; mess. I think we need a pixmap output recording stream in order to do this +;;; right. -- moore (defmacro with-output-to-pixmap ((medium-var sheet &key width height) &body body) `(let* ((pixmap (allocate-pixmap ,sheet ,width ,height)) ; XXX size might be unspecified -- APD (,medium-var (make-medium (port ,sheet) pixmap))
Index: mcclim/recording.lisp diff -u mcclim/recording.lisp:1.115 mcclim/recording.lisp:1.116 --- mcclim/recording.lisp:1.115 Thu Oct 14 08:30:11 2004 +++ mcclim/recording.lisp Wed Feb 2 12:33:58 2005 @@ -2190,43 +2190,62 @@ (call-next-method)))
;;; ---------------------------------------------------------------------------- - +;;; Complicated, underspecified... +;;; +;;; From examining old Genera documentation, I believe that +;;; with-room-for-graphics is supposed to set the medium transformation to +;;; give the desired coordinate system; i.e., it doesn't preserve any +;;; rotation, scaling or translation in the current medium transformation. (defmethod invoke-with-room-for-graphics (cont stream - &key (first-quadrant t) - height - (move-cursor t) - (record-type 'standard-sequence-output-record)) + &key (first-quadrant t) + height + (move-cursor t) + (record-type + 'standard-sequence-output-record)) ;; I am not sure what exactly :height should do. ;; --GB 2003-05-25 ;; The current behavior is consistent with 'classic' CLIM ;; --Hefner 2004-06-19 + ;; Don't know if it still is :) + ;; -- Moore 2005-01-26 (multiple-value-bind (cx cy) (stream-cursor-position stream) - (let ((record - (with-output-recording-options (stream :draw nil :record t) - (with-new-output-record (stream record-type) - (with-drawing-options - (stream :transformation - (if first-quadrant - (make-scaling-transformation 1 -1) - +identity-transformation+)) - (funcall cont stream)))))) - (cond ((null height) - (setf (output-record-position record) - (values cx cy))) - (t - (setf (output-record-position record) - (values cx - (- cy (- (bounding-rectangle-height record) height)))))) - (with-output-recording-options (stream :draw t :record nil) - (replay-output-record record stream)) - (cond (move-cursor - (setf (stream-cursor-position stream) - (values (bounding-rectangle-max-x record) - (bounding-rectangle-max-y record)))) - (t - (setf (stream-cursor-position stream) - (values cx cy))))))) + (with-sheet-medium (medium stream) + (letf (((medium-transformation medium) + (if first-quadrant + (make-scaling-transformation 1 -1) + +identity-transformation+))) + (let ((record (with-output-to-output-record (stream record-type) + (funcall cont stream)))) + ;; Bounding rectangle is in sheet coordinates! + (with-bounding-rectangle* (x1 y1 x2 y2) + record + (declare (ignore x2)) + (if first-quadrant + (setf (output-record-position record) + (values (max cx (+ cx x1)) + (if height + (max cy (+ cy (- height (- y2 y1)))) + cy))) + (setf (output-record-position record) + (values (max cx (+ cx x1)) (max cy (+ cy y1))))) + (when (stream-recording-p stream) + (stream-add-output-record stream record)) + (when (stream-drawing-p stream) + (replay record stream)) + (if move-cursor + (let ((record-height (- y2 y1))) + (setf (stream-cursor-position stream) + (values cx + (if first-quadrant + (+ cy (max (- y1) + (or height 0) + record-height)) + (+ cy (max (or height 0) + record-height)))))) + (setf (stream-cursor-position stream) (values cx cy))) + record)))))) +
(defmethod repaint-sheet ((sheet output-recording-stream) region)
Index: mcclim/stream-output.lisp diff -u mcclim/stream-output.lisp:1.52 mcclim/stream-output.lisp:1.53 --- mcclim/stream-output.lisp:1.52 Sun Oct 31 02:46:31 2004 +++ mcclim/stream-output.lisp Wed Feb 2 12:33:59 2005 @@ -426,6 +426,7 @@ non-nil, that is used as the width where needed; otherwise STREAM-STRING-WIDTH will be called."))
+;;; The cursor is in stream coordinates. (defmethod stream-write-output (stream line string-width &optional (start 0) end) (declare (ignore string-width)) @@ -433,6 +434,7 @@ (multiple-value-bind (cx cy) (stream-cursor-position stream) (draw-text* (sheet-medium stream) line cx (+ cy baseline) + :transformation +identity-transformation+ :start start :end end))))
(defmethod stream-write-char ((stream standard-extended-output-stream) char)
Index: mcclim/utils.lisp diff -u mcclim/utils.lisp:1.39 mcclim/utils.lisp:1.40 --- mcclim/utils.lisp:1.39 Mon Dec 20 16:50:22 2004 +++ mcclim/utils.lisp Wed Feb 2 12:33:59 2005 @@ -452,7 +452,7 @@ (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
(defun stream-designator-symbol (symbol default) - "Maps T to *standard-output*, barfs if argument does not look good. + "Maps T to DEFAULT, barfs if argument does not look good. To be used in the various WITH-... macros." (cond ((eq symbol 't) default)