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)
