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

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

05 Jul '06

Author: junrue Date: Wed Jul 5 15:37:18 2006 New Revision: 178 Added: trunk/src/demos/textedit/ trunk/src/demos/textedit/about.bmp (contents, props changed) trunk/src/demos/textedit/textedit-window.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp Log: started new demo called textedit Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Jul 5 15:37:18 2006 @@ -41,6 +41,7 @@ #:run-image-tester #:run-layout-tester #:run-windlg + #:textedit #:unblocked)) (print "Graphic-Forms UI Toolkit Tests") @@ -58,7 +59,10 @@ :components ((:module "demos" :components - ((:module "unblocked" + ((:module "textedit" + :components + ((:file "textedit-window"))) + (:module "unblocked" :components ((:file "tiles") (:file "unblocked-model") Added: trunk/src/demos/textedit/about.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Jul 5 15:37:18 2006 @@ -0,0 +1,172 @@ +;;;; +;;;; textedit-window.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 *textedit-control* nil) +(defvar *textedit-win* nil) +(defvar *textedit-startup-dir* nil) + +(defun new-textedit-doc (disp item time rect) + (declare (ignore disp item time rect)) + (if *textedit-control* + (setf (gfw:text *textedit-control*) ""))) + +(defun quit-textedit (disp item time rect) + (declare (ignore disp item time rect)) + (setf *textedit-control* nil) + (gfs:dispose *textedit-win*) + (setf *textedit-win* nil) + (gfw:shutdown 0)) + +(defclass textedit-win-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp textedit-win-events) window time) + (declare (ignore window time)) + (quit-textedit disp nil nil nil)) + +(defmethod gfw:event-focus-gain ((self textedit-win-events) window time) + (declare (ignore window time)) + (if *textedit-control* + (gfw:give-focus *textedit-control*))) + +(defclass textedit-about-dialog-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog) time) + (declare (ignore time)) + (call-next-method) + (gfs:dispose dlg)) + +(defun about-textedit (disp item time rect) + (declare (ignore disp item time rect)) + (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*))) + (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 time rect) + (declare (ignore disp btn time rect)) + (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))) + +(defun textedit-startup () +#+clisp + (setf *textedit-startup-dir* (ext:cd)) +#+lispworks + (setf *textedit-startup-dir* (hcl:get-working-directory)) + (let ((menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "&New" :callback #'new-textedit-doc) + (:item "&Open...") + (:item "&Save") + (:item "Save &As...") + (:item "" :separator) + (:item "E&xit" :callback #'quit-textedit))) + (:item "&Edit" + :submenu ((:item "&Undo") + (:item "" :separator) + (:item "Cu&t") + (:item "&Copy") + (:item "&Paste") + (:item "De&lete") + (:item "" :separator) + (:item "&Find...") + (:item "Find &Next") + (:item "&Replace...") + (:item "&Go To...") + (:item "" :separator) + (:item "Select &All"))) + (:item "F&ormat" + :submenu ((:item "&Font...") + (:item "&Word Wrap"))) + (:item "&Help" + :submenu ((:item "&About TextEdit" :callback #'about-textedit))))))) + (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events) + :layout (make-instance 'gfw:heap-layout) + :style '(:frame))) + (setf *textedit-control* (make-instance 'gfw:edit :parent *textedit-win* + :style '(:multi-line + :auto-hscroll :auto-vscroll + :horizontal-scrollbar + :vertical-scrollbar + :want-return))) + (setf (gfw:menu-bar *textedit-win*) menubar) + (setf (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500)) + (gfw:show *textedit-win* t))) + +(defun textedit () + (gfw:startup "TextEdit" #'textedit-startup)) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Wed Jul 5 15:37:18 2006 @@ -89,9 +89,10 @@ (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp" "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp") do (let ((image (make-instance 'gfg:image))) - (gfg:load image (complete-pathname (concatenate 'string - "src/demos/unblocked/" - filename))) + (gfg:load image (merge-pathnames (concatenate 'string + "src/demos/unblocked/" + filename) + (unblocked-startup-dir))) (setf (gethash kind table) image) (incf kind))))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Wed Jul 5 15:37:18 2006 @@ -43,8 +43,8 @@ (defvar *tiles-panel* nil) (defvar *unblocked-win* nil) -(defun complete-pathname (path-segment) - (merge-pathnames path-segment *unblocked-startup-dir*)) +(defun unblocked-startup-dir () + *unblocked-startup-dir*) (defun get-tiles-panel () *tiles-panel*) @@ -107,7 +107,7 @@ (defun about-unblocked (disp item time rect) (declare (ignore disp item time rect)) - (let* ((image (make-instance 'gfg:image :file (complete-pathname "src/demos/unblocked/about.bmp"))) + (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*))) (dlg (make-instance 'gfw:dialog :owner *unblocked-win* :dispatcher (make-instance 'unblocked-about-dialog-events) :layout (make-instance 'gfw:flow-layout @@ -124,7 +124,7 @@ :parent dlg)) (line1 (make-instance 'gfw:label :parent text-panel - :text "UnBlocked version 0.4")) + :text "UnBlocked version 0.5")) (line2 (make-instance 'gfw:label :parent text-panel :text " ")) @@ -160,9 +160,6 @@ (gfs:dispose image)) (gfw:pack dlg) (gfw:center-on-owner dlg) - ;; FIXME: Close button not getting initial focus; looks like - ;; labels or panels are getting it, because I can tab to the - ;; button with enough tabs (gfw:show dlg t))) (defun unblocked-startup () Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Wed Jul 5 15:37:18 2006 @@ -74,6 +74,8 @@ (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))

1 0

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

05 Jul '06

