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

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

29 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 29 Aug '06

29 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

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

22 Aug '06

Author: junrue Date: Tue Aug 22 18:38:07 2006 New Revision: 233 Added: trunk/src/tests/uitoolkit/computer.png (contents, props changed) trunk/src/tests/uitoolkit/open-folder.gif (contents, props changed) Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/website/index.html trunk/src/tests/uitoolkit/image-tester.lisp Log: added gif and png testcases to image-tester Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Tue Aug 22 18:38:07 2006 @@ -5,10 +5,10 @@ Here is what's new in this release: -. SBCL is now supported (version 0.9.15 tested). Graphic-Forms includes - a small patch provided to the SBCL community by Alastair Bridgewater - to enable the stdcall calling convention for alien callbacks. Please - see src/external-libraries/sbcl-callback-patch +. SBCL is now supported (specifically version 0.9.15). Graphic-Forms + includes a small patch provided to the SBCL community by + Alastair Bridgewater to enable the stdcall calling convention for + alien callbacks. Please see src/external-libraries/sbcl-callback-patch . Implemented a plugin mechanism for integrating graphics libraries. This means that ImageMagick is now optional -- if your application can get Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Tue Aug 22 18:38:07 2006 @@ -66,7 +66,9 @@ supporting Windows, and as a consequence, you may experience problems such as 'GC invariant lost' errors that result in a crash to LDB. -3. The gfg:text-extent method currently does not return the correct text +3. The 'unblocked' and 'textedit' demo programs are not yet complete. + +4. The gfg:text-extent method currently does not return the correct text height value. As a workaround, get the text metrics for the font and compute height from that. The gfg:text-extent function does return the correct width. Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Tue Aug 22 18:38:07 2006 @@ -53,7 +53,7 @@ <h3>Status</h3> The current version is - <a href="http://prdownloads.sourceforge.net/graphic-forms/graphic-forms-0.5.0.zip?do…"> + <a href="http://sourceforge.net/project/showfiles.php?group_id=163034"> 0.5.0</a>, released on 25 August 2006. Graphic-Forms is in the alpha stage of development, meaning new features are still being added and existing features require @@ -64,7 +64,7 @@ <ul> <li><a href="http://clisp.cons.org/">CLISP 2.38 or later</a></li> <li><a href="http://www.lispworks.com/">LispWorks 4.4.6</a></li> - <li><a href="http://sbcl.sourceforge.net/">SBCL 0.9.15 or later</a></li> + <li><a href="http://sbcl.sourceforge.net/">SBCL 0.9.15</a></li> </ul> The supported Windows versions are: Added: trunk/src/tests/uitoolkit/computer.png ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Tue Aug 22 18:38:07 2006 @@ -33,20 +33,20 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defvar *image-win* nil) -(defvar *happy-image* nil) -(defvar *bw-image* nil) -(defvar *true-image* nil) +(defvar *image-win* nil) +(defvar *happy-image* nil) +(defvar *bw-image* nil) +(defvar *comp-image* nil) +(defvar *folder-image* nil) +(defvar *true-image* nil) (defclass image-events (gfw:event-dispatcher) ()) (defun dispose-images () - (gfs:dispose *happy-image*) - (setf *happy-image* nil) - (gfs:dispose *bw-image*) - (setf *bw-image* nil) - (gfs:dispose *true-image*) - (setf *true-image* nil)) + (loop for var in '(*happy-image* *bw-image* *folder-image* *true-image* *comp-image*) + do (unless (null (symbol-value var)) + (gfs:dispose (symbol-value var)) + (setf (symbol-value var) nil)))) (defmethod gfw:event-close ((d image-events) window) (declare (ignore window)) @@ -55,36 +55,36 @@ (setf *image-win* nil) (gfw:shutdown 0)) +(defun draw-test-image (gc image origin pixel-pnt) + (gfg:draw-image gc image origin) + (incf (gfs:point-x origin) 36) + (gfg:with-image-transparency (image pixel-pnt) + (gfg:draw-image gc (gfg:transparency-mask image) origin) + (incf (gfs:point-x origin) 36) + (gfg:draw-image gc image origin))) + (defmethod gfw:event-paint ((d image-events) window gc rect) (declare (ignore window rect)) (let ((pnt (gfs:make-point)) (pixel-pnt1 (gfs:make-point)) - (pixel-pnt2 (gfs:make-point :x 0 :y 15))) - - (gfg:draw-image gc *happy-image* pnt) - (incf (gfs:point-x pnt) 36) - (gfg:with-image-transparency (*happy-image* pixel-pnt1) - (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) - (incf (gfs:point-x pnt) 36) - (gfg:draw-image gc *happy-image* pnt)) - + (pixel-pnt2 (gfs:make-point :x 15 :y 0)) + (pixel-pnt3 (gfs:make-point :x 31 :y 31))) + (declare (ignorable pixel-pnt3)) + (draw-test-image gc *happy-image* pnt pixel-pnt1) (setf (gfs:point-x pnt) 0) (incf (gfs:point-y pnt) 36) - (gfg:draw-image gc *bw-image* pnt) - (incf (gfs:point-x pnt) 24) - (gfg:with-image-transparency (*bw-image* pixel-pnt1) - (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) - (incf (gfs:point-x pnt) 24) - (gfg:draw-image gc *bw-image* pnt)) - + (draw-test-image gc *bw-image* pnt pixel-pnt1) (setf (gfs:point-x pnt) 0) - (incf (gfs:point-y pnt) 20) - (gfg:draw-image gc *true-image* pnt) - (incf (gfs:point-x pnt) 20) - (gfg:with-image-transparency (*true-image* pixel-pnt2) - (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) - (incf (gfs:point-x pnt) 20) - (gfg:draw-image gc *true-image* pnt)))) + (incf (gfs:point-y pnt) 36) + (draw-test-image gc *true-image* pnt pixel-pnt2) +#+load-imagemagick-plugin + (progn + (setf (gfs:point-x pnt) 112) + (setf (gfs:point-y pnt) 0) + (draw-test-image gc *folder-image* pnt pixel-pnt1) + (setf (gfs:point-x pnt) 112) + (incf (gfs:point-y pnt) 36) + (draw-test-image gc *comp-image* pnt pixel-pnt3)))) (defun exit-image-fn (disp item) (declare (ignorable disp item)) @@ -93,15 +93,24 @@ (setf *image-win* nil) (gfw:shutdown 0)) +(defun load-images () + (let ((*default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))) + (setf *happy-image* (make-instance 'gfg:image)) + (gfg::load *happy-image* "happy.bmp") + (setf *bw-image* (make-instance 'gfg:image)) + (gfg::load *bw-image* "blackwhite20x16.bmp") + (setf *true-image* (make-instance 'gfg:image)) + (gfg::load *true-image* "truecolor16x16.bmp") +#+load-imagemagick-plugin + (progn + (setf *folder-image* (make-instance 'gfg:image)) + (gfg::load *folder-image* "open-folder.gif") + (setf *comp-image* (make-instance 'gfg:image)) + (gfg::load *comp-image* "computer.png")))) + (defun image-tester-internal () - (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) + (load-images) (let ((menubar nil)) - (setf *happy-image* (make-instance 'gfg:image)) - (setf *bw-image* (make-instance 'gfg:image)) - (setf *true-image* (make-instance 'gfg:image)) - (gfg::load *happy-image* "happy.bmp") - (gfg::load *bw-image* "blackwhite20x16.bmp") - (gfg::load *true-image* "truecolor16x16.bmp") (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:workspace))) (setf (gfw:size *image-win*) (gfs:make-size :width 250 :height 200)) Added: trunk/src/tests/uitoolkit/open-folder.gif ============================================================================== Binary file. No diff available.

1 0

[graphic-forms-cvs] r232 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 22 Aug '06

22 Aug '06

