Author: junrue Date: Tue Aug 29 21:29:32 2006 New Revision: 243
Modified: trunk/docs/manual/widget-types.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/event.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/menu-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented list-box version of append-item, renamed items accessor to items-of
Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Tue Aug 29 21:29:32 2006 @@ -74,26 +74,29 @@ @end deftp
@anchor{item-manager} -@deftp Class item-manager collator image-provider items text-provider +@deftp Class item-manager image-provider items sort-predicate text-provider This is is a mix-in class for @ref{widget}s containing sub-elements. @table @var -@item collator -This slot holds a predicate function of two arguments returning a -@sc{boolean}, for the purpose of ordering @var{items}. The arguments -passed are application-defined objects. Note that not all subclasses -make use of this feature. @item image-provider This slot holds a function accepting one argument and returning an -instance of @ref{image}. The default implementation simply -returns @sc{nil}. +instance of @ref{image}. The function's argument will be one of the +application-supplied objects used to populate the list. The default +implementation simply returns @sc{nil}. @item items -An @sc{adjustable} @sc{vector} containing @ref{item}s representing -sub-elements. +An @sc{adjustable} @sc{vector} containing instances of an +@ref{item} subclass appropriate for the actual @ref{widget}. +Each such item wraps an application-supplied data object. @item text-provider This slot holds a function accepting one argument and returning a -@sc{string}. The default implementation checks whether the argument -is already a @sc{string}, and if so just returns it; otherwise it -calls @sc{format}. +@sc{string}. The function's argument will be one of the +application-supplied objects used to populate the list. The default +implementation checks whether the argument is a @sc{string}, +and if so just returns it; otherwise it calls @sc{format}. +@item sort-predicate +This slot holds a predicate function of two arguments returning a +@sc{boolean}, for the purpose of ordering the members of the @var{items} +list. The actual arguments passed are the application-supplied objects. +Note that not all subclasses make use of this feature. @end table @end deftp
@@ -364,6 +367,14 @@ a combo-box., event-select} @control-callback-initarg{list-box,event-select} +@deffn Initarg :estimated-count +This initarg accepts a positive integer value indicating the expected +number of items that the list-box will hold. If supplied, it enables +an optimization in storage allocation by the underlying native control. +As the name of the initarg implies, this is an estimate, which may be +too high (in which case heap space may be wasted) or too low (in which +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
Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Tue Aug 29 21:29:32 2006 @@ -44,8 +44,8 @@
(defun manage-textedit-file-menu (disp menu) (declare (ignore disp)) - (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)) - (gfw:enable (elt (gfw:items menu) 3) (> (length (gfw:text *textedit-control*)) 0))) + (gfw:enable (elt (gfw:items-of menu) 2) (gfw:text-modified-p *textedit-control*)) + (gfw:enable (elt (gfw:items-of menu) 3) (> (length (gfw:text *textedit-control*)) 0)))
(defun textedit-file-new (disp item) (declare (ignore disp item)) @@ -97,7 +97,7 @@ (declare (ignore disp)) (unless *textedit-control* (return-from manage-textedit-edit-menu nil)) - (let ((items (gfw:items menu)) + (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*))
Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Aug 29 21:29:32 2006 @@ -438,7 +438,7 @@ #:item-height #:item-id #:item-index - #:items + #:items-of #:key-down-p #:key-toggled-p #:label
Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Tue Aug 29 21:29:32 2006 @@ -44,8 +44,8 @@
(defun find-checked-item (disp menu) (declare (ignore disp)) - (dotimes (i (length (gfw:items menu))) - (let ((item (elt (gfw:items menu) i))) + (dotimes (i (length (gfw:items-of menu))) + (let ((item (elt (gfw:items-of menu) i))) (when (gfw:checked-p item) (setf *last-checked-drawing-item* item) (return)))))
Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Aug 29 21:29:32 2006 @@ -213,7 +213,7 @@
(defun manage-file-menu (disp menu) (declare (ignore disp)) - (let ((item (elt (gfw:items menu) 0))) + (let ((item (elt (gfw:items-of menu) 0))) (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer"))))
(defun manage-timer (disp item)
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Aug 29 21:29:32 2006 @@ -211,8 +211,8 @@ (defun check-flow-orient-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout))) - (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout))))) + (gfw:check (elt (gfw:items-of menu) 0) (find :horizontal (gfw:style-of layout))) + (gfw:check (elt (gfw:items-of menu) 1) (find :vertical (gfw:style-of layout)))))
(defun set-flow-horizontal (disp item) (declare (ignorable disp item)) @@ -253,7 +253,7 @@ (defun enable-flow-spacing-items (disp menu) (declare (ignore disp)) (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) - (gfw:enable (elt (gfw:items menu) 0) (> spacing 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> spacing 0))))
(defun decrease-flow-spacing (disp item) (declare (ignore disp item)) @@ -273,22 +273,22 @@ (defun enable-left-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:left-margin-of layout) 0))))
(defun enable-top-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:top-margin-of layout) 0))))
(defun enable-right-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:right-margin-of layout) 0))))
(defun enable-bottom-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:bottom-margin-of layout) 0))))
(defun inc-left-flow-margin (disp item) (declare (ignore disp item))
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Aug 29 21:29:32 2006 @@ -180,7 +180,7 @@ (if owner (cond ((zerop lparam) - (let ((item (get-menuitem tc wparam-lo))) + (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)) @@ -208,7 +208,7 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) (declare (ignore hwnd lparam)) ; FIXME: handle system menus (let* ((tc (thread-context)) - (item (get-menuitem tc (lo-word wparam)))) + (item (get-item tc (lo-word wparam)))) (unless (null item) (let ((d (dispatcher item))) (unless (null d)
Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Tue Aug 29 21:29:32 2006 @@ -58,10 +58,10 @@ (error 'gfs:disposed-error)))
(defmethod delete-all ((self item-manager)) - (let ((items (items self))) + (let ((items (items-of self))) (dotimes (i (length items)) (gfs:dispose (aref items i)))) - (setf (items self) (make-array 7 :fill-pointer 0 :adjustable t))) + (setf (items-of self) (make-array 7 :fill-pointer 0 :adjustable t)))
(defmethod delete-item :before ((self item-manager) index) (declare (ignore index)) @@ -69,9 +69,9 @@ (error 'gfs:disposed-error)))
(defmethod delete-item ((self item-manager) index) - (let* ((items (items self)) + (let* ((items (items-of self)) (it (elt items index))) - (setf (items self) (remove it items :test #'items-equal-p)) + (setf (items-of self) (remove it items :test #'items-equal-p)) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) @@ -91,7 +91,7 @@ (error 'gfs:disposed-error)))
(defmethod item-index ((self item-manager) (it item)) - (let ((pos (position it (items self) :test #'items-equal-p))) + (let ((pos (position it (items-of self) :test #'items-equal-p))) (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 Tue Aug 29 21:29:32 2006 @@ -32,7 +32,22 @@ ;;;;
(in-package :graphic-forms.uitoolkit.widgets) - + +(defun create-item-with-callback (howner thing disp) + (let ((item nil) + (id (increment-item-id (thread-context)))) + (cond + ((null disp) + (setf item (make-instance 'menu-item :item-id id :data thing :handle howner))) + ((functionp disp) + (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :callback disp))) + ((typep disp 'gfw:event-dispatcher) + (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :dispatcher disp))) + (t + (error 'gfs:toolkit-error + :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) + item)) + (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2)))
Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Aug 29 21:29:32 2006 @@ -34,9 +34,31 @@ (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 ;;;
+(defmethod append-item ((self list-box) thing disp &optional disabled checked) + (declare (ignore disabled checked)) + (let* ((tc (thread-context)) + (hcontrol (gfs:handle self)) + (text (call-text-provider self thing)) + (item (create-item-with-callback hcontrol thing disp))) + (insert-list-item hcontrol -1 text (cffi:null-pointer)) + (put-item tc item) + (vector-push-extend item (items-of self)) + item)) + (defmethod compute-style-flags ((self list-box) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+ gfs::+lbs-notify+ @@ -68,7 +90,7 @@ (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0)))
-(defmethod initialize-instance :after ((self list-box) &key parent &allow-other-keys) +(defmethod initialize-instance :after ((self list-box) &key estimated-count parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) @@ -80,23 +102,28 @@ (increment-widget-id (thread-context))))) (setf (slot-value self 'gfs:handle) hwnd))) (init-control self) + (if (and estimated-count (> estimated-count 0)) + (gfs::send-message (gfs:handle self) + gfs::+lb-initstorage+ + estimated-count + (* estimated-count +estimated-text-size+))) (update-from-items self))
-(defmethod (setf items) :after (new-items (self list-box)) +(defmethod (setf items-of) :after (new-items (self list-box)) (declare (ignore new-items)) (update-from-items self))
(defmethod update-from-items ((self list-box)) - (let ((collator (collator-of self)) + (let ((sort-func (sort-predicate-of self)) (items (items-of self)) (hwnd (gfs:handle self))) - (when collator - (setf items (gfs::indexed-sort items collator (lambda (it) (data-of it))) + (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 (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) (loop for item in items - do (append-item self item ???))) + do (append-item self item (dispatcher self)))) (enable-redraw self t))))
Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Tue Aug 29 21:29:32 2006 @@ -166,20 +166,6 @@ (error 'gfs:win32-error :detail "set-menu-item-info failed")) (= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+))))
-(defun create-menuitem-with-callback (hmenu thing disp) - (let ((item nil)) - (cond - ((null disp) - (setf item (make-instance 'menu-item :data thing :handle hmenu))) - ((functionp disp) - (setf item (make-instance 'menu-item :data thing :handle hmenu :callback disp))) - ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance 'menu-item :data thing :handle hmenu :dispatcher disp))) - (t - (error 'gfs:toolkit-error - :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) - item)) - ;;; ;;; methods ;;; @@ -196,7 +182,7 @@
(defmethod gfs:dispose ((it menu-item)) (setf (dispatcher it) nil) - (delete-menuitem (thread-context) it) + (delete-tc-item (thread-context) it) (let ((id (item-id it)) (owner (owner it))) (unless (null owner)
Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Tue Aug 29 21:29:32 2006 @@ -37,7 +37,7 @@ ;;; helper functions ;;;
-(defun insert-menuitem (hmenu mid label hbmp hchildmenu disabled checked) +(defun append-menuitem (hmenu mid label hbmp hchildmenu disabled checked) (declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items (let ((info-mask (logior gfs::+miim-id+ (if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+) @@ -79,8 +79,8 @@ nil)))
(defun visit-menu-tree (menu fn) - (dotimes (index (length (items menu))) - (let ((it (elt (items menu) index)) + (dotimes (index (length (items-of menu))) + (let ((it (elt (items-of menu) index)) (child (sub-menu menu index))) (unless (null child) (visit-menu-tree child fn)) @@ -90,43 +90,39 @@ ;;; methods ;;;
-(defmethod append-item ((owner menu) thing disp &optional disabled checked) +(defmethod append-item ((self menu) thing disp &optional disabled checked) (let* ((tc (thread-context)) - (id (increment-menuitem-id tc)) - (hmenu (gfs:handle owner)) - (item (create-menuitem-with-callback hmenu thing disp)) - (text (call-text-provider owner thing))) - (insert-menuitem hmenu id text (cffi:null-pointer) (cffi:null-pointer) disabled checked) - (setf (item-id item) id) - (put-menuitem tc item) - (vector-push-extend item (items owner)) + (hmenu (gfs:handle self)) + (item (create-item-with-callback hmenu thing disp)) + (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)) item))
-(defmethod append-separator ((owner menu)) - (if (gfs:disposed-p owner) +(defmethod append-separator ((self menu)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-menuitem-id tc)) - (howner (gfs:handle owner)) - (item (make-instance 'menu-item :handle howner))) - (insert-menuitem howner id nil (cffi:null-pointer) (cffi:null-pointer) nil nil) - (setf (item-id item) id) - (put-menuitem tc item) - (vector-push-extend item (items owner)) + (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) + (put-item tc item) + (vector-push-extend item (items-of self)) item))
-(defmethod append-submenu ((parent menu) text (submenu menu) disp &optional disabled checked) - (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu)) +(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-menuitem-id tc)) - (hparent (gfs:handle parent)) + (id (increment-item-id tc)) + (hparent (gfs:handle self)) (hmenu (gfs:handle submenu)) - (item (make-instance 'menu-item :handle hparent))) - (insert-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked) - (setf (item-id item) id) - (put-menuitem tc item) - (vector-push-extend item (items parent)) + (item (make-instance 'menu-item :handle hparent :item-id id))) + (append-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked) + (put-item tc item) + (vector-push-extend item (items-of self)) (put-widget tc submenu) (cond ((null disp)) @@ -143,7 +139,7 @@ (defun menu-cleanup-callback (menu item) (let ((tc (thread-context))) (delete-widget tc (gfs:handle menu)) - (delete-menuitem tc item))) + (delete-tc-item tc item)))
(defmethod gfs:dispose ((m menu)) (visit-menu-tree m #'menu-cleanup-callback)
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Aug 29 21:29:32 2006 @@ -41,10 +41,10 @@ (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) (virtual-key :initform 0 :accessor virtual-key) - (menuitems-by-id :initform (make-hash-table :test #'equal)) + (items-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) - (next-menuitem-id :initform 10000 :reader next-menuitem-id) + (next-item-id :initform 10000 :reader next-item-id) (next-widget-id :initform 100 :reader next-widget-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) @@ -108,10 +108,10 @@ (defgeneric put-kbdnav-widget (self widget)) (defgeneric delete-kbdnav-widget (self widget)) (defgeneric intercept-kbdnav-message (self msg-ptr)) -(defgeneric get-menuitem (self id)) -(defgeneric put-menuitem (self item)) -(defgeneric delete-menuitem (self item)) -(defgeneric increment-menuitem-id (self)) +(defgeneric get-item (self id)) +(defgeneric put-item (self item)) +(defgeneric delete-tc-item (self item)) +(defgeneric increment-item-id (self)) (defgeneric get-timer (self id)) (defgeneric put-timer (self timer)) (defgeneric delete-timer (self timer)) @@ -202,27 +202,27 @@ (return-from intercept-kbdnav-message widget)))) nil)
-(defmethod get-menuitem ((tc thread-context) id) - "Returns the menu item identified by id." - (gethash id (slot-value tc 'menuitems-by-id))) - -(defmethod put-menuitem ((tc thread-context) (it menu-item)) - "Stores a menu item using its id as the key." - (setf (gethash (item-id it) (slot-value tc 'menuitems-by-id)) it)) +(defmethod get-item ((tc thread-context) id) + "Returns the item identified by id." + (gethash id (slot-value tc 'items-by-id))) + +(defmethod put-item ((tc thread-context) (it item)) + "Stores an item using its id as the key." + (setf (gethash (item-id it) (slot-value tc 'items-by-id)) it))
-(defmethod delete-menuitem ((tc thread-context) (it menu-item)) - "Removes the menu item using its id as the key." +(defmethod delete-tc-item ((tc thread-context) (it item)) + "Removes the item using its id as the key." (maphash #'(lambda (k v) (declare (ignore v)) (if (eql k (item-id it)) - (remhash k (slot-value tc 'menuitems-by-id)))) - (slot-value tc 'menuitems-by-id))) + (remhash k (slot-value tc 'items-by-id)))) + (slot-value tc 'items-by-id)))
-(defmethod increment-menuitem-id ((tc thread-context)) +(defmethod increment-item-id ((tc thread-context)) "Return the next menu item ID; also increment the internal value." - (let ((id (next-menuitem-id tc))) - (incf (slot-value tc 'next-menuitem-id)) + (let ((id (next-item-id tc))) + (incf (slot-value tc 'next-item-id)) id))
(defmethod get-timer ((tc thread-context) id)
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Aug 29 21:29:32 2006 @@ -159,12 +159,12 @@ (:documentation "This class represents the standard font dialog."))
(defclass item-manager () - ((collator - :accessor collator-of - :initarg :collator + ((sort-predicate + :accessor sort-predicate-of + :initarg :sort-predicate :initform nil) (items - :accessor 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-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Tue Aug 29 21:29:32 2006 @@ -95,4 +95,5 @@ (defconstant +vk-right-alt+ #xA5)
(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+))) + (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) + (defconstant +estimated-text-size+ 32)) ;; bytes
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Aug 29 21:29:32 2006 @@ -420,6 +420,9 @@ (defgeneric update (self) (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns."))
+(defgeneric update-from-items (self) + (:documentation "Rebuilds the native control's model of self from self's item list.")) + (defgeneric vertical-scrollbar (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise."))