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