Author: junrue Date: Wed Jul 5 10:55:13 2006 New Revision: 177 Modified: trunk/README.txt trunk/docs/manual/api.texinfo trunk/docs/manual/overview.texinfo trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: added layout-managed base class, modified window and group inheritance accordingly, some initial related refactoring in the layout code Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Jul 5 10:55:13 2006 @@ -15,17 +15,17 @@ - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ - - Cells - http://common-lisp.net/project/cells/ + - Cells (latest from CVS) + http://www.common-lisp.net/project/cells/ - CFFI (cffi-060606 or later) http://common-lisp.net/project/cffi/ - lw-compat - http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar… + http://common-lisp.net/project/closer/downloads.html - Closer to MOP - http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.t… + http://common-lisp.net/project/closer/downloads.html - ImageMagick 6.2.6.5-Q16 http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-window… Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed Jul 5 10:55:13 2006 @@ -524,7 +524,7 @@ @end deftp @anchor{group} -@deftp Class group layout children location size style +@deftp Class group children location size style @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 @@ -606,9 +606,27 @@ @end deffn @end deftp +@anchor{layout-managed} +@deftp Class layout-managed layout layout-p +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. +@end deffn +@deffn Initarg :layout +Accepts a @ref{layout-manager} object whose responsibility is to manage +the direct children of this container. +@end deffn +@deffn Reader layout-p => boolean +Returns T if layout behavior is enabled for this container; +@sc{nil} otherwise. +@end deffn +@end deftp + @anchor{menu} @deftp Class menu -The menu class represents a container for menu items and submenus. It +This class represents a container for menu items and submenus. It derives from @ref{widget-with-items}. @end deftp @@ -732,23 +750,12 @@ @anchor{window} @deftp Class window layout-p layout maximum-size minimum-size -This is the base class for user-defined @ref{widget}s that serve as containers. -@deffn Accessor layout-of -Accepts or returns the @ref{layout-manager} associated with this -@code{window}. -@end deffn +This is the base class for user-defined @ref{widget}s that serve as containers; +it is also a @ref{layout-managed} subclass. @deffn Accessor maximum-size @end deffn @deffn Accessor minimum-size @end deffn -@deffn Initarg :layout -Accepts a @ref{layout-manager} object whose responsibility is to manage -the direct children of this @code{window}. -@end deffn -@deffn Reader layout-p => boolean -Returns T if layout behavior is enabled for the @code{window}; -@sc{nil} otherwise. -@end deffn @deffn Initarg :maximum-size @end deffn @deffn Initarg :minimum-size Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Wed Jul 5 10:55:13 2006 @@ -73,14 +73,14 @@ @item ASDF @url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf} -@item Cells -@url{http://common-lisp.net/project/cells} +@item Cells (latest from CVS) +@url{http://www.common-lisp.net/project/cells/} @item CFFI @url{http://common-lisp.net/project/cffi} @item Closer to MOP -@url{http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.tar.gz} +@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} @@ -89,7 +89,7 @@ @url{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html} @item lw-compat -@url{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz} +@url{http://common-lisp.net/project/closer/downloads.html} @end table Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Wed Jul 5 10:55:13 2006 @@ -68,12 +68,12 @@ (declare (ignore parent)) (cons kid bounds))))) -(defmethod perform ((self heap-layout) win width-hint height-hint) +(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 win) - (setf kids (compute-layout self win width-hint height-hint)) + (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)) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Wed Jul 5 10:55:13 2006 @@ -59,12 +59,12 @@ (setf (top-margin-of layout) vertical-margins) (setf (bottom-margin-of layout) vertical-margins))) -(defmethod perform ((layout layout-manager) win width-hint height-hint) - "Calls compute-layout for a window and then handles the actual moving and resizing of its children." +(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 win) - (setf kids (compute-layout layout win width-hint height-hint)) + (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)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed Jul 5 10:55:13 2006 @@ -39,12 +39,18 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) -(defclass group () - ((layout +(defclass layout-managed () + ((layout-p + :reader layout-p + :initform t) + (layout :accessor layout-of :initarg :layout - :initform nil) - (children + :initform nil)) + (: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) @@ -60,7 +66,7 @@ :accessor style-of :initarg :style :initform nil)) - (:documentation "Instances of this class act as lightweight containers for other objects.")) + (:documentation "Instances of this class act as logical containers for other objects.")) (defclass event-source (gfs:native-object) ((dispatcher @@ -143,15 +149,8 @@ (defclass menu (widget-with-items) () (:documentation "The menu class represents a container for menu items (and submenus).")) -(defclass window (widget) - ((layout-p - :reader layout-p - :initform t) - (layout - :accessor layout-of - :initarg :layout - :initform nil) - (maximum-size +(defclass window (widget layout-managed) + ((maximum-size :accessor maximum-size :initarg :maximum-size :initform nil)

1 0

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

05 Jul '06

