August 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r244 - in trunk: . docs/manual src/uitoolkit/widgets
by junrue＠common-lisp.net 30 Aug '06

30 Aug '06

Author: junrue Date: Wed Aug 30 00:57:25 2006 New Revision: 244 Added: trunk/src/uitoolkit/widgets/list-item.lisp Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd 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/widget-classes.lisp Log: refactored more of menu-item, implemented new list-item class Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Wed Aug 30 00:57:25 2006 @@ -104,17 +104,21 @@ @end deffn @end macro -@macro begin-control-subclass{classname,descr,callbackname} -@anchor{\classname\} -@deftp Class \classname\ callback-event-name -\descr\ -@table @var +@macro callback-event-name-slot{callbackname} @item callback-event-name This is an @code{(:allocation :class)} slot that holds the symbol @sc{@ref{\callbackname\}} identifying the event generic function to be implemented on behalf of the application when a function is supplied for the @code{:callback} initarg. See @ref{event-source} for more details on this slot. +@end macro + +@macro begin-control-subclass{classname,descr,callbackname} +@anchor{\classname\} +@deftp Class \classname\ callback-event-name +\descr\ +@table @var +@callback-event-name-slot{\callbackname\} @end table @end macro Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Wed Aug 30 00:57:25 2006 @@ -65,6 +65,7 @@ interface objects serving as subcomponents of an @ref{item-manager}. It derives from @ref{event-source}. @table @var +@callback-event-name-slot{event-select} @item data A reference to the application-defined object to be wrapped by the item. @@ -120,6 +121,16 @@ @end deffn @end deftp +@anchor{list-item} +@deftp Class list-item index +A subclass of @ref{item} representing an element of a @ref{list-box}. +@table @var +@item index +This is an internal value representing the position of the item +within the list-box control. +@end table +@end deftp + @anchor{menu} @deftp Class menu This class represents a container for menu items and submenus. It Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Aug 30 00:57:25 2006 @@ -132,6 +132,7 @@ (:file "label") (:file "button") (:file "item-manager") + (:file "list-item") (:file "list-box") (:file "menu") (:file "menu-item") Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Wed Aug 30 00:57:25 2006 @@ -85,6 +85,12 @@ (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (delete-item self (gfs:span-start sp)))) +(defmethod gfs:dispose ((self item-manager)) + (let ((items (items-of self)) + (tc (thread-context))) + (dotimes (i (length items)) + (delete-tc-item tc (elt items i))))) + (defmethod item-index :before ((self item-manager) (it item)) (declare (ignore it)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Wed Aug 30 00:57:25 2006 @@ -33,16 +33,20 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defun create-item-with-callback (howner thing disp) +;;; +;;; helper functions +;;; + +(defun create-item-with-callback (howner class-symbol 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))) + (setf item (make-instance class-symbol :item-id id :data thing :handle howner))) ((functionp disp) - (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :callback disp))) + (setf item (make-instance class-symbol :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))) + (setf item (make-instance class-symbol :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"))) @@ -51,6 +55,10 @@ (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2))) +;;; +;;; methods +;;; + (defmethod check :before ((self item) flag) (declare (ignore flag)) (if (gfs:null-handle-p (gfs:handle self)) @@ -59,3 +67,26 @@ (defmethod checked-p :before ((self item)) (if (gfs:null-handle-p (gfs:handle self)) (error 'gfs:toolkit-error :detail "null owner handle"))) + +(defmethod gfs:dispose ((self item)) + (setf (dispatcher self) nil) + (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) + (when callback + (unless (typep callback 'function) + (error 'gfs:toolkit-error :detail ":callback value must be a function")) + (setf (dispatcher self) + (make-instance (define-dispatcher (class-name (class-of self)) callback))))) + +(defmethod owner ((self item)) + (let ((hwnd (gfs:handle self))) + (if (gfs:null-handle-p hwnd) + (error 'gfs:toolkit-error :detail "null owner widget handle")) + (let ((widget (get-widget (thread-context) hwnd))) + (if (null widget) + (error 'gfs:toolkit-error :detail "no owner widget")) + widget))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Wed Aug 30 00:57:25 2006 @@ -53,7 +53,7 @@ (let* ((tc (thread-context)) (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) - (item (create-item-with-callback hcontrol thing disp))) + (item (create-item-with-callback hcontrol 'list-item thing disp))) (insert-list-item hcontrol -1 text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) @@ -125,5 +125,8 @@ (progn (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) (loop for item in items - do (append-item self item (dispatcher self)))) + for index = 0 then (1+ index) + do (progn + (setf (index-of item) index) + (append-item self item (dispatcher self))))) (enable-redraw self t)))) Added: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/list-item.lisp Wed Aug 30 00:57:25 2006 @@ -0,0 +1,46 @@ +;;;; +;;;; list-item.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 gfs:dispose ((self list-item)) + (let ((index (index-of self)) + (owner (owner self))) + (if owner + (gfs::send-message (gfs:handle owner) gfs::+lb-deletestring+ index 0)) + (setf (index-of self) 0)) + (call-next-method)) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Wed Aug 30 00:57:25 2006 @@ -170,65 +170,47 @@ ;;; methods ;;; -(defmethod check ((it menu-item) flag) - (let ((hmenu (gfs:handle it))) - (check-menuitem hmenu (item-id it) flag))) +(defmethod check ((self menu-item) flag) + (let ((hmenu (gfs:handle self))) + (check-menuitem hmenu (item-id self) flag))) -(defmethod checked-p ((it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod checked-p ((self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (is-menuitem-checked hmenu (item-id it)))) + (is-menuitem-checked hmenu (item-id self)))) -(defmethod gfs:dispose ((it menu-item)) - (setf (dispatcher it) nil) - (delete-tc-item (thread-context) it) - (let ((id (item-id it)) - (owner (owner it))) +(defmethod gfs:dispose ((self menu-item)) + (let ((id (item-id self)) + (owner (owner self))) (unless (null owner) (gfs::remove-menu (gfs:handle owner) id gfs::+mf-bycommand+) - (let* ((index (item-index owner it)) + (let* ((index (item-index owner self)) (child-menu (sub-menu owner index))) (unless (null child-menu) - (gfs:dispose child-menu)))) - (setf (item-id it) 0) - (setf (slot-value it 'gfs:handle) nil))) + (gfs:dispose child-menu))))) + (call-next-method)) -(defmethod enable ((it menu-item) flag) +(defmethod enable ((self menu-item) flag) (let ((bits 0)) (if flag (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-enabled+)) (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-grayed+))) - (gfs::enable-menu-item (gfs:handle it) (item-id it) bits))) + (gfs::enable-menu-item (gfs:handle self) (item-id self) bits))) -(defmethod enabled-p ((it menu-item)) - (= (logand (get-menuitem-state (gfs:handle it) (item-id it)) +(defmethod enabled-p ((self menu-item)) + (= (logand (get-menuitem-state (gfs:handle self) (item-id self)) gfs::+mfs-enabled+) gfs::+mfs-enabled+)) -(defmethod initialize-instance :after ((self menu-item) &key callback &allow-other-keys) - (when callback - (unless (typep callback 'function) - (error 'gfs:toolkit-error :detail ":callback value must be a function")) - (setf (dispatcher self) (make-instance (define-dispatcher 'menu-item callback))))) - -(defmethod owner ((it menu-item)) - (let ((hmenu (gfs:handle it))) - (if (gfs:null-handle-p hmenu) - (error 'gfs:toolkit-error :detail "null owner menu handle")) - (let ((m (get-widget (thread-context) hmenu))) - (if (null m) - (error 'gfs:toolkit-error :detail "no owner menu")) - m))) - -(defmethod text ((it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod text ((self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (get-menuitem-text hmenu (item-id it)))) + (get-menuitem-text hmenu (item-id self)))) -(defmethod (setf text) (str (it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod (setf text) (str (self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (set-menuitem-text hmenu (item-id it) str))) + (set-menuitem-text hmenu (item-id self) str))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Wed Aug 30 00:57:25 2006 @@ -93,7 +93,7 @@ (defmethod append-item ((self menu) thing disp &optional disabled checked) (let* ((tc (thread-context)) (hmenu (gfs:handle self)) - (item (create-item-with-callback hmenu thing disp)) + (item (create-item-with-callback hmenu 'menu-item 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) @@ -141,11 +141,13 @@ (delete-widget tc (gfs:handle menu)) (delete-tc-item tc item))) -(defmethod gfs:dispose ((m menu)) - (visit-menu-tree m #'menu-cleanup-callback) - (let ((hwnd (gfs:handle m))) - (delete-widget (thread-context) hwnd) - (if (not (gfs:null-handle-p hwnd)) +(defmethod gfs:dispose ((self menu)) + (unless (null (dispatcher self)) + (event-dispose (dispatcher self) self)) + (visit-menu-tree self #'menu-cleanup-callback) + (let ((hwnd (gfs:handle self))) + (when (not (gfs:null-handle-p hwnd)) + (delete-widget (thread-context) hwnd) (if (zerop (gfs::destroy-menu hwnd)) (error 'gfs:win32-error :detail "destroy-menu failed")))) - (setf (slot-value m 'gfs:handle) nil)) + (setf (slot-value self 'gfs:handle) nil)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed Aug 30 00:57:25 2006 @@ -90,8 +90,14 @@ :allocation :class)) ; shadowing same slot from event-source (:documentation "The item class is the base class for all non-windowed user interface objects.")) +(defclass list-item (item) + ((index + :accessor index-of + :initform 0)) + (:documentation "A subclass of item representing an element of a list-box.")) + (defclass menu-item (item) () - (:documentation "A subtype of item representing a menu item.")) + (:documentation "A subclass of item representing a menu item.")) (defclass widget (event-source) ((style

1 0

[graphic-forms-cvs] r243 - in trunk: docs/manual src src/demos/textedit src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 30 Aug '06

30 Aug '06

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

1 0

[graphic-forms-cvs] r242 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 29 Aug '06

29 Aug '06

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)

1 0

[graphic-forms-cvs] r241 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 28 Aug '06

28 Aug '06

Author: junrue Date: Mon Aug 28 18:52:53 2006 New Revision: 241 Modified: trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: item-manager now has slots for functions to obtain text and image from item data, revised append-item accordingly Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Mon Aug 28 18:52:53 2006 @@ -10,25 +10,27 @@ @anchor{ancestor-p} @deffn GenericFunction ancestor-p ancestor descendant => boolean -Returns T if @var{ancestor} is the parent of @var{descendant}; nil otherwise. +Returns T if @var{ancestor} is the parent of @var{descendant}; @sc{nil} +otherwise. @end deffn @anchor{append-item} -@deffn GenericFunction append-item self text image dispatcher &optional disabled checked -Adds the new item with the specified @code{text}, @code{image}, and -@ref{event-dispatcher} to the object, and returns the newly-created item. -The optional @code{checked} and @code{disabled} arguments can be used -to set the item's initial state. -@end deffn - -@deffn GenericFunction append-separator self -Adds a separator item to the object, and returns the newly-created -item. -@end deffn - -@deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked -Adds a submenu anchored to a parent menu and returns the corresponding -menu item. The optional @code{checked} and @code{disabled} arguments can +@deffn GenericFunction append-item self thing dispatcher &optional disabled checked => @ref{item} +Adds a new item representing @var{thing} to @var{self}, where the +class of @var{self} must derive from @ref{item-manager}. The +newly-created item is returned. The @var{dispatcher} parameter must +be an instance of @ref{event-dispatcher} or a subclass thereof. The +optional @var{checked} and @var{disabled} arguments can be used to set +the item's initial state. +@end deffn + +@deffn GenericFunction append-separator self => @ref{item} +Adds a separator item to @var{self}, and returns the newly-created item. +@end deffn + +@deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{item} +Adds @var{submenu} anchored to @var{self} and returns the corresponding +@ref{menu-item}. The optional @var{checked} and @var{disabled} arguments can be used to set the menu item's initial state. @end deffn Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Aug 28 18:52:53 2006 @@ -60,24 +60,35 @@ @end deftp @anchor{item} -@deftp Class item item-id +@deftp Class item data item-id This is the base class for all non-windowed user interface objects serving as subcomponents of an @ref{item-manager}. It derives from @ref{event-source}. @table @var +@item data +A reference to the application-defined object to be wrapped +by the item. @item item-id An identifier for the item managed internally by Graphic-Forms. @end table @end deftp @anchor{item-manager} -@deftp Class item-manager items +@deftp Class item-manager image-provider items text-provider This is is a mix-in class for @ref{widget}s containing sub-elements. - @table @var +@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}. @item items An @sc{adjustable} @sc{vector} containing @ref{item}s representing sub-elements. +@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}. @end table @end deftp @@ -356,10 +367,8 @@ @end deffn @deffn Initarg :initial-items This initarg accepts a list of objects for initially populating the -contents of the list-box. @sc{print-object} will be called for -each object to produce the corresponding item's display string. -The list-box will hold references to the supplied objects. See -also @ref{append-item}. +contents of the list-box. The list-box will hold references to the +supplied objects. See also @ref{append-item}. @end deffn @control-parent-initarg{list-box} @deffn Initarg :style Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Aug 28 18:52:53 2006 @@ -177,7 +177,7 @@ (gfw:mapchildren *layout-tester-win* (lambda (parent child) (declare (ignore parent)) - (let ((it (gfw::append-item menu (gfw:text child) nil nil))) + (let ((it (gfw::append-item menu (gfw:text child) nil))) (unless (null (sub-disp-class-of d)) (setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d)))) (unless (null (check-test-fn d)) @@ -378,9 +378,9 @@ (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-items) (gfw:append-submenu menu "Spacing" spacing-menu #'enable-flow-spacing-items) (let ((style (gfw:style-of (gfw:layout-of *layout-tester-win*)))) - (setf it (gfw:append-item menu "Normalize" nil #'set-flow-layout-normalize)) + (setf it (gfw:append-item menu "Normalize" #'set-flow-layout-normalize)) (gfw:check it (find :normalize style)) - (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) + (setf it (gfw:append-item menu "Wrap" #'set-flow-layout-wrap)) (gfw:check it (find :wrap style))))) (defun exit-layout-callback (disp item) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Aug 28 18:52:53 2006 @@ -33,8 +33,27 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defmethod append-item :before ((self item-manager) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) - (declare (ignore text image disp checked disabled)) +;;; +;;; helper functions +;;; + +(defun call-text-provider (manager thing) + (let ((func (text-provider-of manager)) + (*print-readably* nil)) + (cond + ((stringp thing) + thing) + ((null func) + (format nil "~a" thing)) + (t + (funcall func thing))))) + +;;; +;;; methods +;;; + +(defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled) + (declare (ignore thing disp checked disabled)) (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 Mon Aug 28 18:52:53 2006 @@ -32,7 +32,7 @@ ;;;; (in-package :graphic-forms.uitoolkit.widgets) - + (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2))) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Mon Aug 28 18:52:53 2006 @@ -166,15 +166,15 @@ (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 disp) +(defun create-menuitem-with-callback (hmenu thing disp) (let ((item nil)) (cond ((null disp) - (setf item (make-instance 'menu-item :handle hmenu))) + (setf item (make-instance 'menu-item :data thing :handle hmenu))) ((functionp disp) - (setf item (make-instance 'menu-item :handle hmenu :callback disp))) + (setf item (make-instance 'menu-item :data thing :handle hmenu :callback disp))) ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance 'menu-item :handle hmenu :dispatcher disp))) + (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"))) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Aug 28 18:52:53 2006 @@ -167,6 +167,8 @@ ;;; code generation ;;; +(defstruct menu-item-data text image) + (defun generate-menusystem-code (sexp generator-sym) (let ((code nil)) (mapcar #'(lambda (var) @@ -177,19 +179,25 @@ (defclass win32-menu-generator (base-menu-generator) ()) (defmethod initialize-instance :after ((gen win32-menu-generator) &key) - (let ((m (make-instance 'menu :handle (gfs::create-menu)))) + (let ((m (make-instance 'menu :handle (gfs::create-menu) + :image-provider #'menu-item-data-image + :text-provider #'menu-item-data-text))) (put-widget (thread-context) m) (push m (menu-stack-of gen)))) (defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image) - (append-item (first (menu-stack-of gen)) label image dispatcher disabled checked)) + (append-item (first (menu-stack-of gen)) + (make-menu-item-data :text label :image image) + dispatcher disabled checked)) (defmethod define-separator ((gen win32-menu-generator)) (let ((owner (first (menu-stack-of gen)))) (append-separator owner))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) - (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)))) + (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) + :image-provider #'menu-item-data-image + :text-provider #'menu-item-data-text))) (append-submenu (first (menu-stack-of gen)) label submenu dispatcher disabled) (push submenu (menu-stack-of gen)))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Aug 28 18:52:53 2006 @@ -90,12 +90,12 @@ ;;; methods ;;; -(defmethod append-item ((owner menu) text image disp &optional disabled checked) - (declare (ignore image)) ; FIXME: temporary measure until we support images in menu items +(defmethod append-item ((owner 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 disp))) + (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) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Aug 28 18:52:53 2006 @@ -80,6 +80,10 @@ :accessor item-id :initarg :item-id :initform 0) + (data + :accessor data-of + :initarg :data + :initform nil) (callback-event-name :accessor callback-event-name-of :initform 'event-select @@ -158,7 +162,15 @@ ((items :accessor items ;; FIXME: allow subclasses to set initial size? - :initform (make-array 7 :fill-pointer 0 :adjustable t))) + :initform (make-array 7 :fill-pointer 0 :adjustable t)) + (text-provider + :accessor text-provider-of + :initarg :text-provider + :initform nil) + (image-provider + :accessor image-provider-of + :initarg :image-provider + :initform nil)) (:documentation "A mix-in for objects composed of sub-elements.")) (defclass list-box (widget item-manager) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Aug 28 18:52:53 2006 @@ -45,8 +45,8 @@ (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (self text image dispatcher &optional checked disabled) - (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) +(defgeneric append-item (self thing dispatcher &optional checked disabled) + (:documentation "Adds a new item encapsulating thing to self, and returns the newly-created item.")) (defgeneric append-separator (self) (:documentation "Add a separator item to the object, and returns the newly-created item."))

1 0

[graphic-forms-cvs] r240 - trunk/docs/manual
by junrue＠common-lisp.net 28 Aug '06

28 Aug '06

Author: junrue Date: Mon Aug 28 16:33:21 2006 New Revision: 240 Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo Log: refined controls section of manual, added more doc for list-box Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Mon Aug 28 16:33:21 2006 @@ -89,6 +89,21 @@ The @ref{point} location of the mouse cursor. @end macro +@macro control-callback-initarg{classname,callbackname} +@deffn Initarg :callback +The function supplied via this initarg will be used as +the implementation of @sc{@ref{\callbackname\}} in an +@ref{event-dispatcher} configured for the \classname\. +See also @var{callback-event-name}. +@end deffn +@end macro + +@macro control-parent-initarg{classname} +@deffn Initarg :parent +This initarg specifies the @ref{parent} of the \classname\. +@end deffn +@end macro + @macro begin-control-subclass{classname,descr,callbackname} @anchor{\classname\} @deftp Class \classname\ callback-event-name Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Mon Aug 28 16:33:21 2006 @@ -8,10 +8,12 @@ @node Widget functions @subsection Widget functions -@deffn GenericFunction ancestor-p ancestor descendant -Returns T if ancestor is an ancestor of descendant; nil otherwise. +@anchor{ancestor-p} +@deffn GenericFunction ancestor-p ancestor descendant => boolean +Returns T if @var{ancestor} is the parent of @var{descendant}; nil otherwise. @end deffn +@anchor{append-item} @deffn GenericFunction append-item self text image dispatcher &optional disabled checked Adds the new item with the specified @code{text}, @code{image}, and @ref{event-dispatcher} to the object, and returns the newly-created item. Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Aug 28 16:33:21 2006 @@ -61,13 +61,13 @@ @anchor{item} @deftp Class item item-id -The @code{item} class is the base class for all non-windowed user -interface objects serving as subcomponents of a -@ref{item-manager} object. It derives from @ref{event-source}. -@deffn Initarg :item-id -@end deffn -@deffn Accessor item-id -@end deffn +This is the base class for all non-windowed user +interface objects serving as subcomponents of an +@ref{item-manager}. It derives from @ref{event-source}. +@table @var +@item item-id +An identifier for the item managed internally by Graphic-Forms. +@end table @end deftp @anchor{item-manager} @@ -104,7 +104,7 @@ @anchor{menu} @deftp Class menu This class represents a container for menu items and submenus. It -derives from @ref{item-manager}. +derives from @ref{widget} and @ref{item-manager}. @end deftp @anchor{menu-item} @@ -146,17 +146,14 @@ @subsection Controls @begin-control-subclass{button, -This @ref{control} class represents selectable controls that generate +This @ref{control} subclass represents selectable controls that generate an event when clicked., event-select} -@deffn Initarg :callback -The @sc{function} value supplied via this initarg will be -used as the implementation of @ref{event-select} in an -@ref{event-dispatcher} configured for the @code{button}. -@end deffn +@control-callback-initarg{button,event-select} @deffn Initarg :image -Supplies an image to be used as the @code{button}'s label. +Supplies an image to be used as the button's label. @end deffn +@control-parent-initarg{button} @deffn Initarg :style @table @code @item :cancel-button @@ -165,26 +162,26 @@ action should be interpreted as the user discarding the content of the dialog. @item :check-box -This style specifies a @code{button} having a small box, which may -contain a check mark depending on the @code{button}'s selection state, +This style specifies a button having a small box, which may +contain a check mark depending on the button's selection state, adjacent to a text label. @item :default-button Placing a @code{:default-button} in a dialog enables the @sc{return} key @ref{accelerator} for dismissing the dialog. This action should be interpreted as the user accepting the content of the dialog. Also, the -@code{button} is rendered with an extra thick border. +button is rendered with an extra thick border. @item :push-button This style specifies a traditional push button control. No special keyboard accelerators are enabled. @item :radio-button -This style specifies a @code{button} having a small circle, which may -be filled or unfilled depending on the @code{button}'s selection -state, adjacent to a text label. Radio @code{button}s are typically +This style specifies a button having a small circle, which may +be filled or unfilled depending on the button's selection +state, adjacent to a text label. Radio buttons are typically used in groups and are managed such that only one member of the group is enabled at a time. @item :toggle-button This style specifies a control that when unselected looks like a push -@code{button}. But when in the selected state, the @code{button} +button. But when in the selected state, the button maintains a sunken look. It is similar in function to a @code{:check-box}. @item :tri-state @@ -194,7 +191,7 @@ @end table @end deffn @deffn Initarg :text -Supplies the text for the @code{button} label. +Supplies the text for the button label. @end deffn @end-control-subclass @@ -202,67 +199,65 @@ @deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color The base class for widgets having pre-defined native behavior. It derives from @ref{widget}.@*@* -@strong{Note:} application code should not manipulate @code{control} slots -directly, unless defining a new @code{control} type as an extension to +@strong{Note:} application code should not manipulate control slots +directly, unless defining a new control type as an extension to Graphic-Forms. @table @var @item brush-color -If set, this @ref{color} object is used as the @code{control}'s background color -when the @code{control} needs to be redrawn. +If set, this @ref{color} object is used as the control's background color +when the control needs to be redrawn. @item brush-handle This is a native handle for a Win32 @sc{brush} that is used when customizing -the @code{control}'s background color. +the control's background color. @item font -This is a @ref{font} object for customizing the text of a @code{control}. +This is a @ref{font} object for customizing the text of a control. @item pixel-point This is a @ref{point} object specifying a pixel in an @ref{image} -associated with a @code{control}, for the purpose of determining what +associated with a control, for the purpose of determining what color to use for transparency. @item maximum-size This is a @ref{size} object that places a maximum constraint on the -size that a @ref{layout-manager} may set for the @code{control}. It +size that a @ref{layout-manager} may set for the control. It may be @sc{nil} if no such constraint has been set. @item minimum-size This is a @ref{size} object that places a minimum constraint on the -size that a @ref{layout-manager} may set for the @code{control}. It +size that a @ref{layout-manager} may set for the control. It may be @sc{nil} if no such constraint has been set. @item text-color -If set, this color object is used as the @code{control}'s foreground text -color when the @code{control} needs to be redrawn. +If set, this color object is used as the control's foreground text +color when the control needs to be redrawn. @end table @deffn Initarg :callback -This initarg associates a @sc{function} with an @ref{event-dispatcher} +This initarg associates a function with an @ref{event-dispatcher} subclass that is generated behind the scenes and then instantiated to -serve as the @code{control}'s event dispatcher. Each @code{control} +serve as the control's event dispatcher. Each control subclass specifies the particular event function (e.g., @ref{event-select}) that this callback will implement; see the documentation for specific -@code{control} subclasses for more information on this initarg. +control subclasses for more information on this initarg. @end deffn +@control-parent-initarg{control} @end deftp @begin-control-subclass{edit, This subclass of @ref{control} represents a rectangular area that permits the user to enter and edit text. The @ref{event-focus-gain} -and @ref{event-focus-loss} methods of each @code{edit control}'s +and @ref{event-focus-loss} methods of each edit control's @ref{event-dispatcher} are invoked when focus is given or taken away. The @ref{event-modify} method is invoked when the user edits content., event-modify} -@deffn Initarg :callback -The @sc{function} value supplied via this initarg will be -used as the implementation of @ref{event-modify} in an -@ref{event-dispatcher} configured for the @code{edit control}. -@end deffn +@control-callback-initarg{edit,event-modify} +@control-parent-initarg{edit} @deffn Initarg :style @table @code @item :auto-hscroll -Specifies that the @code{edit control} will scroll text content to the +Specifies that the edit control will scroll text content to the right by 10 characters when the user types a character at the end -of the line. For single-line @code{edit control}s, this style is set +of the line. For single-line edit controls, this style is set by the library. See @ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and @ref{enable-auto-scrolling}. @item :auto-vscroll -Specifies that the @code{edit control} will scroll text up by a page +Specifies that the edit control will scroll text up by a page when the user types @sc{enter} on the last line. This style keyword is only meaningful when @code{:multi-line} is also specified. See @ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and @@ -274,21 +269,21 @@ instead of the one literally typed. The character can be changed via the @ref{echo-character} @sc{setf} method. @item :multi-line -By default, @code{edit control}s are single-line text fields. By specifying +By default, edit controls are single-line text fields. By specifying @code{:multi-line}, multiple lines of text can be supplied. When the -@code{edit control} is in a @ref{dialog}, the @sc{enter} key will invoke +edit control is in a @ref{dialog}, the @sc{enter} key will invoke the default @ref{button}'s @ref{event-dispatcher}, unless @code{:want-return} is also specified. If @code{:auto-hscroll} is not specified, then text will be automatically word-wrapped. @item :no-border -By default, an @code{edit control} is rendered with a border; this style +By default, an edit control is rendered with a border; this style keyword disables that feature. @item :no-hide-selection This specifies that any selection remain rendered even when the -@code{edit control} loses input focus. By default, the selection +edit control loses input focus. By default, the selection is hidden when focus is lost. @item :read-only -Specifies that the @code{edit control}'s contents cannot be modified by +Specifies that the edit control's contents cannot be modified by the user. @item :vertical-scrollbar Specifies that a vertical scrollbar should be displayed. @@ -301,13 +296,14 @@ @end table @end deffn @deffn Initarg :text -Supplies the initial text for the @code{edit control}. +Supplies the initial text for the edit control. @end deffn @end-control-subclass @begin-control-subclass-no-callback{label, This @ref{control} subclass represents non-selectable controls that display a string\, image\, or etched line.} +@control-parent-initarg{label} @deffn Initarg :image Supply an @ref{image} object as the value of this initarg to configure the label to display the image rather than text. @@ -347,8 +343,50 @@ @end-control-subclass @begin-control-subclass{list-box, -This @ref{control} class represents a list of selectable items., +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., 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 +contents of the list-box. @sc{print-object} will be called for +each object to produce the corresponding item's display string. +The list-box will hold references to the supplied objects. See +also @ref{append-item}. +@end deffn +@control-parent-initarg{list-box} +@deffn Initarg :style +@table @code +@item :extend-select +This style keyword causes the list-box to allow multiple items to +be selected by use of the @sc{shift} key and the mouse or special +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. +@item :no-select +This style keyword means that the list-box will display items but +not allow any selections. +@item :tab-stops +This style keyword configures the list-box to to expand tab characters +when rendering item strings. +@item :want-keys +This style keyword allows the application to perform special processing +when the list-box has focus and the user presses a key. +@item :want-scrollbar +This style keyword causes the list-box to show a disabled vertical +scrollbar when it does not contain enough items to scroll. Otherwise +in such a case, the scrollbar will be hidden. +@end table +@end deffn @end-control-subclass

1 0

[graphic-forms-cvs] r239 - in trunk: . docs/manual src src/uitoolkit/widgets
by junrue＠common-lisp.net 28 Aug '06

28 Aug '06

Author: junrue Date: Mon Aug 28 11:20:02 2006 New Revision: 239 Added: trunk/src/uitoolkit/widgets/item-manager.lisp - copied, changed from r231, trunk/src/uitoolkit/widgets/widget-with-items.lisp Removed: trunk/src/uitoolkit/widgets/widget-with-items.lisp Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/glossary.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: widget-with-items base class renamed to item-manager and is now a mix-in Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Aug 28 11:20:02 2006 @@ -75,7 +75,7 @@ * Layouts:: Layout manager classes. * Controls:: Control classes. * Windows and dialogs:: Window and dialog classes. -* Miscellaneous types:: Base classes for more specialized kinds of widgets. +* Miscellaneous types:: Assorted base classes and utility classes. * Event functions:: Functions related to event processing. * Layout functions:: Functions related to layout management. * Widget functions:: Functions related to widgets. Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Mon Aug 28 11:20:02 2006 @@ -63,6 +63,13 @@ invoked in a context-sensitive manner via the mouse or an @ref{accelerator}.@* +@item mix-in class +@anchor{mix-in class} +@cindex mix-in class +A mix-in class represents a specific abstraction that +complements the role(s) of other class(es) in a class +hierarchy.@* + @item mnemonic @anchor{mnemonic} @cindex mnemonic Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Aug 28 11:20:02 2006 @@ -63,13 +63,24 @@ @deftp Class item item-id The @code{item} class is the base class for all non-windowed user interface objects serving as subcomponents of a -@ref{widget-with-items} object. It derives from @ref{event-source}. +@ref{item-manager} object. It derives from @ref{event-source}. @deffn Initarg :item-id @end deffn @deffn Accessor item-id @end deffn @end deftp +@anchor{item-manager} +@deftp Class item-manager items +This is is a mix-in class for @ref{widget}s containing sub-elements. + +@table @var +@item items +An @sc{adjustable} @sc{vector} containing @ref{item}s representing +sub-elements. +@end table +@end deftp + @anchor{layout-managed} @deftp Class layout-managed layout layout-p Instances of this class employ a @ref{layout-manager} to maintain @@ -93,9 +104,10 @@ @anchor{menu} @deftp Class menu This class represents a container for menu items and submenus. It -derives from @ref{widget-with-items}. +derives from @ref{item-manager}. @end deftp +@anchor{menu-item} @deftp Class menu-item A subclass of @ref{item} representing a @ref{menu} item. @end deftp @@ -129,14 +141,6 @@ behavior of the widget; style keywords are widget-specific. @end deftp -@anchor{widget-with-items} -@deftp Class widget-with-items items -The widget-with-items class is the base class for objects composed of -sub-items. It derives from @ref{widget}. The @code{items} slot is an -@sc{adjustable} @sc{vector} containing @ref{item} objects, -representing sub-elements of the widget. -@end deftp - @node Controls @subsection Controls Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Aug 28 11:20:02 2006 @@ -131,7 +131,7 @@ (:file "edit") (:file "label") (:file "button") - (:file "widget-with-items") + (:file "item-manager") (:file "menu") (:file "menu-item") (:file "menu-language") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Aug 28 11:20:02 2006 @@ -256,6 +256,7 @@ #:flow-layout #:heap-layout #:item + #:item-manager #:layout-managed #:layout-manager #:menu @@ -265,7 +266,6 @@ #:timer #:top-level #:widget - #:widget-with-items #:window ;; constants Copied: trunk/src/uitoolkit/widgets/item-manager.lisp (from r231, trunk/src/uitoolkit/widgets/widget-with-items.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Aug 28 11:20:02 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; widget-with-items.lisp +;;;; item-manager.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -33,23 +33,23 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defmethod append-item :before ((self widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) +(defmethod append-item :before ((self item-manager) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) (declare (ignore text image disp checked disabled)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-all ((self widget-with-items)) +(defmethod delete-all ((self item-manager)) (let ((items (items self))) (dotimes (i (length items)) (gfs:dispose (aref items i)))) (setf (items self) (make-array 7 :fill-pointer 0 :adjustable t))) -(defmethod delete-item :before ((self widget-with-items) index) +(defmethod delete-item :before ((self item-manager) index) (declare (ignore index)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item ((self widget-with-items) index) +(defmethod delete-item ((self item-manager) index) (let* ((items (items self)) (it (elt items index))) (setf (items self) (remove it items :test #'items-equal-p)) @@ -57,21 +57,21 @@ (error 'gfs:disposed-error)) (gfs:dispose it))) -(defmethod delete-item-span :before ((self widget-with-items) (sp gfs:span)) +(defmethod delete-item-span :before ((self item-manager) (sp gfs:span)) (declare (ignore sp)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item-span ((self widget-with-items) (sp gfs:span)) +(defmethod delete-item-span ((self item-manager) (sp gfs:span)) (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (delete-item self (gfs:span-start sp)))) -(defmethod item-index :before ((self widget-with-items) (it item)) +(defmethod item-index :before ((self item-manager) (it item)) (declare (ignore it)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod item-index ((self widget-with-items) (it item)) +(defmethod item-index ((self item-manager) (it item)) (let ((pos (position it (items self) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Aug 28 11:20:02 2006 @@ -154,21 +154,21 @@ (defclass font-dialog (widget) () (:documentation "This class represents the standard font dialog.")) -(defclass widget-with-items (widget) +(defclass item-manager () ((items :accessor items ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t))) - (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) + (:documentation "A mix-in for objects composed of sub-elements.")) -(defclass list-box (widget-with-items) +(defclass list-box (widget item-manager) ((callback-event-name :accessor callback-event-name-of :initform 'event-select :allocation :class)) ; shadowing same slot from event-source (:documentation "The list-box class represents the standard listbox control.")) -(defclass menu (widget-with-items) +(defclass menu (widget item-manager) ((callback-event-name :accessor callback-event-name-of :initform 'event-activate

1 0

[graphic-forms-cvs] r237 - in trunk: . docs/manual docs/website src/demos/textedit src/demos/unblocked
by junrue＠common-lisp.net 23 Aug '06

23 Aug '06

Author: junrue Date: Wed Aug 23 09:25:23 2006 New Revision: 237 Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/overview.texinfo trunk/docs/manual/reference.texinfo trunk/docs/website/index.html trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: version number bump Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Wed Aug 23 09:25:23 2006 @@ -1,4 +1,8 @@ + + +============================================================================== + Release 0.5.0 of Graphic-Forms, a Common Lisp library for Windows GUI programming, is now available. This is an alpha release, meaning that the feature set and API have not yet stabilized. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Aug 23 09:25:23 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.5.0 (22 August 2006) +Graphic-Forms README for version 0.6.0 (22 August 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Wed Aug 23 09:25:23 2006 @@ -53,7 +53,7 @@ @itemize @bullet @item CLISP 2.38 or later @item LispWorks 4.4.6 -@item SBCL 0.9.15 or later@footnote{a small patch to enable the +@item SBCL 0.9.15@footnote{a small patch to enable the @sc{stdcall} calling convention for callbacks is temporarily bundled with Graphic-Forms, see @code{src/external-libraries/sbcl-callback-patch/}} @end itemize @@ -113,9 +113,9 @@ @section Building the Library and Running Tests -Please see the @code{README.txt} file included in the -distribution for instructions on how to load the test program -ASDF system and run unit-tests, test programs, and demo programs. +Please see the @code{README.txt} file included in the distribution for +instructions on how to load the ASDF system and run unit-tests, test +programs, and demo programs. @section Support Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Wed Aug 23 09:25:23 2006 @@ -148,7 +148,7 @@ @titlepage @title Graphic-Forms Programming Reference -@c @subtitle Version 0.5 +@c @subtitle Version 0.6 @c @author Jack D. Unrue @page @@ -158,7 +158,7 @@ @ifnottex @node Top -@top Graphic-Forms Programming Reference (version 0.5) +@top Graphic-Forms Programming Reference (version 0.6) @insertcopying @end ifnottex Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Aug 23 09:25:23 2006 @@ -54,7 +54,7 @@ The current version is <a href="http://sourceforge.net/project/showfiles.php?group_id=163034"> - 0.5.0</a>, released on 22 August 2006. + 0.6.0</a>, released on 22 August 2006. Graphic-Forms is in the alpha stage of development, meaning new features are still being added and existing features require considerable testing. Brave souls who experiment with the code should expect Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Aug 23 09:25:23 2006 @@ -52,7 +52,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.5.0" + :version "0.6.0" :author "Jack D. Unrue" :licence "BSD" :components Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Aug 23 09:25:23 2006 @@ -39,7 +39,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.5.0" + :version "0.6.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Aug 23 09:25:23 2006 @@ -155,7 +155,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.5"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.6"))) (defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Wed Aug 23 09:25:23 2006 @@ -102,7 +102,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.5"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.6"))) (defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File"

1 0

[graphic-forms-cvs] r236 - tags/release-0.5.0
by junrue＠common-lisp.net 22 Aug '06

22 Aug '06

Author: junrue Date: Tue Aug 22 19:13:26 2006 New Revision: 236 Added: tags/release-0.5.0/ - copied from r235, trunk/ Log: tagging the 0.5.0 release

1 0

[graphic-forms-cvs] r235 - in trunk: . docs/website
by junrue＠common-lisp.net 22 Aug '06

22 Aug '06

Author: junrue Date: Tue Aug 22 19:10:17 2006 New Revision: 235 Modified: trunk/NEWS.txt trunk/README.txt trunk/build.lisp trunk/config.lisp trunk/docs/website/index.html Log: final tweaks for 0.5.0 Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Tue Aug 22 19:10:17 2006 @@ -86,7 +86,7 @@ Jack Unrue jdunrue (at) gmail (dot) com -25 August 2006 +22 August 2006 ============================================================================== Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Tue Aug 22 19:10:17 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.5.0 (25 August 2006) +Graphic-Forms README for version 0.5.0 (22 August 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -113,8 +113,13 @@ ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; + ;; Note that *gf-dir* should be the Graphic-Forms top-level directory + ;; path. + ;; + ;; ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* + ;; gfsys::*gf-dir* ;; gfsys::*lw-compat-dir* ;; Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Tue Aug 22 19:10:17 2006 @@ -58,5 +58,4 @@ (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") (configure-asdf) - (pushnew *gf-dir* asdf:*central-registry* :test #'equal) (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit)) Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Tue Aug 22 19:10:17 2006 @@ -52,6 +52,6 @@ (defvar *lisp-unit-file* "graphic-forms/src/external-libraries/practicals-1.0.3/lisp-unit.lisp") (defun configure-asdf () - (loop for var in '(*binary-data-dir* *cffi-dir* *closer-mop-dir* *lw-compat-dir* *macro-utilities-dir*) + (loop for var in '(*binary-data-dir* *cffi-dir* *closer-mop-dir* *lw-compat-dir* *macro-utilities-dir* *gf-dir*) when (symbol-value var) do (pushnew (symbol-value var) asdf:*central-registry* :test #'equal))) Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Tue Aug 22 19:10:17 2006 @@ -54,7 +54,7 @@ The current version is <a href="http://sourceforge.net/project/showfiles.php?group_id=163034"> - 0.5.0</a>, released on 25 August 2006. + 0.5.0</a>, released on 22 August 2006. Graphic-Forms is in the alpha stage of development, meaning new features are still being added and existing features require considerable testing. Brave souls who experiment with the code should expect

1 0

[graphic-forms-cvs] r234 - trunk
by junrue＠common-lisp.net 22 Aug '06

22 Aug '06

Author: junrue Date: Tue Aug 22 18:43:47 2006 New Revision: 234 Modified: trunk/config.lisp Log: make configure-asdf work like the readme says it should Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Tue Aug 22 18:43:47 2006 @@ -52,8 +52,6 @@ (defvar *lisp-unit-file* "graphic-forms/src/external-libraries/practicals-1.0.3/lisp-unit.lisp") (defun configure-asdf () - (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) - (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) - (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) - (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal) - (pushnew *macro-utilities-dir* asdf:*central-registry* :test #'equal)) + (loop for var in '(*binary-data-dir* *cffi-dir* *closer-mop-dir* *lw-compat-dir* *macro-utilities-dir*) + when (symbol-value var) + do (pushnew (symbol-value var) asdf:*central-registry* :test #'equal)))

1 0