Author: junrue Date: Tue Aug 29 15:28:42 2006 New Revision: 242

Added: trunk/src/uitoolkit/widgets/list-box.lisp Modified: trunk/NEWS.txt trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: continued work on item-manager refactoring and list-box implementation

Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Tue Aug 29 15:28:42 2006 @@ -1,5 +1,7 @@

+. Implemented GFW:ENABLE-REDRAW to enable applications to temporarily + disable (and later re-enable) drawing of widget content.

==============================================================================

Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Tue Aug 29 15:28:42 2006 @@ -186,24 +186,34 @@ and @ref{auto-vscroll-p}. @end deffn

+@anchor{enable-layout} @deffn GenericFunction enable-layout self flag -Cause the object to allow or disallow layout management. +Passing @sc{nil} for @var{flag} disables layout management in @var{self}; +any non-@sc{nil} value enables it. @end deffn

-@deffn GenericFunction enabled-p self -Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise. +@anchor{enable-redraw} +@deffn GenericFunction enable-redraw self flag +Passing @sc{nil} for @var{flag} prevents @var{self} from being redrawn +when its client area is invalidated; any non-@sc{nil} value enables +drawing and also invalidates the client area. @end deffn

@anchor{enable-scrollbars} @deffn GenericFunction enable-scrollbars self horizontal vertical -Specifying T for @code{horizontal} (@code{vertical}) reveals a +Specifying T for @var{horizontal} (@var{vertical}) reveals a scrollbar to attached to the right-hand (bottom) of -@code{self}. Specifying @sc{nil} hides the scrollbar. These flags do +@var{self}. Specifying @sc{nil} hides the scrollbar. These flags do not affect scrolling behavior in @code{self} -- they only control scrollbar visibility. See @ref{horizontal-scrollbar-p} and @ref{vertical-scrollbar-p}. @end deffn

+@anchor{enabled-p} +@deffn GenericFunction enabled-p self +Returns @sc{t} if @var{self} is enabled; @sc{nil} otherwise. +@end deffn + @anchor{file-dialog-paths} @defun file-dialog-paths dlg => @sc{list} Interrogates the data structure associated with an instance of @@ -533,6 +543,14 @@ before this function returns. @end deffn

+@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. +@end deffn + @anchor{vertical-scrollbar-p} @deffn GenericFunction vertical-scrollbar-p self => boolean Returns T if @code{self} has been configured to display a vertical

Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Tue Aug 29 15:28:42 2006 @@ -74,9 +74,14 @@ @end deftp