Author: junrue Date: Wed Jul 5 00:18:46 2006 New Revision: 176 Modified: trunk/README.txt trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: promoted mapchildren to a widget generic function and cleaned up its semantics, and got rid of with-children at the same time Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Jul 5 00:18:46 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.4.0 +Graphic-Forms README for version 0.5.0 Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed Jul 5 00:18:46 2006 @@ -1107,6 +1107,13 @@ system. @xref{parent}. @end deffn +@deffn GenericFunction mapchildren self func => result-list +Calls @code{func}, which is a function of two arguments, for each +child of @code{self} and places @code{func}'s return value in +@code{result-list}. @code{func}'s two arguments are @code{self} and +the current child. +@end deffn + @anchor{maximum-size} @deffn GenericFunction maximum-size self => size Returns a @ref{size} object describing the largest dimensions to which Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Wed Jul 5 00:18:46 2006 @@ -126,7 +126,7 @@ @titlepage @title Graphic-Forms Programming Reference -@c @subtitle Version 0.4 +@c @subtitle Version 0.5 @c @author Jack D. Unrue @page @@ -136,7 +136,7 @@ @ifnottex @node Top -@top Graphic-Forms Programming Reference (version 0.4) +@top Graphic-Forms Programming Reference (version 0.5) @insertcopying @end ifnottex Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Jul 5 00:18:46 2006 @@ -423,6 +423,7 @@ #:location #:lock #:locked-p + #:mapchildren #:maximize #:maximized-p #:maximum-size @@ -493,7 +494,6 @@ #:vertical-scrollbar #:visible-item-count #:visible-p - #:with-children #:with-file-dialog #:with-font-dialog Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Wed Jul 5 00:18:46 2006 @@ -172,24 +172,29 @@ (defmethod gfw:event-activate ((d child-menu-dispatcher) menu time) (declare (ignore time)) (gfw:clear-all menu) - (gfw:with-children (*layout-tester-win* kids) - (loop for k in kids - do (let ((it (gfw::append-item menu (gfw:text k) nil 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)) - (gfw:check it (funcall (check-test-fn d) k))))))) + (gfw:mapchildren *layout-tester-win* + (lambda (parent child) + (declare (ignore parent)) + (let ((it (gfw::append-item menu (gfw:text child) nil 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)) + (gfw:check it (funcall (check-test-fn d) child))))))) + +(defun find-victim (text) + (let ((victim nil)) + (gfw:mapchildren *layout-tester-win* + (lambda (parent child) + (declare (ignore parent)) + (if (string= (gfw:text child) text) + (setf victim child)))) + victim)) (defclass remove-child-dispatcher (gfw:event-dispatcher) ()) (defmethod gfw:event-select ((d remove-child-dispatcher) item time rect) (declare (ignorable time rect)) - (let ((text (gfw:text item)) - (victim nil)) - (gfw:with-children (*layout-tester-win* kids) - (loop for k in kids - do (if (string= (gfw:text k) text) - (setf victim k)))) + (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfs:dispose victim) (gfw:layout *layout-tester-win*)))) @@ -198,12 +203,7 @@ (defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect) (declare (ignorable time rect)) - (let ((text (gfw:text item)) - (victim nil)) - (gfw:with-children (*layout-tester-win* kids) - (loop for k in kids - do (if (string= (gfw:text k) text) - (setf victim k)))) + (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed Jul 5 00:18:46 2006 @@ -83,10 +83,13 @@ (error 'gfs:disposed-error))) (defmethod cancel-widget ((self dialog)) - (with-children (self kids) - (loop for kid in kids - until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idcancel+) - finally (return kid)))) + (let ((kid nil)) + (mapchildren self + (lambda (parent child) + (declare (ignore parent)) + (if (= (gfs::get-window-long (gfs:handle child) gfs::+gwlp-id+) gfs::+idcancel+) + (setf kid child)))) + kid)) (defmethod (setf cancel-widget) :before ((def-widget widget) (self dialog)) (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) @@ -118,10 +121,13 @@ (error 'gfs:disposed-error))) (defmethod default-widget ((self dialog)) - (with-children (self kids) - (loop for kid in kids - until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idok+) - finally (return kid)))) + (let ((kid nil)) + (mapchildren self + (lambda (parent child) + (declare (ignore parent)) + (if (= (gfs::get-window-long (gfs:handle child) gfs::+gwlp-id+) gfs::+idok+) + (setf kid child)))) + kid)) (defmethod (setf default-widget) :before ((def-widget widget) (self dialog)) (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Wed Jul 5 00:18:46 2006 @@ -171,11 +171,15 @@ ;;; (defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (with-children (win kids) + (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-layout ((layout flow-layout) (win window) width-hint height-hint) - (with-children (win kids) + (let ((kids (mapchildren win (lambda (parent child) + (declare (ignore parent)) + child)))) (flow-container-layout layout (visible-p win) kids width-hint height-hint))) (defmethod initialize-instance :after ((layout flow-layout) &key) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Wed Jul 5 00:18:46 2006 @@ -39,13 +39,13 @@ (defmethod compute-size ((self heap-layout) win width-hint height-hint) (let ((size (gfs:make-size))) - (with-children (win kids) - (loop for kid in kids - do (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)))))) + (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)))))) (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)) @@ -64,8 +64,9 @@ 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))) - (with-children (win kids) - (loop for kid in kids collect (cons kid bounds))))) + (mapchildren win (lambda (parent kid) + (declare (ignore parent)) + (cons kid bounds))))) (defmethod perform ((self heap-layout) win width-hint height-hint) (let ((kids nil) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Jul 5 00:18:46 2006 @@ -204,6 +204,9 @@ (defgeneric locked-p (self) (:documentation "Returns T if this object's contents are locked from being modified.")) +(defgeneric mapchildren (self func) + (:documentation "Executes func for each direct child of self.")) + (defgeneric maximize (self flag) (:documentation "Set the object (or restore it from) the maximized state (not necessarily the same as the maximum size).")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed Jul 5 00:18:46 2006 @@ -61,52 +61,35 @@ (put-kbdnav-widget tc win)) (put-widget tc win)))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro child-visitor-proper (hwnd lparam) + (let ((tc (gensym)) + (tmp-list (gensym)) + (child (gensym)) + (parent (gensym)) + (ancestor-hwnd (gensym))) + `(let* ((,tc (thread-context)) + (,child (get-widget ,tc ,hwnd)) + (,parent (get-widget ,tc (cffi:make-pointer ,lparam)))) + (unless (or (null ,parent) (null ,child)) + (let ((,ancestor-hwnd (gfs::get-ancestor (gfs:handle ,child) gfs::+ga-parent+)) + (,tmp-list (child-visitor-results ,tc))) + (if (cffi:pointer-eq (gfs:handle ,parent) ,ancestor-hwnd) + (setf (child-visitor-results ,tc) (push (call-child-visitor-func ,tc ,parent ,child) ,tmp-list))))))))) + #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) ((hwnd :pointer) (lparam :long)) - (let* ((tc (thread-context)) - (child (get-widget tc hwnd)) - (parent (get-widget tc (cffi:make-pointer lparam)))) - (unless (or (null parent) (null child)) - (call-child-visitor-func tc parent child))) + (child-visitor-proper hwnd lparam) 1) #+clisp (defun child_window_visitor (hwnd lparam) - (let* ((tc (thread-context)) - (child (get-widget tc hwnd)) - (parent (get-widget tc (cffi:make-pointer lparam)))) - (unless (or (null child) (null parent)) - (call-child-visitor-func tc parent child))) + (child-visitor-proper hwnd lparam) 1) -(defun mapchildren (win func) - ;; - ;; supplied closure should expect two parameters: - ;; parent window object - ;; current child widget - ;; - (let ((tc (thread-context))) - (setf (child-visitor-func tc) func) - (unwind-protect -#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle win))) - (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address (gfs:handle win))) -#+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) - (setf ptr (ffi:set-foreign-pointer - (ffi:unsigned-foreign-address - (cffi:pointer-address (gfs:handle win))) - ptr)) - (gfs::enum-child-windows ptr - #'child_window_visitor - (cffi:pointer-address (gfs:handle win)))) - (setf (child-visitor-func tc) nil)) - (let ((tmp (reverse (child-visitor-results tc)))) - (setf (child-visitor-results tc) nil) - tmp))) - (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) @@ -153,17 +136,6 @@ (defun release-mouse () (gfs::release-capture)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro with-children ((win var) &body body) - (let ((hwnd (gensym))) - `(let ((,var (mapchildren ,win (lambda (parent child) - (let ((,hwnd (gfs::get-ancestor - (gfs:handle child) - gfs::+ga-parent+))) - (if (cffi:pointer-eq (gfs:handle parent) ,hwnd) - (push child (child-visitor-results (thread-context))))))))) - ,@body)))) - ;;; ;;; methods ;;; @@ -242,6 +214,28 @@ (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) +(defmethod mapchildren ((self window) func) + (let ((tc (thread-context))) + (setf (child-visitor-func tc) func) + (unwind-protect +#+lispworks + (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle self))) + (fli:make-pointer :symbol-name "child_window_visitor") + (cffi:pointer-address (gfs:handle self))) +#+clisp + (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) + (setf ptr (ffi:set-foreign-pointer + (ffi:unsigned-foreign-address + (cffi:pointer-address (gfs:handle self))) + ptr)) + (gfs::enum-child-windows ptr + #'child_window_visitor + (cffi:pointer-address (gfs:handle self)))) + (setf (child-visitor-func tc) nil)) + (let ((tmp (reverse (child-visitor-results tc)))) + (setf (child-visitor-results tc) nil) + tmp))) + (defmethod (setf maximum-size) :after (max-size (self window)) (unless (or (gfs:disposed-p self) (null (layout-of self))) (let ((size (constrain-new-size max-size (size self) #'min)))

