Author: junrue Date: Sun Oct 1 00:58:28 2006 New Revision: 280 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/scrollbar.lisp Log: scrollbar controls now getting created Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sun Oct 1 00:58:28 2006 @@ -213,30 +213,58 @@ (defun thumb->string (thing) (format nil "~d" (gfw:thumb-position thing))) -(defun populate-scrollbar-test-panel () +(defun populate-slider-test-panel () (let* ((panel-disp (make-instance 'widget-tester-panel-events)) - (layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4)) + (layout1 (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4)) + (layout2 (make-instance 'gfw:flow-layout :style '(:horizontal) :margins 4 :spacing 4)) + (layout3 (make-instance 'gfw:flow-layout :style '(:horizontal) :margins 4 :spacing 4)) (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* - :layout layout)) - (label-1 (make-instance 'gfw:label :parent outer-panel - :text "00")) + :layout layout1)) + (panel-1 (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout layout2)) + (label-1 (make-instance 'gfw:label :parent panel-1 + :text "0 ")) (sl-1-cb (lambda (disp slider axis detail) (declare (ignore disp axis detail)) (setf (gfw:text label-1) (thumb->string slider)))) - (sl-1 (make-instance 'gfw:slider :parent outer-panel + (sl-1 (make-instance 'gfw:slider :parent panel-1 :callback sl-1-cb :outer-limits (gfs:make-span :start 0 :end 10))) - (label-2 (make-instance 'gfw:label :parent outer-panel - :text "00")) + (label-3 (make-instance 'gfw:label :parent panel-1 + :text "0 ")) + (sb-1-cb (lambda (disp scrollbar axis detail) + (declare (ignore disp axis detail)) + (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))) + (panel-2 (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout layout3)) + (label-2 (make-instance 'gfw:label :parent panel-2 + :text "0 ")) (sl-2-cb (lambda (disp slider axis detail) (declare (ignore disp axis detail)) (setf (gfw:text label-2) (thumb->string slider)))) - (sl-2 (make-instance 'gfw:slider :parent outer-panel + (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)))) - (declare (ignore sl-1 sl-2)) + :outer-limits (gfs:make-span :start 0 :end 10))) + (label-4 (make-instance 'gfw:label :parent panel-2 + :text "0 ")) + (sb-2-cb (lambda (disp scrollbar axis detail) + (declare (ignore disp axis detail)) + (setf (gfw:text label-4) (thumb->string scrollbar)))) + (sb-2 (make-instance 'gfw:scrollbar :parent panel-2 + :callback sb-2-cb + :style '(:vertical) + :outer-limits (gfs:make-span :start 0 :end 10)))) + (declare (ignore sl-1 sl-2 sb-1 sb-2)) + (gfw:pack panel-1) + (gfw:pack panel-2) + (gfw:pack outer-panel) outer-panel)) (defun widget-tester-internal () @@ -246,7 +274,7 @@ :style '(:frame))) (let* ((layout (gfw:layout-of *widget-tester-win*)) (test-panels (list (populate-list-box-test-panel) - (populate-scrollbar-test-panel))) + (populate-slider-test-panel))) (select-lb-callback (lambda (disp item) (declare (ignore disp item)) (setf (gfw:top-child-of layout) (first test-panels)) Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrollbar.lisp (original) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Sun Oct 1 00:58:28 2006 @@ -41,7 +41,7 @@ (logand orig-flags (lognot gfs::+sbs-vert+))) (defun sb-vertical-flags (orig-flags) - (logior orig-flags (lognot gfs::+sbs-vert+))) + (logior orig-flags gfs::+sbs-vert+)) (defun validate-scrollbar-type (type) (unless (or (= type gfs::+sb-ctl+) (= type gfs::+sb-horz+) (= type gfs::+sb-vert+)) @@ -238,8 +238,12 @@ (:vertical (setf std-flags (sb-vertical-flags std-flags))))) (values std-flags 0))) -(defmethod initialize-instance :after ((self scrollbar) &key parent &allow-other-keys) - (create-control self parent "" gfs::+icc-standard-classes+)) +(defmethod initialize-instance :after ((self scrollbar) &key outer-limits page-increment parent &allow-other-keys) + (create-control self parent "" gfs::+icc-standard-classes+) + (if outer-limits + (setf (outer-limits self) outer-limits)) + (if page-increment + (setf (page-increment self) page-increment))) (defmethod outer-limits ((self scrollbar)) (if (gfs:disposed-p self) @@ -270,6 +274,19 @@ (error 'gfs:disposed-error)) (sb-set-page-increment self gfs::+sb-ctl+ amount)) +(defmethod preferred-size ((self scrollbar) width-hint height-hint) + (let ((size (gfs:make-size))) + (if (find :vertical (style-of self)) + (setf (gfs:size-width size) (vertical-scrollbar-width) + (gfs:size-height size) +default-widget-height+) + (setf (gfs:size-width size) +default-widget-width+ + (gfs:size-height size) (horizontal-scrollbar-height))) + (if (>= width-hint 0) + (setf (gfs:size-width size) width-hint)) + (if (>= height-hint 0) + (setf (gfs:size-height size) height-hint)) + size)) + (defmethod thumb-position ((self scrollbar)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))