Author: junrue Date: Tue Aug 22 17:37:23 2006 New Revision: 232 Modified: trunk/src/uitoolkit/widgets/layout.lisp Log: fixed layout manager regression Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Tue Aug 22 17:37:23 2006 @@ -65,10 +65,10 @@ (defun delete-layout-item (layout thing) "Removes thing from layout." - (delete thing (data-of layout) :key #'first)) + (setf (data-of layout) (remove thing (data-of layout) :key #'first))) (defun cleanup-disposed-items (layout) - (delete-if #'gfs:disposed-p (data-of layout) :key #'first)) + (setf (data-of layout) (remove-if #'gfs:disposed-p (data-of layout) :key #'first))) (defun arrange-hwnds (kid-specs flags-func) (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs))))

1 0

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

22 Aug '06

Author: junrue Date: Tue Aug 22 17:26:05 2006 New Revision: 231 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp Log: resolved more style warnings reported by SBCL Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Tue Aug 22 17:26:05 2006 @@ -1204,6 +1204,8 @@ @end deffn @deffn GenericFunction cancel-widget self +(setf (@strong{cancel-widget} @var{self}) @var{widget})@* + Returns the @ref{widget} that responds to the @sc{esc} key or otherwise acts to cancel the @ref{owner}. In a @ref{dialog}, this widget must be a @ref{button} and is typically labelled @emph{Cancel}. @@ -1285,6 +1287,8 @@ @end deffn @deffn GenericFunction default-widget self +(setf (@strong{default-widget} @var{self}) @var{widget})@* + Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil} if none has been set. If @sc{nil} is passed to the corresponding @sc{setf} function, then no default widget is set. The default widget @@ -1577,6 +1581,8 @@ @anchor{resizable-p} @deffn GenericFunction resizable-p self => boolean +(setf (@strong{resizable-p} @var{self}) @var{boolean})@* + Returns T if @code{self} can be resized by the user; @sc{nil} otherwise. The corresponding @sc{setf} function is implemented for the @ref{top-level} class (but only has meaning when the @code{:frame} @@ -1634,6 +1640,8 @@ @end deffn @deffn GenericFunction text self => string +(setf (@strong{text} @var{self}) @var{string})@* + For a @ref{window} or @ref{dialog}, this function returns @code{self}'s titlebar text (which may be blank). For other @ref{widget}s that have a text component, this function returns that text component. For anything else, Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Tue Aug 22 17:26:05 2006 @@ -210,6 +210,8 @@ ;;; methods ;;; +(defgeneric copy-pixels (self pixels-pointer)) + (defmethod depth ((self image-data)) (depth (data-plugin-of self))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Aug 22 17:26:05 2006 @@ -411,26 +411,24 @@ (w (get-widget tc hwnd)) (info-ptr (cffi:make-pointer lparam))) (if (typep w 'top-level) - (cffi:with-foreign-slots ((gfs::mintracksize gfs::maxtracksize) - info-ptr gfs::minmaxinfo) - (let ((max-size (maximum-size w)) - (min-size (minimum-size w))) - (if max-size - (cffi:with-foreign-slots ((gfs::x gfs::y) - (cffi:foreign-slot-pointer info-ptr - 'gfs::minmaxinfo - 'gfs::maxtracksize) - gfs::point) - (setf gfs::x (gfs:size-width max-size) - gfs::y (gfs:size-height max-size)))) - (if min-size - (cffi:with-foreign-slots ((gfs::x gfs::y) - (cffi:foreign-slot-pointer info-ptr - 'gfs::minmaxinfo - 'gfs::mintracksize) - gfs::point) - (setf gfs::x (gfs:size-width min-size) - gfs::y (gfs:size-height min-size)))))))) + (let ((max-size (maximum-size w)) + (min-size (minimum-size w))) + (if max-size + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:foreign-slot-pointer info-ptr + 'gfs::minmaxinfo + 'gfs::maxtracksize) + gfs::point) + (setf gfs::x (gfs:size-width max-size) + gfs::y (gfs:size-height max-size)))) + (if min-size + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:foreign-slot-pointer info-ptr + 'gfs::minmaxinfo + 'gfs::mintracksize) + gfs::point) + (setf gfs::x (gfs:size-width min-size) + gfs::y (gfs:size-height min-size))))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) @@ -479,10 +477,7 @@ ;;; (defmethod process-subclass-message (hwnd msg wparam lparam) - (let ((wndproc (get-class-wndproc hwnd))) - (if wndproc - (gfs::call-window-proc (cffi:make-pointer wndproc) hwnd msg wparam lparam) - (gfs::def-window-proc hwnd msg wparam lparam)))) + (gfs::call-window-proc (cffi:make-pointer (get-class-wndproc hwnd)) hwnd msg wparam lparam)) (defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Tue Aug 22 17:26:05 2006 @@ -137,28 +137,14 @@ (error 'gfs:toolkit-error :detail (format nil "invalid menu item option: ~a" opt))))) (when sep - (if (or checked disabled disp image sub) + (if (or callback checked disabled disp image sub) (error 'gfs:toolkit-error :detail "invalid separator options"))) - (when image - (if (or sep sub) - (error 'gfs:toolkit-error :detail "image cannot be set for separators or submenus")) - (if (null image) - (error 'gfs:toolkit-error :detail "missing image object"))) (when callback - (if sep - (error 'gfs:toolkit-error :detail "callbacks cannot be set for separators")) - (if (null callback) - (error 'gfs:toolkit-error :detail "missing callback argument")) (if sub (setf disp `(make-instance (define-dispatcher 'gfw:menu ,callback))) (setf disp `(make-instance (define-dispatcher 'gfw:menu-item ,callback))))) - (when disp - (if sep - (error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators")) - (if (null disp) - (error 'gfs:toolkit-error :detail "missing dispatcher argument"))) (when sub - (if (or checked image sep (not (listp sub))) + (if (or checked image (not (listp sub))) (error 'gfs:toolkit-error :detail "invalid option for submenu"))) (cond (sep (push `(define-separator ,generator-sym) code)) 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 22 17:26:05 2006 @@ -63,6 +63,12 @@ (defgeneric border-width (self) (:documentation "Returns the object's border width.")) +(defgeneric cancel-widget (self) + (:documentation "Returns the widget that will be activated when the ESC key is pressed.")) + +(defgeneric (setf cancel-widget) (widget self) + (:documentation "Sets the widget that will be activated when the ESC key is pressed.")) + (defgeneric caret (self) (:documentation "Returns the object's caret.")) @@ -118,7 +124,10 @@ (:documentation "Copies the current text selection to the clipboard and removes it from self.")) (defgeneric default-widget (self) - (:documentation "Returns the child widget or item that has the default emphasis.")) + (:documentation "Returns the widget or item that will be selected when self is active.")) + +(defgeneric (setf default-widget) (self widget) + (:documentation "Sets the widget or item that will be selected when self is active.")) (defgeneric delete-all (self) (:documentation "Removes all content from the object.")) @@ -241,7 +250,10 @@ (:documentation "Sets the largest dimensions to which the user may resize self.")) (defgeneric menu-bar (self) - (:documentation "Returns the menu object serving as the menubar for this object.")) + (:documentation "Returns the menu object serving as the menubar self.")) + +(defgeneric (setf menu-bar) (menu self) + (:documentation "Sets the menu object to serve as the menubar for self.")) (defgeneric minimum-size (self) (:documentation "Returns a size object describing the smallest supported dimensions of self.")) @@ -300,6 +312,9 @@ (defgeneric resizable-p (self) (:documentation "Returns T if the object is resizable; nil otherwise.")) +(defgeneric (setf resizable-p) (flag self) + (:documentation "Pass nil to disable user resizing of self, or non-nil to enable user resizing.")) + (defgeneric retrieve-span (self) (:documentation "Returns the span object indicating the range of values that are valid for the object.")) @@ -361,7 +376,10 @@ (:documentation "Return an integer representing the configured step size for the object.")) (defgeneric text (self) - (:documentation "Returns the object's text.")) + (:documentation "Returns self's text.")) + +(defgeneric (setf text) (text self) + (:documentation "Sets self's text.")) (defgeneric text-baseline (self) (:documentation "Returns the y coordinate of the object's text component, if any.")) Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Tue Aug 22 17:26:05 2006 @@ -39,9 +39,10 @@ (error 'gfs:disposed-error))) (defmethod delete-all ((self widget-with-items)) - (let ((count (length (items self)))) - (unless (zerop count) - (delete-item-span self (gfs:make-span :start 0 :end (1- count)))))) + (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) (declare (ignore index)) @@ -51,7 +52,7 @@ (defmethod delete-item ((self widget-with-items) index) (let* ((items (items self)) (it (elt items index))) - (delete it (items self) :test #'items-equal-p) + (setf (items self) (remove it items :test #'items-equal-p)) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it)))

1 0

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

22 Aug '06

Author: junrue Date: Tue Aug 22 02:42:16 2006 New Revision: 230 Added: trunk/docs/manual/image-plugins.texinfo trunk/docs/manual/terminology.texinfo Modified: trunk/docs/manual/glossary.texinfo trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/miscellaneous.texinfo Log: documented the image plugin mechanism Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Tue Aug 22 02:42:16 2006 @@ -10,7 +10,8 @@ @node Glossary @chapter Glossary -Terms and definitions. Content will be added in due time. +This chapter defines fundamental terms encountered throughout +the documentation of Graphic-Forms. @table @samp @@ -18,44 +19,65 @@ @anchor{accelerator} @cindex accelerator An accelerator is a key sequence assigned to an application function -that allows a user to bypass navigation of the menu or control +allowing a user to bypass navigation of the menu or control hierarchy normally required to invoke the function. Some accelerators are established by Windows style guidelines, such as @sc{control-c} for the clipboard copy operation from an Edit menu. Applications may define other accelerators as appropriate. Accelerators are generally intended for more knowledgeable users and should not be the sole -mechanism for invoking functionality. Compare with @ref{mnemonic}. +mechanism for invoking functionality. Compare with @ref{mnemonic}.@* @item auto-scrolling @cindex auto-scrolling Auto-scrolling is a feature whereby scrolling occurs as a side effect of user input so content can remain visible, thus avoiding the need to explicitly manipulate scrollbars to -achieve the same result. +achieve the same result.@* @item control @cindex control -A control is a system-defined window class that accepts user input -and/or generates notification events. +A control is a system-defined window class whose role is to +accept user input and possibly generate notification events +based on such input.@* @item dialog @cindex dialog A dialog is a mechanism for collecting user input or showing information. The system defines common dialogs for tasks like choosing files, fonts, or colors. Custom dialogs can be defined -by application code. +by application code.@* + +@item extension +@anchor{extension} +@cindex extension +An extension is code providing additional functionality beyond the +original scope of a system. An extension framework encourages +modularity. More importantly, it is a conscious design choice to allow +a system to be stretched beyond what the original designers may have +anticipated. Compare with @ref{plugin}.@* @item menu @cindex menu -A collection of menu items. +A collection of menu items presented within a single rectangular +region. Menus are often anchored to a menu bar, but may also be +invoked in a context-sensitive manner via the mouse or an +@ref{accelerator}.@* @item mnemonic @anchor{mnemonic} @cindex mnemonic A mnemonic is a key sequence (usually a single character modified by -the @sc{alt} key) that enables mouse-free navigation of a menu or +the @sc{alt} key) enabling mouse-free navigation of a menu or control hierarchy to invoke an application function. Depending on the user's system settings, mnemonic characters may be hidden until -the user presses the @sc{alt} key. Compare with @ref{accelerator}. +the user presses the @sc{alt} key. Compare with @ref{accelerator}.@* + +@item plugin +@anchor{plugin} +@cindex plugin +A plugin is code integrated into a larger system in order to implement +a specific instance of an established category of services. A plugin +framework encourages modularity within a defined scope of +functionality. Compare with @ref{extension}.@* @end table Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Tue Aug 22 02:42:16 2006 @@ -220,8 +220,9 @@ order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the proper transparency @ref{color}; or else by default, the pixel -color at @code{(0, 0)} in each image will be used. @emph{FIXME: -link to documentation of graphics plugins here}. +color at @code{(0, 0)} in each image will be used. See +@ref{Image data plugins} for more information on how image +files are loaded. @end deffn @deffn Initarg :images This initarg accepts a @sc{cl:list} of image objects. Since @@ -263,8 +264,8 @@ This subclass of @ref{native-object} wraps a Win32 bitmap handle. Instances may be drawn using @ref{draw-image} or displayed within certain @ref{control}s such as a @ref{label}. Images may originate -from a variety of formats. @emph{FIXME: link to documentation -of graphics plugins here}. +from a variety of formats -- see @ref{Image data plugins} for +more information on how file formats are loaded. @table @var @anchor{transparency-pixel} @item transparency-pixel @@ -288,8 +289,9 @@ may be loaded (via the @ref{load} method) and then converted to an @ref{image} object by the @ref{data-object} @sc{setf} function.@*@* @code{image-data} serves as an integration point between Graphic-Forms -and third-party graphics libraries such as ImageMagick. @emph{FIXME: -link to documentation of graphics plugins here}. +and third-party graphics libraries such as ImageMagick -- see +@ref{Image data plugins} for more information on supporting other +representations. @table @var @item data-plugin This slot holds a subclass of @ref{image-data-plugin} encapsulating @@ -302,9 +304,10 @@ @anchor{image-data-plugin} @deftp Class image-data-plugin This is a base class for plugin objects that encapsulate third-party -library representations of images. @emph{FIXME: -link to documentation of graphics plugins here}. It derives from -@ref{native-object}. +library representations of images. See @ref{Image data plugins} for +more information on the role of this class. + +This class derives from @ref{native-object}. @end deftp Added: trunk/docs/manual/image-plugins.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/image-plugins.texinfo Tue Aug 22 02:42:16 2006 @@ -0,0 +1,118 @@ + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@node Image data plugins +@section Image data plugins + +This section documents the image data plugin system. + + +@subsection Rationale + +An important feature of a user interface library is the display of +graphical images, which are aggregates of pixel data and color +information. The Windows @sc{gdi} provides adequate +support@footnote{Nowadays, the Windows platform offers alternatives, +such as @sc{gdi+} which adds among other features native support for +additional image formats. Graphic-Forms sticks with plain-old @sc{gdi} +to avoid the possibility of these alternatives not being installed.} +for the basic tasks of creating system objects populated with image +data, drawing on them, rendering them on the screen, and querying +their attributes. Central to the @sc{gdi} concept of an image is the +@emph{bitmap}. This format has a long history which becomes evident as +one learns about features designed at a time when memory and CPU +performance were markedly constrained compared to today's +machines. For our purposes, the @sc{gdi} bitmap serves as a normalized +representation of image data. Graphic-Forms encapsulates @sc{gdi} +bitmap functionality via the @ref{graphics-context} and @ref{image} +classes, plus related functions and macros. + +A traditional Windows application embeds bitmap data within its binary +executable (or @sc{dll}) via the Windows resource compiler. Such an +application then uses Win32 @sc{api} calls to access the resource +data and instantiate bitmap objects. Windows applications may also +choose to store image data in other locations, such as within files on +disk. Graphic-Forms relies on this latter arrangement instead of +the resource infrastructure.@footnote{As do GUI bindings in other +languages such as Java.} + +There are many image formats in use today. Whether images are stored +as @sc{gif}, @sc{jpeg}, @sc{png}, @sc{bmp}, or some other format, +there must be code to read the file data and convert it into a +@sc{gdi} bitmap format for use with drawing operations. This is the +problem solved by the image data plugin mechanism in Graphic-Forms. +It is solved in a manner insulating format-independent code in the +main library from format-specific details, and in a manner allowing +applications to provide their own code to do likewise. + + +@subsection Image file loading + +When an image file is to be loaded, such as when a @sc{pathname} is +supplied to the @code{:file} keyword for the @ref{image} or +@ref{icon-bundle} classes, the library traverses a list of file loader +functions bound to the @code{gfg::*image-plugins*} variable -- +@code{funcall}'ing each one in turn until one of them returns a +non-@sc{nil} list, or the members of @code{gfg::*image-plugins*} is +exhausted. In the latter case, a @ref{toolkit-error} is raised to +notify application code that no registered plugin supports the file. + +Under normal circumstances, the library will manage the list bound to +@code{gfg::*image-plugins*} behind the scenes. However, applications +requiring precise control over loader function calling order may +directly modify @code{gfg::*image-plugins*} @emph{but must take care +to do so properly}. Improper modifications, such as accidentally +assigning some other data structure, or adding the wrong kind of +object, will result in program errors. + + +@subsection Plugins bundled with the library + +Graphic-Forms includes two plugins in the distribution. + +The @emph{Default} plugin is available to applications unless the +@code{:skip-default-plugin} keyword symbol is pushed onto +@code{*features*} prior to loading the system. This plugin implements +support for the @sc{bmp} and @sc{ico} formats directly in Common Lisp, +thus imposing no additional external dependencies on applications. + +The @emph{ImageMagick} plugin is loaded when the +@code{:load-imagemagick-plugin} keyword symbol is pushed onto +@code{*features*} prior to loading the system. Thanks to the +ImageMagick library, this plugin supports most of the image formats +one might expect to need. However, it requires additional preparation +compared to the @emph{Default} plugin. Developers must download the +ImageMagick Q16 distribution and install it.@footnote{See the main +ImageMagick website at @url{http://imagemagick.org} for downloads and +documentation.} When delivering applications, the developer must +execute the ImageMagick installation process, or else replicate the +expected directory structure and registry entries. Also, bear in mind +that due to the rich functionality offered by ImageMagick, +applications will pull in additional @sc{dll}s and may have larger +memory requirements. + + +@subsection Implementing additional plugins + +@strong{FIXME:} @emph{add more info to this subsection once the plugin +system has matured a bit.} + +As described in the rationale, the role of an image data plugin is to +translate an external library representation of image data. In a +nutshell, this is accomplished by subclassing @ref{image-data-plugin} +and implementing certain generic functions. Third parties may +implement and register additional plugins in an identical fashion. + +As a convenience, the symbol @code{gfg::*image-file-types*} is bound +to an @sc{alist} where the first of each pair is a string naming a +file extension, and the second of each pair is a string supplying a +brief description of the format. Plugin developers may retrieve these +pairs to avoid duplication of the same information in their own code. + +Developers are welcome to inspect the source code of bundled plugins +(located under @code{src/uitoolkit/graphics/plugins} in the +distribution) for additional hints as to how these plugins may be +implemented. Modified: trunk/docs/manual/miscellaneous.texinfo ============================================================================== --- trunk/docs/manual/miscellaneous.texinfo (original) +++ trunk/docs/manual/miscellaneous.texinfo Tue Aug 22 02:42:16 2006 @@ -11,77 +11,9 @@ @chapter Miscellaneous Topics @menu -* terminology:: Some notes about terminology conventions. +* Image data plugins:: Documentation of the image data plugin system. +* Terminology conventions:: Some notes about terminology conventions. @end menu - -@node terminology -@section terminology - -This chapter documents terminology conventions observed in -Graphic-Forms. These conventions should be interpreted with the -traditional Common Lisp conventions in mind (some of which are -documented here: @url{http://www.cliki.net/Naming%20conventions}). - -@table @option - -@item accessor names -For clearer identification of accessors, Graphic-Forms -uses the suffix @samp{-of} whenever possible. - -@item @samp{check} versus @samp{select} -Admittedly, these two concepts are similar. They can be used as verbs -and they both describe a state of being (@samp{checked} and -@samp{selected}). Yet they need to remain separate due to the fact -that certain @ref{widget}s can exist in both states simultaneously, -like a tri-state @ref{button}, or a table or tree whose items are -checkboxes. The choice of which best describes an action or state -amounts to a judgement call. In Graphic-Forms, the author chooses to -use @samp{select} when a user gesture causes a widget to issue its -primary notification event, such as a menu item or button being -clicked. Hence, the verb @samp{select} aligns with the -@ref{event-select} function.@footnote{This topic gets muddier when -edit controls come into the picture. Text in an edit control is -selected despite there being no notification event; yet there is a -notification (event-modify) then the user types text. I'm choosing to -live with this inconsistency, partly because otherwise my -categorization scheme seems to work well; and one can refer to the act -of retrieving edit control selection, confident that developers will -know this means obtaining highlighted text.} And so the -@samp{selection} state is associated with highlighting of an -@ref{item}. Graphic-Forms uses @samp{check} to identify an operation -that flags or annotates a widget; the @samp{checked} state means being -annotated. - -@c @item @samp{clear} versus @samp{delete} -@c There is a distinction between @samp{clear} and @samp{delete} which -@c hinges on the difference between the primary content of a @ref{widget} -@c and secondary state information. An example of primary content is text -@c within an @ref{edit} @ref{control}. An example of secondary state -@c information (relevant to this topic at least) is the @ref{span} of -@c selected text in an edit control. With that in mind, Graphic-Forms -@c functions @samp{delete} content but @samp{clear} secondary state. This -@c choice aligns with the semantics of @sc{CL:delete}, including the -@c notion of that function being a destructive operation. - -@item function and method names -Functions and methods should be named using a verb to suggest -action. It may be tempting (especially for former Java programmers) to -use the Java getter/setter naming conventions for accessor-like -functions, but the author prefers @samp{obtain} rather than -@samp{get}, and he prefers @sc{setf}'able places which therefore can -have @sc{setf} functions defined for them. For status querying -functions, the author suggests @samp{available-p}, such as -@ref{undo-available-p}. - -@item macro names -Macros should be named consistent with established Common Lisp -practice, with an exception being allowed for convenience wrappers -around structure accessors (see for example -@ref{location}). Otherwise, the temptation to define an unorthodox -macro name is a symptom that maybe the code in question should not be -a macro in the first place. The rule of thumb is: if something can -be a function, then let it be a function; in general, think carefully -before creating a new macro. - -@end table +@include image-plugins.texinfo +@include terminology.texinfo Added: trunk/docs/manual/terminology.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/terminology.texinfo Tue Aug 22 02:42:16 2006 @@ -0,0 +1,73 @@ + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@node Terminology conventions +@section Terminology conventions + +This section documents terminology conventions observed in +Graphic-Forms. These conventions should be interpreted with the +traditional Common Lisp conventions in mind (some of which are +documented here: @url{http://www.cliki.net/Naming%20conventions}). + +@table @option + +@item accessor names +For clearer identification of accessors, Graphic-Forms +uses the suffix @samp{-of} whenever possible. + +@item @samp{check} versus @samp{select} +Admittedly, these two concepts are similar. They can be used as verbs +and they both describe a state of being (@samp{checked} and +@samp{selected}). Yet they need to remain separate due to the fact +that certain @ref{widget}s can exist in both states simultaneously, +like a tri-state @ref{button}, or a table or tree whose items are +checkboxes. The choice of which best describes an action or state +amounts to a judgement call. In Graphic-Forms, the author chooses to +use @samp{select} when a user gesture causes a widget to issue its +primary notification event, such as a menu item or button being +clicked. Hence, the verb @samp{select} aligns with the +@ref{event-select} function.@footnote{This topic gets muddier when +edit controls come into the picture. Text in an edit control is +selected despite there being no notification event; yet there is a +notification (event-modify) then the user types text. I'm choosing to +live with this inconsistency, partly because otherwise my +categorization scheme seems to work well; and one can refer to the act +of retrieving edit control selection, confident that developers will +know this means obtaining highlighted text.} And so the +@samp{selection} state is associated with highlighting of an +@ref{item}. Graphic-Forms uses @samp{check} to identify an operation +that flags or annotates a widget; the @samp{checked} state means being +annotated. + +@c @item @samp{clear} versus @samp{delete} +@c There is a distinction between @samp{clear} and @samp{delete} which +@c hinges on the difference between the primary content of a @ref{widget} +@c and secondary state information. An example of primary content is text +@c within an @ref{edit} @ref{control}. An example of secondary state +@c information (relevant to this topic at least) is the @ref{span} of +@c selected text in an edit control. With that in mind, Graphic-Forms +@c functions @samp{delete} content but @samp{clear} secondary state. This +@c choice aligns with the semantics of @sc{CL:delete}, including the +@c notion of that function being a destructive operation. + +@item function and method names +Functions and methods should be named using a verb to suggest +action. It may be tempting (especially for former Java programmers) to +use the Java getter/setter naming conventions for accessor-like +functions, but the author prefers @samp{obtain} rather than +@samp{get}, and he prefers @sc{setf}able places to Java-style +@samp{put} or @samp{set} functions. In the latter case, where a symbol +refers to both an accessor and a @sc{setf} function, the author +omits the @samp{obtain} prefix (like @ref{size}). For status querying +functions, the author suggests following the standard Common Lisp +convention of @samp{availablep} or @samp{some-test-p}. + +@item macro names +Macro names should be chosen in a manner consistent with established +Common Lisp practice. An exception is allowed for convenience wrappers +around structure accessors (see for example @ref{location}). + +@end table

1 0

[graphic-forms-cvs] r229 - in trunk/src: . uitoolkit/graphics uitoolkit/graphics/plugins/default uitoolkit/graphics/plugins/imagemagick
by junrue＠common-lisp.net 21 Aug '06

21 Aug '06

Author: junrue Date: Mon Aug 21 17:23:22 2006 New Revision: 229 Modified: trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: refactored graphics plugins slightly for common code Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Aug 21 17:23:22 2006 @@ -151,7 +151,7 @@ #:copy-color #:copy-font-data #:copy-font-metrics - #:data->image + #:copy-pixels #:data-object #:depth #:descent Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Aug 21 17:23:22 2006 @@ -39,9 +39,6 @@ (defgeneric (setf background-color) (color self) (:documentation "Sets the current background color.")) -(defgeneric data->image (self) - (:documentation "Plugins implement this to translate from a data structure to an HGDIOBJ.")) - (defgeneric data-object (self &optional gc) (:documentation "Returns the data structure representing the raw form of self.")) @@ -132,6 +129,9 @@ (defgeneric metrics (self font) (:documentation "Returns a font-metrics object describing key attributes of the specified font.")) +(defgeneric obtain-pixels (self pixels-pointer) + (:documentation "Plugins implement this to populate pixels-pointer with image pixel data.")) + (defgeneric size (self) (:documentation "Returns a size object describing the dimensions of self.")) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Mon Aug 21 17:23:22 2006 @@ -166,7 +166,7 @@ ((typep file 'pathname) (let ((data (load-image-data file))) (setf image-list (loop for entry in data - collect (make-instance 'gfg:image :handle (data->image entry)))))) + collect (make-instance 'gfg:image :handle (plugin->image entry)))))) ((listp images) (setf image-list images))) (when image-list Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Aug 21 17:23:22 2006 @@ -78,12 +78,47 @@ ;;; helper functions ;;; +(defun make-initial-bitmapinfo (plugin) + (let ((bi-ptr (cffi:foreign-alloc 'gfs::bitmapinfo))) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes gfs::bibitcount + gfs::bicompression gfs::bmicolors) + bi-ptr gfs::bitmapinfo) + (gfs::zero-mem bi-ptr gfs::bitmapinfo) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biplanes 1 + gfs::bibitcount (depth plugin) + gfs::bicompression gfs::+bi-rgb+) + (let ((im-size (size plugin))) + (setf gfs::biwidth (gfs:size-width im-size) + gfs::biheight (- (gfs:size-height im-size))))) + bi-ptr)) + (defun load-image-data (path) (loop for loader in *image-plugins* for data = (funcall loader path) until data finally (return data))) +(defun plugin->image (plugin) + (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) + (hbmp (cffi:null-pointer))) + (unwind-protect + (cffi:with-foreign-object (pix-bits-ptr :pointer) + (setf hbmp (gfs::create-dib-section screen-dc + plugin + gfs::+dib-rgb-colors+ + pix-bits-ptr + (cffi:null-pointer) + 0)) + (if (gfs:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-dib-section failed")) + (copy-pixels plugin (cffi:mem-ref pix-bits-ptr :pointer))) + (gfs::release-dc (cffi:null-pointer) screen-dc)) + hbmp)) + +(defun data->image (self) + (plugin->image (data-plugin-of self))) + (defun image->data (hbmp) (declare (ignore hbmp))) #| (defun image->data (hbmp) @@ -175,9 +210,6 @@ ;;; methods ;;; -(defmethod data->image ((self image-data)) - (data->image (data-plugin-of self))) - (defmethod depth ((self image-data)) (depth (data-plugin-of self))) @@ -208,7 +240,7 @@ (size (data-plugin-of self))) (defmethod (setf size) (size (self image-data)) - (setf (gfg:size (data-plugin-of self)) size)) + (setf (size (data-plugin-of self)) size)) (defmethod print-object ((self image-data) stream) (if (or (null (gfs:handle self)) (cffi:null-pointer-p (gfs:handle self))) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Mon Aug 21 17:23:22 2006 @@ -114,26 +114,6 @@ (push #'loader gfg::*image-plugins*) -(defmethod gfg:data->image ((self default-data-plugin)) - (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) - (hbmp (cffi:null-pointer))) - (unwind-protect - (cffi:with-foreign-object (pix-bits-ptr :pointer) - (setf hbmp (gfs::create-dib-section screen-dc - self - gfs::+dib-rgb-colors+ - pix-bits-ptr - (cffi:null-pointer) - 0)) - (if (gfs:null-handle-p hbmp) - (error 'gfs:win32-error :detail "create-dib-section failed")) - (let ((plugin-pixels (pixels-of self)) - (ptr (cffi:mem-ref pix-bits-ptr :pointer))) - (dotimes (i (length plugin-pixels)) - (setf (cffi:mem-aref ptr :uint8 i) (aref plugin-pixels i))))) - (gfs::release-dc (cffi:null-pointer) screen-dc)) - hbmp)) - (defmethod gfg:depth ((self default-data-plugin)) (let ((info (gfs:handle self))) (unless info @@ -143,59 +123,42 @@ (defmethod gfs:dispose ((self default-data-plugin)) (setf (slot-value self 'gfs:handle) nil)) -(defmethod cffi:free-translated-object (pixels-ptr (name (eql 'gfs::bitmap-pixels-pointer)) param) - (declare (ignore param)) - (cffi:foreign-free pixels-ptr)) - (defmethod cffi:free-translated-object (bi-ptr (name (eql 'gfs::bitmap-info-pointer)) param) (declare (ignore param)) (cffi:foreign-free bi-ptr)) +(defmethod gfg:copy-pixels ((self default-data-plugin) pixels-pointer) + (let ((plugin-pixels (pixels-of self))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref pixels-pointer :uint8 i) (aref plugin-pixels i)))) + pixels-pointer) + (defmethod gfg:size ((self default-data-plugin)) (let ((info (gfs:handle self))) (unless info (error 'gfs:disposed-error)) - (gfs:make-size :width (biWidth info) :height (biHeight info)))) + (gfs:make-size :width (biWidth info) :height (- (biHeight info))))) (defmethod (setf gfg:size) (size (self default-data-plugin)) (let ((info (gfs:handle self))) (unless info (error 'gfs:disposed-error)) (setf (biWidth info) (gfs:size-width size) - (biHeight info) (gfs:size-height size))) + (biHeight info) (- (gfs:size-height size)))) size) (defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) - (name (eql 'gfs::bitmap-pixels-pointer))) - (let* ((plugin-pixels (pixels-of lisp-obj)) - (pixels-ptr (cffi:foreign-alloc :uint8 :count (length plugin-pixels)))) - (dotimes (i (length plugin-pixels)) - (setf (cffi:mem-aref pixels-ptr :uint8 i) (aref plugin-pixels i))) - pixels-ptr)) - -(defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) (name (eql 'gfs::bitmapinfo-pointer))) - (let ((bi-ptr (cffi:foreign-alloc 'gfs::bitmapinfo))) - (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes gfs::bibitcount - gfs::bicompression gfs::bmicolors) - bi-ptr gfs::bitmapinfo) - (gfs::zero-mem bi-ptr gfs::bitmapinfo) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biplanes 1 - gfs::bibitcount (gfg:depth lisp-obj) - gfs::bicompression gfs::+bi-rgb+) - (let ((im-size (gfg:size lisp-obj))) - (setf gfs::biwidth (gfs:size-width im-size) - gfs::biheight (gfs:size-height im-size))) - (let ((colors (gfg:color-table (palette-of lisp-obj))) - (ptr (cffi:foreign-slot-pointer bi-ptr 'gfs::bitmapinfo 'gfs::bmicolors))) - (dotimes (i (length colors)) - (let ((clr (aref colors i))) - (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen - gfs::rgbred gfs::rgbreserved) - (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) - (setf gfs::rgbblue (gfg:color-blue clr) - gfs::rgbgreen (gfg:color-green clr) - gfs::rgbred (gfg:color-red clr) - gfs::rgbreserved 0)))))) + (let ((bi-ptr (gfg::make-initial-bitmapinfo lisp-obj)) + (colors (gfg:color-table (palette-of lisp-obj)))) + (let ((ptr (cffi:foreign-slot-pointer bi-ptr 'gfs::bitmapinfo 'gfs::bmicolors))) + (dotimes (i (length colors)) + (let ((clr (aref colors i))) + (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen + gfs::rgbred gfs::rgbreserved) + (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbreserved 0 + gfs::rgbblue (gfg:color-blue clr) + gfs::rgbgreen (gfg:color-green clr) + gfs::rgbred (gfg:color-red clr)))))) bi-ptr)) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Mon Aug 21 17:23:22 2006 @@ -136,6 +136,11 @@ (width :unsigned-long) (height :unsigned-long)) +(defcfun + ("GetIndexes" get-indexes) + :pointer ;; IndexPacket* + (image :pointer)) ;; Image* + (defun scale-quantum-to-byte (quant) (floor quant 257)) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp Mon Aug 21 17:23:22 2006 @@ -63,6 +63,8 @@ (defctype quantum :unsigned-short) +(defctype index-packet quantum) + (defcenum boolean-type (:false 0) (:true 1)) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Mon Aug 21 17:23:22 2006 @@ -54,73 +54,16 @@ (push #'loader gfg::*image-plugins*) -(defmethod gfg:data->image ((self magick-data-plugin)) - (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) - (cffi:with-foreign-slots ((gfs::bisize - gfs::biwidth - gfs::biheight - gfs::biplanes - gfs::bibitcount - gfs::bicompression - gfs::bisizeimage - gfs::bixpels - gfs::biypels - gfs::biclrused - gfs::biclrimp - gfs::bmicolors) - bi-ptr gfs::bitmapinfo) - (let* ((handle (gfs:handle self)) - (sz (gfg:size self)) - (pix-count (* (gfs:size-width sz) (gfs:size-height sz))) - (hbmp (cffi:null-pointer)) - (screen-dc (gfs::get-dc (cffi:null-pointer)))) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biwidth (gfs:size-width sz) - gfs::biheight (- 0 (gfs:size-height sz)) - gfs::biplanes 1 - gfs::bibitcount 32 ;; 32bpp even if original image file is not - gfs::bicompression gfs::+bi-rgb+ - gfs::bisizeimage 0 - gfs::bixpels 0 - gfs::biypels 0 - gfs::biclrused 0 - gfs::biclrimp 0) - - ;; create the bitmap - ;; - (cffi:with-foreign-object (pix-bits-ptr :pointer) - (setf hbmp (gfs::create-dib-section screen-dc - bi-ptr - gfs::+dib-rgb-colors+ - pix-bits-ptr - (cffi:null-pointer) - 0)) - (if (gfs:null-handle-p hbmp) - (error 'gfs:win32-error :detail "create-dib-section failed")) - - ;; update the RGBQUADs - ;; - (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz))) - (ptr (cffi:mem-ref pix-bits-ptr :pointer))) - (dotimes (i pix-count) - (cffi:with-foreign-slots ((blue green red reserved) - (cffi:mem-aref tmp 'pixel-packet i) - pixel-packet) - (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved) - (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) - (setf gfs::rgbreserved 0) - (setf gfs::rgbred (scale-quantum-to-byte red)) - (setf gfs::rgbgreen (scale-quantum-to-byte green)) - (setf gfs::rgbblue (scale-quantum-to-byte blue))))))) - (unless (gfs:null-handle-p screen-dc) - (gfs::release-dc (cffi:null-pointer) screen-dc)) - hbmp)))) - (defmethod gfg:depth ((self magick-data-plugin)) + ;; FIXME: further debugging of non-true-color format required throughout + ;; this plugin, reverting back to assumption of 32bpp for now. +#| (let ((handle (gfs:handle self))) (if (null handle) (error 'gfs:disposed-error)) (cffi:foreign-slot-value handle 'magick-image 'depth))) +|# + 32) (defmethod gfs:dispose ((self magick-data-plugin)) (let ((victim (gfs:handle self))) @@ -128,6 +71,22 @@ (destroy-image victim))) (setf (slot-value self 'gfs:handle) nil)) +(defmethod gfg:copy-pixels ((self magick-data-plugin) pixels-pointer) + (let* ((handle (gfs:handle self)) + (im-size (gfg:size self)) + (pixel-count (* (gfs:size-width im-size) (gfs:size-height im-size))) + (pix-tmp (get-image-pixels handle 0 0 (gfs:size-width im-size) (gfs:size-height im-size)))) + (dotimes (i pixel-count) + (cffi:with-foreign-slots ((blue green red reserved) + (cffi:mem-aref pix-tmp 'pixel-packet i) pixel-packet) + (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved) + (cffi:mem-aref pixels-pointer 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbreserved 0 + gfs::rgbred (scale-quantum-to-byte red) + gfs::rgbgreen (scale-quantum-to-byte green) + gfs::rgbblue (scale-quantum-to-byte blue)))))) + pixels-pointer) + (defmethod gfg:size ((self magick-data-plugin)) (let ((handle (gfs:handle self)) (size (gfs:make-size))) @@ -161,3 +120,9 @@ (destroy-image handle)) (destroy-exception-info ex))) size) + +(defmethod cffi:translate-to-foreign ((lisp-obj magick-data-plugin) + (name (eql 'gfs::bitmapinfo-pointer))) + ;; FIXME: assume true-color for now + ;; + (gfg::make-initial-bitmapinfo lisp-obj))

1 0

[graphic-forms-cvs] r228 - in trunk: . src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 21 Aug '06

21 Aug '06

Author: junrue Date: Mon Aug 21 12:51:48 2006 New Revision: 228 Modified: trunk/NEWS.txt trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: reviewed and fixed macro definitions Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Aug 21 12:51:48 2006 @@ -32,20 +32,22 @@ argument to every function (for which the vast majority of methods had no use). -. Provided a new generic function called event-session so applications - can participate in the WM_QUERYENDSESSION / WM_ENDSESSION protocol. +. Defined the following new generic functions: -. Provided event-activate and event-deactivate generic functions so - applications can respond to window activation state changes. + * event-session GF so applications can participate in the + WM_QUERYENDSESSION / WM_ENDSESSION protocol. -. Defined generic functions for querying undo and redo state. Implemented - corresponding methods for edit controls. + * event-activate and event-deactivate GFs so applications can respond + to window activation state changes. -. Defined generic functions for configuring auto-scrolling and scrollbar - visibility. Implemented corresponding methods for edit controls. + * GFs for querying undo and redo state. Implemented corresponding + methods for edit controls. -. Defined generic functions representing text clipboard data convenience - functionality. Implemented corresponding methods for edit controls. + * GFs for configuring auto-scrolling and scrollbar visibility. Implemented + corresponding methods for edit controls. + + * GFs representing text clipboard data convenience functionality. + Implemented corresponding methods for edit controls. . Made other miscellaneous improvements to flesh out edit control support. Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Mon Aug 21 12:51:48 2006 @@ -35,19 +35,21 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro color->rgb (color) - (let ((result (gensym))) - `(let ((,result 0)) - (setf (ldb (byte 8 0) ,result) (color-red ,color)) - (setf (ldb (byte 8 8) ,result) (color-green ,color)) - (setf (ldb (byte 8 16) ,result) (color-blue ,color)) + (let ((tmp-color (gensym)) + (result (gensym))) + `(let ((,tmp-color ,color) + (,result 0)) + (setf (ldb (byte 8 0) ,result) (color-red ,tmp-color)) + (setf (ldb (byte 8 8) ,result) (color-green ,tmp-color)) + (setf (ldb (byte 8 16) ,result) (color-blue ,tmp-color)) ,result))) (defmacro rgb->color (colorref) - (let ((color (gensym))) - `(let ((,color (make-color :red (ldb (byte 8 0) ,colorref) - :green (ldb (byte 8 8) ,colorref) - :blue (ldb (byte 8 16) ,colorref)))) - ,color)))) + (let ((tmp-colorref (gensym))) + `(let ((,tmp-colorref ,colorref)) + (make-color :red (ldb (byte 8 0) ,tmp-colorref) + :green (ldb (byte 8 8) ,tmp-colorref) + :blue (ldb (byte 8 16) ,tmp-colorref)))))) (defvar *color-black* (make-color :red 0 :green 0 :blue 0)) (defvar *color-blue* (make-color :red 0 :green 0 :blue #xFF)) @@ -57,4 +59,4 @@ (defmethod print-object ((obj color) stream) (print-unreadable-object (obj stream :type t) - (format stream "~a,~a,~a" (color-red obj) (color-green obj) (color-blue obj)))) + (format stream "(~a,~a,~a)" (color-red obj) (color-green obj) (color-blue obj)))) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Aug 21 12:51:48 2006 @@ -62,8 +62,10 @@ `(gfg::font-metrics-leading ,metrics)) (defmacro height (metrics) - `(+ (gfg::font-metrics-ascent ,metrics) - (gfg::font-metrics-descent ,metrics))) + (let ((tmp-metrics (gensym))) + `(let ((,tmp-metrics ,metrics)) + (+ (gfg::font-metrics-ascent ,tmp-metrics) + (gfg::font-metrics-descent ,tmp-metrics))))) (defmacro average-char-width (metrics) `(gfg::font-metrics-avg-char-width ,metrics)) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Aug 21 12:51:48 2006 @@ -38,13 +38,15 @@ ;;; (defmacro with-image-transparency ((image pnt) &body body) - (let ((orig-pnt (gensym))) - `(let ((,orig-pnt (transparency-pixel-of ,image))) + (let ((tmp-image (gensym)) + (orig-pnt (gensym))) + `(let* ((,tmp-image ,image) + (,orig-pnt (transparency-pixel-of ,tmp-image))) (unwind-protect (progn - (setf (transparency-pixel-of ,image) ,pnt) + (setf (transparency-pixel-of ,tmp-image) ,pnt) ,@body) - (setf (transparency-pixel-of ,image) ,orig-pnt))))) + (setf (transparency-pixel-of ,tmp-image) ,orig-pnt))))) (defun clone-bitmap (horig) (let ((hclone (cffi:null-pointer)) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Aug 21 12:51:48 2006 @@ -50,9 +50,10 @@ `(loop for ,i from 0 below (foreign-type-size (quote ,type)) do (setf (mem-aref ,object :char ,i) 0)))) -#+lispworks (defun native-object-special-action (obj) - (if (typep obj 'gfs:native-object) - (gfs:dispose obj))) +#+lispworks +(defun native-object-special-action (obj) + (if (typep obj 'gfs:native-object) + (gfs:dispose obj))) ;;; ;;; convenience macros Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Aug 21 12:51:48 2006 @@ -37,29 +37,33 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-graphics-context ((gc &optional thing) &body body) - `(let ((,gc (cond - ((null ,thing) - (make-instance 'gfg:graphics-context)) ; DC compatible with display - ((typep ,thing 'gfw:widget) - (make-instance 'gfg:graphics-context :widget ,thing)) - ((typep ,thing 'gfg:image) - (make-instance 'gfg:graphics-context :image ,thing)) - (t - (error 'gfs:toolkit-error - :detail (format nil "~a is an unsupported type" ,thing)))))) - (unwind-protect - (progn - ,@body) - (gfs:dispose ,gc)))) + (let ((tmp-thing (gensym))) + `(let* ((,tmp-thing ,thing) + (,gc (cond + ((null ,tmp-thing) + (make-instance 'gfg:graphics-context)) ; DC compatible with display + ((typep ,tmp-thing 'gfw:widget) + (make-instance 'gfg:graphics-context :widget ,tmp-thing)) + ((typep ,tmp-thing 'gfg:image) + (make-instance 'gfg:graphics-context :image ,tmp-thing)) + (t + (error 'gfs:toolkit-error + :detail (format nil "~a is an unsupported type" ,tmp-thing)))))) + (unwind-protect + (progn + ,@body) + (gfs:dispose ,gc))))) (defmacro with-drawing-disabled ((widget) &body body) - `(unwind-protect - (progn - (unless (gfs:disposed-p ,widget) - (error 'gfs:disposed-error)) - (gfs::lock-window-update (gfs:handle ,widget)) - ,@body) - (gfs::lock-window-update (cffi:null-pointer))))) + (let ((tmp-widget (gensym))) + `(let ((,tmp-widget ,widget)) + (unwind-protect + (progn + (unless (gfs:disposed-p ,tmp-widget) + (error 'gfs:disposed-error)) + (gfs::lock-window-update (gfs:handle ,tmp-widget)) + ,@body) + (gfs::lock-window-update (cffi:null-pointer))))))) (defun translate-and-dispatch (msg-ptr) (gfs::translate-message msg-ptr)

1 0

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

21 Aug '06

Author: junrue Date: Mon Aug 21 02:49:15 2006 New Revision: 227 Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/overview.texinfo trunk/docs/website/index.html Log: doc updates in preparation for the 0.5.0 release Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Aug 21 02:49:15 2006 @@ -1,15 +1,90 @@ +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. + +Here is what's new in this release: + +. SBCL is now supported (version 0.9.15 tested). Graphic-Forms includes + a small patch provided to the SBCL community by Alastair Bridgewater + to enable the stdcall calling convention for alien callbacks. Please + see src/external-libraries/sbcl-callback-patch + +. Implemented a plugin mechanism for integrating graphics libraries. This + means that ImageMagick is now optional -- if your application can get + by with just BMP and ICO formats, then the default plugin (which has no + external dependencies) may be used. This feature also allows applications + to integrate other graphics libraries of their choice. + +. In addition to ImageMagick now being optional, external library + dependencies have been further simplified. Several small libraries + are now directly bundled with the Graphic-Forms. Cells is no longer + used in the library proper nor in the demos (but may return at a + later point). + +. Implemented a class called icon-bundle which may be populated with + multiple images and then used to set icon data for window frames. + This includes the concept of there being 'large' and 'small' icon + sizes. + +. Simplified the argument lists for the event-*** generic functions. + Provided gfw:obtain-event-time as a substitute for passing a time + argument to every function (for which the vast majority of methods + had no use). + +. Provided a new generic function called event-session so applications + can participate in the WM_QUERYENDSESSION / WM_ENDSESSION protocol. + +. Provided event-activate and event-deactivate generic functions so + applications can respond to window activation state changes. + +. Defined generic functions for querying undo and redo state. Implemented + corresponding methods for edit controls. + +. Defined generic functions for configuring auto-scrolling and scrollbar + visibility. Implemented corresponding methods for edit controls. + +. Defined generic functions representing text clipboard data convenience + functionality. Implemented corresponding methods for edit controls. -. SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch - to enable the stdcall calling convention for alien callbacks, located - in src/external-libraries/sbcl-callback-patch. +. Made other miscellaneous improvements to flesh out edit control + support. -. Implemented a plugin mechanism for integrating graphics libraries. +. Implemented the standard color chooser dialog and associated + convenience macro 'with-color-dialog'. -. Implemented the standard color chooser dialog. +. Added the macro 'with-graphics-context' as a convenience for code that + needs to instantiate a context outside of event-paint. -. Simplified external library dependencies, getting rid of some and - bundling small libraries into the Graphic-Forms distribution. +. Heavily revised internal layout manager code in preparation for + supporting more sophisticated layouts. A new class called layout-managed + has been created to serve as a mix-in when defining objects (not + necessarily only windows) that have children to be sized and positioned. + +. Implemented a new demo program called textedit which is essentially + a Notepad clone. Its purpose is to show off the multi-line edit + control and the standard Find/Replace dialog. + +. Upgraded to the latest lisp-unit and changed test loading code so that + unit-tests are no longer compiled. + +. Wrote more documentation and reorganized existing content a bit. + Added discussion of certain naming convention choices. + +. Made a variety of bug fixes. + +The README.txt file in the release zip file also has additional important +information about this release. + +Download the release zip file here: +http://prdownloads.sourceforge.net/graphic-forms/graphic-forms-0.5.0.zip?download + +The project website is: +http://common-lisp.net/project/graphic-forms/ + +Jack Unrue +jdunrue (at) gmail (dot) com +25 August 2006 ============================================================================== Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Aug 21 02:49:15 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.5.0 +Graphic-Forms README for version 0.5.0 (25 August 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -10,7 +10,8 @@ Dependencies ------------ -Graphic-Forms depends on the following packages: +Graphic-Forms requires the following libraries which must be downloaded +separately: - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ @@ -19,14 +20,13 @@ - CFFI (cffi-060606 or later) http://common-lisp.net/project/cffi/ - - lw-compat + - Closer to MOP http://common-lisp.net/project/closer/downloads.html - - Closer to MOP + - lw-compat http://common-lisp.net/project/closer/downloads.html -The following libraries are bundled with Graphic-Forms, thus do not need -to be downloaded separately: +The following libraries are bundled with Graphic-Forms: - Practical Common Lisp Chapter08 and Chapter24 http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz @@ -43,8 +43,8 @@ Supported Common Lisp Implementations ------------------------------------- -Graphic-Forms currently supports CLISP 2.38, LispWorks 4.4.6, and SBCL 0.9.15 -(the latter with a small patch). +Graphic-Forms currently supports CLISP 2.38 or higher, LispWorks 4.4.6, +and SBCL 0.9.15 (the latter with a small patch). Known Problems @@ -58,103 +58,102 @@ http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1… - may result in intermittent GPFs when windows with layout managers are - resized. - -2. Image loading currently requires installation of the ImageMagick - library as described in the next section. I have tested with Windows - BMP files (and this is what the image-tester application displays). - ImageMagick itself supports many image formats, but Graphic-Forms - has not been tested with all of them. Therefore, images may not - display properly, expecially when a transparency is selected. - -3. The src/demos/unblocked directory contains a start at a demo - program in the form of a simple game where one clicks on block - shapes to score points, and the rest of the blocks fall down to - fill in the gaps. This demo program is not yet finished, but the - source code can still serve as sample code. - -4. The text-extent generic function currently does not return - the correct text height. As a workaround, get the text metrics - for the desired font and base height calculations on that - value. The text-extent function does return the correct width. - + may result in a GPF if a window's layout manager is changed. Compared + to prior releases of Graphic-Forms, there is much less chance of this + problem affecting layout management. + +2. Please be advised that SBCL is itself still in the early stages of + supporting Windows, and as a consequence, you may experience problems + such as 'GC invariant lost' errors that result in a crash to LDB. + +3. The gfg:text-extent method currently does not return the correct text + height value. As a workaround, get the text metrics for the font and + compute height from that. The gfg:text-extent function does return + the correct width. How To Configure and Build -------------------------- -NOTE: in a future release, this project will be packaged for use -with asdf-install. +NOTE: in a future release, this project will be packaged for delivery +via asdf-install. -1. Install ImageMagick 6.2.6.5-Q16 (note in particular that it is the Q16 - version that is needed, not the Q8 version). The default installation - directory is "c:/Program Files/ImageMagick-6.2.6-Q16/". +1. [OPTIONAL] Install ImageMagick 6.2.6.5-Q16 (note in particular that it + is the Q16 version that is needed, not the Q8 version). The default + installation directory is "c:/Program Files/ImageMagick-6.2.6-Q16/". 2. Extract the Graphic-Forms distribution archive somewhere on your machine (or check out the source from Subversion). 3. Change to the Graphic-Forms top-level directory. -4. Load ASDF into your Lisp image if it is not already present. +4. Load ASDF into your Lisp image if it is not already present. Note that + SBCL bundles ASDF, so in this case you just need to (require 'asdf) -5. Execute the following forms from your REPL - - (load "config.lisp") +5. Execute the following forms at your REPL ;; - ;; If ImageMagick is not installed in the default location, execute: + ;; If you need the ImageMagick plugin, execute: + + (push :load-imagemagick-plugin *features*) + (setf cl-user::*magick-library-directory* "c:/path/to/ImageMagick/") + + ;; ... the latter being necessary only if ImageMagick is not installed + ;; in the default location. + ;; - (setf cl-user::*magick-library-directory* "c:/path/to/your/ImageMagick/install/") + ;; Next, execute: - ;; setf these variables as needed for your specific environment to + (load "config.lisp") + + ;; + ;; Set these variables as needed for your specific environment to ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* ;; gfsys::*lw-compat-dir* - ;; - ;; Set the following var only if you want to run the unit-tests. - ;; Its value is the path to the lisp-unit.lisp source file minus - ;; the file extension. - ;; - ;; gfsys::*lisp-unit-file* + ;; ;; Execute the following form to populate asdf:*central-registry* ;; Note that it will skip any systems whose location variables were ;; set to nil in the previous step. - ;; + (gfsys::configure-asdf) - ;; Now load the graphic-forms system and its dependencies. ;; + ;; Now load the graphic-forms system and its dependencies. + (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit) 6. You may optionally compile the reference manual. GNU Make and - makeinfo are prerequisites. Assuming you already have those - components installed, the reference manual can be built by - opening a command prompt and cd'ing to the `docs\manual' + makeinfo (version 4.8) are prerequisites. Assuming you already + have those components installed, the reference manual can be + built by opening a command prompt and cd'ing to the `docs\manual' subdirectory, then typing `make'. The output will be - produced within a subdirectory called `reference'. + deposited in a subdirectory called `reference'. 7. Proceed to the next section to run the tests, or start coding! -How To Run Tests And Samples ----------------------------- +How To Run Tests And Demos +-------------------------- 1. Load the graphic-forms-uitoolkit system as described in the previous section. 2. Execute the following forms from your REPL: - (load (compile-file gfsys::*lisp-unit-file*)) + ;; + ;; configure ASDF for the test programs and then load it - (asdf:operate 'asdf:load-op :graphic-forms-tests) + (load "tests.lisp") + (gfsys::load-tests) - ;; execute demos and test programs ;; + ;; execute demos and test programs + (gft:unblocked) (gft:textedit) @@ -169,14 +168,15 @@ (gft:windlg) - ;; execute the unit-tests ;; + ;; execute the unit-tests + (in-package :gft) (run-tests) -Support and Feedback --------------------- +Feedback and Bug Reports +------------------------ Please provide feedback via the following channels: Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Mon Aug 21 02:49:15 2006 @@ -14,19 +14,18 @@ focusing on the Windows platform. Graphic-Forms is licensed under the terms of the BSD License. -The goal is to provide a Lisp-based toolkit for developing GUI -applications on Windows. Platform-specific features are encapsulated -by a thin abstraction layer that presents a more Lisp-friendly -interface for programmers. The library can be extended by using the -Lisp bindings for system APIs, rather than requiring knowledge of -some other programming language. +The goal is to provide a Common Lisp-based toolkit for developing GUI +applications on Windows. GUI features are encapsulated by a thin +abstraction layer offering a Lisp-friendly interface. The library can +be extended via Common Lisp bindings for system APIs, avoiding a +prerequisite for coding ability in a non-Lisp programming language. Why implement another UI toolkit? Applications that need portability -across windowing systems are already served by projects such as McCLIM -or LTK or wxCL in the open-source world, or the toolkits provided by -commercial vendors. The audience served by Graphic-Forms consists of +across windowing systems are served today by projects such as +LTK or wxCL in the open-source world, or the toolkits provided by +commercial vendors. The target audience of Graphic-Forms consists of GUI developers focused on the Windows platform who want to leverage -platform features without compromises due to portability. +platform-specific features. Long-term goals for this project may include implementing an application framework on top of the toolkit, or a rapid UI development language, or Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Mon Aug 21 02:49:15 2006 @@ -30,46 +30,47 @@ terms of the <a href="http://home.earthlink.net/~jdunrue/license.html">BSD License</a>. - The goal is to provide a Lisp-based toolkit for developing GUI - applications on Windows. Platform-specific features are encapsulated - by a thin abstraction layer that presents a more Lisp-friendly interface - for programmers. The library can be extended by using the Lisp - bindings for system APIs, rather than requiring knowledge of some other - programming language. - Why implement another UI toolkit? Applications that need portability - across windowing systems are already served by projects such as - <a href="http://common-lisp.net/project/mcclim/">McCLIM</a> - or + The goal is to provide a <a href="http://www.lisp.org">Common Lisp</a>-based + toolkit for developing GUI applications on Windows. GUI features + are encapsulated by a thin abstraction layer offering a Lisp-friendly + interface. The library can be extended via + <a href="http://www.lisp.org">Common Lisp</a> bindings for system APIs, + avoiding a prerequisite for coding ability in a non-Lisp programming + language. + Why implement another UI toolkit? Applications requiring portability + across windowing systems are served today by projects such as <a href="http://www.peter-herth.de/ltk/">LTK</a> or <a href="http://www.wxcl-project.org">wxCL</a> in the open-source world, or the toolkits provided by commercial - vendors. The audience served by Graphic-Forms consists of GUI + vendors. The target audience of Graphic-Forms consists of GUI developers focused on the Windows platform who want to leverage - platform features without compromises due to portability. + platform-specific features. Long-term goals for this project may include implementing an application framework on top of the toolkit, or a rapid UI development language, or a UI design tool, or some combination thereof. <h3>Status</h3> - The current release is - <a href="http://sourceforge.net/project/showfiles.php?group_id=163034">version 0.4.0</a>. - This library is in the alpha stage of development, which means that new - features are still being added and existing features require considerable - testing. Brave souls who experiment with the code should expect significant - API and behavior changes for at least several more releases. + The current version is + <a href="http://prdownloads.sourceforge.net/graphic-forms/graphic-forms-0.5.0.zip?do…"> + 0.5.0</a>, released on 25 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 + significant API and behavior changes for at least several more releases. The supported Lisp implementations are: <ul> - <li><a href="http://clisp.cons.org/">CLISP 2.38</a></li> + <li><a href="http://clisp.cons.org/">CLISP 2.38 or later</a></li> <li><a href="http://www.lispworks.com/">LispWorks 4.4.6</a></li> + <li><a href="http://sbcl.sourceforge.net/">SBCL 0.9.15 or later</a></li> </ul> The supported Windows versions are: <ul> <li>XP SP2</li> - <li>Vista (in progress, testing on Beta 2 currently underway)</li> + <li>Vista (testing on Beta 2 currently underway)</li> </ul> <h3 id="mailinglists">Mailing Lists</h3>

1 0

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

20 Aug '06

Author: junrue Date: Mon Aug 21 00:36:51 2006 New Revision: 226 Modified: trunk/NEWS.txt trunk/README.txt trunk/build.lisp trunk/config.lisp trunk/docs/manual/overview.texinfo trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp Log: completed removal of Cells usage, updated dependency documentation Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Aug 21 00:36:51 2006 @@ -1,11 +1,16 @@ . SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch -to enable the stdcall calling convention for alien callbacks, located -in src/external-libraries/sbcl-callback-patch + to enable the stdcall calling convention for alien callbacks, located + in src/external-libraries/sbcl-callback-patch. + +. Implemented a plugin mechanism for integrating graphics libraries. . Implemented the standard color chooser dialog. +. Simplified external library dependencies, getting rid of some and + bundling small libraries into the Graphic-Forms distribution. + ============================================================================== Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Aug 21 00:36:51 2006 @@ -16,9 +16,6 @@ http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ *note: ASDF is bundled with SBCL* - - Cells (latest from CVS) - http://www.common-lisp.net/project/cells/ - - CFFI (cffi-060606 or later) http://common-lisp.net/project/cffi/ @@ -114,7 +111,6 @@ ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; - ;; gfsys::*cells-dir* ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* ;; gfsys::*lw-compat-dir* Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Mon Aug 21 00:36:51 2006 @@ -44,7 +44,6 @@ (defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) (defvar *project-root* "c:/projects/public/") -(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) (setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/")) (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Mon Aug 21 00:36:51 2006 @@ -39,7 +39,6 @@ (in-package #:graphic-forms-system) -(defvar *cells-dir* "cells/") (defvar *cffi-dir* "cffi-060606/") (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") @@ -54,7 +53,6 @@ (defun configure-asdf () (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) - (pushnew *cells-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) Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Mon Aug 21 00:36:51 2006 @@ -70,14 +70,13 @@ @section Dependencies -The libraries that Graphic-Forms relies upon are: +@strong{Libraries required by Graphic-Forms to be downloaded +separately:} @table @code @item ASDF -@url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf} - -@item Cells (latest from CVS) -@url{http://www.common-lisp.net/project/cells/} +@url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf}@* +@emph{Note that ASDF is bundled with SBCL.} @item CFFI @url{http://common-lisp.net/project/cffi} @@ -85,21 +84,39 @@ @item Closer to MOP @url{http://common-lisp.net/project/closer/downloads.html} -@item ImageMagick -@url{http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows-dll.exe} +@item lw-compat +@url{http://common-lisp.net/project/closer/downloads.html} +@end table + +@strong{Required libraries bundled with Graphic-Forms:} + +@table @code + +@item Practical Common Lisp Chapter08 and Chapter24 +@url{http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz} @item lisp-unit @url{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html} -@item lw-compat -@url{http://common-lisp.net/project/closer/downloads.html} +@end table + +@strong{Optional libraries that can be used with Graphic-Forms:} + +@table @code + +@item ImageMagick +@url{http://imagemagick.org/script/binary-releases.php#windows}@* +@emph{Install the Q16 version and push the symbol +:load-imagemagick-plugin onto *features* before executing ASDF.} + @end table @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 ASDF system and run tests. +distribution for instructions on how to load the test program +ASDF system and run unit-tests, test programs, and demo programs. @section Support Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Aug 21 00:36:51 2006 @@ -55,7 +55,6 @@ :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" - :depends-on ("cells") :components ((:module "src" :components Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Aug 21 00:36:51 2006 @@ -117,7 +117,10 @@ (shape-pnts (shape-pnts-of self))) (when (and (eql button :left-button) shape-pnts) (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) - (game-shape-data shape-pnts) + (progn + (update-game-tiles shape-pnts) + (update-panel (get-scoreboard-panel)) + (update-panel (get-tiles-panel))) (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) (setf (shape-kind-of self) 0) (setf (shape-pnts-of self) nil)) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Mon Aug 21 00:36:51 2006 @@ -48,66 +48,53 @@ until (> entry score) finally (return level))) -(defun revise-tiles (active-tiles orig-tiles shape-data) - (if shape-data - (loop with tmp = (clone-tiles active-tiles) - for pnt in shape-data do (set-tile tmp pnt 0) - finally (return (collapse-tiles tmp))) - orig-tiles)) - -(cells:defmodel unblocked-game-model () - ((level - :accessor level - :initform (cells:c? (lookup-level-reached (^score)))) - (score - :accessor score - :initform (cells:c? (+ (or cells:.cache 0) - (* 5 (length (^shape-data)))))) +(defun compute-new-game-tiles () + (collapse-tiles (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+)))) + +(defclass unblocked-game-model () + ((score + :accessor score-of + :initform 0) (shape-data - :accessor shape-data - :initform (cells:c-in nil)) + :accessor shape-data-of + :initform nil) (original-tiles - :accessor original-tiles - :initarg :original-tiles - :initform (cells:c-in (collapse-tiles (init-tiles +horz-tile-count+ - +vert-tile-count+ - (1- +max-tile-kinds+))))) + :accessor original-tiles-of + :initform nil) (active-tiles - :accessor active-tiles - :initform (cells:c? (revise-tiles cells:.cache (^original-tiles) (^shape-data)))))) + :accessor active-tiles-of + :initform nil))) (defvar *game* (make-instance 'unblocked-game-model)) (defun new-game () - (cells:cells-reset) - (setf *game* (make-instance 'unblocked-game-model))) + (let ((tiles (compute-new-game-tiles))) + (setf (score-of *game*) 0 + (original-tiles-of *game*) tiles + (active-tiles-of *game*) tiles))) (defun restart-game () - (let ((saved-tiles (original-tiles *game*))) - (cells:cells-reset) - (setf *game* (make-instance 'unblocked-game-model :original-tiles saved-tiles)))) + (setf (score-of *game*) 0 + (active-tiles-of *game*) (original-tiles-of *game*))) (defun game-tiles () - (active-tiles *game*)) + (active-tiles-of *game*)) -(defun game-shape-data (pnts) - (setf (shape-data *game*) pnts)) +(defun update-game-tiles (shape-data) + (setf (active-tiles-of *game*) + (if shape-data + (progn + (incf (score-of *game*) (* 5 (length shape-data))) + (loop with tmp = (clone-tiles (active-tiles-of *game*)) + for pnt in shape-data do (set-tile tmp pnt 0) + finally (return (collapse-tiles tmp)))) + (original-tiles-of *game*)))) (defun game-level () - (level *game*)) + (lookup-level-reached (score-of *game*))) (defun game-points-needed () - (- (nth (1- (level *game*)) *points-needed-table*) (score *game*))) + (- (nth (1- (game-level)) *points-needed-table*) (score-of *game*))) (defun game-score () - (score *game*)) - -(defun update-panel (panel) - (update-buffer (gfw:dispatcher panel)) - (gfw:redraw panel)) - -(cells:defobserver score ((self unblocked-game-model)) - (update-panel (get-scoreboard-panel))) - -(cells:defobserver active-tiles ((self unblocked-game-model)) - (update-panel (get-tiles-panel))) + (score-of *game*)) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Aug 21 00:36:51 2006 @@ -65,6 +65,10 @@ (kind (shape-kind shape))) (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) +(defun update-panel (panel) + (update-buffer (gfw:dispatcher panel)) + (gfw:redraw panel)) + (defun reveal-unblocked (disp item) (declare (ignore disp item)) (let ((shape (find-shape (game-tiles) #'accept-shape-p))) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Mon Aug 21 00:36:51 2006 @@ -124,7 +124,7 @@ (title-buffer (cffi:null-pointer)) (dir-buffer (cffi:null-pointer)) (ext-buffer (cffi:null-pointer)) - (file-buffer (cffi:foreign-alloc :char :count 1024 :initial-element #\Null))) ; see FIXME above + (file-buffer (cffi:foreign-alloc :char :count 1024 :initial-element 0))) ; see FIXME above (if text (setf title-buffer (collect-foreign-strings (list text)))) (if initial-directory

1 0

[graphic-forms-cvs] r225 - in trunk: . src/demos src/demos/textedit src/demos/unblocked src/uitoolkit/widgets
by junrue＠common-lisp.net 20 Aug '06

20 Aug '06

Author: junrue Date: Sun Aug 20 23:03:53 2006 New Revision: 225 Added: trunk/src/demos/demo-utils.lisp trunk/src/demos/textedit/textedit.ico (contents, props changed) trunk/src/demos/unblocked/unblocked.ico (contents, props changed) Modified: trunk/graphic-forms-tests.asd trunk/src/demos/textedit/textedit-document.lisp trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp Log: fixed bug in extract-foreign-strings function; removal of Cells usage from textedit demo; implemented shared about dialog for demo programs Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 20 23:03:53 2006 @@ -61,13 +61,16 @@ :components ((:module "demos" :components - ((:module "textedit" + ((:file "demo-utils") + (:module "textedit" :serial t + :depends-on ("demo-utils") :components ((:file "textedit-document") (:file "textedit-window"))) (:module "unblocked" :serial t + :depends-on ("demo-utils") :components ((:file "tiles") (:file "unblocked-model") Added: trunk/src/demos/demo-utils.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/demo-utils.lisp Sun Aug 20 23:03:53 2006 @@ -0,0 +1,96 @@ +;;;; +;;;; demo-utils.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.tests) + +(defclass demo-about-dialog-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp demo-about-dialog-events) (dlg gfw:dialog)) + (call-next-method) + (gfs:dispose dlg)) + +(defun about-demo (owner image-path title desc) + (let* ((image (make-instance 'gfg:image :file image-path)) + (dlg (make-instance 'gfw:dialog :owner owner + :dispatcher (make-instance 'demo-about-dialog-events) + :layout (make-instance 'gfw:flow-layout + :margins 8 + :spacing 8) + :style '(:owner-modal) + :text title)) + (label (make-instance 'gfw:label :parent dlg)) + (text-panel (make-instance 'gfw:panel + :layout (make-instance 'gfw:flow-layout + :margins 0 + :spacing 2 + :style '(:vertical)) + :parent dlg)) + (line1 (make-instance 'gfw:label + :parent text-panel + :text desc)) + (line2 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (line3 (make-instance 'gfw:label + :parent text-panel + :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) + (line4 (make-instance 'gfw:label + :parent text-panel + :text "All Rights Reserved.")) + (line5 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (line6 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (btn-panel (make-instance 'gfw:panel + :parent dlg + :layout (make-instance 'gfw:flow-layout + :margins 0 + :spacing 0 + :style '(:vertical :normalize)))) + (close-btn (make-instance 'gfw:button + :callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfs:dispose dlg)) + :style '(:cancel-button) + :text "Close" + :parent btn-panel))) + (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) + (unwind-protect + (gfg:with-image-transparency (image (gfs:make-point)) + (setf (gfw:image label) image)) + (gfs:dispose image)) + (gfw:pack dlg) + (gfw:center-on-owner dlg) + (gfw:show dlg t))) Modified: trunk/src/demos/textedit/textedit-document.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-document.lisp (original) +++ trunk/src/demos/textedit/textedit-document.lisp Sun Aug 20 23:03:53 2006 @@ -33,18 +33,13 @@ (in-package :graphic-forms.uitoolkit.tests) -(cells:defmodel textedit-document () - ((content-replaced - :cell :ephemeral - :accessor content-replaced - :initform (cells:c-in nil)) - (content-modified - :cell :ephemeral - :accessor content-modified - :initform (cells:c-in nil)) +(defclass textedit-document () + ((content-modified + :accessor content-modified-of + :initform nil) (file-path - :accessor file-path - :initform (cells:c-in nil)))) + :accessor file-path-of + :initform nil))) (defvar *textedit-model* (make-instance 'textedit-document)) @@ -57,7 +52,7 @@ (if (zerop (length line)) (setf buffer (concatenate 'string buffer (format nil "~c~c" #\Return #\Newline))) (setf buffer (concatenate 'string buffer (format nil "~a~c~c" line #\Return #\Newline)))))) - (setf (content-replaced *textedit-model*) buffer))) + buffer)) (defun save-textedit-doc (path buffer) (with-open-file (output path :direction :output :if-exists :supersede) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Aug 20 23:03:53 2006 @@ -39,16 +39,21 @@ (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*"))) +(defvar *textedit-new-title* "new file - TextEdit") + + (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) 2) (gfw:text-modified-p *textedit-control*)) + (gfw:enable (elt (gfw:items menu) 3) (> (length (gfw:text *textedit-control*)) 0))) (defun textedit-file-new (disp item) (declare (ignore disp item)) (when *textedit-control* (setf (gfw:text *textedit-control*) "") (setf (gfw:text-modified-p *textedit-control*) nil) - (setf (file-path *textedit-model*) nil))) + (setf (file-path-of *textedit-model*) nil) + (setf (gfw:text *textedit-win*) *textedit-new-title*))) (defun textedit-file-open (disp item) (declare (ignore disp item)) @@ -57,14 +62,16 @@ paths :filters *textedit-file-filters*) (when paths - (load-textedit-doc (first paths)) - (setf (file-path *textedit-model*) (namestring (first paths)))))) + (setf (gfw:text *textedit-control*) (load-textedit-doc (first paths))) + (setf (file-path-of *textedit-model*) (namestring (first paths))) + (setf (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths)))))) (defun textedit-file-save (disp item) - (if (file-path *textedit-model*) - (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*)) + (if (file-path-of *textedit-model*) + (save-textedit-doc (file-path-of *textedit-model*) (gfw:text *textedit-control*)) (textedit-file-save-as disp item)) - (setf (gfw:text-modified-p *textedit-control*) nil)) + (if (file-path-of *textedit-model*) + (setf (gfw:text-modified-p *textedit-control*) nil))) (defun textedit-file-save-as (disp item) (declare (ignore disp item)) @@ -75,8 +82,9 @@ :text "Save As") (when paths (save-textedit-doc (first paths) (gfw:text *textedit-control*)) - (setf (file-path *textedit-model*) (namestring (first paths))) - (setf (gfw:text-modified-p *textedit-control*) nil)))) + (setf (file-path-of *textedit-model*) (namestring (first paths)) + (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths)) + (gfw:text-modified-p *textedit-control*) nil)))) (defun textedit-file-quit (disp item) (declare (ignore disp item)) @@ -143,80 +151,11 @@ (declare (ignore window)) (textedit-file-quit disp nil)) -(defclass textedit-about-dialog-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog)) - (call-next-method) - (gfs:dispose dlg)) - (defun about-textedit (disp item) (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) - (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) - (dlg (make-instance 'gfw:dialog :owner *textedit-win* - :dispatcher (make-instance 'textedit-about-dialog-events) - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 8) - :style '(:owner-modal) - :text (concatenate 'string "About TextEdit"))) - (label (make-instance 'gfw:label :parent dlg)) - (text-panel (make-instance 'gfw:panel - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 2 - :style '(:vertical)) - :parent dlg)) - (line1 (make-instance 'gfw:label - :parent text-panel - :text "TextEdit version 0.5")) - (line2 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line3 (make-instance 'gfw:label - :parent text-panel - :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) - (line4 (make-instance 'gfw:label - :parent text-panel - :text "All Rights Reserved.")) - (line5 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line6 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (btn-panel (make-instance 'gfw:panel - :parent dlg - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 0 - :style '(:vertical :normalize)))) - (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfs:dispose dlg)) - :style '(:cancel-button) - :text "Close" - :parent btn-panel))) - (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) - (unwind-protect - (gfg:with-image-transparency (image (gfs:make-point)) - (setf (gfw:image label) image)) - (gfs:dispose image)) - (gfw:pack dlg) - (gfw:center-on-owner dlg) - (gfw:show dlg t))) - -(cells:defobserver content-replaced ((self textedit-document)) - (if *textedit-control* - (setf (gfw:text *textedit-control*) (content-replaced self)))) - -(cells:defobserver content-modified ((self textedit-document))) - -(cells:defobserver file-path ((self textedit-document)) - (if *textedit-win* - (setf (gfw:text *textedit-win*) (format nil "~a - GraphicForms TextEdit" (file-path self))) - (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit"))) + (image-path (merge-pathnames "about.bmp"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.5"))) (defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu @@ -252,9 +191,11 @@ :auto-vscroll :vertical-scrollbar :want-return))) - (setf (gfw:menu-bar *textedit-win*) menubar) - (setf (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500)) - (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit") + (setf (gfw:menu-bar *textedit-win*) menubar + (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500) + (gfw:text *textedit-win*) *textedit-new-title*) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*))) + (setf (gfw:image *textedit-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "textedit.ico")))) (gfw:show *textedit-win* t))) (defun textedit () Added: trunk/src/demos/textedit/textedit.ico ============================================================================== Binary file. No diff available. Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Aug 20 23:03:53 2006 @@ -94,79 +94,21 @@ (declare (ignore timer)) (update-panel *tiles-panel*)) -(defclass unblocked-about-dialog-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog)) - (call-next-method) - (gfs:dispose dlg)) - (defun about-unblocked (disp item) (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) - (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) - (dlg (make-instance 'gfw:dialog :owner *unblocked-win* - :dispatcher (make-instance 'unblocked-about-dialog-events) - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 8) - :style '(:owner-modal) - :text (concatenate 'string "About UnBlocked"))) - (label (make-instance 'gfw:label :parent dlg)) - (text-panel (make-instance 'gfw:panel - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 2 - :style '(:vertical)) - :parent dlg)) - (line1 (make-instance 'gfw:label - :parent text-panel - :text "UnBlocked version 0.5")) - (line2 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line3 (make-instance 'gfw:label - :parent text-panel - :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) - (line4 (make-instance 'gfw:label - :parent text-panel - :text "All Rights Reserved.")) - (line5 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line6 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (btn-panel (make-instance 'gfw:panel - :parent dlg - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 0 - :style '(:vertical :normalize)))) - (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfs:dispose dlg)) - :style '(:cancel-button) - :text "Close" - :parent btn-panel))) - (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) - (unwind-protect - (gfg:with-image-transparency (image (gfs:make-point)) - (setf (gfw:image label) image)) - (gfs:dispose image)) - (gfw:pack dlg) - (gfw:center-on-owner dlg) - (gfw:show dlg t))) + (image-path (merge-pathnames "about.bmp"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.5"))) (defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File" - :submenu ((:item "&New" :callback #'new-unblocked) - (:item "&Restart" :callback #'restart-unblocked) - (:item "Reveal &Move" :callback #'reveal-unblocked) - (:item "" :separator) - (:item "E&xit" :callback #'quit-unblocked))) + :submenu ((:item "&New" :callback #'new-unblocked) + (:item "&Restart" :callback #'restart-unblocked) + (:item "Reveal &Move" :callback #'reveal-unblocked) + (:item "" :separator) + (:item "E&xit" :callback #'quit-unblocked))) (:item "&Help" - :submenu ((:item "&About" :callback #'about-unblocked)))))) + :submenu ((:item "&About UnBlocked" :callback #'about-unblocked)))))) (scoreboard-buffer-size (compute-scoreboard-size)) (tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+) 2) @@ -189,14 +131,16 @@ :style '(:border) :dispatcher (make-instance 'tiles-panel-events :buffer-size tile-buffer-size))) - (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") + (setf (gfw:text *unblocked-win*) "UnBlocked") (setf (gfw:resizable-p *unblocked-win*) nil) (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) - (setf (gfw:minimum-size *unblocked-win*) size) - (setf (gfw:maximum-size *unblocked-win*) size)) + (setf (gfw:minimum-size *unblocked-win*) size + (gfw:maximum-size *unblocked-win*) size)) (new-unblocked nil nil) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) + (setf (gfw:image *unblocked-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) (gfw:show *unblocked-win* t))) (defun unblocked () Added: trunk/src/demos/unblocked/unblocked.ico ============================================================================== Binary file. No diff available. Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sun Aug 20 23:03:53 2006 @@ -124,7 +124,7 @@ (title-buffer (cffi:null-pointer)) (dir-buffer (cffi:null-pointer)) (ext-buffer (cffi:null-pointer)) - (file-buffer (cffi:foreign-alloc :char :count 1024))) ; see FIXME above + (file-buffer (cffi:foreign-alloc :char :count 1024 :initial-element #\Null))) ; see FIXME above (if text (setf title-buffer (collect-foreign-strings (list text)))) (if initial-directory

1 0

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

19 Aug '06

Author: junrue Date: Sat Aug 19 22:13:35 2006 New Revision: 224 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: cleaned up some SBCL style warnings Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 19 22:13:35 2006 @@ -317,19 +317,23 @@ this time. @anchor{background-color} -@deffn GenericFunction background-color self +@deffn GenericFunction background-color self => @ref{color} +(setf (@strong{background-color} @var{self}) @var{color})@*@* Returns a color object corresponding to the current background color. +The corresponding @sc{setf} function allows the background color to +be set. @end deffn @anchor{data-object} @deffn GenericFunction data-object self &optional gc => object +(setf (@strong{data-object} @var{self}) @var{object})@*@* Returns the data structure representing the raw data form of the object. The @code{gc} argument must be supplied when calling this -function on a @ref{font}, and the value must be a -@ref{graphics-context}. +function on a @ref{font}, and the value must be a @ref{graphics-context}. +The corresponding @sc{setf} function updates this representation. @end deffn -@deffn GenericFunction depth self +@deffn GenericFunction depth self => integer Returns the bits-per-pixel depth of the object. @end deffn @@ -521,13 +525,18 @@ @end table @end deffn -@deffn GenericFunction font self -Returns the current font. +@deffn GenericFunction font self => @ref{font} +(setf (@strong{font} @var{self}) @var{font})@*@* +Returns the current font. The corresponding @sc{setf} function +allows the font to be set. @end deffn @anchor{foreground-color} -@deffn GenericFunction foreground-color self +@deffn GenericFunction foreground-color self => @ref{color} +(setf (@strong{foreground-color} @var{self}) @var{color})@*@* Returns a color object corresponding to the current foreground color. +The corresponding @sc{setf} function allows the foreground color +to be set. @end deffn @anchor{icon-bundle-length} @@ -603,7 +612,10 @@ @end defun @deffn GenericFunction size self => @ref{size} +(setf (@strong{size} @var{self}) @var{size})@*@* Returns a size object describing the dimensions of @var{self}. +The corresponding @sc{setf} function allows the size to be +set. @end deffn @deffn GenericFunction text-extent self text &optional style tab-width @@ -632,5 +644,6 @@ @defmac with-image-transparency (image point) &body body This macro wraps @var{body} in an @sc{unwind-protect} form with @var{point} set as the @ref{transparency-pixel} for @var{image}. -Any existing point set in @var{image} is restored. +The original point set in @var{image}, if any, is restored after +@var{body} completes. @end defmac Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 22:13:35 2006 @@ -1395,9 +1395,7 @@ @end deffn @deffn GenericFunction image self => @ref{image} - -(setf (@strong{image} @var{self}) @var{image})@* - +(setf (@strong{image} @var{self}) @var{image})@*@* Returns the image currently associated with @var{self}. The @sc{setf} function changes the image. If @var{self} is a @ref{window}, then this function returns an @ref{icon-bundle}. And in that case, the @sc{setf} function accepts either @@ -1419,6 +1417,7 @@ @end deffn @deffn GenericFunction location self => @ref{point} +(setf (@strong{location} @var{self}) @var{point})@*@* Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system. @xref{parent}. @@ -1433,6 +1432,7 @@ @anchor{maximum-size} @deffn GenericFunction maximum-size self => size +(setf (@strong{maximum-size} @var{self}) @var{size})@*@* Returns a @ref{size} object describing the largest dimensions to which the user may resize this widget. By default, @ref{window}s and @ref{control}s return @sc{nil} indicating that there is effectively no @@ -1442,12 +1442,14 @@ is resized to the new maximum. @xref{minimum-size}. @end deffn -@deffn GenericFunction menu-bar self +@deffn GenericFunction menu-bar self => @ref{menu} +(setf (@strong{menu-bar} @var{self}) @var{menu})@*@* Returns the menu object serving as the menubar for this object. @end deffn @anchor{minimum-size} @deffn GenericFunction minimum-size self => size +(setf (@strong{minimum-size} @var{self}) @var{size})@*@* Returns a @ref{size} object describing the smallest dimensions to which the user may resize this widget. By default, @ref{window} objects return @sc{nil} indicating that the minimum constraint is @@ -1625,7 +1627,8 @@ necessarily top-most in the display z-order. @end deffn -@deffn GenericFunction size self +@deffn GenericFunction size self => @ref{size} +(setf (@strong{size} @var{self}) @var{size})@*@* Returns a size object describing the size of the object in its parent's coordinate system. @end deffn @@ -1659,7 +1662,8 @@ @end deffn @anchor{text-modified-p} -@deffn GenericFunction text-modified-p self +@deffn GenericFunction text-modified-p self => boolean +(setf (@strong{text-modified-p} @var{self}) @var{boolean})@*@* Returns T if the text component of @code{self} has been modified by the user; @sc{nil} otherwise. The corresponding @sc{setf} function updates the dirty state flag. This function is not implemented for all Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sat Aug 19 22:13:35 2006 @@ -78,12 +78,14 @@ ((:file "graphics-constants") (:file "graphics-classes") (:file "graphics-generics") - (:file "color") - (:file "palette") + (:file "color" + :depends-on ("graphics-classes")) + (:file "palette" + :depends-on ("graphics-classes")) (:file "image-data" :depends-on ("graphics-classes")) (:file "image" - :depends-on ("graphics-classes")) + :depends-on ("graphics-classes" "graphics-generics")) (:file "icon-bundle" :depends-on ("graphics-constants" "image")) (:file "font-data") Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sat Aug 19 22:13:35 2006 @@ -36,11 +36,17 @@ (defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) +(defgeneric (setf background-color) (color self) + (:documentation "Sets the current background color.")) + (defgeneric data->image (self) (:documentation "Plugins implement this to translate from a data structure to an HGDIOBJ.")) (defgeneric data-object (self &optional gc) - (:documentation "Returns the data structure representing the raw form of the object.")) + (:documentation "Returns the data structure representing the raw form of self.")) + +(defgeneric (setf data-object) (data self) + (:documentation "Sets a data structure representing the raw form of self.")) (defgeneric depth (self) (:documentation "Returns the bits-per-pixel depth of the object.")) @@ -111,9 +117,15 @@ (defgeneric font (self) (:documentation "Returns the current font.")) +(defgeneric (setf font) (font self) + (:documentation "Sets the current font.")) + (defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) +(defgeneric (setf foreground-color) (color self) + (:documentation "Sets the current foreground color.")) + (defgeneric load (self path) (:documentation "Loads the object from filesystem data identified by the specified pathname or string.")) @@ -121,7 +133,10 @@ (:documentation "Returns a font-metrics object describing key attributes of the specified font.")) (defgeneric size (self) - (:documentation "Returns a size object describing the size of the object.")) + (:documentation "Returns a size object describing the dimensions of self.")) + +(defgeneric (setf size) (size self) + (:documentation "Sets the dimensions of self.")) (defgeneric text-extent (self str &optional style tab-width) (:documentation "Returns the size of the rectangular area that would be covered by the string if drawn in the current font.")) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sat Aug 19 22:13:35 2006 @@ -117,7 +117,6 @@ font)) (defmethod (setf gfg:font) :before (font (self control)) - (declare (ignore color)) (if (or (gfs:disposed-p self) (gfs:disposed-p font)) (error 'gfs:disposed-error))) @@ -161,19 +160,24 @@ (let ((class (define-dispatcher (class-name (class-of self)) callback))) (setf (dispatcher self) (make-instance (class-name class)))))) -(defmethod (setf maximum-size) :after (max-size (self control)) +(defmethod maximum-size ((self control)) + (max-size-of self)) + +(defmethod (setf maximum-size) (max-size (self control)) (unless (gfs:disposed-p self) + (setf (max-size-of self) max-size) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size)))) -(defmethod minimum-size :after ((self control)) - (let ((size (slot-value self 'minimum-size))) +(defmethod minimum-size ((self control)) + (let ((size (min-size-of self))) (if (null size) (preferred-size self -1 -1) size))) -(defmethod (setf minimum-size) :after (min-size (self control)) +(defmethod (setf minimum-size) (min-size (self control)) (unless (gfs:disposed-p self) + (setf (min-size-of self) min-size) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size)))) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Sat Aug 19 22:13:35 2006 @@ -42,6 +42,5 @@ (error 'gfs:toolkit-error :detail "null owner handle"))) (defmethod checked-p :before ((self item)) - (declare (ignore flag)) (if (gfs:null-handle-p (gfs:handle self)) (error 'gfs:toolkit-error :detail "null owner handle"))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat Aug 19 22:13:35 2006 @@ -95,6 +95,28 @@ (gfs::destroy-window hwnd))))) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) +(defgeneric init-utility-hwnd (self)) +(defgeneric call-child-visitor-func (self parent child)) +(defgeneric call-display-visitor-func (self hmonitor data)) +(defgeneric call-top-level-visitor-func (self window)) +(defgeneric get-widget (self hwnd)) +(defgeneric put-widget (self widget)) +(defgeneric delete-widget (self hwnd)) +(defgeneric widget-in-progress (self)) +(defgeneric (setf widget-in-progress) (widget self)) +(defgeneric clear-widget-in-progress (self)) +(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-timer (self id)) +(defgeneric put-timer (self timer)) +(defgeneric delete-timer (self timer)) +(defgeneric increment-widget-id (self)) + (defmethod init-utility-hwnd ((tc thread-context)) (register-toplevel-noerasebkgnd-window-class) (let ((hwnd (create-window "GraphicFormsTopLevelNoEraseBkgnd" ; can't use constant here Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Aug 19 22:13:35 2006 @@ -115,12 +115,12 @@ (pixel-point :accessor pixel-point-of :initform nil) - (maximum-size - :accessor maximum-size + (max-size + :accessor max-size-of :initarg :maximum-size :initform nil) - (minimum-size - :accessor minimum-size + (min-size + :accessor min-size-of :initarg :minimum-size :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) @@ -169,12 +169,12 @@ (:documentation "The menu class represents a container for menu items (and submenus).")) (defclass window (widget layout-managed) - ((maximum-size - :accessor maximum-size + ((max-size + :accessor max-size-of :initarg :maximum-size :initform nil) - (minimum-size - :accessor minimum-size + (min-size + :accessor min-size-of :initarg :minimum-size :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Aug 19 22:13:35 2006 @@ -193,7 +193,10 @@ (:documentation "Returns T if the object is in its iconified state.")) (defgeneric image (self) - (:documentation "Returns the object's image object if it has one, or nil otherwise.")) + (:documentation "Returns self's image object if it has one, or nil otherwise.")) + +(defgeneric (setf image) (image self) + (:documentation "Sets self's image object.")) (defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) @@ -211,7 +214,10 @@ (:documentation "Returns T if the object's lines are visible; nil otherwise.")) (defgeneric location (self) - (:documentation "Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system.")) + (:documentation "Returns a point object describing the coordinates of the top-left corner of self in its parent's coordinate system.")) + +(defgeneric (setf location) (point self) + (:documentation "Sets a point describing the coordinates of self in its parent's coordinate system.")) (defgeneric lock (self flag) (:documentation "Prevents or enables modification of the object's contents.")) @@ -229,13 +235,19 @@ (:documentation "Returns T if the object is in its maximized state (not necessarily the same as the maximum size); nil otherwise.")) (defgeneric maximum-size (self) - (:documentation "Returns a size object describing the largest dimensions to which the user may resize the widget.")) + (:documentation "Returns a size object describing the largest dimensions to which the user may resize self.")) + +(defgeneric (setf maximum-size) (size self) + (:documentation "Sets the largest dimensions to which the user may resize self.")) (defgeneric menu-bar (self) (:documentation "Returns the menu object serving as the menubar for this object.")) (defgeneric minimum-size (self) - (:documentation "Returns a size object describing the smallest size this object can exist.")) + (:documentation "Returns a size object describing the smallest supported dimensions of self.")) + +(defgeneric (setf minimum-size) (size self) + (:documentation "Sets the smallest supported dimensions of self.")) (defgeneric mouse-over-image (self) (:documentation "Returns the image displayed when the mouse is hovering over this object.")) @@ -340,7 +352,10 @@ (:documentation "This object's items are scrolled until the selection is visible.")) (defgeneric size (self) - (:documentation "Returns a size object describing the size of the object in its parent's coordinate system.")) + (:documentation "Returns the size of self in its parent's coordinate system.")) + +(defgeneric (setf size) (size self) + (:documentation "Sets the size of self in its parent's coordinate system.")) (defgeneric step-increment (self) (:documentation "Return an integer representing the configured step size for the object.")) @@ -363,6 +378,9 @@ (defgeneric text-modified-p (self) (:documentation "Returns true if the text component has been modified; nil otherwise.")) +(defgeneric (setf text-modified-p) (modified self) + (:documentation "Sets self's modified flag.")) + (defgeneric thumb-size (self) (:documentation "Returns an integer representing the width (or height) of this object's thumb.")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sat Aug 19 22:13:35 2006 @@ -259,15 +259,23 @@ (setf (child-visitor-results tc) nil) tmp))) -(defmethod (setf maximum-size) :after (max-size (self window)) +(defmethod maximum-size ((self window)) + (max-size-of self)) + +(defmethod (setf maximum-size) (max-size (self window)) (unless (or (gfs:disposed-p self) (null (layout-of self))) + (setf (max-size-of self) max-size) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size) (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)) size))) -(defmethod (setf minimum-size) :after (min-size (self window)) +(defmethod minimum-size ((self window)) + (min-size-of self)) + +(defmethod (setf minimum-size) (min-size (self window)) (unless (or (gfs:disposed-p self) (null (layout-of self))) + (setf (min-size-of self) min-size) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size) (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))

1 0

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

19 Aug '06

Author: junrue Date: Sat Aug 19 20:37:13 2006 New Revision: 223 Modified: trunk/NEWS.txt trunk/docs/manual/widgets-api.texinfo trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp Log: changed obtain-event-time to call native GetMessageTime, and removed obsolete slot from thread-context Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Aug 19 20:37:13 2006 @@ -4,6 +4,8 @@ to enable the stdcall calling convention for alien callbacks, located in src/external-libraries/sbcl-callback-patch +. Implemented the standard color chooser dialog. + ============================================================================== Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 20:37:13 2006 @@ -1162,8 +1162,7 @@ @anchor{obtain-event-time} @defun obtain-event-time => milliseconds -Returns the timestamp for the event currently being processed, or -zero if called prior to delivery of any events. +Returns the timestamp for the event currently being processed. @end defun Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sat Aug 19 20:37:13 2006 @@ -414,6 +414,10 @@ (filter-max UINT)) (defcfun + ("GetMessageTime" get-message-time) + LONG) + +(defcfun ("GetMonitorInfoA" get-monitor-info) BOOL (hmonitor HANDLE) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Aug 19 20:37:13 2006 @@ -78,7 +78,6 @@ gfs::time gfs::pnt) msg-ptr gfs::msg) - (setf (event-time (thread-context)) gfs::time) (when (funcall msg-filter gm msg-ptr) (return-from message-loop gfs::wparam))))))) @@ -140,10 +139,8 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) -;;; FIXME: replace event-time slot with call to GetMessageTime -;;; (defun obtain-event-time () - (event-time (thread-context))) + (gfs::get-message-time)) (defun option->reason (lparam) ;; MSDN says the value is a bitmask, so must be tested bit-wise. Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat Aug 19 20:37:13 2006 @@ -40,7 +40,6 @@ (display-visitor-results :initform nil :accessor display-visitor-results) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) ; FIXME: GetMessageTime (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt)