1 0

[graphic-forms-cvs] r175 - tags/release-0.4.0
by junrue＠common-lisp.net 03 Jul '06

03 Jul '06

Author: junrue Date: Mon Jul 3 19:32:35 2006 New Revision: 175 Added: tags/release-0.4.0/ - copied from r174, trunk/ Log: tagging the 0.4.0 release

1 0

[graphic-forms-cvs] r174 - trunk
by junrue＠common-lisp.net 03 Jul '06

03 Jul '06

Author: junrue Date: Mon Jul 3 19:22:32 2006 New Revision: 174 Added: trunk/NEWS.txt Modified: trunk/README.txt Log: more doc updates for 0.4.0 Added: trunk/NEWS.txt ============================================================================== --- (empty file) +++ trunk/NEWS.txt Mon Jul 3 19:22:32 2006 @@ -0,0 +1,97 @@ + +Release 0.4.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: + +. CFFI snapshot 060606 or later is required in order to benefit from a +bugfix for a problem when running on LispWorks where foreign structure +contents could be corrupted; the most obvious symptom of this was a +Win32 error encountered when attempting to create a window. + +. A new layout manager called `heap-layout' has been implemented. Its +purpose is to align all the children of a container in a single +Z-orderwise stack and allow the application to select which of the +children are top-most at any given time. This is useful when +implemnenting windows with panels containing related functionality, +where only one such panel should be visible at a time (e.g., property +sheets or wizard dialogs). + +. This release provides access to the standard font dialog, and +integrates with the previously-defined font and font-data classes. + +. Application-defined modal and modeless dialogs are now fully +supported, including keyboard navigation (tab traversal, default +button invocation via the ENTER key, and cancel button invocation via +the ESC key). + +. In this release, the flow-layout manager gets a new style called +:normalize which instructs the manager to size children equally using +the maximum dimension of the children's preferred sizes opposite to +the dimension in which the layout is oriented. + +. Applications may set minimum size and/or maximum size constraints +for top-level windows. Setting both constraints to the same size +implicitly disables resizing by the user. + +. It is also possible to explicitly disable resizabilty, which not +only results in a fixed window size but also causes window decorations +to be updated appropriately (no maximize box and no resize handles in +the window frame). + +. The button class has been expanded to support checkboxes, radio +buttons, toggle buttons, and tri-state button controls. + +. There is now basic support for instantiating single-line and +multi-line edit controls. Edit controls participate in the focus gain +/ focus loss protocol; they also provide notification when contents +change via the event-modify generic function. + +. Implemented event-focus-gain and event-focus-loss to allow applications +to response to changes in focus. + +. It is now possible to customize the background color, foreground +color, and font of label controls. Infrastructure to support similar +customizations for other controls is in place. + +. Functions capture-mouse and release-mouse are available to implement +mouse capturing behavior. + +. Added a function to programmatically append separators to menus; +this was already possible via DEFMENU but not yet supported for +dynamic menu management. + +. Rewrote timer event processing such that the library no longer uses +the TimerProc callback technique, but instead each call to the Win32 +SetTimer function is made with the handle to a hidden utility window +managed by the library code. + +. Changed the rectangle type to be a structure; it was a class before. + +. Started work on infrastructure required to support a new layout +manager called `group-layout' which will appear in a subsequent +release. The infrastructure developed this time includes definition of +a text-baseline method that widgets implement to help layout managers +align text appropriately. + +. Also started work on infrastructure needed to enable WinXP-themed +controls. + +. Continued work on the UnBlocked demo game. + +The above list is in addition to documentation enhancements and +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.4.0.zip?download + +The project website is: +http://common-lisp.net/project/graphic-forms/ + +Jack Unrue +jdunrue (at) gmail (dot) com +July 3rd 2006 + +============================================================================== Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Jul 3 19:22:32 2006 @@ -18,7 +18,7 @@ - Cells http://common-lisp.net/project/cells/ - - CFFI 0.9.0 + - CFFI (cffi-060606 or later) http://common-lisp.net/project/cffi/ - lw-compat @@ -62,9 +62,9 @@ display properly, expecially when a transparency is selected. 3. The src/demos/unblocked directory contains a start at a demo - program (a simple game where one clicks on block shapes to - score points, where the rest of the blocks fall down to fill - in the gaps). This demo program is not yet finished, but the + 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

1 0

[graphic-forms-cvs] r173 - in trunk/docs: manual website
by junrue＠common-lisp.net 03 Jul '06

03 Jul '06

