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

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

09 Sep '06

Author: junrue Date: Sat Sep 9 00:39:19 2006 New Revision: 253 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp Log: implemented select-all for list-box 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 9 00:39:19 2006 @@ -66,13 +66,13 @@ (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) (defun manage-lb-button-states (lb move-btn all-btn none-btn) - (let ((count (gfw:selected-count lb)) - (items (gfw:items-of lb))) - (gfw:enable move-btn (> count 0)) + (let ((sel-count (gfw:selected-count lb)) + (item-count (length (gfw:items-of lb)))) + (gfw:enable move-btn (> sel-count 0)) (if all-btn - (gfw:enable all-btn (< count (length items)))) + (gfw:enable all-btn (and (> item-count 0) (< sel-count item-count)))) (if none-btn - (gfw:enable none-btn (> count 0))))) + (gfw:enable none-btn (> sel-count 0))))) (defun move-lb-content (orig-lb dest-lb) (let ((sel-items (gfw:selected-items orig-lb))) @@ -99,16 +99,20 @@ (declare (ignore disp btn)) (move-lb-content lb2 lb1) (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (manage-lb-button-states lb2 btn-left nil nil))) (btn-right-callback (lambda (disp btn) (declare (ignore disp btn)) (move-lb-content lb1 lb2) (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (manage-lb-button-states lb2 btn-left nil nil))) (btn-all-callback (lambda (disp btn) - (declare (ignore disp btn)))) + (declare (ignore disp btn)) + (gfw:select-all lb1 t) + (manage-lb-button-states lb1 btn-right btn-all btn-none))) (btn-none-callback (lambda (disp btn) - (declare (ignore disp btn)))) + (declare (ignore disp btn)) + (gfw:select-all lb1 nil) + (manage-lb-button-states lb1 btn-right btn-all btn-none))) (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Sat Sep 9 00:39:19 2006 @@ -102,6 +102,8 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) + (if (or (< index 0) (>= index (length (slot-value self 'items)))) + (error 'gfs:toolkit-error :detail "invalid item index")) (multiple-value-bind (new-items victim) (gfs::remove-element (slot-value self 'items) index #'make-items-array) (setf (slot-value self 'items) new-items) @@ -116,10 +118,6 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-span ((self item-manager) (sp gfs:span)) - (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) - (delete-item self (gfs:span-start sp)))) - (defmethod gfs:dispose ((self item-manager)) (let ((items (slot-value self 'items)) (tc (thread-context))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Sat Sep 9 00:39:19 2006 @@ -123,6 +123,13 @@ do (gfs:dispose item)) (enable-redraw self t))) +(defmethod delete-span ((self list-box) (span gfs:span)) + (enable-redraw self nil) + (unwind-protect + (dotimes (i (1+ (- (gfs:span-end span) (gfs:span-start span)))) + (delete-item self (gfs:span-start span))) + (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) @@ -194,6 +201,11 @@ (incf (gfs:size-width size) (vertical-scrollbar-width))) size)) +(defmethod select-all ((self list-box) flag) + (when (or (test-native-style self gfs::+lbs-extendedsel+) + (test-native-style self gfs::+lbs-multiplesel+)) + (gfs::send-message (gfs:handle self) gfs::+lb-setsel+ (if flag 1 0) #xFFFFFFFF))) + (defmethod selected-count ((self list-box)) (let ((hwnd (gfs:handle self))) (if (test-native-style self gfs::+lbs-nosel+)

1 0

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

09 Sep '06

Author: junrue Date: Fri Sep 8 23:02:05 2006 New Revision: 252 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: rewrote item dispose / manager delete-item, implemented item-index to replace index-of accessor, added unit-tests Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Fri Sep 8 23:02:05 2006 @@ -147,11 +147,6 @@ Removes the @ref{item} at the zero-based @var{index}. @end deffn -@deffn GenericFunction delete-item-span self @ref{span} -Removes the items from @var{self} whose zero-based indices lie within -the specified @var{span}. -@end deffn - @deffn GenericFunction delete-selection self Removes the subset of items from @var{self} that are in the @samp{selected} state. For a @ref{control} with a text field @@ -159,6 +154,11 @@ selected text. @end deffn +@deffn GenericFunction delete-span self @ref{span} +Removes the content from @var{self} whose zero-based indices lie within +the specified @var{span}. +@end deffn + @deffn GenericFunction display-to-object self pnt Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system. Modified: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Fri Sep 8 23:02:05 2006 @@ -69,6 +69,14 @@ :handle *test-hwnd*))))) (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)))) +(define-test item-manager-positions-test + (let* ((values '(a b c)) + (mgr (make-instance 'mock-item-manager :items values)) + (items (slot-value mgr 'gfw::items))) + (assert-equal 0 (gfw:item-index mgr (elt items 0))) + (assert-equal 1 (gfw:item-index mgr (elt items 1))) + (assert-equal 2 (gfw:item-index mgr (elt items 2))))) + (define-test item-manager-modifications-test (let ((values1 '(a b c)) (values2 '(1 2 3)) @@ -113,7 +121,7 @@ (validate-item 1 (first tmp) nil nil) (assert-equal 3 (length (gfw:items-of mgr2))) (loop for actual in (gfw:items-of mgr2) - for expected in (subseq (append values2 '(4)) 1 4) + for expected in (mapcar (lambda (x) (1+ x)) (subseq values2 0 3)) do (validate-item expected actual nil *test-hwnd*))) ;; delete last item from mgr3 (using dispose) @@ -129,6 +137,6 @@ (assert-equal 3 (length (gfw:items-of mgr1))) (loop for actual in (gfw:items-of mgr1) for expected in (subseq (append values2 '(4)) 1 4) - do (validate-item expected actual nil *test-hwnd*))) + do (validate-item expected actual nil *default-hwnd*))) (gfw::delete-widget (gfw::thread-context) *default-hwnd*))))) Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Fri Sep 8 23:02:05 2006 @@ -102,3 +102,88 @@ (assert-equal 3 (length result1)) (assert-equal 3 (length result2)) (validate-array-elements result1 result2)))) + +(define-test remove-element-list-test + (let ((orig '(a b c)) + (remainder nil)) + (multiple-value-bind (tmp victim) (gfs::remove-element orig 1 nil) + (setf remainder tmp) + (assert-equal 2 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'c (second tmp)) + (assert-eql 'b victim)) + (multiple-value-bind (tmp victim) (gfs::remove-element remainder 1 nil) + (setf remainder tmp) + (assert-equal 1 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'c victim)) + (multiple-value-bind (tmp victim) (gfs::remove-element remainder 0 nil) + (assert-false tmp) + (assert-eql 'a victim)))) + +(define-test remove-elements-list-test + (let ((orig '(a b c d e f)) + (remainder nil)) + (multiple-value-bind (tmp victims) + (gfs::remove-elements orig (gfs:make-span :start 2 :end 4) nil) + (setf remainder tmp) + (assert-equal 3 (length victims)) + (assert-eql 'c (first victims)) + (assert-eql 'd (second victims)) + (assert-eql 'e (third victims)) + (assert-equal 3 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'b (second tmp)) + (assert-eql 'f (third tmp))) + (multiple-value-bind (tmp victims) + (gfs::remove-elements remainder (gfs:make-span :start 0 :end 1) nil) + (setf remainder tmp) + (assert-equal 2 (length victims)) + (assert-eql 'a (first victims)) + (assert-eql 'b (second victims)) + (assert-equal 1 (length tmp)) + (assert-eql 'f (first tmp))) + (multiple-value-bind (tmp victims) + (gfs::remove-elements remainder (gfs:make-span :start 0 :end 0) nil) + (assert-false tmp) + (assert-equal 1 (length victims)) + (assert-eql 'f (first victims))))) + +(define-test remove-element-non-adjustable-array-test + (let ((orig (make-array 3 :initial-contents '(a b c))) + (tmp nil)) + (setf tmp (gfs::remove-element orig 1 (lambda () (make-array 2)))) + (assert-false (array-has-fill-pointer-p tmp)) + (assert-false (adjustable-array-p tmp)) + (assert-equal 2 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-eql 'c (elt tmp 1)) + (setf tmp (gfs::remove-element tmp 1 (lambda () (make-array 1)))) + (assert-equal 1 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-false (gfs::remove-element tmp 0 (lambda () (make-array 0)))))) + +(defun reaam-test-make-array () + (make-array 10 :fill-pointer 0 :adjustable t)) + +(define-test remove-elements-adjustable-array-test + (let ((orig (reaam-test-make-array)) + (tmp nil)) + (loop for item in '(a b c d e f) do (vector-push-extend item orig)) + (setf tmp (gfs::remove-elements orig + (gfs:make-span :start 2 :end 4) + #'reaam-test-make-array)) + (assert-true (array-has-fill-pointer-p tmp)) + (assert-true (adjustable-array-p tmp)) + (assert-equal 3 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-eql 'b (elt tmp 1)) + (assert-eql 'f (elt tmp 2)) + (setf tmp (gfs::remove-elements tmp + (gfs:make-span :start 0 :end 1) + #'reaam-test-make-array)) + (assert-equal 1 (length tmp)) + (assert-eql 'f (elt tmp 0)) + (assert-false (gfs::remove-elements tmp + (gfs:make-span :start 0 :end 0) + #'reaam-test-make-array)))) Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Fri Sep 8 23:02:05 2006 @@ -76,6 +76,7 @@ (defun move-lb-content (orig-lb dest-lb) (let ((sel-items (gfw:selected-items orig-lb))) + (gfw:delete-selection orig-lb) (if sel-items (setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb)))))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Fri Sep 8 23:02:05 2006 @@ -65,15 +65,51 @@ (dotimes (i (length tmp)) (setf (elt result i) (second (elt tmp i)))))) result)) -(defun pick-elements (lisp-seq indices &optional count) +(defun pick-elements (sequence indices &optional count) (let ((picks nil)) (if (cffi:pointerp indices) (dotimes (i count) - (push (elt lisp-seq (mem-aref indices :unsigned-int i)) picks)) + (push (elt sequence (mem-aref indices :unsigned-int i)) picks)) (dotimes (i (length indices)) - (push (elt lisp-seq (elt indices i)) picks))) + (push (elt sequence (elt indices i)) picks))) (reverse picks))) +(defun add-element (element sequence index) + (cond + ((listp sequence) + (push element sequence)) + ((adjustable-array-p sequence) + (vector-push-extend element sequence)) + (t + (setf (elt sequence index) element))) + sequence) + +(defun remove-element (sequence index creator) + (let ((result nil) + (victim nil)) + (dotimes (i (length sequence)) + (if (= i index) + (setf victim (elt sequence i)) + (setf result (add-element (elt sequence i) + (or result (if creator (funcall creator) nil)) + (if victim (1- i) i))))) + (if (listp result) + (values (reverse result) victim) + (values result victim)))) + +(defun remove-elements (sequence span creator) + (let ((result nil) + (victims nil)) + (dotimes (i (length sequence)) + (if (and (>= i (gfs:span-start span)) (<= i (gfs:span-end span))) + (push (elt sequence i) victims) + (setf result (add-element (elt sequence i) + (or result (if creator (funcall creator) nil)) + (- i (length victims)))))) + (if (listp result) + (values (reverse result) (reverse victims)) + (values result (reverse victims))))) + (defun flatten (tree) (if (cl:atom tree) (list tree) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Fri Sep 8 23:02:05 2006 @@ -61,7 +61,9 @@ (dotimes (i (length new-items)) (let ((item (elt new-items i))) (if (typep item item-class) - (vector-push-extend item replacements) + (progn + (setf (slot-value item 'gfs:handle) handle) + (vector-push-extend item replacements)) (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements))))) @@ -69,7 +71,9 @@ ((listp new-items) (loop for item in new-items do (if (typep item item-class) - (vector-push-extend item replacements) + (progn + (setf (slot-value item 'gfs:handle) handle) + (vector-push-extend item replacements)) (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements)))) @@ -98,17 +102,21 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) - (let* ((items (slot-value self 'items)) - (it (elt items index))) - (setf (slot-value self 'items) (remove it items :test #'items-equal)) - (gfs:dispose it))) + (multiple-value-bind (new-items victim) + (gfs::remove-element (slot-value self 'items) index #'make-items-array) + (setf (slot-value self 'items) new-items) + (gfs:dispose victim))) -(defmethod delete-item-span :before ((self item-manager) (sp gfs:span)) +(defmethod delete-selection :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod delete-span :before ((self item-manager) (sp gfs:span)) (declare (ignore sp)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item-span ((self item-manager) (sp gfs:span)) +(defmethod delete-span ((self item-manager) (sp gfs:span)) (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (delete-item self (gfs:span-start sp)))) @@ -127,7 +135,7 @@ (let ((pos (position it (slot-value self 'items) :test #'items-equal))) (if (null pos) (return-from item-index 0)) - 0)) + pos)) (defmethod items-of ((self item-manager)) (coerce (slot-value self 'items) 'list)) 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 8 23:02:05 2006 @@ -116,6 +116,13 @@ (lb-delete-all self) (setf (slot-value self 'items) (make-items-array))) +(defmethod delete-selection ((self list-box)) + (enable-redraw self nil) + (unwind-protect + (loop for item in (selected-items self) + do (gfs:dispose item)) + (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) @@ -214,6 +221,8 @@ (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (hwnd (gfs:handle self))) + (unless (zerop (lb-item-count hwnd)) + (error 'gfs:toolkit-error :detail "list-box has existing content")) (when sort-func (setf (slot-value self 'items) (gfs::indexed-sort (slot-value self 'items) sort-func #'data-of))) (enable-redraw self nil) @@ -222,6 +231,5 @@ (dotimes (index (length items)) (let* ((item (elt items index)) (text (call-text-provider self (data-of item)))) - (setf (index-of item) index) (lb-insert-item hwnd #xFFFFFFFF text (cffi:null-pointer))))) (enable-redraw self t)))) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Fri Sep 8 23:02:05 2006 @@ -70,17 +70,9 @@ ;;; (defmethod gfs:dispose ((self list-item)) - (let ((index (index-of self)) - (howner (gfs:handle self))) - (if howner - (gfs::send-message howner gfs::+lb-deletestring+ index 0)) - (setf (index-of self) 0)) + (let ((hwnd (gfs:handle self))) + (unless (or (null hwnd) (cffi:null-pointer-p hwnd)) + (let ((owner (get-widget (thread-context) hwnd))) + (if (and owner (cffi:pointer-eq hwnd (gfs:handle owner))) + (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0))))) (call-next-method)) - -(defmethod print-object ((self list-item) stream) - (print-unreadable-object (self stream :type t) - (format stream "id: ~d " (item-id self)) - (format stream "index: ~d " (index-of self)) - (format stream "data: ~a " (data-of self)) - (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a" (dispatcher 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 8 23:02:05 2006 @@ -90,10 +90,7 @@ :allocation :class)) ; shadowing same slot from event-source (:documentation "The item class is the base class for all non-windowed user interface objects.")) -(defclass list-item (item) - ((index - :accessor index-of - :initform 0)) +(defclass list-item (item) () (:documentation "A subclass of item representing an element of a list-box.")) (defclass menu-item (item) () Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Sep 8 23:02:05 2006 @@ -135,12 +135,12 @@ (defgeneric delete-item (self index) (:documentation "Removes the item at the zero-based index from the object.")) -(defgeneric delete-item-span (self span) - (:documentation "Removes the sequence of items represented by the specified span object.")) - (defgeneric delete-selection (self) (:documentation "Removes items from self that are in the selected state.")) +(defgeneric delete-span (self span) + (:documentation "Removes the sequence of items represented by the specified span object.")) + (defgeneric disabled-image (self) (:documentation "Returns the image used to render this item with a disabled look.")) @@ -213,6 +213,12 @@ (defgeneric item-index (self item) (:documentation "Return the zero-based index of the location of the other object in this object.")) +(defgeneric items-of (self) + (:documentation "Returns a list of item subclasses representing the content of self.")) + +(defgeneric (setf items-of) (items self) + (:documentation "Accepts a list of application data (or list subclasses) to set the content of self.")) + (defgeneric layout (self) (:documentation "Set the size and location of this object's children.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Sep 8 23:02:05 2006 @@ -165,20 +165,11 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item :before ((self widget) index) - (declare (ignore index)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - -(defmethod delete-item-span :before ((self widget) span) +(defmethod delete-span :before ((self widget) span) (declare (ignore span)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-selection :before ((self widget)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - (defmethod gfs:dispose ((self widget)) (unless (null (dispatcher self)) (event-dispose (dispatcher self) self))

1 0

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

08 Sep '06

Author: junrue Date: Fri Sep 8 11:32:27 2006 New Revision: 251 Added: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-functions.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/tests.lisp Log: added unit-tests for item-manager, fixed more bugs Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Fri Sep 8 11:32:27 2006 @@ -70,7 +70,7 @@ @end macro @macro apps-shouldnt-call-function -This function should typically not be called from application code. +This function is not intended to be called from application code. @end macro @macro event-dispatcher-arg Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Fri Sep 8 11:32:27 2006 @@ -36,13 +36,13 @@ @anchor{auto-hscroll-p} @deffn GenericFunction auto-hscroll-p self => boolean -Returns T if @code{self} is configured for automatic horizontal scrolling; +Returns T if @var{self} is configured for automatic horizontal scrolling; @sc{nil} otherwise. See @ref{auto-vscroll-p} and @ref{enable-auto-scrolling}. @end deffn @anchor{auto-vscroll-p} @deffn GenericFunction auto-vscroll-p self => boolean -Returns T if @code{self} is configured for automatic vertical scrolling; +Returns T if @var{self} is configured for automatic vertical scrolling; @sc{nil} otherwise. See @ref{auto-hscroll-p} and @ref{enable-auto-scrolling}. @end deffn @@ -56,9 +56,9 @@ @anchor{capture-mouse} @defun capture-mouse self -Enables the @ref{window} identified by @code{self} to receive mouse +Enables the @ref{window} identified by @var{self} to receive mouse input events even when the mouse pointer is outside of the bounds -of @code{self}. Only one window at a time can capture the mouse. This +of @var{self}. Only one window at a time can capture the mouse. This function is primarily intended for use with a window in the foreground; background windows may still capture the mouse, but only mouse move events will be received and those only when the mouse hotspot is within @@ -67,15 +67,15 @@ @anchor{center-on-owner} @deffn GenericFunction center-on-owner self -Position @code{self} such that it is centrally located relative to its -@ref{owner}, based on @code{self}'s current outermost size. +Position @var{self} such that it is centrally located relative to its +@ref{owner}, based on @var{self}'s current outermost size. See also @ref{center-on-parent}. @end deffn @anchor{center-on-parent} @deffn GenericFunction center-on-parent self -Position @code{self} such that it is centrally located relative to its -@ref{parent}, based on @code{self}'s current outermost size. +Position @var{self} such that it is centrally located relative to its +@ref{parent}, based on @var{self}'s current outermost size. See also @ref{center-on-owner}. @end deffn @@ -93,7 +93,7 @@ @end deffn @deffn GenericFunction compute-style-flags self &rest extra-data -Convert a list of keyword symbols in the object's @code{style} slot to +Convert a list of keyword symbols in the object's @var{style} slot to a values pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports. @end deffn @@ -106,8 +106,8 @@ @anchor{copy-text} @deffn GenericFunction copy-text self This function is a shortcut for a common clipboard transfer operation, -namely the transfer of text from @code{self} to the system clipboard. -The existing content of @code{self} remains in place. Some @ref{control}s +namely the transfer of text from @var{self} to the system clipboard. +The existing content of @var{self} remains in place. Some @ref{control}s like the @ref{edit} control have built-in clipboard functionality, and in such cases, the implementation of this function delegates directly. See @ref{cut-text}, @ref{paste-text}, and @ref{text-for-pasting-p}.@*@* @@ -118,8 +118,8 @@ @anchor{cut-text} @deffn GenericFunction cut-text self This function is a shortcut for a common clipboard transfer operation, -namely the transfer of text from @code{self} to the system clipboard -and removal of content from @code{self}. Some @ref{control}s like the +namely the transfer of text from @var{self} to the system clipboard +and removal of content from @var{self}. Some @ref{control}s like the @ref{edit} control have built-in clipboard functionality, and in such cases, the implementation of this function delegates directly. For other @ref{widget}s, this operation is a wrapper around a copy/delete @@ -135,12 +135,12 @@ Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil} if none has been set. If @sc{nil} is passed to the corresponding @sc{setf} function, then no default widget is set. The default widget -is the one that is selected when @code{self} is active and the user +is the one that is selected when @var{self} is active and the user presses @sc{enter}. @end deffn @deffn GenericFunction delete-all self -Removes all content from @code{self}. +Removes all content from @var{self}. @end deffn @deffn GenericFunction delete-item self index @@ -204,7 +204,7 @@ Specifying T for @var{horizontal} (@var{vertical}) reveals a scrollbar to attached to the right-hand (bottom) of @var{self}. Specifying @sc{nil} hides the scrollbar. These flags do -not affect scrolling behavior in @code{self} -- they only control +not affect scrolling behavior in @var{self} -- they only control scrollbar visibility. See @ref{horizontal-scrollbar-p} and @ref{vertical-scrollbar-p}. @end deffn @@ -224,7 +224,7 @@ @end defun @deffn GenericFunction focus-p self -Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} +Returns @sc{t} if @var{self} currently has keyboard focus; @sc{nil} otherwise. @end deffn @@ -233,7 +233,7 @@ Interrogates the data structure associated with an instance of @ref{font-dialog} to obtain the @ref{font} and @ref{color} corresponding to selections made by the user, and returns -them via @sc{values}. The @code{gc} parameter should be the same +them via @sc{values}. The @var{gc} parameter should be the same @ref{graphics-context} object with which the dialog was created. If the user cancelled the dialog, the font value will be @sc{nil}. Also, the color value will be @sc{nil} if the dialog was created with @@ -242,12 +242,12 @@ @end defun @deffn GenericFunction give-focus self -Places keyboard focus on @code{self}. +Places keyboard focus on @var{self}. @end deffn @anchor{horizontal-scrollbar-p} @deffn GenericFunction horizontal-scrollbar-p self => boolean -Returns T if @code{self} has been configured to display a horizontal +Returns T if @var{self} has been configured to display a horizontal scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @@ -270,7 +270,7 @@ @anchor{line-count} @deffn GenericFunction line-count self => integer -Returns the total number of lines (e.g., of text) contained by @code{self}. +Returns the total number of lines (e.g., of text) contained by @var{self}. @end deffn @deffn GenericFunction location self => @ref{point} @@ -281,9 +281,9 @@ @end deffn @deffn GenericFunction mapchildren self func => result-list -Calls @code{func}, which is a function of two arguments, for each -child of @code{self} and places @code{func}'s return value in -@code{result-list}. @code{func}'s two arguments are @code{self} and +Calls @var{func}, which is a function of two arguments, for each +child of @var{self} and places @var{func}'s return value in +@var{result-list}. @var{func}'s two arguments are @var{self} and the current child. @end deffn @@ -343,8 +343,8 @@ @anchor{owner} @deffn GenericFunction owner self -Returns the @code{owner} of @code{self}, which may be different from -@code{self}'s @ref{parent} because the window ownership hierarchy +Returns the @var{owner} of @var{self}, which may be different from +@var{self}'s @ref{parent} because the window ownership hierarchy includes the relationships between physically separate @ref{top-level}s and dialogs. And it is possible for a window to be unowned but still have a @ref{parent}. Consequently, calling @@ -370,7 +370,7 @@ @anchor{parent} @deffn GenericFunction parent self => @ref{window} -Returns the @code{parent} of @code{self}. In the case of @ref{panel}s +Returns the @code{parent} of @var{self}. In the case of @ref{panel}s and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or @ref{top-level} window. In the case of a dialog or @ref{top-level}, then a @ref{root-window} is returned. In the case of a @code{submenu}, @@ -391,8 +391,8 @@ @anchor{paste-text} @deffn GenericFunction paste-text self This function is a shortcut for a common clipboard transfer operation, -namely the transfer of text from the system clipboard to @code{self}. -Depending on the current selection within @code{self}, the text either +namely the transfer of text from the system clipboard to @var{self}. +Depending on the current selection within @var{self}, the text either gets inserted or existing content is replaced. Some @ref{control}s like the @ref{edit} control have built-in clipboard functionality, and in such cases, the implementation of this function delegates directly. See @@ -403,12 +403,12 @@ @anchor{preferred-size} @deffn GenericFunction preferred-size self width-hint height-hint -Implement this function to return @code{self}'s preferred @ref{size}; -that is, the dimensions that @code{self} computes as being the best +Implement this function to return @var{self}'s preferred @ref{size}; +that is, the dimensions that @var{self} computes as being the best fit for itself and/or its children. If one or both of -@code{width-hint} and @code{height-hint} are positive, then each such +@var{width-hint} and @var{height-hint} are positive, then each such parameter is used as a constraint on the @ref{size} calculation -- if -for example @code{width-hint} is some positive value, then @code{self} +for example @var{width-hint} is some positive value, then @var{self} must determine how tall it would be given that width. @end deffn @@ -418,7 +418,7 @@ @end defun @deffn GenericFunction redo-available-p self => boolean -Returns T if @code{self} has @sc{redo} capability and has an +Returns T if @var{self} has @sc{redo} capability and has an operation that can be redone; @sc{nil} otherwise. @end deffn @@ -436,11 +436,11 @@ @deffn GenericFunction resizable-p self => boolean (setf (@strong{resizable-p} @var{self}) @var{boolean})@* -Returns T if @code{self} can be resized by the user; @sc{nil} +Returns T if @var{self} can be resized by the user; @sc{nil} otherwise. The corresponding @sc{setf} function is implemented for the @ref{top-level} class (but only has meaning when the @code{:frame} or @code{:workspace} styles are set), allowing the application to -modify the resizability of @code{self}, whereupon the frame +modify the resizability of @var{self}, whereupon the frame decorations are modified appropriately. @end deffn @@ -514,14 +514,14 @@ @deffn GenericFunction text self => string (setf (@strong{text} @var{self}) @var{string})@* -For a @ref{window} or @ref{dialog}, this function returns @code{self}'s +For a @ref{window} or @ref{dialog}, this function returns @var{self}'s titlebar text (which may be blank). For other @ref{widget}s that have a text component, this function returns that text component. For anything else, this function returns @sc{nil}. @end deffn @deffn GenericFunction text-baseline self => integer -Returns the y coordinate value (relative to the top of @code{self}'s +Returns the y coordinate value (relative to the top of @var{self}'s bounding box) that correlates to the baseline of the text of the @ref{control}, if any. For controls in which a text baseline is not meaningful, such as a @ref{label} with an @ref{image}, this function @@ -544,7 +544,7 @@ @anchor{text-modified-p} @deffn GenericFunction text-modified-p self => boolean (setf (@strong{text-modified-p} @var{self}) @var{boolean})@*@* -Returns T if the text component of @code{self} has been modified by +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 widgets, since in some cases there are multiple text components and in @@ -553,7 +553,7 @@ @anchor{undo-available-p} @deffn GenericFunction undo-available-p self => boolean -Returns T if @code{self} has @sc{undo} capability and has an +Returns T if @var{self} has @sc{undo} capability and has an operation that can be undone; @sc{nil} otherwise. @end deffn @@ -584,7 +584,7 @@ @anchor{vertical-scrollbar-p} @deffn GenericFunction vertical-scrollbar-p self => boolean -Returns T if @code{self} has been configured to display a vertical +Returns T if @var{self} has been configured to display a vertical scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @@ -595,7 +595,7 @@ @html @deffn GenericFunction window->display self Return the @ref{display} object representing the monitor that is nearest -to @code{self}. The @ref{rectangle} bounding @code{self} is not required +to @var{self}. The @ref{rectangle} bounding @var{self} is not required to intersect the returned @ref{display}. @end deffn @end html Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Sep 8 11:32:27 2006 @@ -368,6 +368,7 @@ #:cut-text #:current-font #:cursor + #:data-of #:default-message-filter #:default-widget #:defmenu Added: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Fri Sep 8 11:32:27 2006 @@ -0,0 +1,134 @@ +;;;; +;;;; item-manager-unit-tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defvar *test-hwnd* (cffi:make-pointer 1)) + +(defun validate-item (expected actual &optional expected-id (expected-hwnd *default-hwnd*)) + (assert-true (typep actual 'mock-item)) + (if expected-id + (assert-equal expected-id (gfw:item-id actual)) + (assert-false (zerop (gfw::item-id actual)))) + (if expected-hwnd + (assert-equality #'cffi:pointer-eq expected-hwnd (gfs:handle actual)) + (assert-equality #'eql expected-hwnd (gfs:handle actual))) + (assert-equality #'equal expected (gfw:data-of actual))) + +(defun validate-item-array (expected array &optional (expected-hwnd *default-hwnd*)) + (assert-true (vectorp array)) + (assert-true (array-has-fill-pointer-p array)) + (assert-true (adjustable-array-p array)) + (assert-equal (length expected) (length array)) + (dotimes (i (length array)) + (validate-item (elt expected i) (elt array i) nil expected-hwnd))) + +(define-test copy-item-sequence-test + (let ((values '(a b c))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* values 'mock-item) *test-hwnd*) + (let ((tmp (loop for datum in values + collect (make-instance 'mock-item :data datum + :handle *test-hwnd*)))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)) + (let ((tmp (make-array 3 :initial-contents (loop for datum in values + collect datum)))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)) + (let ((tmp (make-array 3 :initial-contents (loop for datum in values + collect (make-instance 'mock-item + :data datum + :handle *test-hwnd*))))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)))) + +(define-test item-manager-modifications-test + (let ((values1 '(a b c)) + (values2 '(1 2 3)) + (disp (make-instance 'gfw:event-dispatcher))) + (let ((mgr1 (make-instance 'mock-item-manager :items values1)) + (mgr2 (make-instance 'mock-item-manager :items values2 :handle *test-hwnd*)) + (mgr3 (make-instance 'mock-item-manager))) + + (gfw::put-widget (gfw::thread-context) mgr3) + (unwind-protect + (progn + + ;; sanity check initial states + ;; + (validate-item-array values1 (slot-value mgr1 'gfw::items)) + (validate-item-array values2 (slot-value mgr2 'gfw::items) *test-hwnd*) + (assert-true (zerop (length (slot-value mgr3 'gfw::items)))) + + ;; append a new item to each and sanity check again + ;; + (gfw:append-item mgr1 'd disp) + (validate-item-array (append values1 '(d)) (slot-value mgr1 'gfw::items)) + (gfw:append-item mgr2 4 disp) + (validate-item-array (append values2 '(4)) (slot-value mgr2 'gfw::items) *test-hwnd*) + (gfw:append-item mgr3 t disp) + (validate-item-array (list t) (slot-value mgr3 'gfw::items)) + + ;; delete all from mgr1 + ;; + (let ((tmp (gfw:items-of mgr1))) + (assert-equal 4 (length tmp)) + (gfw:delete-all mgr1) + (assert-true (zerop (length (gfw:items-of mgr1)))) + (loop for actual in tmp + for expected in (append values1 '(d)) + do (validate-item expected actual nil nil))) + + ;; delete an item from mgr2 (using delete-item) + ;; + (let ((tmp (gfw:items-of mgr2))) + (gfw:delete-item mgr2 0) + (validate-item 1 (first tmp) nil nil) + (assert-equal 3 (length (gfw:items-of mgr2))) + (loop for actual in (gfw:items-of mgr2) + for expected in (subseq (append values2 '(4)) 1 4) + do (validate-item expected actual nil *test-hwnd*))) + + ;; delete last item from mgr3 (using dispose) + ;; + (let ((tmp (gfw:items-of mgr3))) + (gfs:dispose (first tmp)) + (assert-true (zerop (length (gfw:items-of mgr3)))) + (validate-item t (first tmp) nil nil)) + + ;; copy items from mgr2 to mgr1 + ;; + (setf (gfw:items-of mgr1) (gfw:items-of mgr2)) + (assert-equal 3 (length (gfw:items-of mgr1))) + (loop for actual in (gfw:items-of mgr1) + for expected in (subseq (append values2 '(4)) 1 4) + do (validate-item expected actual nil *test-hwnd*))) + + (gfw::delete-widget (gfw::thread-context) *default-hwnd*))))) Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Sep 8 11:32:27 2006 @@ -34,8 +34,8 @@ (in-package :graphic-forms.uitoolkit.tests) (define-test layout-attributes-test - (let ((widget1 (make-instance 'mock-widget :handle 1234)) - (widget2 (make-instance 'mock-widget :handle 5678))) + (let ((widget1 (make-instance 'mock-widget :handle (cffi:make-pointer 1234))) + (widget2 (make-instance 'mock-widget :handle (cffi:make-pointer 5678)))) (let ((data1 `(,widget1 (a 1 b 2))) (data2 `(,widget2 (a 10 c 30))) (layout (make-instance 'gfw:layout-manager))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Sep 8 11:32:27 2006 @@ -37,6 +37,8 @@ (defconstant +default-container-width+ 300) (defconstant +default-container-height+ 200) +(defvar *default-hwnd* (cffi:make-pointer #xFFFFFFFF)) + ;;; ;;; stand-in for a window, used as parent of mock-widget ;;; @@ -80,19 +82,19 @@ :initarg :min-size :initform (gfs:make-size)))) -(defmethod initialize-instance :after ((widget mock-widget) &key handle &allow-other-keys) - (setf (slot-value widget 'gfs:handle) (cffi:make-pointer (or handle #xFFFFFFFF)))) +(defmethod initialize-instance :after ((self mock-widget) &key handle &allow-other-keys) + (setf (slot-value self 'gfs:handle) (or handle *default-hwnd*))) -(defmethod gfw:location ((widget mock-widget)) +(defmethod gfw:location ((self mock-widget)) (gfs:make-point)) -(defmethod gfw:minimum-size ((widget mock-widget)) - (gfs:make-size :width (gfs:size-width (min-size-of widget)) - :height (gfs:size-height (min-size-of widget)))) +(defmethod gfw:minimum-size ((self mock-widget)) + (gfs:make-size :width (gfs:size-width (min-size-of self)) + :height (gfs:size-height (min-size-of self)))) -(defmethod gfw:preferred-size ((widget mock-widget) width-hint height-hint) +(defmethod gfw:preferred-size ((self mock-widget) width-hint height-hint) (let ((size (gfs:make-size)) - (min-size (min-size-of widget))) + (min-size (min-size-of self))) (if (< width-hint 0) (setf (gfs:size-width size) (gfs:size-width min-size)) (setf (gfs:size-width size) width-hint)) @@ -101,8 +103,30 @@ (setf (gfs:size-height size) height-hint)) size)) -(defmethod gfw:text-baseline ((widget mock-widget)) - (floor (* (gfs:size-height (min-size-of widget)) 3) 4)) +(defmethod gfw:text-baseline ((self mock-widget)) + (floor (* (gfs:size-height (min-size-of self)) 3) 4)) + +(defmethod gfw:visible-p ((self mock-widget)) + (visibility-of self)) + +;;; +;;; infrastructure for item-manager unit tests +;;; + +(defclass mock-item (gfw:item) ()) + +(defclass mock-item-manager (gfw:widget gfw:item-manager) ()) + +(defmethod initialize-instance :after ((self mock-item-manager) &key handle items &allow-other-keys) + (setf (slot-value self 'gfs:handle) (or handle *default-hwnd*)) + (if items + (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) items 'mock-item)))) + +(defmethod gfw:append-item ((self mock-item-manager) thing (disp gfw:event-dispatcher) &optional checked disabled) + (declare (ignore disabled checked)) + (let ((item (gfw::create-item-with-callback (gfs:handle self) 'mock-item thing disp))) + (vector-push-extend item (slot-value self 'gfw::items)) + item)) -(defmethod gfw:visible-p ((widget mock-widget)) - (visibility-of widget)) +(defmethod (setf gfw:items-of) (new-items (self mock-item-manager)) + (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) new-items 'mock-item))) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Fri Sep 8 11:32:27 2006 @@ -51,9 +51,8 @@ (t (funcall func thing))))) -(defun copy-item-sequence (parent new-items item-class) - (let ((hwnd (gfs:handle parent)) - (tc (thread-context)) +(defun copy-item-sequence (handle new-items item-class) + (let ((tc (thread-context)) (replacements (make-items-array))) (cond ((null new-items) @@ -63,7 +62,7 @@ (let ((item (elt new-items i))) (if (typep item item-class) (vector-push-extend item replacements) - (let ((tmp (make-instance item-class :handle hwnd :data item))) + (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements))))) replacements) @@ -71,7 +70,7 @@ (loop for item in new-items do (if (typep item item-class) (vector-push-extend item replacements) - (let ((tmp (make-instance item-class :handle hwnd :data item))) + (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements)))) replacements) @@ -101,9 +100,7 @@ (defmethod delete-item ((self item-manager) index) (let* ((items (slot-value self 'items)) (it (elt items index))) - (setf (slot-value self 'items) (remove it items :test #'items-equal-p)) - (if (gfs:disposed-p it) - (error 'gfs:disposed-error)) + (setf (slot-value self 'items) (remove it items :test #'items-equal)) (gfs:dispose it))) (defmethod delete-item-span :before ((self item-manager) (sp gfs:span)) @@ -127,7 +124,7 @@ (error 'gfs:disposed-error))) (defmethod item-index ((self item-manager) (it item)) - (let ((pos (position it (slot-value self 'items) :test #'items-equal-p))) + (let ((pos (position it (slot-value self 'items) :test #'items-equal))) (if (null pos) (return-from item-index 0)) 0)) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Fri Sep 8 11:32:27 2006 @@ -51,7 +51,7 @@ :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) item)) -(defun items-equal-p (item1 item2) +(defun items-equal (item1 item2) (= (item-id item1) (item-id item2))) ;;; @@ -68,16 +68,13 @@ (error 'gfs:toolkit-error :detail "null owner handle"))) (defmethod gfs:dispose ((self item)) - (setf (dispatcher self) nil) (let ((hwnd (gfs:handle self))) (unless (or (null hwnd) (cffi:null-pointer-p hwnd)) (let ((owner (get-widget (thread-context) hwnd))) (if owner (setf (slot-value owner 'items) - (remove self (slot-value owner 'items) :test #'items-equal-p)))))) + (remove self (slot-value owner 'items) :test #'items-equal)))))) (delete-tc-item (thread-context) self) - (setf (data-of self) nil) - (setf (item-id self) 0) (setf (slot-value self 'gfs:handle) nil)) (defmethod initialize-instance :after ((self item) &key callback &allow-other-keys) 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 8 11:32:27 2006 @@ -134,12 +134,12 @@ estimated-count (* estimated-count +estimated-text-size+))))) (if items - (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) + (setf (slot-value self 'items) (copy-item-sequence (gfs:handle self) items 'list-item))) (update-from-items self)) (defmethod (setf items-of) (new-items (self list-box)) (lb-delete-all self) - (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) + (setf (slot-value self 'items) (copy-item-sequence (gfs:handle self) new-items 'list-item)) (update-from-items self)) (defmethod preferred-size ((self list-box) width-hint height-hint) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Fri Sep 8 11:32:27 2006 @@ -70,7 +70,6 @@ ;;; (defmethod gfs:dispose ((self list-item)) -(print self) (let ((index (index-of self)) (howner (gfs:handle self))) (if howner 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 8 11:32:27 2006 @@ -55,6 +55,10 @@ (gfs:dispose ,gc))))) (defmacro with-drawing-disabled ((widget) &body body) + ;; FIXME: should this macro use enable-redraw instead? + ;; One immediate problem is that only one window can be + ;; locked at a time by LockWindowUpdate. + ;; (let ((tmp-widget (gensym))) `(let ((,tmp-widget ,widget)) (unwind-protect Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Fri Sep 8 11:32:27 2006 @@ -45,4 +45,5 @@ (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")))

1 0

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

07 Sep '06

Author: junrue Date: Thu Sep 7 01:46:41 2006 New Revision: 250 Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: revised item-manager protocol so that now we have selected-items and selected-span, implemented selected-items for list-box and fixed up menu implementation, more debugging/bugfixing via widget-tester Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Thu Sep 7 01:46:41 2006 @@ -69,6 +69,10 @@ @acronym{GFW} @end macro +@macro apps-shouldnt-call-function +This function should typically not be called from application code. +@end macro + @macro event-dispatcher-arg @item event-dispatcher The @ref{event-dispatcher} to process this event. Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Thu Sep 7 01:46:41 2006 @@ -568,6 +568,8 @@ data structures) with data derived from the @var{items} slot. If @var{self} has been assigned a sorting predicate, the array of items will be sorted prior to the internal model update. + +@apps-shouldnt-call-function @end deffn @anchor{update-native-style} @@ -576,6 +578,8 @@ @var{integer} and calls any additional API needed to ensure that @var{self}'s visual representation is refreshed. The supplied @var{integer} is returned. + +@apps-shouldnt-call-function @end deffn @anchor{vertical-scrollbar-p} Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Thu Sep 7 01:46:41 2006 @@ -375,7 +375,8 @@ @begin-control-subclass{list-box, This @ref{control} subclass represents a list of selectable items; it also inherits @ref{item-manager}. The list is always visible\, unlike -a combo-box., +a combo-box. Each of the @code{-select} style keywords mentioned below +are exclusive., event-select} @control-callback-initarg{list-box,event-select} @deffn Initarg :estimated-count @@ -400,11 +401,13 @@ keys. @item :multiple-select This style keyword enables individual toggling of multiple item -selections within the list-box. Without this style, the list-box will -only allow a single selection. +selections within the list-box. @item :no-select This style keyword means that the list-box will display items but not allow any selections. +@item :single-select +This style keyword means that the list-box only allows one item at a +time to be selected. This is the default selection style. @item :tab-stops This style keyword configures the list-box to to expand tab characters when rendering item strings. Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Sep 7 01:46:41 2006 @@ -520,7 +520,6 @@ #:trim-sizes #:undo-available-p #:update - #:update-from-items #:vertical-scrollbar #:visible-item-count #:visible-p Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Thu Sep 7 01:46:41 2006 @@ -65,15 +65,50 @@ (gfg:foreground-color gc) color)) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) -(defun lb-select (disp lb) - (declare (ignore disp)) - (print lb)) +(defun manage-lb-button-states (lb move-btn all-btn none-btn) + (let ((count (gfw:selected-count lb)) + (items (gfw:items-of lb))) + (gfw:enable move-btn (> count 0)) + (if all-btn + (gfw:enable all-btn (< count (length items)))) + (if none-btn + (gfw:enable none-btn (> count 0))))) + +(defun move-lb-content (orig-lb dest-lb) + (let ((sel-items (gfw:selected-items orig-lb))) + (if sel-items + (setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb)))))) (defun populate-list-box-test-panel () (setf (gfw:text *widget-tester-win*) "Widget Tester (List Boxes)") (let* ((panel-disp (make-instance 'widget-tester-panel-events)) - (lb1 nil) - (lb2 nil) + (lb1 nil) + (lb2 nil) + (btn-left nil) + (btn-right nil) + (btn-all nil) + (btn-none nil) + (lb1-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-right btn-all btn-none))) + (lb2-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-left nil nil))) + (btn-left-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb2 lb1) + (manage-lb-button-states lb1 btn-right btn-all btn-none) + (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (btn-right-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb1 lb2) + (manage-lb-button-states lb1 btn-right btn-all btn-none) + (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (btn-all-callback (lambda (disp btn) + (declare (ignore disp btn)))) + (btn-none-callback (lambda (disp btn) + (declare (ignore disp btn)))) + (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* :layout (make-instance 'gfw:flow-layout :spacing 4 :margins 4))) @@ -82,26 +117,43 @@ :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) (btn-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent outer-panel - :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) + :layout (make-instance 'gfw:flow-layout :style '(:vertical :normalize) :spacing 4 :margins 4))) (lb2-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent outer-panel :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4)))) + (make-instance 'gfw:label :text "Multiple Select:" :parent lb1-panel) (setf lb1 (make-instance 'gfw:list-box :parent lb1-panel - :callback #'lb-select + :callback lb1-callback :sort-predicate #'string< :style '(:multiple-select) :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) - (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " ==> ") nil) - (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " <== ") nil) + + (setf btn-right (make-instance 'gfw:button :parent btn-panel + :text " ==> " + :callback btn-right-callback)) + (gfw:enable btn-right nil) + (setf btn-left (make-instance 'gfw:button :parent btn-panel + :text " <== " + :callback btn-left-callback)) + (gfw:enable btn-left nil) + (setf btn-all (make-instance 'gfw:button :parent btn-panel + :text "Select All" + :callback btn-all-callback)) + (setf btn-none (make-instance 'gfw:button :parent btn-panel + :text "Select None" + :callback btn-none-callback)) + (gfw:enable btn-none nil) (gfw:pack btn-panel) + (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel - :callback #'lb-select + :callback lb2-callback :style '(:extend-select :want-scrollbar) :items (subseq *list-box-test-data* 4))) (gfw:pack lb2-panel) + (gfw:pack outer-panel) (let ((size (gfw:size lb1))) (setf (gfw:maximum-size lb1) size @@ -109,7 +161,6 @@ (gfw:maximum-size lb2) size (gfw:minimum-size lb2) size)) (setf (gfw:items-of lb1) *list-box-test-data*) - (gfw:update-from-items lb1) (gfw:delete-all lb2) outer-panel)) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Thu Sep 7 01:46:41 2006 @@ -39,6 +39,7 @@ (defun recreate-array (array) (make-array (array-dimensions array) + :element-type (array-element-type array) :adjustable (adjustable-array-p array) :fill-pointer (if (array-has-fill-pointer-p array) 0 nil))) @@ -64,6 +65,15 @@ (dotimes (i (length tmp)) (setf (elt result i) (second (elt tmp i)))))) result)) +(defun pick-elements (lisp-seq indices &optional count) + (let ((picks nil)) + (if (cffi:pointerp indices) + (dotimes (i count) + (push (elt lisp-seq (mem-aref indices :unsigned-int i)) picks)) + (dotimes (i (length indices)) + (push (elt lisp-seq (elt indices i)) picks))) + (reverse picks))) + (defun flatten (tree) (if (cl:atom tree) (list tree) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Thu Sep 7 01:46:41 2006 @@ -37,6 +37,9 @@ ;;; helper functions ;;; +(defun make-items-array (&optional (count 7)) + (make-array count :fill-pointer 0 :adjustable t)) + (defun call-text-provider (manager thing) (let ((func (text-provider-of manager)) (*print-readably* nil)) @@ -51,7 +54,7 @@ (defun copy-item-sequence (parent new-items item-class) (let ((hwnd (gfs:handle parent)) (tc (thread-context)) - (replacements (make-array 7 :fill-pointer 0 :adjustable t))) + (replacements (make-items-array))) (cond ((null new-items) replacements) @@ -85,10 +88,10 @@ (error 'gfs:disposed-error))) (defmethod delete-all ((self item-manager)) - (let ((items (items-of self))) + (let ((items (slot-value self 'items))) (dotimes (i (length items)) (gfs:dispose (aref items i)))) - (setf (items-of self) (make-array 7 :fill-pointer 0 :adjustable t))) + (setf (slot-value self 'items) (make-items-array))) (defmethod delete-item :before ((self item-manager) index) (declare (ignore index)) @@ -96,9 +99,9 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) - (let* ((items (items-of self)) + (let* ((items (slot-value self 'items)) (it (elt items index))) - (setf (items-of self) (remove it items :test #'items-equal-p)) + (setf (slot-value self 'items) (remove it items :test #'items-equal-p)) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) @@ -113,7 +116,7 @@ (delete-item self (gfs:span-start sp)))) (defmethod gfs:dispose ((self item-manager)) - (let ((items (items-of self)) + (let ((items (slot-value self 'items)) (tc (thread-context))) (dotimes (i (length items)) (delete-tc-item tc (elt items i))))) @@ -124,11 +127,23 @@ (error 'gfs:disposed-error))) (defmethod item-index ((self item-manager) (it item)) - (let ((pos (position it (items-of self) :test #'items-equal-p))) + (let ((pos (position it (slot-value self 'items) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) 0)) +(defmethod items-of ((self item-manager)) + (coerce (slot-value self 'items) 'list)) + +(defmethod selected-items :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod (setf selected-items) :before (items (self item-manager)) + (declare (ignore items)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod update-from-items :before ((self item-manager)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Thu Sep 7 01:46:41 2006 @@ -38,15 +38,14 @@ ;;; (defun create-item-with-callback (howner class-symbol thing disp) - (let ((item nil) - (id (increment-item-id (thread-context)))) + (let ((item nil)) (cond ((null disp) - (setf item (make-instance class-symbol :item-id id :data thing :handle howner))) + (setf item (make-instance class-symbol :data thing :handle howner))) ((functionp disp) - (setf item (make-instance class-symbol :item-id id :data thing :handle howner :callback disp))) + (setf item (make-instance class-symbol :data thing :handle howner :callback disp))) ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance class-symbol :item-id id :data thing :handle howner :dispatcher disp))) + (setf item (make-instance class-symbol :data thing :handle howner :dispatcher disp))) (t (error 'gfs:toolkit-error :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) @@ -70,12 +69,19 @@ (defmethod gfs:dispose ((self item)) (setf (dispatcher self) nil) + (let ((hwnd (gfs:handle self))) + (unless (or (null hwnd) (cffi:null-pointer-p hwnd)) + (let ((owner (get-widget (thread-context) hwnd))) + (if owner + (setf (slot-value owner 'items) + (remove self (slot-value owner 'items) :test #'items-equal-p)))))) (delete-tc-item (thread-context) self) (setf (data-of self) nil) (setf (item-id self) 0) (setf (slot-value self 'gfs:handle) nil)) (defmethod initialize-instance :after ((self item) &key callback &allow-other-keys) + (setf (item-id self) (increment-item-id (thread-context))) (when callback (unless (typep callback 'function) (error 'gfs:toolkit-error :detail ":callback value must be a function")) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Thu Sep 7 01:46:41 2006 @@ -52,11 +52,9 @@ (lognot (logior gfs::+lbs-multiplesel+ gfs::+lbs-extendedsel+)))) (logior orig-flags gfs::+lbs-nosel+)) -(defun lb-init-storage (hwnd item-count total-bytes) - (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) - -(defun lb-clear-content (hwnd) - (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) +(defun lb-single-select-flags (orig-flags) + (logand orig-flags + (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+)))) (defun lb-width (hwnd) (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) @@ -70,6 +68,14 @@ (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) count)) +(defun lb-delete-all (lb) + (let ((old-items (slot-value lb 'items))) + (gfs::send-message (gfs:handle lb) gfs::+lb-resetcontent+ 0 0) + (dotimes (i (length old-items)) + (let ((victim (elt old-items i))) + (setf (slot-value victim 'gfs:handle) nil) + (gfs:dispose victim))))) + ;;; ;;; methods ;;; @@ -82,7 +88,7 @@ (item (create-item-with-callback hcontrol 'list-item thing disp))) (lb-insert-item hcontrol #xFFFFFFFF text (cffi:null-pointer)) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) item)) (defmethod compute-style-flags ((self list-box) &rest extra-data) @@ -97,6 +103,7 @@ (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) (:no-select (setf std-flags (lb-no-select-flags std-flags))) + (:single-select (setf std-flags (lb-single-select-flags std-flags))) ;; styles that can be combined ;; @@ -105,6 +112,10 @@ (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) +(defmethod delete-all ((self list-box)) + (lb-delete-all self) + (setf (slot-value self 'items) (make-items-array))) + (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) @@ -115,23 +126,19 @@ 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)) - (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) + (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+))))) (if items (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) (update-from-items self)) -(defmethod (setf items-of) :before (new-items (self list-box)) - (declare (ignore new-items)) - (let ((old-items (items-of self))) - (dotimes (i (length old-items)) - (let ((victim (elt old-items i))) - (setf (slot-value victim 'gfs:handle) nil) - (gfs:dispose victim))))) - -(defmethod (setf items-of) :after (new-items (self list-box)) +(defmethod (setf items-of) (new-items (self list-box)) + (lb-delete-all self) (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) (update-from-items self)) @@ -180,15 +187,38 @@ (incf (gfs:size-width size) (vertical-scrollbar-width))) size)) +(defmethod selected-count ((self list-box)) + (let ((hwnd (gfs:handle self))) + (if (test-native-style self gfs::+lbs-nosel+) + (if (>= (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0) 0) 1 0) + (let ((count (gfs::send-message hwnd gfs::+lb-getselcount+ 0 0))) + (if (< count 0) 0 count))))) + +(defmethod selected-items ((self list-box)) + (let ((hwnd (gfs:handle self)) + (items (slot-value self 'items))) + (if (and (not (test-native-style self gfs::+lbs-extendedsel+)) + (not (test-native-style self gfs::+lbs-multiplesel+))) + (let ((index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) + (if (and (>= index 0) (< index (length items))) + (list (elt items index)) + nil)) + (let ((count (gfs::send-message hwnd gfs::+lb-getselcount+ 0 0))) + (if (<= count 0) + nil + (cffi:with-foreign-object (indices :unsigned-int count) + (if (/= (gfs::send-message hwnd gfs::+lb-getselitems+ count (cffi:pointer-address indices)) count) + nil + (gfs::pick-elements items indices count)))))))) + (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (hwnd (gfs:handle self))) (when sort-func - (setf (slot-value self 'items) (gfs::indexed-sort (items-of self) sort-func #'data-of))) + (setf (slot-value self 'items) (gfs::indexed-sort (slot-value self 'items) sort-func #'data-of))) (enable-redraw self nil) (unwind-protect - (let ((items (items-of self))) - (lb-clear-content hwnd) + (let ((items (slot-value self 'items))) (dotimes (index (length items)) (let* ((item (elt items index)) (text (call-text-provider self (data-of item)))) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Thu Sep 7 01:46:41 2006 @@ -70,6 +70,7 @@ ;;; (defmethod gfs:dispose ((self list-item)) +(print self) (let ((index (index-of self)) (howner (gfs:handle self))) (if howner Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Thu Sep 7 01:46:41 2006 @@ -79,8 +79,8 @@ nil))) (defun visit-menu-tree (menu fn) - (dotimes (index (length (items-of menu))) - (let ((it (elt (items-of menu) index)) + (dotimes (index (length (slot-value menu 'items))) + (let ((it (elt (slot-value menu 'items) index)) (child (sub-menu menu index))) (unless (null child) (visit-menu-tree child fn)) @@ -97,32 +97,30 @@ (text (call-text-provider self thing))) (append-menuitem hmenu (item-id item) text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) item)) (defmethod append-separator ((self menu)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-item-id tc)) (hmenu (gfs:handle self)) - (item (make-instance 'menu-item :handle hmenu :item-id id))) - (append-menuitem hmenu id nil (cffi:null-pointer) (cffi:null-pointer) nil nil) + (item (make-instance 'menu-item :handle hmenu))) + (append-menuitem hmenu (item-id item) nil (cffi:null-pointer) (cffi:null-pointer) nil nil) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) item)) (defmethod append-submenu ((self menu) text (submenu menu) disp &optional disabled checked) (if (or (gfs:disposed-p self) (gfs:disposed-p submenu)) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-item-id tc)) (hparent (gfs:handle self)) (hmenu (gfs:handle submenu)) - (item (make-instance 'menu-item :handle hparent :item-id id))) - (append-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked) + (item (make-instance 'menu-item :handle hparent))) + (append-menuitem hparent (item-id item) text (cffi:null-pointer) hmenu disabled checked) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) (put-widget tc submenu) (cond ((null disp)) 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 7 01:46:41 2006 @@ -170,7 +170,6 @@ :initarg :sort-predicate :initform nil) (items - :accessor items-of ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t)) (text-provider Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu Sep 7 01:46:41 2006 @@ -347,15 +347,6 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod selected-items :before ((self widget)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - -(defmethod (setf selected-items) :before (items (self widget)) - (declare (ignore items)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - (defmethod selected-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

1 0

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

06 Sep '06

Author: junrue Date: Wed Sep 6 01:08:05 2006 New Revision: 249 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: API cleanup: collapsed selection-span and select-span into selected-span and associated setf function Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Wed Sep 6 01:08:05 2006 @@ -449,37 +449,56 @@ or to the unselected state if @sc{nil}. @end deffn +@anchor{select-all} @deffn GenericFunction select-all self flag -Sets the entire content of @code{self} to the selected state if +Sets the entire content of @var{self} to the selected state if @var{flag} is not @sc{nil} or to the unselected state if @sc{nil}. @end deffn -@anchor{select-items} -@deffn GenericFunction select-items self indices flag -Sets the @ref{item}s of @var{self}, each identified by a zero-based -index from the @var{indices} @sc{list}, to the selected state if -@var{flag} is not @sc{nil} or to the unselected state if @sc{nil}. -This is the function to use when not all of the items in question -are contiguous. +@anchor{selected-count} +@deffn GenericFunction selected-count self => integer +Returns the number of @ref{item}s selected in @var{self}. @end deffn -@anchor{select-span} -@deffn GenericFunction select-span self span -Sets the @ref{item}s of @var{self} that lie within @var{span} to -the selected state. An existing selection's extent is modified -to match the new @var{span}. -@end deffn +@anchor{selected-items} +@deffn GenericFunction selected-items self => list +(setf (@strong{selected-items} @var{self}) @var{list}) + +Returns a @sc{list} containing subclasses of @ref{item} appropriate +for @var{self} that correspond to selections made by the user, or +@sc{nil} if there are no selections. This function is defined only +for @ref{widget}s whose notion of @emph{selection} is a set of +item objects. -@deffn GenericFunction selection-span self => @ref{span} -Returns a span object describing the @var{start} and @var{end} of the -selection within @var{self}. If there is no selection, this function -returns @sc{nil}. +The @sc{setf} function takes a @var{list} of item subclasses +appropriate for @var{self} which identify the items in +@var{self} that should be selected. Passing @sc{nil} will unselect all +items, which is equivalent to calling @ref{select-all} with @sc{nil}. @end deffn +@anchor{selected-p} @deffn GenericFunction selected-p self => boolean Returns T if @var{self} is in the selected state; @sc{nil} otherwise. @end deffn +@anchor{selected-span} +@deffn GenericFunction selected-span self => @var{object}, @var{span} +(setf (@strong{selected-span} @var{self}) @var{span}) + +Returns a @ref{span} describing a range of data within @var{self} +that is in the selected state, as well as an @var{object} comprising +the selected data. If there is no selection, this +function returns @sc{nil} for both values. This function is defined +only for @ref{widget}s whose notion of @emph{selection} is a +contiguous range of simple data (e.g., characters in a string). + +The corresponding @sc{setf} function sets the content of +@var{self} whose indices lie within @var{span} to the selected +state. An existing selection's extent is modified to match the +new @var{span}. Passing @sc{nil} for @var{span} will unselect +all content. +@end deffn + @anchor{show} @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Sep 6 01:08:05 2006 @@ -98,17 +98,19 @@ (unless *textedit-control* (return-from manage-textedit-edit-menu nil)) (let ((items (gfw:items-of menu)) - (text (gfw:text *textedit-control*)) - (text-sel (gfw:selection-span *textedit-control*))) - (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)) - (gfw:enable (elt items 2) text-sel) - (gfw:enable (elt items 3) text-sel) - (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*)) - (gfw:enable (elt items 5) text-sel) - (gfw:enable (elt items 12) (and (> (length text) 0) - (or (null text-sel) - (> (gfs:span-start text-sel) 0) - (< (gfs:span-end text-sel) (length text))))))) + (text (gfw:text *textedit-control*))) + (multiple-value-bind (sub-text text-sel) + (gfw:selected-span *textedit-control*) + (declare (ignore sub-text)) + (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)) + (gfw:enable (elt items 2) text-sel) + (gfw:enable (elt items 3) text-sel) + (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*)) + (gfw:enable (elt items 5) text-sel) + (gfw:enable (elt items 12) (and (> (length text) 0) + (or (null text-sel) + (> (gfs:span-start text-sel) 0) + (< (gfs:span-end text-sel) (length text)))))))) (defun textedit-edit-copy (disp item) (declare (ignore disp item)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Sep 6 01:08:05 2006 @@ -487,12 +487,10 @@ #:scroll #:select #:select-all - #:select-items + #:selected-count + #:selected-items #:selected-p - #:selection-count - #:selection-index - #:selection-indices - #:selection-span + #:selected-span #:show #:show-column #:show-header Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Wed Sep 6 01:08:05 2006 @@ -133,13 +133,7 @@ (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 (length (text self))) (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 0))) -(defmethod select-span ((self edit) (span gfs:span)) - (with-drawing-disabled (self) - (let ((hwnd (gfs:handle self))) - (gfs::send-message hwnd gfs::+em-setsel+ 1 1) - (gfs::send-message hwnd gfs::+em-setsel+ (gfs:span-start span) (gfs:span-end span))))) - -(defmethod selection-span ((self edit)) +(defmethod selected-span ((self edit)) (cffi:with-foreign-object (start-ptr :unsigned-long) (cffi:with-foreign-object (end-ptr :unsigned-long) (gfs::send-message (gfs:handle self) @@ -147,8 +141,17 @@ (cffi:pointer-address start-ptr) (cffi:pointer-address end-ptr)) (let ((start (cffi:mem-ref start-ptr :unsigned-long)) - (end (cffi:mem-ref end-ptr :unsigned-long))) - (if (= start end) nil (gfs:make-span :start start :end end)))))) + (end (cffi:mem-ref end-ptr :unsigned-long)) + (str (text self))) + (if (= start end) + (values nil nil) + (values (subseq str start end) (gfs:make-span :start start :end end))))))) + +(defmethod (setf selected-span) ((span gfs:span) (self edit)) + (with-drawing-disabled (self) + (let ((hwnd (gfs:handle self))) + (gfs::send-message hwnd gfs::+em-setsel+ 1 1) + (gfs::send-message hwnd gfs::+em-setsel+ (gfs:span-start span) (gfs:span-end span))))) (defmethod text ((self edit)) (get-widget-text self)) 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 6 01:08:05 2006 @@ -327,26 +327,23 @@ (defgeneric select-all (self flag) (:documentation "Set all items of this object into (or out of) the selected state.")) -(defgeneric select-items (self indices flag) - (:documentation "Set items of self, each identified by a zero-based index, into (or out of) the selected state.")) +(defgeneric selected-count (self) + (:documentation "Returns the number of this object's items that are selected.")) + +(defgeneric selected-items (self) + (:documentation "Returns a list of item subclasses representing selected items in self, or nil if no items are selected.")) -(defgeneric select-span (self span) - (:documentation "Set items of self that lie within span into the selected state.")) +(defgeneric (setf selected-items) (items self) + (:documentation "Updates self's visual display such that the specified items are selected.")) (defgeneric selected-p (self) (:documentation "Returns T if the object is in the selected state; nil otherwise.")) -(defgeneric selection-count (self) - (:documentation "Returns the number of this object's items that are selected.")) - -(defgeneric selection-index (self) - (:documentation "Returns the zero-based index of the currently-selected item, or nil if no item is selected.")) - -(defgeneric selection-indices (self) - (:documentation "Returns a list of zero-based indices identifying the selected items within this object.")) +(defgeneric selected-span (self) + (:documentation "Returns a span describing the range of data selected in self, and the selected data.")) -(defgeneric selection-span (self) - (:documentation "Returns a span object describing the start and end indices of the selection within self.")) +(defgeneric (setf selected-span) (span self) + (:documentation "Updates self's visual display such that the data within span is selected.")) (defgeneric show (self flag) (:documentation "Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed Sep 6 01:08:05 2006 @@ -343,13 +343,16 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod select-items :before ((self widget) items flag) - (declare (ignore items flag)) +(defmethod selected-count :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod select-span :before ((self widget) span) - (declare (ignore span)) +(defmethod selected-items :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod (setf selected-items) :before (items (self widget)) + (declare (ignore items)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -360,7 +363,15 @@ (defmethod selected-p ((self widget)) nil) -(defmethod selection-span :before ((self widget)) +(defmethod selected-span :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod selected-span ((self widget)) + nil) + +(defmethod (setf selected-span) :before (span (self widget)) + (declare (ignore span)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

1 0

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

05 Sep '06

Author: junrue Date: Tue Sep 5 11:39:37 2006 New Revision: 248 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: converted update-native-style to a generic function, added other convenience functions for querying style flags Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Tue Sep 5 11:39:37 2006 @@ -546,9 +546,17 @@ @anchor{update-from-items} @deffn GenericFunction update-from-items self Synchronizes @var{self}'s internal model (i.e., a native control's -data structures) with the list from the @var{items} slot -after that list has been sorted. Application code typically does not -need to call this function. +data structures) with data derived from the @var{items} slot. +If @var{self} has been assigned a sorting predicate, the array +of items will be sorted prior to the internal model update. +@end deffn + +@anchor{update-native-style} +@deffn GenericFunction update-native-style self integer => integer +This function replaces the native style flags of @var{self} with +@var{integer} and calls any additional API needed to ensure that +@var{self}'s visual representation is refreshed. The supplied +@var{integer} is returned. @end deffn @anchor{vertical-scrollbar-p} Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Tue Sep 5 11:39:37 2006 @@ -93,8 +93,8 @@ :style '(:multiple-select) :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) - (make-instance 'gfw:button :parent btn-panel :text " ==> ") - (make-instance 'gfw:button :parent btn-panel :text " <== ") + (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " ==> ") nil) + (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " <== ") nil) (gfw:pack btn-panel) (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Sep 5 11:39:37 2006 @@ -140,3 +140,7 @@ (defmethod text-baseline ((self button)) (widget-text-baseline self +vertical-button-text-margin+)) + +(defmethod update-native-style ((self button) flags) + (gfs::send-message (gfs:handle self) gfs::+bm-setstyle+ flags 1) + flags) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Sep 5 11:39:37 2006 @@ -195,3 +195,12 @@ (defmethod text-baseline ((self control)) (gfs:size-height (size self))) + +(defmethod update-native-style ((self control) flags) + (let ((hwnd (gfs:handle self))) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+))) + flags) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Tue Sep 5 11:39:37 2006 @@ -106,16 +106,16 @@ (let ((old-widget (cancel-widget self))) (if old-widget (let* ((hwnd (gfs:handle old-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style old-widget))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (update-native-style old-widget style)))) (let* ((hwnd (gfs:handle cancel-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style cancel-widget))) (setf style (logior style gfs::+bs-pushbutton+)) (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idcancel+) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) + (update-native-style cancel-widget style))) (defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) @@ -144,18 +144,18 @@ (let ((old-widget (default-widget self))) (if old-widget (let* ((hwnd (gfs:handle old-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style old-widget))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (update-native-style old-widget style)))) (let* ((hdlg (gfs:handle self)) (hwnd (gfs:handle def-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style def-widget))) (setf style (logior style gfs::+bs-defpushbutton+)) (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idok+) (gfs::send-message hdlg gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) + (update-native-style def-widget style))) (defmethod gfs:dispose ((self dialog)) (reenable-top-levels) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Sep 5 11:39:37 2006 @@ -41,12 +41,10 @@ ;;; (defmethod auto-hscroll-p ((self edit)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+es-autohscroll+) gfs::+es-autohscroll+))) + (test-native-style self gfs::+es-autohscroll+)) (defmethod auto-vscroll-p ((self edit)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+))) + (test-native-style self gfs::+es-autovscroll+)) (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) @@ -84,7 +82,7 @@ (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0)) (defmethod enable-scrollbars ((self edit) horizontal vertical) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) + (let ((bits (get-native-style self))) (if horizontal (setf bits (logior bits gfs::+ws-hscroll+)) (setf bits (logand bits (lognot gfs::+ws-hscroll+)))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Sep 5 11:39:37 2006 @@ -117,8 +117,7 @@ (defmethod (setf image) ((image gfg:image) (label label)) (if (or (gfs:disposed-p label) (gfs:disposed-p image)) (error 'gfs:disposed-error)) - (let* ((hwnd (gfs:handle label)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (let* ((orig-flags (get-native-style label)) (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+))) (flags (logior etch-flags @@ -142,8 +141,8 @@ (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) (setf image tmp-image))) (if (/= orig-flags flags) - (gfs::set-window-long hwnd gfs::+gwl-style+ flags)) - (gfs::send-message hwnd + (update-native-style label flags)) + (gfs::send-message (gfs:handle label) gfs::+stm-setimage+ gfs::+image-bitmap+ (cffi:pointer-address (gfs:handle image))))) @@ -164,9 +163,8 @@ (init-control label)) (defmethod preferred-size ((self label) width-hint height-hint) - (let* ((hwnd (gfs:handle self)) - (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) - (b-width (* (border-width self) 2))) + (let ((bits (get-native-style self)) + (b-width (* (border-width self) 2))) (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) (let ((image (image self))) (if image @@ -191,23 +189,18 @@ (get-widget-text self)) (defmethod (setf text) (str (self label)) - (let* ((hwnd (gfs:handle self)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (let* ((orig-flags (get-native-style self)) (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+)))) (multiple-value-bind (std-flags ex-flags) (compute-style-flags self nil nil str) (declare (ignore ex-flags)) - (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags - std-flags - +default-child-style+)))) + (update-native-style self (logior etch-flags std-flags +default-child-style+)))) (set-widget-text self str)) (defmethod text-baseline ((self label)) (let ((b-width (border-width self))) - (if (= (logand (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+) - gfs::+ss-bitmap+) - gfs::+ss-bitmap+) + (if (test-native-style self gfs::+ss-bitmap+) (let ((image (image self))) (if image (+ (gfs:size-height (gfg:size image)) b-width) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Sep 5 11:39:37 2006 @@ -52,6 +52,24 @@ (lognot (logior gfs::+lbs-multiplesel+ gfs::+lbs-extendedsel+)))) (logior orig-flags gfs::+lbs-nosel+)) +(defun lb-init-storage (hwnd item-count total-bytes) + (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) + +(defun lb-clear-content (hwnd) + (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) + +(defun lb-width (hwnd) + (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) + (if (< width 0) + (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) + width)) + +(defun lb-item-count (hwnd) + (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (if (< count 0) + (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) + count)) + ;;; ;;; methods ;;; @@ -151,15 +169,14 @@ ((>= height-hint 0) (setf (gfs:size-height size) height-hint)) (t - (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd))))) + (setf (gfs:size-height size) (* (lb-item-count hwnd) (1+ (lb-item-height hwnd)))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) (incf (gfs:size-width size) (+ b-width 4))) (if (zerop (gfs:size-height size)) (setf (gfs:size-height size) +default-widget-height+) (incf (gfs:size-height size) b-width)) - (if (= (logand (gfs::get-window-long hwnd gfs::+gwl-style+) gfs::+ws-vscroll+) - gfs::+ws-vscroll+) + (if (test-native-style self gfs::+ws-vscroll+) (incf (gfs:size-width size) (vertical-scrollbar-width))) size)) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Tue Sep 5 11:39:37 2006 @@ -37,12 +37,6 @@ ;;; helper functions ;;; -(defun lb-init-storage (hwnd item-count total-bytes) - (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) - -(defun lb-clear-content (hwnd) - (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) - (defun lb-insert-item (hwnd index label hbmp) (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box (let ((text (or label ""))) @@ -51,18 +45,6 @@ (if (< retval 0) (error 'gfs:toolkit-error :detail (format nil "LB_INSERTSTRING failed: ~d" retval))))))) -(defun lb-width (hwnd) - (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) - (if (< width 0) - (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) - width)) - -(defun lb-item-count (hwnd) - (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) - (if (< count 0) - (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) - count)) - (defun lb-item-height (hwnd) (let ((height (gfs::send-message hwnd gfs::+lb-getitemheight+ 0 0))) (if (< height 0) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Sep 5 11:39:37 2006 @@ -52,9 +52,8 @@ -1)) (defun update-top-level-resizability (win same-size-flag) - (let* ((hwnd (gfs:handle win)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) - (new-flags 0)) + (let ((orig-flags (get-native-style win)) + (new-flags 0)) (cond (same-size-flag (setf new-flags (logand orig-flags (lognot gfs::+ws-maximizebox+))) @@ -192,8 +191,7 @@ (format stream "max size: ~a" (maximum-size self)))) (defmethod resizable-p ((self top-level)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+ws-thickframe+) gfs::+ws-thickframe+))) + (test-native-style self gfs::+ws-thickframe+)) (defmethod (setf resizable-p) (flag (self top-level)) (let ((style (style-of self))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Sep 5 11:39:37 2006 @@ -423,6 +423,9 @@ (defgeneric update-from-items (self) (:documentation "Rebuilds the native control's model of self from self's item list.")) +(defgeneric update-native-style (self flags) + (:documentation "Modifies self's native style flags and refreshes self's visual appearance.")) + (defgeneric vertical-scrollbar (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Sep 5 11:39:37 2006 @@ -141,14 +141,6 @@ (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) retval)) -(defun update-native-style (widget bits) - (let ((hwnd (gfs:handle widget))) - (gfs::set-window-long hwnd gfs::+gwl-style+ bits) - (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ - gfs::+swp-nomove+ - gfs::+swp-nosize+ - gfs::+swp-nozorder+)))) - (defun get-widget-text (w) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) @@ -282,3 +274,15 @@ (let ((new-width (funcall compare-fn (gfs:size-width new-size) (gfs:size-width current-size))) (new-height (funcall compare-fn (gfs:size-height new-size) (gfs:size-height current-size)))) (gfs:make-size :width new-width :height new-height))) + +(defun get-native-style (widget) + (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+)) + +(defun get-native-exstyle (widget) + (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+)) + +(defun test-native-style (widget bits) + (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) bits)) + +(defun test-native-exstyle (widget bits) + (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) bits)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Sep 5 11:39:37 2006 @@ -92,8 +92,7 @@ (error 'gfs:disposed-error))) (defmethod border-width ((self widget)) - (let* ((hwnd (gfs:handle self)) - (bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (let ((bits (get-native-exstyle self))) (cond ((/= (logand bits gfs::+ws-ex-clientedge+) 0) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxedge+))) @@ -103,8 +102,7 @@ (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) ((/= (logand bits gfs::+ws-ex-windowedge+) 0) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxdlgframe+)))) - (setf bits (gfs::get-window-long hwnd gfs::+gwl-style+)) - (when (logand bits gfs::+ws-border+) + (when (test-native-style self gfs::+ws-border+) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) 0)) @@ -434,6 +432,11 @@ (unless (gfs:null-handle-p hwnd) (gfs::update-window hwnd)))) +(defmethod update-native-style :before ((self widget) bits) + (declare (ignore bits)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod visible-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Sep 5 11:39:37 2006 @@ -152,16 +152,16 @@ (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) color)) -(defmethod compute-outer-size ((win window) desired-client-size) - (let ((hwnd (gfs:handle win)) +(defmethod compute-outer-size ((self window) desired-client-size) + (let ((hwnd (gfs:handle self)) (new-size (gfs:make-size))) (gfs::with-rect (setf gfs::right (gfs:size-width desired-client-size) gfs::bottom (gfs:size-height desired-client-size)) (if (zerop (gfs::adjust-window-rect gfs::rect-ptr - (gfs::get-window-long hwnd gfs::+gwl-style+) + (get-native-style self) (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) - (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (get-native-exstyle self))) (error 'gfs:win32-error :detail "adjust-window-rect failed")) (setf (gfs:size-width new-size) (- gfs::right gfs::left) (gfs:size-height new-size) (- gfs::bottom gfs::top))) @@ -314,6 +314,15 @@ (outer-size self sz) sz)) +(defmethod update-native-style ((self window) flags) + (let ((hwnd (gfs:handle self))) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+))) + flags) + (defmethod window->display :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

1 0

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

05 Sep '06

Author: junrue Date: Tue Sep 5 00:26:37 2006 New Revision: 247 Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/list-box.lisp Log: fixed bugs in indexed-sort, got listbox selection notification working, revised list-box compute-style-flags Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Tue Sep 5 00:26:37 2006 @@ -45,7 +45,7 @@ (assert-true (> (gfs:size-height size)) 0)) (assert-true (> (length (gfw:text display)) 0)))) -(define-test indexed-sort-test +(define-test indexed-sort-list-test (let* ((orig1 '("zzz" "mmm" "aaa")) (result1 (gfs::indexed-sort orig1 #'string< #'identity)) (orig2 '((zzz 10) (mmm 5) (aaa 1))) @@ -59,3 +59,46 @@ (assert-true (= 5 (second (second result2)))) (assert-true (eql 'zzz (first (third result2)))) (assert-true (= 10 (second (third result2)))))) + +(defun validate-array-elements (arr1 arr2) + (assert-true (string= "aaa" (elt arr1 0))) + (assert-true (string= "mmm" (elt arr1 1))) + (assert-true (string= "zzz" (elt arr1 2))) + (assert-true (eql 'aaa (first (elt arr2 0)))) + (assert-true (= 1 (second (elt arr2 0)))) + (assert-true (eql 'mmm (first (elt arr2 1)))) + (assert-true (= 5 (second (elt arr2 1)))) + (assert-true (eql 'zzz (first (elt arr2 2)))) + (assert-true (= 10 (second (elt arr2 2))))) + +(define-test indexed-sort-non-adjustable-array-test + (let* ((orig1 (make-array 3 :initial-contents '("zzz" "mmm" "aaa"))) + (result1 (gfs::indexed-sort orig1 #'string< #'identity)) + (orig2 (make-array 3 :initial-contents '((zzz 10) (mmm 5) (aaa 1)))) + (result2 (gfs::indexed-sort orig2 #'string< #'first))) + (assert-false (array-has-fill-pointer-p result1)) + (assert-false (array-has-fill-pointer-p result2)) + (assert-false (adjustable-array-p result1)) + (assert-false (adjustable-array-p result2)) + (assert-equal 3 (first (array-dimensions result1))) + (assert-equal 3 (first (array-dimensions result2))) + (assert-equal 3 (length result1)) + (assert-equal 3 (length result2)) + (validate-array-elements result1 result2))) + +(define-test indexed-sort-adjustable-array-test + (let ((orig1 (make-array 3 :adjustable t :fill-pointer 0)) + (orig2 (make-array 3 :adjustable t :fill-pointer 0))) + (loop for item in '("zzz" "mmm" "aaa") do (vector-push item orig1)) + (loop for item in '((zzz 10) (mmm 5) (aaa 1)) do (vector-push item orig2)) + (let ((result1 (gfs::indexed-sort orig1 #'string< #'identity)) + (result2 (gfs::indexed-sort orig2 #'string< #'first))) + (assert-true (array-has-fill-pointer-p result1)) + (assert-true (array-has-fill-pointer-p result2)) + (assert-true (adjustable-array-p result1)) + (assert-true (adjustable-array-p result2)) + (assert-equal 3 (first (array-dimensions result1))) + (assert-equal 3 (first (array-dimensions result2))) + (assert-equal 3 (length result1)) + (assert-equal 3 (length result2)) + (validate-array-elements result1 result2)))) Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Tue Sep 5 00:26:37 2006 @@ -60,21 +60,61 @@ (defmethod gfw:event-paint ((disp widget-tester-panel-events) window gc rect) (declare (ignore rect)) - (setf (gfg:background-color gc) gfg:*color-white* - (gfg:foreground-color gc) gfg:*color-white*) + (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) +(defun lb-select (disp lb) + (declare (ignore disp)) + (print lb)) + (defun populate-list-box-test-panel () - (let* ((disp (make-instance 'widget-tester-panel-events)) - (layout (make-instance 'gfw:flow-layout)) - (panel (make-instance 'gfw:panel :dispatcher disp - :parent *widget-tester-win* - :layout layout))) - (make-instance 'gfw:list-box :parent panel :items *list-box-test-data*) - (gfW:pack panel) - panel)) + (setf (gfw:text *widget-tester-win*) "Widget Tester (List Boxes)") + (let* ((panel-disp (make-instance 'widget-tester-panel-events)) + (lb1 nil) + (lb2 nil) + (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent *widget-tester-win* + :layout (make-instance 'gfw:flow-layout :spacing 4 :margins 4))) + (lb1-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) + (btn-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) + (lb2-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4)))) + (make-instance 'gfw:label :text "Multiple Select:" :parent lb1-panel) + (setf lb1 (make-instance 'gfw:list-box :parent lb1-panel + :callback #'lb-select + :sort-predicate #'string< + :style '(:multiple-select) + :items (subseq *list-box-test-data* 4))) + (gfw:pack lb1-panel) + (make-instance 'gfw:button :parent btn-panel :text " ==> ") + (make-instance 'gfw:button :parent btn-panel :text " <== ") + (gfw:pack btn-panel) + (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) + (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel + :callback #'lb-select + :style '(:extend-select :want-scrollbar) + :items (subseq *list-box-test-data* 4))) + (gfw:pack lb2-panel) + (gfw:pack outer-panel) + (let ((size (gfw:size lb1))) + (setf (gfw:maximum-size lb1) size + (gfw:minimum-size lb1) size + (gfw:maximum-size lb2) size + (gfw:minimum-size lb2) size)) + (setf (gfw:items-of lb1) *list-box-test-data*) + (gfw:update-from-items lb1) + (gfw:delete-all lb2) + 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" @@ -82,8 +122,9 @@ (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher disp :layout layout :style '(:frame))) - (setf (gfw:menu-bar *widget-tester-win*) menubar) - (setf (gfw:top-child-of layout) (populate-list-box-test-panel)) + (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))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Tue Sep 5 00:26:37 2006 @@ -37,12 +37,32 @@ ;;; convenience functions ;;; +(defun recreate-array (array) + (make-array (array-dimensions array) + :adjustable (adjustable-array-p array) + :fill-pointer (if (array-has-fill-pointer-p array) 0 nil))) + (defun indexed-sort (sequence predicate key) - (let* ((tmp1 (loop for item in sequence - collect (list (funcall key item) item))) - (tmp2 (sort tmp1 predicate :key #'first))) - (loop for item in tmp2 - collect (second item)))) + (let ((result (cond + ((listp sequence) + nil) + ((vectorp sequence) + (recreate-array sequence)) + (t + (error 'gfs:toolkit-error :detail (format nil "unsupported type: ~a" sequence))))) + (tmp nil)) + (dotimes (i (length sequence)) + (let ((item (elt sequence i))) + (pushnew (list (funcall key item) item) tmp))) + (setf tmp (sort (reverse tmp) predicate :key #'first)) + (cond + ((listp result) + (setf result (loop for item in tmp collect (second item)))) + ((adjustable-array-p result) + (dotimes (i (length tmp)) (vector-push (second (elt tmp i)) result))) + (t + (dotimes (i (length tmp)) (setf (elt result i) (second (elt tmp i)))))) + result)) (defun flatten (tree) (if (cl:atom tree) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Sep 5 00:26:37 2006 @@ -126,6 +126,7 @@ (#.gfs::+en-update+ (event-modify disp widget)) (#.gfs::+lbn-dblclk+ (event-default-action disp widget)) (#.gfs::+lbn-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+lbn-selchange+ (event-select disp widget)) (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget))))) (defun process-ctlcolor-message (wparam lparam) @@ -180,21 +181,17 @@ (wparam-hi (hi-word wparam)) (wparam-lo (lo-word wparam)) (owner (get-widget tc hwnd))) + ; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) (if owner - (cond - ((zerop lparam) - (let ((item (get-item tc wparam-lo))) - (if (null item) - (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) - (unless (null (dispatcher item)) - (event-select (dispatcher item) item))))) - ((eq wparam-hi 1) - (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug - (t - (let ((widget (get-widget tc (cffi:make-pointer lparam)))) - (when (and widget (dispatcher widget)) - ; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) - (dispatch-notification widget wparam-hi))))) + (if (zerop lparam) + (let ((item (get-item tc wparam-lo))) + (if (null item) + (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) + (unless (null (dispatcher item)) + (event-select (dispatcher item) item)))) + (let ((widget (get-widget tc (cffi:make-pointer lparam)))) + (when (and widget (dispatcher widget)) + (dispatch-notification widget wparam-hi)))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Sep 5 00:26:37 2006 @@ -34,6 +34,25 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(defun lb-extend-select-flags (orig-flags) + (setf orig-flags (logand orig-flags + (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-multiplesel+)))) + (logior orig-flags gfs::+lbs-extendedsel+)) + +(defun lb-multi-select-flags (orig-flags) + (setf orig-flags (logand orig-flags + (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-extendedsel+)))) + (logior orig-flags gfs::+lbs-multiplesel+)) + +(defun lb-no-select-flags (orig-flags) + (setf orig-flags (logand orig-flags + (lognot (logior gfs::+lbs-multiplesel+ gfs::+lbs-extendedsel+)))) + (logior orig-flags gfs::+lbs-nosel+)) + +;;; ;;; methods ;;; @@ -57,26 +76,15 @@ do (ecase sym ;; primary list-box styles ;; - (:extend-select (setf std-flags (logand std-flags (lognot gfs::+lbs-nosel+))) - (setf std-flags (logior std-flags - gfs::+lbs-extendedsel+ - gfs::+lbs-multiplesel+))) - - (:multiple (setf std-flags (logand std-flags (lognot gfs::+lbs-nosel+))) - (setf std-flags (logior std-flags gfs::+lbs-multiplesel+))) - - (:no-select (setf std-flags (logand std-flags - (lognot (logior gfs::+lbs-extendedsel+ - gfs::+lbs-multiplesel+)))) - (setf std-flags (logior std-flags gfs::+lbs-nosel+))) + (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) + (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) + (:no-select (setf std-flags (lb-no-select-flags std-flags))) ;; styles that can be combined ;; - (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) - - (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) - - (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) + (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) + (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) + (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) @@ -97,37 +105,56 @@ (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) (update-from-items self)) -(defmethod (setf items-of) :after (new-items (self list-box)) +(defmethod (setf items-of) :before (new-items (self list-box)) + (declare (ignore new-items)) (let ((old-items (items-of self))) (dotimes (i (length old-items)) (let ((victim (elt old-items i))) (setf (slot-value victim 'gfs:handle) nil) - (gfs:dispose victim)))) + (gfs:dispose victim))))) + +(defmethod (setf items-of) :after (new-items (self list-box)) (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) (update-from-items self)) (defmethod preferred-size ((self list-box) width-hint height-hint) (let ((hwnd (gfs:handle self)) + (min-size (min-size-of self)) + (max-size (max-size-of self)) (size (gfs:make-size :width width-hint :height height-hint)) (b-width (* (border-width self) 2))) - (flet ((item-text (index) - (lb-item-text hwnd index (1+ (lb-item-text-length hwnd index))))) - (when (< width-hint 0) - (setf (gfs:size-width size) - (loop for index to (1- (lb-item-count hwnd)) - with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) - maximizing (gfs:size-width (widget-text-size self - (lambda (unused) - (declare (ignore unused)) - (item-text index)) - dt-flags)) - into max-width - finally (return (or max-width 0)))))) + (cond + ((and min-size (< width-hint (gfs:size-width min-size))) + (setf (gfs:size-width size) (gfs:size-width min-size))) + ((and max-size (> width-hint (gfs:size-width max-size))) + (setf (gfs:size-width size) (gfs:size-width max-size))) + ((>= width-hint 0) + (setf (gfs:size-width size) width-hint)) + (t + (flet ((item-text (index) + (lb-item-text hwnd index (1+ (lb-item-text-length hwnd index))))) + (setf (gfs:size-width size) + (loop for index to (1- (lb-item-count hwnd)) + with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) + maximizing (gfs:size-width (widget-text-size self + (lambda (unused) + (declare (ignore unused)) + (item-text index)) + dt-flags)) + into max-width + finally (return (or max-width 0))))))) + (cond + ((and min-size (< height-hint (gfs:size-height min-size))) + (setf (gfs:size-height size) (gfs:size-height min-size))) + ((and max-size (> height-hint (gfs:size-height max-size))) + (setf (gfs:size-height size) (gfs:size-height max-size))) + ((>= height-hint 0) + (setf (gfs:size-height size) height-hint)) + (t + (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) (incf (gfs:size-width size) (+ b-width 4))) - (when (< height-hint 0) - (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) (if (zerop (gfs:size-height size)) (setf (gfs:size-height size) +default-widget-height+) (incf (gfs:size-height size) b-width)) @@ -138,16 +165,12 @@ (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) - (items (items-of self)) (hwnd (gfs:handle self))) -#| (when sort-func - (setf items (gfs::indexed-sort items sort-func (lambda (it) (data-of it))) - (items-of self) items)) -|# + (setf (slot-value self 'items) (gfs::indexed-sort (items-of self) sort-func #'data-of))) (enable-redraw self nil) (unwind-protect - (progn + (let ((items (items-of self))) (lb-clear-content hwnd) (dotimes (index (length items)) (let* ((item (elt items index))

1 0

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

04 Sep '06

Author: junrue Date: Mon Sep 4 16:01:46 2006 New Revision: 246 Added: trunk/src/tests/uitoolkit/widget-tester.lisp Modified: trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-tests.asd trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: lots of list-box debugging, with new widget-tester test program Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Sep 4 16:01:46 2006 @@ -387,8 +387,8 @@ case the control will re-allocate storage as necessary). @end deffn @deffn Initarg :items -This initarg accepts a list of objects for populating the -contents of the list-box. The list-box will hold references to the +This initarg accepts a list of @ref{list-item} objects for populating +the contents of the list-box. The list-box will hold references to the supplied objects. See also @ref{append-item}. @end deffn @control-parent-initarg{list-box} @@ -693,7 +693,11 @@ @anchor{panel} @deftp Class panel Base class for @ref{window}s that are children of @ref{top-level} -windows, @ref{dialog}s, or other @code{panel}s. +windows, @ref{dialog}s, or other panels. +@deffn Initarg :parent +This initarg is used to specify the @ref{parent} window of the +panel. +@end deffn @end deftp @anchor{root-window} Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Sep 4 16:01:46 2006 @@ -42,6 +42,7 @@ #:hello-world #:image-tester #:layout-tester + #:widget-tester #:textedit #:unblocked #:windlg)) @@ -87,4 +88,5 @@ (:file "layout-tester") (:file "image-tester") (:file "drawing-tester") + (:file "widget-tester") (:file "windlg"))))))))) Added: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Mon Sep 4 16:01:46 2006 @@ -0,0 +1,91 @@ +;;;; +;;;; widget-tester.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + + ;; drop cookies +(defvar *list-box-test-data* '("chocolate chip" "butterscotch crunch" "peanut butter" "oatmeal" + ;; molded cookies + "butterfinger chunkies" "jam thumbprints" "cappuccino flats" + ;; pressed cookies + "langues de chat" "macaroons" "shortbread" + ;; refrigerator cookies + "brysell" "caramel" "mosaic" "praline" "toffee")) + +(defvar *widget-tester-win* nil) + +(defun widget-tester-exit (disp item) + (declare (ignore disp item)) + (gfs:dispose *widget-tester-win*) + (setf *widget-tester-win* nil) + (gfw:shutdown 0)) + +(defclass widget-tester-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp widget-tester-events) window) + (declare (ignore window)) + (widget-tester-exit disp nil)) + +(defclass widget-tester-panel-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-paint ((disp widget-tester-panel-events) window gc rect) + (declare (ignore rect)) + (setf (gfg:background-color gc) gfg:*color-white* + (gfg:foreground-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) + +(defun populate-list-box-test-panel () + (let* ((disp (make-instance 'widget-tester-panel-events)) + (layout (make-instance 'gfw:flow-layout)) + (panel (make-instance 'gfw:panel :dispatcher disp + :parent *widget-tester-win* + :layout layout))) + (make-instance 'gfw:list-box :parent panel :items *list-box-test-data*) + (gfW:pack panel) + panel)) + +(defun widget-tester-internal () + (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 (gfw:menu-bar *widget-tester-win*) menubar) + (setf (gfw:top-child-of layout) (populate-list-box-test-panel)) + (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/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Sep 4 16:01:46 2006 @@ -48,6 +48,33 @@ (t (funcall func thing))))) +(defun copy-item-sequence (parent new-items item-class) + (let ((hwnd (gfs:handle parent)) + (tc (thread-context)) + (replacements (make-array 7 :fill-pointer 0 :adjustable t))) + (cond + ((null new-items) + replacements) + ((vectorp new-items) + (dotimes (i (length new-items)) + (let ((item (elt new-items i))) + (if (typep item item-class) + (vector-push-extend item replacements) + (let ((tmp (make-instance item-class :handle hwnd :data item))) + (put-item tc tmp) + (vector-push-extend tmp replacements))))) + replacements) + ((listp new-items) + (loop for item in new-items + do (if (typep item item-class) + (vector-push-extend item replacements) + (let ((tmp (make-instance item-class :handle hwnd :data item))) + (put-item tc tmp) + (vector-push-extend tmp replacements)))) + replacements) + (t + (error 'gfs:toolkit-error :detail (format nil "invalid data structure type: ~a" new-items)))))) + ;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Mon Sep 4 16:01:46 2006 @@ -90,3 +90,10 @@ (if (null widget) (error 'gfs:toolkit-error :detail "no owner widget")) widget))) + +(defmethod print-object ((self item) stream) + (print-unreadable-object (self stream :type t) + (format stream "id: ~d " (item-id self)) + (format stream "data: ~a " (data-of self)) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a" (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Mon Sep 4 16:01:46 2006 @@ -76,23 +76,22 @@ for rect = (cdr k) for size = (gfs:size rect) for pnt = (gfs:location rect) - do (progn - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width size) - (gfs:size-height size) - (funcall flags-func (car k))) - (gfs::defer-window-pos hdwp - (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width size) - (gfs:size-height size) - (funcall flags-func (car k)))))) + do (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))) + (gfs::defer-window-pos hdwp + (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))))) (unless (gfs:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp)))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Mon Sep 4 16:01:46 2006 @@ -43,7 +43,7 @@ (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) (item (create-item-with-callback hcontrol 'list-item thing disp))) - (lb-insert-item hcontrol -1 text (cffi:null-pointer)) + (lb-insert-item hcontrol #xFFFFFFFF text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) item)) @@ -79,7 +79,7 @@ (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) -(defmethod initialize-instance :after ((self list-box) &key estimated-count parent &allow-other-keys) +(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) @@ -93,10 +93,17 @@ (init-control self) (if (and estimated-count (> estimated-count 0)) (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) + (if items + (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) (update-from-items self)) (defmethod (setf items-of) :after (new-items (self list-box)) - (declare (ignore new-items)) + (let ((old-items (items-of self))) + (dotimes (i (length old-items)) + (let ((victim (elt old-items i))) + (setf (slot-value victim 'gfs:handle) nil) + (gfs:dispose victim)))) + (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) (update-from-items self)) (defmethod preferred-size ((self list-box) width-hint height-hint) @@ -109,14 +116,16 @@ (setf (gfs:size-width size) (loop for index to (1- (lb-item-count hwnd)) with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) - maximizing (widget-text-size self - (lambda () (item-text index)) - dt-flags) + maximizing (gfs:size-width (widget-text-size self + (lambda (unused) + (declare (ignore unused)) + (item-text index)) + dt-flags)) into max-width - finally (return max-width))))) + finally (return (or max-width 0)))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) - (incf (gfs:size-width size) b-width)) + (incf (gfs:size-width size) (+ b-width 4))) (when (< height-hint 0) (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) (if (zerop (gfs:size-height size)) @@ -131,16 +140,18 @@ (let ((sort-func (sort-predicate-of self)) (items (items-of self)) (hwnd (gfs:handle self))) +#| (when sort-func (setf items (gfs::indexed-sort items sort-func (lambda (it) (data-of it))) (items-of self) items)) +|# (enable-redraw self nil) (unwind-protect (progn (lb-clear-content hwnd) - (loop for item in items - for index = 0 then (1+ index) - do (progn - (setf (index-of item) index) - (append-item self item (dispatcher self))))) + (dotimes (index (length items)) + (let* ((item (elt items index)) + (text (call-text-provider self (data-of item)))) + (setf (index-of item) index) + (lb-insert-item hwnd #xFFFFFFFF text (cffi:null-pointer))))) (enable-redraw self t)))) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Mon Sep 4 16:01:46 2006 @@ -47,8 +47,9 @@ (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box (let ((text (or label ""))) (cffi:with-foreign-string (str-ptr text) - (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) - (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) + (let ((retval (gfs::send-message hwnd gfs::+lb-insertstring+ index (cffi:pointer-address str-ptr)))) + (if (< retval 0) + (error 'gfs:toolkit-error :detail (format nil "LB_INSERTSTRING failed: ~d" retval))))))) (defun lb-width (hwnd) (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) @@ -88,8 +89,16 @@ (defmethod gfs:dispose ((self list-item)) (let ((index (index-of self)) - (owner (owner self))) - (if owner - (gfs::send-message (gfs:handle owner) gfs::+lb-deletestring+ index 0)) + (howner (gfs:handle self))) + (if howner + (gfs::send-message howner gfs::+lb-deletestring+ index 0)) (setf (index-of self) 0)) (call-next-method)) + +(defmethod print-object ((self list-item) stream) + (print-unreadable-object (self stream :type t) + (format stream "id: ~d " (item-id self)) + (format stream "index: ~d " (index-of self)) + (format stream "data: ~a " (data-of self)) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a" (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Sep 4 16:01:46 2006 @@ -183,7 +183,7 @@ :initform nil)) (:documentation "A mix-in for objects composed of sub-elements.")) -(defclass list-box (widget item-manager) +(defclass list-box (control item-manager) ((callback-event-name :accessor callback-event-name-of :initform 'event-select Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Sep 4 16:01:46 2006 @@ -310,7 +310,7 @@ (defmethod print-object ((self widget) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a~%" (dispatcher self)))) + (format stream "dispatcher: ~a" (dispatcher self)))) (defmethod redo-available-p :before ((self widget)) (if (gfs:disposed-p self)

1 0

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

01 Sep '06

Author: junrue Date: Fri Sep 1 00:27:49 2006 New Revision: 245 Modified: trunk/docs/manual/event-functions.texinfo trunk/docs/manual/glossary.texinfo trunk/docs/manual/reference.texinfo trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented wrappers for list box messages, implemented list-box preferred-size method, some light refactoring of other controls Modified: trunk/docs/manual/event-functions.texinfo ============================================================================== --- trunk/docs/manual/event-functions.texinfo (original) +++ trunk/docs/manual/event-functions.texinfo Fri Sep 1 00:27:49 2006 @@ -37,7 +37,7 @@ @end defun @anchor{event-activate} -@deffn GenericFunction event-activate dispatcher widget +@deffn GenericFunction event-activate @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being activated. For a @ref{top-level} @ref{window} or @ref{dialog}, this means that @var{widget} was brought to the foreground and its trim (titlebar and @@ -64,7 +64,7 @@ @end table @end deffn -@deffn GenericFunction event-close dispatcher widget +@deffn GenericFunction event-close @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being closed by the user. Only @ref{dialog}s and @ref{top-level} @ref{window}s receive close events. @@ -76,7 +76,7 @@ @end deffn @anchor{event-deactivate} -@deffn GenericFunction event-deactivate dispatcher widget +@deffn GenericFunction event-deactivate @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being deactivated, meaning that some other object has been made active. This event only applies to @ref{top-level} @ref{window}s or @@ -88,7 +88,21 @@ @end table @end deffn -@deffn GenericFunction event-dispose dispatcher widget +@anchor{event-default-action} +@deffn GenericFunction event-default-action @ref{event-dispatcher} @ref{widget} +Implement this method to respond to a @ref{default action}, for +example when the user double-clicks on a @ref{list-box} @ref{item}, or +presses @sc{enter} while the keyboard focus is in an @ref{edit} +control. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} for which the default action was invoked. +@end table +@end deffn + +@anchor{event-dispose} +@deffn GenericFunction event-dispose @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being disposed (explicitly via @ref{dispose}; this event is not associated with garbage collection). This event function is called while the contents of @var{widget} are still @@ -101,7 +115,7 @@ @end deffn @anchor{event-focus-gain} -@deffn GenericFunction event-focus-gain dispatcher widget +@deffn GenericFunction event-focus-gain @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} gaining keyboard focus. @table @var @event-dispatcher-arg @@ -111,7 +125,7 @@ @end deffn @anchor{event-focus-loss} -@deffn GenericFunction event-focus-loss dispatcher widget +@deffn GenericFunction event-focus-loss @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} losing keyboard focus. @table @var @event-dispatcher-arg @@ -120,7 +134,7 @@ @end table @end deffn -@deffn GenericFunction event-key-down dispatcher widget keycode char +@deffn GenericFunction event-key-down @ref{event-dispatcher} @ref{widget} keycode char Implement this method to respond to a key being pressed within @var{widget}. @table @var @@ -135,7 +149,7 @@ @end table @end deffn -@deffn GenericFunction event-key-up dispatcher widget keycode char +@deffn GenericFunction event-key-up @ref{event-dispatcher} @ref{widget} keycode char Implement this method to respond to a key being released within @var{widget}. @table @var @event-dispatcher-arg @@ -150,7 +164,7 @@ @end deffn @anchor{event-modify} -@deffn GenericFunction event-modify dispatcher widget +@deffn GenericFunction event-modify @ref{event-dispatcher} @ref{widget} Implement this method to respond to changes due to user input within @ref{widget}, for example when the user types text inside an @ref{edit} @ref{control}. @@ -161,7 +175,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-double dispatcher widget point button +@deffn GenericFunction event-mouse-double @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button double-click within @var{widget}. @table @var @event-dispatcher-arg @@ -172,7 +186,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-down dispatcher widget point button +@deffn GenericFunction event-mouse-down @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button click within @var{widget}. @table @var @event-dispatcher-arg @@ -183,7 +197,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-move dispatcher widget point button +@deffn GenericFunction event-mouse-move @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse move event within @var{widget}. @table @var @event-dispatcher-arg @@ -194,7 +208,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-up dispatcher widget point button +@deffn GenericFunction event-mouse-up @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button being released within @var{widget}. @table @var @@ -206,7 +220,7 @@ @end table @end deffn -@deffn GenericFunction event-move dispatcher widget point +@deffn GenericFunction event-move @ref{event-dispatcher} @ref{widget} @ref{point} Implement this method to respond to @var{widget} being moved within its @ref{parent}'s coordinate system. @table @var @@ -219,7 +233,7 @@ @end deffn @anchor{event-paint} -@deffn GenericFunction event-paint dispatcher widget gc rect +@deffn GenericFunction event-paint @ref{event-dispatcher} @ref{widget} @ref{graphics-context} @ref{rectangle} Implement this method to respond to system requests to repaint @var{widget}. @table @var @event-dispatcher-arg @@ -233,7 +247,7 @@ @end table @end deffn -@deffn GenericFunction event-resize dispatcher widget size type +@deffn GenericFunction event-resize @ref{event-dispatcher} @ref{widget} size type Implement this method to respond to @var{widget} being resized. @table @var @event-dispatcher-arg @@ -258,7 +272,7 @@ @end deffn @anchor{event-select} -@deffn GenericFunction event-select dispatcher widget +@deffn GenericFunction event-select @ref{event-dispatcher} @ref{widget} Implement this method to handle notification that @var{widget} (or some @ref{item} within @var{widget}) has been clicked on by the user in order to invoke some action. Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Fri Sep 1 00:27:49 2006 @@ -40,6 +40,17 @@ accept user input and possibly generate notification events based on such input.@* +@item default action +@anchor{default action} +@cindex default action +Conceptually, a default action is a secondary event initiated by user +input that is a logical follow-up to a previous event. Examples of +such user gestures include double-clicking an item in a list box +control, or pressing @sc{enter} when an edit control has the keyboard +focus. The response to a default action makes use of context +established by the preceding event (e.g., the selection set by an +initial click becomes the context for the double-click response).@* + @item dialog @cindex dialog A dialog is a mechanism for collecting user input or showing Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Fri Sep 1 00:27:49 2006 @@ -70,7 +70,7 @@ @end macro @macro event-dispatcher-arg -@item dispatcher +@item event-dispatcher The @ref{event-dispatcher} to process this event. @end macro 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 1 00:27:49 2006 @@ -556,6 +556,13 @@ (defconstant +lb-multipleaddstring+ #x01B1) (defconstant +lb-getlistboxinfo+ #x01B2) +(defconstant +lbn-errspace+ -2) +(defconstant +lbn-selchange+ 1) +(defconstant +lbn-dblclk+ 2) +(defconstant +lbn-selcancel+ 3) +(defconstant +lbn-setfocus+ 4) +(defconstant +lbn-killfocus+ 5) + (defconstant +lbs-notify+ #x0001) (defconstant +lbs-sort+ #x0002) (defconstant +lbs-noredraw+ #x0004) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Sep 1 00:27:49 2006 @@ -97,7 +97,7 @@ (init-control self)) (defmethod preferred-size ((self button) width-hint height-hint) - (let ((text-size (widget-text-size self gfs::+dt-singleline+)) + (let ((text-size (widget-text-size self #'text gfs::+dt-singleline+)) (size (gfs:make-size)) (b-width (* (border-width self) 2)) (need-cb-size (intersection '(:check-box :radio-button :tri-state) (style-of self))) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Fri Sep 1 00:27:49 2006 @@ -115,7 +115,7 @@ (gfs::send-message (gfs:handle self) gfs::+wm-paste+ 0 0)) (defmethod preferred-size ((self edit) width-hint height-hint) - (let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) + (let ((text-size (widget-text-size self #'text (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) (size (gfs:make-size)) (b-width (* (border-width self) 2))) (if (>= width-hint 0) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Fri Sep 1 00:27:49 2006 @@ -58,6 +58,11 @@ (:method (dispatcher widget) (declare (ignorable dispatcher widget)))) +(defgeneric event-default-action (dispatcher widget) + (:documentation "Implement this to respond to the widget-specific default action.") + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) + (defgeneric event-deiconify (dispatcher widget) (:documentation "Implement this to respond to an object being deiconified.") (:method (dispatcher widget) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Sep 1 00:27:49 2006 @@ -120,10 +120,13 @@ (defun dispatch-notification (widget wparam-hi) (let ((disp (dispatcher widget))) (case wparam-hi - (0 (event-select disp widget)) - (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) - (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) - (#.gfs::+en-update+ (event-modify disp widget))))) + (0 (event-select disp widget)) + (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) + (#.gfs::+en-update+ (event-modify disp widget)) + (#.gfs::+lbn-dblclk+ (event-default-action disp widget)) + (#.gfs::+lbn-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget))))) (defun process-ctlcolor-message (wparam lparam) (let* ((widget (get-widget (thread-context) (cffi:make-pointer lparam))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Sep 1 00:27:49 2006 @@ -178,7 +178,7 @@ (size nil)) (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf size (widget-text-size self flags)) + (setf size (widget-text-size self #'text flags)) (if (>= width-hint 0) (setf (gfs:size-width size) width-hint) (incf (gfs:size-width size) b-width)) 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 1 00:27:49 2006 @@ -34,17 +34,6 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; helper functions -;;; - -(defun insert-list-item (hwnd index label hbmp) - (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box - (let ((text (or label ""))) - (cffi:with-foreign-string (str-ptr text) - (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) - (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) - -;;; ;;; methods ;;; @@ -54,7 +43,7 @@ (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) (item (create-item-with-callback hcontrol 'list-item thing disp))) - (insert-list-item hcontrol -1 text (cffi:null-pointer)) + (lb-insert-item hcontrol -1 text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) item)) @@ -103,16 +92,41 @@ (setf (slot-value self 'gfs:handle) hwnd))) (init-control self) (if (and estimated-count (> estimated-count 0)) - (gfs::send-message (gfs:handle self) - gfs::+lb-initstorage+ - estimated-count - (* estimated-count +estimated-text-size+))) + (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) (update-from-items self)) (defmethod (setf items-of) :after (new-items (self list-box)) (declare (ignore new-items)) (update-from-items self)) +(defmethod preferred-size ((self list-box) width-hint height-hint) + (let ((hwnd (gfs:handle self)) + (size (gfs:make-size :width width-hint :height height-hint)) + (b-width (* (border-width self) 2))) + (flet ((item-text (index) + (lb-item-text hwnd index (1+ (lb-item-text-length hwnd index))))) + (when (< width-hint 0) + (setf (gfs:size-width size) + (loop for index to (1- (lb-item-count hwnd)) + with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) + maximizing (widget-text-size self + (lambda () (item-text index)) + dt-flags) + into max-width + finally (return max-width))))) + (if (zerop (gfs:size-width size)) + (setf (gfs:size-width size) +default-widget-width+) + (incf (gfs:size-width size) b-width)) + (when (< height-hint 0) + (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) + (if (zerop (gfs:size-height size)) + (setf (gfs:size-height size) +default-widget-height+) + (incf (gfs:size-height size) b-width)) + (if (= (logand (gfs::get-window-long hwnd gfs::+gwl-style+) gfs::+ws-vscroll+) + gfs::+ws-vscroll+) + (incf (gfs:size-width size) (vertical-scrollbar-width))) + size)) + (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (items (items-of self)) @@ -123,7 +137,7 @@ (enable-redraw self nil) (unwind-protect (progn - (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) + (lb-clear-content hwnd) (loop for item in items for index = 0 then (1+ index) do (progn Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Fri Sep 1 00:27:49 2006 @@ -34,6 +34,55 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(defun lb-init-storage (hwnd item-count total-bytes) + (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) + +(defun lb-clear-content (hwnd) + (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) + +(defun lb-insert-item (hwnd index label hbmp) + (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box + (let ((text (or label ""))) + (cffi:with-foreign-string (str-ptr text) + (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) + (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) + +(defun lb-width (hwnd) + (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) + (if (< width 0) + (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) + width)) + +(defun lb-item-count (hwnd) + (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (if (< count 0) + (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) + count)) + +(defun lb-item-height (hwnd) + (let ((height (gfs::send-message hwnd gfs::+lb-getitemheight+ 0 0))) + (if (< height 0) + (error 'gfs:win32-error :detail "LB_GETITEMHEIGHT failed")) + height)) + +(defun lb-item-text (hwnd index &optional buffer-size) + (if (or (null buffer-size) (<= buffer-size 0)) + (setf buffer-size (lb-item-text-length hwnd index))) + (cffi:with-foreign-pointer-as-string (str-ptr (1+ buffer-size)) + (if (< (gfs::send-message hwnd gfs::+lb-gettext+ index (cffi:pointer-address str-ptr)) 0) + (error 'gfs:win32-error :detail "LB_GETTEXT failed")) + (cffi:foreign-string-to-lisp str-ptr))) + +(defun lb-item-text-length (hwnd index) + (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0))) + (if (< length 0) + (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed")) + length)) + +;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Fri Sep 1 00:27:49 2006 @@ -95,5 +95,7 @@ (defconstant +vk-right-alt+ #xA5) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) - (defconstant +estimated-text-size+ 32)) ;; bytes + (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) + (defconstant +default-widget-width+ 64) + (defconstant +default-widget-height+ 64) + (defconstant +estimated-text-size+ 32)) ; bytes 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 1 00:27:49 2006 @@ -190,18 +190,30 @@ (setf (gfs:size-width sz) (- gfs::windowright gfs::windowleft)) (setf (gfs:size-height sz) (- gfs::windowbottom gfs::windowtop))))) +(defun horizontal-scrollbar-height () + (gfs::get-system-metrics gfs::+sm-cyhscroll+)) + +(defun horizontal-scrollbar-arrow-width () + (gfs::get-system-metrics gfs::+sm-cxhscroll+)) + +(defun vertical-scrollbar-arrow-height () + (gfs::get-system-metrics gfs::+sm-cyvscroll+)) + +(defun vertical-scrollbar-width () + (gfs::get-system-metrics gfs::+sm-cxvscroll+)) + (defun set-widget-text (w str) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) (gfs::set-window-text (gfs:handle w) str)) -(defun widget-text-size (widget dt-flags) +(defun widget-text-size (widget text-func dt-flags) (let ((hwnd (gfs:handle widget)) (hfont nil)) (gfs::with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs::with-hfont-selected (hdc hfont) - (gfg::text-bounds hdc (text widget) dt-flags 0))))) + (gfg::text-bounds hdc (funcall text-func widget) dt-flags 0))))) ;;; ;;; This algorithm adapted from the calculate_best_bounds() @@ -233,8 +245,8 @@ ;; use scrollbar system metric values as a rough approximation ;; (return-from check-box-size - (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxvscroll+) - :height (gfs::get-system-metrics gfs::+sm-cyvscroll+)))) + (gfs:make-size :width (vertical-scrollbar-width) + :height (vertical-scrollbar-arrow-height)))) (unwind-protect (cffi:with-foreign-object (bm-ptr 'gfs::bitmap)

1 0