[mcclim-cvs] CVS mcclim/Backends/beagle/native-panes
tmoore
tmoore at common-lisp.net
Thu Mar 30 12:07:59 UTC 2006
Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes
In directory clnet:/tmp/cvs-serv25437/Backends/beagle/native-panes
Modified Files:
beagle-scroll-bar-pane.lisp
Log Message:
Fix up scroll bars in Beagle. Use the high level gadget events to
signal scroll bar changes to the application. Document the unintuitive
scroll-bar-thumb-size slot in the scroll-bar gadget.
--- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2006/02/22 10:55:41 1.7
+++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2006/03/30 12:07:59 1.8
@@ -4,13 +4,7 @@
;;; Limitations:
;;;
;;; - ignores different NSControl sizes
-;;; - inherits from the 'standard' scroll-bar-pane, rather than from the abstract
-;;; scroll bar
-;;; Inheriting from 'scroll-bar' will probably work if we use the :default-initargs
-;;; hackery out of gadgets.lisp (but shouldn't these be part of the abstract type?)
-
-;;;(defclass beagle-scroll-bar-pane (scroll-bar)
(defclass beagle-scroll-bar-pane (scroll-bar)
((tk-obj :initform (%null-ptr) :accessor toolkit-object)))
@@ -83,6 +77,54 @@
:min-height width
:height width))))
+;;; Change the value of the scroll bar in the application process i.e.,
+;;; consistently with respect to events that have been received.
+
+(defmethod drag-callback :before
+ ((gadget beagle-scroll-bar-pane) client gadget-id value)
+ (declare (ignore client gadget-id))
+ (setf (slot-value gadget 'climi::value) value))
+
+(defun update-cocoa-scroll-bar (scroll-bar)
+ (let* ((range (- (gadget-max-value scroll-bar)
+ (gadget-min-value scroll-bar)))
+ (value (if (zerop range)
+ 0.0
+ (/ (- (gadget-value scroll-bar)
+ (gadget-min-value scroll-bar))
+ range)))
+ (ts (climi::scroll-bar-thumb-size scroll-bar))
+ (loz-size (if (<= range 0)
+ 1.0
+ (/ ts (+ range ts)))))
+ (send (toolkit-object scroll-bar)
+ :set-float-value (coerce (clamp value 0.0 1.0) 'short-float)
+ :knob-proportion (coerce (clamp loz-size 0.0 1.0) 'short-float))))
+
+(defmethod (setf gadget-min-value) :after
+ (new-value (pane beagle-scroll-bar-pane))
+ (declare (ignore new-value))
+ (update-cocoa-scroll-bar pane))
+
+(defmethod (setf gadget-max-value) :after (new-value (pane beagle-scroll-bar-pane))
+ (declare (ignore new-value))
+ (update-cocoa-scroll-bar pane))
+
+(defmethod (setf climi::scroll-bar-thumb-size) :after (new-value (pane beagle-scroll-bar-pane))
+ (declare (ignore new-value))
+ (update-cocoa-scroll-bar pane))
+
+(defmethod (setf gadget-value) :after (new-value (pane beagle-scroll-bar-pane) &key invoke-callback)
+ (declare (ignore new-value invoke-callback))
+ (update-cocoa-scroll-bar pane))
+
+(climi::defmethod* (setf climi::scroll-bar-values)
+ (min-value max-value thumb-size value (scroll-bar beagle-scroll-bar-pane))
+ (setf (slot-value scroll-bar 'climi::min-value) min-value
+ (slot-value scroll-bar 'climi::max-value) max-value
+ (slot-value scroll-bar 'climi::thumb-size) thumb-size
+ (slot-value scroll-bar 'climi::value) value)
+ (update-cocoa-scroll-bar scroll-bar))
;;; No need to update the scrollbar (most of the time) since Cocoa will move
;;; the 'thumb' appropriately. Stick some debug in to see when it's invoked.
@@ -91,6 +133,7 @@
;;; I believe it's safe to leave this alone though since the sb will only be
;;; redrawn once through the event loop it shouldn't be too inefficient to
;;; be changing its value regularly.
+#-(and)
(defmethod (setf gadget-value) :before (value (gadget beagle-scroll-bar-pane)
&key invoke-callback)
(declare (ignore invoke-callback))
@@ -101,12 +144,10 @@
(let* ((range (- (gadget-max-value gadget)
(gadget-min-value gadget)))
- (size (if (eq (gadget-orientation gadget) :vertical)
- (bounding-rectangle-height gadget)
- (bounding-rectangle-width gadget)))
+ (size (climi::scroll-bar-thumb-size gadget))
(position (if (<= range 0)
0.0
- (/ value range)))
+ (/ (- value (gadget-min-value gadget) range)))
(loz-size (if (<= range 0)
1.0
(/ size range))))
@@ -115,6 +156,7 @@
:knob-proportion (coerce loz-size 'short-float))))
+;;; Called in the Cocoa App thread.
(defun scroll-bar-action-handler (pane sender)
;; Now we need to decide exactly what we do with these events... not sure
@@ -132,28 +174,33 @@
(let ((hit-part (send sender 'hit-part)))
(cond ((or (eq hit-part #$NSScrollerKnob) ; drag knob
(eq hit-part #$NSScrollerKnobSlot)) ; click on knob (or alt-click on slot)
- (let ((value (* (send sender 'float-value) ; 0.0 - 1.0
+ (let ((value (+ (* (send sender 'float-value) ; 0.0 - 1.0
(- (gadget-max-value pane) ; range; 0.0 -> max extent ...
- (gadget-min-value pane))))) ; ... (probably)
- (clim:drag-callback pane
- (gadget-client pane)
- (gadget-id pane)
- value)))
+ (gadget-min-value pane)))
+ (gadget-min-value pane)))) ; ... (probably)
+ (queue-callback #'clim:drag-callback
+ pane
+ (gadget-client pane)
+ (gadget-id pane)
+ value)))
((eq hit-part #$NSScrollerDecrementLine)
- (clim:scroll-up-line-callback pane
- (gadget-client pane)
- (gadget-id pane)))
+ (queue-callback #'clim:scroll-up-line-callback
+ pane
+ (gadget-client pane)
+ (gadget-id pane)))
((eq hit-part #$NSScrollerDecrementPage)
- (clim:scroll-up-page-callback pane
- (gadget-client pane)
- (gadget-id pane)))
+ (queue-callback #'clim:scroll-up-page-callback
+ pane
+ (gadget-client pane)
+ (gadget-id pane)))
((eq hit-part #$NSScrollerIncrementLine)
- (clim:scroll-down-line-callback pane
- (gadget-client pane)
- (gadget-id pane)))
+ (queue-callback #'clim:scroll-down-line-callback
+ pane
+ (gadget-client pane)
+ (gadget-id pane)))
((eq hit-part #$NSScrollerIncrementPage)
- (clim:scroll-down-page-callback pane
- (gadget-client pane)
- (gadget-id pane))))))
-
+ (queue-callback #'clim:scroll-down-page-callback
+ pane
+ (gadget-client pane)
+ (gadget-id pane))))))
More information about the Mcclim-cvs
mailing list