Author: junrue Date: Mon Jul 3 14:40:32 2006 New Revision: 173 Added: trunk/docs/website/gradient.png (contents, props changed) Modified: trunk/docs/manual/overview.texinfo trunk/docs/website/index.html trunk/docs/website/style.css Log: doc update in preparation for 0.4.0 release Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Mon Jul 3 14:40:32 2006 @@ -11,35 +11,26 @@ @chapter Overview Graphic-Forms is a user interface library implemented in Common Lisp -focusing on the Windows@registeredsymbol{} platform. Graphic-Forms is -licensed under the terms of the BSD License. +focusing on the Windows platform. Graphic-Forms is licensed under the +terms of the BSD License. -Graphic-Forms has two primary goals: - -@itemize @bullet -@item -in the short term, provide a toolkit encapsulating the underlying -window system primitives, custom controls and dialogs, and -platform-specific features - -@item -in the longer-term, implement an application framework on -top of the toolkit -- as an analogy, consider the relationship between -SWT and JFace in the Eclipse framework. -@end itemize - -Support for multiple Common Lisp implementations is planned; see the -project website for up-to-date information on supported vendors and -current known issues. - -Why implement another UI toolkit? The niche for Graphic-Forms is that -it emphasizes the use of Windows@registeredsymbol{} features without -comprising functionality due to portability constraints. Applications -that need portability across windowing systems are already served by -projects such as McCLIM and LTK in the open-source world or the -toolkits provided by commercial vendors. Or you might consider helping -new portable UI projects such as wxCL. This project is aimed -specifically at Windows@registeredsymbol{} developers. +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 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 +GUI developers focused on the Windows platform who want to leverage +platform features without compromises due to portability. + +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. The remainder of this chapter provides basic information for programmers that want to use Graphic-Forms in their projects as well @@ -50,9 +41,30 @@ changes unless and until the interfaces are deemed stable, at which time a policy for backwards compatibility will be published. -The main project website: @* + +@section Project Website + @url{http://common-lisp.net/project/graphic-forms} + +@section Supported Lisp Implementations + +Graphic-Forms is currently developed and tested with: + +@itemize @bullet +@item CLISP 2.38 +@item LispWorks 4.4.6 +@end itemize + + +@section Support Windows Versions + +@itemize @bullet +@item XP SP2 +@item Vista (testing on Beta 2 is in-progress as of this release) +@end itemize + + @section Dependencies The libraries that Graphic-Forms relies upon are: @@ -109,3 +121,10 @@ Please use the following patch tracking mechanism to contribute patches: @url{http://sourceforge.net/tracker/?group_id=163034&atid=826147} + + +@section Trademarks + +Windows@registeredsymbol{} is a registered trademark of Microsoft Corporation. +LispWorks is a trademark of LispWorks Ltd. All other trademarks used are owned +by their respective owners. Added: trunk/docs/website/gradient.png ============================================================================== Binary file. No diff available. Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Mon Jul 3 14:40:32 2006 @@ -10,7 +10,7 @@ <body> <div class="header"> <h1>Graphic-Forms</h1> - <h2>A user interface toolkit for the Windows® platform.</h2> + <h2>A user interface toolkit for the Windows platform.</h2> </div> <div class="NavBar"> @@ -26,42 +26,51 @@ <p>Graphic-Forms is a user interface library implemented in <a href="http://www.lisp.org">Common Lisp</a> focusing on the - Windows® platform. Graphic-Forms is licensed under the + Windows platform. Graphic-Forms is licensed under the terms of the <a href="http://home.earthlink.net/~jdunrue/license.html">BSD License</a>.</p> - <p>In the near term, the goal - is to provide a toolkit encapsulating the underlying - window system primitives, also providing custom controls and dialogs, - and facilitating application use of platform-specific features. A - long-term goal is to implement an application framework on top of - the toolkit -- as an analogy, consider the relationship between SWT - and JFace in the <a href="http://www.eclipse.org">Eclipse</a> - framework. Support for multiple CL implementations is planned, - but at this time development is occurring on - <a href="http://clisp.cons.org">CLISP</a> and - <a href="http://www.lispworks.com">LispWorks</a>®.</p> - - <p>Why implement another UI toolkit? The niche for Graphic-Forms is - that it emphasizes the use of Windows® features without comprising - functionality due to portability constraints. Applications that need - portability across windowing systems are already served by projects - such as - <a href="http://common-lisp.net/project/mcclim/">McCLIM</a> - and - <a href="http://www.peter-herth.de/ltk/">LTK</a> - in the open-source world or the toolkits provided by commercial - vendors. Or you might consider helping new portable UI projects - such as <a href="http://www.wxcl-project.org">wxCL</a>. <i>This - project</i> is aimed specifically at Windows® developers.</p> + <p>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.</p> + <p>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 + <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 + developers focused on the Windows platform who want to leverage + platform features without compromises due to portability. + <p>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.</p> <h3>Status</h3> - <p>The current release is version 0.3.0.</p> + <p>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.</p> - <p>This library is in the early implementation stage. Brave souls who - experiment with the code should expect significant API and - behavior changes in the preliminary releases leading up to the 1.0 release.</p> + <p>The supported Lisp implementations are: + <ul> + <li><a href="http://clisp.cons.org/">CLISP 2.38</a></li> + <li><a href="http://www.lispworks.com/">LispWorks 4.4.6</a></li> + </ul> + + <p>The supported Windows versions are: + <ul> + <li>XP SP2</li> + <li>Vista <i>(in progress, testing on Beta 2 currently underway)</i></li> + </ul> <h3 id="mailinglists">Mailing Lists</h3> <ul> @@ -76,10 +85,15 @@ graphic-forms-announce</a><br>for announcements</li> </ul> - <div class="footer"> - <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> - Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> - </div> + <p><b>Trademarks</b><br> + Windows® is a registered trademark of <a href="http://www.microsoft.com/">Microsoft</a>. + LispWorks is a trademark of <a href="http://www.lispworks.com/">LispWorks Ltd</a>. All other + trademarks used are owned by their respective owners.</p> + + <div class="footer"> + <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> + Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + </div> <!-- <a href="http://sourceforge.net"><IMG src="http://sourceforge.net/sflogo.php?group_id=20959" width="88" height="31" border="0" alt="SourceForge Logo"></a> Modified: trunk/docs/website/style.css ============================================================================== --- trunk/docs/website/style.css (original) +++ trunk/docs/website/style.css Mon Jul 3 14:40:32 2006 @@ -1,11 +1,10 @@ .header { font-size: medium; - background-color:#336699; - color:#ffffff; - border-style:solid; - border-width: 5px; - border-color:#002244; + color:#fafa00; + background-image: url("gradient.png"); + background-repeat: repeat-fixed; + background-attachment: fixed; padding: 1mm 1mm 1mm 5mm; } @@ -13,11 +12,10 @@ font-size: small; font-style: italic; text-align: right; - background-color:#336699; - color:#ffffff; - border-style:solid; - border-width: 2px; - border-color:#002244; + color:#fafa00; + background-image: url("gradient.png"); + background-repeat: repeat-fixed; + background-attachment: fixed; padding: 1mm 1mm 1mm 1mm; }

1 0

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

03 Jul '06

Author: junrue Date: Mon Jul 3 12:31:37 2006 New Revision: 172 Modified: trunk/README.txt trunk/docs/manual/api.texinfo trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp Log: refactored menu item/submenu/separator convenience functions and fixed behavior of :disabled in menu language Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Jul 3 12:31:37 2006 @@ -61,18 +61,13 @@ has not been tested with all of them. Therefore, images may not display properly, expecially when a transparency is selected. -3. The event-tester application's menu definition specifies that the - Test Menu | Submenu | Item A item should be disabled but it does - not get disabled. However, the GFW:ENABLE function does otherwise - work correctly for menu items. - -4. The src/demos/unblocked directory contains a start at a demo +3. The src/demos/unblocked directory contains a start at a demo program (a simple game where one clicks on block shapes to score points, where 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. -5. The text-extent generic function currently does not return +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. Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jul 3 12:31:37 2006 @@ -939,9 +939,11 @@ Returns T if ancestor is an ancestor of descendant; nil otherwise. @end deffn -@deffn GenericFunction append-item self text image dispatcher -Adds the new item with the specified text to the object, and returns -the newly-created 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 @@ -949,8 +951,10 @@ item. @end deffn -@deffn GenericFunction append-submenu self text submenu dispatcher -Adds a submenu anchored to a parent menu and returns the corresponding item. +@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 +be used to set the menu item's initial state. @end deffn @deffn GenericFunction cancel-widget self Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Jul 3 12:31:37 2006 @@ -196,21 +196,16 @@ (push m (menu-stack-of gen)))) (defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image) - (let* ((owner (first (menu-stack-of gen))) - (item (append-item owner label image dispatcher))) - (enable item (not disabled)) - (check item checked))) + (append-item (first (menu-stack-of gen)) label 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))) - (parent (first (menu-stack-of gen))) - (item (append-submenu parent label submenu dispatcher))) - (push submenu (menu-stack-of gen)) - (enable item (not disabled)))) + (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)))) + (append-submenu (first (menu-stack-of gen)) label submenu dispatcher disabled) + (push submenu (menu-stack-of gen)))) (defmethod complete-submenu ((gen win32-menu-generator)) (pop (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 Jul 3 12:31:37 2006 @@ -37,8 +37,14 @@ ;;; helper functions ;;; -(defun insert-menuitem (hmenu mid label hbmp) - (cffi:with-foreign-string (str-ptr label) +(defun insert-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+) + (if hchildmenu gfs::+miim-submenu+))) + (info-type (if label 0 gfs::+mft-separator+)) + (info-state (logior (if checked gfs::+mfs-checked+ 0) + (if disabled gfs::+mfs-disabled+ 0)))) (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type gfs::state gfs::id gfs::hsubmenu @@ -46,69 +52,23 @@ gfs::idata gfs::tdata gfs::cch gfs::hbmpitem) mii-ptr gfs::menuiteminfo) - (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) - (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-string+)) - (setf gfs::type 0) - (setf gfs::state 0) - (setf gfs::id mid) - (setf gfs::hsubmenu (cffi:null-pointer)) - (setf gfs::hbmpchecked (cffi:null-pointer)) - (setf gfs::hbmpunchecked (cffi:null-pointer)) - (setf gfs::idata 0) - (setf gfs::tdata str-ptr) - (setf gfs::cch (length label)) - (setf gfs::hbmpitem hbmp)) - (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) - (error 'gfs::win32-error :detail "insert-menu-item failed"))))) - -(defun insert-submenu (hparent mid label hbmp hchildmenu) - (cffi:with-foreign-string (str-ptr label) - (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) - (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type - gfs::state gfs::id gfs::hsubmenu - gfs::hbmpchecked gfs::hbmpunchecked - gfs::idata gfs::tdata gfs::cch - gfs::hbmpitem) - mii-ptr gfs::menuiteminfo) - (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) - (setf gfs::mask (logior gfs::+miim-id+ - gfs::+miim-string+ - gfs::+miim-submenu+)) - (setf gfs::type 0) - (setf gfs::state 0) - (setf gfs::id mid) - (setf gfs::hsubmenu hchildmenu) - (setf gfs::hbmpchecked (cffi:null-pointer)) - (setf gfs::hbmpunchecked (cffi:null-pointer)) - (setf gfs::idata 0) - (setf gfs::tdata str-ptr) - (setf gfs::cch (length label)) - (setf gfs::hbmpitem hbmp)) - (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) - (error 'gfs::win32-error :detail "insert-menu-item failed"))))) - -(defun insert-separator (hmenu mid) - (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) - (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type - gfs::state gfs::id gfs::hsubmenu - gfs::hbmpchecked gfs::hbmpunchecked - gfs::idata gfs::tdata gfs::cch - gfs::hbmpitem) - mii-ptr gfs::menuiteminfo) - (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) - (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-ftype+)) - (setf gfs::type gfs::+mft-separator+) - (setf gfs::state 0) - (setf gfs::id mid) - (setf gfs::hsubmenu (cffi:null-pointer)) - (setf gfs::hbmpchecked (cffi:null-pointer)) - (setf gfs::hbmpunchecked (cffi:null-pointer)) - (setf gfs::idata 0) - (setf gfs::tdata (cffi:null-pointer)) - (setf gfs::cch 0) - (setf gfs::hbmpitem (cffi:null-pointer))) - (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) - (error 'gfs::win32-error :detail "insert-menu-item failed")))) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo) + gfs::mask info-mask + gfs::type info-type + gfs::state info-state + gfs::id mid + gfs::hsubmenu hchildmenu + gfs::hbmpchecked (cffi:null-pointer) + gfs::hbmpunchecked (cffi:null-pointer) + gfs::idata 0 + gfs::tdata (cffi:null-pointer)) + (if label + (cffi:with-foreign-string (str-ptr label) + (setf gfs::tdata str-ptr) + (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) + (error 'gfs::win32-error :detail "insert-menu-item failed"))) + (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) + (error 'gfs::win32-error :detail "insert-menu-item failed"))))))) (defun sub-menu (m index) (if (gfs:disposed-p m) @@ -130,13 +90,13 @@ ;;; methods ;;; -(defmethod append-item ((owner menu) text image disp) +(defmethod append-item ((owner menu) text image disp &optional disabled checked) (declare (ignore image)) ; FIXME: temporary measure until we support images in menu items (let* ((tc (thread-context)) (id (increment-menuitem-id tc)) (hmenu (gfs:handle owner)) (item (create-menuitem-with-callback hmenu disp))) - (insert-menuitem hmenu id text (cffi:null-pointer)) + (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)) @@ -149,13 +109,13 @@ (id (increment-menuitem-id tc)) (howner (gfs:handle owner)) (item (make-instance 'menu-item :handle howner))) - (insert-separator howner id) + (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)) item)) -(defmethod append-submenu ((parent menu) text (submenu menu) disp) +(defmethod append-submenu ((parent menu) text (submenu menu) disp &optional disabled checked) (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu)) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) @@ -163,7 +123,7 @@ (hparent (gfs:handle parent)) (hmenu (gfs:handle submenu)) (item (make-instance 'menu-item :handle hparent))) - (insert-submenu hparent id text (cffi:null-pointer) hmenu) + (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)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Jul 3 12:31:37 2006 @@ -45,13 +45,13 @@ (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (self text image dispatcher) +(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-separator (self) (:documentation "Add a separator item to the object, and returns the newly-created item.")) -(defgeneric append-submenu (self text submenu dispatcher) +(defgeneric append-submenu (self text submenu dispatcher &optional checked disabled) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) (defgeneric border-width (self) 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 Mon Jul 3 12:31:37 2006 @@ -33,8 +33,8 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher)) - (declare (ignore text image disp)) +(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) + (declare (ignore text image disp checked disabled)) (if (gfs:disposed-p w) (error 'gfs:disposed-error)))

