September 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r278 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 30 Sep '06

30 Sep '06

Author: junrue Date: Sat Sep 30 12:43:30 2006 New Revision: 278 Modified: trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event.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-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: slider controls now getting created, more work needed; renamed thumb-limits GF to outer-limits and added inner-limits Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Sat Sep 30 12:43:30 2006 @@ -283,6 +283,18 @@ an image or an icon-bundle. @end deffn +@anchor{inner-limits} +@deffn GenericFunction inner-limits self => @ref{span} +(setf (@strong{inner-limits} @var{self}) @var{span})@* + +Certain @ref{control}s having the concept of a range of values within +which a selector may be positioned also allow the indicator to +be further constrained to a narrower range, e.g., @ref{slider}. +By default, this function returns the same span that @ref{outer-limits} +does. If the @sc{setf} function is used to set a sub-range, @var{self}'s +visual style will be updated and the indicator restricted appropriately. +@end deffn + @anchor{item-count} @deffn GenericFunction item-count self => integer Returns the number of instances of @ref{item} subclasses contained within @@ -419,6 +431,18 @@ being the primary. @end defun +@anchor{outer-limits} +@deffn GenericFunction outer-limits self => @ref{span} +(setf (@strong{outer-limits} @var{self}) @var{span})@* + +Returns a span representing the widest range of start and end +positions to which the indicator within @var{self} may be set. The +@sc{setf} function allows this span to be modified. Application code +is responsible for synchronizing the range with its content model. +Certain controls also allow the actual range of positions to be +further constrained; @xref{inner-limits}. +@end deffn + @anchor{owner} @deffn GenericFunction owner self Returns the @var{owner} of @var{self}, which may be different from @@ -672,17 +696,6 @@ other cases there is no text component at all. @end deffn -@anchor{thumb-limits} -@deffn GenericFunction thumb-limits self => @ref{span} -(setf (@strong{thumb-limits} @var{self}) @var{span})@* - -Returns a span representing the start and end positions to which the -scrollbar @var{self} may be set. The @sc{setf} function allows this -span to be modified. Application code is responsible for managing the -thumb limits in relation to the content model that will be scrolled -within a @ref{window}. @xref{thumb-position}. -@end deffn - @anchor{thumb-position} @deffn GenericFunction thumb-position self => integer (setf (@strong{thumb-position} @var{self}) @var{integer})@* @@ -691,7 +704,7 @@ scroll thumb for @var{self}. The @sc{setf} function allows the position to be modified. A @ref{scrolling-event-dispatcher} instance will manage the thumb position for the @ref{window} -to which it is assigned. @xref{thumb-limits}. +to which it is assigned. @xref{outer-limits}. @end deffn @anchor{undo-available-p} Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Sat Sep 30 12:43:30 2006 @@ -475,10 +475,20 @@ @end-control-subclass @begin-control-subclass{slider, -This class represents a @ref{control} having a slider component and optional -tick marks., +This class represents a @ref{control} having a sliding-thumb component +and optional tick marks., event-select} @control-callback-initarg{slider,event-select} +@deffn Initarg :outer-limits +This initarg accepts a @ref{span} that describes the minimum and maximum +possible slider positions. +@end deffn +@deffn Initarg :page-increment +TODO +@end deffn +@deffn Initarg :step-increment +TODO +@end deffn @deffn Initarg :style @begin-primary-style-choices{By default\, sliders are oriented horizontally with a tick mark below the control at the beginning and end of its range.} @@ -494,9 +504,6 @@ This style keyword configures the slider to be oriented vertically. @end-primary-style-choices @begin-optional-style-choices -@item :constrained-range -Specifies that the slider restricts (and highlights) a subset of the -total range; the subset is indicated with triangles instead of dashes. @item :no-border By default, a slider is drawn with a border; this style keyword disables that feature. Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Sep 30 12:43:30 2006 @@ -264,7 +264,9 @@ #:menu-item #:panel #:root-window + #:scrollbar #:scrolling-event-dispatcher + #:slider #:timer #:top-level #:widget @@ -438,6 +440,7 @@ #:initial-delay-of #:horizontal-policy-of #:image + #:inner-limits #:item-count #:item-height #:item-id @@ -474,6 +477,7 @@ #:obtain-horizontal-scrollbar #:obtain-primary-display #:obtain-vertical-scrollbar + #:outer-limits #:owner #:pack #:page-increment @@ -516,7 +520,6 @@ #:text-height #:text-limit #:text-modified-p - #:thumb-limits #:thumb-position #:thumb-track-position #:tooltip-text 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 Sat Sep 30 12:43:30 2006 @@ -51,11 +51,11 @@ (gfw:minimum-size panel) panel-size) (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size))) (let ((scrollbar (gfw:obtain-horizontal-scrollbar parent))) - (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (gfs:size-width panel-size)) + (setf (gfw:outer-limits scrollbar) (gfs:make-span :end (gfs:size-width panel-size)) (gfw:thumb-position scrollbar) 0) (gfs:dispose scrollbar)) (let ((scrollbar (gfw:obtain-vertical-scrollbar parent))) - (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (gfs:size-height panel-size)) + (setf (gfw:outer-limits scrollbar) (gfs:make-span :end (gfs:size-height panel-size)) (gfw:thumb-position scrollbar) 0) (gfs:dispose scrollbar)) #| Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sat Sep 30 12:43:30 2006 @@ -210,20 +210,41 @@ (gfw:delete-all lb2) outer-panel)) +(defun populate-scrollbar-test-panel () + (let* ((panel-disp (make-instance 'widget-tester-panel-events)) + (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent *widget-tester-win* + :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4)))) + (make-instance 'gfw:label :parent outer-panel :text "some nice slider label") + (make-instance 'gfw:slider :parent outer-panel :outer-limits (gfs:make-span :start 0 :end 10)) + outer-panel)) + (defun widget-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) - (let ((disp (make-instance 'widget-tester-events)) - (layout (make-instance 'gfw:heap-layout)) - (menubar (gfw:defmenu ((:item "&File" - :submenu ((:item "E&xit" :callback #'widget-tester-exit))))))) - (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher disp - :layout layout - :style '(:frame))) + (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'widget-tester-events) + :layout (make-instance 'gfw:heap-layout) + :style '(:frame))) + (let* ((layout (gfw:layout-of *widget-tester-win*)) + (test-panels (list (populate-list-box-test-panel) + (populate-scrollbar-test-panel))) + (select-lb-callback (lambda (disp item) + (declare (ignore disp item)) + (setf (gfw:top-child-of layout) (first test-panels)) + (gfw:layout *widget-tester-win*))) + (select-sb-callback (lambda (disp item) + (declare (ignore disp item)) + (setf (gfw:top-child-of layout) (second test-panels)) + (gfw:layout *widget-tester-win*))) + (menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'widget-tester-exit))) + (:item "&Panels" + :submenu ((:item "&List Boxes" :callback select-lb-callback) + (:item "&Scrollbars" :callback select-sb-callback))))))) (setf (gfw:menu-bar *widget-tester-win*) menubar - (gfw:top-child-of layout) (populate-list-box-test-panel) - (gfw:image *widget-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) - (gfw:pack *widget-tester-win*) - (gfw:show *widget-tester-win* t))) + (gfw:top-child-of layout) (first test-panels) + (gfw:image *widget-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico")))) + (gfw:pack *widget-tester-win*) + (gfw:show *widget-tester-win* t)) (defun widget-tester () (gfw:startup "Widget Tester" #'widget-tester-internal)) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Sat Sep 30 12:43:30 2006 @@ -143,6 +143,18 @@ (if (typep obj 'gfs:native-object) (gfs:dispose obj))) +(declaim (inline lparam-high-word)) +(defun lparam-high-word (lparam) + (ash (logand #xFFFF0000 lparam) -16)) + +(declaim (inline lparam-low-word)) +(defun lparam-low-word (lparam) + (logand #x0000FFFF lparam)) + +(declaim (inline make-lparam)) +(defun make-lparam (hi lo) + (logior (ash (logand lo #xFFFF) 16) (logand hi #xFFFF))) + ;;; ;;; convenience macros ;;; Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sat Sep 30 12:43:30 2006 @@ -54,7 +54,7 @@ (gfs:handle parent) std-style ex-style - (or id (increment-widget-id (thread-context)))))) + id))) (setf (slot-value ctrl 'gfs:handle) hwnd) (subclass-wndproc hwnd) (put-widget (thread-context) ctrl) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Sep 30 12:43:30 2006 @@ -81,12 +81,6 @@ (when (funcall msg-filter gm msg-ptr) (return-from message-loop gfs::wparam))))))) -(defmacro hi-word (lparam) - `(ash (logand #xFFFF0000 ,lparam) -16)) - -(defmacro lo-word (lparam) - `(logand #x0000FFFF ,lparam)) - (defun key-down-p (key-code) "Return T if the key corresponding to key-code is currently down." (= (logand (gfs::get-async-key-state key-code) #x8000) #x8000)) @@ -100,8 +94,8 @@ (w (get-widget tc hwnd)) (pnt (mouse-event-pnt tc))) (when w - (setf (gfs:point-x pnt) (lo-word lparam)) - (setf (gfs:point-y pnt) (hi-word lparam)) + (setf (gfs:point-x pnt) (gfs::lparam-low-word lparam)) + (setf (gfs:point-y pnt) (gfs::lparam-high-word lparam)) (funcall fn (dispatcher w) w pnt btn-symbol))) 0) @@ -109,7 +103,7 @@ (let ((wndproc-val (gfs::get-class-long hwnd gfs::+gclp-wndproc+))) (if (zerop wndproc-val) (error 'gfs:win32-error :detail "get-class-long failed")) - wndproc-val)) + (logand wndproc-val #xFFFFFFFF))) (defun subclass-wndproc (hwnd) (if (zerop (gfs::set-window-long hwnd @@ -197,8 +191,8 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-command+)) wparam lparam) (let* ((tc (thread-context)) - (wparam-hi (hi-word wparam)) - (wparam-lo (lo-word wparam)) + (wparam-hi (gfs::lparam-high-word wparam)) + (wparam-lo (gfs::lparam-low-word wparam)) (owner (get-widget tc hwnd))) ; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) (if owner @@ -227,7 +221,7 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) (declare (ignore hwnd lparam)) ; FIXME: handle system menus (let* ((tc (thread-context)) - (item (get-item tc (lo-word wparam)))) + (item (get-item tc (gfs::lparam-low-word wparam)))) (unless (null item) (let ((d (dispatcher item))) (unless (null d) @@ -269,7 +263,7 @@ (declare (ignore lparam)) (let* ((tc (thread-context)) (widget (get-widget tc hwnd)) - (ch (code-char (lo-word wparam)))) + (ch (code-char (gfs::lparam-low-word wparam)))) (when widget (event-key-down (dispatcher widget) widget (virtual-key tc) ch))) 0) @@ -277,7 +271,7 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context)) - (wparam-lo (lo-word wparam)) + (wparam-lo (gfs::lparam-low-word wparam)) (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) @@ -288,7 +282,7 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam) (declare (ignore lparam)) (let ((tc (thread-context))) - (let* ((wparam-lo (lo-word wparam)) + (let* ((wparam-lo (gfs::lparam-low-word wparam)) (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (when w @@ -352,14 +346,14 @@ (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (dispatch-scroll-notification widget :horizontal (lo-word wparam)))) + (dispatch-scroll-notification widget :horizontal (gfs::lparam-low-word wparam)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-vscroll+)) wparam lparam) (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (dispatch-scroll-notification widget :vertical (lo-word wparam)))) + (dispatch-scroll-notification widget :vertical (gfs::lparam-low-word wparam)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrollbar.lisp (original) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Sat Sep 30 12:43:30 2006 @@ -133,6 +133,19 @@ (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)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self (orientation-of self)) + (declare (ignore pagesize pos trackpos)) + limits)) + +(defmethod (setf outer-limits) (span (self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (sb-set-thumb-limits self (orientation-of self) span)) + (defmethod owner ((self standard-scrollbar)) (parent self)) @@ -184,19 +197,6 @@ (t (warn 'gfs:toolkit-warning :detail "parent dispatcher is wrong type"))))) -(defmethod thumb-limits ((self standard-scrollbar)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (destructuring-bind (limits pagesize pos trackpos) - (sb-get-info self (orientation-of self)) - (declare (ignore pagesize pos trackpos)) - limits)) - -(defmethod (setf thumb-limits) (span (self standard-scrollbar)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (sb-set-thumb-limits self (orientation-of self) span)) - (defmethod thumb-position ((self standard-scrollbar)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) 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 Sat Sep 30 12:43:30 2006 @@ -43,7 +43,7 @@ (defun compute-scrolling-delta (scrollbar step-size detail) (let ((page-size (page-increment scrollbar)) - (limits (thumb-limits scrollbar)) + (limits (outer-limits scrollbar)) (curr-pos (thumb-position scrollbar))) (let ((new-pos (case detail (:start (gfs:span-start limits)) Modified: trunk/src/uitoolkit/widgets/slider.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/slider.lisp (original) +++ trunk/src/uitoolkit/widgets/slider.lisp Sat Sep 30 12:43:30 2006 @@ -90,12 +90,118 @@ ;; styles that can be combined ;; - (:constrained-range (setf std-flags (sl-sel-range-flags std-flags))) (:no-border (setf std-flags (sl-no-border-flags std-flags))) (:ticks-after (setf std-flags (sl-ticks-after-flags std-flags))) (:ticks-before (setf std-flags (sl-ticks-before-flags std-flags))) (:tooltip (setf std-flags (sl-tooltip-flags std-flags))))) (values std-flags 0))) -(defmethod initialize-instance :after ((self slider) &key parent &allow-other-keys) - (create-control self parent "" gfs::+icc-win95-classes+)) +(defmethod initialize-instance :after ((self slider) &key outer-limits 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))) + +(defmethod inner-limits ((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-getselstart+ 0 0) + :end (gfs::send-message hwnd gfs::+tbm-getselend+ 0 0)))) + +(defmethod (setf inner-limits) (limits (self slider)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (test-native-style self gfs::+tbs-enableselrange+) + (update-native-style self (logior (get-native-style self) gfs::+tbs-enableselrange+))) + (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-setsel+ + 1 + (if (<= start end) + (gfs::make-lparam start end) + (gfs::make-lparam end start)))) + limits) + +(defmethod outer-limits ((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)))) + +(defmethod (setf outer-limits) (limits (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) + +(defmethod page-increment ((self slider)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::send-message (gfs:handle self) gfs::+tbm-getpagesize+ 0 0)) + +(defmethod (setf page-increment) (amount (self slider)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (if (< amount 0) + (error 'gfs:toolkit-error :detail "negative slider page increment")) + (if (< amount (step-increment self)) + (warn 'gfs::toolkit-warning :detail "slider page increment less than step increment")) + (gfs::send-message (gfs:handle self) gfs::+tbm-setpagesize+ 0 amount) + amount) + +(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))) + (size (gfs:make-size))) + (if (find :vertical (style-of self)) + (setf (gfs:size-width size) (* (vertical-scrollbar-width) 2) + (gfs:size-height size) (+ (* 8 numticks) b-width)) + (setf (gfs:size-width size) (+ (* 8 numticks) b-width) + (gfs:size-height size) (* (horizontal-scrollbar-height) 2))) + (if (>= width-hint 0) + (setf (gfs:size-width size) width-hint)) + (if (>= height-hint 0) + (setf (gfs:size-height size) height-hint)) + size)) + +(defmethod step-increment ((self slider)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::send-message (gfs:handle self) gfs::+tbm-getlinesize+ 0 0)) + +(defmethod (setf step-increment) (amount (self slider)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (if (< amount 0) + (error 'gfs:toolkit-error :detail "negative slider step increment")) + (if (> amount (page-increment self)) + (warn 'gfs::toolkit-warning :detail "slider step increment greater than page increment")) + (gfs::send-message (gfs:handle self) gfs::+tbm-setlinesize+ 0 amount) + amount) + +(defmethod thumb-position ((self slider)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::send-message (gfs:handle self) gfs::+tbm-getpos+ 0 0)) + +(defmethod (setf thumb-position) (pos (self slider)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::send-message (gfs:handle self) gfs::+tbm-setpos+ 1 pos) + (gfs::send-message (gfs:handle self) gfs::+tbm-getpos+ 0 0)) ; might have been adjusted Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Sep 30 12:43:30 2006 @@ -176,8 +176,8 @@ (defmacro define-control-class (classname system-classname callback-event-name &optional docstring mixins) `(defclass ,classname `,(control ,@mixins) - ((,(intern "CALLBACK-EVENT-NAME") - :accessor ,(intern "CALLBACK-EVENT-NAME-OF") + ((callback-event-name + :accessor callback-event-name-of :initform ,callback-event-name :allocation :class) (,(intern "SYSTEM-CLASSNAME") Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Sep 30 12:43:30 2006 @@ -207,6 +207,12 @@ (defgeneric (setf image) (image self) (:documentation "Sets self's image object.")) +(defgeneric inner-limits (self) + (:documentation "Returns the lowest and highest allowed positions of self's indicator.")) + +(defgeneric (setf inner-limits) (span self) + (:documentation "Sets the lowest and highest allowed positions of self's indicator.")) + (defgeneric item-count (self) (:documentation "Returns the number of items contained within self.")) @@ -288,6 +294,12 @@ (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 (setf outer-limits) (span self) + (:documentation "Sets the lowest and highest possible positions of self's indicator.")) + (defgeneric owner (self) (:documentation "Returns self's owner (which is not necessarily the same as parent).")) @@ -417,12 +429,6 @@ (defgeneric (setf text-modified-p) (modified self) (:documentation "Sets self's modified flag.")) -(defgeneric thumb-limits (self) - (:documentation "Returns the lowest and highest allowed positions of self's thumb component.")) - -(defgeneric (setf thumb-limits) (span self) - (:documentation "Sets the lowest and highest allowed positions of self's thumb component.")) - (defgeneric thumb-position (self) (:documentation "Returns the position of self's thumb component."))

1 0

[graphic-forms-cvs] r277 - in trunk: . src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 29 Sep '06

29 Sep '06

Author: junrue Date: Fri Sep 29 15:56:34 2006 New Revision: 277 Modified: trunk/src/tests/uitoolkit/widget-unit-tests.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/slider.lisp trunk/tests.lisp Log: refactored control initialization Modified: trunk/src/tests/uitoolkit/widget-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/widget-unit-tests.lisp Fri Sep 29 15:56:34 2006 @@ -37,9 +37,10 @@ (assert-true (> (gfw::register-panel-window-class) 0) 'gfw::register-panel-class) (assert-true (> (gfw::register-toplevel-erasebkgnd-window-class) 0) 'gfw::register-toplevel-erasebkgnd-window-class) (assert-true (> (gfw::register-toplevel-noerasebkgnd-window-class) 0) 'gfw::register-toplevel-noerasebkgnd-window-class) - (assert-true (> (gfw::register-dialog-class) 0) 'gfw::register-dialog-class)) + (assert-true (> (gfw::register-dialog-class) 0) 'gfw::register-dialog-class) -(define-test repeat-class-registration-test + ;; test registering them again + ;; (assert-true (> (gfw::register-panel-window-class) 0) 'gfw::register-panel-class) (assert-true (> (gfw::register-toplevel-erasebkgnd-window-class) 0) 'gfw::register-toplevel-erasebkgnd-window-class) (assert-true (> (gfw::register-toplevel-noerasebkgnd-window-class) 0) 'gfw::register-toplevel-noerasebkgnd-window-class) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Sep 29 15:56:34 2006 @@ -73,25 +73,19 @@ (values std-flags 0))) (defmethod initialize-instance :after ((self button) &key parent text &allow-other-keys) - (initialize-comctl-classes gfs::+icc-standard-classes+) - (multiple-value-bind (std-style ex-style) - (compute-style-flags self) - (let ((hwnd (create-window (system-classname-of self) - (or text " ") - (gfs:handle parent) - std-style - ex-style - (cond - ((find :default-button (style-of self)) - gfs::+idok+) - ((find :cancel-button (style-of self)) - gfs::+idcancel+) - (t - (increment-widget-id (thread-context))))))) - (unless (zerop (logand std-style gfs::+bs-defpushbutton+)) - (gfs::send-message (gfs:handle parent) gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0)) - (setf (slot-value self 'gfs:handle) hwnd))) - (init-control self)) + (let ((id (cond + ((find :default-button (style-of self)) + gfs::+idok+) + ((find :cancel-button (style-of self)) + gfs::+idcancel+) + (t + (increment-widget-id (thread-context)))))) + (create-control self parent text gfs::+icc-standard-classes+ id) + (if (test-native-style self gfs::+bs-defpushbutton+) + (gfs::send-message (gfs:handle parent) + gfs::+dm-setdefid+ + (cffi:pointer-address (gfs:handle self)) + 0)))) (defmethod preferred-size ((self button) width-hint height-hint) (let ((text-size (widget-text-size self #'text gfs::+dt-singleline+)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Sep 29 15:56:34 2006 @@ -43,21 +43,27 @@ (setf gfs::size (cffi:foreign-type-size 'gfs::initcommoncontrolsex) gfs::icc icc-flags)) (if (and (zerop (gfs::init-common-controls ic-ptr)) (/= (gfs::get-last-error) 0)) - ;; returns false when called on SBCL with ICC_STANDARD_CLASSES, so - ;; this warning gets triggered a lot; need to investigate further (warn 'gfs:win32-warning :detail "init-common-controls failed")))) -(defun init-control (ctrl) - (let ((hwnd (gfs:handle ctrl))) - (subclass-wndproc hwnd) - (put-widget (thread-context) ctrl) - (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) - (unless (gfs:null-handle-p hfont) - (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))) - ;; FIXME: this is a temporary hack to allow layout management testing; - ;; it breaks in the presence of virtual containers like group - ;; - (let ((parent (parent ctrl))) +(defun create-control (ctrl parent text icc-flags &optional id) + (initialize-comctl-classes icc-flags) + (multiple-value-bind (std-style ex-style) + (compute-style-flags ctrl) + (let ((hwnd (create-window (system-classname-of ctrl) + (or text " ") + (gfs:handle parent) + std-style + ex-style + (or id (increment-widget-id (thread-context)))))) + (setf (slot-value ctrl 'gfs:handle) hwnd) + (subclass-wndproc hwnd) + (put-widget (thread-context) ctrl) + (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) + (unless (gfs:null-handle-p hfont) + (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it won't work if virtual containers like group are implemented. + ;; (when (and parent (layout-of parent)) (append-layout-item (layout-of parent) ctrl))))) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Fri Sep 29 15:56:34 2006 @@ -92,17 +92,7 @@ (update-native-style self bits))) (defmethod initialize-instance :after ((self edit) &key parent text &allow-other-keys) - (initialize-comctl-classes gfs::+icc-standard-classes+) - (multiple-value-bind (std-style ex-style) - (compute-style-flags self) - (let ((hwnd (create-window (system-classname-of self) - (or text "") - (gfs:handle parent) - std-style - ex-style - (increment-widget-id (thread-context))))) - (setf (slot-value self 'gfs:handle) hwnd))) - (init-control self)) + (create-control self parent text gfs::+icc-standard-classes+)) (defmethod line-count ((self edit)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Sep 29 15:56:34 2006 @@ -147,20 +147,10 @@ gfs::+image-bitmap+ (cffi:pointer-address (gfs:handle image))))) -(defmethod initialize-instance :after ((self label) &key image parent separator text &allow-other-keys) - (initialize-comctl-classes gfs::+icc-standard-classes+) - (multiple-value-bind (std-style ex-style) - (compute-style-flags self image separator text) - (let ((hwnd (create-window (system-classname-of self) - (or text " ") - (gfs:handle parent) - (logior std-style) - ex-style - (increment-widget-id (thread-context))))) - (setf (slot-value self 'gfs:handle) hwnd) - (if image - (setf (image self) image)))) - (init-control self)) +(defmethod initialize-instance :after ((self label) &key image parent text &allow-other-keys) + (create-control self parent text gfs::+icc-standard-classes+) + (if image + (setf (image self) image))) (defmethod preferred-size ((self label) width-hint height-hint) (let ((bits (get-native-style self)) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 29 15:56:34 2006 @@ -220,22 +220,12 @@ (enable-redraw self t))) (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) - (initialize-comctl-classes gfs::+icc-standard-classes+) - (multiple-value-bind (std-style ex-style) - (compute-style-flags self) - (let ((hwnd (create-window (system-classname-of self) - "" - (gfs:handle parent) - std-style - ex-style - (increment-widget-id (thread-context))))) - (setf (slot-value self 'gfs:handle) hwnd) - (init-control self) - (if (and estimated-count (> estimated-count 0)) - (gfs::send-message hwnd - gfs::+lb-initstorage+ - estimated-count - (* estimated-count +estimated-text-size+))))) + (create-control self parent "" gfs::+icc-standard-classes+) + (if (and estimated-count (> estimated-count 0)) + (gfs::send-message (gfs:handle self) + gfs::+lb-initstorage+ + estimated-count + (* estimated-count +estimated-text-size+))) (if items (setf (slot-value self 'items) (copy-item-sequence (gfs:handle self) items 'list-item))) (update-from-items self)) Modified: trunk/src/uitoolkit/widgets/slider.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/slider.lisp (original) +++ trunk/src/uitoolkit/widgets/slider.lisp Fri Sep 29 15:56:34 2006 @@ -98,14 +98,4 @@ (values std-flags 0))) (defmethod initialize-instance :after ((self slider) &key parent &allow-other-keys) - (initialize-comctl-classes gfs::+icc-win95-classes+) - (multiple-value-bind (std-style ex-style) - (compute-style-flags self) - (let ((hwnd (create-window (system-classname-of self) - "" - (gfs:handle parent) - std-style - ex-style - (increment-widget-id (thread-context))))) - (setf (slot-value self 'gfs:handle) hwnd) - (init-control self)))) + (create-control self parent "" gfs::+icc-win95-classes+)) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Fri Sep 29 15:56:34 2006 @@ -36,14 +36,14 @@ (defun load-tests () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests) - (load (concatenate 'string *gf-tests-dir* "test-utils")) - (load (concatenate 'string *gf-tests-dir* "mock-objects")) - (load (concatenate 'string *gf-tests-dir* "color-unit-tests")) - (load (concatenate 'string *gf-tests-dir* "graphics-context-unit-tests")) - (load (concatenate 'string *gf-tests-dir* "image-unit-tests")) - (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests")) - (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) - (load (concatenate 'string *gf-tests-dir* "flow-layout-unit-tests")) - (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) - (load (concatenate 'string *gf-tests-dir* "item-manager-unit-tests")) - (load (concatenate 'string *gf-tests-dir* "misc-unit-tests"))) + (load (merge-pathnames "test-utils.lisp" *gf-tests-dir*)) + (load (merge-pathnames "mock-objects" *gf-tests-dir*)) + (load (merge-pathnames "color-unit-tests" *gf-tests-dir*)) + (load (merge-pathnames "graphics-context-unit-tests" *gf-tests-dir*)) + (load (merge-pathnames "image-unit-tests" *gf-tests-dir*)) + (load (merge-pathnames "icon-bundle-unit-tests" *gf-tests-dir*)) + (load (merge-pathnames "layout-unit-tests" *gf-tests-dir*)) + (load (merge-pathnames "flow-layout-unit-tests" *gf-tests-dir*)) + (load (merge-pathnames "widget-unit-tests" *gf-tests-dir*)) + (load (merge-pathnames "item-manager-unit-tests" *gf-tests-dir*)) + (load (merge-pathnames "misc-unit-tests" *gf-tests-dir*)))

1 0

[graphic-forms-cvs] r276 - in trunk/src/uitoolkit: system widgets
by junrue＠common-lisp.net 29 Sep '06

29 Sep '06

Author: junrue Date: Fri Sep 29 12:43:16 2006 New Revision: 276 Modified: trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/slider.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: define-control-class macro now includes class allocated slot for win32 window classname Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Sep 29 12:43:16 2006 @@ -34,16 +34,6 @@ (in-package :graphic-forms.uitoolkit.system) ;;; -;;; control class names -;;; -(defparameter *button-classname* "button") -(defparameter *edit-classname* "edit") -(defparameter *listbox-classname* "listbox") -(defparameter *scrollbar-classname* "scrollbar") -(defparameter *static-classname* "static") -(defparameter *trackbar-classname* "msctls_trackbar32") - -;;; ;;; registered message names ;;; (defparameter *lbselchstringa* "commdlg_LBSelChangedNotify") Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Sep 29 12:43:16 2006 @@ -76,7 +76,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::*button-classname* + (let ((hwnd (create-window (system-classname-of self) (or text " ") (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Sep 29 12:43:16 2006 @@ -37,6 +37,16 @@ ;;; helper functions ;;; +(defun initialize-comctl-classes (icc-flags) + (cffi:with-foreign-object (ic-ptr 'gfs::initcommoncontrolsex) + (cffi:with-foreign-slots ((gfs::size gfs::icc) ic-ptr gfs::initcommoncontrolsex) + (setf gfs::size (cffi:foreign-type-size 'gfs::initcommoncontrolsex) + gfs::icc icc-flags)) + (if (and (zerop (gfs::init-common-controls ic-ptr)) (/= (gfs::get-last-error) 0)) + ;; returns false when called on SBCL with ICC_STANDARD_CLASSES, so + ;; this warning gets triggered a lot; need to investigate further + (warn 'gfs:win32-warning :detail "init-common-controls failed")))) + (defun init-control (ctrl) (let ((hwnd (gfs:handle ctrl))) (subclass-wndproc hwnd) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Fri Sep 29 12:43:16 2006 @@ -95,7 +95,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::*edit-classname* + (let ((hwnd (create-window (system-classname-of self) (or text "") (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Sep 29 12:43:16 2006 @@ -147,20 +147,20 @@ gfs::+image-bitmap+ (cffi:pointer-address (gfs:handle image))))) -(defmethod initialize-instance :after ((label label) &key image parent separator text &allow-other-keys) +(defmethod initialize-instance :after ((self label) &key image parent separator text &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) - (compute-style-flags label image separator text) - (let ((hwnd (create-window gfs::*static-classname* + (compute-style-flags self image separator text) + (let ((hwnd (create-window (system-classname-of self) (or text " ") (gfs:handle parent) (logior std-style) ex-style (increment-widget-id (thread-context))))) - (setf (slot-value label 'gfs:handle) hwnd) + (setf (slot-value self 'gfs:handle) hwnd) (if image - (setf (image label) image)))) - (init-control label)) + (setf (image self) image)))) + (init-control self)) (defmethod preferred-size ((self label) width-hint height-hint) (let ((bits (get-native-style self)) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 29 12:43:16 2006 @@ -223,7 +223,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::*listbox-classname* + (let ((hwnd (create-window (system-classname-of self) "" (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/slider.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/slider.lisp (original) +++ trunk/src/uitoolkit/widgets/slider.lisp Fri Sep 29 12:43:16 2006 @@ -96,3 +96,16 @@ (:ticks-before (setf std-flags (sl-ticks-before-flags std-flags))) (:tooltip (setf std-flags (sl-tooltip-flags std-flags))))) (values std-flags 0))) + +(defmethod initialize-instance :after ((self slider) &key parent &allow-other-keys) + (initialize-comctl-classes gfs::+icc-win95-classes+) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self) + (let ((hwnd (create-window (system-classname-of self) + "" + (gfs:handle parent) + std-style + ex-style + (increment-widget-id (thread-context))))) + (setf (slot-value self 'gfs:handle) hwnd) + (init-control self)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Sep 29 12:43:16 2006 @@ -174,40 +174,52 @@ :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) -(defmacro define-control-class (classname callback-event-name &optional docstring mixins) +(defmacro define-control-class (classname system-classname callback-event-name &optional docstring mixins) `(defclass ,classname `,(control ,@mixins) ((,(intern "CALLBACK-EVENT-NAME") :accessor ,(intern "CALLBACK-EVENT-NAME-OF") :initform ,callback-event-name + :allocation :class) + (,(intern "SYSTEM-CLASSNAME") + :reader ,(intern "SYSTEM-CLASSNAME-OF") + :initform ,system-classname :allocation :class)) ,(if (typep docstring 'string) `(:documentation ,docstring) `(:documentation "")))) (define-control-class button + "button" 'event-select "This class represents selectable controls that issue notifications when clicked.") (define-control-class edit + "edit" 'event-modify "This class represents a control in which the user may enter and edit text.") -(defclass label (control) () - (:documentation "This class represents non-selectable controls that display a string or image.")) +(define-control-class + label + "static" + 'event-select + "This class represents non-selectable controls that display a string or image.") (define-control-class list-box + "listbox" 'event-select "The list-box class represents a listbox control." (item-manager)) (define-control-class scrollbar + "scrollbar" 'event-select "This class represents an individual scrollbar control.") (define-control-class slider + "msctls_trackbar32" 'event-select "This class represents a slider (or trackbar) control.") Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Sep 29 12:43:16 2006 @@ -107,16 +107,6 @@ (defun shutdown (exit-code) (gfs::post-quit-message exit-code)) -(defun initialize-comctl-classes (icc-flags) - (cffi:with-foreign-object (ic-ptr 'gfs::initcommoncontrolsex) - (cffi:with-foreign-slots ((gfs::size gfs::icc) ic-ptr gfs::initcommoncontrolsex) - (setf gfs::size (cffi:foreign-type-size 'gfs::initcommoncontrolsex) - gfs::icc icc-flags)) - (if (zerop (gfs::init-common-controls ic-ptr)) - ;; returns false when called on SBCL with ICC_STANDARD_CLASSES, so - ;; this warning gets triggered a lot; need to investigate further - (warn 'gfs:win32-warning :detail "init-common-controls failed")))) - (defun create-window (class-name title parent-hwnd std-style ex-style &optional child-id) (cffi:with-foreign-string (cname-ptr class-name) (cffi:with-foreign-string (title-ptr title)

1 0

[graphic-forms-cvs] r275 - in trunk: . docs/manual src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 29 Sep '06

29 Sep '06

Author: junrue Date: Thu Sep 28 23:34:15 2006 New Revision: 275 Added: trunk/src/uitoolkit/widgets/slider.lisp Modified: trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/scrollbar.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: started work on slider control Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Thu Sep 28 23:34:15 2006 @@ -474,6 +474,47 @@ @end deffn @end-control-subclass +@begin-control-subclass{slider, +This class represents a @ref{control} having a slider component and optional +tick marks., +event-select} +@control-callback-initarg{slider,event-select} +@deffn Initarg :style +@begin-primary-style-choices{By default\, sliders are oriented horizontally +with a tick mark below the control at the beginning and end of its range.} +@item :auto-ticks +Specifies that the slider will display a tick mark for +each increment in its value range. Compare with @code{:no-ticks}. +@item :horizontal +This style keyword configures the slider to be oriented horizontally. +@item :no-ticks +Specifies that the slider will not display any tick marks. Compare +with @code{:auto-ticks}. +@item :vertical +This style keyword configures the slider to be oriented vertically. +@end-primary-style-choices +@begin-optional-style-choices +@item :constrained-range +Specifies that the slider restricts (and highlights) a subset of the +total range; the subset is indicated with triangles instead of dashes. +@item :no-border +By default, a slider is drawn with a border; this style keyword +disables that feature. +@item :ticks-after +Specifies that the slider should display its tick marks +to the right of (or below) the control. This style can +be combined with @code{:ticks-before}. +@item :ticks-before +Specifies that the slider should display its tick marks +to the left of (or above) the control. This style can +be combined with @code{:ticks-after}. +@item :tooltip +Specifies that the slider should display a +tooltip showing its current position. The side on which the +tooltip appears can be configured with @strong{FIXME} +@end-optional-style-choices +@end deffn +@end-control-subclass @node Windows and dialogs @subsection Windows and dialogs Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Sep 28 23:34:15 2006 @@ -140,6 +140,7 @@ (:file "event") (:file "scrolling-event-dispatcher") (:file "scrollbar") + (:file "slider") (:file "window") (:file "root-window") (:file "top-level") Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Sep 28 23:34:15 2006 @@ -36,21 +36,26 @@ ;;; ;;; control class names ;;; -(defparameter *button-classname* "button") -(defparameter *edit-classname* "edit") -(defparameter *listbox-classname* "listbox") -(defparameter *static-classname* "static") +(defparameter *button-classname* "button") +(defparameter *edit-classname* "edit") +(defparameter *listbox-classname* "listbox") +(defparameter *scrollbar-classname* "scrollbar") +(defparameter *static-classname* "static") +(defparameter *trackbar-classname* "msctls_trackbar32") ;;; ;;; registered message names ;;; -(defparameter *lbselchstringa* "commdlg_LBSelChangedNotify") -(defparameter *sharevistringa* "commdlg_ShareViolation") -(defparameter *fileokstringa* "commdlg_FileNameOK") -(defparameter *colorokstringa* "commdlg_ColorOK") -(defparameter *setrgbstringa* "commdlg_SetRGBColor") -(defparameter *helpmsgstringa* "commdlg_help") -(defparameter *findmsgstringa* "commdlg_FindReplace") +(defparameter *lbselchstringa* "commdlg_LBSelChangedNotify") +(defparameter *sharevistringa* "commdlg_ShareViolation") +(defparameter *fileokstringa* "commdlg_FileNameOK") +(defparameter *colorokstringa* "commdlg_ColorOK") +(defparameter *setrgbstringa* "commdlg_SetRGBColor") +(defparameter *helpmsgstringa* "commdlg_help") +(defparameter *findmsgstringa* "commdlg_FindReplace") + +(defconstant +wm-user+ #x0400) +(defconstant +wm-app+ #x8000) (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) @@ -887,6 +892,17 @@ (defconstant +sb-right+ 7) (defconstant +sb-endscroll+ 8) +(defconstant +sbs-horz+ #x0000) +(defconstant +sbs-vert+ #x0001) +(defconstant +sbs-topalign+ #x0002) +(defconstant +sbs-leftalign+ #x0002) +(defconstant +sbs-bottomalign+ #x0004) +(defconstant +sbs-rightalign+ #x0004) +(defconstant +sbs-sizeboxtopleftalign+ #x0002) +(defconstant +sbs-sizeboxbottomrightalign+ #x0004) +(defconstant +sbs-sizebox+ #x0008) +(defconstant +sbs-sizegrip+ #x0010) + (defconstant +sif-range+ #x0001) (defconstant +sif-page+ #x0002) (defconstant +sif-pos+ #x0004) @@ -1066,6 +1082,16 @@ (defconstant +sw-forceminimize+ 11) (defconstant +sw-max+ 11) +(defconstant +tb-lineup+ 0) +(defconstant +tb-linedown+ 1) +(defconstant +tb-pageup+ 2) +(defconstant +tb-pagedown+ 3) +(defconstant +tb-thumbposition+ 4) +(defconstant +tb-thumbtrack+ 5) +(defconstant +tb-top+ 6) +(defconstant +tb-bottom+ 7) +(defconstant +tb-endtrack+ 8) + (defconstant +swp-nosize+ #x0001) (defconstant +swp-nomove+ #x0002) (defconstant +swp-nozorder+ #x0004) @@ -1082,6 +1108,49 @@ (defconstant +swp-defererase+ #x2000) (defconstant +swp-asyncwindowpos+ #x4000) +(defconstant +tbm-getpos+ +wm-user+) +(defconstant +tbm-getrangemin+ (+ +wm-user+ 1)) +(defconstant +tbm-getrangemax+ (+ +wm-user+ 2)) +(defconstant +tbm-gettic+ (+ +wm-user+ 3)) +(defconstant +tbm-settic+ (+ +wm-user+ 4)) +(defconstant +tbm-setpos+ (+ +wm-user+ 5)) +(defconstant +tbm-setrange+ (+ +wm-user+ 6)) +(defconstant +tbm-setrangemin+ (+ +wm-user+ 7)) +(defconstant +tbm-setrangemax+ (+ +wm-user+ 8)) +(defconstant +tbm-cleartics+ (+ +wm-user+ 9)) +(defconstant +tbm-setsel+ (+ +wm-user+ 10)) +(defconstant +tbm-setselstart+ (+ +wm-user+ 11)) +(defconstant +tbm-setselend+ (+ +wm-user+ 12)) +(defconstant +tbm-getptics+ (+ +wm-user+ 14)) +(defconstant +tbm-getticpos+ (+ +wm-user+ 15)) +(defconstant +tbm-getnumtics+ (+ +wm-user+ 16)) +(defconstant +tbm-getselstart+ (+ +wm-user+ 17)) +(defconstant +tbm-getselend+ (+ +wm-user+ 18)) +(defconstant +tbm-clearsel+ (+ +wm-user+ 19)) +(defconstant +tbm-setticfreq+ (+ +wm-user+ 20)) +(defconstant +tbm-setpagesize+ (+ +wm-user+ 21)) +(defconstant +tbm-getpagesize+ (+ +wm-user+ 22)) +(defconstant +tbm-setlinesize+ (+ +wm-user+ 23)) +(defconstant +tbm-getlinesize+ (+ +wm-user+ 24)) +(defconstant +tbm-getthumbrect+ (+ +wm-user+ 25)) +(defconstant +tbm-getchannelrect+ (+ +wm-user+ 26)) +(defconstant +tbm-setthumblength+ (+ +wm-user+ 27)) +(defconstant +tbm-getthumblength+ (+ +wm-user+ 28)) + +(defconstant +tbs-autoticks+ #x0001) +(defconstant +tbs-vert+ #x0002) +(defconstant +tbs-horz+ #x0000) +(defconstant +tbs-top+ #x0004) +(defconstant +tbs-bottom+ #x0000) +(defconstant +tbs-left+ #x0004) +(defconstant +tbs-right+ #x0000) +(defconstant +tbs-both+ #x0008) +(defconstant +tbs-noticks+ #x0010) +(defconstant +tbs-enableselrange+ #x0020) +(defconstant +tbs-fixedlength+ #x0040) +(defconstant +tbs-nothumb+ #x0080) +(defconstant +tbs-tooltips+ #x0100) + (defconstant +tpm-leftbutton+ #x0000) (defconstant +tpm-rightbutton+ #x0002) (defconstant +tpm-leftalign+ #x0000) @@ -1256,8 +1325,6 @@ (defconstant +wm-printclient+ #x0318) (defconstant +wm-appcommand+ #x0319) (defconstant +wm-themechanged+ #x031A) -(defconstant +wm-user-base+ #x0400) -(defconstant +wm-app-base+ #x8000) (defconstant +ws-overlapped+ #x00000000) (defconstant +ws-popup+ #x80000000) Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrollbar.lisp (original) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Thu Sep 28 23:34:15 2006 @@ -173,7 +173,7 @@ (defmethod (setf step-increment) (amount (self standard-scrollbar)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (uness (>= amount 0) + (unless (>= amount 0) (warn 'gfs:toolkit-warning :detail "negative step increment")) (let ((disp (dispatcher (parent self)))) (cond Added: trunk/src/uitoolkit/widgets/slider.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/slider.lisp Thu Sep 28 23:34:15 2006 @@ -0,0 +1,98 @@ +;;;; +;;;; slider.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; helper functions +;;; + +(defun sl-auto-ticks-flags (orig-flags) + (logior (logand orig-flags (lognot gfs::+tbs-noticks+)) gfs::+tbs-autoticks+)) + +(defun sl-no-ticks-flags (orig-flags) + (setf orig-flags (logand orig-flags (lognot (logior gfs::+tbs-top+ gfs::+tbs-left+)))) + (logior (logand orig-flags (lognot gfs::+tbs-autoticks+)) gfs::+tbs-noticks+)) + +(defun sl-ticks-after-flags (orig-flags) + (setf orig-flags (logand orig-flags (lognot gfs::+tbs-both+))) + (logand orig-flags (lognot gfs::+tbs-top+))) + +(defun sl-ticks-before-flags (orig-flags) + (setf orig-flags (logand orig-flags (lognot gfs::+tbs-both+))) + (logior orig-flags gfs::+tbs-top+)) + +(defun sl-ticks-both-flags (orig-flags) + (setf orig-flags (logand orig-flags (lognot gfs::+tbs-top+))) + (logior orig-flags gfs::+tbs-both+)) + +(defun sl-horizontal-flags (orig-flags) + (logand orig-flags (lognot gfs::+tbs-vert+))) + +(defun sl-sel-range-flags (orig-flags) + (logior orig-flags gfs::+tbs-enableselrange+)) + +(defun sl-tooltip-flags (orig-flags) + (logior orig-flags gfs::+tbs-tooltips+)) + +(defun sl-vertical-flags (orig-flags) + (logior orig-flags gfs::+tbs-vert+)) + +(defun sl-no-border-flags (orig-flags) + (logand orig-flags (lognot gfs::+ws-border+))) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self slider) &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+ gfs::+ws-border+)) + (style (style-of self))) + (loop for sym in style + do (ecase sym + ;; primary slider styles + ;; + (:horizontal (setf std-flags (sl-horizontal-flags std-flags))) + (:vertical (setf std-flags (sl-vertical-flags std-flags))) + (:auto-ticks (setf std-flags (sl-auto-ticks-flags std-flags))) + (:no-ticks (setf std-flags (sl-no-ticks-flags std-flags))) + + ;; styles that can be combined + ;; + (:constrained-range (setf std-flags (sl-sel-range-flags std-flags))) + (:no-border (setf std-flags (sl-no-border-flags std-flags))) + (:ticks-after (setf std-flags (sl-ticks-after-flags std-flags))) + (:ticks-before (setf std-flags (sl-ticks-before-flags std-flags))) + (:tooltip (setf std-flags (sl-tooltip-flags std-flags))))) + (values std-flags 0))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu Sep 28 23:34:15 2006 @@ -198,7 +198,7 @@ (define-control-class list-box 'event-select - "The list-box class represents the standard listbox control." + "The list-box class represents a listbox control." (item-manager)) (define-control-class

1 0

[graphic-forms-cvs] r274 - in trunk: docs/manual src/uitoolkit/widgets
by junrue＠common-lisp.net 28 Sep '06

28 Sep '06

Author: junrue Date: Thu Sep 28 01:05:33 2006 New Revision: 274 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/uitoolkit/widgets/scrollbar.lisp trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: fixed step-size bug in compute-scrolling-delta; implemented step-increment for standard scrollbars Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Thu Sep 28 01:05:33 2006 @@ -446,6 +446,21 @@ by @ref{preferred-size}. @end deffn +@anchor{page-increment} +@deffn GenericFunction page-increment self => integer +(setf (@strong{page-increment} @var{self}) @var{integer})@* + +This function returns the amount by which the viewport origin +is incremented forward (or backward) when a user gesture causes +a scroll event of type @code{:page-forward} (or @code{:page-back}); +see @ref{event-scroll}. This value determines the size of a +proportional scrollbar's thumb. + +The @sc{setf} function sets this value. The +@ref{scrolling-event-dispatcher} class will manage this on behalf of +@ref{window}s with @emph{standard scrollbars}. +@end deffn + @anchor{parent} @deffn GenericFunction parent self => @ref{window} Returns the @code{parent} of @var{self}. In the case of @ref{panel}s @@ -602,6 +617,20 @@ parent's coordinate system. @end deffn +@anchor{step-increment} +@deffn GenericFunction step-increment self => integer +(setf (@strong{step-increment} @var{self}) @var{integer})@* + +This function returns the amount by which the viewport origin +is incremented forward (or backward) when a user gesture causes +a scroll event of type @code{:step-forward} (or @code{:step-back}); +see @ref{event-scroll}. + +The @sc{setf} function sets this value. The +@ref{scrolling-event-dispatcher} class will manage this on behalf of +@ref{window}s with @emph{standard scrollbars}. +@end deffn + @deffn GenericFunction text self => string (setf (@strong{text} @var{self}) @var{string})@* @@ -634,7 +663,8 @@ @anchor{text-modified-p} @deffn GenericFunction text-modified-p self => boolean -(setf (@strong{text-modified-p} @var{self}) @var{boolean})@*@* +(setf (@strong{text-modified-p} @var{self}) @var{boolean})@* + Returns T if the text component of @var{self} has been modified by the user; @sc{nil} otherwise. The corresponding @sc{setf} function updates the dirty state flag. This function is not implemented for all @@ -642,6 +672,28 @@ other cases there is no text component at all. @end deffn +@anchor{thumb-limits} +@deffn GenericFunction thumb-limits self => @ref{span} +(setf (@strong{thumb-limits} @var{self}) @var{span})@* + +Returns a span representing the start and end positions to which the +scrollbar @var{self} may be set. The @sc{setf} function allows this +span to be modified. Application code is responsible for managing the +thumb limits in relation to the content model that will be scrolled +within a @ref{window}. @xref{thumb-position}. +@end deffn + +@anchor{thumb-position} +@deffn GenericFunction thumb-position self => integer +(setf (@strong{thumb-position} @var{self}) @var{integer})@* + +Returns an integer value representing the position of the +scroll thumb for @var{self}. The @sc{setf} function allows +the position to be modified. A @ref{scrolling-event-dispatcher} +instance will manage the thumb position for the @ref{window} +to which it is assigned. @xref{thumb-limits}. +@end deffn + @anchor{undo-available-p} @deffn GenericFunction undo-available-p self => boolean Returns T if @var{self} has @sc{undo} capability and has an Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrollbar.lisp (original) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Thu Sep 28 01:05:33 2006 @@ -133,34 +133,86 @@ (error 'gfs:toolkit-error :detail "invalid standard scrollbar orientation"))) (setf (slot-value self 'dispatcher) nil)) ; standard scrollbars don't use dispatchers +(defmethod owner ((self standard-scrollbar)) + (parent self)) + (defmethod page-increment ((self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) (destructuring-bind (limits pagesize pos trackpos) (sb-get-info self (orientation-of self)) (declare (ignore limits pos trackpos)) pagesize)) (defmethod (setf page-increment) (amount (self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) (sb-set-page-increment self (orientation-of self) amount)) +(defmethod parent ((self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((parent (get-widget (thread-context) (gfs:handle self)))) + (unless parent + (error 'gfs:toolkit-error :detail "missing parent for standard scrollbar")) + parent)) + +(defmethod step-increment ((self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((disp (dispatcher (parent self)))) + (cond + ((typep disp 'scrolling-event-dispatcher) + (if (eql (orientation-of self) :horizontal) + (gfs:size-width (step-increments self)) + (gfs:size-height (step-increments self)))) + (t + (warn 'gfs:toolkit-warning :detail "parent dispatcher is wrong type") + 0)))) + +(defmethod (setf step-increment) (amount (self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (uness (>= amount 0) + (warn 'gfs:toolkit-warning :detail "negative step increment")) + (let ((disp (dispatcher (parent self)))) + (cond + ((typep disp 'scrolling-event-dispatcher) + (if (eql (orientation-of self) :horizontal) + (setf (gfs:size-width (step-increments self)) amount) + (setf (gfs:size-height (step-increments self)) amount))) + (t + (warn 'gfs:toolkit-warning :detail "parent dispatcher is wrong type"))))) + (defmethod thumb-limits ((self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) (destructuring-bind (limits pagesize pos trackpos) (sb-get-info self (orientation-of self)) (declare (ignore pagesize pos trackpos)) limits)) (defmethod (setf thumb-limits) (span (self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) (sb-set-thumb-limits self (orientation-of self) span)) (defmethod thumb-position ((self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) (destructuring-bind (limits pagesize pos trackpos) (sb-get-info self (orientation-of self)) (declare (ignore limits pagesize trackpos)) pos)) (defmethod (setf thumb-position) (position (self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) (sb-set-thumb-position self (orientation-of self) position)) (defmethod thumb-track-position ((self standard-scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) (destructuring-bind (limits pagesize pos trackpos) (sb-get-info self (orientation-of self)) (declare (ignore limits pagesize pos)) 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 Thu Sep 28 01:05:33 2006 @@ -48,8 +48,8 @@ (let ((new-pos (case detail (:start (gfs:span-start limits)) (:end (gfs:span-end limits)) - (:step-back (1- curr-pos)) - (:step-forward (1+ curr-pos)) + (:step-back (- curr-pos step-size)) + (:step-forward (+ curr-pos step-size)) (:page-back (- curr-pos page-size)) (:page-forward (+ curr-pos page-size)) (:thumb-position curr-pos) @@ -59,7 +59,7 @@ (- (gfs:span-end limits) (gfs:span-start limits)) page-size)) (setf (thumb-position scrollbar) new-pos) - (* (- curr-pos new-pos) step-size)))) + (- curr-pos new-pos)))) (defun update-scrolling-state (window &optional axis detail) (unless axis Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu Sep 28 01:05:33 2006 @@ -174,12 +174,6 @@ :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) -(defmacro define-callback-slot (callback-event-name) - `(,(intern "CALLBACK-EVENT-NAME") - :accessor ,(intern "CALLBACK-EVENT-NAME-OF") - :initform ,callback-event-name - :allocation :class)) - (defmacro define-control-class (classname callback-event-name &optional docstring mixins) `(defclass ,classname `,(control ,@mixins) ((,(intern "CALLBACK-EVENT-NAME")

1 0

[graphic-forms-cvs] r273 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 28 Sep '06

28 Sep '06

Author: junrue Date: Wed Sep 27 21:09:57 2006 New Revision: 273 Modified: trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: added missing defgenerics; implemented define-control-class macro; made dispatch-scroll-notification slightly nicer Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed Sep 27 21:09:57 2006 @@ -144,22 +144,23 @@ ret-val)) (defun dispatch-scroll-notification (widget axis wparam-lo) - (let ((disp (dispatcher widget))) - (case wparam-lo - (#.gfs::+sb-top+ (event-scroll disp widget axis :start)) -; (#.gfs::+sb-left+ (event-scroll disp widget axis :start)) - (#.gfs::+sb-bottom+ (event-scroll disp widget axis :end)) -; (#.gfs::+sb-right+ (event-scroll disp widget axis :end)) - (#.gfs::+sb-lineup+ (event-scroll disp widget axis :step-back)) -; (#.gfs::+sb-lineleft+ (event-scroll disp widget axis :step-back)) - (#.gfs::+sb-linedown+ (event-scroll disp widget axis :step-forward)) -; (#.gfs::+sb-lineright+ (event-scroll disp widget axis :step-forward)) - (#.gfs::+sb-pageup+ (event-scroll disp widget axis :page-back)) -; (#.gfs::+sb-pageleft+ (event-scroll disp widget axis :page-back)) - (#.gfs::+sb-pagedown+ (event-scroll disp widget axis :page-forward)) -; (#.gfs::+sb-pageright+ (event-scroll disp widget axis :page-forward)) - (#.gfs::+sb-thumbposition+ (event-scroll disp widget axis :thumb-position)) - (#.gfs::+sb-thumbtrack+ (event-scroll disp widget axis :thumb-track))))) + (let ((disp (dispatcher widget)) + (detail (case wparam-lo + (#.gfs::+sb-top+ :start) +; (#.gfs::+sb-left+ :start) + (#.gfs::+sb-bottom+ :end) +; (#.gfs::+sb-right+ :end) + (#.gfs::+sb-lineup+ :step-back) +; (#.gfs::+sb-lineleft+ :step-back) + (#.gfs::+sb-linedown+ :step-forward) +; (#.gfs::+sb-lineright+ :step-forward) + (#.gfs::+sb-pageup+ :page-back) +; (#.gfs::+sb-pageleft+ :page-back) + (#.gfs::+sb-pagedown+ :page-forward) +; (#.gfs::+sb-pageright+ :page-forward) + (#.gfs::+sb-thumbposition+ :thumb-position) + (#.gfs::+sb-thumbtrack+ :thumb-track)))) + (event-scroll disp widget axis detail))) (defun obtain-event-time () (gfs::get-message-time)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed Sep 27 21:09:57 2006 @@ -132,6 +132,24 @@ (defclass caret (widget) () (:documentation "The caret class provides an i-beam typically representing an insertion point.")) +(defclass item-manager () + ((sort-predicate + :accessor sort-predicate-of + :initarg :sort-predicate + :initform nil) + (items + ;; FIXME: allow subclasses to set initial size? + :initform (make-array 7 :fill-pointer 0 :adjustable t)) + (text-provider + :accessor text-provider-of + :initarg :text-provider + :initform nil) + (image-provider + :accessor image-provider-of + :initarg :image-provider + :initform nil)) + (:documentation "A mix-in for objects composed of sub-elements.")) + (defclass control (widget) ((brush-color :accessor brush-color-of @@ -156,23 +174,49 @@ :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) -(defclass button (control) - ((callback-event-name - :accessor callback-event-name-of - :initform 'event-select - :allocation :class)) ; shadowing same slot from event-source - (:documentation "This class represents selectable controls that issue notifications when clicked.")) - -(defclass edit (control) - ((callback-event-name - :accessor callback-event-name-of - :initform 'event-modify - :allocation :class)) ; shadowing same slot from event-source - (:documentation "This class represents a control in which the user may enter and edit text.")) +(defmacro define-callback-slot (callback-event-name) + `(,(intern "CALLBACK-EVENT-NAME") + :accessor ,(intern "CALLBACK-EVENT-NAME-OF") + :initform ,callback-event-name + :allocation :class)) + +(defmacro define-control-class (classname callback-event-name &optional docstring mixins) + `(defclass ,classname `,(control ,@mixins) + ((,(intern "CALLBACK-EVENT-NAME") + :accessor ,(intern "CALLBACK-EVENT-NAME-OF") + :initform ,callback-event-name + :allocation :class)) + ,(if (typep docstring 'string) `(:documentation ,docstring) `(:documentation "")))) + +(define-control-class + button + 'event-select + "This class represents selectable controls that issue notifications when clicked.") + +(define-control-class + edit + 'event-modify + "This class represents a control in which the user may enter and edit text.") (defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image.")) +(define-control-class + list-box + 'event-select + "The list-box class represents the standard listbox control." + (item-manager)) + +(define-control-class + scrollbar + 'event-select + "This class represents an individual scrollbar control.") + +(define-control-class + slider + 'event-select + "This class represents a slider (or trackbar) control.") + (defclass color-dialog (widget) () (:documentation "This class represents the standard color chooser dialog.")) @@ -185,31 +229,6 @@ (defclass font-dialog (widget) () (:documentation "This class represents the standard font dialog.")) -(defclass item-manager () - ((sort-predicate - :accessor sort-predicate-of - :initarg :sort-predicate - :initform nil) - (items - ;; FIXME: allow subclasses to set initial size? - :initform (make-array 7 :fill-pointer 0 :adjustable t)) - (text-provider - :accessor text-provider-of - :initarg :text-provider - :initform nil) - (image-provider - :accessor image-provider-of - :initarg :image-provider - :initform nil)) - (:documentation "A mix-in for objects composed of sub-elements.")) - -(defclass list-box (control item-manager) - ((callback-event-name - :accessor callback-event-name-of - :initform 'event-select - :allocation :class)) ; shadowing same slot from event-source - (:documentation "The list-box class represents the standard listbox control.")) - (defclass menu (widget item-manager) ((callback-event-name :accessor callback-event-name-of Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Sep 27 21:09:57 2006 @@ -282,6 +282,12 @@ (defgeneric moveable-p (self) (:documentation "Returns T if the object is moveable; nil otherwise.")) +(defgeneric obtain-horizontal-scrollbar (self) + (:documentation "Returns a scrollbar object if self has been configured to have one horizontally.")) + +(defgeneric obtain-vertical-scrollbar (self) + (:documentation "Returns a scrollbar object if self has been configured to have one horizontally.")) + (defgeneric owner (self) (:documentation "Returns self's owner (which is not necessarily the same as parent).")) @@ -291,6 +297,9 @@ (defgeneric page-increment (self) (:documentation "Return an integer representing the configured page size for the object.")) +(defgeneric (setf page-increment) (amount self) + (:documentation "Configures self's page size for scrolling.")) + (defgeneric parent (self) (:documentation "Returns the object's parent.")) @@ -379,7 +388,10 @@ (:documentation "Sets the size of self in its parent's coordinate system.")) (defgeneric step-increment (self) - (:documentation "Return an integer representing the configured step size for the object.")) + (:documentation "Return an integer representing the configured step size for self.")) + +(defgeneric (setf step-increment) (amount self) + (:documentation "Configures self's step size for scrolling.")) (defgeneric text (self) (:documentation "Returns self's text."))

1 0

[graphic-forms-cvs] r272 - in trunk/src: demos/unblocked uitoolkit/system
by junrue＠common-lisp.net 27 Sep '06

27 Sep '06

Author: junrue Date: Wed Sep 27 01:08:38 2006 New Revision: 272 Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/unblocked-controller.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp Log: generate a new set of tiles on reaching the next level; provide a bit of feedback when asked to reveal next move Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Wed Sep 27 01:08:38 2006 @@ -112,8 +112,8 @@ (unwind-protect (progn (clear-buffer self gc) - (draw-scoreboard-row gc 1 image-size label-font *score-label* value-font (game-score)) - (draw-scoreboard-row gc 0 image-size label-font *level-label* value-font (game-level)) + (draw-scoreboard-row gc 1 image-size label-font *score-label* value-font (model-score)) + (draw-scoreboard-row gc 0 image-size label-font *level-label* value-font (model-level)) (draw-scoreboard-row gc 2 image-size label-font *points-needed-label* value-font (game-points-needed))) (gfs:dispose gc)))) Modified: trunk/src/demos/unblocked/unblocked-controller.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-controller.lisp (original) +++ trunk/src/demos/unblocked/unblocked-controller.lisp Wed Sep 27 01:08:38 2006 @@ -47,13 +47,20 @@ (defun ctrl-reveal-move () (let ((shape (find-shape (model-tiles) #'accept-shape-p))) - (when shape - (let ((shape-pnts (shape-tile-points shape)) - (timer (make-instance 'gfw:timer :initial-delay +revealed-duration+ - :delay 0 - :dispatcher (gfw:dispatcher (get-unblocked-win))))) - (draw-tiles-directly (get-tiles-panel) shape-pnts +max-tile-kinds+) - (gfw:enable timer t))))) + (cond + (shape + (let ((shape-pnts (shape-tile-points shape)) + (timer (make-instance 'gfw:timer :initial-delay +revealed-duration+ + :delay 0 + :dispatcher (gfw:dispatcher (get-unblocked-win))))) + (draw-tiles-directly (get-tiles-panel) shape-pnts +max-tile-kinds+) + (gfw:enable timer t))) + (t + (gfs::message-box (gfs:handle (get-unblocked-win)) + "There are no remaining shapes." + "Sorry!" + (logior gfs::+mb-ok+ gfs::+mb-iconinformation+) + 0))))) (defun ctrl-start-selection (shape-pnts panel point button) (let* ((tiles (model-tiles)) @@ -75,8 +82,11 @@ (let ((tile-pnt (window->tiles point))) (when (and (eql button :left-button) shape-pnts) (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) - (progn - (update-model-tiles shape-pnts) + (let ((prev-level (model-level))) + (update-model-score shape-pnts) + (if (> (model-level) prev-level) + (regenerate-model-tiles) + (update-model-tiles shape-pnts)) (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) (draw-tiles-directly panel shape-pnts shape-kind))))) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Wed Sep 27 01:08:38 2006 @@ -85,21 +85,26 @@ (defun model-tiles () (active-tiles-of *game*)) +(defun update-model-score (shape-data) + (incf (score-of *game*) (* 5 (length shape-data)))) + (defun update-model-tiles (shape-data) (setf (active-tiles-of *game*) (if shape-data (progn - (incf (score-of *game*) (* 5 (length shape-data))) (loop with tmp = (clone-tiles (active-tiles-of *game*)) for pnt in shape-data do (set-tile tmp pnt 0) finally (return (collapse-tiles tmp)))) (original-tiles-of *game*)))) -(defun game-level () +(defun regenerate-model-tiles () + (setf (active-tiles-of *game*) (compute-new-game-tiles))) + +(defun model-level () (lookup-level-reached (score-of *game*))) (defun game-points-needed () - (- (nth (1- (game-level)) *points-needed-table*) (score-of *game*))) + (- (nth (1- (model-level)) *points-needed-table*) (score-of *game*))) -(defun game-score () +(defun model-score () (score-of *game*)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Sep 27 01:08:38 2006 @@ -597,6 +597,38 @@ (defconstant +lr-copyfromresource+ #x4000) (defconstant +lr-shared+ #x8000) +(defconstant +mb-ok+ #x00000000) +(defconstant +mb-okcancel+ #x00000001) +(defconstant +mb-abortretryignore+ #x00000002) +(defconstant +mb-yesnocancel+ #x00000003) +(defconstant +mb-yesno+ #x00000004) +(defconstant +mb-retrycancel+ #x00000005) +(defconstant +mb-canceltrycontinue+ #x00000006) +(defconstant +mb-iconhand+ #x00000010) +(defconstant +mb-iconquestion+ #x00000020) +(defconstant +mb-iconexclamation+ #x00000030) +(defconstant +mb-iconasterisk+ #x00000040) +(defconstant +mb-usericon+ #x00000080) +(defconstant +mb-iconwarning+ #x00000030) +(defconstant +mb-iconerror+ #x00000010) +(defconstant +mb-iconinformation+ #x00000040) +(defconstant +mb-iconstop+ #x00000010) +(defconstant +mb-defbutton1+ #x00000000) +(defconstant +mb-defbutton2+ #x00000100) +(defconstant +mb-defbutton3+ #x00000200) +(defconstant +mb-defbutton4+ #x00000300) +(defconstant +mb-applmodal+ #x00000000) +(defconstant +mb-systemmodal+ #x00001000) +(defconstant +mb-taskmodal+ #x00002000) +(defconstant +mb-help+ #x00004000) +(defconstant +mb-nofocus+ #x00008000) +(defconstant +mb-setforeground+ #x00010000) +(defconstant +mb-default-desktop-only+ #x00020000) +(defconstant +mb-topmost+ #x00040000) +(defconstant +mb-right+ #x00080000) +(defconstant +mb-rtlreading+ #x00100000) +(defconstant +mb-service-notification+ #x00200000) + (defconstant +mf-bycommand+ #x00000000) (defconstant +mf-byposition+ #x00000400) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Wed Sep 27 01:08:38 2006 @@ -570,6 +570,15 @@ (type UINT)) (defcfun + ("MessageBoxExA" message-box) + INT + (hwnd HANDLE) + (text :string) + (caption :string) + (type UINT) + (langid WORD)) + +(defcfun ("MonitorFromWindow" monitor-from-window) HANDLE (hwnd HANDLE)

1 0

[graphic-forms-cvs] r271 - in trunk: . docs/website src/demos/unblocked
by junrue＠common-lisp.net 27 Sep '06

27 Sep '06

Author: junrue Date: Tue Sep 26 22:58:14 2006 New Revision: 271 Added: trunk/src/demos/unblocked/unblocked-controller.lisp Modified: trunk/docs/website/index.html trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: separated controller code from window and panel code Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Tue Sep 26 22:58:14 2006 @@ -64,7 +64,7 @@ <ul> <li><a href="http://clisp.cons.org/">CLISP 2.38 or later</a></li> <li><a href="http://www.lispworks.com/">LispWorks 4.4.6</a></li> - <li><a href="http://sbcl.sourceforge.net/">SBCL 0.9.15</a></li> + <li><a href="http://www.sbcl.org/">SBCL 0.9.15</a></li> </ul> <p>The supported Windows versions are: Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Tue Sep 26 22:58:14 2006 @@ -75,6 +75,7 @@ :components ((:file "tiles") (:file "unblocked-model") + (:file "unblocked-controller") (:file "double-buffered-event-dispatcher") (:file "scoreboard-panel") (:file "tiles-panel") Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Tue Sep 26 22:58:14 2006 @@ -93,35 +93,21 @@ (incf kind))))) (defmethod gfw:event-mouse-down ((self tiles-panel-events) panel point button) - (let* ((tiles (game-tiles)) - (tile-pnt (window->tiles point)) - (tile-kind (obtain-tile tiles tile-pnt)) - (shape-pnts (shape-pnts-of self)) - (tmp-table (make-hash-table :test #'equalp))) - (unless (or (null shape-pnts) (find tile-pnt shape-pnts :test #'eql-point)) - (draw-tiles-directly panel shape-pnts (shape-kind-of self)) - (setf (shape-pnts-of self) nil) - (setf (shape-kind-of self) 0)) - (setf shape-pnts nil) - (if (and (eql button :left-button) (> tile-kind 0)) - (shape-tiles tiles tile-pnt tmp-table)) - (when (> (hash-table-count tmp-table) 1) - (gfw:capture-mouse panel) - (setf (shape-kind-of self) tile-kind) - (setf (shape-pnts-of self) (shape-tile-points tmp-table)) - (draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+)))) + (multiple-value-bind (shape-kind shape-pnts) + (ctrl-start-selection (shape-pnts-of self) panel point button) + (if shape-pnts + (progn + (setf (shape-kind-of self) shape-kind + (shape-pnts-of self) shape-pnts) + (gfw:capture-mouse panel)) + (progn + (draw-tiles-directly panel (shape-pnts-of self) (shape-kind-of self)) + (setf (shape-kind-of self) 0) + (setf (shape-pnts-of self) nil))))) (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel point button) (gfw:release-mouse) - (let ((tile-pnt (window->tiles point)) - (shape-pnts (shape-pnts-of self))) - (when (and (eql button :left-button) shape-pnts) - (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) - (progn - (update-game-tiles shape-pnts) - (update-panel (get-scoreboard-panel)) - (update-panel (get-tiles-panel))) - (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) + (ctrl-finish-selection (shape-pnts-of self) (shape-kind-of self) panel point button) (setf (shape-kind-of self) 0) (setf (shape-pnts-of self) nil)) @@ -132,7 +118,7 @@ (map-tiles #'(lambda (pnt kind) (unless (= kind 0) (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) - (game-tiles))))) + (model-tiles))))) (defclass tiles-panel (gfw:panel) ()) Added: trunk/src/demos/unblocked/unblocked-controller.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-controller.lisp Tue Sep 26 22:58:14 2006 @@ -0,0 +1,82 @@ +;;;; +;;;; unblocked-controller.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defconstant +revealed-duration+ 2000) ; millis + +(defun ctrl-start-game () + (model-new) + (update-panel (get-scoreboard-panel)) + (update-panel (get-tiles-panel))) + +(defun ctrl-restart-game () + (model-rollback) + (update-panel (get-scoreboard-panel)) + (update-panel (get-tiles-panel))) + +(defun ctrl-reveal-move () + (let ((shape (find-shape (model-tiles) #'accept-shape-p))) + (when shape + (let ((shape-pnts (shape-tile-points shape)) + (timer (make-instance 'gfw:timer :initial-delay +revealed-duration+ + :delay 0 + :dispatcher (gfw:dispatcher (get-unblocked-win))))) + (draw-tiles-directly (get-tiles-panel) shape-pnts +max-tile-kinds+) + (gfw:enable timer t))))) + +(defun ctrl-start-selection (shape-pnts panel point button) + (let* ((tiles (model-tiles)) + (tile-pnt (window->tiles point)) + (tile-kind (obtain-tile tiles tile-pnt)) + (tmp-table (make-hash-table :test #'equalp))) + (unless (or (null shape-pnts) (find tile-pnt shape-pnts :test #'eql-point)) + (draw-tiles-directly panel shape-pnts tile-kind)) + (if (and (eql button :left-button) (> tile-kind 0)) + (shape-tiles tiles tile-pnt tmp-table)) + (cond + ((> (hash-table-count tmp-table) 1) + (let ((shape-pnts (shape-tile-points tmp-table))) + (draw-tiles-directly panel shape-pnts +max-tile-kinds+) + (values tile-kind shape-pnts))) + (t (values nil nil))))) + +(defun ctrl-finish-selection (shape-pnts shape-kind panel point button) + (let ((tile-pnt (window->tiles point))) + (when (and (eql button :left-button) shape-pnts) + (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) + (progn + (update-model-tiles shape-pnts) + (update-panel (get-scoreboard-panel)) + (update-panel (get-tiles-panel))) + (draw-tiles-directly panel shape-pnts shape-kind))))) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Tue Sep 26 22:58:14 2006 @@ -51,6 +51,11 @@ (defun compute-new-game-tiles () (collapse-tiles (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+)))) +(defun accept-shape-p (shape) + (let ((size (shape-size shape)) + (kind (shape-kind shape))) + (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) + (defclass unblocked-game-model () ((score :accessor score-of @@ -67,20 +72,20 @@ (defvar *game* (make-instance 'unblocked-game-model)) -(defun new-game () +(defun model-new () (let ((tiles (compute-new-game-tiles))) (setf (score-of *game*) 0 (original-tiles-of *game*) tiles (active-tiles-of *game*) tiles))) -(defun restart-game () +(defun model-rollback () (setf (score-of *game*) 0 (active-tiles-of *game*) (original-tiles-of *game*))) -(defun game-tiles () +(defun model-tiles () (active-tiles-of *game*)) -(defun update-game-tiles (shape-data) +(defun update-model-tiles (shape-data) (setf (active-tiles-of *game*) (if shape-data (progn Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Tue Sep 26 22:58:14 2006 @@ -36,12 +36,13 @@ (defconstant +spacing+ 4) (defconstant +margin+ 4) -(defconstant +revealed-duration+ 2000) ; millis - (defvar *scoreboard-panel* nil) (defvar *tiles-panel* nil) (defvar *unblocked-win* nil) +(defun get-unblocked-win () + *unblocked-win*) + (defun get-tiles-panel () *tiles-panel*) @@ -50,20 +51,11 @@ (defun new-unblocked (disp item) (declare (ignore disp item)) - (new-game) - (update-panel *scoreboard-panel*) - (update-panel *tiles-panel*)) + (ctrl-start-game)) (defun restart-unblocked (disp item) (declare (ignore disp item)) - (restart-game) - (update-panel *scoreboard-panel*) - (update-panel *tiles-panel*)) - -(defun accept-shape-p (shape) - (let ((size (shape-size shape)) - (kind (shape-kind shape))) - (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) + (ctrl-restart-game)) (defun update-panel (panel) (update-buffer (gfw:dispatcher panel)) @@ -71,14 +63,7 @@ (defun reveal-unblocked (disp item) (declare (ignore disp item)) - (let ((shape (find-shape (game-tiles) #'accept-shape-p))) - (when shape - (let ((shape-pnts (shape-tile-points shape)) - (timer (make-instance 'gfw:timer :initial-delay +revealed-duration+ - :delay 0 - :dispatcher (gfw:dispatcher *unblocked-win*)))) - (draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+) - (gfw:enable timer t))))) + (ctrl-reveal-move)) (defun quit-unblocked (disp item) (declare (ignore disp item))

1 0

[graphic-forms-cvs] r270 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 26 Sep '06

26 Sep '06

Author: junrue Date: Tue Sep 26 18:12:23 2006 New Revision: 270 Modified: trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Log: update viewport size after calculating vertical scrollbar page size so that horizontal scrollbar page size takes the vertical scrollbar into account 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 Tue Sep 26 18:12:23 2006 @@ -102,14 +102,15 @@ (top (obtain-top-child window))) (let ((step-incs (step-increments disp)) (top-size (if top (size top) viewport-size))) - (update-scrollbar-page-size (obtain-horizontal-scrollbar window) - (gfs:size-width viewport-size) - (gfs:size-width top-size) - (gfs:size-width step-incs)) (update-scrollbar-page-size (obtain-vertical-scrollbar window) (gfs:size-height viewport-size) (gfs:size-height top-size) - (gfs:size-height step-incs))))) + (gfs:size-height step-incs)) + (setf viewport-size (client-size window)) + (update-scrollbar-page-size (obtain-horizontal-scrollbar window) + (gfs:size-width viewport-size) + (gfs:size-width top-size) + (gfs:size-width step-incs))))) (defun update-viewport-origin-for-resize (window) (let* ((top (obtain-top-child window)) @@ -124,7 +125,6 @@ (if (and (> delta-y 0) (> (gfs:point-y origin) 0)) (setf (gfs:point-y origin) (max 0 (- (gfs:point-y origin) delta-y))) (setf delta-y 0)) -(format t "~a~%" origin) (scroll top delta-x delta-y nil 0) origin))

1 0

[graphic-forms-cvs] r269 - trunk/src/uitoolkit/system
by junrue＠common-lisp.net 26 Sep '06

26 Sep '06

Author: junrue Date: Tue Sep 26 16:54:18 2006 New Revision: 269 Modified: trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp Log: added foreign type translators for the RECT and POINT foreign types Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Tue Sep 26 16:54:18 2006 @@ -58,15 +58,38 @@ (declare (ignore param)) (cffi:foreign-free ptr)) +(defmethod cffi:free-translated-object (ptr (name (eql 'rect-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free ptr)) + (defmethod cffi:translate-from-foreign (ptr (name (eql 'point-pointer))) - (if (null-pointer-p ptr) + (if (cffi:null-pointer-p ptr) (make-point) (cffi:with-foreign-slots ((x y) ptr point) (make-point :x x :y y)))) +(defmethod cffi:translate-from-foreign (ptr (name (eql 'rect-pointer))) + (if (cffi:null-pointer-p ptr) + (make-rectangle) + (cffi:with-foreign-slots ((left top right bottom) ptr rect) + (let ((pnt (make-point :x left :y top)) + (size (make-size :width (- right left) :height (- bottom top)))) + (make-rectangle :location pnt :size size))))) + (defmethod cffi:translate-to-foreign ((lisp-pnt point) (name (eql 'point-pointer))) (let ((ptr (cffi:foreign-alloc 'point))) (cffi:with-foreign-slots ((x y) ptr point) (setf x (point-x lisp-pnt) y (point-y lisp-pnt))) ptr)) + +(defmethod cffi:translate-to-foreign ((lisp-rect rectangle) (name (eql 'rect-pointer))) + (let ((ptr (cffi:foreign-alloc 'rect)) + (pnt (location lisp-rect)) + (size (size lisp-rect))) + (cffi:with-foreign-slots ((left top right bottom) ptr rect) + (setf left (gfs:point-x pnt) + top (gfs:point-y pnt) + right (+ (gfs:point-x pnt) (gfs:size-width size)) + bottom (+ (gfs:point-y pnt) (gfs:size-height size)))) + ptr)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Sep 26 16:54:18 2006 @@ -1277,6 +1277,15 @@ (defconstant +ws-ex-composited+ #x02000000) (defconstant +ws-ex-noactivate+ #x08000000) +(defconstant +wvr-aligntop+ #x0010) +(defconstant +wvr-alignleft+ #x0020) +(defconstant +wvr-alignbottom+ #x0040) +(defconstant +wvr-alignright+ #x0080) +(defconstant +wvr-hredraw+ #x0100) +(defconstant +wvr-vredraw+ #x0200) +(defconstant +wvr-redraw+ #x0300) +(defconstant +wvr-validrects+ #x0400) + (defconstant +white-brush+ 0) (defconstant +ltgray-brush+ 1) (defconstant +gray-brush+ 2) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Sep 26 16:54:18 2006 @@ -287,6 +287,8 @@ (incupdate BOOL) (reserved BYTE :count 32)) +(defctype rect-pointer :pointer) + (defcstruct rect (left LONG) (top LONG) @@ -300,6 +302,12 @@ (flags DWORD) (device TCHAR :count 32)) ; CCHDEVICENAME +(defcstruct nccalcsize_params + (clientnewrect rect) + (destvalidrect rect) + (srcvalidrect rect) + (lppos LPTR)) + (defcstruct openfilename (ofnsize DWORD) (ofnhwnd HANDLE) @@ -383,6 +391,15 @@ (cywinborders UINT) (wintype ATOM) (version WORD)) + +(defcstruct windowpos + (hwnd HANDLE) + (hwndafter HANDLE) + (x INT) + (y INT) + (cx INT) + (cy INT) + (flags UINT)) (defcstruct wndclassex (cbsize UINT)

1 0

[graphic-forms-cvs] r268 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 26 Sep '06

26 Sep '06

Author: junrue Date: Tue Sep 26 00:52:07 2006 New Revision: 268 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp trunk/src/uitoolkit/widgets/window.lisp Log: scrolling very close to working, but visual artifacts still produced during rapid resizing Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Tue Sep 26 00:52:07 2006 @@ -224,12 +224,12 @@ @anchor{enable-scrollbars} @deffn GenericFunction enable-scrollbars self horizontal vertical -Specifying T for @var{horizontal} (@var{vertical}) reveals a -scrollbar to attached to the right-hand (bottom) of -@var{self}. Specifying @sc{nil} hides the scrollbar. These flags do -not affect scrolling behavior in @var{self} -- they only control -scrollbar visibility. See @ref{horizontal-scrollbar-p} and -@ref{vertical-scrollbar-p}. +Specifying T for @var{horizontal} (@var{vertical}) configures @var{self} +to have a scrollbar to attached to the right-hand (bottom) edge. The +visibility of each scrollbar then depends on the scrollbar visibility +policy configured for @var{self} and the state of the scrolling +viewport. Specifying @sc{nil} forceably hides each scrollbar. +See @ref{horizontal-scrollbar-p} and @ref{vertical-scrollbar-p}. @end deffn @anchor{enabled-p} 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 Tue Sep 26 00:52:07 2006 @@ -36,7 +36,7 @@ (defconstant +grid-cell-extent+ 50) (defconstant +grid-half-extent+ 25) -(defvar *grid-model-size* (gfs:make-size :width 25 :height 16)) ; grid cells +(defvar *grid-model-size* (gfs:make-size :width 15 :height 10)) ; grid cells (defvar *grid-char-size* (gfs:make-size)) @@ -47,7 +47,8 @@ :height (1+ (* (gfs:size-height *grid-model-size*) +grid-cell-extent+)))) (panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events) :parent parent))) - (setf (gfw:maximum-size panel) panel-size) + (setf (gfw:maximum-size panel) panel-size + (gfw:minimum-size panel) panel-size) (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size))) (let ((scrollbar (gfw:obtain-horizontal-scrollbar parent))) (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (gfs:size-width panel-size)) Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Tue Sep 26 00:52:07 2006 @@ -61,7 +61,8 @@ (setf (gfw:menu-bar *scroll-tester-win*) menubar (gfw:top-child-of layout) panel (gfw:image *scroll-tester-win*) icons)) - (setf (gfw:text *scroll-tester-win*) "Scroll Tester") + (setf (gfw:text *scroll-tester-win*) "Scroll Tester" + (gfw:size *scroll-tester-win*) (gfs:make-size :width 300 :height 275)) (gfw:show *scroll-tester-win* t))) (defun scroll-tester () Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Tue Sep 26 00:52:07 2006 @@ -53,3 +53,20 @@ (defun equal-size-p (size1 size2) (and (= (size-width size1) (size-width size2)) (= (size-height size1) (size-height size2)))) + +(defmethod cffi:free-translated-object (ptr (name (eql 'point-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free ptr)) + +(defmethod cffi:translate-from-foreign (ptr (name (eql 'point-pointer))) + (if (null-pointer-p ptr) + (make-point) + (cffi:with-foreign-slots ((x y) ptr point) + (make-point :x x :y y)))) + +(defmethod cffi:translate-to-foreign ((lisp-pnt point) (name (eql 'point-pointer))) + (let ((ptr (cffi:foreign-alloc 'point))) + (cffi:with-foreign-slots ((x y) ptr point) + (setf x (point-x lisp-pnt) + y (point-y lisp-pnt))) + ptr)) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Sep 26 00:52:07 2006 @@ -275,7 +275,7 @@ ("GetWindowOrgEx" get-window-org) BOOL (hdc HANDLE) - (point LPTR)) + (point point-pointer)) (defcfun ("MaskBlt" mask-blt) @@ -434,7 +434,7 @@ (hdc HANDLE) (x INT) (y INT) - (point LPTR)) + (point point-pointer)) (defun makerop4 (fore back) (logior (logand (ash back 8) #xFF000000) fore)) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Sep 26 00:52:07 2006 @@ -255,6 +255,8 @@ (cch UINT) (hbmpitem HANDLE)) +(defctype point-pointer :pointer) + (defcstruct point (x LONG) (y LONG)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Sep 26 00:52:07 2006 @@ -377,12 +377,9 @@ (let ((parent (gfw:parent widget))) (when (and parent (typep (dispatcher parent) 'scrolling-event-dispatcher)) (let ((origin (slot-value (dispatcher parent) 'viewport-origin))) - (gfs::set-window-org (gfs:handle gc) - (- (gfs:point-x origin)) - (- (gfs:point-y origin)) - (cffi:null-pointer)) - (decf (gfs:point-x pnt) (gfs:point-x origin)) - (decf (gfs:point-y pnt) (gfs:point-y origin)))) + (set-window-origin gc origin) + (incf (gfs:point-x pnt) (gfs:point-x origin)) + (incf (gfs:point-y pnt) (gfs:point-y origin)))) (event-paint disp widget gc (gfs:make-rectangle :location pnt :size size))) (gfs:dispose gc) (gfs::end-paint hwnd ps-ptr))))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Tue Sep 26 00:52:07 2006 @@ -34,6 +34,17 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(defun obtain-top-child (window) + (let* ((layout (layout-of window)) + (top (top-child-of layout))) + (if top + top + (car (first (compute-layout layout window -1 -1)))))) + +;;; ;;; methods ;;; 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 Tue Sep 26 00:52:07 2006 @@ -66,26 +66,23 @@ (return-from update-scrolling-state nil)) (unless detail (setf detail :thumb-position)) - (let ((layout (layout-of window)) - (disp (dispatcher window))) - (unless (typep layout 'heap-layout) - (return-from update-scrolling-state nil)) - (let ((child (top-child-of (layout-of window))) + (let ((disp (dispatcher window))) + (let ((child (obtain-top-child window)) (step-incs (step-increments disp)) (delta-x 0) (delta-y 0)) (cond - ((eql axis :horizontal) + ((or (eql axis :horizontal) (eql axis :both)) (let ((scrollbar (obtain-horizontal-scrollbar window))) (setf delta-x (compute-scrolling-delta scrollbar (gfs:size-width step-incs) detail)) (gfs:dispose scrollbar))) - ((eql axis :vertical) + ((or (eql axis :vertical) (eql axis :both)) (let ((scrollbar (obtain-vertical-scrollbar window))) (setf delta-y (compute-scrolling-delta scrollbar (gfs:size-height step-incs) detail)) (gfs:dispose scrollbar)))) (let ((origin (slot-value disp 'viewport-origin))) - (incf (gfs:point-x origin) delta-x) - (incf (gfs:point-y origin) delta-y) + (decf (gfs:point-x origin) delta-x) + (decf (gfs:point-y origin) delta-y) (scroll child delta-x delta-y nil 0)))) detail) @@ -93,29 +90,43 @@ (if (or (<= (gfs:size-width amounts) 0) (<= (gfs:size-height amounts) 0)) (error 'gfs:toolkit-error :detail "invalid step increment"))) +(defun update-scrollbar-page-size (scrollbar viewport-width top-width step-size) + (if scrollbar + (setf (page-increment scrollbar) (* (1+ (min viewport-width top-width)) + step-size))) + scrollbar) + (defun update-scrollbar-page-sizes (window) (let ((disp (dispatcher window)) (viewport-size (client-size window)) - (top nil) - (scrollbar nil) - (layout (layout-of window))) - (unless (and layout (typep layout 'heap-layout)) - (return-from update-scrollbar-page-sizes nil)) - (setf top (top-child-of layout)) - (unless top - (setf top (car (first (compute-layout layout window -1 -1))))) + (top (obtain-top-child window))) (let ((step-incs (step-increments disp)) (top-size (if top (size top) viewport-size))) - (setf scrollbar (obtain-horizontal-scrollbar window)) - (if scrollbar - (setf (page-increment scrollbar) (* (1+ (min (gfs:size-width viewport-size) - (gfs:size-width top-size))) - (gfs:size-width step-incs)))) - (setf scrollbar (obtain-vertical-scrollbar window)) - (if scrollbar - (setf (page-increment scrollbar) (* (1+ (min (gfs:size-height viewport-size) - (gfs:size-height top-size))) - (gfs:size-height step-incs))))))) + (update-scrollbar-page-size (obtain-horizontal-scrollbar window) + (gfs:size-width viewport-size) + (gfs:size-width top-size) + (gfs:size-width step-incs)) + (update-scrollbar-page-size (obtain-vertical-scrollbar window) + (gfs:size-height viewport-size) + (gfs:size-height top-size) + (gfs:size-height step-incs))))) + +(defun update-viewport-origin-for-resize (window) + (let* ((top (obtain-top-child window)) + (viewport-size (client-size window)) + (top-size (if top (size top) viewport-size)) + (origin (slot-value (dispatcher window) 'viewport-origin)) + (delta-x (- (+ (gfs:size-width viewport-size) (gfs:point-x origin)) (gfs:size-width top-size))) + (delta-y (- (+ (gfs:size-height viewport-size) (gfs:point-y origin)) (gfs:size-height top-size)))) + (if (and (> delta-x 0) (> (gfs:point-x origin) 0)) + (setf (gfs:point-x origin) (max 0 (- (gfs:point-x origin) delta-x))) + (setf delta-x 0)) + (if (and (> delta-y 0) (> (gfs:point-y origin) 0)) + (setf (gfs:point-y origin) (max 0 (- (gfs:point-y origin) delta-y))) + (setf delta-y 0)) +(format t "~a~%" origin) + (scroll top delta-x delta-y nil 0) + origin)) ;;; ;;; methods @@ -124,11 +135,14 @@ (defmethod event-resize ((disp scrolling-event-dispatcher) (window window) size type) (declare (ignore size type)) (call-next-method) - (update-scrollbar-page-sizes window)) + (when (typep (layout-of window) 'heap-layout) + (update-scrollbar-page-sizes window) + (update-viewport-origin-for-resize window))) (defmethod event-scroll ((disp scrolling-event-dispatcher) (window window) axis detail) (declare (ignore disp)) - (update-scrolling-state window axis detail)) + (when (typep (layout-of window) 'heap-layout) + (update-scrolling-state window axis detail))) (defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key) (validate-step-values (step-increments self))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Sep 26 00:52:07 2006 @@ -138,6 +138,15 @@ (defun release-mouse () (gfs::release-capture)) +(defun get-window-origin (gc) + (let ((pnt (gfs:make-point))) + (gfs::get-window-org (gfs:handle gc) pnt) + pnt)) + +(defun set-window-origin (gc pnt) + (gfs::set-window-org (gfs:handle gc) (gfs:point-x pnt) (gfs:point-y pnt) (cffi:null-pointer)) + pnt) + (defun scroll-children (window delta-x delta-y) (let ((specs (mapchildren window (lambda (parent child) (declare (ignore parent)) @@ -204,14 +213,24 @@ (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) (defmethod enable-scrollbars ((self window) horizontal vertical) - (let ((bits (get-native-style self))) + (let ((style (style-of self)) + (bits (get-native-style self))) (if horizontal - (setf bits (logior bits gfs::+ws-hscroll+)) - (setf bits (logand bits (lognot gfs::+ws-hscroll+)))) + (pushnew :horizontal-scrollbar style) + (progn + (setf style (remove :horizontal-scrollbar style)) + (update-native-style self (logand bits (lognot gfs::+ws-hscroll+))))) (if vertical - (setf bits (logior bits gfs::+ws-vscroll+)) - (setf bits (logand bits (lognot gfs::+ws-vscroll+)))) - (update-native-style self bits))) + (pushnew :vertical-scrollbar style) + (progn + (setf style (remove :vertical-scrollbar style)) + (update-native-style self (logand bits (lognot gfs::+ws-vscroll+))))) + (setf (style-of self) style)) + (if (and (layout-of self) (layout-p self)) + (let ((size (client-size self))) + (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)))) + (update-scrollbar-page-sizes self) + (update-scrolling-state self :both)) (defmethod event-resize ((disp event-dispatcher) (self window) size type) (declare (ignore size type)) @@ -235,7 +254,7 @@ (gfs::set-focus (gfs:handle self))) (defmethod horizontal-scrollbar-p ((self top-level)) - (test-native-style self gfs::+ws-hscroll+)) + (find :horizontal-scrollbar (style-of self))) (defmethod image ((self window)) (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0)) @@ -322,7 +341,7 @@ (error 'gfs:disposed-error))) (defmethod obtain-horizontal-scrollbar ((self window)) - (if (test-native-style self gfs::+ws-hscroll+) + (if (horizontal-scrollbar-p self) (make-instance 'standard-scrollbar :handle (gfs:handle self) :orientation gfs::+sb-horz+))) (defmethod obtain-vertical-scrollbar :before ((self window)) @@ -330,7 +349,7 @@ (error 'gfs:disposed-error))) (defmethod obtain-vertical-scrollbar ((self window)) - (if (test-native-style self gfs::+ws-vscroll+) + (if (vertical-scrollbar-p self) (make-instance 'standard-scrollbar :handle (gfs:handle self) :orientation gfs::+sb-vert+))) (defmethod pack ((self window)) @@ -393,7 +412,7 @@ flags) (defmethod vertical-scrollbar-p ((self top-level)) - (test-native-style self gfs::+ws-vscroll+)) + (find :vertical-scrollbar (style-of self))) (defmethod window->display :before ((self window)) (if (gfs:disposed-p self)

1 0

[graphic-forms-cvs] r267 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 25 Sep '06

25 Sep '06

Author: junrue Date: Mon Sep 25 12:12:28 2006 New Revision: 267 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: some more pieces of the scrolling puzzle Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Mon Sep 25 12:12:28 2006 @@ -653,10 +653,13 @@ before this function returns. @end deffn -@defun update-scrolling-state @ref{event-dispatcher} @ref{window} &optional axis detail => symbol +@defun update-scrolling-state @ref{window} &optional axis detail => symbol Call this function to respond to a scrolling event so that the content of @var{window} can be scrolled and @var{window}'s scrollbar state(s) -updated. The @var{axis} argument can be @code{:horizontal} or @code{:vertical} +updated. The dispatcher assigned to @var{window} must be an instance of +(or an instance of a subclass of) @ref{scrolling-event-dispatcher}. + +The @var{axis} argument can be @code{:horizontal} or @code{:vertical} to request processing in the corresponding direction; or if unspecified, scroll processing will occur in both directions. The @var{detail} argument can be one of the values described for @ref{event-scroll}; or if @@ -664,7 +667,8 @@ the value of the @var{detail} argument. Note that @ref{scrolling-event-dispatcher} calls this function on -behalf of a window when set as that window's dispatcher. +behalf of a window when set as that window's dispatcher. Application +code may also call this function as needed. @end defun @anchor{update-from-items} 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 Mon Sep 25 12:12:28 2006 @@ -43,18 +43,18 @@ (defclass scroll-grid-panel-events (gfw:event-dispatcher) ()) (defun make-scroll-grid-panel (parent) - (let ((panel-size (gfs:make-size :width (* (gfs:size-width *grid-model-size*) +grid-cell-extent+) - :height (* (gfs:size-height *grid-model-size*) +grid-cell-extent+))) + (let ((panel-size (gfs:make-size :width (1+ (* (gfs:size-width *grid-model-size*) +grid-cell-extent+)) + :height (1+ (* (gfs:size-height *grid-model-size*) +grid-cell-extent+)))) (panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events) :parent parent))) (setf (gfw:maximum-size panel) panel-size) (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size))) (let ((scrollbar (gfw:obtain-horizontal-scrollbar parent))) - (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (1- (gfs:size-width panel-size))) + (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (gfs:size-width panel-size)) (gfw:thumb-position scrollbar) 0) (gfs:dispose scrollbar)) (let ((scrollbar (gfw:obtain-vertical-scrollbar parent))) - (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (1- (gfs:size-height panel-size))) + (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (gfs:size-height panel-size)) (gfw:thumb-position scrollbar) 0) (gfs:dispose scrollbar)) #| @@ -79,14 +79,13 @@ (gfg:foreground-color gc) color)) (gfg:draw-filled-rectangle gc rect) (setf (gfg:foreground-color gc) gfg:*color-black* - (gfg:pen-style gc) '(:solid :flat-endcap) - (gfg:pen-width gc) 2) + (gfg:pen-style gc) '(:solid :flat-endcap)) (let* ((pnt (gfs:location rect)) (size (gfs:size rect)) (first-row (floor (gfs:point-y pnt) +grid-cell-extent+)) - (last-row (floor (gfs:size-height size) +grid-cell-extent+)) + (last-row (floor (+ (gfs:point-y pnt) (gfs:size-height size)) +grid-cell-extent+)) (first-col (floor (gfs:point-x pnt) +grid-cell-extent+)) - (last-col (floor (gfs:size-width size) +grid-cell-extent+)) + (last-col (floor (+ (gfs:point-x pnt) (gfs:size-width size)) +grid-cell-extent+)) (lr-pnt (gfs:make-point :x (* +grid-cell-extent+ (gfs:size-width *grid-model-size*)) :y (* +grid-cell-extent+ (gfs:size-height *grid-model-size*))))) (loop for row from first-row upto last-row Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Mon Sep 25 12:12:28 2006 @@ -47,18 +47,6 @@ (declare (ignore window)) (scroll-tester-exit disp nil)) -(defmethod gfw:event-resize ((disp scroll-tester-events) window size type) - (declare (ignore size type)) - (let ((client-size (gfw:client-size window)) - (scrollbar nil)) - (setf scrollbar (gfw:obtain-horizontal-scrollbar window)) - (if scrollbar - (setf (gfw:page-increment scrollbar) (gfs:size-width client-size))) - (setf scrollbar (gfw:obtain-vertical-scrollbar window)) - (if scrollbar - (setf (gfw:page-increment scrollbar) (gfs:size-height client-size)))) - (call-next-method)) - (defun scroll-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((disp (make-instance 'scroll-tester-events)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Sep 25 12:12:28 2006 @@ -365,22 +365,27 @@ (declare (ignore wparam lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (let ((rct (gfs:make-rectangle))) - (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) - (cffi:with-foreign-slots ((gfs::rcpaint-x - gfs::rcpaint-y - gfs::rcpaint-width - gfs::rcpaint-height) - ps-ptr gfs::paintstruct) - (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) - (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x - :y gfs::rcpaint-y)) - (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width - :height gfs::rcpaint-height)) + (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) + (cffi:with-foreign-slots ((gfs::rcpaint-x gfs::rcpaint-y + gfs::rcpaint-width gfs::rcpaint-height) + ps-ptr gfs::paintstruct) + (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr))) + (pnt (gfs:make-point :x gfs::rcpaint-x :y gfs::rcpaint-y)) + (size (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) + (disp (dispatcher widget))) (unwind-protect - (event-paint (dispatcher widget) widget gc rct) + (let ((parent (gfw:parent widget))) + (when (and parent (typep (dispatcher parent) 'scrolling-event-dispatcher)) + (let ((origin (slot-value (dispatcher parent) 'viewport-origin))) + (gfs::set-window-org (gfs:handle gc) + (- (gfs:point-x origin)) + (- (gfs:point-y origin)) + (cffi:null-pointer)) + (decf (gfs:point-x pnt) (gfs:point-x origin)) + (decf (gfs:point-y pnt) (gfs:point-y origin)))) + (event-paint disp widget gc (gfs:make-rectangle :location pnt :size size))) (gfs:dispose gc) - (gfs::end-paint hwnd ps-ptr)))))) + (gfs::end-paint hwnd ps-ptr))))) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) 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 Mon Sep 25 12:12:28 2006 @@ -38,61 +38,97 @@ ;;; (defun clamp-scroll-pos (pos total-steps page-size) - (setf pos (min pos (- total-steps page-size))) + (setf pos (min pos (1+ (- total-steps page-size)))) (max pos 0)) -(defun update-scrolling-state (disp window &optional axis detail) - (unless detail - (setf detail :thumb-position)) - (unless axis - (if (horizontal-scrollbar-p window) - (update-scrolling-state disp window :horizontal detail)) - (if (vertical-scrollbar-p window) - (update-scrolling-state disp window :vertical detail)) - (return-from update-scrolling-state detail)) - (let ((scrollbar nil) - (step-incs (step-increments disp)) - (step-size 0)) - (ecase axis - (:horizontal - (setf scrollbar (obtain-horizontal-scrollbar window) - step-size (gfs:size-width step-incs))) - (:vertical - (setf scrollbar (obtain-vertical-scrollbar window) - step-size (gfs:size-height step-incs)))) - (let* ((page-size (page-increment scrollbar)) - (limits (thumb-limits scrollbar)) - (curr-pos (thumb-position scrollbar)) - (new-pos (case detail - (:start (gfs:span-start limits)) - (:end (gfs:span-end limits)) - (:step-back (- curr-pos step-size)) - (:step-forward (+ curr-pos step-size)) - (:page-back (- curr-pos page-size)) - (:page-forward (+ curr-pos page-size)) - (:thumb-position curr-pos) - (:thumb-track (thumb-track-position scrollbar)) - (otherwise curr-pos)))) +(defun compute-scrolling-delta (scrollbar step-size detail) + (let ((page-size (page-increment scrollbar)) + (limits (thumb-limits scrollbar)) + (curr-pos (thumb-position scrollbar))) + (let ((new-pos (case detail + (:start (gfs:span-start limits)) + (:end (gfs:span-end limits)) + (:step-back (1- curr-pos)) + (:step-forward (1+ curr-pos)) + (:page-back (- curr-pos page-size)) + (:page-forward (+ curr-pos page-size)) + (: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)) - (ecase axis - (:horizontal (scroll window (- new-pos curr-pos) 0 nil 0)) - (:vertical (scroll window 0 (- new-pos curr-pos) nil 0))) - (setf (thumb-position scrollbar) new-pos)) - (gfs:dispose scrollbar)) + (setf (thumb-position scrollbar) new-pos) + (* (- curr-pos new-pos) step-size)))) + +(defun update-scrolling-state (window &optional axis detail) + (unless axis + (return-from update-scrolling-state nil)) + (unless detail + (setf detail :thumb-position)) + (let ((layout (layout-of window)) + (disp (dispatcher window))) + (unless (typep layout 'heap-layout) + (return-from update-scrolling-state nil)) + (let ((child (top-child-of (layout-of window))) + (step-incs (step-increments disp)) + (delta-x 0) + (delta-y 0)) + (cond + ((eql axis :horizontal) + (let ((scrollbar (obtain-horizontal-scrollbar window))) + (setf delta-x (compute-scrolling-delta scrollbar (gfs:size-width step-incs) detail)) + (gfs:dispose scrollbar))) + ((eql axis :vertical) + (let ((scrollbar (obtain-vertical-scrollbar window))) + (setf delta-y (compute-scrolling-delta scrollbar (gfs:size-height step-incs) detail)) + (gfs:dispose scrollbar)))) + (let ((origin (slot-value disp 'viewport-origin))) + (incf (gfs:point-x origin) delta-x) + (incf (gfs:point-y origin) delta-y) + (scroll child delta-x delta-y nil 0)))) detail) -(defun validate-step-values (step-increments) - (if (or (<= (gfs:size-width step-increments) 0) (<= (gfs:size-height step-increments) 0)) +(defun validate-step-values (amounts) + (if (or (<= (gfs:size-width amounts) 0) (<= (gfs:size-height amounts) 0)) (error 'gfs:toolkit-error :detail "invalid step increment"))) +(defun update-scrollbar-page-sizes (window) + (let ((disp (dispatcher window)) + (viewport-size (client-size window)) + (top nil) + (scrollbar nil) + (layout (layout-of window))) + (unless (and layout (typep layout 'heap-layout)) + (return-from update-scrollbar-page-sizes nil)) + (setf top (top-child-of layout)) + (unless top + (setf top (car (first (compute-layout layout window -1 -1))))) + (let ((step-incs (step-increments disp)) + (top-size (if top (size top) viewport-size))) + (setf scrollbar (obtain-horizontal-scrollbar window)) + (if scrollbar + (setf (page-increment scrollbar) (* (1+ (min (gfs:size-width viewport-size) + (gfs:size-width top-size))) + (gfs:size-width step-incs)))) + (setf scrollbar (obtain-vertical-scrollbar window)) + (if scrollbar + (setf (page-increment scrollbar) (* (1+ (min (gfs:size-height viewport-size) + (gfs:size-height top-size))) + (gfs:size-height step-incs))))))) + ;;; ;;; methods ;;; +(defmethod event-resize ((disp scrolling-event-dispatcher) (window window) size type) + (declare (ignore size type)) + (call-next-method) + (update-scrollbar-page-sizes window)) + (defmethod event-scroll ((disp scrolling-event-dispatcher) (window window) axis detail) - (update-scrolling-state disp window axis detail)) + (declare (ignore disp)) + (update-scrolling-state window axis detail)) (defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key) (validate-step-values (step-increments self))) @@ -106,7 +142,3 @@ (defmethod (setf step-increment) :after (amounts (self scrolling-event-dispatcher)) (validate-step-values amounts) (setf (slot-value self 'step-increment) (gfs:copy-size amounts))) - -(defmethod (setf total-step-count) :after (amounts (self scrolling-event-dispatcher)) - (validate-step-values amounts) - (setf (slot-value self 'step-increment) (gfs:copy-size amounts))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Sep 25 12:12:28 2006 @@ -51,7 +51,9 @@ (vertical-policy :accessor vertical-policy-of :initarg :vertical-policy - :initform :always)) + :initform :always) + (viewport-origin + :initform (gfs:make-point))) (:documentation "Instances of this class manage scrolling behavior in addition to other event processing.")) (defvar *default-dispatcher* (make-instance 'event-dispatcher)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Sep 25 12:12:28 2006 @@ -358,7 +358,7 @@ (format stream "size: ~a" (size self))))) (defmethod scroll ((self window) delta-x delta-y children-p millis) - (let ((flags (logior gfs::+sw-erase+ gfs::+sw-invalidate+))) + (let ((flags gfs::+sw-invalidate+)) (if (> millis 0) (let ((tmp (ash (logand millis #xFFFF) 16))) (setf flags (logior flags tmp gfs::+sw-smoothscroll+))))

1 0

[graphic-forms-cvs] r266 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 24 Sep '06

24 Sep '06

Author: junrue Date: Sun Sep 24 02:54:04 2006 New Revision: 266 Modified: trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/scrollbar.lisp trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: more progress towards scroll-tester actually working Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Sun Sep 24 02:54:04 2006 @@ -522,6 +522,17 @@ decorations are modified appropriately. @end deffn +@anchor{scroll} +@deffn GenericFunction scroll self delta-x delta-y children-p millis +Scrolls @var{self} by a number of pixels right or down equal to the +integer values @var{delta-x} and @var{delta-y}; either delta value +may be negative in order to scroll left or up. When @var{children-p} +is non-@sc{nil}, the children of @var{self} are scrolled as well. +When @var{millis} is greater than zero, the system will animate +the scrolling operation within the specified number of milliseconds. +Paint events are delivered for the areas needing to be repainted. +@end deffn + @deffn GenericFunction select self flag Sets @var{self} to the selected state if @var{flag} is not @sc{nil} or to the unselected state if @sc{nil}. @@ -642,6 +653,20 @@ before this function returns. @end deffn +@defun update-scrolling-state @ref{event-dispatcher} @ref{window} &optional axis detail => symbol +Call this function to respond to a scrolling event so that the content +of @var{window} can be scrolled and @var{window}'s scrollbar state(s) +updated. The @var{axis} argument can be @code{:horizontal} or @code{:vertical} +to request processing in the corresponding direction; or if unspecified, +scroll processing will occur in both directions. The @var{detail} argument +can be one of the values described for @ref{event-scroll}; or if +unspecified, @code{:thumb-position} will be assumed. This function returns +the value of the @var{detail} argument. + +Note that @ref{scrolling-event-dispatcher} calls this function on +behalf of a window when set as that window's dispatcher. +@end defun + @anchor{update-from-items} @deffn GenericFunction update-from-items self Synchronizes @var{self}'s internal model (i.e., a native control's Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Sun Sep 24 02:54:04 2006 @@ -142,6 +142,39 @@ A subclass of @ref{item} representing a @ref{menu} item. @end deftp +@anchor{scrolling-event-dispatcher} +@deftp Class scrolling-event-dispatcher horizontal-policy step-increments vertical-policy +This is a subclass of @ref{event-dispatcher} that is specialized for +processing scrolling events on behalf of @ref{window}s. +@table @var +@item horizontal-policy +One of the following keyword symbols describing a scrollbar visibility +policy: +@table @code +@item :always +The scrollbar is always visible, set to a disabled state if scrolling +is unnecessary. +@item :when-needed +The scrollbar is hidden when scrolling is unnecessary. +@end table +The default policy is @code{:always} +@item step-increments +A @ref{size} object describing how many pixels a single step in either +direction will jump, by default one pixel. +@item vertical-policy +One of the following keyword symbols describing a scrollbar visibility +policy: +@table @code +@item :always +The scrollbar is always visible, set to a disabled state if scrolling +is unnecessary. +@item :when-needed +The scrollbar is hidden when scrolling is unnecessary. +@end table +The default policy is @code{:always} +@end table +@end deftp + @anchor{standard-scrollbar} @deftp Class standard-scrollbar orientation step-increment This class encapsulates a @emph{standard scrollbar}, which Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Sep 24 02:54:04 2006 @@ -264,6 +264,7 @@ #:menu-item #:panel #:root-window + #:scrolling-event-dispatcher #:timer #:top-level #:widget @@ -506,7 +507,7 @@ #:size #:spacing-of #:startup - #:step-increment + #:step-increments #:style-of #:sub-menu #:text @@ -527,6 +528,7 @@ #:trim-sizes #:undo-available-p #:update + #:update-scrolling-state #:vertical-policy-of #:visible-item-count #:visible-p 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 Sun Sep 24 02:54:04 2006 @@ -49,6 +49,14 @@ :parent parent))) (setf (gfw:maximum-size panel) panel-size) (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size))) + (let ((scrollbar (gfw:obtain-horizontal-scrollbar parent))) + (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (1- (gfs:size-width panel-size))) + (gfw:thumb-position scrollbar) 0) + (gfs:dispose scrollbar)) + (let ((scrollbar (gfw:obtain-vertical-scrollbar parent))) + (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (1- (gfs:size-height panel-size))) + (gfw:thumb-position scrollbar) 0) + (gfs:dispose scrollbar)) #| (let* ((gc (make-instance 'gfg:graphics-context :widget panel)) (font (make-instance 'gfg:font :gc gc))) Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Sun Sep 24 02:54:04 2006 @@ -41,12 +41,24 @@ (setf *scroll-tester-win* nil) (gfw:shutdown 0)) -(defclass scroll-tester-events (gfw:event-dispatcher) ()) +(defclass scroll-tester-events (gfw:scrolling-event-dispatcher) ()) (defmethod gfw:event-close ((disp scroll-tester-events) window) (declare (ignore window)) (scroll-tester-exit disp nil)) +(defmethod gfw:event-resize ((disp scroll-tester-events) window size type) + (declare (ignore size type)) + (let ((client-size (gfw:client-size window)) + (scrollbar nil)) + (setf scrollbar (gfw:obtain-horizontal-scrollbar window)) + (if scrollbar + (setf (gfw:page-increment scrollbar) (gfs:size-width client-size))) + (setf scrollbar (gfw:obtain-vertical-scrollbar window)) + (if scrollbar + (setf (gfw:page-increment scrollbar) (gfs:size-height client-size)))) + (call-next-method)) + (defun scroll-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((disp (make-instance 'scroll-tester-events)) @@ -61,6 +73,7 @@ (setf (gfw:menu-bar *scroll-tester-win*) menubar (gfw:top-child-of layout) panel (gfw:image *scroll-tester-win*) icons)) + (setf (gfw:text *scroll-tester-win*) "Scroll Tester") (gfw:show *scroll-tester-win* t))) (defun scroll-tester () Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Sep 24 02:54:04 2006 @@ -272,6 +272,12 @@ (lpm LPTR)) (defcfun + ("GetWindowOrgEx" get-window-org) + BOOL + (hdc HANDLE) + (point LPTR)) + +(defcfun ("MaskBlt" mask-blt) BOOL (hdest HANDLE) @@ -422,5 +428,13 @@ (hdc HANDLE) (color COLORREF)) +(defcfun + ("SetWindowOrgEx" set-window-org) + BOOL + (hdc HANDLE) + (x INT) + (y INT) + (point LPTR)) + (defun makerop4 (fore back) (logior (logand (ash back 8) #xFF000000) fore)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Sep 24 02:54:04 2006 @@ -1007,6 +1007,17 @@ (defconstant +stn-enable+ 2) (defconstant +stn-disable+ 3) +;;; +;;; commands for ScrollWindowEx() +;;; +(defconstant +sw-scrollchildren+ #x0001) +(defconstant +sw-invalidate+ #x0002) +(defconstant +sw-erase+ #x0004) +(defconstant +sw-smoothscroll+ #x0010) + +;;; +;;; commands for ShowWindow() +;;; (defconstant +sw-hide+ 0) (defconstant +sw-shownormal+ 1) (defconstant +sw-normal+ 1) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Sep 24 02:54:04 2006 @@ -631,6 +631,18 @@ (pnt :pointer)) (defcfun + ("ScrollWindowEx" scroll-window) + INT + (hwnd HANDLE) + (dx INT) + (dy INT) + (scrollrect LPTR) + (cliprect LPTR) + (updatergn HANDLE) + (updaterect LPTR) + (flags UINT)) + +(defcfun ("SendMessageA" send-message) LRESULT (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Sep 24 02:54:04 2006 @@ -33,12 +33,6 @@ (in-package :graphic-forms.uitoolkit.widgets) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+ - gfs::+swp-noownerzorder+ - gfs::+swp-noactivate+ - gfs::+swp-nocopybits+))) - ;;; ;;; helper functions ;;; Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrollbar.lisp (original) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Sun Sep 24 02:54:04 2006 @@ -142,10 +142,6 @@ (defmethod (setf page-increment) (amount (self standard-scrollbar)) (sb-set-page-increment self (orientation-of self) amount)) -(defmethod (setf step-increment) :after (amount (self standard-scrollbar)) - (if (< amount 0) - (warn 'gfs:toolkit-warning :detail "negative scrollbar step increment"))) - (defmethod thumb-limits ((self standard-scrollbar)) (destructuring-bind (limits pagesize pos trackpos) (sb-get-info self (orientation-of self)) 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 Sun Sep 24 02:54:04 2006 @@ -37,14 +37,76 @@ ;;; helper functions ;;; -(defun validate-scrollbar-policies (disp) - (unless (and (find (horizontal-policy-of disp) '(:always :when-needed)) - (find (vertical-policy-of disp) '(:always :when-needed))) - (error 'gfs:toolkit-error :detail "invalid scrollbar policy"))) +(defun clamp-scroll-pos (pos total-steps page-size) + (setf pos (min pos (- total-steps page-size))) + (max pos 0)) + +(defun update-scrolling-state (disp window &optional axis detail) + (unless detail + (setf detail :thumb-position)) + (unless axis + (if (horizontal-scrollbar-p window) + (update-scrolling-state disp window :horizontal detail)) + (if (vertical-scrollbar-p window) + (update-scrolling-state disp window :vertical detail)) + (return-from update-scrolling-state detail)) + (let ((scrollbar nil) + (step-incs (step-increments disp)) + (step-size 0)) + (ecase axis + (:horizontal + (setf scrollbar (obtain-horizontal-scrollbar window) + step-size (gfs:size-width step-incs))) + (:vertical + (setf scrollbar (obtain-vertical-scrollbar window) + step-size (gfs:size-height step-incs)))) + (let* ((page-size (page-increment scrollbar)) + (limits (thumb-limits scrollbar)) + (curr-pos (thumb-position scrollbar)) + (new-pos (case detail + (:start (gfs:span-start limits)) + (:end (gfs:span-end limits)) + (:step-back (- curr-pos step-size)) + (:step-forward (+ curr-pos step-size)) + (:page-back (- curr-pos page-size)) + (:page-forward (+ curr-pos page-size)) + (: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)) + (ecase axis + (:horizontal (scroll window (- new-pos curr-pos) 0 nil 0)) + (:vertical (scroll window 0 (- new-pos curr-pos) nil 0))) + (setf (thumb-position scrollbar) new-pos)) + (gfs:dispose scrollbar)) + detail) + +(defun validate-step-values (step-increments) + (if (or (<= (gfs:size-width step-increments) 0) (<= (gfs:size-height step-increments) 0)) + (error 'gfs:toolkit-error :detail "invalid step increment"))) ;;; ;;; methods ;;; +(defmethod event-scroll ((disp scrolling-event-dispatcher) (window window) axis detail) + (update-scrolling-state disp window axis detail)) + (defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key) - (validate-scrollbar-policies self)) + (validate-step-values (step-increments self))) + +(defmethod print-object ((self scrolling-event-dispatcher) stream) + (print-unreadable-object (self stream :type t) + (format stream "horizontal policy: ~a " (horizontal-policy-of self)) + (format stream "vertical policy: ~a " (vertical-policy-of self)) + (format stream "step increments: ~a" (step-increments self)))) + +(defmethod (setf step-increment) :after (amounts (self scrolling-event-dispatcher)) + (validate-step-values amounts) + (setf (slot-value self 'step-increment) (gfs:copy-size amounts))) + +(defmethod (setf total-step-count) :after (amounts (self scrolling-event-dispatcher)) + (validate-step-values amounts) + (setf (slot-value self 'step-increment) (gfs:copy-size amounts))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Sep 24 02:54:04 2006 @@ -44,6 +44,10 @@ :accessor horizontal-policy-of :initarg :horizontal-policy :initform :always) + (step-increments + :accessor step-increments + :initarg :step-increments + :initform (gfs:make-size :width 1 :height 1)) (vertical-policy :accessor vertical-policy-of :initarg :vertical-policy @@ -113,11 +117,7 @@ ((orientation :reader orientation-of :initarg :orientation - :initform nil) - (step-increment - :accessor step-increment - :initarg :step-increment - :initform 1)) + :initform nil)) (:documentation "This class encapsulates a scrollbar attached to a window.")) (defclass widget (event-source) Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Sun Sep 24 02:54:04 2006 @@ -98,4 +98,8 @@ (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) (defconstant +default-widget-width+ 64) (defconstant +default-widget-height+ 64) - (defconstant +estimated-text-size+ 32)) ; bytes + (defconstant +estimated-text-size+ 32) ; bytes + (defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+ + gfs::+swp-noownerzorder+ + gfs::+swp-noactivate+ + gfs::+swp-nocopybits+))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Sep 24 02:54:04 2006 @@ -327,8 +327,8 @@ (defgeneric retrieve-span (self) (:documentation "Returns the span object indicating the range of values that are valid for the object.")) -(defgeneric scroll (self dest-pnt src-rect children-too) - (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting.")) +(defgeneric scroll (self delta-x delta-y children-p millis) + (:documentation "Scrolls the contents of self a specified number of pixels.")) (defgeneric select (self flag) (:documentation "Set self into (or out of) the selected state.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Sep 24 02:54:04 2006 @@ -336,6 +336,11 @@ (defmethod resizable-p ((self widget)) nil) +(defmethod scroll :before ((self widget) delta-x delta-y children-p millis) + (declare (ignore delta-x delta-y children-p millis)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod select :before ((self widget) flag) (declare (ignore flag)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Sep 24 02:54:04 2006 @@ -138,6 +138,16 @@ (defun release-mouse () (gfs::release-capture)) +(defun scroll-children (window delta-x delta-y) + (let ((specs (mapchildren window (lambda (parent child) + (declare (ignore parent)) + (let ((pnt (location child)) + (size (size child))) + (incf (gfs:point-x pnt) delta-x) + (incf (gfs:point-y pnt) delta-y) + (list child (gfs:make-rectangle :location pnt :size size))))))) + (arrange-hwnds specs (lambda (child) (declare (ignore child)) +window-pos-flags+)))) + ;;; ;;; methods ;;; @@ -347,6 +357,22 @@ (if (not (gfs:disposed-p self)) (format stream "size: ~a" (size self))))) +(defmethod scroll ((self window) delta-x delta-y children-p millis) + (let ((flags (logior gfs::+sw-erase+ gfs::+sw-invalidate+))) + (if (> millis 0) + (let ((tmp (ash (logand millis #xFFFF) 16))) + (setf flags (logior flags tmp gfs::+sw-smoothscroll+)))) + (if children-p + (scroll-children self delta-x delta-y)) + (gfs::scroll-window (gfs:handle self) + delta-x + delta-y + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + flags))) + (defmethod show ((self window) flag) (declare (ignore flag)) (call-next-method)

1 0

[graphic-forms-cvs] r265 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 23 Sep '06

23 Sep '06

Author: junrue Date: Fri Sep 22 23:33:53 2006 New Revision: 265 Modified: trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/scrollbar.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: got rid of accessors for min-size and max-size slots of control and window, to further discourage direct access of those slots by application code Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Sep 22 23:33:53 2006 @@ -74,11 +74,9 @@ :initarg :actual-size :initform (gfs:make-size)) (max-size - :accessor max-size-of :initarg :max-size :initform (gfs:make-size :width +max-widget-size+ :height +max-widget-size+)) (min-size - :accessor min-size-of :initarg :min-size :initform (gfs:make-size)))) @@ -89,12 +87,12 @@ (gfs:make-point)) (defmethod gfw:minimum-size ((self mock-widget)) - (gfs:make-size :width (gfs:size-width (min-size-of self)) - :height (gfs:size-height (min-size-of self)))) + (gfs:make-size :width (gfs:size-width (slot-value self 'min-size)) + :height (gfs:size-height (slot-value self 'min-size)))) (defmethod gfw:preferred-size ((self mock-widget) width-hint height-hint) (let ((size (gfs:make-size)) - (min-size (min-size-of self))) + (min-size (slot-value self 'min-size))) (if (< width-hint 0) (setf (gfs:size-width size) (gfs:size-width min-size)) (setf (gfs:size-width size) width-hint)) @@ -104,7 +102,7 @@ size)) (defmethod gfw:text-baseline ((self mock-widget)) - (floor (* (gfs:size-height (min-size-of self)) 3) 4)) + (floor (* (gfs:size-height (slot-value self 'min-size)) 3) 4)) (defmethod gfw:visible-p ((self mock-widget)) (visibility-of self)) 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 Fri Sep 22 23:33:53 2006 @@ -48,7 +48,7 @@ (panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events) :parent parent))) (setf (gfw:maximum-size panel) panel-size) - (assert (gfs:equal-size-p panel-size (gfw::max-size-of panel))) + (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size))) #| (let* ((gc (make-instance 'gfg:graphics-context :widget panel)) (font (make-instance 'gfg:font :gc gc))) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Sep 22 23:33:53 2006 @@ -161,22 +161,22 @@ (setf (dispatcher self) (make-instance (class-name class)))))) (defmethod maximum-size ((self control)) - (max-size-of self)) + (slot-value self 'max-size)) (defmethod (setf maximum-size) (max-size (self control)) - (setf (max-size-of self) max-size) + (setf (slot-value self 'max-size) max-size) (unless (gfs:disposed-p self) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size)))) (defmethod minimum-size ((self control)) - (let ((size (min-size-of self))) + (let ((size (slot-value self 'min-size))) (if (null size) (preferred-size self -1 -1) size))) (defmethod (setf minimum-size) (min-size (self control)) - (setf (min-size-of self) min-size) + (setf (slot-value self 'min-size) min-size) (unless (gfs:disposed-p self) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size)))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Fri Sep 22 23:33:53 2006 @@ -80,8 +80,8 @@ (if spec (let ((bounds (cdr spec))) (setf (gfs:size bounds) (gfs::clamp-size (gfs:size bounds) - (min-size-of top) - (max-size-of top))) + (slot-value top 'min-size) + (slot-value top 'max-size))) (setf (cdr spec) bounds)))) (arrange-hwnds kid-specs (lambda (item) (if (eql top item) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 22 23:33:53 2006 @@ -247,8 +247,8 @@ (defmethod preferred-size ((self list-box) width-hint height-hint) (let ((hwnd (gfs:handle self)) - (min-size (min-size-of self)) - (max-size (max-size-of self)) + (min-size (slot-value self 'min-size)) + (max-size (slot-value self 'max-size)) (size (gfs:make-size :width width-hint :height height-hint)) (b-width (* (border-width self) 2))) (cond Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrollbar.lisp (original) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Fri Sep 22 23:33:53 2006 @@ -131,7 +131,7 @@ (let ((orient (orientation-of self))) (unless (or (= orient gfs::+sb-horz+) (= orient gfs::+sb-vert+)) (error 'gfs:toolkit-error :detail "invalid standard scrollbar orientation"))) - (setf (slot-value self 'dispatcher) nil)) + (setf (slot-value self 'dispatcher) nil)) ; standard scrollbars don't use dispatchers (defmethod page-increment ((self standard-scrollbar)) (destructuring-bind (limits pagesize pos trackpos) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Sep 22 23:33:53 2006 @@ -147,11 +147,9 @@ :accessor pixel-point-of :initform nil) (max-size - :accessor max-size-of :initarg :maximum-size :initform nil) (min-size - :accessor min-size-of :initarg :minimum-size :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) @@ -219,11 +217,9 @@ (defclass window (widget layout-managed) ((max-size - :accessor max-size-of :initarg :maximum-size :initform nil) (min-size - :accessor min-size-of :initarg :minimum-size :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Sep 22 23:33:53 2006 @@ -284,10 +284,10 @@ tmp))) (defmethod maximum-size ((self window)) - (max-size-of self)) + (slot-value self 'max-size)) (defmethod (setf maximum-size) (max-size (self window)) - (setf (max-size-of self) max-size) + (setf (slot-value self 'max-size) max-size) (unless (gfs:disposed-p self) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size) @@ -296,10 +296,10 @@ size))) (defmethod minimum-size ((self window)) - (min-size-of self)) + (slot-value self 'min-size)) (defmethod (setf minimum-size) (min-size (self window)) - (setf (min-size-of self) min-size) + (setf (slot-value self 'min-size) min-size) (unless (gfs:disposed-p self) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size)

