[mcclim-cvs] CVS update: mcclim/graphics.lisp mcclim/incremental-redisplay.lisp mcclim/package.lisp mcclim/pointer-tracking.lisp mcclim/sheets.lisp
Timothy Moore
tmoore at common-lisp.net
Tue Jan 11 13:35:33 UTC 2005
Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv16352
Modified Files:
graphics.lisp incremental-redisplay.lisp package.lisp
pointer-tracking.lisp sheets.lisp
Log Message:
Rewrote WITH-DOUBLE-BUFFERING. This version takes a rectangle as an
argument, allocates a pixmap for that region of the screen, and sets up
the sheet transformations so that drawing is done in the correct
pixmap coordinates.
Use WITH-DOUBLE-BUFFERING in DRAG-OUTPUT-RECORD. Add a little example
of using dragging-output.
Change the definition of ROUND-COORDINATE in the CLX backend to round
down from .5, not up. This should follow the CLIM pixel coverage
definition for shapes more closely. Replace most uses of ROUND in the
CLX backend with ROUND-COORDINATE.
Allow inconsistent :ID-TEST arguments in UPDATING-OUTPUT.
Date: Tue Jan 11 14:35:19 2005
Author: tmoore
Index: mcclim/graphics.lisp
diff -u mcclim/graphics.lisp:1.48 mcclim/graphics.lisp:1.49
--- mcclim/graphics.lisp:1.48 Mon Mar 1 13:52:29 2004
+++ mcclim/graphics.lisp Tue Jan 11 14:35:18 2005
@@ -664,10 +664,12 @@
(setf (%sheet-medium ,sheet) old-medium));is sheet a sheet-with-medium-mixin? --GB
pixmap))
-; This seems to be incorrect.
-; This presumes that your drawing will completely fill the bounding rectangle of the sheet
-; and will effectively randomise anything that isn't draw, within it.
-; FIXME
+;;; XXX This seems to be incorrect.
+;;; This presumes that your drawing will completely fill the bounding rectangle
+;;; of the sheet and will effectively randomize anything that isn't drawn
+;;; within it.
+;;; FIXME
+#+nil
(defmacro with-double-buffering ((sheet) &body body)
(let ((width (gensym))
(height (gensym))
@@ -687,6 +689,115 @@
; in which case, we shouldn't blit it back
(copy-from-pixmap ,pixmap 0 0 ,width ,height ,sheet 0 0))
(deallocate-pixmap ,pixmap)))))
+
+;;; Another attempt
+
+(defun invoke-with-double-buffering (sheet continuation x1 y1 x2 y2)
+ (let* ((medium (sheet-medium sheet))
+ (sheet-transform (sheet-native-transformation sheet))
+ (medium-transform (medium-transformation (sheet-medium sheet)))
+ (world-transform (compose-transformations sheet-transform
+ medium-transform)))
+ (multiple-value-bind (sheet-x1 sheet-y1)
+ (transform-position world-transform x1 y1)
+ (multiple-value-bind (sheet-x2 sheet-y2)
+ (transform-position world-transform x2 y2)
+ ;; Be conservative with the size of the pixmap, including all of
+ ;; the pixels at the edges.
+ (let* ((pixmap-x1 (floor sheet-x1))
+ (pixmap-y1 (floor sheet-y1))
+ (pixmap-x2 (ceiling sheet-x2))
+ (pixmap-y2 (ceiling sheet-y2))
+ (pixmap-width (- pixmap-x2 pixmap-x1))
+ (pixmap-height (- pixmap-y2 pixmap-y1))
+ (current-sheet-region (sheet-region sheet))
+ (sheet-native (compose-transformation-with-translation
+ sheet-transform
+ (- pixmap-x1)
+ (- pixmap-y1)))
+ (pixmap (allocate-pixmap sheet pixmap-width pixmap-height))
+ )
+ (unless pixmap
+ (error "Couldn't allocate pixmap"))
+ (multiple-value-bind (user-pixmap-x1 user-pixmap-y1)
+ (untransform-position world-transform pixmap-x1 pixmap-y1)
+ (multiple-value-bind (user-pixmap-x2 user-pixmap-y2)
+ (untransform-position world-transform pixmap-x2 pixmap-y2)
+ (flet ((set-native (transform region sheet)
+ (%%set-sheet-native-transformation transform sheet)
+ (setf (slot-value sheet 'region) region)
+ (invalidate-cached-regions sheet)
+ (invalidate-cached-transformations sheet)))
+ ;; Assume that the scaling for the sheet-native
+ ;; transformation for the pixmap will be the same as that of
+ ;; the mirror .
+ (unwind-protect
+ (letf (((sheet-parent sheet) nil)
+ ((sheet-direct-mirror sheet)
+ (pixmap-mirror pixmap)))
+ (unwind-protect
+ (let ((pixmap-region
+ (make-bounding-rectangle user-pixmap-x1
+ user-pixmap-y1
+ user-pixmap-x2
+ user-pixmap-y2)))
+ (set-native sheet-native pixmap-region sheet)
+ ;(break)
+ (with-drawing-options
+ (medium :ink (medium-background medium))
+
+ (medium-draw-rectangle* medium
+ user-pixmap-x1
+ user-pixmap-y1
+ user-pixmap-x2
+ user-pixmap-y2
+ t))
+ (funcall continuation sheet
+ user-pixmap-x1 user-pixmap-y1
+ user-pixmap-x2 user-pixmap-y2))
+ (set-native sheet-transform
+ current-sheet-region
+ sheet)))
+ (copy-from-pixmap pixmap 0 0
+ pixmap-width pixmap-height sheet
+ user-pixmap-x1 user-pixmap-y1)
+ (deallocate-pixmap pixmap))))))))))
+
+(defmacro with-double-buffering (((sheet &rest bounds-args)
+ (&rest pixmap-args))
+ &body body)
+ (with-gensyms (continuation)
+ (let ((cont-form
+ (case (length pixmap-args)
+ (1
+ (with-gensyms (pixmap-x1 pixmap-y1 pixmap-x2 pixmap-y2)
+ `(,continuation (,sheet
+ ,pixmap-x1 ,pixmap-y1 ,pixmap-x2 ,pixmap-y2)
+ (let ((,(car pixmap-args)
+ (make-bounding-rectangle ,pixmap-x1 ,pixmap-y1
+ ,pixmap-x2 ,pixmap-y2)))
+ , at body))))
+ (4
+ `(,continuation (,sheet , at pixmap-args)
+ , at body))
+ (otherwise (error "Invalid pixmap-args ~S" pixmap-args)))))
+ (case (length bounds-args)
+ (1
+ (with-gensyms (x1 y1 x2 y2)
+ `(flet (,cont-form)
+ (declare (dynamic-extent #',continuation))
+ (with-bounding-rectangle* (,x1 ,y1 ,x2 ,y2)
+ ,(car bounds-args)
+ (invoke-with-double-buffering ,sheet
+ #',continuation
+ ,x1 ,y1 ,x2 ,y2)))))
+ (4
+ `(flet (,cont-form)
+ (declare (dynamic-extent #',continuation))
+ (invoke-with-double-buffering ,sheet #',continuation
+ , at bounds-args)))
+ (otherwise (error "invalid bounds-args ~S" bounds-args))))))
+
;;; Generic graphic operation methods
Index: mcclim/incremental-redisplay.lisp
diff -u mcclim/incremental-redisplay.lisp:1.40 mcclim/incremental-redisplay.lisp:1.41
--- mcclim/incremental-redisplay.lisp:1.40 Sun Oct 24 17:47:02 2004
+++ mcclim/incremental-redisplay.lisp Tue Jan 11 14:35:18 2005
@@ -105,7 +105,9 @@
(id-counter :accessor id-counter
:documentation "The counter used to assign unique ids to
updating output records without one.")
- (tester-function :accessor tester-function :initform 'none)
+ (tester-function :accessor tester-function :initform 'none
+ :documentation "The function used to lookup
+ updating output records in this map if unique; otherwise, :mismatch.")
(element-count :accessor element-count :initform 0)))
;;; Complete guess...
@@ -113,6 +115,8 @@
"The limit at which the id map in an updating output record switches to a
hash table.")
+;;; ((eq map-test-func :mismatch)
+;;; nil)
(defun function-matches-p (map func)
(let ((map-test-func (tester-function map)))
(cond ((eq map-test-func func)
@@ -125,19 +129,25 @@
(eq map-test-func (symbol-value func)))
(t nil))))
+(defun ensure-test (map test)
+ (unless (function-matches-p map test)
+ (explode-map-hash map)
+ (setf (tester-function map) :mismatch)))
+
(defun get-from-map (map value test)
(when (eq (tester-function map) 'none)
(return-from get-from-map nil))
- (if (function-matches-p map test)
- (let ((map (id-map map)))
- (if (hash-table-p map)
- (gethash value map)
- (cdr (assoc value map :test test))))
- (error "Test function ~S doesn't match ~S" test (tester-function map))))
+ (ensure-test map test)
+ (let ((map (id-map map)))
+ (if (hash-table-p map)
+ (gethash value map)
+ (cdr (assoc value map :test test)))))
+
(defun maybe-convert-to-hash (map)
(let ((test (tester-function map)))
- (when (and (> (element-count map) *updating-map-threshold*)
+ (when (and (not (eq test :mismatch))
+ (> (element-count map) *updating-map-threshold*)
(or (case test
((eq eql equal equalp) t))
(eq test #'eq)
@@ -150,42 +160,48 @@
do (setf (gethash key new-map) value))
(setf (id-map map) new-map)))))
+(defun explode-map-hash (map)
+ (let ((hash-map (id-map map)))
+ (when (hash-table-p hash-map)
+ (loop
+ for key being each hash-key of hash-map using (hash-value record)
+ collect (cons key record) into alist
+ finally (setf (id-map map) alist)))))
+
(defun add-to-map (map record value test replace)
- (when (eq (tester-function map) 'none)
- (setf (tester-function map) test))
- (if (function-matches-p map test)
- (let ((val-map (id-map map)))
- (if (hash-table-p val-map)
- (multiple-value-bind (existing-value in-table)
- (if replace
- (gethash value val-map)
- (values nil nil))
- (declare (ignore existing-value))
- (setf (gethash value val-map) record)
- (unless in-table
- (incf (element-count map))))
- (let ((val-cons (if replace
- (assoc value val-map :test test)
- nil)))
- (if val-cons
- (setf (cdr val-cons) record)
- (progn
- (setf (id-map map) (acons value record val-map))
- (incf (element-count map))
- (maybe-convert-to-hash map))))))
- (error "Test function ~S doesn't match ~S" test (tester-function map))))
+ (if (eq (tester-function map) 'none)
+ (setf (tester-function map) test)
+ (ensure-test map test))
+ (let ((val-map (id-map map)))
+ (if (hash-table-p val-map)
+ (multiple-value-bind (existing-value in-table)
+ (if replace
+ (gethash value val-map)
+ (values nil nil))
+ (declare (ignore existing-value))
+ (setf (gethash value val-map) record)
+ (unless in-table
+ (incf (element-count map))))
+ (let ((val-cons (if replace
+ (assoc value val-map :test test)
+ nil)))
+ (if val-cons
+ (setf (cdr val-cons) record)
+ (progn
+ (setf (id-map map) (acons value record val-map))
+ (incf (element-count map))
+ (maybe-convert-to-hash map)))))))
(defun delete-from-map (map value test)
- (if (function-matches-p map test)
- (let ((val-map (id-map map))
- (deleted nil))
- (if (hash-table-p val-map)
- (setf deleted (remhash value val-map))
- (setf (values (id-map map) deleted)
- (delete-1 value val-map :test test :key #'car)))
- (when deleted
- (decf (element-count map))))
- (error "Test function ~S doesn't match ~S" test (tester-function map))))
+ (ensure-test map test)
+ (let ((val-map (id-map map))
+ (deleted nil))
+ (if (hash-table-p val-map)
+ (setf deleted (remhash value val-map))
+ (setf (values (id-map map) deleted)
+ (delete-1 value val-map :test test :key #'car)))
+ (when deleted
+ (decf (element-count map)))))
(defmethod shared-initialize :after ((obj updating-output-map-mixin) slot-names
&key)
@@ -887,10 +903,6 @@
(setf (parent-cache record) parent-cache)))
record)))
-;;; &key (unique-id (gensym)) was used earlier,
-;;; changed to (unique-id `',(gensym)) as per gilham's request
-;;; please CHECKME and delete this comment :]
-;;;
;;; The Franz user guide says that updating-output does
;;; &allow-other-keys, and some code I've encountered does mention
;;; other magical arguments, so we'll do the same. -- moore
Index: mcclim/package.lisp
diff -u mcclim/package.lisp:1.46 mcclim/package.lisp:1.47
--- mcclim/package.lisp:1.46 Mon Dec 20 16:49:19 2004
+++ mcclim/package.lisp Tue Jan 11 14:35:18 2005
@@ -409,6 +409,7 @@
#:+textual-dialog-view+ ;constant
#:+textual-menu-view+ ;constant
#:+textual-view+ ;constant
+ #:+text-field-view+ ;constant (Franz User's Guide)
#:+transparent-ink+ ;constant
#:+white+ ;constant
#:+yellow+ ;constant
@@ -1104,7 +1105,6 @@
#:pointer-event-x ;generic function
#:pointer-event-y ;generic function
#:pointer-exit-event ;class
- #:pointer-modifier-state ;generic function (in franz user guide)
#:pointer-motion-event ;class
#:pointer-position ;generic function
#:pointer-sheet ;generic function
@@ -1119,6 +1119,7 @@
#:port ;protocol class
#:port ;generic function
#:port-keyboard-input-focus ;generic function
+ #:port-modifier-state ;generic function (in franz user guide)
#:port-name ;generic function
#:port-pointer ;generic function (in franz user guide)
#:port-properties ;generic function
@@ -1456,6 +1457,7 @@
#:text-editor-pane ;class
#:text-field ;class
#:text-field-pane ;class
+ #:text-field-view ;class (Franz User's Guide)
#:text-size ;generic function
#:text-style ;protocol class
#:text-style-ascent ;generic function
Index: mcclim/pointer-tracking.lisp
diff -u mcclim/pointer-tracking.lisp:1.15 mcclim/pointer-tracking.lisp:1.16
--- mcclim/pointer-tracking.lisp:1.15 Fri Nov 12 07:39:44 2004
+++ mcclim/pointer-tracking.lisp Tue Jan 11 14:35:18 2005
@@ -173,64 +173,126 @@
;;; multiple-window is completely unsupported.
;;; window-repaint events while dragging.
+(defun bound-rectangles (r1-x1 r1-y1 r1-x2 r1-y2 r2-x1 r2-y1 r2-x2 r2-y2)
+ (values (min r1-x1 r2-x1) (min r1-y1 r2-y1)
+ (max r1-x2 r2-x2) (max r1-y2 r2-y2)))
+
+
(defgeneric drag-output-record
(stream output
&key repaint erase feedback finish-on-release multiple-window))
+;;; Fancy double-buffered feedback function
+(defun make-buffered-feedback-function (record finish-on-release erase-final)
+ (multiple-value-bind (record-x record-y)
+ (output-record-position record)
+ (lambda (record stream initial-x initial-y x y event)
+ (flet ((simple-erase ()
+ (when erase-final
+ (when (output-record-parent record)
+ (delete-output-record record (output-record-parent record)))
+ (with-double-buffering
+ ((stream record) (buffer-rectangle))
+ (stream-replay stream buffer-rectangle)))))
+ (let ((dx (- record-x initial-x))
+ (dy (- record-y initial-y)))
+ (typecase event
+ (null
+ (setf (output-record-position record) (values (+ dx x) (+ dy y)))
+ (stream-add-output-record stream record)
+ (stream-replay stream record))
+ (pointer-motion-event
+ ;; Don't do an explicit erase. Instead, update the position of the
+ ;; output record and redraw the union of the old and new
+ ;; positions.
+ (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2)
+ record
+ (when (output-record-parent record)
+ (delete-output-record record (output-record-parent record)))
+ (setf (output-record-position record)
+ (values (+ dx x) (+ dy y)))
+ (stream-add-output-record stream record)
+ (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2)
+ record
+ (multiple-value-bind (area-x1 area-y1 area-x2 area-y2)
+ (bound-rectangles old-x1 old-y1 old-x2 old-y2
+ new-x1 new-y1 new-x2 new-y2)
+ (with-double-buffering
+ ((stream area-x1 area-y1 area-x2 area-y2)
+ (buffer-rectangle))
+ (stream-replay stream buffer-rectangle))))))
+ (pointer-button-press-event
+ (unless finish-on-release
+ (simple-erase)))
+ (pointer-button-release-event
+ (when finish-on-release
+ (simple-erase)))
+ (t nil)))))))
+
+;;; If the user supplies a feedback function, create a function to
+;;; call it with the simple :draw / :erase arguments.
+
+(defun make-simple-feedback-function
+ (record feedback finish-on-release erase-final)
+ (declare (ignore record))
+ (lambda (record stream initial-x initial-y x y event)
+ (typecase event
+ (null
+ (funcall feedback record stream initial-x initial-y x y :draw))
+ (pointer-motion-event
+ (funcall feedback record stream initial-x initial-y x y :erase)
+ (funcall feedback record stream initial-x initial-y x y :draw))
+ (pointer-button-press-event
+ (unless finish-on-release
+ (when erase-final
+ (funcall feedback record stream initial-x initial-y x y :erase))))
+ (pointer-button-release-event
+ (when (and finish-on-release erase-final)
+ (funcall feedback record stream initial-x initial-y x y :erase)))
+ (t nil))))
+
+
(defmethod drag-output-record
((stream output-recording-stream) (record output-record)
&key (repaint t) (erase #'erase-output-record)
feedback finish-on-release multiple-window
- feedback-event)
- (declare (ignore repaint multiple-window))
- (multiple-value-bind (dx dy)
- (output-record-position record)
- (flet ((feedback-fn (record stream initial-x initial-y x y action)
- (declare (ignore initial-x initial-y))
- (if (eq action :erase)
- (funcall erase record stream)
- (progn
- (setf (output-record-position record)
- (values (+ dx x) (+ dy y)))
- (stream-add-output-record stream record)
- (stream-replay stream record))))
- (feedback-event-fn (record stream initial-x initial-y x y
- action event)
- (declare (ignore event))
- (when (or (eq action :draw) (eq action :erase))
- (funcall feedback record stream initial-x initial-y x y
- action))))
- (declare (dynamic-extent #'feedback-fn #'feedback-event-fn))
- (unless feedback
- (setq feedback #'feedback-fn))
- (unless feedback-event
- (setq feedback-event #'feedback-event-fn))
- (setf (stream-current-output-record stream)
- (stream-output-history stream))
- (let* ((pointer (port-pointer (port stream)))
- (pointer-state (pointer-button-state pointer)))
- (multiple-value-bind (x0 y0)
- (stream-pointer-position stream)
- (funcall feedback-event record stream x0 y0 x0 y0 :draw nil)
- (tracking-pointer (stream)
- (:pointer-motion (&key event x y)
- ;; XXX What about the sheet?
- (funcall feedback-event record stream x0 y0 x y :erase event)
- (funcall feedback-event record stream x0 y0 x y :draw event))
- (:pointer-button-press (&key event x y)
- (funcall feedback-event record stream x0 y0 x y
- :button-press event)
- (unless finish-on-release
- (return-from drag-output-record (values x y))))
- (:pointer-button-release (&key event x y)
- ;; If the button released was one of those held down on entry to
- ;; drag-output-record, we're done.
- (when (and finish-on-release
- (not (zerop (logand pointer-state
- (pointer-event-button event)))))
- (funcall feedback-event record stream x0 y0 x y
- :button-release event)
- (return-from drag-output-record (values x y))))))))))
+ feedback-event erase-final)
+ (declare (ignore erase repaint multiple-window))
+ (let ((feedback-event-fn
+ (cond (feedback-event
+ feedback-event)
+ (feedback
+ (make-simple-feedback-function record
+ feedback
+ finish-on-release
+ erase-final))
+ (t (make-buffered-feedback-function record
+ finish-on-release
+ erase-final)))))
+ (setf (stream-current-output-record stream)
+ (stream-output-history stream))
+ (let* ((pointer (port-pointer (port stream)))
+ (pointer-state (pointer-button-state pointer)))
+ (multiple-value-bind (x0 y0)
+ (stream-pointer-position stream)
+ (funcall feedback-event-fn record stream x0 y0 x0 y0 nil)
+ (tracking-pointer (stream)
+ (:pointer-motion (&key event x y)
+ ;; XXX What about the sheet?
+ (funcall feedback-event-fn record stream x0 y0 x y event)
+ (funcall feedback-event-fn record stream x0 y0 x y event))
+ (:pointer-button-press (&key event x y)
+ (unless finish-on-release
+ (funcall feedback-event-fn record stream x0 y0 x y event)
+ (return-from drag-output-record (values x y))))
+ (:pointer-button-release (&key event x y)
+ ;; If the button released was one of those held down on entry to
+ ;; drag-output-record, we're done.
+ (when (and finish-on-release
+ (not (zerop (logand pointer-state
+ (pointer-event-button event)))))
+ (funcall feedback-event-fn record stream x0 y0 x y event)
+ (return-from drag-output-record (values x y)))))))))
(defmacro dragging-output ((&optional (stream '*standard-output*) &rest args
&key repaint finish-on-release multiple-window)
@@ -240,7 +302,6 @@
(with-gensyms (record)
`(let ((,record (with-output-to-output-record (,stream)
, at body)))
- (multiple-value-prog1
- (drag-output-record ,stream ,record , at args)
- (erase-output-record ,record ,stream)))))
+ (drag-output-record ,stream ,record :erase-final t , at args))))
+
Index: mcclim/sheets.lisp
diff -u mcclim/sheets.lisp:1.47 mcclim/sheets.lisp:1.48
--- mcclim/sheets.lisp:1.47 Sun Dec 5 20:37:52 2004
+++ mcclim/sheets.lisp Tue Jan 11 14:35:18 2005
@@ -413,11 +413,15 @@
(defmethod sheet-native-region ((sheet basic-sheet))
(with-slots (native-region) sheet
(unless native-region
- (setf native-region (region-intersection
- (transform-region
- (sheet-native-transformation sheet)
- (sheet-region sheet))
- (sheet-native-region (sheet-parent sheet)))))
+ (let ((this-native-region (transform-region
+ (sheet-native-transformation sheet)
+ (sheet-region sheet)))
+ (parent (sheet-parent sheet)))
+ (setf native-region (if parent
+ (region-intersection this-native-region
+ (sheet-native-region
+ parent))
+ this-native-region))))
native-region))
(defmethod sheet-device-transformation ((sheet basic-sheet))
@@ -706,15 +710,17 @@
(defmethod sheet-native-region ((sheet mirrored-sheet-mixin))
(with-slots (native-region) sheet
(unless native-region
- (setf native-region
- (region-intersection
- (transform-region
- (sheet-native-transformation sheet)
- (sheet-region sheet))
- (transform-region
- (invert-transformation
- (%sheet-mirror-transformation sheet))
- (sheet-native-region (sheet-parent sheet))))))
+ (let ((this-region (transform-region (sheet-native-transformation sheet)
+ (sheet-region sheet)))
+ (parent (sheet-parent sheet)))
+ (setf native-region
+ (if parent
+ (region-intersection this-region
+ (transform-region
+ (invert-transformation
+ (%sheet-mirror-transformation sheet))
+ (sheet-native-region parent)))
+ this-region))))
native-region))
(defmethod (setf sheet-enabled-p) :after (new-value (sheet mirrored-sheet-mixin))
More information about the Mcclim-cvs
mailing list