[graphic-forms-cvs] r243 - in trunk: docs/manual src src/demos/textedit src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Aug 30 01:29:35 UTC 2006
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}
- at deftp Class item-manager collator image-provider items text-provider
+ at 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
- at item collator
-This slot holds a predicate function of two arguments returning a
- at 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
+ at 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
- at 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}.
+ at 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}.
+ at item sort-predicate
+This slot holds a predicate function of two arguments returning a
+ at 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}
+ at 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).
+ at 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."))
More information about the Graphic-forms-cvs
mailing list