1 0

[graphic-forms-cvs] r264 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 23 Sep '06

23 Sep '06

Author: junrue Date: Fri Sep 22 20:37:13 2006 New Revision: 264 Added: trunk/src/uitoolkit/widgets/scrollbar.lisp trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Modified: trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented standard scrollbar abstraction Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Fri Sep 22 20:37:13 2006 @@ -388,27 +388,27 @@ @end defun @anchor{obtain-horizontal-scrollbar} -@deffn GenericFunction obtain-horizontal-scrollbar self => widget -Returns a @ref{widget} representing the horizontal scrollbar attached +@deffn GenericFunction obtain-horizontal-scrollbar self => @ref{standard-scrollbar} +Returns an object representing the horizontal scrollbar attached to the bottom of @var{self}, if @var{self} is configured to have one and whether or not said scrollbar is currently visible; or returns @sc{nil} if @var{self} is not configured to have a horizontal scrollbar. Note that the widget returned by this function is not a @ref{control} -instance; it is instead an abstract of what is referred to in the Microsoft -documentation as a @emph{standard scrollbar}. +instance; rather, it is an abstraction of what Microsoft's documentation +refers to as a @emph{standard scrollbar}. See also @ref{obtain-vertical-scrollbar} and @ref{horizontal-scrollbar-p}. @end deffn @anchor{obtain-vertical-scrollbar} -@deffn GenericFunction obtain-vertical-scrollbar self => widget -Returns a @ref{widget} representing the vertical scrollbar attached +@deffn GenericFunction obtain-vertical-scrollbar self => @ref{standard-scrollbar} +Returns an object representing the vertical scrollbar attached to the right side of @var{self}, if @var{self} is configured to have one and whether or not said scrollbar is currently visible; or returns @sc{nil} if @var{self} is not configured to have a vertical scrollbar. Note that the widget returned by this function is not a @ref{control} -instance; it is instead an abstract of what is referred to in the Microsoft -documentation as a @emph{standard scrollbar}. +instance; rather, it is an abstraction of what Microsoft's documentation +refers to as a @emph{standard scrollbar}. See also @ref{obtain-horizontal-scrollbar} and @ref{vertical-scrollbar-p}. @end deffn Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Fri Sep 22 20:37:13 2006 @@ -142,6 +142,24 @@ A subclass of @ref{item} representing a @ref{menu} item. @end deftp +@anchor{standard-scrollbar} +@deftp Class standard-scrollbar orientation step-increment +This class encapsulates a @emph{standard scrollbar}, which +is Microsoft's term for a scrollbar-like component attached to +the right side or bottom of a window. This class is not meant +to be instantiated by application code. See @ref{obtain-horizontal-scrollbar} +and @ref{obtain-vertical-scrollbar}. +@table @var +@item orientation +This slot holds an internal value identifying this object as +either the horizontal or vertical scrollbar. +@item step-increment +This slot holds an integer value specifying how many pixels +to move the viewport when the scrollbar is stepped forward +or back. +@end table +@end deftp + @anchor{timer} @deftp Class timer id initial-delay delay A timer is a non-windowed object that generates events at a regular Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Sep 22 20:37:13 2006 @@ -138,6 +138,8 @@ (:file "menu-item") (:file "menu-language") (:file "event") + (:file "scrolling-event-dispatcher") + (:file "scrollbar") (:file "window") (:file "root-window") (:file "top-level") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Sep 22 20:37:13 2006 @@ -435,7 +435,7 @@ #:iconified-p #:id-of #:initial-delay-of - #:horizontal-scrollbar + #:horizontal-policy-of #:image #:item-count #:item-height @@ -470,7 +470,9 @@ #:obtain-chosen-color #:obtain-displays #:obtain-event-time + #:obtain-horizontal-scrollbar #:obtain-primary-display + #:obtain-vertical-scrollbar #:owner #:pack #:page-increment @@ -513,7 +515,9 @@ #:text-height #:text-limit #:text-modified-p - #:thumb-size + #:thumb-limits + #:thumb-position + #:thumb-track-position #:tooltip-text #:top-child-of #:top-index @@ -523,7 +527,7 @@ #:trim-sizes #:undo-available-p #:update - #:vertical-scrollbar + #:vertical-policy-of #:visible-item-count #:visible-p #:with-color-dialog 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 Fri Sep 22 20:37:13 2006 @@ -33,18 +33,70 @@ (in-package #:graphic-forms.uitoolkit.tests) +(defconstant +grid-cell-extent+ 50) +(defconstant +grid-half-extent+ 25) + +(defvar *grid-model-size* (gfs:make-size :width 25 :height 16)) ; grid cells + +(defvar *grid-char-size* (gfs:make-size)) + (defclass scroll-grid-panel-events (gfw:event-dispatcher) ()) (defun make-scroll-grid-panel (parent) - (let ((panel-size (gfs:make-size :width 1000 :height 800)) + (let ((panel-size (gfs:make-size :width (* (gfs:size-width *grid-model-size*) +grid-cell-extent+) + :height (* (gfs:size-height *grid-model-size*) +grid-cell-extent+))) (panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events) :parent parent))) (setf (gfw:maximum-size panel) panel-size) (assert (gfs:equal-size-p panel-size (gfw::max-size-of panel))) +#| + (let* ((gc (make-instance 'gfg:graphics-context :widget panel)) + (font (make-instance 'gfg:font :gc gc))) + (unwind-protect + (let ((metrics (gfg:metrics gc font))) + (setf (gfs:size-width *grid-char-size*) (gfg:maximum-char-width metrics) + (gfs:size-height *grid-char-size*) (+ (gfg:ascent metrics) + (gfg:descent metrics)))) + (gfs:dispose font) + (gfs:dispose gc))) +|# + (setf (gfs:size-width *grid-char-size*) (floor +grid-half-extent+ 2) + (gfs:size-height *grid-char-size*) (floor +grid-half-extent+ 2)) panel)) (defmethod gfw:event-paint ((disp scroll-grid-panel-events) window gc rect) + (declare (ignore window)) (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) (setf (gfg:background-color gc) color (gfg:foreground-color gc) color)) - (gfg:draw-filled-rectangle gc rect)) + (gfg:draw-filled-rectangle gc rect) + (setf (gfg:foreground-color gc) gfg:*color-black* + (gfg:pen-style gc) '(:solid :flat-endcap) + (gfg:pen-width gc) 2) + (let* ((pnt (gfs:location rect)) + (size (gfs:size rect)) + (first-row (floor (gfs:point-y pnt) +grid-cell-extent+)) + (last-row (floor (gfs:size-height size) +grid-cell-extent+)) + (first-col (floor (gfs:point-x pnt) +grid-cell-extent+)) + (last-col (floor (gfs:size-width size) +grid-cell-extent+)) + (lr-pnt (gfs:make-point :x (* +grid-cell-extent+ (gfs:size-width *grid-model-size*)) + :y (* +grid-cell-extent+ (gfs:size-height *grid-model-size*))))) + (loop for row from first-row upto last-row + for start-pnt = (gfs:make-point :y (* row +grid-cell-extent+)) + do (progn + (gfg:draw-line gc start-pnt (gfs:make-point :x (gfs:point-x lr-pnt) + :y (gfs:point-y start-pnt))) + (loop for col from first-col upto last-col + for text = (format nil "~d ~d" col row) + for start-pnt = (gfs:make-point :x (* col +grid-cell-extent+)) + for text-pnt = (gfs:make-point :x (+ (* col +grid-cell-extent+) + (- +grid-half-extent+ + (gfs:size-width *grid-char-size*))) + :y (+ (* row +grid-cell-extent+) + (- +grid-half-extent+ + (gfs:size-height *grid-char-size*)))) + do (progn + (if (= row first-row) + (gfg:draw-line gc start-pnt (gfs:make-point :x (gfs:point-x start-pnt) + :y (gfs:point-y lr-pnt)))) + (gfg:draw-text gc text text-pnt '(:transparent)))))))) Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Fri Sep 22 20:37:13 2006 @@ -55,7 +55,7 @@ :submenu ((:item "E&xit" :callback #'scroll-tester-exit))))))) (setf *scroll-tester-win* (make-instance 'gfw:top-level :dispatcher disp :layout layout - :style '(:workspace))) + :style '(:workspace :horizontal-scrollbar :vertical-scrollbar))) (let ((icons (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (panel (make-scroll-grid-panel *scroll-tester-win*))) (setf (gfw:menu-bar *scroll-tester-win*) menubar Added: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Fri Sep 22 20:37:13 2006 @@ -0,0 +1,175 @@ +;;;; +;;;; scrollbar.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; helper functions +;;; + +(defun validate-scrollbar-type (type) + (unless (or (= type gfs::+sb-ctl+) (= type gfs::+sb-horz+) (= type gfs::+sb-vert+)) + (error 'gfs:toolkit-error :detail "invalid scrollbar type ID"))) + +(defun sb-get-info (scrollbar type) + (if (gfs:disposed-p scrollbar) + (error 'gfs:disposed-error)) + (validate-scrollbar-type type) + (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) + 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) + gfs::pagesize + gfs::pos + gfs::trackpos))))) + +(defun sb-set-page-increment (scrollbar type amount) + (validate-scrollbar-type type) + (when (< amount 0) + (warn 'gfs:toolkit-warning :detail "negative scrollbar page increment") + (return-from sb-set-page-increment 0)) + (if (gfs:disposed-p scrollbar) + (error 'gfs:disposed-error)) + (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) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask gfs::+sif-page+ + gfs::pagesize amount)) + (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)) + (warn 'gfs:toolkit-warning :detail "negative scrollbar limit") + (return-from sb-set-thumb-limits nil)) + (if (gfs:disposed-p scrollbar) + (error 'gfs:disposed-error)) + (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::maxpos gfs::minpos) + 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::set-scroll-info hwnd type info-ptr 1))) + span) + +(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 + ;; is not cheap, whereas the application will be calling this + ;; method frequently to maintain the scrollbar's position; + ;; more thought needed. + ;; + (if (gfs:disposed-p scrollbar) + (error 'gfs:disposed-error)) + (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::pos) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask gfs::+sif-pos+ + gfs::pos position)) + (gfs::set-scroll-info hwnd type info-ptr 1))) + position) + +;;; +;;; standard scrollbar implementation +;;; + +(defmethod gfs:dispose ((self standard-scrollbar)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod initialize-instance :after ((self standard-scrollbar) &key) + (if (gfs:null-handle-p (gfs:handle self)) + (error 'gfs:disposed-error)) + (let ((orient (orientation-of self))) + (unless (or (= orient gfs::+sb-horz+) (= orient gfs::+sb-vert+)) + (error 'gfs:toolkit-error :detail "invalid standard scrollbar orientation"))) + (setf (slot-value self 'dispatcher) nil)) + +(defmethod page-increment ((self standard-scrollbar)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self (orientation-of self)) + (declare (ignore limits pos trackpos)) + pagesize)) + +(defmethod (setf page-increment) (amount (self standard-scrollbar)) + (sb-set-page-increment self (orientation-of self) amount)) + +(defmethod (setf step-increment) :after (amount (self standard-scrollbar)) + (if (< amount 0) + (warn 'gfs:toolkit-warning :detail "negative scrollbar step increment"))) + +(defmethod thumb-limits ((self standard-scrollbar)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self (orientation-of self)) + (declare (ignore pagesize pos trackpos)) + limits)) + +(defmethod (setf thumb-limits) (span (self standard-scrollbar)) + (sb-set-thumb-limits self (orientation-of self) span)) + +(defmethod thumb-position ((self standard-scrollbar)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self (orientation-of self)) + (declare (ignore limits pagesize trackpos)) + pos)) + +(defmethod (setf thumb-position) (position (self standard-scrollbar)) + (sb-set-thumb-position self (orientation-of self) position)) + +(defmethod thumb-track-position ((self standard-scrollbar)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self (orientation-of self)) + (declare (ignore limits pagesize pos)) + trackpos)) + +;;; +;;; TBD: scrollbar control implementation +;;; Added: trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Fri Sep 22 20:37:13 2006 @@ -0,0 +1,50 @@ +;;;; +;;;; scrolling-event-dispatcher.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; helper functions +;;; + +(defun validate-scrollbar-policies (disp) + (unless (and (find (horizontal-policy-of disp) '(:always :when-needed)) + (find (vertical-policy-of disp) '(:always :when-needed))) + (error 'gfs:toolkit-error :detail "invalid scrollbar policy"))) + +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key) + (validate-scrollbar-policies self)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Sep 22 20:37:13 2006 @@ -39,6 +39,17 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) +(defclass scrolling-event-dispatcher (event-dispatcher) + ((horizontal-policy + :accessor horizontal-policy-of + :initarg :horizontal-policy + :initform :always) + (vertical-policy + :accessor vertical-policy-of + :initarg :vertical-policy + :initform :always)) + (:documentation "Instances of this class manage scrolling behavior in addition to other event processing.")) + (defvar *default-dispatcher* (make-instance 'event-dispatcher)) (defclass layout-managed () @@ -98,6 +109,17 @@ (defclass menu-item (item) () (:documentation "A subclass of item representing a menu item.")) +(defclass standard-scrollbar (event-source) + ((orientation + :reader orientation-of + :initarg :orientation + :initform nil) + (step-increment + :accessor step-increment + :initarg :step-increment + :initform 1)) + (:documentation "This class encapsulates a scrollbar attached to a window.")) + (defclass widget (event-source) ((style :accessor style-of Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Sep 22 20:37:13 2006 @@ -405,8 +405,20 @@ (defgeneric (setf text-modified-p) (modified self) (:documentation "Sets self's modified flag.")) -(defgeneric thumb-size (self) - (:documentation "Returns an integer representing the width (or height) of this object's thumb.")) +(defgeneric thumb-limits (self) + (:documentation "Returns the lowest and highest allowed positions of self's thumb component.")) + +(defgeneric (setf thumb-limits) (span self) + (:documentation "Sets the lowest and highest allowed positions of self's thumb component.")) + +(defgeneric thumb-position (self) + (:documentation "Returns the position of self's thumb component.")) + +(defgeneric (setf thumb-position) (position self) + (:documentation "Sets the position of self's thumb component.")) + +(defgeneric thumb-track-position (self) + (:documentation "Returns self's current track position.")) (defgeneric tooltip-text (self) (:documentation "Returns the text that will appear within a tooltip when the mouse hovers over this object.")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Sep 22 20:37:13 2006 @@ -307,6 +307,22 @@ (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))) size))) +(defmethod obtain-horizontal-scrollbar :before ((self window)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod obtain-horizontal-scrollbar ((self window)) + (if (test-native-style self gfs::+ws-hscroll+) + (make-instance 'standard-scrollbar :handle (gfs:handle self) :orientation gfs::+sb-horz+))) + +(defmethod obtain-vertical-scrollbar :before ((self window)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod obtain-vertical-scrollbar ((self window)) + (if (test-native-style self gfs::+ws-vscroll+) + (make-instance 'standard-scrollbar :handle (gfs:handle self) :orientation gfs::+sb-vert+))) + (defmethod pack ((self window)) (unless (null (layout-of self)) (perform (layout-of self) self -1 -1))

1 0

[graphic-forms-cvs] r263 - in trunk: . src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 22 Sep '06

22 Sep '06

Author: junrue Date: Thu Sep 21 20:48:28 2006 New Revision: 263 Added: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Modified: trunk/NEWS.txt trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed bugs in setf of minimum and maximum sizes for windows; improved heap-layout such that it obeys the top child min and max sizes if any Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Thu Sep 21 20:48:28 2006 @@ -14,6 +14,15 @@ Additional list box control features will be provided in a future release. +. Implemented scrolling support: + + * new window styles :horizontal-scrollbar and :vertical-scrollbar + + * new event-scroll method for handling raw scrolling events + +. Improved GFW:HEAP-LAYOUT such that it obeys the top child's minimum and + maximum sizes, if any such sizes are set. + . Did some housecleaning of the item-manager protocol and heavily refactored the implementation of item-manager base functionality. @@ -23,6 +32,14 @@ . Fixed a silly bug in GFW:CHECKED-P (and GFW:SELECTED-P) for checkbox and radio button -style buttons. +. Fixed another silly bug, this one in the initialization of the paint + rectangle in the WM_PAINT message handling method; the correct rectangle + is now passed to GFW:EVENT-PAINT + +. Fixed a bug in the SETF methods for GFW:MAXIMUM-SIZE and GFW:MINIMUM-SIZE + for windows whereby the size value was not being set in the appropriate + slot if there were no layout set for the window. + ============================================================================== Release 0.5.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Thu Sep 21 20:48:28 2006 @@ -90,5 +90,6 @@ (:file "image-tester") (:file "drawing-tester") (:file "widget-tester") + (:file "scroll-grid-panel") (:file "scroll-tester") (:file "windlg"))))))))) Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Thu Sep 21 20:48:28 2006 @@ -187,3 +187,26 @@ (assert-false (gfs::remove-elements tmp (gfs:make-span :start 0 :end 0) #'reaam-test-make-array)))) + +(define-test clamp-size-test + (let ((min-size (gfs:make-size :width 10 :height 10)) + (max-size (gfs:make-size :width 100 :height 100)) + (test-sizes (loop for width in '(5 10 50 100 150) + for height in '(10 5 100 50 150) + collect (gfs:make-size :width width :height height))) + (expected-sizes-1 (loop for width in '(10 10 50 100 100) + for height in '(10 10 100 50 100) + collect (gfs:make-size :width width :height height))) + (expected-sizes-2 (loop for width in '(5 10 50 100 100) + for height in '(10 5 100 50 100) + collect (gfs:make-size :width width :height height))) + (expected-sizes-3 (loop for width in '(10 10 50 100 150) + for height in '(10 10 100 50 150) + collect (gfs:make-size :width width :height height)))) + (loop for min-size-1 in (list min-size nil min-size nil) + for max-size-1 in (list max-size max-size nil nil) + for exp-list in (list expected-sizes-1 expected-sizes-2 expected-sizes-3 test-sizes) + do (loop for test-size in test-sizes + for exp-size in exp-list + do (let ((clamped-size (gfs::clamp-size test-size min-size-1 max-size-1))) + (assert-true (gfs:equal-size-p exp-size clamped-size) exp-size test-size)))))) Added: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Thu Sep 21 20:48:28 2006 @@ -0,0 +1,50 @@ +;;;; +;;;; scroll-grid-panel.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + +(defclass scroll-grid-panel-events (gfw:event-dispatcher) ()) + +(defun make-scroll-grid-panel (parent) + (let ((panel-size (gfs:make-size :width 1000 :height 800)) + (panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events) + :parent parent))) + (setf (gfw:maximum-size panel) panel-size) + (assert (gfs:equal-size-p panel-size (gfw::max-size-of panel))) + panel)) + +(defmethod gfw:event-paint ((disp scroll-grid-panel-events) window gc rect) + (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (gfg:draw-filled-rectangle gc rect)) Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Thu Sep 21 20:48:28 2006 @@ -47,31 +47,18 @@ (declare (ignore window)) (scroll-tester-exit disp nil)) -(defclass scroll-panel-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-paint ((disp scroll-panel-events) window gc rect) - (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) - (setf (gfg:background-color gc) color - (gfg:foreground-color gc) color)) - (gfg:draw-filled-rectangle gc rect)) - (defun scroll-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((disp (make-instance 'scroll-tester-events)) - (panel-disp (make-instance 'scroll-panel-events)) (layout (make-instance 'gfw:heap-layout)) (menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'scroll-tester-exit))))))) (setf *scroll-tester-win* (make-instance 'gfw:top-level :dispatcher disp :layout layout - :style '(:frame))) + :style '(:workspace))) (let ((icons (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) - (panel (make-instance 'gfw:panel :dispatcher panel-disp - :parent *scroll-tester-win*)) - (panel-size (gfs:make-size :width 200 :height 200))) - (setf (gfw:minimum-size panel) panel-size - (gfw:maximum-size panel) panel-size - (gfw:menu-bar *scroll-tester-win*) menubar + (panel (make-scroll-grid-panel *scroll-tester-win*))) + (setf (gfw:menu-bar *scroll-tester-win*) menubar (gfw:top-child-of layout) panel (gfw:image *scroll-tester-win*) icons)) (gfw:show *scroll-tester-win* t))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Thu Sep 21 20:48:28 2006 @@ -115,6 +115,21 @@ (list tree) (mapcan (function flatten) tree))) +(defun clamp-size (proposed-size min-size max-size) + (let ((clamped-size (make-size :width (gfs:size-width proposed-size) + :height (gfs:size-height proposed-size)))) + (when min-size + (if (< (gfs:size-width proposed-size) (gfs:size-width min-size)) + (setf (gfs:size-width clamped-size) (gfs:size-width min-size))) + (if (< (gfs:size-height proposed-size) (gfs:size-height min-size)) + (setf (gfs:size-height clamped-size) (gfs:size-height min-size)))) + (when max-size + (if (> (gfs:size-width proposed-size) (gfs:size-width max-size)) + (setf (gfs:size-width clamped-size) (gfs:size-width max-size))) + (if (> (gfs:size-height proposed-size) (gfs:size-height max-size)) + (setf (gfs:size-height clamped-size) (gfs:size-height max-size)))) + clamped-size)) + ;;; lifted from lispbuilder-windows/windows/util.lisp ;;; author: Frank Buss ;;; Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Thu Sep 21 20:48:28 2006 @@ -164,8 +164,8 @@ (max-size-of self)) (defmethod (setf maximum-size) (max-size (self control)) + (setf (max-size-of self) max-size) (unless (gfs:disposed-p self) - (setf (max-size-of self) max-size) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size)))) @@ -176,8 +176,8 @@ size))) (defmethod (setf minimum-size) (min-size (self control)) + (setf (min-size-of self) min-size) (unless (gfs:disposed-p self) - (setf (min-size-of self) min-size) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size)))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Thu Sep 21 20:48:28 2006 @@ -72,8 +72,17 @@ (if (layout-p container) (let ((top (top-child-of self)) (kid-specs (compute-layout self container width-hint height-hint))) - (unless top - (setf top (car (first kid-specs)))) + (let ((spec (if top + (find-if (lambda (x) (eql x top)) kid-specs :key #'car) + (progn + (setf top (car (first kid-specs))) + (first kid-specs))))) + (if spec + (let ((bounds (cdr spec))) + (setf (gfs:size bounds) (gfs::clamp-size (gfs:size bounds) + (min-size-of top) + (max-size-of top))) + (setf (cdr spec) bounds)))) (arrange-hwnds kid-specs (lambda (item) (if (eql top item) (logior +window-pos-flags+ gfs::+swp-showwindow+) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Sep 21 20:48:28 2006 @@ -287,22 +287,24 @@ (max-size-of self)) (defmethod (setf maximum-size) (max-size (self window)) - (unless (or (gfs:disposed-p self) (null (layout-of self))) - (setf (max-size-of self) max-size) + (setf (max-size-of self) max-size) + (unless (gfs:disposed-p self) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size) - (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)) + (unless (null (layout-of self)) + (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))) size))) (defmethod minimum-size ((self window)) (min-size-of self)) (defmethod (setf minimum-size) (min-size (self window)) - (unless (or (gfs:disposed-p self) (null (layout-of self))) - (setf (min-size-of self) min-size) + (setf (min-size-of self) min-size) + (unless (gfs:disposed-p self) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size) - (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)) + (unless (null (layout-of self)) + (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))) size))) (defmethod pack ((self window))

1 0

[graphic-forms-cvs] r262 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 21 Sep '06

21 Sep '06

Author: junrue Date: Thu Sep 21 16:58:29 2006 New Revision: 262 Added: trunk/src/tests/uitoolkit/scroll-tester.lisp Modified: trunk/docs/manual/widget-functions.texinfo trunk/graphic-forms-tests.asd trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed a silly WM_PAINT handling bug in initializing the paint rect; small improvement to window print-object; other miscellaneous tweaks Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Thu Sep 21 16:58:29 2006 @@ -271,7 +271,8 @@ @anchor{horizontal-scrollbar-p} @deffn GenericFunction horizontal-scrollbar-p self => boolean Returns T if @var{self} has been configured to display a horizontal -scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. +scrollbar, even if said scrollbar is not currently visible; or +returns @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @deffn GenericFunction image self => @ref{image} @@ -386,6 +387,32 @@ of these is the primary @ref{display}. @end defun +@anchor{obtain-horizontal-scrollbar} +@deffn GenericFunction obtain-horizontal-scrollbar self => widget +Returns a @ref{widget} representing the horizontal scrollbar attached +to the bottom of @var{self}, if @var{self} is configured to have one +and whether or not said scrollbar is currently visible; or returns +@sc{nil} if @var{self} is not configured to have a horizontal scrollbar. +Note that the widget returned by this function is not a @ref{control} +instance; it is instead an abstract of what is referred to in the Microsoft +documentation as a @emph{standard scrollbar}. + +See also @ref{obtain-vertical-scrollbar} and @ref{horizontal-scrollbar-p}. +@end deffn + +@anchor{obtain-vertical-scrollbar} +@deffn GenericFunction obtain-vertical-scrollbar self => widget +Returns a @ref{widget} representing the vertical scrollbar attached +to the right side of @var{self}, if @var{self} is configured to have one +and whether or not said scrollbar is currently visible; or returns +@sc{nil} if @var{self} is not configured to have a vertical scrollbar. +Note that the widget returned by this function is not a @ref{control} +instance; it is instead an abstract of what is referred to in the Microsoft +documentation as a @emph{standard scrollbar}. + +See also @ref{obtain-horizontal-scrollbar} and @ref{vertical-scrollbar-p}. +@end deffn + @anchor{obtain-primary-display} @defun obtain-primary-display => @ref{display} Return a display object that is regarded by the system as @@ -638,7 +665,8 @@ @anchor{vertical-scrollbar-p} @deffn GenericFunction vertical-scrollbar-p self => boolean Returns T if @var{self} has been configured to display a vertical -scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. +scrollbar, even if said scrollbar is not currently visible; or +returns @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @deffn GenericFunction visible-p self Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Thu Sep 21 16:58:29 2006 @@ -42,6 +42,7 @@ #:hello-world #:image-tester #:layout-tester + #:scroll-tester #:widget-tester #:textedit #:unblocked @@ -89,4 +90,5 @@ (:file "image-tester") (:file "drawing-tester") (:file "widget-tester") + (:file "scroll-tester") (:file "windlg"))))))))) Added: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Thu Sep 21 16:58:29 2006 @@ -0,0 +1,80 @@ +;;;; +;;;; scroll-tester.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + +(defvar *scroll-tester-win* nil) + +(defun scroll-tester-exit (disp item) + (declare (ignore disp item)) + (gfs:dispose *scroll-tester-win*) + (setf *scroll-tester-win* nil) + (gfw:shutdown 0)) + +(defclass scroll-tester-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp scroll-tester-events) window) + (declare (ignore window)) + (scroll-tester-exit disp nil)) + +(defclass scroll-panel-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-paint ((disp scroll-panel-events) window gc rect) + (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (gfg:draw-filled-rectangle gc rect)) + +(defun scroll-tester-internal () + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) + (let ((disp (make-instance 'scroll-tester-events)) + (panel-disp (make-instance 'scroll-panel-events)) + (layout (make-instance 'gfw:heap-layout)) + (menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'scroll-tester-exit))))))) + (setf *scroll-tester-win* (make-instance 'gfw:top-level :dispatcher disp + :layout layout + :style '(:frame))) + (let ((icons (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) + (panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent *scroll-tester-win*)) + (panel-size (gfs:make-size :width 200 :height 200))) + (setf (gfw:minimum-size panel) panel-size + (gfw:maximum-size panel) panel-size + (gfw:menu-bar *scroll-tester-win*) menubar + (gfw:top-child-of layout) panel + (gfw:image *scroll-tester-win*) icons)) + (gfw:show *scroll-tester-win* t))) + +(defun scroll-tester () + (gfw:startup "Scroll Tester" #'scroll-tester-internal)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Sep 21 16:58:29 2006 @@ -372,11 +372,11 @@ gfs::rcpaint-width gfs::rcpaint-height) ps-ptr gfs::paintstruct) - (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x - :y gfs::rcpaint-y)) - (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width - :height gfs::rcpaint-height)) (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) + (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x + :y gfs::rcpaint-y)) + (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width + :height gfs::rcpaint-height)) (unwind-protect (event-paint (dispatcher widget) widget gc rct) (gfs:dispose gc) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Sep 21 16:58:29 2006 @@ -193,12 +193,6 @@ (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod event-resize ((disp event-dispatcher) (self window) size type) - (declare (ignore size type)) - (unless (null (layout-of self)) - (let ((sz (client-size self))) - (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) - (defmethod enable-scrollbars ((self window) horizontal vertical) (let ((bits (get-native-style self))) (if horizontal @@ -209,6 +203,12 @@ (setf bits (logand bits (lognot gfs::+ws-vscroll+)))) (update-native-style self bits))) +(defmethod event-resize ((disp event-dispatcher) (self window) size type) + (declare (ignore size type)) + (unless (null (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) + (defmethod focus-p :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -326,7 +326,8 @@ (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "size: ~a" (size self)))) + (if (not (gfs:disposed-p self)) + (format stream "size: ~a" (size self))))) (defmethod show ((self window) flag) (declare (ignore flag))

1 0

[graphic-forms-cvs] r261 - trunk/docs/website
by junrue＠common-lisp.net 14 Sep '06

14 Sep '06

Author: junrue Date: Thu Sep 14 00:46:04 2006 New Revision: 261 Modified: trunk/docs/website/download.html trunk/docs/website/index.html Log: website tweak Modified: trunk/docs/website/download.html ============================================================================== --- trunk/docs/website/download.html (original) +++ trunk/docs/website/download.html Thu Sep 14 00:46:04 2006 @@ -2,7 +2,7 @@ <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> <head> - <title>Graphic-Forms Source Control</title> + <title>Graphic-Forms Downloads</title> <link rel="stylesheet" type="text/css" href="style.css" /> <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" /> </head> @@ -10,7 +10,7 @@ <body> <div class="header"> - <h3>Graphic-Forms downloads</h3> + <h3>Graphic-Forms Downloads</h3> </div> <p>Graphic-Forms is distributed in source code form. Please choose from @@ -19,8 +19,7 @@ <ul> <li> <a href="http://sourceforge.net/project/showfiles.php?group_id=163034">Download</a> - a release tarball. File hosting courtesy of - <a href="http://sourceforge.net"><IMG src="http://sourceforge.net/sflogo.php?group_id=20959" width="88" height="31" border="0" alt="SourceForge Logo"></a><p/> + a release tarball.<p/> </li> <li> <a href="http://common-lisp.net/faq.shtml">Download</a> Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Thu Sep 14 00:46:04 2006 @@ -91,6 +91,8 @@ LispWorks is a trademark of <a href="http://www.lispworks.com/">LispWorks Ltd</a>. All other trademarks used are owned by their respective owners.</p> + <a href="http://sourceforge.net"><IMG src="http://sourceforge.net/sflogo.php?group_id=20959" width="88" height="31" border="0" alt="SourceForge Logo"></a><p/> + <div class="footer"> <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a>

1 0

[graphic-forms-cvs] r260 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 14 Sep '06

14 Sep '06

Author: junrue Date: Wed Sep 13 23:44:06 2006 New Revision: 260 Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: added some missing scrollbar-related methods to window Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Sep 13 23:44:06 2006 @@ -192,7 +192,7 @@ (defgeneric header-visible-p (self) (:documentation "Returns T if the object's header is visible; nil otherwise.")) -(defgeneric horizontal-scrollbar (self) +(defgeneric horizontal-scrollbar-p (self) (:documentation "Returns T if this object currently has a horizontal scrollbar; nil otherwise.")) (defgeneric iconify (self flag) @@ -432,7 +432,7 @@ (defgeneric update-native-style (self flags) (:documentation "Modifies self's native style flags and refreshes self's visual appearance.")) -(defgeneric vertical-scrollbar (self) +(defgeneric vertical-scrollbar-p (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise.")) (defgeneric visible-item-count (self) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed Sep 13 23:44:06 2006 @@ -206,9 +206,21 @@ (if flag (redraw self))) +(defmethod enable-scrollbars :before ((self widget) horizontal vertical) + (declare (ignore horizontal vertical)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod enabled-p ((self widget)) (/= (gfs::is-window-enabled (gfs:handle self)) 0)) +(defmethod horizontal-scrollbar-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod horizontal-scrollbar-p ((self widget)) + nil) + (defmethod image :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -430,6 +442,13 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) +(defmethod vertical-scrollbar-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod vertical-scrollbar-p ((self widget)) + nil) + (defmethod visible-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed Sep 13 23:44:06 2006 @@ -193,12 +193,22 @@ (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod event-resize ((d event-dispatcher) (self window) size type) +(defmethod event-resize ((disp event-dispatcher) (self window) size type) (declare (ignore size type)) (unless (null (layout-of self)) (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) +(defmethod enable-scrollbars ((self window) horizontal vertical) + (let ((bits (get-native-style self))) + (if horizontal + (setf bits (logior bits gfs::+ws-hscroll+)) + (setf bits (logand bits (lognot gfs::+ws-hscroll+)))) + (if vertical + (setf bits (logior bits gfs::+ws-vscroll+)) + (setf bits (logand bits (lognot gfs::+ws-vscroll+)))) + (update-native-style self bits))) + (defmethod focus-p :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -214,6 +224,9 @@ (defmethod give-focus ((self window)) (gfs::set-focus (gfs:handle self))) +(defmethod horizontal-scrollbar-p ((self top-level)) + (test-native-style self gfs::+ws-hscroll+)) + (defmethod image ((self window)) (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0)) (large (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-big+ 0)) @@ -334,6 +347,9 @@ gfs::+swp-nozorder+))) flags) +(defmethod vertical-scrollbar-p ((self top-level)) + (test-native-style self gfs::+ws-vscroll+)) + (defmethod window->display :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

1 0

[graphic-forms-cvs] r259 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 12 Sep '06

12 Sep '06

Author: junrue Date: Tue Sep 12 01:35:09 2006 New Revision: 259 Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: added scroll event testing to event-tester Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Tue Sep 12 01:35:09 2006 @@ -157,6 +157,14 @@ @end table @end macro +@macro window-scrollbar-style{orientation,location} +@item :\orientation\-scrollbar +This style keyword configures a window to have a \orientation\ +scrollbar attached on the \location\. This style is a prerequisite +for scrolling functionality. The visibility policy for the scrollbar +can be configured via FIXME FIXME +@end macro + @c ==========================End Macros ============================= @copying Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Tue Sep 12 01:35:09 2006 @@ -702,6 +702,14 @@ This initarg is used to specify the @ref{parent} window of the panel. @end deffn +@deffn Initarg :style +@begin-primary-style-choices{} +@item :border +This style keyword causes the panel to maintain a thin border. +@window-scrollbar-style{horizontal,bottom} +@window-scrollbar-style{vertical,right} +@end-primary-style-choices +@end deffn @end deftp @anchor{root-window} @@ -728,10 +736,12 @@ @anchor{top-level} @deftp Class top-level -Base class for @ref{window}s that are self-contained and parented to +This class represents @ref{window}s that are self-contained and parented to the @ref{root-window}. Except when created with the @code{:borderless} or @code{:palette} styles, they are resizable and have title bars -(also called @samp{captions}). +(also called @samp{captions}). They may have scrollbars if either of the +@code{:horizontal-scrollbar} or @code{:vertical-scrollbar} styles are +specified, with further control over scrollbar visibility being possible. @deffn Initarg :maximum-size Sets the maximum @ref{size} to which the user may adjust the boundaries of the window. @@ -765,9 +775,11 @@ using the @sc{color_appworkspace} Win32 color scheme. @end-primary-style-choices @begin-optional-style-choices +@window-scrollbar-style{horizontal,bottom} @item :keyboard-navigation Enables keyboard traversal of controls within the @code{window} as if it were a @ref{dialog}. +@window-scrollbar-style{vertical,right} @end-optional-style-choices @end deffn @end deftp Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Sep 12 01:35:09 2006 @@ -416,6 +416,7 @@ #:event-pre-move #:event-pre-resize #:event-resize + #:event-scroll #:event-select #:event-session #:event-timer Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Sep 12 01:35:09 2006 @@ -59,6 +59,45 @@ (declare (ignore widget)) (exit-event-tester)) +(defun initialize-scrollbars () + ;; yucky test code to set scrollbar parameters -- this + ;; is not how applications will be expected to do it. + ;; + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::maxpos gfs::pagesize) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask (logior gfs::+sif-page+ gfs::+sif-range+ gfs::+sif-disablenoscroll+) + gfs::maxpos 500 + gfs::pagesize 50)) + (gfs::set-scroll-info (gfs:handle *event-tester-window*) gfs::+sb-horz+ info-ptr 0) + (gfs::set-scroll-info (gfs:handle *event-tester-window*) gfs::+sb-vert+ info-ptr 0))) + +(defun update-scrollbars (axis detail) + ;; yucky test code to set scrollbar parameters -- this + ;; is not how applications will be expected to do it. + ;; + (let ((which-sb (if (eql axis :vertical) gfs::+sb-vert+ gfs::+sb-horz+)) + (hwnd (gfs:handle *event-tester-window*))) + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pos gfs::pagesize + gfs::minpos 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 which-sb info-ptr) + (case detail + (:start (setf gfs::pos gfs::minpos)) + (:end (setf gfs::pos gfs::maxpos)) + (:step-back (setf gfs::pos (- gfs::pos 5))) + (:step-forward (setf gfs::pos (+ gfs::pos 5))) + (:page-back (setf gfs::pos (- gfs::pos gfs::pagesize))) + (:page-forward (setf gfs::pos (+ gfs::pos gfs::pagesize))) + (:thumb-track (setf gfs::pos gfs::trackpos))) + (gfs::set-scroll-info hwnd which-sb info-ptr 1))))) + (defun text-for-modifiers () (format nil "~:[SHIFT~;~] ~:[CTRL~;~] ~:[ALT~;~] ~:[L-WIN~;~] ~:[R-WIN~;~] ~:[ESC~;~] ~:[CAPSLOCK~;~] ~:[NUMLOCK~;~] ~:[SCROLLOCK~;~]" @@ -137,6 +176,15 @@ (gfw:obtain-event-time) (text-for-modifiers))) +(defun text-for-scroll (axis detail) + (format nil + "~a scroll: ~s detail: ~s time: 0x~x ~s" + (incf *event-counter*) + axis + detail + (gfw:obtain-event-time) + (text-for-modifiers))) + (defmethod gfw:event-activate ((d event-tester-window-events) window) (setf *event-tester-text* (text-for-activation "window activated")) (gfw:redraw window)) @@ -174,13 +222,16 @@ (defmethod gfw:event-move ((d event-tester-window-events) window pnt) (setf *event-tester-text* (text-for-move pnt)) - (gfw:redraw window) - 0) + (gfw:redraw window)) (defmethod gfw:event-resize ((d event-tester-window-events) window size type) (setf *event-tester-text* (text-for-size type size)) - (gfw:redraw window) - 0) + (gfw:redraw window)) + +(defmethod gfw:event-scroll ((d event-tester-window-events) window axis detail) + (update-scrollbars axis detail) + (setf *event-tester-text* (text-for-scroll axis detail)) + (gfw:redraw window)) (defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ()) @@ -240,7 +291,8 @@ (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) - :style '(:workspace))) + :style '(:workspace :horizontal-scrollbar :vertical-scrollbar))) + (initialize-scrollbars) (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu :submenu ((:item "Timer" :callback #'manage-timer) (:item "" :separator) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Sep 12 01:35:09 2006 @@ -834,6 +834,11 @@ (defconstant +ps-geometric+ #x00010000) (defconstant +ps-type-mask+ #x000f0000) +(defconstant +sb-horz+ 0) +(defconstant +sb-vert+ 1) +(defconstant +sb-ctl+ 2) +(defconstant +sb-both+ 3) + (defconstant +sb-lineup+ 0) (defconstant +sb-lineleft+ 0) (defconstant +sb-linedown+ 1) @@ -850,6 +855,13 @@ (defconstant +sb-right+ 7) (defconstant +sb-endscroll+ 8) +(defconstant +sif-range+ #x0001) +(defconstant +sif-page+ #x0002) +(defconstant +sif-pos+ #x0004) +(defconstant +sif-disablenoscroll+ #x0008) +(defconstant +sif-trackpos+ #x0010) +(defconstant +sif-all+ #x0017) + (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1) (defconstant +size-maximized+ 2) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Sep 12 01:35:09 2006 @@ -329,6 +329,15 @@ (rgbred BYTE) (rgbreserved BYTE)) +(defcstruct scrollinfo + (cbsize UINT) + (fmask UINT) + (minpos INT) + (maxpos INT) + (pagesize UINT) + (pos INT) + (trackpos INT)) + (defcstruct size (cx LONG) (cy LONG)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Sep 12 01:35:09 2006 @@ -436,6 +436,13 @@ (hwnd HANDLE)) (defcfun + ("GetScrollInfo" get-scroll-info) + BOOL + (hwnd HANDLE) + (bar INT) + (info LPTR)) + +(defcfun ("GetSubMenu" get-submenu) HANDLE (hwnd HANDLE) @@ -667,6 +674,14 @@ (item-info LPTR)) (defcfun + ("SetScrollInfo" set-scroll-info) + INT + (hwnd HANDLE) + (bar INT) + (info LPTR) + (redraw BOOL)) + +(defcfun ("SetTimer" set-timer) UINT (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Sep 12 01:35:09 2006 @@ -143,9 +143,9 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) -(defun dispatch-scroll-notification (widget axis wparam-hi) +(defun dispatch-scroll-notification (widget axis wparam-lo) (let ((disp (dispatcher widget))) - (case wparam-hi + (case wparam-lo (#.gfs::+sb-top+ (event-scroll disp widget axis :start)) ; (#.gfs::+sb-left+ (event-scroll disp widget axis :start)) (#.gfs::+sb-bottom+ (event-scroll disp widget axis :end)) @@ -351,14 +351,14 @@ (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (dispatch-scroll-notification widget :horizontal (hi-word wparam)))) + (dispatch-scroll-notification widget :horizontal (lo-word wparam)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-vscroll+)) wparam lparam) (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (dispatch-scroll-notification widget :vertical (hi-word wparam)))) + (dispatch-scroll-notification widget :vertical (lo-word wparam)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Tue Sep 12 01:35:09 2006 @@ -56,13 +56,16 @@ (defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags +default-child-style+)) - (mapc #'(lambda (sym) - (cond + (loop for sym in (style-of self) + do (ecase sym ;; styles that can be combined ;; - ((eq sym :border) - (setf std-flags (logior std-flags gfs::+ws-border+))))) - (style-of self)) + (:border + (setf std-flags (logior std-flags gfs::+ws-border+))) + (:horizontal-scrollbar + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:vertical-scrollbar + (setf std-flags (logior std-flags gfs::+ws-vscroll+))))) (values std-flags gfs::+ws-ex-controlparent+))) (defmethod initialize-instance :after ((self panel) &key parent &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Sep 12 01:35:09 2006 @@ -68,47 +68,28 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) &rest extra-data) +(defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) (ex-flags 0)) - (mapc #'(lambda (sym) - (cond - ;; styles that can be combined - ;; -#| - ((eq sym :hscroll) - (setf std-flags (logior std-flags gfs::+ws-hscroll+))) - ((eq sym :max) - (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :min) - (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :sysmenu) - (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :title) - (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :top) - (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) - ((eq sym :vscroll) - (setf std-flags (logior std-flags gfs::+ws-vscroll+))) -|# - - ;; pre-packaged combinations of window styles - ;; - ((eq sym :borderless) + (loop for sym in (style-of self) + do (ecase sym + ;; pre-packaged combinations of window styles + ;; + (:borderless (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-border+ gfs::+ws-popup+)) (setf ex-flags gfs::+ws-ex-topmost+)) - ((eq sym :palette) + (:palette (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popupwindow+ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-toolwindow+ gfs::+ws-ex-windowedge+))) - ((eq sym :miniframe) + (:miniframe (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popup+ @@ -117,22 +98,40 @@ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-appwindow+ gfs::+ws-ex-toolwindow+))) - ((or (eq sym :workspace) (eq sym :frame)) + (:frame + (setf std-flags (logior gfs::+ws-overlappedwindow+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+)) + (setf ex-flags 0)) + (:workspace (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) - (setf ex-flags 0)))) - (style-of win)) + (setf ex-flags 0)) + + ;; styles that can be combined + ;; +#| + (:max (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) + (:min (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) + (:sysmenu (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) + (:title (setf std-flags (logior std-flags gfs::+ws-caption+))) + (:top (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) +|# + (:horizontal-scrollbar + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:vertical-scrollbar + (setf std-flags (logior std-flags gfs::+ws-vscroll+))))) (values std-flags ex-flags))) -(defmethod gfs:dispose ((win top-level)) - (let ((m (menu-bar win))) +(defmethod gfs:dispose ((self top-level)) + (let ((m (menu-bar self))) (unless (null m) (visit-menu-tree m #'menu-cleanup-callback) (delete-widget (thread-context) (gfs:handle m)))) (call-next-method)) -(defmethod initialize-instance :after ((win top-level) &key owner text &allow-other-keys) +(defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) @@ -140,21 +139,21 @@ (setf text *default-window-title*)) (let ((classname *toplevel-noerasebkgnd-window-classname*) (register-func #'register-toplevel-noerasebkgnd-window-class)) - (when (find :workspace (style-of win)) + (when (find :workspace (style-of self)) (setf classname *toplevel-erasebkgnd-window-classname*) (setf register-func #'register-toplevel-erasebkgnd-window-class)) - (init-window win classname register-func owner text))) + (init-window self classname register-func owner text))) (defmethod (setf maximum-size) :after (max-size (self top-level)) (when (and max-size (minimum-size self)) (update-top-level-resizability self (gfs:equal-size-p (minimum-size self) max-size)))) -(defmethod menu-bar :before ((win top-level)) - (if (gfs:disposed-p win) +(defmethod menu-bar :before ((self top-level)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod menu-bar ((win top-level)) - (let ((hmenu (gfs::get-menu (gfs:handle win)))) +(defmethod menu-bar ((self top-level)) + (let ((hmenu (gfs::get-menu (gfs:handle self)))) (if (gfs:null-handle-p hmenu) (return-from menu-bar nil)) (let ((m (get-widget (thread-context) hmenu))) @@ -162,13 +161,13 @@ (error 'gfs:toolkit-error :detail "no object for menu handle")) m))) -(defmethod (setf menu-bar) :before ((m menu) (win top-level)) +(defmethod (setf menu-bar) :before ((m menu) (self top-level)) (declare (ignore m)) - (if (gfs:disposed-p win) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf menu-bar) ((m menu) (win top-level)) - (let* ((hwnd (gfs:handle win)) +(defmethod (setf menu-bar) ((m menu) (self top-level)) + (let* ((hwnd (gfs:handle self)) (hmenu (gfs::get-menu hwnd)) (old-menu (get-widget (thread-context) hmenu))) (unless (gfs:null-handle-p hmenu)

1 0

[graphic-forms-cvs] r258 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 12 Sep '06

12 Sep '06

Author: junrue Date: Mon Sep 11 23:04:31 2006 New Revision: 258 Modified: trunk/docs/manual/event-functions.texinfo trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/list-box.lisp Log: implemented and documented event-scroll generic function as first stage of implementing general scrolling support; renamed list-box style :vertical-scrollbar to :scrollbar-always to reflect that this is a policy style Modified: trunk/docs/manual/event-functions.texinfo ============================================================================== --- trunk/docs/manual/event-functions.texinfo (original) +++ trunk/docs/manual/event-functions.texinfo Mon Sep 11 23:04:31 2006 @@ -271,6 +271,62 @@ @end table @end deffn +@anchor{event-scroll} +@deffn GenericFunction event-scroll @ref{event-dispatcher} @ref{widget} axis detail +Implement this method to handle scrolling notifications for @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} that was scrolled. +@item axis +The scrolling orientation, identified by one of the following +keyword symbols:@*@* +@table @code +@item :horizontal +Indicates that scrolling is occurring in the horizontal axis. +@item :vertical +Indicates that scrolling is occurring in the vertical axis. +@end table +@item detail +The specific scrolling request, identified by one of the +following keyword symbols:@*@* +@table @code +@item :end +The bottom or right-most content is revealed. +@item :page-back +The viewport is moved backward towards content start by +an amount equal to the viewport's height or width, or +the amount remaining between the viewport's origin +and the start, whichever is smaller. +@item :page-forward +The viewport is moved forward towards content end by +an amount equal to the viewport's height or width, or +the amount remaining between the viewport's origin +and the end, whichever is smaller. +@item :start +The viewport is moved such that the top or left-most +content edge is revealed. +@item :step-back +The viewport is moved backward towards content start by +an application-defined increment, or the amount +remaining between the viewport's origin and the start, +whichever is smaller. +@item :step-forward +The viewport is moved forward towards content end by an +application-defined increment, or the amount +remaining between the viewport's origina and the end, +whichever is smaller. +@item :thumb-position +Indicates an absolute position to which the viewport origin +is moved, as when the user releases the mouse button from a +scrollbar thumb. +@item :thumb-track +Indicates that the user is adjusting the position of the +viewport continuously, as when dragging a scrollbar thumb. +@end table +@end table +@end deffn + @anchor{event-select} @deffn GenericFunction event-select @ref{event-dispatcher} @ref{widget} Implement this method to handle notification that @var{widget} (or some Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Mon Sep 11 23:04:31 2006 @@ -136,6 +136,27 @@ @end deftp @end macro +@macro begin-primary-style-choices{defaultdesc} +The @code{:style} initarg is a list of keywords that define the +look-and-feel of the widget being created. \defaultdesc\ +Applications may choose from one of the following primary styles: +@table @code +@end macro + +@macro end-primary-style-choices +@end table +@end macro + +@macro begin-optional-style-choices +One or more of the following optional style keyword(s) may be +specified in the style keyword list: +@table @code +@end macro + +@macro end-optional-style-choices +@end table +@end macro + @c ==========================End Macros ============================= @copying Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Sep 11 23:04:31 2006 @@ -185,7 +185,8 @@ @end deffn @control-parent-initarg{button} @deffn Initarg :style -@table @code +@begin-primary-style-choices{The @code{:push-button} style is the +default.} @item :cancel-button Placing a @code{:cancel-button} in a @ref{dialog} enables the @sc{escape} key @ref{accelerator} for dismissing the dialog. This @@ -218,7 +219,7 @@ This style specifies a control that looks similar to a @code{:check-box}, but the box can be grayed as well as checked or cleared. The grayed look is used to indicate an undetermined state. -@end table +@end-primary-style-choices @end deffn @deffn Initarg :text Supplies the text for the button label. @@ -279,7 +280,7 @@ @control-callback-initarg{edit,event-modify} @control-parent-initarg{edit} @deffn Initarg :style -@table @code +@begin-optional-style-choices @item :auto-hscroll Specifies that the edit control will scroll text content to the right by 10 characters when the user types a character at the end @@ -323,7 +324,7 @@ style is also specified. Without this style, within a dialog the act of typing @sc{enter} has the same effect as pressing the dialog's default button. -@end table +@end-optional-style-choices @end deffn @deffn Initarg :text Supplies the initial text for the edit control. @@ -394,7 +395,8 @@ @end deffn @control-parent-initarg{list-box} @deffn Initarg :style -@table @code +@begin-primary-style-choices{By default\, a single item may be +selected at a time.} @item :extend-select This style keyword causes the list-box to allow multiple items to be selected by use of the @sc{shift} key and the mouse or special @@ -405,20 +407,19 @@ @item :no-select This style keyword means that the list-box will display items but not allow any selections. -@item :single-select -This style keyword means that the list-box only allows one item at a -time to be selected. This is the default selection style. +@end-primary-style-choices +@begin-optional-style-choices +@item :scrollbar-always +This style keyword causes the list-box to show a disabled vertical +scrollbar when it does not contain enough items to scroll. Otherwise +in such a case, the scrollbar will be hidden until needed. @item :tab-stops This style keyword configures the list-box to to expand tab characters when rendering item strings. @item :want-keys This style keyword allows the application to perform special processing when the list-box has focus and the user presses a key. -@item :want-scrollbar -This style keyword causes the list-box to show a disabled vertical -scrollbar when it does not contain enough items to scroll. Otherwise -in such a case, the scrollbar will be hidden. -@end table +@end-optional-style-choices @end deffn @end-control-subclass @@ -453,8 +454,8 @@ @ref{window} or a dialog. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols: -@table @code +@begin-primary-style-choices{By default\, the dialog does not +show the custom colors interface.} @item :allow-custom-colors This configures the dialog to enable the Define Custom Color button, which when clicked reveals additional controls for @@ -462,7 +463,7 @@ @item :display-solid-only This configures the dialog to only display solid colors in the set of basic colors. -@end table +@end-primary-style-choices @end deffn @end deftp @@ -484,7 +485,7 @@ @sc{nil} for the owner. @end deffn @deffn Initarg :style -@table @code +@begin-primary-style-choices{} @item :application-modal Specifies that the dialog is @emph{modal} with respect to all @ref{top-level} windows and @ref{dialog}s created by the application @@ -498,7 +499,7 @@ Specifies that the dialog is @emph{modal} only in relation to its @ref{owner} (which could be a window or another dialog). This style is the default if no style keywords are specified. -@end table +@end-primary-style-choices @end deffn @deffn Initarg :text Specifies the dialog's title. @@ -566,31 +567,32 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols: -@table @code +@begin-primary-style-choices{} +@item :open +This configures the dialog to be used to select one or more files +for loading data. +@item :save +This configures the dialog to be used to specify a destination file +for data to be saved. +@end-primary-style-choices +@begin-optional-style-choices @item :add-to-recent This enables the system to add a link to the selected file in the directory that contains the user's most recently used documents. @item :multiple-select This configures the dialog to accept multiple selections. -@item :open -This configures the dialog to be used to select one or more files -for loading data. @item :path-must-exist This keyword enables a validation check that constrains the user's selection to file paths that actually exist. A warning dialog will be displayed if the user supplies a non-existent path. -@item :save -This configures the dialog to be used to specify a destination file -for data to be saved. @item :show-hidden This keyword enables the dialog to display files marked @sc{hidden} by the system. @strong{Note:} files marked both @sc{hidden} and @sc{system} will not be displayed in any case. Also, be aware that using this keyword effectively overrides the user's preference settings. -@end table +@end-optional-style-choices @end deffn @deffn Initarg :text This initarg accepts a string that will become the title of the file @@ -636,8 +638,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols: -@table @code +@begin-primary-style-choices{} @item :all-fonts This is a convenience style, used by default if no other font criteria are specified, that enables the dialog to offer all @@ -659,7 +660,7 @@ Enables the dialog to offer the intersection of the sets of fonts available on the screen and the printer associated with the graphics-context specified by the @code{:gc} initarg. -@end table +@end-primary-style-choices @end deffn @end deftp @@ -728,8 +729,9 @@ @anchor{top-level} @deftp Class top-level Base class for @ref{window}s that are self-contained and parented to -the @ref{root-window}. Except for the @code{:palette} style, they are -normally resizable and have title bars (also called 'captions'). +the @ref{root-window}. Except when created with the @code{:borderless} +or @code{:palette} styles, they are resizable and have title bars +(also called @samp{captions}). @deffn Initarg :maximum-size Sets the maximum @ref{size} to which the user may adjust the boundaries of the window. @@ -739,10 +741,7 @@ boundaries of the window. @end deffn @deffn Initarg :style -The @code{:style} initarg is a list of keywords that define the overall -look-and-feel of the window being created. Applications may choose -from one of the following primary styles: -@table @code +@begin-primary-style-choices{} @item :borderless Specifies a window with a one-pixel border (so not really @emph{borderless} in the strictest sense); no frame icon, system menu, minimize/maximize @@ -764,13 +763,12 @@ and minimize/maximize buttons; this window type is resizable; it differs from the @code{:frame} style in that the system paints the background using the @sc{color_appworkspace} Win32 color scheme. -@end table -The following style keyword(s) may also be included: -@table @code +@end-primary-style-choices +@begin-optional-style-choices @item :keyboard-navigation Enables keyboard traversal of controls within the @code{window} as if it were a @ref{dialog}. -@end table +@end-optional-style-choices @end deffn @end deftp Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Mon Sep 11 23:04:31 2006 @@ -191,7 +191,7 @@ (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel :callback lb2-callback - :style '(:extend-select :want-scrollbar) + :style '(:extend-select :scrollbar-always) :items (subseq *list-box-test-data* 4))) (gfw:pack lb2-panel) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Mon Sep 11 23:04:31 2006 @@ -834,6 +834,22 @@ (defconstant +ps-geometric+ #x00010000) (defconstant +ps-type-mask+ #x000f0000) +(defconstant +sb-lineup+ 0) +(defconstant +sb-lineleft+ 0) +(defconstant +sb-linedown+ 1) +(defconstant +sb-lineright+ 1) +(defconstant +sb-pageup+ 2) +(defconstant +sb-pageleft+ 2) +(defconstant +sb-pagedown+ 3) +(defconstant +sb-pageright+ 3) +(defconstant +sb-thumbposition+ 4) +(defconstant +sb-thumbtrack+ 5) +(defconstant +sb-top+ 6) +(defconstant +sb-left+ 6) +(defconstant +sb-bottom+ 7) +(defconstant +sb-right+ 7) +(defconstant +sb-endscroll+ 8) + (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1) (defconstant +size-maximized+ 2) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Mon Sep 11 23:04:31 2006 @@ -174,10 +174,15 @@ (declare (ignorable dispatcher widget)))) (defgeneric event-resize (dispatcher widget size type) - (:documentation "Implement this to respond to an object being resized.") + (:documentation "Implement this to respond to widget being resized.") (:method (dispatcher widget size type) (declare (ignorable dispatcher widget size type)))) +(defgeneric event-scroll (dispatcher widget axis detail) + (:documentation "Implement this to respond to scrolling within widget.") + (:method (dispatcher widget axis detail) + (declare (ignorable dispatcher widget axis detail)))) + (defgeneric event-select (dispatcher item) (:documentation "Implement this to respond to an object (or item within) being selected.") (:method (dispatcher item) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Sep 11 23:04:31 2006 @@ -117,7 +117,7 @@ (cffi:pointer-address (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed"))) -(defun dispatch-notification (widget wparam-hi) +(defun dispatch-control-notification (widget wparam-hi) (let ((disp (dispatcher widget))) (case wparam-hi (0 (event-select disp widget)) @@ -143,6 +143,24 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) +(defun dispatch-scroll-notification (widget axis wparam-hi) + (let ((disp (dispatcher widget))) + (case wparam-hi + (#.gfs::+sb-top+ (event-scroll disp widget axis :start)) +; (#.gfs::+sb-left+ (event-scroll disp widget axis :start)) + (#.gfs::+sb-bottom+ (event-scroll disp widget axis :end)) +; (#.gfs::+sb-right+ (event-scroll disp widget axis :end)) + (#.gfs::+sb-lineup+ (event-scroll disp widget axis :step-back)) +; (#.gfs::+sb-lineleft+ (event-scroll disp widget axis :step-back)) + (#.gfs::+sb-linedown+ (event-scroll disp widget axis :step-forward)) +; (#.gfs::+sb-lineright+ (event-scroll disp widget axis :step-forward)) + (#.gfs::+sb-pageup+ (event-scroll disp widget axis :page-back)) +; (#.gfs::+sb-pageleft+ (event-scroll disp widget axis :page-back)) + (#.gfs::+sb-pagedown+ (event-scroll disp widget axis :page-forward)) +; (#.gfs::+sb-pageright+ (event-scroll disp widget axis :page-forward)) + (#.gfs::+sb-thumbposition+ (event-scroll disp widget axis :thumb-position)) + (#.gfs::+sb-thumbtrack+ (event-scroll disp widget axis :thumb-track))))) + (defun obtain-event-time () (gfs::get-message-time)) @@ -191,7 +209,7 @@ (event-select (dispatcher item) item)))) (let ((widget (get-widget tc (cffi:make-pointer lparam)))) (when (and widget (dispatcher widget)) - (dispatch-notification widget wparam-hi)))) + (dispatch-control-notification widget wparam-hi)))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) @@ -329,10 +347,23 @@ 1 0))) +(defmethod process-message (hwnd (msg (eql gfs::+wm-hscroll+)) wparam lparam) + (declare (ignore lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (dispatch-scroll-notification widget :horizontal (hi-word wparam)))) + 0) + +(defmethod process-message (hwnd (msg (eql gfs::+wm-vscroll+)) wparam lparam) + (declare (ignore lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (dispatch-scroll-notification widget :vertical (hi-word wparam)))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) (declare (ignore wparam lparam)) - (let* ((tc (thread-context)) - (widget (get-widget tc hwnd))) + (let ((widget (get-widget (thread-context) hwnd))) (if widget (let ((rct (gfs:make-rectangle))) (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Mon Sep 11 23:04:31 2006 @@ -189,16 +189,16 @@ do (ecase sym ;; primary list-box styles ;; - (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) - (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) - (:no-select (setf std-flags (lb-no-select-flags std-flags))) - (:single-select (setf std-flags (lb-single-select-flags std-flags))) + (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) + (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) + (:no-select (setf std-flags (lb-no-select-flags std-flags))) + (:single-select (setf std-flags (lb-single-select-flags std-flags))) ;; styles that can be combined ;; - (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) - (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) - (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) + (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) + (:scrollbar-always (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))) + (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))))) (values std-flags 0))) (defmethod delete-all ((self list-box))

1 0

[graphic-forms-cvs] r257 - in trunk: docs/manual src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 11 Sep '06

11 Sep '06

Author: junrue Date: Mon Sep 11 16:30:56 2006 New Revision: 257 Modified: trunk/docs/manual/event-functions.texinfo trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: account for menu wrapping in window compute-outer-size Modified: trunk/docs/manual/event-functions.texinfo ============================================================================== --- trunk/docs/manual/event-functions.texinfo (original) +++ trunk/docs/manual/event-functions.texinfo Mon Sep 11 16:30:56 2006 @@ -239,10 +239,10 @@ @event-dispatcher-arg @item widget The @ref{widget} whose contents need to be repainted. -@item gc +@item graphics-context A @ref{graphics-context} initialized for use during this paint event and which will be @ref{dispose}d after this method returns. -@item rect +@item rectangle The specific @ref{rectangle} within @var{widget} needing to be repainted. @end table @end deffn Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Sep 11 16:30:56 2006 @@ -175,8 +175,8 @@ (setf gfs::tablength tab-width) (setf gfs::leftmargin 0) (setf gfs::rightmargin 0) - (gfs::with-rect - (gfs::draw-text-ex hdc str -1 gfs::rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) + (gfs::with-rect (rect-ptr) + (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) (setf (gfs:size-width sz) (- gfs::right gfs::left)) (setf (gfs:size-height sz) (- gfs::bottom gfs::top)))))) (when (or (zerop len) (zerop (gfs:size-height sz))) @@ -292,7 +292,7 @@ (let ((hdc (gfs:handle self)) (pnt (gfs:location rect)) (size (gfs:size rect))) - (gfs::with-rect + (gfs::with-rect (rect-ptr) (setf gfs::top (gfs:point-y pnt) gfs::left (gfs:point-x pnt) gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size)) @@ -441,19 +441,19 @@ (setf gfs::tablength tb-width) (setf gfs::leftmargin 0) (setf gfs::rightmargin 0) - (gfs::with-rect + (gfs::with-rect (rect-ptr) (setf gfs::left (gfs:point-x pnt)) (setf gfs::top (gfs:point-y pnt)) (gfs::draw-text-ex (gfs:handle self) text -1 - gfs::rect-ptr + rect-ptr (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+))) dt-ptr) (gfs::draw-text-ex (gfs:handle self) text (length text) - gfs::rect-ptr + rect-ptr flags dt-ptr) (gfs::set-bk-mode (gfs:handle self) old-bk-mode)))))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Sep 11 16:30:56 2006 @@ -132,11 +132,11 @@ ;;; convenience macros ;;; -(defmacro with-rect (&body body) - `(cffi:with-foreign-object (rect-ptr 'gfs::rect) +(defmacro with-rect ((rect-var) &body body) + `(cffi:with-foreign-object (,rect-var 'gfs::rect) (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) - rect-ptr gfs::rect) - (zero-mem rect-ptr gfs::rect) + ,rect-var gfs::rect) + (zero-mem ,rect-var gfs::rect) ,@body))) (defmacro with-hfont-selected ((hdc hfont) &body body) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Sep 11 16:30:56 2006 @@ -153,18 +153,29 @@ color)) (defmethod compute-outer-size ((self window) desired-client-size) - (let ((hwnd (gfs:handle self)) - (new-size (gfs:make-size))) - (gfs::with-rect + (let* ((hwnd (gfs:handle self)) + (has-menu (not (cffi:null-pointer-p (gfs::get-menu hwnd)))) + (new-size (gfs:make-size))) + (gfs::with-rect (rect-ptr) (setf gfs::right (gfs:size-width desired-client-size) gfs::bottom (gfs:size-height desired-client-size)) - (if (zerop (gfs::adjust-window-rect gfs::rect-ptr + (if (zerop (gfs::adjust-window-rect rect-ptr (get-native-style self) - (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) + (if has-menu 1 0) (get-native-exstyle self))) (error 'gfs:win32-error :detail "adjust-window-rect failed")) (setf (gfs:size-width new-size) (- gfs::right gfs::left) - (gfs:size-height new-size) (- gfs::bottom gfs::top))) + (gfs:size-height new-size) (- gfs::bottom gfs::top)) + ;; check how much wrapping occurs if there is a menu and we + ;; size a window to the above-computed width and infinite + ;; height + (when has-menu + (setf gfs::bottom #x7FFFFFFF) ; ensures we handle all possible menu wrap + (gfs::send-message hwnd gfs::+wm-nccalcsize+ 0 (cffi:pointer-address rect-ptr)) + ;; gfs::top is now the bottom-most position of the top part of the window's + ;; non-client area, which is the area that the wrapped menu occupies and for + ;; which compensation is needed. + (incf (gfs:size-height new-size) gfs::top))) new-size)) (defmethod gfs:dispose ((self window))

1 0

[graphic-forms-cvs] r256 - trunk
by junrue＠common-lisp.net 11 Sep '06

11 Sep '06

Author: junrue Date: Mon Sep 11 00:41:24 2006 New Revision: 256 Modified: trunk/NEWS.txt trunk/README.txt Log: doc updates Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Sep 11 00:41:24 2006 @@ -1,8 +1,28 @@ +. Initial list box control functionality is now available: + + * three selection modes (none / multiple / extend) + + * list item data comprised by arbitrary application-defined data + + * application defined sorting predicates + + * querying and programmatic control of item selection states + + * customizability of vertical scrollbar mode and keyboard input + + Additional list box control features will be provided in a future release. + +. Did some housecleaning of the item-manager protocol and heavily refactored + the implementation of item-manager base functionality. + . Implemented GFW:ENABLE-REDRAW to enable applications to temporarily disable (and later re-enable) drawing of widget content. +. Fixed a silly bug in GFW:CHECKED-P (and GFW:SELECTED-P) for checkbox and + radio button -style buttons. + ============================================================================== Release 0.5.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Sep 11 00:41:24 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.6.0 (22 August 2006) +Graphic-Forms README for version 0.6.0 (xx xxxxxxx 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -73,11 +73,15 @@ compute height from that. The gfg:text-extent function does return the correct width. +5. If a Graphic-Forms application is launched from within SLIME on a + single-threaded Common Lisp implementation, further SLIME commands + will be 'pipelined' until the Graphic-Forms main message loop exits. + How To Configure and Build -------------------------- -NOTE: in a future release, this project will be packaged for delivery +NOTE: in a future release, this library will be packaged for delivery via asdf-install. 1. [OPTIONAL] Install ImageMagick 6.2.6.5-Q16 (note in particular that it @@ -169,10 +173,12 @@ (gft:event-tester) - (gft:image-tester) + (gft:image-tester) ; if ImageMagick loaded, shows PNG and GIF images (gft:layout-tester) + (gft:widget-tester) + (gft:windlg) ;;

1 0

[graphic-forms-cvs] r255 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 10 Sep '06

10 Sep '06

Author: junrue Date: Sun Sep 10 18:59:22 2006 New Revision: 255 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/list-item.lisp Log: implemented select and selected-p for list-item Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sun Sep 10 18:59:22 2006 @@ -85,7 +85,9 @@ (defun select-lb-content (lb state) (let ((count (gfw:item-count lb)) (func (if state #'gfw::lb-select-item #'gfw::lb-deselect-item))) - (loop for index in '(0 2 4) + (if (> count 0) + (gfw:select (first (gfw:items-of lb)) state)) + (loop for index in '(2 4) when (>= count (1+ index)) do (funcall func lb index)))) #| Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Sun Sep 10 18:59:22 2006 @@ -77,6 +77,16 @@ (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0))))) (call-next-method)) +(defmethod select ((self list-item) flag) + (let ((owner (owner self))) + (if flag + (lb-select-item owner (item-index owner self)) + (lb-deselect-item owner (item-index owner self))))) + +(defmethod selected-p ((self list-item)) + (let ((owner (owner self))) + (> (gfs::send-message (gfs:handle self) gfs::+lb-getsel+ (item-index owner self) 0) 0))) + (defmethod text ((self list-item)) (let ((hwnd (gfs:handle self))) (if (or (null hwnd) (cffi:null-pointer-p hwnd))

1 0

[graphic-forms-cvs] r254 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Sep '06

10 Sep '06

Author: junrue Date: Sun Sep 10 17:31:01 2006 New Revision: 254 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: fixed a bug in checked-p for buttons; implemented low-level select and deselect functions for list-box; enhanced test-native-style to support more than one bit to test Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Sun Sep 10 17:31:01 2006 @@ -16,22 +16,35 @@ @anchor{append-item} @deffn GenericFunction append-item self thing dispatcher &optional disabled checked => @ref{item} -Adds a new item representing @var{thing} to @var{self}, where the -class of @var{self} must derive from @ref{item-manager}. The -newly-created item is returned. The @var{dispatcher} parameter must -be an instance of @ref{event-dispatcher} or a subclass thereof. The -optional @var{checked} and @var{disabled} arguments can be used to set -the item's initial state. +Adds a new item representing @var{thing} to @var{self}, where @var{thing} +can be any @sc{object}. The newly-created item is returned. +The @var{dispatcher} parameter must be one of the following: +@itemize @bullet +@item An instance of @ref{event-dispatcher} or a subclass thereof. +@item A function whose argument list matches the event method +identified by the @var{callback-event-name} slot in @var{self}'s +class. + +See also @ref{items-of}. +@end itemize + +The optional @var{checked} and @var{disabled} arguments will each be +interpreted as @sc{generalized boolean} values in order to set the +item's initial state. Note, however, that not all @ref{item-manager} +subclasses support enabled or checked states for individual items. @end deffn @deffn GenericFunction append-separator self => @ref{item} -Adds a separator item to @var{self}, and returns the newly-created item. +Adds a separator to @var{self}, and returns a newly-created item to +wrap the separator. A separator is a thin etched divider that serves +to visually separate groups of items and has no other behavior. @end deffn -@deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{item} +@deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{menu-item} Adds @var{submenu} anchored to @var{self} and returns the corresponding -@ref{menu-item}. The optional @var{checked} and @var{disabled} arguments can -be used to set the menu item's initial state. +menu-item. The optional @var{checked} and @var{disabled} arguments +will each be interpreted as @sc{generalized boolean} values +in order to set the menu item's initial state. @end deffn @anchor{auto-hscroll-p} @@ -139,6 +152,16 @@ presses @sc{enter}. @end deffn +@anchor{data-of} +@deffn Accessor data-of self +(setf (@strong{data-of} @var{self}) @var{object})@* + +Returns application-specific data associated with @var{self}. + +The corresponding @sc{set} function associates new data with +@var{self}. +@end deffn + @deffn GenericFunction delete-all self Removes all content from @var{self}. @end deffn @@ -259,8 +282,33 @@ an image or an icon-bundle. @end deffn +@anchor{item-count} +@deffn GenericFunction item-count self => integer +Returns the number of instances of @ref{item} subclasses contained within +@var{self}. +@end deffn + +@anchor{item-index} @deffn GenericFunction item-index self item -Return the zero-based index of the location of the other object in this object. +Return the zero-based index of the location of @var{item} within @var{self}. +@end deffn + +@anchor{items-of} +@deffn GenericFunction items-of self +(setf (@strong{items-of} @var{self}) @var{items})@* + +Returns a fresh @sc{list} of @ref{item} subclasses appropriate for +@var{self}'s type. + +The corresponding @sc{setf} function accepts a list whose contents +are any combination of: +@itemize @bullet +@item Instances of @ref{item} subclasses appropriate for @var{self}. +@item Instances of any @sc{object} type; these will be wrapped by item +objects, to be accessible later via the @ref{data-of} method. +@end itemize +Existing items contained by @var{self} are replaced, and then the +native control is refreshed. See also @ref{append-item}. @end deffn @anchor{layout} @@ -284,7 +332,10 @@ Calls @var{func}, which is a function of two arguments, for each child of @var{self} and places @var{func}'s return value in @var{result-list}. @var{func}'s two arguments are @var{self} and -the current child. +the current child. Note that @code{mapchildren} accesses @var{self}'s +@emph{actual} children as determined by the underlying window's +data structures, regardless of any @ref{layout-manager} assigned +to @var{self}. @end deffn @anchor{maximum-size} @@ -464,16 +515,18 @@ @deffn GenericFunction selected-items self => list (setf (@strong{selected-items} @var{self}) @var{list}) -Returns a @sc{list} containing subclasses of @ref{item} appropriate -for @var{self} that correspond to selections made by the user, or -@sc{nil} if there are no selections. This function is defined only -for @ref{widget}s whose notion of @emph{selection} is a set of -item objects. - -The @sc{setf} function takes a @var{list} of item subclasses -appropriate for @var{self} which identify the items in -@var{self} that should be selected. Passing @sc{nil} will unselect all -items, which is equivalent to calling @ref{select-all} with @sc{nil}. +Returns a fresh @sc{list} containing subclasses of @ref{item} +appropriate for @var{self} that correspond to selections made by the +user, or @sc{nil} if there are no selections. This function is defined +only for @ref{widget}s whose notion of @emph{selection} is a set of +instances of @ref{item} subclasses. + +The @sc{setf} function takes a @sc{list} of instances of item +subclasses appropriate for @var{self} which identify the items in +@var{self} that should be selected.@footnote{In this respect, +@ref{selected-items} is not symmetric with @ref{items-of}.} Passing +@sc{nil} will unselect all items, which is equivalent to calling +@ref{select-all} with @sc{nil}. @end deffn @anchor{selected-p} Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Sep 10 17:31:01 2006 @@ -436,6 +436,7 @@ #:initial-delay-of #:horizontal-scrollbar #:image + #:item-count #:item-height #:item-id #:item-index Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sun Sep 10 17:31:01 2006 @@ -65,10 +65,12 @@ (gfg:foreground-color gc) color)) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) -(defun manage-lb-button-states (lb move-btn all-btn none-btn) +(defun manage-lb-button-states (lb move-btn selected-btn all-btn none-btn) (let ((sel-count (gfw:selected-count lb)) - (item-count (length (gfw:items-of lb)))) + (item-count (gfw:item-count lb))) (gfw:enable move-btn (> sel-count 0)) + (if selected-btn + (gfw:check selected-btn (> sel-count 0))) (if all-btn (gfw:enable all-btn (and (> item-count 0) (< sel-count item-count)))) (if none-btn @@ -80,39 +82,64 @@ (if sel-items (setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb)))))) +(defun select-lb-content (lb state) + (let ((count (gfw:item-count lb)) + (func (if state #'gfw::lb-select-item #'gfw::lb-deselect-item))) + (loop for index in '(0 2 4) + when (>= count (1+ index)) + do (funcall func lb index)))) +#| + (let ((items (gfw:items-of lb))) + (setf (gfw:selected-items lb) (subseq items 0 (min 4 (length items)))))) +|# + (defun populate-list-box-test-panel () (setf (gfw:text *widget-tester-win*) "Widget Tester (List Boxes)") (let* ((panel-disp (make-instance 'widget-tester-panel-events)) - (lb1 nil) - (lb2 nil) - (btn-left nil) - (btn-right nil) - (btn-all nil) - (btn-none nil) - (lb1-callback (lambda (disp lb) - (declare (ignore disp)) - (manage-lb-button-states lb btn-right btn-all btn-none))) - (lb2-callback (lambda (disp lb) - (declare (ignore disp)) - (manage-lb-button-states lb btn-left nil nil))) - (btn-left-callback (lambda (disp btn) - (declare (ignore disp btn)) - (move-lb-content lb2 lb1) - (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left nil nil))) - (btn-right-callback (lambda (disp btn) - (declare (ignore disp btn)) - (move-lb-content lb1 lb2) - (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left nil nil))) - (btn-all-callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfw:select-all lb1 t) - (manage-lb-button-states lb1 btn-right btn-all btn-none))) - (btn-none-callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfw:select-all lb1 nil) - (manage-lb-button-states lb1 btn-right btn-all btn-none))) + (latch nil) + (lb1 nil) + (lb2 nil) + (btn-left nil) + (btn-right nil) + (btn-all nil) + (btn-none nil) + (btn-select nil) + (lb1-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-right (if latch nil btn-select) btn-all btn-none))) + (lb2-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-left nil nil nil))) + (btn-left-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb2 lb1) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) + (manage-lb-button-states lb2 btn-left nil nil nil))) + (btn-right-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb1 lb2) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) + (manage-lb-button-states lb2 btn-left nil nil nil))) + (btn-all-callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfw:select-all lb1 t) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none))) + (btn-none-callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfw:select-all lb1 nil) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none))) + (btn-reset-callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfw:delete-all lb2) + (setf (gfw:items-of lb1) *list-box-test-data*) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) + (manage-lb-button-states lb2 btn-left nil nil nil))) + (btn-select-callback (lambda (disp btn) + (declare (ignore disp)) + (setf latch t) + (select-lb-content lb1 (gfw:selected-p btn)) + (manage-lb-button-states lb1 btn-right nil btn-all btn-none) + (setf latch nil))) (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* @@ -135,21 +162,28 @@ :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) - (setf btn-right (make-instance 'gfw:button :parent btn-panel - :text " ==> " - :callback btn-right-callback)) + (setf btn-right (make-instance 'gfw:button :parent btn-panel + :text " ==> " + :callback btn-right-callback)) (gfw:enable btn-right nil) - (setf btn-left (make-instance 'gfw:button :parent btn-panel - :text " <== " - :callback btn-left-callback)) + (setf btn-left (make-instance 'gfw:button :parent btn-panel + :text " <== " + :callback btn-left-callback)) (gfw:enable btn-left nil) - (setf btn-all (make-instance 'gfw:button :parent btn-panel - :text "Select All" - :callback btn-all-callback)) - (setf btn-none (make-instance 'gfw:button :parent btn-panel - :text "Select None" - :callback btn-none-callback)) + (setf btn-all (make-instance 'gfw:button :parent btn-panel + :text "Select All" + :callback btn-all-callback)) + (setf btn-none (make-instance 'gfw:button :parent btn-panel + :text "Select None" + :callback btn-none-callback)) (gfw:enable btn-none nil) + (make-instance 'gfw:button :parent btn-panel + :text "Reset" + :callback btn-reset-callback) + (setf btn-select (make-instance 'gfw:button :parent btn-panel + :text "Select 0,2,4" + :style '(:check-box) + :callback btn-select-callback)) (gfw:pack btn-panel) (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) @@ -160,12 +194,17 @@ (gfw:pack lb2-panel) (gfw:pack outer-panel) + ;; FIXME: need to think of a more elegant solution for the following + ;; use-case where we want synchronize the sizes of two or more + ;; layout children + ;; (let ((size (gfw:size lb1))) (setf (gfw:maximum-size lb1) size (gfw:minimum-size lb1) size (gfw:maximum-size lb2) size (gfw:minimum-size lb2) size)) (setf (gfw:items-of lb1) *list-box-test-data*) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) (gfw:delete-all lb2) outer-panel)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Sep 10 17:31:01 2006 @@ -729,3 +729,9 @@ ("UpdateWindow" update-window) BOOL (hwnd HANDLE)) + +(defcfun + ("ValidateRect" validate-rect) + BOOL + (hwnd HANDLE) + (rct LPTR)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun Sep 10 17:31:01 2006 @@ -46,10 +46,7 @@ (defmethod checked-p ((self button)) (let ((bits (gfs::send-message (gfs:handle self) gfs::+bm-getcheck+ 0 0))) - (case bits - (gfs::+bst-checked+ t) - (gfs::+bst-unchecked+ nil) - (otherwise nil)))) + (= (logand bits gfs::+bst-checked+) gfs::+bst-checked+))) (defmethod compute-style-flags ((self button) &rest extra-data) (declare (ignore extra-data)) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Sun Sep 10 17:31:01 2006 @@ -124,6 +124,13 @@ (dotimes (i (length items)) (delete-tc-item tc (elt items i))))) +(defmethod item-count :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod item-count ((self item-manager)) + (length (slot-value self 'items))) + (defmethod item-index :before ((self item-manager) (it item)) (declare (ignore it)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Sun Sep 10 17:31:01 2006 @@ -56,6 +56,11 @@ (logand orig-flags (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+)))) +(defun lb-is-single-select (lb) + (not (test-native-style lb (logior gfs::+lbs-extendedsel+ + gfs::+lbs-multiplesel+ + gfs::+lbs-nosel+)))) + (defun lb-width (hwnd) (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) (if (< width 0) @@ -76,6 +81,90 @@ (setf (slot-value victim 'gfs:handle) nil) (gfs:dispose victim))))) +;;; This function is based on the package private select( int, boolean ) +;;; method from SWT 3.2 located in List.java starting on line 998, without +;;; the additional scrolling logic. +;;; +(defun lb-select-item (lb index) + (let ((hwnd (gfs:handle lb))) + + ;; sanity-check the index + ;; + (if (or (< index 0) (>= index (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (return-from lb-select-item nil)) + + ;; save the index of the top-most item + ;; + (let ((top-index (gfs::send-message hwnd gfs::+lb-gettopindex+ 0 0))) + (cffi:with-foreign-object (top-item-rect-ptr 'gfs::rect) + (cffi:with-foreign-object (sel-item-rect-ptr 'gfs::rect) + + ;; get the rectangle for the top-most item which we + ;; will repaint at the end + ;; + (gfs::send-message hwnd gfs::+lb-getitemrect+ + top-index (cffi:pointer-address top-item-rect-ptr)) + (let ((redraw-needed (zerop (gfs::is-window-visible hwnd))) + (has-sel-item nil)) + + ;; if the list box is visible, disable repainting + ;; + (if redraw-needed + (enable-redraw lb nil)) + (unwind-protect + (progn + (if (lb-is-single-select lb) + + ;; single-select list boxes must be configured differently + ;; from multi-select + ;; + (let ((old-index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) + (setf has-sel-item (/= old-index -1)) + + ;; get the rectangle for the old selected item + ;; + (if has-sel-item + (gfs::send-message hwnd gfs::+lb-getitemrect+ + old-index (cffi:pointer-address sel-item-rect-ptr))) + + ;; set the new selection + ;; + (gfs::send-message hwnd gfs::+lb-setcursel+ index 0)) + + ;; configure new selection for multi-select list boxes + ;; + (let ((focus-index (gfs::send-message hwnd gfs::+lb-getcaretindex+ 0 0))) + + ;; set the new selection + ;; + (gfs::send-message hwnd gfs::+lb-setsel+ 1 index) + + ;; if there was an item with focus, restore it + ;; + (if (/= focus-index -1) + (gfs::send-message hwnd gfs::+lb-setcaretindex+ focus-index 0))))) + + ;; restore the original top-index, then update the + ;; list box and the top item and the selection item + ;; + (gfs::send-message hwnd gfs::+lb-settopindex+ top-index 0) + (when redraw-needed + (enable-redraw lb t) + (gfs::validate-rect hwnd (cffi:null-pointer)) + (gfs::invalidate-rect hwnd top-item-rect-ptr 1) + (if has-sel-item + (gfs::invalidate-rect hwnd sel-item-rect-ptr 1)))))))))) + +(defun lb-deselect-item (lb index) + (let ((hwnd (gfs:handle lb))) + (if (or (< index 0) (>= index (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (return-from lb-deselect-item nil)) + (if (lb-is-single-select lb) + (let ((curr-index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) + (if (= curr-index index) + (gfs::send-message hwnd gfs::+lb-setcursel+ -1 0))) + (gfs::send-message hwnd gfs::+lb-setsel+ 0 index)))) + ;;; ;;; methods ;;; @@ -202,8 +291,7 @@ size)) (defmethod select-all ((self list-box) flag) - (when (or (test-native-style self gfs::+lbs-extendedsel+) - (test-native-style self gfs::+lbs-multiplesel+)) + (when (test-native-style self (logior gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+)) (gfs::send-message (gfs:handle self) gfs::+lb-setsel+ (if flag 1 0) #xFFFFFFFF))) (defmethod selected-count ((self list-box)) @@ -216,8 +304,7 @@ (defmethod selected-items ((self list-box)) (let ((hwnd (gfs:handle self)) (items (slot-value self 'items))) - (if (and (not (test-native-style self gfs::+lbs-extendedsel+)) - (not (test-native-style self gfs::+lbs-multiplesel+))) + (if (lb-is-single-select self) (let ((index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) (if (and (>= index 0) (< index (length items))) (list (elt items index)) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Sun Sep 10 17:31:01 2006 @@ -51,6 +51,12 @@ (error 'gfs:win32-error :detail "LB_GETITEMHEIGHT failed")) height)) +(defun lb-item-text-length (hwnd index) + (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0))) + (if (< length 0) + (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed")) + length)) + (defun lb-item-text (hwnd index &optional buffer-size) (if (or (null buffer-size) (<= buffer-size 0)) (setf buffer-size (lb-item-text-length hwnd index))) @@ -59,12 +65,6 @@ (error 'gfs:win32-error :detail "LB_GETTEXT failed")) (cffi:foreign-string-to-lisp str-ptr))) -(defun lb-item-text-length (hwnd index) - (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0))) - (if (< length 0) - (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed")) - length)) - ;;; ;;; methods ;;; @@ -76,3 +76,9 @@ (if (and owner (cffi:pointer-eq hwnd (gfs:handle owner))) (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0))))) (call-next-method)) + +(defmethod text ((self list-item)) + (let ((hwnd (gfs:handle self))) + (if (or (null hwnd) (cffi:null-pointer-p hwnd)) + "" + (lb-item-text hwnd (item-index (get-widget (thread-context) hwnd) self))))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Sep 10 17:31:01 2006 @@ -39,6 +39,8 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) +(defvar *default-dispatcher* (make-instance 'event-dispatcher)) + (defclass layout-managed () ((layout-p :reader layout-p @@ -68,7 +70,7 @@ ((dispatcher :accessor dispatcher :initarg :dispatcher - :initform (make-instance 'event-dispatcher)) + :initform *default-dispatcher*) (callback-event-name :accessor callback-event-name-of :initform nil Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Sep 10 17:31:01 2006 @@ -207,6 +207,9 @@ (defgeneric (setf image) (image self) (:documentation "Sets self's image object.")) +(defgeneric item-count (self) + (:documentation "Returns the number of items contained within self.")) + (defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Sep 10 17:31:01 2006 @@ -141,7 +141,7 @@ (defun show-common-dialog (dlg dlg-func) (let* ((struct-ptr (gfs:handle dlg)) (retval (funcall dlg-func struct-ptr))) - (if (and (zerop retval) (not (zerop (gfs::comm-dlg-extended-error)))) + (if (and (zerop retval) (/= (gfs::comm-dlg-extended-error) 0)) (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) retval)) @@ -286,7 +286,7 @@ (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+)) (defun test-native-style (widget bits) - (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) bits)) + (/= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) 0)) (defun test-native-exstyle (widget bits) - (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) bits)) + (/= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) 0)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Sep 10 17:31:01 2006 @@ -207,7 +207,7 @@ (redraw self))) (defmethod enabled-p ((self widget)) - (not (zerop (gfs::is-window-enabled (gfs:handle self))))) + (/= (gfs::is-window-enabled (gfs:handle self)) 0)) (defmethod image :before ((self widget)) (if (gfs:disposed-p self) @@ -435,4 +435,4 @@ (error 'gfs:disposed-error))) (defmethod visible-p ((self widget)) - (not (zerop (gfs::is-window-visible (gfs:handle self))))) + (/= (gfs::is-window-visible (gfs:handle self)) 0))

1 0