[mcclim-cvs] CVS update: mcclim/gadgets.lisp
Gilbert Baumann
gbaumann at common-lisp.net
Mon Nov 28 17:00:34 UTC 2005
Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv10998
Modified Files:
gadgets.lisp
Log Message:
SCROLL-BAR-PANE
Complete overhaul:
- The blitter hack now works, because we round coordinates to
integers, COPY-AREA was fixed for case we work under a
transformation and finally because we get :graphcis-exposure
events.
- We use poor man's incremental redisplay for updating the scroll
bar display. So now, when changing the value of a scroll bar
without actually changing it, we don't have a flickering display
anymore.
- The thumb bed is drawn in *3D-INNER-COLOR*, which is slightly
darker than the background of the thumb itself. This leads to
more clearly visible thumb.
- The thumb won't get smaller than +MINIMUM-THUMB-SIZE-IN-PIXELS+,
so a really large stream pane, won't cause such an usability
problem anymore.
Date: Mon Nov 28 18:00:33 2005
Author: gbaumann
Index: mcclim/gadgets.lisp
diff -u mcclim/gadgets.lisp:1.91 mcclim/gadgets.lisp:1.92
--- mcclim/gadgets.lisp:1.91 Wed Oct 12 16:22:27 2005
+++ mcclim/gadgets.lisp Mon Nov 28 18:00:32 2005
@@ -1286,17 +1286,25 @@
;;; ------------------------------------------------------------------------------------------
;;; 30.4.4 The concrete scroll-bar Gadget
-(defclass scroll-bar-pane (sheet-multiple-child-mixin
- 3D-border-mixin
- scroll-bar
- )
+(defclass scroll-bar-pane (3D-border-mixin
+ scroll-bar)
((event-state :initform nil)
(drag-dy :initform nil)
- (inhibit-redraw-p
- :initform nil
- :documentation "Hack, when set to non-NIL changing something does not trigger redrawing.")
- (thumb :initform nil)
- )
+ ;;; poor man's incremental redisplay
+ ;; drawn state
+ (up-state :initform nil)
+ (dn-state :initform nil)
+ (tb-state :initform nil)
+ (tb-y1 :initform nil)
+ (tb-y2 :initform nil)
+ ;; old drawn state
+ (old-up-state :initform nil)
+ (old-dn-state :initform nil)
+ (old-tb-state :initform nil)
+ (old-tb-y1 :initform nil)
+ (old-tb-y2 :initform nil)
+ ;;
+ (all-new-p :initform t) )
(:default-initargs :value 0
:min-value 0
:max-value 1
@@ -1317,95 +1325,115 @@
:min-width (* 3 *scrollbar-thickness*)
:width (* 4 *scrollbar-thickness*))))
-;;; The thumb of a scroll bar
+;;;; Redisplay
-;; work in progress --GB
+(defun scroll-bar/update-display (scroll-bar)
+ (with-slots (up-state dn-state tb-state tb-y1 tb-y2
+ old-up-state old-dn-state old-tb-state old-tb-y1 old-tb-y2
+ all-new-p)
+ scroll-bar
+ ;;
+ (scroll-bar/compute-display scroll-bar)
+ ;; redraw up arrow
+ (unless (and (not all-new-p) (eql up-state old-up-state))
+ (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar))
+ (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-up-region scroll-bar)
+ (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-inner-color*)
+ (let ((pg (list (make-point (/ (+ x1 x2) 2) y1)
+ (make-point x1 y2)
+ (make-point x2 y2))))
+ (case up-state
+ (:armed
+ (draw-polygon scroll-bar pg :ink *3d-inner-color*)
+ (draw-bordered-polygon scroll-bar pg :style :inset :border-width 2))
+ (otherwise
+ (draw-polygon scroll-bar pg :ink *3d-normal-color*)
+ (draw-bordered-polygon scroll-bar pg :style :outset :border-width 2) ))))) )
+ ;; redraw dn arrow
+ (unless (and (not all-new-p) (eql dn-state old-dn-state))
+ (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar))
+ (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-down-region scroll-bar)
+ (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-inner-color*)
+ (let ((pg (list (make-point (/ (+ x1 x2) 2) y2)
+ (make-point x1 y1)
+ (make-point x2 y1))))
+ (case dn-state
+ (:armed
+ (draw-polygon scroll-bar pg :ink *3d-inner-color*)
+ (draw-bordered-polygon scroll-bar pg :style :inset :border-width 2))
+ (otherwise
+ (draw-polygon scroll-bar pg :ink *3d-normal-color*)
+ (draw-bordered-polygon scroll-bar pg :style :outset :border-width 2)))))))
+ ;; thumb
+ (unless (and (not all-new-p)
+ (and (eql tb-state old-tb-state)
+ (eql tb-y1 old-tb-y1)
+ (eql tb-y2 old-tb-y2)))
+ (cond ((and (not all-new-p)
+ (eql tb-state old-tb-state)
+ (numberp tb-y1) (numberp old-tb-y1)
+ (numberp tb-y2) (numberp old-tb-y2)
+ (= (- tb-y2 tb-y1) (- old-tb-y2 old-tb-y1)))
+ ;; Thumb is just moving, compute old and new region
+ (multiple-value-bind (x1 ignore.1 x2 ignore.2)
+ (bounding-rectangle* (scroll-bar-thumb-bed-region scroll-bar))
+ (declare (ignore ignore.1 ignore.2))
+ ;; compute new and old region
+ (with-sheet-medium (medium scroll-bar)
+ (with-drawing-options (medium :transformation (scroll-bar-transformation scroll-bar))
+ (multiple-value-bind (ox1 oy1 ox2 oy2) (values x1 old-tb-y1 x2 old-tb-y2)
+ (multiple-value-bind (nx1 ny1 nx2 ny2) (values x1 tb-y1 x2 tb-y2)
+ (declare (ignore nx2))
+ (copy-area medium ox1 oy1 (- ox2 ox1) (- oy2 oy1) nx1 ny1)
+ ;; clear left-overs from the old region
+ (if (< oy1 ny1)
+ (draw-rectangle* medium ox1 oy1 ox2 ny1 :ink *3d-inner-color*)
+ (draw-rectangle* medium ox1 oy2 ox2 ny2 :ink *3d-inner-color*)))) ))))
+ (t
+ ;; redraw whole thumb bed and thumb all anew
+ (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar))
+ (with-bounding-rectangle* (bx1 by1 bx2 by2) (scroll-bar-thumb-bed-region scroll-bar)
+ (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-region scroll-bar)
+ (draw-rectangle* scroll-bar bx1 by1 bx2 y1 :ink *3d-inner-color*)
+ (draw-rectangle* scroll-bar bx1 y2 bx2 by2 :ink *3d-inner-color*)
+ (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-normal-color*)
+ (draw-bordered-polygon scroll-bar
+ (polygon-points (make-rectangle* x1 y1 x2 y2))
+ :style :outset
+ :border-width 2)
+ ;;;;;;
+ (let ((y (/ (+ y1 y2) 2)))
+ (draw-bordered-polygon scroll-bar
+ (polygon-points (make-rectangle* (+ x1 3) (- y 1) (- x2 3) (+ y 1)))
+ :style :inset
+ :border-width 1)
+ (draw-bordered-polygon scroll-bar
+ (polygon-points (make-rectangle* (+ x1 3) (- y 4) (- x2 3) (- y 2)))
+ :style :inset
+ :border-width 1)
+ (draw-bordered-polygon scroll-bar
+ (polygon-points (make-rectangle* (+ x1 3) (+ y 4) (- x2 3) (+ y 2)))
+ :style :inset
+ :border-width 1))))))))
+ (setf old-up-state up-state
+ old-dn-state dn-state
+ old-tb-state tb-state
+ old-tb-y1 tb-y1
+ old-tb-y2 tb-y2
+ all-new-p nil) ))
+
+(defun scroll-bar/compute-display (scroll-bar)
+ (with-slots (up-state dn-state tb-state tb-y1 tb-y2
+ event-state) scroll-bar
+ (setf up-state (if (eq event-state :up-armed) :armed nil))
+ (setf dn-state (if (eq event-state :dn-armed) :armed nil))
+ (setf tb-state nil) ;we have no armed display yet
+ (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-region scroll-bar)
+ (declare (ignore x1 x2))
+ (setf tb-y1 y1
+ tb-y2 y2))))
-#||
-(defclass scroll-bar-thumb-pane (arm/disarm-repaint-mixin
- basic-gadget)
- ((tr :initform nil)
- (allowed-region :initarg :allowed-region))
- (:default-initargs
- :background *3d-normal-color*))
-
-(defmethod handle-event ((pane scroll-bar-thumb-pane) (event pointer-enter-event))
- (declare (ignoreable event))
- (with-slots (armed) pane
- (arm-gadget pane (adjoin :have-mouse armed))))
-
-(defmethod handle-event ((pane scroll-bar-thumb-pane) (event pointer-exit-event))
- (declare (ignoreable event))
- (with-slots (armed) pane
- (arm-gadget pane (remove :have-mouse armed))))
-
-(defmethod handle-event ((pane scroll-bar-thumb-pane) (event pointer-button-press-event))
- (with-slots (tr armed) pane
- (arm-gadget pane (adjoin :dragging armed))
- (setf tr (compose-transformations
- (make-scaling-transformation 1 1)
- (compose-transformations
- (compose-transformations
- (make-translation-transformation (- (pointer-event-x event)) (- (pointer-event-y event)))
- (invert-transformation (sheet-delta-transformation (sheet-parent pane) (graft pane))))
- (invert-transformation (sheet-native-transformation (graft pane)))))) ))
-
-(defmethod handle-event ((pane scroll-bar-thumb-pane) (event pointer-button-release-event))
- (with-slots (tr armed) pane
- (arm-gadget pane (remove :dragging armed))
- (setf tr nil)) )
-
-(defmethod handle-event ((pane scroll-bar-thumb-pane) (event pointer-motion-event))
- (with-slots (tr allowed-region) pane
- (when tr
- (multiple-value-bind (nx ny) (transform-position tr
- (pointer-event-native-graft-x event)
- (pointer-event-native-graft-y event))
- (with-bounding-rectangle* (x1 y1 x2 y2) allowed-region
- (move-sheet pane
- (clamp nx x1 x2)
- (clamp ny y1 y2)))))))
-
-(defmethod handle-repaint ((pane scroll-bar-thumb-pane) region)
- (with-bounding-rectangle* (x1 y1 x2 y2) pane
- (draw-rectangle* pane x1 y1 x2 y2 :ink (effective-gadget-background pane))
- (draw-bordered-polygon pane
- (polygon-points (make-rectangle* x1 y1 x2 y2))
- :style :outset
- :border-width 2)
- (let ((y (/ (+ y1 y2) 2)))
- (draw-bordered-polygon pane
- (polygon-points (make-rectangle* (+ x1 3) (- y 1) (- x2 3) (+ y 1)))
- :style :inset
- :border-width 1)
- (draw-bordered-polygon pane
- (polygon-points (make-rectangle* (+ x1 3) (- y 4) (- x2 3) (- y 2)))
- :style :inset
- :border-width 1)
- (draw-bordered-polygon pane
- (polygon-points (make-rectangle* (+ x1 3) (+ y 4) (- x2 3) (+ y 2)))
- :style :inset
- :border-width 1))))
-
-;;;
-
-(defmethod sheet-adopt-child :after (sheet (scroll-bar scroll-bar-pane))
- ;; create a sheet for the thumb
- '(with-slots (thumb) scroll-bar
- (setf thumb (make-pane 'scroll-bar-thumb-pane
- :allowed-region (make-rectangle* 2 15 14 340)
- ))
- (setf (sheet-region thumb)
- (make-rectangle* 0 0 12 50))
- (setf (sheet-transformation thumb)
- (compose-transformations
- (make-transformation 1 0 0 1 0 0)
- (make-translation-transformation 2 0)))
- (sheet-adopt-child scroll-bar thumb)))
-
-||#
-
-;;; Utilities
+;;;; Utilities
;; We think all scroll bars as vertically oriented, therefore we have
;; SCROLL-BAR-TRANSFORMATION, which should make every scroll bar
@@ -1419,26 +1447,31 @@
(defun translate-range-value (a mina maxa mino maxo)
"When \arg{a} is some value in the range from \arg{mina} to \arg{maxa},
proportionally translate the value into the range \arg{mino} to \arg{maxo}."
- (+ mino (* (/ (- a mina) (- maxa mina)) (- maxo mino))))
+ (+ mino (* (/ (- a mina)
+ (- maxa mina)) ;### avoid divide by zero here.
+ (- maxo mino))))
+
+;;;; SETF :after methods
-;;; Scroll-bar's sub-regions
+(defmethod (setf gadget-min-value) :after (new-value (pane scroll-bar-pane))
+ (declare (ignore new-value))
+ (scroll-bar/update-display pane))
+
+(defmethod (setf gadget-max-value) :after (new-value (pane scroll-bar-pane))
+ (declare (ignore new-value))
+ (scroll-bar/update-display pane))
-(defmethod (setf scroll-bar-thumb-size) :after (new-value (sb scroll-bar-pane))
+(defmethod (setf scroll-bar-thumb-size) :after (new-value (pane scroll-bar-pane))
(declare (ignore new-value))
- (with-slots (inhibit-redraw-p thumb) sb
- #||
- ;;work in progress
- (setf (sheet-region thumb)
- (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb)
- (multiple-value-bind (minv maxv) (gadget-range* sb)
- (multiple-value-bind (v) (gadget-value sb)
- (let ((ts (scroll-bar-thumb-size sb)))
- (let ((ya (translate-range-value v minv (+ maxv ts) y1 y2))
- (yb (translate-range-value (+ v ts) minv (+ maxv ts) y1 y2)))
- (make-rectangle* 0 0 (- x2 x1) (- yb ya))))))))
- ||#
- (unless inhibit-redraw-p
- (dispatch-repaint sb +everywhere+)))) ;arg...
+ (scroll-bar/update-display pane))
+
+(defmethod (setf gadget-value) :after (new-value (pane scroll-bar-pane) &key invoke-callback)
+ (declare (ignore new-value invoke-callback))
+ (scroll-bar/update-display pane))
+
+;;;; geometry
+
+(defparameter +minimum-thumb-size-in-pixels+ 30)
(defmethod scroll-bar-up-region ((sb scroll-bar-pane))
(with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
@@ -1454,70 +1487,57 @@
(make-rectangle* minx (- maxy (- maxx minx))
maxx maxy)))
-(defmethod scroll-bar-thumb-bed-region ((sb scroll-bar-pane))
+(defun scroll-bar/thumb-bed* (sb)
+ ;; -> y1 y2 y3
(with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
(pane-inner-region sb))
- (make-rectangle* minx (+ miny (- maxx minx) 1)
- maxx (- maxy (- maxx minx) 1))))
-
-(defmethod scroll-bar-thumb-region ((sb scroll-bar-pane))
- (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb)
- (multiple-value-bind (minv maxv) (gadget-range* sb)
- (multiple-value-bind (v) (gadget-value sb)
- (let ((ts (scroll-bar-thumb-size sb)))
- (let ((ya (translate-range-value v minv (+ maxv ts) y1 y2))
- (yb (translate-range-value (+ v ts) minv (+ maxv ts) y1 y2)))
- (make-rectangle* x1 ya x2 yb)))))))
-
-#||
-;; alternative:
-
-(defmethod scroll-bar-up-region ((sb scroll-bar-pane))
- (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
- (sheet-region sb))
- (make-rectangle* (+ minx 2) (- (- maxy (* 2 (- maxx minx))) 2)
- (- maxx 2) (- (- maxy (- maxx minx)) 2))))
-
-(defmethod scroll-bar-down-region ((sb scroll-bar-pane))
- (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
- (sheet-region sb))
- (make-rectangle* (+ minx 2) (+ (- maxy (- maxx minx)) 2)
- (- maxx 2) (- maxy 2))))
+ (let ((y1 (+ miny (- maxx minx) 1))
+ (y3 (- maxy (- maxx minx) 1)))
+ (let ((ts (scroll-bar-thumb-size sb)))
+ ;; This is the right spot to handle ts = :none or perhaps NIL
+ (multiple-value-bind (range) (gadget-range sb)
+ (let ((ts-in-pixels (round (* (- y3 y1) (/ ts (+ range ts)))))) ;### range + ts = 0?
+ (setf ts-in-pixels (min (- y3 y1) ;thumb can't be larger than the thumb bed
+ (max +minimum-thumb-size-in-pixels+ ;but shouldn't be smaller than this.
+ ts-in-pixels)))
+ (values
+ y1
+ (- y3 ts-in-pixels)
+ y3)))))))
(defmethod scroll-bar-thumb-bed-region ((sb scroll-bar-pane))
(with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
- (sheet-region sb))
- (make-rectangle* (+ minx 2) (+ miny 2 )
- (- maxx 2) (- maxy 2 (* 2 (- maxx minx)) 2))))
+ (pane-inner-region sb))
+ (declare (ignore miny maxy))
+ (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
+ (declare (ignore y2))
+ (make-rectangle* minx y1
+ maxx y3))))
+
+(defun scroll-bar/map-coordinate-to-value (sb y)
+ (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
+ (declare (ignore y3))
+ (multiple-value-bind (minv maxv) (gadget-range* sb)
+ (if (= y1 y2) ;### fix this in translate-range-value
+ minv
+ (translate-range-value y y1 y2 minv maxv)))))
+
+(defun scroll-bar/map-value-to-coordinate (sb v)
+ (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
+ (declare (ignore y3))
+ (multiple-value-bind (minv maxv) (gadget-range* sb)
+ ;; oops, if the range is empty we lose!
+ (if (= minv maxv) ;### fix this in translate-range-value
+ y1
+ (round (translate-range-value v minv maxv y1 y2))))))
(defmethod scroll-bar-thumb-region ((sb scroll-bar-pane))
(with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb)
- (multiple-value-bind (minv maxv) (gadget-range* sb)
- (multiple-value-bind (v) (gadget-value sb)
- (let ((ts (scroll-bar-thumb-size sb)))
- (let ((ya (translate-range-value v minv (+ maxv ts) y1 y2))
- (yb (translate-range-value (+ v ts) minv (+ maxv ts) y1 y2)))
- (make-rectangle* x1 ya x2 yb)))))))
-||#
-
-
-;;; Event handlers
-
-#||
-(defmethod handle-event ((sb scroll-bar-pane) (event pointer-enter-event))
- (declare (ignorable event))
- (with-slots (armed) sb
- (unless armed
- (setf armed t)
- (armed-callback sb (gadget-client sb) (gadget-id sb)))))
-
-(defmethod handle-event ((sb scroll-bar-pane) (event pointer-exit-event))
- (declare (ignorable event))
- (with-slots (armed) sb
- (when armed
- (setf armed nil)
- (disarmed-callback sb (gadget-client sb) (gadget-id sb)))))
-||#
+ (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
+ (let ((y4 (scroll-bar/map-value-to-coordinate sb (gadget-value sb))))
+ (make-rectangle* x1 y4 x2 (+ y4 (- y3 y2)))))))
+
+;;;; event handler
(defmethod handle-event ((sb scroll-bar-pane) (event pointer-button-press-event))
(multiple-value-bind (x y) (transform-position (scroll-bar-transformation sb)
@@ -1526,14 +1546,16 @@
(cond ((region-contains-position-p (scroll-bar-up-region sb) x y)
(scroll-up-line-callback sb (gadget-client sb) (gadget-id sb))
(setf event-state :up-armed)
- (dispatch-repaint sb +everywhere+))
+ (scroll-bar/update-display sb))
((region-contains-position-p (scroll-bar-down-region sb) x y)
(scroll-down-line-callback sb (gadget-client sb) (gadget-id sb))
(setf event-state :dn-armed)
- (dispatch-repaint sb +everywhere+))
+ (scroll-bar/update-display sb))
+ ;;
((region-contains-position-p (scroll-bar-thumb-region sb) x y)
(setf event-state :dragging
drag-dy (- y (bounding-rectangle-min-y (scroll-bar-thumb-region sb)))))
+ ;;
((region-contains-position-p (scroll-bar-thumb-bed-region sb) x y)
(if (< y (bounding-rectangle-min-y (scroll-bar-thumb-region sb)))
(scroll-up-page-callback sb (gadget-client sb) (gadget-id sb))
@@ -1541,109 +1563,36 @@
(t
nil)))))
-(defmethod handle-event ((sb scroll-bar-pane) (event pointer-button-release-event))
- (with-slots (event-state) sb
- (case event-state
- (:up-armed (setf event-state nil))
- (:dn-armed (setf event-state nil))
- (otherwise
- (setf event-state nil) )))
- (dispatch-repaint sb +everywhere+) )
-
(defmethod handle-event ((sb scroll-bar-pane) (event pointer-motion-event))
(multiple-value-bind (x y) (transform-position (scroll-bar-transformation sb)
(pointer-event-x event) (pointer-event-y event))
(declare (ignore x))
- (with-slots (event-state drag-dy inhibit-redraw-p) sb
+ (with-slots (event-state drag-dy) sb
(case event-state
(:dragging
(let* ((y-new-thumb-top (- y drag-dy))
- (ts (scroll-bar-thumb-size sb))
- (new-value (min (gadget-max-value sb)
- (max (gadget-min-value sb)
- (translate-range-value y-new-thumb-top
- (bounding-rectangle-min-y (scroll-bar-thumb-bed-region sb))
- (bounding-rectangle-max-y (scroll-bar-thumb-bed-region sb))
- (gadget-min-value sb)
- (+ (gadget-max-value sb) ts))))))
- ;; Blitter hack:
- #-nil
- (with-drawing-options (sb :transformation (scroll-bar-transformation sb))
- (with-bounding-rectangle* (ox1 oy1 ox2 oy2) (scroll-bar-thumb-region sb)
- (setf (gadget-value sb) new-value)
- (with-bounding-rectangle* (nx1 ny1 nx2 ny2) (scroll-bar-thumb-region sb)
- (declare (ignore nx2))
- (copy-area sb ox1 oy1 (- ox2 ox1) (- oy2 oy1) nx1 ny1)
- (if (< oy1 ny1)
- (draw-rectangle* sb ox1 oy1 ox2 ny1 :ink *3d-normal-color*)
- (draw-rectangle* sb ox1 oy2 ox2 ny2 :ink *3d-normal-color*)))))
- #+nil
- (dispatch-repaint sb +everywhere+)
- (unwind-protect
- (progn
- (setf inhibit-redraw-p t)
- (setf (gadget-value sb) new-value)
- (drag-callback sb (gadget-client sb) (gadget-id sb)
- new-value))
- (setf inhibit-redraw-p nil))
- ))))))
-
-;;; Repaint
-
-(defmethod handle-repaint ((sb scroll-bar-pane) region)
- (declare (ignore region))
- (with-special-choices (sb)
- (let ((tr (scroll-bar-transformation sb)))
- (with-bounding-rectangle* (minx miny maxx maxy) (transform-region tr (sheet-region sb))
- (with-drawing-options (sb :transformation tr)
- (draw-rectangle* sb minx miny maxx maxy :filled t
- :ink *3d-normal-color*)
- ;; draw up arrow
- (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-up-region sb)
- (let ((pg (list (make-point (/ (+ x1 x2) 2) y1)
- (make-point x1 y2)
- (make-point x2 y2))))
- (case (slot-value sb 'event-state)
- (:up-armed
- (draw-polygon sb pg :ink *3d-inner-color*)
- (draw-bordered-polygon sb pg :style :inset :border-width 2))
- (otherwise
- (draw-polygon sb pg :ink *3d-normal-color*)
- (draw-bordered-polygon sb pg :style :outset :border-width 2) ))))
-
- ;; draw down arrow
- (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-down-region sb)
- (let ((pg (list (make-point (/ (+ x1 x2) 2) y2)
- (make-point x1 y1)
- (make-point x2 y1))))
- (case (slot-value sb 'event-state)
- (:dn-armed
- (draw-polygon sb pg :ink *3d-inner-color*)
- (draw-bordered-polygon sb pg :style :inset :border-width 2))
- (otherwise
- (draw-polygon sb pg :ink *3d-normal-color*)
- (draw-bordered-polygon sb pg :style :outset :border-width 2)))))
- ;; draw thumb
- (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-region sb)
- (draw-rectangle* sb x1 y1 x2 y2 :ink *3d-normal-color*)
- (draw-bordered-polygon sb
- (polygon-points (make-rectangle* x1 y1 x2 y2))
- :style :outset
- :border-width 2)
- (let ((y (/ (+ y1 y2) 2)))
- (draw-bordered-polygon sb
- (polygon-points (make-rectangle* (+ x1 3) (- y 1) (- x2 3) (+ y 1)))
- :style :inset
- :border-width 1)
- (draw-bordered-polygon sb
- (polygon-points (make-rectangle* (+ x1 3) (- y 4) (- x2 3) (- y 2)))
- :style :inset
- :border-width 1)
- (draw-bordered-polygon sb
- (polygon-points (make-rectangle* (+ x1 3) (+ y 4) (- x2 3) (+ y 2)))
- :style :inset
- :border-width 1))) )))))
+ (new-value
+ (min (gadget-max-value sb)
+ (max (gadget-min-value sb)
+ (scroll-bar/map-coordinate-to-value sb y-new-thumb-top)))) )
+ ;; ### when dragging value shouldn't be immediately updated
+ (setf (gadget-value sb #|:invoke-callback nil|#)
+ new-value)
+ (drag-callback sb (gadget-client sb) (gadget-id sb) new-value)) )))))
+
+(defmethod handle-event ((sb scroll-bar-pane) (event pointer-button-release-event))
+ (with-slots (event-state) sb
+ (case event-state
+ (:up-armed (setf event-state nil))
+ (:dn-armed (setf event-state nil))
+ (otherwise
+ (setf event-state nil) )))
+ (scroll-bar/update-display sb) )
+(defmethod handle-repaint ((pane scroll-bar-pane) region)
+ (with-slots (all-new-p) pane
+ (setf all-new-p t)
+ (scroll-bar/update-display pane)))
;;; ------------------------------------------------------------------------------------------
;;; 30.4.5 The concrete slider Gadget
More information about the Mcclim-cvs
mailing list