[graphic-forms-cvs] r280 - in trunk/src: tests/uitoolkit uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Oct 1 04:58:28 UTC 2006
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))
More information about the Graphic-forms-cvs
mailing list