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

[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> <p>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.</p> <p>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> <p>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>.</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 + <p>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.</p> + <p>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. <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 - <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>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.</p> + <p>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.</p> <p>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> <p>The supported Windows versions are: <ul> <li>XP SP2</li> - <li>Vista <i>(in progress, testing on Beta 2 currently underway)</i></li> + <li>Vista <i>(testing on Beta 2 currently underway)</i></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 21 Aug '06

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

21 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 20 Aug '06

20 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