[graphic-forms-cvs] r301 - in trunk/src: . tests/uitoolkit uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Oct 12 01:41:13 UTC 2006
Author: junrue
Date: Wed Oct 11 21:41:12 2006
New Revision: 301
Modified:
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
trunk/src/tests/uitoolkit/scroll-text-panel.lisp
trunk/src/tests/uitoolkit/widget-tester.lisp
trunk/src/uitoolkit/widgets/scrollbar.lisp
trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp
trunk/src/uitoolkit/widgets/slider.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
Log:
simplified concept of scrollbar/slider limits to just be a zero-based maximum position
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Wed Oct 11 21:41:12 2006
@@ -477,7 +477,7 @@
#:obtain-horizontal-scrollbar
#:obtain-primary-display
#:obtain-vertical-scrollbar
- #:outer-limits
+ #:outer-limit
#:owner
#:pack
#:page-increment
Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-grid-panel.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Wed Oct 11 21:41:12 2006
@@ -62,12 +62,10 @@
(panel (gfw::obtain-top-child window))
(panel-size (gfw:size panel))
(scrollbar (gfw:obtain-horizontal-scrollbar window)))
- (setf (gfw:outer-limits scrollbar)
- (gfs:make-span :end (gfs:size-width panel-size)))
+ (setf (gfw:outer-limit scrollbar) (gfs:size-width panel-size))
(setf (gfw:thumb-position scrollbar) 0)
(setf scrollbar (gfw:obtain-vertical-scrollbar window))
- (setf (gfw:outer-limits scrollbar)
- (gfs:make-span :end (gfs:size-height panel-size)))
+ (setf (gfw:outer-limit scrollbar) (gfs:size-height panel-size))
(setf (gfw:thumb-position scrollbar) 0)
(setf (gfw:step-increments disp) (gfs:make-size :width 1 :height 1))
(setf (slot-value disp 'gfw::viewport-origin) (gfs:make-point))
Modified: trunk/src/tests/uitoolkit/scroll-text-panel.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-text-panel.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-text-panel.lisp Wed Oct 11 21:41:12 2006
@@ -85,12 +85,10 @@
(gfw:with-graphics-context (gc panel)
(let ((metrics (gfg:metrics gc (font-of (gfw:dispatcher panel))))
(scrollbar (gfw:obtain-horizontal-scrollbar window)))
- (setf (gfw:outer-limits scrollbar)
- (gfs:make-span :end (gfs:size-width panel-size)))
+ (setf (gfw:outer-limit scrollbar) (gfs:size-width panel-size))
(setf (gfw:thumb-position scrollbar) 0)
(setf scrollbar (gfw:obtain-vertical-scrollbar window))
- (setf (gfw:outer-limits scrollbar)
- (gfs:make-span :end (gfs:size-height panel-size)))
+ (setf (gfw:outer-limit scrollbar) (gfs:size-height panel-size))
(setf (gfw:thumb-position scrollbar) 0)
(setf (gfw:step-increments disp) (gfs:make-size :width (gfg:average-char-width metrics)
:height (gfg:height metrics)))))
Modified: trunk/src/tests/uitoolkit/widget-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/widget-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/widget-tester.lisp Wed Oct 11 21:41:12 2006
@@ -231,7 +231,7 @@
(setf (gfw:text label-1) (thumb->string slider))))
(sl-1 (make-instance 'gfw:slider :parent panel-1
:callback sl-1-cb
- :outer-limits (gfs:make-span :start 0 :end 10)))
+ :outer-limit 10))
(label-3 (make-instance 'gfw:label :parent panel-1
:text "0 "))
(sb-1-cb (lambda (disp scrollbar axis detail)
@@ -239,7 +239,7 @@
(setf (gfw:text label-3) (thumb->string scrollbar))))
(sb-1 (make-instance 'gfw:scrollbar :parent panel-1
:callback sb-1-cb
- :outer-limits (gfs:make-span :start 0 :end 10)))
+ :outer-limit 10))
(panel-2 (make-instance 'gfw:panel :dispatcher panel-disp
:parent outer-panel
:layout layout3))
@@ -251,7 +251,7 @@
(sl-2 (make-instance 'gfw:slider :parent panel-2
:callback sl-2-cb
:style '(:vertical :auto-ticks :ticks-after :ticks-before)
- :outer-limits (gfs:make-span :start 0 :end 10)))
+ :outer-limit 10))
(label-4 (make-instance 'gfw:label :parent panel-2
:text "0 "))
(sb-2-cb (lambda (disp scrollbar axis detail)
@@ -260,7 +260,7 @@
(sb-2 (make-instance 'gfw:scrollbar :parent panel-2
:callback sb-2-cb
:style '(:vertical)
- :outer-limits (gfs:make-span :start 0 :end 10))))
+ :outer-limit 10)))
(declare (ignore sl-1 sl-2 sb-1 sb-2))
(gfw:pack panel-1)
(gfw:pack panel-2)
Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/scrollbar.lisp (original)
+++ trunk/src/uitoolkit/widgets/scrollbar.lisp Wed Oct 11 21:41:12 2006
@@ -54,13 +54,13 @@
(let ((hwnd (gfs:handle scrollbar)))
(cffi:with-foreign-object (info-ptr 'gfs::scrollinfo)
(gfs::zero-mem info-ptr gfs::scrollinfo)
- (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pagesize gfs::pos
- gfs::minpos gfs::maxpos gfs::trackpos)
+ (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pagesize
+ gfs::pos gfs::maxpos gfs::trackpos)
info-ptr gfs::scrollinfo)
(setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo)
gfs::fmask gfs::+sif-all+)
(gfs::get-scroll-info hwnd type info-ptr)
- (list (gfs:make-span :start gfs::minpos :end gfs::maxpos)
+ (list gfs::maxpos
gfs::pagesize
gfs::pos
gfs::trackpos)))))
@@ -83,10 +83,10 @@
(gfs::set-scroll-info hwnd type info-ptr 1)))
amount)
-(defun sb-set-thumb-limits (scrollbar type span)
- (when (or (< (gfs:span-start span) 0) (< (gfs:span-end span) 0))
+(defun sb-set-thumb-limit (scrollbar type limit)
+ (when (< limit 0)
(warn 'gfs:toolkit-warning :detail "negative scrollbar limit")
- (return-from sb-set-thumb-limits nil))
+ (return-from sb-set-thumb-limit nil))
(if (gfs:disposed-p scrollbar)
(error 'gfs:disposed-error))
(let ((hwnd (gfs:handle scrollbar)))
@@ -96,17 +96,17 @@
info-ptr gfs::scrollinfo)
(setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo)
gfs::fmask gfs::+sif-range+
- gfs::minpos (gfs:span-start span)
- gfs::maxpos (gfs:span-end span)))
+ gfs::minpos 0
+ gfs::maxpos limit))
(gfs::set-scroll-info hwnd type info-ptr 1)))
- span)
+ limit)
(defun sb-set-thumb-position (scrollbar type position)
(when (< position 0)
(warn 'gfs:toolkit-warning :detail "negative scrollbar position")
(return-from sb-set-thumb-position 0))
;;
- ;; TODO: should check position against limits, but doing that
+ ;; TODO: should check position against limit, but doing that
;; is not cheap, whereas the application will be calling this
;; method frequently to maintain the scrollbar's position;
;; more thought needed.
@@ -139,18 +139,18 @@
(error 'gfs:toolkit-error :detail "invalid standard scrollbar orientation")))
(setf (slot-value self 'dispatcher) nil)) ; standard scrollbars don't use dispatchers
-(defmethod outer-limits ((self standard-scrollbar))
+(defmethod outer-limit ((self standard-scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (destructuring-bind (limits pagesize pos trackpos)
+ (destructuring-bind (limit pagesize pos trackpos)
(sb-get-info self (orientation-of self))
(declare (ignore pagesize pos trackpos))
- limits))
+ limit))
-(defmethod (setf outer-limits) (span (self standard-scrollbar))
+(defmethod (setf outer-limit) (limit (self standard-scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (sb-set-thumb-limits self (orientation-of self) span))
+ (sb-set-thumb-limit self (orientation-of self) limit))
(defmethod owner ((self standard-scrollbar))
(parent self))
@@ -158,9 +158,9 @@
(defmethod page-increment ((self standard-scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (destructuring-bind (limits pagesize pos trackpos)
+ (destructuring-bind (limit pagesize pos trackpos)
(sb-get-info self (orientation-of self))
- (declare (ignore limits pos trackpos))
+ (declare (ignore limit pos trackpos))
pagesize))
(defmethod (setf page-increment) (amount (self standard-scrollbar))
@@ -206,9 +206,9 @@
(defmethod thumb-position ((self standard-scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (destructuring-bind (limits pagesize pos trackpos)
+ (destructuring-bind (limit pagesize pos trackpos)
(sb-get-info self (orientation-of self))
- (declare (ignore limits pagesize trackpos))
+ (declare (ignore limit pagesize trackpos))
pos))
(defmethod (setf thumb-position) (position (self standard-scrollbar))
@@ -219,9 +219,9 @@
(defmethod thumb-track-position ((self standard-scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (destructuring-bind (limits pagesize pos trackpos)
+ (destructuring-bind (limit pagesize pos trackpos)
(sb-get-info self (orientation-of self))
- (declare (ignore limits pagesize pos))
+ (declare (ignore limit pagesize pos))
trackpos))
;;;
@@ -238,25 +238,25 @@
(:vertical (setf std-flags (sb-vertical-flags std-flags)))))
(values std-flags 0)))
-(defmethod initialize-instance :after ((self scrollbar) &key outer-limits page-increment parent &allow-other-keys)
+(defmethod initialize-instance :after ((self scrollbar) &key outer-limit page-increment parent &allow-other-keys)
(create-control self parent "" gfs::+icc-standard-classes+)
- (if outer-limits
- (setf (outer-limits self) outer-limits))
+ (if outer-limit
+ (setf (outer-limit self) outer-limit))
(if page-increment
(setf (page-increment self) page-increment)))
-(defmethod outer-limits ((self scrollbar))
+(defmethod outer-limit ((self scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (destructuring-bind (limits pagesize pos trackpos)
+ (destructuring-bind (limit pagesize pos trackpos)
(sb-get-info self gfs::+sb-ctl+)
(declare (ignore pagesize pos trackpos))
- limits))
+ limit))
-(defmethod (setf outer-limits) (span (self scrollbar))
+(defmethod (setf outer-limit) (span (self scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (sb-set-thumb-limits self gfs::+sb-ctl+ span))
+ (sb-set-thumb-limit self gfs::+sb-ctl+ span))
(defmethod owner ((self scrollbar))
(parent self))
@@ -264,9 +264,9 @@
(defmethod page-increment ((self scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (destructuring-bind (limits pagesize pos trackpos)
+ (destructuring-bind (limit pagesize pos trackpos)
(sb-get-info self gfs::+sb-ctl+)
- (declare (ignore limits pos trackpos))
+ (declare (ignore limit pos trackpos))
pagesize))
(defmethod (setf page-increment) (amount (self scrollbar))
@@ -290,9 +290,9 @@
(defmethod thumb-position ((self scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (destructuring-bind (limits pagesize pos trackpos)
+ (destructuring-bind (limit pagesize pos trackpos)
(sb-get-info self gfs::+sb-ctl+)
- (declare (ignore limits pagesize trackpos))
+ (declare (ignore limit pagesize trackpos))
pos))
(defmethod (setf thumb-position) (position (self scrollbar))
@@ -303,7 +303,7 @@
(defmethod thumb-track-position ((self scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (destructuring-bind (limits pagesize pos trackpos)
+ (destructuring-bind (limit pagesize pos trackpos)
(sb-get-info self gfs::+sb-ctl+)
- (declare (ignore limits pagesize pos))
+ (declare (ignore limit pagesize pos))
trackpos))
Modified: trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp (original)
+++ trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Wed Oct 11 21:41:12 2006
@@ -43,11 +43,11 @@
(defun update-scrollbar (scrollbar step-size detail)
(let ((page-size (page-increment scrollbar))
- (limits (outer-limits scrollbar))
+ (limit (outer-limit scrollbar))
(curr-pos (thumb-position scrollbar)))
(let ((new-pos (case detail
- (:start (gfs:span-start limits))
- (:end (gfs:span-end limits))
+ (:start 0)
+ (:end limit)
(:step-back (- curr-pos step-size))
(:step-forward (+ curr-pos step-size))
(:page-back (- curr-pos page-size))
@@ -55,9 +55,7 @@
(:thumb-position curr-pos)
(:thumb-track (thumb-track-position scrollbar))
(otherwise curr-pos))))
- (setf new-pos (clamp-scroll-pos new-pos
- (- (gfs:span-end limits) (gfs:span-start limits))
- page-size))
+ (setf new-pos (clamp-scroll-pos new-pos limit page-size))
(setf (thumb-position scrollbar) new-pos)
new-pos)))
@@ -111,9 +109,9 @@
(saved-x (gfs:point-x origin))
(saved-y (gfs:point-y origin))
(delta-x (- (+ (gfs:size-width viewport-size) saved-x)
- (gfs:span-end (outer-limits hscrollbar))))
+ (outer-limit hscrollbar)))
(delta-y (- (+ (gfs:size-height viewport-size) saved-y)
- (gfs:span-end (outer-limits vscrollbar)))))
+ (outer-limit vscrollbar))))
(if (and (> delta-x 0) (> saved-x 0))
(setf (gfs:point-x origin) (max 0 (- saved-x delta-x)))
(setf delta-x 0))
Modified: trunk/src/uitoolkit/widgets/slider.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/slider.lisp (original)
+++ trunk/src/uitoolkit/widgets/slider.lisp Wed Oct 11 21:41:12 2006
@@ -93,12 +93,12 @@
(setf std-flags (sl-ticks-both-flags std-flags)))
(values std-flags 0)))
-(defmethod initialize-instance :after ((self slider) &key outer-limits parent &allow-other-keys)
+(defmethod initialize-instance :after ((self slider) &key outer-limit parent &allow-other-keys)
(create-control self parent "" gfs::+icc-win95-classes+)
(setf (gfg:background-color self)
(gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))
- (if outer-limits
- (setf (outer-limits self) outer-limits)))
+ (if outer-limit
+ (setf (outer-limit self) outer-limit)))
(defmethod inner-limits ((self slider))
(if (gfs:disposed-p self)
@@ -124,27 +124,19 @@
(gfs::make-lparam end start))))
limits)
-(defmethod outer-limits ((self slider))
+(defmethod outer-limit ((self slider))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
(let ((hwnd (gfs:handle self)))
- (gfs:make-span :start (gfs::send-message hwnd gfs::+tbm-getrangemin+ 0 0)
- :end (gfs::send-message hwnd gfs::+tbm-getrangemax+ 0 0))))
+ (gfs::send-message hwnd gfs::+tbm-getrangemax+ 0 0)))
-(defmethod (setf outer-limits) (limits (self slider))
+(defmethod (setf outer-limit) (limit (self slider))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (let ((start (gfs:span-start limits))
- (end (gfs:span-end limits)))
- (if (or (< start 0) (< end 0))
- (error 'gfs:toolkit-error :detail "negative slider thumb limit"))
- (gfs::send-message (gfs:handle self)
- gfs::+tbm-setrange+
- 1
- (if (<= start end)
- (gfs::make-lparam start end)
- (gfs::make-lparam end start))))
- limits)
+ (if (< limit 0)
+ (error 'gfs:toolkit-error :detail "negative slider thumb limit"))
+ (gfs::send-message (gfs:handle self) gfs::+tbm-setrange+ 1 (gfs::make-lparam 0 limit))
+ limit)
(defmethod page-increment ((self slider))
(if (gfs:disposed-p self)
@@ -163,13 +155,12 @@
(defmethod preferred-size ((self slider) width-hint height-hint)
(let* ((b-width (* (border-width self) 2))
- (limits (outer-limits self))
- (numticks (- (gfs:span-end limits) (gfs:span-start limits)))
+ (limit (outer-limit self))
(size (gfs:make-size)))
(if (find :vertical (style-of self))
(setf (gfs:size-width size) (floor (* (vertical-scrollbar-width) 5) 2)
- (gfs:size-height size) (+ (* 10 numticks) b-width))
- (setf (gfs:size-width size) (+ (* 10 numticks) b-width)
+ (gfs:size-height size) (+ (* 10 limit) b-width))
+ (setf (gfs:size-width size) (+ (* 10 limit) b-width)
(gfs:size-height size) (floor (* (horizontal-scrollbar-height) 5) 2)))
(if (>= width-hint 0)
(setf (gfs:size-width size) width-hint))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Oct 11 21:41:12 2006
@@ -294,11 +294,11 @@
(defgeneric obtain-vertical-scrollbar (self)
(:documentation "Returns a scrollbar object if self has been configured to have one horizontally."))
-(defgeneric outer-limits (self)
- (:documentation "Returns the lowest and highest possible positions of self's indicator."))
+(defgeneric outer-limit (self)
+ (:documentation "Returns the zero-based highest possible position of self's indicator."))
-(defgeneric (setf outer-limits) (span self)
- (:documentation "Sets the lowest and highest possible positions of self's indicator."))
+(defgeneric (setf outer-limit) (limit self)
+ (:documentation "Sets the zero-based highest possible position of self's indicator."))
(defgeneric owner (self)
(:documentation "Returns self's owner (which is not necessarily the same as parent)."))
More information about the Graphic-forms-cvs
mailing list