1 0

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

19 Aug '06

Author: junrue Date: Sat Aug 19 18:56:20 2006 New Revision: 222 Added: trunk/src/uitoolkit/widgets/color-dialog.lisp Modified: trunk/NEWS.txt trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/comdlg32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp trunk/src/uitoolkit/widgets/font-dialog.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented and documented system color dialog Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Aug 19 18:56:20 2006 @@ -1,8 +1,8 @@ -. SBCL 0.9.15 is now a supported Common Lisp implementation. Graphic-Forms - includes a small patch to enable the stdcall calling convention for alien - callbacks, located in src/external-libraries/sbcl-callback-patch +. SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch +to enable the stdcall calling convention for alien callbacks, located +in src/external-libraries/sbcl-callback-patch ============================================================================== Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 18:56:20 2006 @@ -28,7 +28,7 @@ @node widget types @subsection widget types -@strong{NOTE:} A future release will provide additional widget +@strong{Note:} A future release will provide additional widget classes. @anchor{button} @@ -90,6 +90,46 @@ @end deffn @end deftp +@anchor{color-dialog} +@deftp Class color-dialog +This class provides a standard dialog for choosing (or defining new) +@ref{color}s. The @ref{with-color-dialog} macro wraps the creation of +this dialog type and subsequent retrieval of the user's color choice. +However, applications may choose to implement these steps manually, in +which case the @ref{obtain-chosen-color} function can be used.@*@* +Like other system dialogs in Graphic-Forms, @code{color-dialog} is +derived from @ref{widget} rather than @ref{dialog} since the majority +of its functionality is implemented by the system. @strong{Note:} A +future release will provide a customization mechanism. +@deffn Initarg :initial-color +This initarg causes the dialog to show the specified color as +initially selected. +@end deffn +@deffn Initarg :initial-custom-colors +This initarg accepts a list of color objects which are used to +populate the custom color editing portion of the dialog. A +maximum of 16 colors are used, with any extras supplied in the +list being ignored. Fewer than 16 may be supplied, in which case +black is displayed as a default color for the remaining entries. +@end deffn +@deffn Initarg :owner +A value is required for this initarg, and it may be either a +@ref{window} or a dialog. +@end deffn +@deffn Initarg :style +This initarg accepts a list of keyword symbols: +@table @code +@item :allow-custom-colors +This configures the dialog to enable the Define Custom Color +button, which when clicked reveals additional controls for +creating custom colors. +@item :display-solid-only +This configures the dialog to only display solid colors in the +set of basic colors. +@end table +@end deffn +@end deftp + @anchor{control} @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 @@ -314,7 +354,7 @@ must be followed by an explicit call to @ref{dispose}.@*@* Like other system dialogs in Graphic-Forms, @code{file-dialog} is derived from @ref{widget} rather than @ref{dialog} since the majority -of its functionality is implemented by the system. @strong{NOTE:} A +of its functionality is implemented by the system. @strong{Note:} A future release will provide a customization mechanism.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if @@ -354,7 +394,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols, as follows: +This initarg accepts a list of keyword symbols: @table @code @item :add-to-recent This enables the system to add a link to the selected file @@ -374,7 +414,7 @@ for data to be saved. @item :show-hidden This keyword enables the dialog to display files marked @sc{hidden} by -the system. @strong{NOTE:} files marked both @sc{hidden} and +the system. @strong{Note:} files marked both @sc{hidden} and @sc{system} will not be displayed in any case. Also, be aware that using this keyword effectively overrides the user's preference settings. @@ -402,7 +442,7 @@ by an explicit call to @ref{dispose}.@*@* Like other system dialogs in Graphic-Forms, @code{font-dialog} is derived from @ref{widget} rather than @ref{dialog} since the majority of its -functionality is implemented by the system. @strong{NOTE:} A future release +functionality is implemented by the system. @strong{Note:} A future release will provide a customization mechanism.@* @deffn Initarg :gc This required initarg accepts a @ref{graphics-context} object providing @@ -424,7 +464,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols, as follows: +This initarg accepts a list of keyword symbols: @table @code @item :all-fonts This is a convenience style, used by default if no other font @@ -453,7 +493,7 @@ @anchor{group} @deftp Class group children location size style -@strong{NOTE:} this class is not yet fully implemented +@strong{Note:} this class is not yet fully implemented and does not yet participate in the layout protocol.@*@* A @code{group} represents a logical rectangular aggregation of @ref{window} children which has the following properties @@ -748,7 +788,7 @@ This slot holds a margin value in pixels for the bottom side of the container. @item data -This slot holds a @sc{alist} of pairs, each one associating a +This slot holds an @sc{alist} of pairs, each one associating a @sc{plist} of layout-specific attributes with an item from a container. @item left-margin @@ -1171,7 +1211,7 @@ @end deffn @anchor{capture-mouse} -@deffn Function capture-mouse self +@defun capture-mouse self Enables the @ref{window} identified by @code{self} to receive mouse input events even when the mouse pointer is outside of the bounds of @code{self}. Only one window at a time can capture the mouse. This @@ -1179,7 +1219,7 @@ background windows may still capture the mouse, but only mouse move events will be received and those only when the mouse hotspot is within the visible portions of such a window. @xref{release-mouse}. -@end deffn +@end defun @anchor{center-on-owner} @deffn GenericFunction center-on-owner self @@ -1319,13 +1359,13 @@ @end deffn @anchor{file-dialog-paths} -@deffn Function file-dialog-paths dlg => @sc{list} +@defun file-dialog-paths dlg => @sc{list} Interrogates the data structure associated with an instance of @ref{file-dialog} to obtain the paths for selected files. This return value is either @sc{nil} if the user cancelled the dialog, or a list of file @sc{namestring}s. Use this function when manually constructing a file dialog. @xref{with-file-dialog}. -@end deffn +@end defun @deffn GenericFunction focus-p self Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} @@ -1333,7 +1373,7 @@ @end deffn @anchor{font-dialog-results} -@deffn Function font-dialog-results dlg gc => @ref{font}, @ref{color} +@defun font-dialog-results dlg gc => @ref{font}, @ref{color} Interrogates the data structure associated with an instance of @ref{font-dialog} to obtain the @ref{font} and @ref{color} corresponding to selections made by the user, and returns @@ -1343,7 +1383,7 @@ Also, the color value will be @sc{nil} if the dialog was created with the @code{:no-effects} style keyword. Use this function when manually constructing a font dialog. @xref{with-font-dialog}. -@end deffn +@end defun @deffn GenericFunction give-focus self Places keyboard focus on @code{self}. @@ -1420,23 +1460,28 @@ the new minimum. @xref{maximum-size}. @end deffn -@deffn GenericFunction object-to-display self pnt -Return a point that is the result of transforming the specified point -from this object's coordinate system to display-relative coordinates. -@end deffn +@anchor{obtain-chosen-color} +@defun obtain-chosen-color @ref{color-dialog} => @ref{color}, list +Interrogates the data structure associated with @var{color-dialog} +to retrieve @var{color}. The secondary value is a list of color +objects corresponding to custom colors displayed by the dialog. +If the user cancelled the dialog, @sc{nil} is returned for both +values. Use this function when manually constructing a color dialog. +@xref{with-color-dialog}. +@end defun @anchor{obtain-displays} -@deffn Function obtain-displays +@defun obtain-displays => list Returns a list of @ref{display} objects, each of which describes a monitor attached to the system. The system specifies that one of these is the primary @ref{display}. -@end deffn +@end defun @anchor{obtain-primary-display} -@deffn Function obtain-primary-display -Return a @ref{display} object that is regarded by the system as +@defun obtain-primary-display => @ref{display} +Return a display object that is regarded by the system as being the primary. -@end deffn +@end defun @anchor{owner} @deffn GenericFunction owner self @@ -1461,11 +1506,12 @@ @anchor{pack} @deffn GenericFunction pack self -Causes @code{self} to be resized to its preferred @ref{size}. +Causes @var{self} to be resized to the dimensions returned +by @ref{preferred-size}. @end deffn @anchor{parent} -@deffn GenericFunction parent self +@deffn GenericFunction parent self => @ref{window} Returns the @code{parent} of @code{self}. In the case of @ref{panel}s and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or @ref{top-level} window. In the case of a dialog or @ref{top-level}, @@ -1508,10 +1554,10 @@ must determine how tall it would be given that width. @end deffn -@deffn Function primary-p display +@defun primary-p display Returns T if the system regards the specified display as the primary display; nil otherwise. -@end deffn +@end defun @deffn GenericFunction redo-available-p self => boolean Returns T if @code{self} has @sc{redo} capability and has an @@ -1523,10 +1569,10 @@ @end deffn @anchor{release-mouse} -@deffn Function release-mouse +@defun release-mouse Clears the mouse capture state to restore normal mouse input processing. @xref{capture-mouse}. -@end deffn +@end defun @anchor{resizable-p} @deffn GenericFunction resizable-p self => boolean @@ -1651,6 +1697,16 @@ @end deffn @end html +@anchor{with-color-dialog} +@defmac with-color-dialog (owner style color custom-colors &key initial-color initial-custom-colors) &body body +This macro wraps the instantiation of a standard color dialog and +the subsequent retrieval of the user's color selection (supplied to @var{body} +via @var{color}). The @var{custom-colors} argument is bound to a list containing +colors that the user has modified in the extended portion of the dialog. +@xref{color-dialog}. +@end defmac + +@anchor{with-drawing-disabled} @defmac with-drawing-disabled (widget) &body body This macro executes @var{body} while updates of @var{widget} are disabled. Drawing operations attempted while @var{body} Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sat Aug 19 18:56:20 2006 @@ -122,6 +122,9 @@ (:file "timer") (:file "item") (:file "widget") + (:file "color-dialog") + (:file "file-dialog") + (:file "font-dialog") (:file "control") (:file "edit") (:file "label") @@ -136,8 +139,6 @@ (:file "top-level") (:file "panel") (:file "dialog") - (:file "file-dialog") - (:file "font-dialog") (:file "layout") (:file "heap-layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 19 18:56:20 2006 @@ -244,6 +244,7 @@ ;; classes and structs #:button #:caret + #:color-dialog #:control #:dialog #:display @@ -462,7 +463,7 @@ #:move-above #:move-below #:moveable-p - #:object-to-display + #:obtain-chosen-color #:obtain-displays #:obtain-event-time #:obtain-primary-display @@ -523,6 +524,7 @@ #:vertical-scrollbar #:visible-item-count #:visible-p + #:with-color-dialog #:with-drawing-disabled #:with-file-dialog #:with-font-dialog Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sat Aug 19 18:56:20 2006 @@ -117,6 +117,14 @@ :initial-directory #P"c:/") (print paths))) +(defun choose-color-dlg (disp item) + (declare (ignore disp item)) + (gfw:with-color-dialog (*main-win* '(:allow-custom-colors) color custom-colors :initial-custom-colors (list gfg:*color-red* gfg:*color-blue*)) + (if color + (print color)) + (if custom-colors + (print custom-colors)))) + (defun choose-font-dlg (disp item) (declare (ignore disp item)) (gfw:with-graphics-context (gc *main-win*) @@ -235,16 +243,17 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) (:item "&Custom Dialogs" - :submenu ((:item "&Modal" :callback #'open-modal-dlg) - (:item "&Modeless" :callback #'open-modeless-dlg))) + :submenu ((:item "&Modal" :callback #'open-modal-dlg) + (:item "&Modeless" :callback #'open-modeless-dlg))) (:item "&System Dialogs" - :submenu ((:item "&Choose Font" :callback #'choose-font-dlg) - (:item "&Open File" :callback #'open-file-dlg) - (:item "&Save File" :callback #'save-file-dlg))) + :submenu ((:item "Choose &Color" :callback #'choose-color-dlg) + (:item "Choose &Font" :callback #'choose-font-dlg) + (:item "&Open File" :callback #'open-file-dlg) + (:item "&Save File" :callback #'save-file-dlg))) (:item "&Windows" - :submenu ((:item "&Borderless" :callback #'create-borderless-win) - (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Palette" :callback #'create-palette-win)))))) + :submenu ((:item "&Borderless" :callback #'create-borderless-win) + (:item "&Mini Frame" :callback #'create-miniframe-win) + (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) (setf (gfw:image *main-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *main-win* t))) Modified: trunk/src/uitoolkit/system/comdlg32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comdlg32.lisp (original) +++ trunk/src/uitoolkit/system/comdlg32.lisp Sat Aug 19 18:56:20 2006 @@ -39,6 +39,11 @@ (load-foreign-library "comdlg32.dll") (defcfun + ("ChooseColorA" choose-color) + BOOL + (struct LPTR)) ; choosecolor struct + +(defcfun ("ChooseFontA" choose-font) BOOL (struct LPTR)) ; choosefont struct Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat Aug 19 18:56:20 2006 @@ -137,10 +137,20 @@ (defconstant +cbm-init+ #x04) -(defconstant +cchdevicename+ 32) +(defconstant +cc-rgbinit+ #x00000001) +(defconstant +cc-fullopen+ #x00000002) +(defconstant +cc-preventfullopen+ #x00000004) +(defconstant +cc-showhelp+ #x00000008) +(defconstant +cc-enablehook+ #x00000010) +(defconstant +cc-enabletemplate+ #x00000020) +(defconstant +cc-enabletemplatehandle+ #x00000040) +(defconstant +cc-solidcolor+ #x00000080) +(defconstant +cc-anycolor+ #x00000100) (defconstant +ccerr-choosecolorcodes+ #x5000) +(defconstant +cchdevicename+ 32) + (defconstant +cderr-dialogfailure+ #xFFFF) (defconstant +cderr-generalcodes+ #x0000) (defconstant +cderr-structsize+ #x0001) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Sat Aug 19 18:56:20 2006 @@ -150,6 +150,17 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct choosecolor + (ccsize DWORD) + (howner HANDLE) + (hinst HANDLE) + (result COLORREF) + (ccolors LPTR) + (flags DWORD) + (cdata LPARAM) + (hookfn LPTR) ; CCHookProc + (templname :string)) + (defcstruct choosefont (structsize DWORD) (howner HANDLE) @@ -159,7 +170,7 @@ (flags DWORD) (color COLORREF) (data LPARAM) - (hookfn LPTR) ; FIXME: not yet used, but eventually should be CFHookProc + (hookfn LPTR) ; CFHookProc (templname :string) (hinstance HANDLE) (style :string) @@ -184,7 +195,7 @@ (whatlen WORD) (withlen WORD) (data LPARAM) - (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc + (hookfn LPTR) ; FRHookProc (templname :string)) (defcstruct iconinfo Added: trunk/src/uitoolkit/widgets/color-dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/color-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -0,0 +1,130 @@ +;;;; +;;;; color-dialog.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) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +custom-color-array-size+ 16)) + +;;; +;;; helper functions +;;; + +(defun obtain-chosen-color (dlg) + (let ((cc-ptr (gfs:handle dlg))) + (if (cffi:null-pointer-p cc-ptr) + (error 'gfs:disposed-error)) + (cffi:with-foreign-slots ((gfs::result gfs::ccolors) cc-ptr gfs::choosecolor) + (values (gfg:rgb->color gfs::result) + (loop for index to (1- +custom-color-array-size+) + collect (gfg:rgb->color (cffi:mem-aref gfs::ccolors 'gfs::colorref index))))))) + +(defmacro with-color-dialog ((owner style color custom-colors &key initial-color initial-custom-colors) &body body) + (let ((dlg (gensym))) + `(let ((,color nil) + (,custom-colors nil) + (,dlg (make-instance 'color-dialog + :initial-custom-colors ,initial-custom-colors + :initial-color ,initial-color + :owner ,owner + :style ,style))) + (unwind-protect + (unless (zerop (show ,dlg t)) + (multiple-value-bind (tmp-color tmp-custom) + (obtain-chosen-color ,dlg) + (setf ,color tmp-color + ,custom-colors tmp-custom) + ,@body)) + (gfs:dispose ,dlg))))) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self color-dialog) &rest extra-data) + (let ((std-flags (logior gfs::+cc-anycolor+ gfs::+cc-preventfullopen+ (if extra-data gfs::+cc-rgbinit+ 0)))) + (loop for sym in (style-of self) + do (ecase sym + (:allow-custom-colors + (setf std-flags (logand std-flags (lognot gfs::+cc-preventfullopen+)))) + (:display-solid-only) + (setf std-flags (logior std-flags gfs::+cc-solidcolor+)))) + (values std-flags 0))) + +(defmethod gfs:dispose ((self color-dialog)) + (let ((cc-ptr (gfs:handle self))) + (unless (cffi:null-pointer-p cc-ptr) + (cffi:with-foreign-slots ((gfs::ccolors) cc-ptr gfs::choosecolor) + (unless (cffi:null-pointer-p gfs::ccolors) + (cffi:foreign-free gfs::ccolors))) + (cffi:foreign-free cc-ptr) + (setf (slot-value self 'gfs:handle) nil)))) + +(defmethod initialize-instance :after ((self color-dialog) &key initial-color initial-custom-colors owner &allow-other-keys) + (if (null owner) + (error 'gfs:toolkit-error :detail ":owner initarg is required")) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let ((cc-ptr (cffi:foreign-alloc 'gfs::choosecolor)) + (colors-ptr (cffi:foreign-alloc 'gfs::colorref :count +custom-color-array-size+)) + (index 0) + (default-rgb (gfg:color->rgb gfg:*color-black*))) + (loop for color in initial-custom-colors + when (< index +custom-color-array-size+) + do (progn + (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) (gfg:color->rgb color)) + (incf index))) + (loop until (>= index +custom-color-array-size+) + do (progn + (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) default-rgb) + (incf index))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self initial-color) + (declare (ignore ex-style)) + (cffi:with-foreign-slots ((gfs::ccsize gfs::howner gfs::hinst gfs::result + gfs::ccolors gfs::flags gfs::cdata gfs::hookfn gfs::templname) + cc-ptr gfs::choosecolor) + (setf gfs::ccsize (cffi:foreign-type-size 'gfs::choosecolor) + gfs::howner (gfs:handle owner) + gfs::hinst (cffi:null-pointer) + gfs::result (gfg:color->rgb (or initial-color (gfg:make-color))) + gfs::ccolors colors-ptr + gfs::flags std-style + gfs::cdata 0 + gfs::hookfn (cffi:null-pointer) + gfs::templname (cffi:null-pointer)))) + (setf (slot-value self 'gfs:handle) cc-ptr))) + +(defmethod show ((self color-dialog) flag) + (declare (ignore flag)) + (show-common-dialog self #'gfs::choose-color)) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -38,19 +38,18 @@ ;;; (defun file-dialog-paths (dlg) - (let ((paths nil) - (ofn-ptr (gfs:handle dlg))) + (let ((ofn-ptr (gfs:handle dlg))) (if (cffi:null-pointer-p ofn-ptr) (error 'gfs:disposed-error)) (cffi:with-foreign-slots ((gfs::ofnfile) ofn-ptr gfs::openfilename) - (unless (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + (if (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + nil (let* ((raw-list (extract-foreign-strings gfs::ofnfile)) (dir-str (first raw-list))) - (if (cdr raw-list) - (setf paths (loop for filename in (cdr raw-list) - collect (parse-namestring (concatenate 'string dir-str "\\" filename)))) - (setf paths (list (parse-namestring dir-str))))))) - paths)) + (if (rest raw-list) + (loop for filename in (rest raw-list) + collect (parse-namestring (concatenate 'string dir-str "\\" filename))) + (list (parse-namestring dir-str)))))))) (defmacro with-file-dialog ((owner style paths &key default-extension filters initial-directory initial-filename text) &body body) (let ((dlg (gensym))) @@ -106,7 +105,7 @@ (unless (cffi:null-pointer-p gfs::ofndefext) (cffi:foreign-free gfs::ofndefext))) (cffi:foreign-free ofn-ptr) - (setf (slot-value self 'gfs:handle) (cffi:null-pointer))))) + (setf (slot-value self 'gfs:handle) nil)))) (defmethod initialize-instance :after ((self file-dialog) &key default-extension filters initial-directory initial-filename owner style text) ;; FIXME: implement an OFNHookProc to process CDN_SELCHANGE Modified: trunk/src/uitoolkit/widgets/font-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/font-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/font-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -65,12 +65,11 @@ :owner ,owner :style ,style))) (unwind-protect - (progn - (unless (zerop (show ,dlg t)) - (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc) - (setf ,font f) - (setf ,color c)) - ,@body)) + (unless (zerop (show ,dlg t)) + (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc) + (setf ,font f) + (setf ,color c)) + ,@body) (gfs:dispose ,dlg))))) ;;; Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sat Aug 19 18:56:20 2006 @@ -116,15 +116,15 @@ (setf (top-margin-of self) vertical-margins (bottom-margin-of self) vertical-margins))) -(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed)) - (let ((orig-layout (layout-of container))) +(defmethod (setf layout-of) :after ((layout layout-manager) (self layout-managed)) + (let ((orig-layout (layout-of self))) (if orig-layout - (setf (data-of self) (loop for item in (data-of orig-layout) - when (not (gfs:disposed-p (first item))) - collect item) + (setf (data-of layout) (loop for item in (data-of orig-layout) + when (not (gfs:disposed-p (first item))) + collect item) (data-of orig-layout) nil) - (if (typep container 'window) - (setf (data-of self) (mapchildren container (lambda (parent child) + (if (typep self 'window) + (setf (data-of layout) (mapchildren self (lambda (parent child) (declare (ignore parent)) (list child nil)))))))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Aug 19 18:56:20 2006 @@ -142,6 +142,9 @@ (defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image.")) +(defclass color-dialog (widget) () + (:documentation "This class represents the standard color chooser dialog.")) + (defclass file-dialog (widget) ((open-mode :reader open-mode Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Aug 19 18:56:20 2006 @@ -249,9 +249,6 @@ (defgeneric moveable-p (self) (:documentation "Returns T if the object is moveable; nil otherwise.")) -(defgeneric object-to-display (self pnt) - (:documentation "Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates.")) - (defgeneric owner (self) (:documentation "Returns self's owner (which is not necessarily the same as parent)."))

1 0

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

18 Aug '06

Author: junrue Date: Fri Aug 18 18:30:58 2006 New Revision: 221 Added: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/tests.lisp Log: refactored flow-layout implementation, updated associated unit-tests Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Aug 18 18:30:58 2006 @@ -255,6 +255,7 @@ #:flow-layout #:heap-layout #:item + #:layout-managed #:layout-manager #:menu #:menu-item Added: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Fri Aug 18 18:30:58 2006 @@ -0,0 +1,266 @@ +;;;; +;;;; flow-layout-unit-tests.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.tests) + +(defvar *large-size* (gfs:make-size :width 25 :height 5)) +(defvar *small-size* (gfs:make-size :width 20 :height 10)) + +(defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *small-size*))) +(defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *large-size*) + (make-instance 'mock-widget :min-size *small-size*))) + +(defvar *flow-container* (make-instance 'mock-container)) + +(define-test flow-layout-test1 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) + (assert-equal 60 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test2 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test3 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width, unrestricted height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) + (data (gfw::compute-layout layout *flow-container* 45 -1)) + (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test4 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width, restricted height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) + (data (gfw::compute-layout layout *flow-container* -1 25)) + (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test5 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) + (data (gfw::compute-layout layout *flow-container* 45 18)) + (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test6 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) + (data (gfw::compute-layout layout *flow-container* 30 25)) + (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test7 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 4)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) + (assert-equal 68 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test8 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 4)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 38 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test9 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)) + (data (gfw::compute-layout layout *flow-container* 45 18)) + (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test10 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)) + (data (gfw::compute-layout layout *flow-container* 30 25)) + (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test11 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) + (assert-equal 63 (gfs:size-width size)) + (assert-equal 13 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test12 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) + (assert-equal 23 (gfs:size-width size)) + (assert-equal 33 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test13 + ;; orient: horizontal + ;; normalize: enabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: mixed + ;; + (let* ((layout (make-flow-layout *flow-mixed-kids* '(:horizontal :normalize))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) + (assert-equal 75 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test14 + ;; orient: vertical + ;; normalize: enabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: mixed + ;; + (let* ((layout (make-flow-layout *flow-mixed-kids* '(:vertical :normalize))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) + (assert-equal 25 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Aug 18 18:30:58 2006 @@ -33,27 +33,6 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *large-size* (gfs:make-size :width 25 :height 5)) -(defvar *small-size* (gfs:make-size :width 20 :height 10)) -(defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*))) -(defvar *flow-layout-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *large-size*) - (make-instance 'mock-widget :min-size *small-size*))) - -(defun validate-layout-rects (entries expected-rects) - (let ((actual-rects (loop for entry in entries collect (cdr entry)))) - (mapc #'(lambda (expected actual) - (let ((pnt-a (gfs:location actual)) - (sz-a (gfs:size actual))) - (assert-equal (first expected) (gfs:point-x pnt-a)) - (assert-equal (second expected) (gfs:point-y pnt-a)) - (assert-equal (third expected) (gfs:size-width sz-a)) - (assert-equal (fourth expected) (gfs:size-height sz-a)))) - expected-rects - actual-rects))) - (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle 1234)) (widget2 (make-instance 'mock-widget :handle 5678))) @@ -72,229 +51,3 @@ (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) (assert-equal 100 (gfw:layout-attribute layout widget2 'd))))) - -(define-test flow-layout-test1 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) - (assert-equal 60 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test2 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test3 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width, unrestricted height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test4 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width, restricted height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test5 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test6 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test7 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) - (assert-equal 68 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test8 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 38 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test9 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18)) - (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test10 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) - (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test11 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout - :style '(:horizontal) - :left-margin 3 - :top-margin 3)) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) - (assert-equal 63 (gfs:size-width size)) - (assert-equal 13 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test12 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout - :style '(:vertical) - :right-margin 3 - :bottom-margin 3)) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 23 (gfs:size-width size)) - (assert-equal 33 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test13 - ;; orient: horizontal - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :normalize))) - (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1)) - (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) - (assert-equal 75 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test14 - ;; orient: vertical - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :normalize))) - (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1)) - (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) - (assert-equal 25 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Aug 18 18:30:58 2006 @@ -33,10 +33,33 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +max-widget-size+ 5000) +(defconstant +max-widget-size+ 5000) +(defconstant +default-container-width+ 300) +(defconstant +default-container-height+ 200) ;;; -;;; stand-ins for widgets that would be children of windows, to be organized +;;; stand-in for a window, used as parent of mock-widget +;;; + +(defclass mock-container (gfw:layout-managed) + ((location + :accessor location-of + :initarg :location + :initform (gfs:make-point)) + (size + :accessor size-of + :initarg :size + :initform (gfs:make-size :width +default-container-width+ :height +default-container-height+)) + (visibility + :accessor visibility-of + :initarg :visibility + :initform t))) + +(defmethod gfw:visible-p ((self mock-container)) + (visibility-of self)) + +;;; +;;; stand-in for widgets that would be children of windows, to be organized ;;; via layout managers ;;; Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Fri Aug 18 18:30:58 2006 @@ -33,9 +33,32 @@ (in-package :graphic-forms.uitoolkit.tests) +(defun make-flow-layout (kids style &optional spacing left-margin top-margin right-margin bottom-margin) + (let ((layout (make-instance 'gfw:flow-layout + :style style + :spacing (or spacing 0) + :left-margin (or left-margin 0) + :top-margin (or top-margin 0) + :right-margin (or right-margin 0) + :bottom-margin (or bottom-margin 0)))) + (loop for kid in kids do (gfw::append-layout-item layout kid)) + layout)) + (defun validate-image (image expected-size expected-depth) (declare (ignore expected-depth)) (assert-false (null image)) (assert-false (gfs:disposed-p image)) ;; (assert-equal expected-depth (gfg:depth image)) ; FIXME: image->data needed (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) + +(defun validate-rects (entries expected-rects) + (let ((actual-rects (loop for entry in entries collect (cdr entry)))) + (mapc #'(lambda (expected actual) + (let ((pnt-a (gfs:location actual)) + (sz-a (gfs:size actual))) + (assert-equal (first expected) (gfs:point-x pnt-a)) + (assert-equal (second expected) (gfs:point-y pnt-a)) + (assert-equal (third expected) (gfs:size-width sz-a)) + (assert-equal (fourth expected) (gfs:size-height sz-a)))) + expected-rects + actual-rects))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 18:30:58 2006 @@ -34,7 +34,6 @@ (in-package :graphic-forms.uitoolkit.widgets) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +wm-gf-init-msg+ #xABCD) (defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ gfs::+pm-noyield+ gfs::+pm-qs-input+ @@ -222,18 +221,8 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) (let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot (if (typep widget 'dialog) - (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam))) - (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget - (return-from process-message tmp)) - (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget - 0) - -(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam) - (declare (ignore wparam lparam)) - (let ((widget (get-widget (thread-context) hwnd))) - (unless widget - (return-from process-message 0))) - 0) + (gfs::def-dlg-proc hwnd msg wparam lparam) + 0))) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 18:30:58 2006 @@ -53,7 +53,7 @@ (start-margin-fn nil) (current nil)) -(defun init-flow-data (layout visible kids width-hint height-hint) +(defun init-flow-data (layout visible items width-hint height-hint) (let ((state (if (find :vertical (style-of layout)) (make-flow-data :hint height-hint :next-coord (top-margin-of layout) @@ -71,7 +71,8 @@ :extent-fn #'gfs:size-height :limit-margin-fn #'right-margin-of :start-margin-fn #'left-margin-of)))) - (loop for kid in kids + (loop for item in items + for kid = (first item) when (or (visible-p kid) (not visible)) do (let* ((size (preferred-size kid -1 -1)) (dist (funcall (flow-data-distance-fn state) size)) @@ -86,37 +87,6 @@ (setf (flow-data-kid-sizes state) (reverse (flow-data-kid-sizes state))) state)) -(defun flow-container-size (layout visible kids width-hint height-hint) - (let ((kid-count (length kids)) - (horz-margin-total (+ (left-margin-of layout) (right-margin-of layout))) - (vert-margin-total (+ (top-margin-of layout) (bottom-margin-of layout))) - (vertical (find :vertical (style-of layout))) - (horizontal (find :horizontal (style-of layout)))) - (let ((spacing-total (* (spacing-of layout) (1- kid-count))) - (state (init-flow-data layout - visible - kids - (if vertical width-hint -1) - (if vertical -1 height-hint)))) - (if (find :normalize (style-of layout)) - (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count))) - (cond - (horizontal - (gfs:make-size :width (+ (flow-data-distance-total state) - horz-margin-total - spacing-total) - :height (+ (flow-data-max-extent state) - vert-margin-total))) - (vertical - (gfs:make-size :width (+ (flow-data-max-extent state) - horz-margin-total) - :height (+ (flow-data-distance-total state) - vert-margin-total - spacing-total))) - (t - (error 'gfs:toolkit-error - :detail (format nil "unrecognized flow layout style: ~a" (style-of layout)))))))) - (defun wrap-needed-p (state layout kid-size) (and (>= (flow-data-hint state) 0) (> (+ (flow-data-next-coord state) @@ -143,12 +113,49 @@ (flow-data-spacing state))) (cons kid (gfs:make-rectangle :size kid-size :location pnt)))) -(defun flow-container-layout (layout visible kids width-hint height-hint) +;;; +;;; methods +;;; + +(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kid-count (length (data-of self))) + (horz-margin-total (+ (left-margin-of self) (right-margin-of self))) + (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self))) + (vertical (find :vertical (style-of self))) + (horizontal (find :horizontal (style-of self)))) + (let ((spacing-total (* (spacing-of self) (1- kid-count))) + (state (init-flow-data self + (visible-p container) + (data-of self) + (if vertical width-hint -1) + (if vertical -1 height-hint)))) + (if (find :normalize (style-of self)) + (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count))) + (cond + (horizontal + (gfs:make-size :width (+ (flow-data-distance-total state) + horz-margin-total + spacing-total) + :height (+ (flow-data-max-extent state) + vert-margin-total))) + (vertical + (gfs:make-size :width (+ (flow-data-max-extent state) + horz-margin-total) + :height (+ (flow-data-distance-total state) + vert-margin-total + spacing-total))) + (t + (error 'gfs:toolkit-error + :detail (format nil "unrecognized flow layout style: ~a" (style-of self)))))))) + +(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) (let ((flows nil) - (normal (find :normalize (style-of layout))) - (vertical (find :vertical (style-of layout))) - (state (init-flow-data layout visible kids width-hint height-hint))) - (loop with wrap = (find :wrap (style-of layout)) + (normal (find :normalize (style-of self))) + (vertical (find :vertical (style-of self))) + (state (init-flow-data self (visible-p container) (data-of self) width-hint height-hint))) + (loop with wrap = (find :wrap (style-of self)) for (kid kid-size) in (flow-data-kid-sizes state) do (cond ((and normal vertical) @@ -159,26 +166,13 @@ (gfs:size-height kid-size) (flow-data-max-extent state)))) (if (and wrap (flow-data-current state) - (wrap-needed-p state layout kid-size)) - (setf flows (append flows (wrap-flow state layout)))) - (push (new-flow-element state layout kid kid-size) (flow-data-current state))) + (wrap-needed-p state self kid-size)) + (setf flows (append flows (wrap-flow state self)))) + (push (new-flow-element state self kid kid-size) (flow-data-current state))) (if (flow-data-current state) - (setf flows (append flows (wrap-flow state layout)))) + (setf flows (append flows (wrap-flow state self)))) flows)) -;;; -;;; methods -;;; - -(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) - (cleanup-disposed-items self) - (let ((kids (loop for item in (data-of self) collect (first item)))) - (flow-container-size self (visible-p container) kids width-hint height-hint))) - -(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) - (cleanup-disposed-items self) - (let ((kids (loop for item in (data-of self) collect (first item)))) - (flow-container-layout self (visible-p container) kids width-hint height-hint))) (defmethod initialize-instance :after ((self flow-layout) &key) (unless (intersection (style-of self) '(:horizontal :vertical)) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 18:30:58 2006 @@ -60,7 +60,7 @@ (defsetf layout-attribute set-layout-attribute) (defun append-layout-item (layout thing) - "Adds thing to layout unless it is already registered." + "Adds thing to layout. Duplicate entries are not prevented." (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) (defun delete-layout-item (layout thing) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Fri Aug 18 18:30:58 2006 @@ -43,5 +43,6 @@ (load (concatenate 'string *gf-tests-dir* "image-unit-tests")) (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests")) (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "flow-layout-unit-tests")) (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) (load (concatenate 'string *gf-tests-dir* "misc-unit-tests")))

1 0

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

18 Aug '06

Author: junrue Date: Fri Aug 18 13:18:48 2006 New Revision: 220 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented layout item registration, no longer directly using mapchildren to layout children Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Fri Aug 18 13:18:48 2006 @@ -539,8 +539,10 @@ Instances of this class employ a @ref{layout-manager} to maintain the positions and sizes of their children. @deffn Accessor layout-of -Accepts or returns the @ref{layout-manager} associated with this -container. +Accepts or returns the layout-manager associated with this +container. Note that children currently registered with the previous +layout-manager are copied to the new one, but existing layout +attributes that were set for each child are not copied. @end deffn @deffn Initarg :layout Accepts a @ref{layout-manager} object whose responsibility is to manage @@ -1701,11 +1703,10 @@ @anchor{compute-layout} @deffn GenericFunction compute-layout @ref{layout-manager} container width-hint height-hint -Returns a list of pairs @code{(item rectangle)} describing the +Returns a list of conses @code{(child . rectangle)} describing the new bounds of each child within @var{container}. A layout-manager subclass implements this method based on its particular layout strategy, taking -into account attributes set by the user via @ref{layout-attribute}. Certain -Graphic-Forms functions call this method to accomplish layout within a container. +into account attributes set by the user via @ref{layout-attribute}. @table @var @item layout-manager The layout object dictating how children of @var{container} Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Aug 18 13:18:48 2006 @@ -57,8 +57,8 @@ (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle 1234)) (widget2 (make-instance 'mock-widget :handle 5678))) - (let ((data1 `(,(cffi:make-pointer 1234) (a 1 b 2))) - (data2 `(,(cffi:make-pointer 5678) (a 10 c 30))) + (let ((data1 `(,widget1 (a 1 b 2))) + (data2 `(,widget2 (a 10 c 30))) (layout (make-instance 'gfw:layout-manager))) (setf (slot-value layout 'gfw::data) (list data1 data2)) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Aug 18 13:18:48 2006 @@ -1014,6 +1014,14 @@ (defconstant +wm-displaychange+ #x007E) (defconstant +wm-geticon+ #x007F) (defconstant +wm-seticon+ #x0080) +(defconstant +wm-nccreate+ #x0081) +(defconstant +wm-ncdestroy+ #x0082) +(defconstant +wm-nccalcsize+ #x0083) +(defconstant +wm-nchittest+ #x0084) +(defconstant +wm-ncpaint+ #x0085) +(defconstant +wm-ncactivate+ #x0086) +(defconstant +wm-getdlgcode+ #x0087) +(defconstant +wm-syncpaint+ #x0088) (defconstant +wm-ncmousemove+ #x00A0) (defconstant +wm-nclbuttondown+ #x00A1) (defconstant +wm-nclbuttonup+ #x00A2) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Aug 18 13:18:48 2006 @@ -43,7 +43,13 @@ (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfs:null-handle-p hfont) - (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))))) + (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it breaks in the presence of virtual containers like group + ;; + (let ((parent (parent ctrl))) + (when (and parent (layout-of parent)) + (append-layout-item (layout-of parent) ctrl))))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Fri Aug 18 13:18:48 2006 @@ -169,7 +169,7 @@ (error 'gfs:disposed-error))) (if (null text) (setf text *default-dialog-title*)) - ;; NOTE: do not allow apps to specify the desktop window as the + ;; Don't allow apps to specify the desktop window as the ;; owner of the dialog; it would cause the desktop to become ;; disabled. ;; Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 13:18:48 2006 @@ -33,10 +33,12 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ - gfs::+pm-noyield+ - gfs::+pm-qs-input+ - gfs::+pm-qs-postmessage+)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +wm-gf-init-msg+ #xABCD) + (defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ + gfs::+pm-noyield+ + gfs::+pm-qs-input+ + gfs::+pm-qs-postmessage+))) ;;; ;;; window procedures @@ -139,6 +141,8 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) +;;; FIXME: replace event-time slot with call to GetMessageTime +;;; (defun obtain-event-time () (event-time (thread-context))) @@ -216,13 +220,30 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) - (let ((w (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot - (if (typep w 'dialog) - (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam)))) + (let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot + (if (typep widget 'dialog) + (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam))) + (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget + (return-from process-message tmp)) + (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget + 0) + +(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam) + (declare (ignore wparam lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (unless widget + (return-from process-message 0))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (event-dispose (dispatcher widget) widget))) + ;; If widget is registered with a layout manager, that reference + ;; is not cleared until the next time the layout manager is invoked. + ;; This alleviates the need for slow messy code here. + ;; (delete-widget (thread-context) hwnd) 0) @@ -242,10 +263,10 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context)) - (w (get-widget tc hwnd)) + (widget (get-widget tc hwnd)) (ch (code-char (lo-word wparam)))) - (when w - (event-key-down (dispatcher w) w (virtual-key tc) ch))) + (when widget + (event-key-down (dispatcher widget) widget (virtual-key tc) ch))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 13:18:48 2006 @@ -170,18 +170,16 @@ ;;; methods ;;; -(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (let ((kids (mapchildren win (lambda (parent child) - (declare (ignore parent)) - child)))) - (flow-container-size layout (visible-p win) kids width-hint height-hint))) +(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kids (loop for item in (data-of self) collect (first item)))) + (flow-container-size self (visible-p container) kids width-hint height-hint))) -(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) - (let ((kids (mapchildren win (lambda (parent child) - (declare (ignore parent)) - child)))) - (flow-container-layout layout (visible-p win) kids width-hint height-hint))) +(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kids (loop for item in (data-of self) collect (first item)))) + (flow-container-layout self (visible-p container) kids width-hint height-hint))) -(defmethod initialize-instance :after ((layout flow-layout) &key) - (unless (intersection (style-of layout) '(:horizontal :vertical)) - (setf (style-of layout) (list :horizontal)))) +(defmethod initialize-instance :after ((self flow-layout) &key) + (unless (intersection (style-of self) '(:horizontal :vertical)) + (setf (style-of self) (list :horizontal)))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Fri Aug 18 13:18:48 2006 @@ -37,21 +37,23 @@ ;;; methods ;;; -(defmethod compute-size ((self heap-layout) win width-hint height-hint) +(defmethod compute-size ((self heap-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) (let ((size (gfs:make-size))) - (mapchildren win (lambda (parent kid) - (declare (ignore parent)) - (let ((kid-size (preferred-size kid width-hint height-hint))) - (setf (gfs:size-width size) (max (gfs:size-width size) - (gfs:size-width kid-size)) - (gfs:size-height size) (max (gfs:size-height size) - (gfs:size-height kid-size)))))) + (mapc (lambda (item) + (let ((kid-size (preferred-size (first item) width-hint height-hint))) + (setf (gfs:size-width size) (max (gfs:size-width size) + (gfs:size-width kid-size)) + (gfs:size-height size) (max (gfs:size-height size) + (gfs:size-height kid-size))))) + (data-of self)) (incf (gfs:size-width size) (+ (left-margin-of self) (right-margin-of self))) (incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self))) size)) -(defmethod compute-layout ((self heap-layout) win width-hint height-hint) - (let* ((size (client-size win)) +(defmethod compute-layout ((self heap-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let* ((size (client-size container)) (horz-margin (+ (left-margin-of self) (right-margin-of self))) (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) (new-size (gfs:make-size :width (- (if (> width-hint horz-margin) @@ -64,16 +66,19 @@ vert-margin))) (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) (bounds (gfs:make-rectangle :size new-size :location new-pnt))) - (mapchildren win (lambda (parent kid) - (declare (ignore parent)) - (cons kid bounds))))) + (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) - (let ((top (top-child-of self)) - (kid-specs (compute-layout self container width-hint height-hint))) - (unless top - (setf top (car (first kid-specs)))) - (arrange-children kid-specs (lambda (item) - (if (cffi:pointer-eq (gfs:handle top) (gfs:handle item)) - (logior +window-pos-flags+ gfs::+swp-showwindow+) - (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))) + (if (layout-p container) + (let ((top (top-child-of self)) + (kid-specs (compute-layout self container width-hint height-hint))) + (unless top + (setf top (car (first kid-specs)))) + (arrange-hwnds kid-specs (lambda (item) + (if (eql top item) + (logior +window-pos-flags+ gfs::+swp-showwindow+) + (logior +window-pos-flags+ gfs::+swp-hidewindow+))))))) + +(defmethod (setf top-child-of) :after (child (self heap-layout)) + (unless (typep child 'widget) + (error 'gfs:toolkit-error :detail "top child must be an instance of a widget subclass"))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 13:18:48 2006 @@ -43,27 +43,34 @@ ;;; helper functions ;;; -(defun layout-attribute (layout widget name) - "Return the value associated with name for widget; or NIL if no value is set." - (if (gfs:disposed-p widget) - (error 'gfs:disposed-error)) - (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) - (unless attrs - (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) - (getf (first (rest attrs)) name))) - -(defun set-layout-attribute (layout widget name value) - "Sets a value associated with name for widget in the specified layout." - (if (gfs:disposed-p widget) - (error 'gfs:disposed-error)) - (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) - (unless attrs - (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) - (setf (getf (first (rest attrs)) name) value))) +(defun layout-attribute (layout thing name) + "Return the value associated with name for thing; or NIL if no value is set." + (let ((items (assoc thing (data-of layout)))) + (unless items + (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) + (getf (first (rest items)) name))) + +(defun set-layout-attribute (layout thing name value) + "Sets a value associated with name for thing in the specified layout." + (let ((items (assoc thing (data-of layout)))) + (unless items + (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) + (setf (getf (first (rest items)) name) value))) (defsetf layout-attribute set-layout-attribute) -(defun arrange-children (kid-specs flags-func) +(defun append-layout-item (layout thing) + "Adds thing to layout unless it is already registered." + (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) + +(defun delete-layout-item (layout thing) + "Removes thing from layout." + (delete thing (data-of layout) :key #'first)) + +(defun cleanup-disposed-items (layout) + (delete-if #'gfs:disposed-p (data-of layout) :key #'first)) + +(defun arrange-hwnds (kid-specs flags-func) (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) (loop for k in kid-specs for rect = (cdr k) @@ -93,25 +100,37 @@ ;;; methods ;;; -(defmethod initialize-instance :after ((layout layout-manager) +(defmethod initialize-instance :after ((self layout-manager) &key style margins horizontal-margins vertical-margins &allow-other-keys) - (setf (style-of layout) (if (listp style) style (list style))) + (setf (style-of self) (if (listp style) style (list style))) (unless (null margins) - (setf (left-margin-of layout) margins - (right-margin-of layout) margins - (top-margin-of layout) margins - (bottom-margin-of layout) margins)) + (setf (left-margin-of self) margins + (right-margin-of self) margins + (top-margin-of self) margins + (bottom-margin-of self) margins)) (unless (null horizontal-margins) - (setf (left-margin-of layout) horizontal-margins - (right-margin-of layout) horizontal-margins)) + (setf (left-margin-of self) horizontal-margins + (right-margin-of self) horizontal-margins)) (unless (null vertical-margins) - (setf (top-margin-of layout) vertical-margins - (bottom-margin-of layout) vertical-margins))) + (setf (top-margin-of self) vertical-margins + (bottom-margin-of self) vertical-margins))) + +(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed)) + (let ((orig-layout (layout-of container))) + (if orig-layout + (setf (data-of self) (loop for item in (data-of orig-layout) + when (not (gfs:disposed-p (first item))) + collect item) + (data-of orig-layout) nil) + (if (typep container 'window) + (setf (data-of self) (mapchildren container (lambda (parent child) + (declare (ignore parent)) + (list child nil)))))))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) - (when (layout-p container) - (arrange-children (compute-layout self container width-hint height-hint) - (lambda (item) - (declare (ignore item)) - +window-pos-flags+)))) + (if (layout-p container) + (arrange-hwnds (compute-layout self container width-hint height-hint) + (lambda (item) + (declare (ignore item)) + +window-pos-flags+)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Fri Aug 18 13:18:48 2006 @@ -40,7 +40,7 @@ (display-visitor-results :initform nil :accessor display-visitor-results) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) + (event-time :initform 0 :accessor event-time) ; FIXME: GetMessageTime (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Aug 18 13:18:48 2006 @@ -50,11 +50,7 @@ (:documentation "Instances of this class employ a layout manager to organize their children.")) (defclass group (layout-managed) - ((children - :accessor children-of - :initarg :children - :initform nil) - (location + ((location :accessor location-of :initarg :location :initform nil) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Aug 18 13:18:48 2006 @@ -219,37 +219,37 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) - (setf (slot-value w 'style) (if (listp style) style (list style)))) +(defmethod initialize-instance :after ((self widget) &key style &allow-other-keys) + (setf (slot-value self 'style) (if (listp style) style (list style)))) -(defmethod location :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod location :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod location ((w widget)) +(defmethod location ((self widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::clientleft gfs::clienttop) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle self) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) (cffi:with-foreign-object (pnt-ptr 'gfs::point) (cffi:with-foreign-slots ((gfs::x gfs::y) pnt-ptr gfs::point) (setf gfs::x gfs::clientleft) (setf gfs::y gfs::clienttop) - (gfs::screen-to-client (gfs:handle w) pnt-ptr) + (gfs::screen-to-client (gfs:handle self) pnt-ptr) (gfs:make-point :x gfs::x :y gfs::y)))))) -(defmethod (setf location) :before ((pnt gfs:point) (w widget)) +(defmethod (setf location) :before ((pnt gfs:point) (self widget)) (declare (ignore pnt)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf location) ((pnt gfs:point) (w widget)) - (if (zerop (gfs::set-window-pos (gfs:handle w) +(defmethod (setf location) ((pnt gfs:point) (self widget)) + (if (zerop (gfs::set-window-pos (gfs:handle self) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) @@ -272,12 +272,12 @@ nil (get-widget (thread-context) hwnd)))) -(defmethod pack :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod pack :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod pack ((w widget)) - (setf (size w) (preferred-size w -1 -1))) +(defmethod pack ((self widget)) + (setf (size self) (preferred-size self -1 -1))) (defmethod parent ((self widget)) ;; Unlike the owner method, this method should Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Aug 18 13:18:48 2006 @@ -58,7 +58,13 @@ (error 'gfs:win32-error :detail "create-window failed")) (if (find :keyboard-navigation (style-of win)) (put-kbdnav-widget tc win)) - (put-widget tc win)))) + (put-widget tc win)) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it breaks in the presence of virtual containers like group + ;; + (let ((parent (parent win))) + (if (and parent (layout-of parent)) + (append-layout-item (layout-of parent) win))))) (defun child-window-visitor (hwnd lparam) (let* ((tc (thread-context))

1 0

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

17 Aug '06

Author: junrue Date: Thu Aug 17 18:53:32 2006 New Revision: 219 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp Log: refactored gfw:perform implementations Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Thu Aug 17 18:53:32 2006 @@ -694,14 +694,16 @@ @node layout types @subsection layout types -@strong{NOTE:} A future release will provide additional layout -manager classes. - @anchor{flow-layout} @deftp Class flow-layout spacing -This @ref{layout-manager} subclass arranges dialog or window children -in a row or column, with optional spacing (specified in pixels) -between children. +This @ref{layout-manager} subclass arranges container children +in a row or column. There are no child-specific layout attributes +defined for this class. +@table @var +@item spacing +A pixel value specifying how far apart each child should be from +the next. +@end table @deffn Initarg :style This initarg accepts a list containing one of the following style keywords: @@ -725,13 +727,15 @@ @anchor{heap-layout} @deftp Class heap-layout top-child This @ref{layout-manager} subclass resizes all children to the same -size and stacks them on top of each other. -@deffn Initarg :top-child +size and stacks them on top of each other. There are no child-specific +layout attributes defined for this class. +@table @var +@item top-child Use this initarg to specify the child widget that should be visible. The corresponding accessor @code{top-child-of} can be set subsequently, followed by calling @ref{layout} on the container, in order to make a different child visible. -@end deffn +@end table @end deftp @anchor{layout-manager} @@ -1741,11 +1745,12 @@ @anchor{layout-attribute} @defun layout-attribute @ref{layout-manager} thing symbol => value (setf (@strong{layout-attribute} @var{layout-manager} @var{thing} @var{symbol}) @var{value})@*@* -This function returns @var{value} if the attribute named by @var{symbol} -is set in @var{layout-manager}; @sc{nil} otherwise. The corresponding -@sc{setf} function allows the attribute to be set. Each layout-manager -subclass supports 0 or more attributes that apply to each @var{thing}. -This function does not restrict application code +Each layout-manager subclass supports 0 or more attributes that apply +to each @var{thing}. This function returns @var{value} if the attribute +named by @var{symbol} is set for @var{thing} in @var{layout-manager}; +it returns @sc{nil} otherwise. The corresponding @sc{setf} function +allows the attribute to be set (note: call @ref{layout} on @var{container} +after doing so). This function does not restrict application code from querying or setting attributes that are not supported by the layout manager. @table @var @@ -1763,22 +1768,22 @@ @end defun @anchor{perform} -@deffn GenericFunction perform @var{layout-manager} container width-hint height-hint -Calls @ref{compute-layout} for @code{container} and then moves and -resizes @code{container}'s children. Layout subclasses may override +@deffn GenericFunction perform @ref{layout-manager} @ref{layout-managed} width-hint height-hint +Calls @ref{compute-layout} for @var{layout-managed} and then moves and +resizes @var{layout-managed}'s children. Subclasses may override this method -- however, most derivations should call @sc{CALL-NEXT-METHOD} to allow the base implementation to execute. @table @var @item layout-manager -The layout object dictating how children of @var{container} +The layout object dictating how children of @var{layout-managed} are to be arranged. @item container -The @var{layout-manager} arranges the elements of @var{container}. +The @var{layout-manager} arranges the elements of @var{layout-managed}. @item width-hint -A hypothetical width value, or negative if @var{container}'s width is +A hypothetical width value, or negative if @var{layout-managed}'s width is not constrained. @item height-hint -A hypothetical height value, or negative if @var{container}'s height is +A hypothetical height value, or negative if @var{layout-managed}'s height is not constrained. @end table @end deffn Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Thu Aug 17 18:53:32 2006 @@ -69,38 +69,11 @@ (cons kid bounds))))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) - (let ((kids nil) - (hdwp (cffi:null-pointer)) - (top (top-child-of self))) - (when (layout-p container) - (setf kids (compute-layout self container width-hint height-hint)) - (unless top - (setf top (car (first kids)))) - (setf hdwp (gfs::begin-defer-window-pos (length kids))) - (loop for k in kids - do (let* ((rect (cdr k)) - (sz (gfs:size rect)) - (pnt (gfs:location rect)) - (kid-win (car k)) - (hwnd-after (cffi:null-pointer)) - (flags (logior +window-pos-flags+ gfs::+swp-hidewindow+))) - (when (cffi:pointer-eq (gfs:handle kid-win) (gfs:handle top)) - (setf flags (logior +window-pos-flags+ gfs::+swp-showwindow+))) - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle kid-win) - hwnd-after - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - flags) - (setf hdwp (gfs::defer-window-pos hdwp - (gfs:handle kid-win) - hwnd-after - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - flags))))) - (unless (gfs:null-handle-p hdwp) - (gfs::end-defer-window-pos hdwp))))) + (let ((top (top-child-of self)) + (kid-specs (compute-layout self container width-hint height-hint))) + (unless top + (setf top (car (first kid-specs)))) + (arrange-children kid-specs (lambda (item) + (if (cffi:pointer-eq (gfs:handle top) (gfs:handle item)) + (logior +window-pos-flags+ gfs::+swp-showwindow+) + (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Thu Aug 17 18:53:32 2006 @@ -63,6 +63,32 @@ (defsetf layout-attribute set-layout-attribute) +(defun arrange-children (kid-specs flags-func) + (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) + (loop for k in kid-specs + for rect = (cdr k) + for size = (gfs:size rect) + for pnt = (gfs:location rect) + do (progn + (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))) + (gfs::defer-window-pos hdwp + (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k)))))) + (unless (gfs:null-handle-p hdwp) + (gfs::end-defer-window-pos hdwp)))) + ;;; ;;; methods ;;; @@ -84,31 +110,8 @@ (bottom-margin-of layout) vertical-margins))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) - "Calls compute-layout for a container and then handles the actual moving and resizing of its children." - (let ((kids nil) - (hdwp (cffi:null-pointer))) - (when (layout-p container) - (setf kids (compute-layout self container width-hint height-hint)) - (setf hdwp (gfs::begin-defer-window-pos (length kids))) - (loop for k in kids - do (let* ((rect (cdr k)) - (sz (gfs:size rect)) - (pnt (gfs:location rect))) - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - +window-pos-flags+) - (setf hdwp (gfs::defer-window-pos hdwp - (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - +window-pos-flags+))))) - (unless (gfs:null-handle-p hdwp) - (gfs::end-defer-window-pos hdwp))))) + (when (layout-p container) + (arrange-children (compute-layout self container width-hint height-hint) + (lambda (item) + (declare (ignore item)) + +window-pos-flags+))))

1 0