[mcclim-cvs] CVS mcclim
thenriksen
thenriksen at common-lisp.net
Thu Dec 21 10:36:40 UTC 2006
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv23679
Modified Files:
pointer-tracking.lisp package.lisp NEWS
Log Message:
Implemented `pointer-place-rubber-band-line*',
`pointer-input-rectangle*' and `pointer-input-rectangle' (CLIM 2.2).
--- /project/mcclim/cvsroot/mcclim/pointer-tracking.lisp 2006/03/10 21:58:13 1.17
+++ /project/mcclim/cvsroot/mcclim/pointer-tracking.lisp 2006/12/21 10:36:40 1.18
@@ -295,7 +295,7 @@
(return-from drag-output-record (values x y)))))))))
(defmacro dragging-output ((&optional (stream '*standard-output*) &rest args
- &key repaint finish-on-release multiple-window)
+ &key (repaint t) finish-on-release multiple-window)
&body body)
(declare (ignore repaint finish-on-release multiple-window))
(setq stream (stream-designator-symbol stream '*standard-output*))
@@ -304,4 +304,156 @@
, at body)))
(drag-output-record ,stream ,record :erase-final t , at args))))
+(defun dragging-drawing (stream drawer &key (finish-on-release t)
+ (pointer (port-pointer (port stream)))
+ multiple-window)
+ "Draws something simple in response to pointer events for
+`pointer' and returns the coordinates of the pointer when the
+function finishes. The function finishes when mouse button one is
+no longer held down if `finish-on-release' is true; if it is
+false, it finishes when the mouse is clicked. `Drawer' should
+draw something on `stream', and is called with tree arguments:
+two integers, the X and the Y coordinates for the pointer motion
+triggering the draw, and either the symbol `:draw' or `:erase'
+signalling what the function should do. `Drawer' will be called
+with the previously used coordinates whenever pointer motion
+occurs, so it can erase the previous output (elegantly done by
+using `+flipping-ink+' for drawing and ignoring the state
+symbol)."
+ (with-output-recording-options (stream :draw t :record nil)
+ (let ((ox nil) (oy nil)) ; So we can erase the old line.
+ (labels ((draw (x y)
+ (funcall drawer x y :draw))
+ (erase (x y)
+ (funcall drawer x y :erase))
+ (motion (x y)
+ (when ox (erase ox oy))
+ (draw x y)
+ (setf ox x oy y))
+ (end (event x y)
+ (when (eql (event-sheet event) stream)
+ (when ox (draw ox oy))
+ (return-from dragging-drawing
+ (values x y)))))
+ ;; Make an initial draw. We need to convert the screen
+ ;; coordinates from the pointer into sheet-local coordinates.
+ (multiple-value-call #'transform-position
+ (sheet-native-transformation stream) (pointer-position pointer))
+ (tracking-pointer (stream :pointer pointer
+ :multiple-window multiple-window)
+ (:pointer-motion (window x y)
+ (when (eql window stream)
+ (motion x y)))
+ (:pointer-button-press (event x y)
+ (end event x y))
+ (:pointer-button-release (event x y)
+ (when finish-on-release
+ (end event x y))))))))
+(defun pointer-place-rubber-band-line* (&key (stream *standard-output*)
+ (pointer (port-pointer (port stream)))
+ multiple-window start-x start-y
+ (finish-on-release t))
+ "Let the user drag a line on `stream', returning the
+coordinates of the line ends as four values. `Pointer' is the
+pointer that will be tracked (the default should be used unless
+the port has multiple pointing devices), `multiple-window' is
+currently unimplemented and `start-x'/`start-y', if provided (and
+both or none must be provided) are the coordinates for one end of
+the line. If these arguments are not provided, the user will have
+to press a mouse button to specify the beginning of the line. If
+`finish-on-release' is true, the function will end when the user
+releases the mouse button. If false, the user will have to click
+to finish inputting the line."
+ (assert (not (eq (not (not start-x)) (not start-y))) nil
+ "You must provide either both `:start-x' and `:start-y'
+or none at all")
+ (or start-x
+ (block nil
+ (tracking-pointer (stream :pointer pointer
+ :multiple-window multiple-window)
+ (:pointer-button-press (event x y)
+ (declare (ignore event))
+ (setf start-x x)
+ (setf start-y y)
+ (return)))))
+ (assert (and (>= start-x 0) (>= start-y 0)))
+ (labels ((draw (x y state)
+ (declare (ignore state))
+ (with-drawing-options (stream :ink +flipping-ink+)
+ (draw-line* stream start-x start-y x y))))
+ (multiple-value-call #'values
+ (values start-x start-y)
+ (dragging-drawing stream #'draw :finish-on-release finish-on-release
+ :pointer pointer :multiple-window multiple-window))))
+
+;; The CLIM 2.2 spec is slightly unclear about how the next two
+;; functions are supposed to behave, especially wrt. the user
+;; experience. I think these functions are supposed to present a
+;; rectangle on screen and let the user drag around the edges - this
+;; would make supporting both left/top and right/bottom make sense,
+;; and provide a way for the :rectangle argument to
+;; `pointer-input-rectangle' to make sense. However, this would be a
+;; very weird user experience, so I (Troels) have instead chosen to
+;; consider left/top and right/bottom to be the same thing, preferring
+;; left/top if both are specified. The :rectangle argument to
+;; `pointer-input-rectangle' is ignored. The user is meant to drag out
+;; a rectangle with the mouse, possibly by first providing a starting
+;; point. This is intuitive behavior and I see no point in supporting
+;; something more complicated. These changes should be invisible to
+;; the calling program.
+
+(defun pointer-input-rectangle* (&key (stream *standard-output*)
+ (pointer (port-pointer (port stream)))
+ multiple-window left top right bottom
+ (finish-on-release t))
+ "Let the user drag a rectangle on `stream' and return four
+values, the coordinates of the rectangle. `Pointer' is the
+pointer that will be tracked (the default should be used unless
+the port has multiple pointing devices), `multiple-window' is
+currently unimplemented and both `left'/`top' and
+`right'/`bottom' specify an initial position for a rectangle
+corner. You must provide either both parts of any of these two
+coordinate pairs or none at all. If you provide both `left'/`top'
+and `right'/`bottom', the `left'/`top' values will be used,
+otherwise, the non-nil set will be used. If neither is specified,
+the user will be able to specify the origin corner of the
+rectangle by clicking the mouse. If `finish-on-release' is true,
+the function will end when the user releases the mouse button. If
+false, the user will have to click to finish inputting the
+rectangle."
+ (assert (not (eq (not (not top)) (not left))) nil
+ "You must provide either none or both of `:top' and `:left'")
+ (assert (not (eq (not (not right)) (not bottom))) nil
+ "You must provide either none or both of `:right' and `:bottom'")
+ (setf top (or top bottom)
+ left (or left right))
+ (unless top
+ (block nil
+ (tracking-pointer (stream :pointer pointer
+ :multiple-window multiple-window)
+ (:pointer-button-press (event x y)
+ (declare (ignore event))
+ (setf left x)
+ (setf top y)
+ (return)))))
+ (multiple-value-bind (x y)
+ (labels ((draw (x y state)
+ (declare (ignore state))
+ (with-drawing-options (stream :ink +flipping-ink+)
+ (draw-rectangle* stream left top x y :filled nil))))
+ (dragging-drawing stream #'draw :finish-on-release finish-on-release
+ :pointer pointer :multiple-window multiple-window))
+ ;; Normalise so that x1 < x2 ^ y1 < y2.
+ (values (min left x) (min top y)
+ (max left x) (max top y))))
+
+(defun pointer-input-rectangle (&rest args &key (stream *standard-output*)
+ (pointer (port-pointer (port stream)))
+ multiple-window rectangle
+ (finish-on-release t))
+ "Like `pointer-input-rectangle*', but returns a bounding
+rectangle instead of coordinates."
+ (declare (ignore pointer multiple-window rectangle finish-on-release))
+ (with-keywords-removed (args (:rectangle))
+ (apply #'make-bounding-rectangle (apply #'pointer-input-rectangle args))))
--- /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/10 23:35:12 1.56
+++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/21 10:36:40 1.57
@@ -1110,7 +1110,10 @@
#:pointer-event-x ;generic function
#:pointer-event-y ;generic function
#:pointer-exit-event ;class
+ #:pointer-input-rectangle ;function (in franz user guide)
+ #:pointer-input-rectangle* ;function (in franz user guide)
#:pointer-motion-event ;class
+ #:pointer-place-rubber-band-line* ;function (in franz user guide)
#:pointer-position ;generic function
#:pointer-sheet ;generic function
#:pointerp ;predicate
--- /project/mcclim/cvsroot/mcclim/NEWS 2006/12/20 20:07:10 1.14
+++ /project/mcclim/cvsroot/mcclim/NEWS 2006/12/21 10:36:40 1.15
@@ -18,6 +18,12 @@
implemented.
** specification compliance: DISPLAY-COMMAND-MENU function now
implemented.
+** specification compliance: POINTER-PLACE-RUBBER-BAND-LINE* function
+ now implemented.
+** specification compliance: POINTER-INPUT-RECTANGLE* function now
+ implemented.
+** specification compliance: POINTER-INPUT-RECTANGLE function now
+ implemented.
* Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2:
** backend improvement: The Null backend now registers itself in the
More information about the Mcclim-cvs
mailing list