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)))