1 0

[graphic-forms-cvs] r171 - trunk/src/demos/unblocked
by junrue＠common-lisp.net 03 Jul '06

03 Jul '06

Author: junrue Date: Mon Jul 3 01:25:20 2006 New Revision: 171 Modified: trunk/src/demos/unblocked/about.bmp Log: finished unblocked about dialog image Modified: trunk/src/demos/unblocked/about.bmp ============================================================================== Binary files. No diff available.

1 0

[graphic-forms-cvs] r170 - in trunk: docs/manual src src/demos/unblocked src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Jul '06

03 Jul '06

Author: junrue Date: Sun Jul 2 23:54:05 2006 New Revision: 170 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented resizable-p, refactored minimum-size/maximum-size methods for top-level windows Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 2 23:54:05 2006 @@ -1221,6 +1221,16 @@ @xref{capture-mouse}. @end deffn +@anchor{resizable-p} +@deffn GenericFunction resizable-p self => 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} +or @code{:workspace} styles are set), allowing the application to +modify the resizability of @code{self}, whereupon the frame +decorations are modified appropriately. +@end deffn + @anchor{show} @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jul 2 23:54:05 2006 @@ -201,9 +201,12 @@ :dispatcher (make-instance 'tiles-panel-events :buffer-size tile-buffer-size))) (setf (gfw:text *unblocked-win*) "Graphic-Forms 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)) + (new-unblocked nil nil nil nil) (gfw:show *unblocked-win* t))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Jul 2 23:54:05 2006 @@ -65,6 +65,7 @@ #:detail #:dispose #:disposed-p + #:equal-size-p #:flatten #:handle #:location Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Sun Jul 2 23:54:05 2006 @@ -46,3 +46,7 @@ (defmacro size (rect) `(rectangle-size ,rect)) + +(defun equal-size-p (size1 size2) + (and (= (size-width size1) (size-width size2)) + (= (size-height size1) (size-height size2)))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Jul 2 23:54:05 2006 @@ -51,6 +51,24 @@ gfs::+cs-dblclks+ -1)) +(defun update-top-level-resizability (win same-size-flag) + (let* ((hwnd (gfs:handle win)) + (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (new-flags 0)) + (cond + (same-size-flag + (setf new-flags (logand orig-flags (lognot gfs::+ws-maximizebox+))) + (setf new-flags (logand new-flags (lognot gfs::+ws-thickframe+)))) + (t + (setf new-flags (logior orig-flags gfs::+ws-maximizebox+)) + (setf new-flags (logior new-flags gfs::+ws-thickframe+)))) + (when (/= orig-flags new-flags) + (gfs::set-window-long hwnd gfs::+gwl-style+ new-flags) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+))))) + ;;; ;;; methods ;;; @@ -132,6 +150,10 @@ (setf register-func #'register-toplevel-erasebkgnd-window-class)) (init-window win classname register-func owner text))) +(defmethod (setf maximum-size) :after (max-size (self top-level)) + (when (and max-size (minimum-size self)) + (update-top-level-resizability self (gfs:equal-size-p (minimum-size self) max-size)))) + (defmethod menu-bar :before ((win top-level)) (if (gfs:disposed-p win) (error 'gfs:disposed-error))) @@ -161,6 +183,10 @@ (gfs::set-menu hwnd (gfs:handle m)) (gfs::draw-menu-bar hwnd))) +(defmethod (setf minimum-size) :after (min-size (self top-level)) + (when (and (maximum-size self) min-size) + (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) + (defmethod print-object ((self top-level) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) @@ -169,17 +195,26 @@ (format stream "min size: ~a " (minimum-size self)) (format stream "max size: ~a" (maximum-size self)))) -(defmethod text :before ((win top-level)) - (if (gfs:disposed-p win) +(defmethod resizable-p ((self top-level)) + (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) + (= (logand bits gfs::+ws-thickframe+) gfs::+ws-thickframe+))) + +(defmethod (setf resizable-p) (flag (self top-level)) + (let ((style (style-of self))) + (if (or (find :frame style) (find :workspace style)) + (update-top-level-resizability self (not flag))))) + +(defmethod text :before ((self top-level)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod text ((win top-level)) - (get-widget-text win)) +(defmethod text ((self top-level)) + (get-widget-text self)) -(defmethod (setf text) :before (str (win top-level)) +(defmethod (setf text) :before (str (self top-level)) (declare (ignore str)) - (if (gfs:disposed-p win) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf text) (str (win top-level)) - (set-widget-text win str)) +(defmethod (setf text) (str (self top-level)) + (set-widget-text self str)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Jul 2 23:54:05 2006 @@ -246,39 +246,46 @@ (format stream "handle: ~x " (gfs:handle self)) (format stream "dispatcher: ~a " (dispatcher self)))) -(defmethod redraw :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod redraw :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod redraw ((w widget)) - (let ((hwnd (gfs:handle w))) +(defmethod redraw ((self widget)) + (let ((hwnd (gfs:handle self))) (unless (gfs:null-handle-p hwnd) (gfs::invalidate-rect hwnd nil 1)))) -(defmethod selected-p :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod resizable-p :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod selected-p ((w widget)) - (declare (ignore w)) +(defmethod resizable-p ((self widget)) nil) -(defmethod size :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod selected-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod selected-p ((self widget)) + (declare (ignore self)) + nil) + +(defmethod size :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod size ((w widget)) - (client-size w)) +(defmethod size ((self widget)) + (client-size self)) -(defmethod (setf size) :before ((size gfs:size) (w widget)) +(defmethod (setf size) :before ((size gfs:size) (self widget)) (declare (ignore size)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf size) ((size gfs:size) (w widget)) - (if (gfs:disposed-p w) +(defmethod (setf size) ((size gfs:size) (self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (if (zerop (gfs::set-window-pos (gfs:handle w) + (if (zerop (gfs::set-window-pos (gfs:handle self) (cffi:null-pointer) 0 0 (gfs:size-width size) @@ -287,13 +294,13 @@ (error 'gfs:win32-error :detail "set-window-pos failed")) size) -(defmethod show :before ((w widget) flag) +(defmethod show :before ((self widget) flag) (declare (ignore flag)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod show ((w widget) flag) - (gfs::show-window (gfs:handle w) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+))) +(defmethod show ((self widget) flag) + (gfs::show-window (gfs:handle self) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+))) (defmethod text-baseline :before ((self widget)) (if (gfs:disposed-p self)

1 0

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

03 Jul '06

Author: junrue Date: Sun Jul 2 21:08:12 2006 New Revision: 169 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented keyboard navigation for windows and modeless dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 2 21:08:12 2006 @@ -679,31 +679,37 @@ boundaries of the window. @end deffn @deffn Initarg :style -The :style initarg is a list of keywords that define the overall +The @code{:style} initarg is a list of keywords that define the overall look-and-feel of the window being created. Applications may choose -from one of the following primary style keywords: +from one of the following primary styles: @table @code @item :borderless -a window with a one-pixel border (so not really @emph{borderless} in the -strictest sense); no frame icon, system menu, minimize/maximize buttons, -or close buttons; the system does not paint the background +Specifies a window with a one-pixel border (so not really @emph{borderless} +in the strictest sense); no frame icon, system menu, minimize/maximize +buttons, or close buttons; the system does not paint the background. @item :frame -the standard top-level frame style with system menu, close box, and -minimize/maximize buttons; this window type is resizable; it differs +Specifies the standard top-level frame style with system menu, close box, +and minimize/maximize buttons; this window type is resizable; it differs from the @code{:workspace} style in that the application is completely -responsible for painting the contents +responsible for painting the contents. @item :miniframe -a resizable window with a shorter than normal caption; has a close box -but no system menu or minimize/maximize buttons; the system does not -paint the background +Specifies a resizable window with a shorter than normal caption; has a +close box but no system menu or minimize/maximize buttons; the system +does not paint the background. @item :palette -similar to the @code{:miniframe} style, but in this case the window -does not have a resize frame; the system does not paint the background +Similar to the @code{:miniframe} style, except that this style also +restricts the window from having a resize frame. @item :workspace -the standard top-level frame style with system menu, close box, and -minimize/maximize buttons; this window type is resizable; it differs +Specifies the standard top-level frame style with system menu, close box, +and minimize/maximize buttons; this window type is resizable; it differs from the @code{:frame} style in that the system paints the background -using the @sc{color_appworkspace} color scheme +using the @sc{color_appworkspace} Win32 color scheme. +@end table +The following style keyword(s) may also be included: +@table @code +@item :keyboard-navigation +Enables keyboard traversal of controls within the @code{window} as if +it were a @ref{dialog}. @end table @end deffn @end deftp @@ -716,8 +722,8 @@ behavior of the widget; style keywords are widget-specific. @end deftp -@anchor{widget-with-items} items -@deftp Class widget-with-items +@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, @@ -725,13 +731,27 @@ @end deftp @anchor{window} -@deftp Class window +@deftp Class window layout-p layout maximum-size minimum-size This is the base class for user-defined @ref{widget}s that serve as containers. -@deffn Reader layout-p +@deffn Accessor layout-of +Accepts or returns the @ref{layout-manager} associated with this +@code{window}. +@end deffn +@deffn Accessor maximum-size +@end deffn +@deffn Accessor minimum-size @end deffn @deffn Initarg :layout +Accepts a @ref{layout-manager} object whose responsibility is to manage +the direct children of this @code{window}. @end deffn -@deffn Accessor layout-of +@deffn Reader layout-p => boolean +Returns T if layout behavior is enabled for the @code{window}; +@sc{nil} otherwise. +@end deffn +@deffn Initarg :maximum-size +@end deffn +@deffn Initarg :minimum-size @end deffn @end deftp Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jul 2 21:08:12 2006 @@ -127,7 +127,7 @@ (defconstant +ccerr-choosecolorcodes+ #x5000) -(defconstant +cderr-dialogfailure+ #xffff) +(defconstant +cderr-dialogfailure+ #xFFFF) (defconstant +cderr-generalcodes+ #x0000) (defconstant +cderr-structsize+ #x0001) (defconstant +cderr-initialization+ #x0002) @@ -138,8 +138,8 @@ (defconstant +cderr-loadresfailure+ #x0007) (defconstant +cderr-lockresfailure+ #x0008) (defconstant +cderr-memallocfailure+ #x0009) -(defconstant +cderr-memlockfailure+ #x000a) -(defconstant +cderr-nohook+ #x000b) +(defconstant +cderr-memlockfailure+ #x000A) +(defconstant +cderr-nohook+ #x000B) (defconstant +cderr-registermsgfail+ #x000C) (defconstant +cf-screenfonts+ #x00000001) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Sun Jul 2 21:08:12 2006 @@ -168,6 +168,7 @@ ;; (if (cffi:pointer-eq (gfs:handle owner) (gfs::get-desktop-window)) (setf owner nil)) + (push :keyboard-navigation (style-of self)) ;; FIXME: check if owner is actually a top-level or dialog, and if not, ;; walk up the ancestors until one is found. Only top level hwnds can ;; be owners. Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sun Jul 2 21:08:12 2006 @@ -50,6 +50,7 @@ (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)) + (kbdnav-widgets :initform nil :accessor kbdnav-widgets) (timers-by-id :initform (make-hash-table :test #'equal)) (top-level-visitor-func :initform nil :accessor top-level-visitor-func) (top-level-visitor-results :initform nil :accessor top-level-visitor-results) @@ -149,6 +150,31 @@ "Store the widget currently under construction." (setf (slot-value tc 'wip) nil)) +(defmethod put-kbdnav-widget ((tc thread-context) (widget widget)) + (if (find :keyboard-navigation (style-of widget)) + (setf (kbdnav-widgets tc) (push widget (kbdnav-widgets tc))))) + +(defmethod remove-kbdnav-widget ((tc thread-context) (widget widget)) + (setf (kbdnav-widgets tc) + (remove-if (lambda (hwnd) (cffi:pointer-eq (gfs:handle widget) hwnd)) + (kbdnav-widgets tc) + :key #'gfs:handle))) + +(defmethod intercept-kbdnav-message ((tc thread-context) msg-ptr) + (let ((widgets (kbdnav-widgets tc))) + (unless widgets + (return-from intercept-kbdnav-message nil)) + (let ((widget (first widgets))) + (if (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0) + (return-from intercept-kbdnav-message widget)) + (setf widget (find-if (lambda (w) (/= (gfs::is-dialog-message (gfs:handle w) msg-ptr))) + (rest widgets))) + (when (and widget (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0)) + (let ((tmp (remove-kbdnav-widget tc widget))) + (setf (kbdnav-widgets tc) (push widget tmp))) + (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))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Jul 2 21:08:12 2006 @@ -81,7 +81,7 @@ (defclass widget (event-source) ((style - :reader style-of + :accessor style-of :initarg :style :initform nil)) (:documentation "The widget class is the base class for all windowed user interface objects.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Jul 2 21:08:12 2006 @@ -48,6 +48,8 @@ ((= gm-code -1) (warn 'gfs:win32-warning :detail "get-message failed") t) + ((intercept-kbdnav-message (thread-context) msg-ptr) + nil) (t (translate-and-dispatch msg-ptr) nil))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Jul 2 21:08:12 2006 @@ -57,6 +57,8 @@ (let ((hwnd (gfs:handle win))) (if (not hwnd) ; handle slot should have been set during create-window (error 'gfs:win32-error :detail "create-window failed")) + (if (find :keyboard-navigation (style-of win)) + (put-kbdnav-widget tc win)) (put-widget tc win)))) #+lispworks @@ -191,6 +193,10 @@ (gfs:size-height new-size) (- gfs::bottom gfs::top))) new-size)) +(defmethod gfs:dispose ((self window)) + (remove-kbdnav-widget (thread-context) self) + (call-next-method)) + (defmethod enable-layout :before ((win window) flag) (declare (ignore flag)) (if (gfs:disposed-p win)

1 0