[graphic-forms-cvs] r242 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Aug 29 19:28:44 UTC 2006
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
+ at 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- at sc{nil} value enables it.
@end deffn
- at deffn GenericFunction enabled-p self
-Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise.
+ at anchor{enable-redraw}
+ at 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- at 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
- at code{self}. Specifying @sc{nil} hides the scrollbar. These flags do
+ at 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
+ at anchor{enabled-p}
+ at deffn GenericFunction enabled-p self
+Returns @sc{t} if @var{self} is enabled; @sc{nil} otherwise.
+ at 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
+ at anchor{update-from-items}
+ at 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.
+ at 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}
- at deftp Class item-manager image-provider items text-provider
+ at 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
+ 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
@@ -359,14 +364,8 @@
a combo-box.,
event-select}
@control-callback-initarg{list-box,event-select}
- at 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.
- at end deffn
- at deffn Initarg :initial-items
-This initarg accepts a list of objects for initially populating the
+ at 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)
More information about the Graphic-forms-cvs
mailing list