@anchor{item-manager} -@deftp Class item-manager image-provider items text-provider +@deftp Class item-manager collator image-provider items 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 @@ -359,14 +364,8 @@ a combo-box., event-select} @control-callback-initarg{list-box,event-select} -@deffn Initarg :collator -This initarg accepts a predicate function of two arguments -returning a @sc{boolean}, for the purpose of ordering the list-box -items. The arguments passed are the application-supplied data objects -used to populate the list-box. -@end deffn -@deffn Initarg :initial-items -This initarg accepts a list of objects for initially populating the +@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 supplied objects. See also @ref{append-item}. @end deffn

Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Aug 29 15:28:42 2006 @@ -132,6 +132,7 @@ (:file "label") (:file "button") (:file "item-manager") + (:file "list-box") (:file "menu") (:file "menu-item") (:file "menu-language")

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Aug 29 15:28:42 2006 @@ -259,6 +259,7 @@ #:item-manager #:layout-managed #:layout-manager + #:list-box #:menu #:menu-item #:panel @@ -521,6 +522,7 @@ #:trim-sizes #:undo-available-p #:update + #:update-from-items #:vertical-scrollbar #:visible-item-count #:visible-p

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 Aug 29 15:28:42 2006 @@ -44,3 +44,18 @@ (assert-true (> (gfs:size-width size)) 0) (assert-true (> (gfs:size-height size)) 0)) (assert-true (> (length (gfw:text display)) 0)))) + +(define-test indexed-sort-test + (let* ((orig1 '("zzz" "mmm" "aaa")) + (result1 (gfs::indexed-sort orig1 #'string< #'identity)) + (orig2 '((zzz 10) (mmm 5) (aaa 1))) + (result2 (gfs::indexed-sort orig2 #'string< #'first))) + (assert-true (string= "aaa" (first result1))) + (assert-true (string= "mmm" (second result1))) + (assert-true (string= "zzz" (third result1))) + (assert-true (eql 'aaa (first (first result2)))) + (assert-true (= 1 (second (first result2)))) + (assert-true (eql 'mmm (first (second result2)))) + (assert-true (= 5 (second (second result2)))) + (assert-true (eql 'zzz (first (third result2)))) + (assert-true (= 10 (second (third result2))))))

Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Aug 29 15:28:42 2006 @@ -38,6 +38,7 @@ ;;; (defparameter *button-classname* "button") (defparameter *edit-classname* "edit") +(defparameter *listbox-classname* "listbox") (defparameter *static-classname* "static")

;;; @@ -512,6 +513,66 @@ (defconstant +image-cursor+ 2) (defconstant +image-enhmetafile+ 3)

+(defconstant +lb-addstring+ #x0180) +(defconstant +lb-insertstring+ #x0181) +(defconstant +lb-deletestring+ #x0182) +(defconstant +lb-selitemrangeex+ #x0183) +(defconstant +lb-resetcontent+ #x0184) +(defconstant +lb-setsel+ #x0185) +(defconstant +lb-setcursel+ #x0186) +(defconstant +lb-getsel+ #x0187) +(defconstant +lb-getcursel+ #x0188) +(defconstant +lb-gettext+ #x0189) +(defconstant +lb-gettextlen+ #x018A) +(defconstant +lb-getcount+ #x018B) +(defconstant +lb-selectstring+ #x018C) +(defconstant +lb-dir+ #x018D) +(defconstant +lb-gettopindex+ #x018E) +(defconstant +lb-findstring+ #x018F) +(defconstant +lb-getselcount+ #x0190) +(defconstant +lb-getselitems+ #x0191) +(defconstant +lb-settabstops+ #x0192) +(defconstant +lb-gethorizontalextent+ #x0193) +(defconstant +lb-sethorizontalextent+ #x0194) +(defconstant +lb-setcolumnwidth+ #x0195) +(defconstant +lb-addfile+ #x0196) +(defconstant +lb-settopindex+ #x0197) +(defconstant +lb-getitemrect+ #x0198) +(defconstant +lb-getitemdata+ #x0199) +(defconstant +lb-setitemdata+ #x019A) +(defconstant +lb-selitemrange+ #x019B) +(defconstant +lb-setanchorindex+ #x019C) +(defconstant +lb-getanchorindex+ #x019D) +(defconstant +lb-setcaretindex+ #x019E) +(defconstant +lb-getcaretindex+ #x019F) +(defconstant +lb-setitemheight+ #x01A0) +(defconstant +lb-getitemheight+ #x01A1) +(defconstant +lb-findstringexact+ #x01A2) +(defconstant +lb-setlocale+ #x01A5) +(defconstant +lb-getlocale+ #x01A6) +(defconstant +lb-setcount+ #x01A7) +(defconstant +lb-initstorage+ #x01A8) +(defconstant +lb-itemfrompoint+ #x01A9) +(defconstant +lb-multipleaddstring+ #x01B1) +(defconstant +lb-getlistboxinfo+ #x01B2) + +(defconstant +lbs-notify+ #x0001) +(defconstant +lbs-sort+ #x0002) +(defconstant +lbs-noredraw+ #x0004) +(defconstant +lbs-multiplesel+ #x0008) +(defconstant +lbs-ownerdrawfixed+ #x0010) +(defconstant +lbs-ownerdrawvariable+ #x0020) +(defconstant +lbs-hasstrings+ #x0040) +(defconstant +lbs-usetabstops+ #x0080) +(defconstant +lbs-nointegralheight+ #x0100) +(defconstant +lbs-multicolumn+ #x0200) +(defconstant +lbs-wantkeyboardinput+ #x0400) +(defconstant +lbs-extendedsel+ #x0800) +(defconstant +lbs-disablenoscroll+ #x1000) +(defconstant +lbs-nodata+ #x2000) +(defconstant +lbs-nosel+ #x4000) +(defconstant +lbs-combobox+ #x8000) + (defconstant +lf-facesize+ 32) (defconstant +lf-fullfacesize+ 64)

Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Tue Aug 29 15:28:42 2006 @@ -37,6 +37,13 @@ ;;; convenience functions ;;;

+(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)))) + (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 Tue Aug 29 15:28:42 2006 @@ -95,3 +95,7 @@ (if (null pos) (return-from item-index 0)) 0)) + +(defmethod update-from-items :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)))

Added: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Aug 29 15:28:42 2006 @@ -0,0 +1,102 @@ +;;;; +;;;; list-box.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; methods +;;; + +(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+ + gfs::+ws-vscroll+ gfs::+ws-border+)) + (style (style-of self))) + (loop for sym in style + 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+))) + + ;; 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+))))) + (values std-flags 0))) + +(defmethod initialize-instance :after ((self list-box) &key parent &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self) + (let ((hwnd (create-window gfs::*listbox-classname* + "" + (gfs:handle parent) + std-style + ex-style + (increment-widget-id (thread-context))))) + (setf (slot-value self 'gfs:handle) hwnd))) + (init-control self) + (update-from-items self)) + +(defmethod (setf items) :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)) + (items (items-of self)) + (hwnd (gfs:handle self))) + (when collator + (setf items (gfs::indexed-sort items collator (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 ???))) + (enable-redraw self t))))

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 15:28:42 2006 @@ -159,7 +159,11 @@ (:documentation "This class represents the standard font dialog."))

(defclass item-manager () - ((items + ((collator + :accessor collator-of + :initarg :collator + :initform nil) + (items :accessor items ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t))

Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Aug 29 15:28:42 2006 @@ -203,12 +203,22 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

-(defmethod enabled-p :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod enabled-p :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

-(defmethod enabled-p ((w widget)) - (not (zerop (gfs::is-window-enabled (gfs:handle w))))) +(defmethod enable-redraw :before ((self widget) flag) + (declare (ignore flag)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod enable-redraw ((self widget) flag) + (gfs::send-message (gfs:handle self) gfs::+wm-setredraw+ (if flag 1 0) 0) + (if flag + (redraw self))) + +(defmethod enabled-p ((self widget)) + (not (zerop (gfs::is-window-enabled (gfs:handle self)))))

(defmethod image :before ((self widget)) (if (gfs:disposed-p self)