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

[graphic-forms-cvs] r64 - trunk/docs/manual
by junrue＠common-lisp.net 21 Mar '06

21 Mar '06

Author: junrue Date: Tue Mar 21 18:36:21 2006 New Revision: 64 Added: trunk/docs/manual/api.texinfo - copied, changed from r62, trunk/docs/manual/packages.texinfo Removed: trunk/docs/manual/packages.texinfo Modified: trunk/docs/manual/overview.texinfo trunk/docs/manual/reference.texinfo Log: programming manual updated content Copied: trunk/docs/manual/api.texinfo (from r62, trunk/docs/manual/packages.texinfo) ============================================================================== --- trunk/docs/manual/packages.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 21 18:36:21 2006 @@ -5,40 +5,628 @@ @c Copyright (c) 2006, Jack D. Unrue @c =================================================================== -@c CHAPTER: Packages +@c CHAPTER: API -@node Packages -@chapter Packages +@node API +@chapter API -General comments about the packages. +This chapter documents the Graphic-Forms programming interface. All +of the package names are prefixed with @code{graphic-forms.uitoolkit}. -@section Graphics -@cindex Graphics Package +@section graphics package +@cindex graphics package Nickname: GFG This package represents graphical functionality, particularly drawing operations. Support for the ImageMagick library is defined here. This -package along with GFW constitute the bulk of the public API for -Graphic-Forms. +package and GFW together constitute the bulk of the public API. -@section System -@cindex System Package +@menu +* graphics types:: Documentation of the graphics types. +* graphics functions:: Documentation of the graphics methods and functions. +@end menu + + +@section system package +@cindex system package Nickname: GFS The symbols in this package correspond to system-level functionality, examples of which include bindings for Win32 API functions and associated -constants. +constants. The majority of the symbols herein are not exported, except for +a few fundamental types and methods + +@menu +* system types:: Documentation of the system types. +* system functions:: Documentation of the system functions. +* system conditions:: Documentation of the system conditions. +@end menu + -@section Tests -@cindex Tests Package +@section tests package +@cindex tests package -This package contains the symbols corresponding to test programs. +Nickname: GFT -@section Widgets -@cindex Widgets Package +This package contains the symbols corresponding to test programs. No +symbols are exported. + + +@section widgets package +@cindex widgets package + +Nickname: GFW This package contains symbols for all of the widgets, event methods, and other UI objects defined by Graphic-Forms. This package and GFG together constitute the bulk of the public API. + +@menu +* widget types:: Documentation of the widget types. +* layout types:: Documentation of the pre-defined layout manager classes. +* widget functions:: Documentation of the widget methods and functions. +* event functions:: Documentation of event-handling functions. +* layout functions:: Documentation of layout manager functions. +@end menu + + +@node system types +@section system types + +@anchor{native-object} +@deftp Class native-object handle +This class encapsulates a Win32 object handle, which is technically a +foreign pointer but should be treated as an opaque cookie. +@deffn Initarg :handle +@end deffn +@deffn Reader handle +@end deffn +@end deftp + +@anchor{point} +@deftp Structure point x y z +This structure represents a point in the Cartesian coordinate system. +@end deftp + +@anchor{rectangle} +@deftp Class rectangle location size +This class identifies a region in the Cartesian coordinate system +consisting of an upper-left coordinate and bounds. See @ref{point} and +@ref{size}. +@deffn Initarg :location +@end deffn +@deffn Initarg :size +@end deffn +@deffn Accessor location +@end deffn +@deffn Accessor size +@end deffn +@end deftp + +@anchor{size} +@deftp Structure size width height depth +This structure represents an area or volume. +@end deftp + +@anchor{span} +@deftp Structure span start end +This structure represents a range of values or times in a collection. +@end deftp + + +@node system functions +@section system functions + +@anchor{dispose} +@deffn GenericFunction dispose self +This function is called to discard the underlying native @var{handle} +and execute any other necessary cleanup code. +@end deffn + +@deffn GenericFunction disposed-p self +Returns T if @ref{dispose} has been called on @var{self} and the +object has not since been re-initialized; returns nil otherwise. +This function also returns T if @var{self} has been instantiated +but secondary initialization code has not yet executed. +@end deffn + +@deffn Function make-point :x :y :z +This function creates a new @ref{point} object. +@end deffn + +@deffn Function make-size :width :height :depth +This function creates a new @ref{size} object. +@end deffn + +@deffn Function make-span :start :end +This function creates a new @ref{span} object. +@end deffn + + +@node system conditions +@section system conditions + +@anchor{toolkit-error} +@deftp Condition toolkit-error detail +Error conditions originating from Graphic-Forms library code (as opposed +to system errors) are reported by raising this condition. The detail slot +is a string that describes the error in more detail. +@deffn Initarg :detail +@end deffn +@deffn Reader detail +@end deffn +@end deftp + +@deftp Condition win32-error +This condition is a subclass of toolkit-error that is used by the +library to report system-level errors. @xref{toolkit-error}. +@deffn Initarg :code +@end deffn +@deffn Reader code +@end deffn +@end deftp + + +@node widget types +@section widget types + +@strong{NOTE:} A future release will provide additional widget +classes. + +@deftp Class button +This @ref{control} class represents selectable controls that issue +notifications when clicked. +@end deftp + +@anchor{control} +@deftp Class control +The base class for widgets having pre-defined native behavior. It derives from +@ref{widget}. +@end deftp + +@deftp Class event-dispatcher +This is the base class for objects process events on behalf of user interface objects. +@end deftp + +@anchor{event-source} +@deftp Class event-source dispatcher +This is the base class for user interface objects that generate events. It +derives from @ref{native-object}. +@deffn Initarg :dispatcher +@end deffn +@deffn Accessor dispatcher +@end deffn +@end deftp + +@anchor{item} +@deftp Class item +The item class is the base class for all non-windowed user interface objects. +@deffn Initarg :item-id +@end deffn +@deffn Accessor item-id +@end deffn +@end deftp + +@deftp Class label +This @ref{control} class represents non-selectable controls that +display a string or image. +@end deftp + +@deftp Class menu +The menu class represents a container for menu items and submenus. It +derives from @ref{widget-with-items}. +@end deftp + +@deftp Class menu-item +A subclass of @ref{item} representing a menu item. +@end deftp + +@deftp Class panel +Base class for @ref{window}s that are children of @ref{top-level} @ref{window}s (or +other panels). +@end deftp + +@deftp Class timer +A timer is a non-windowed object that generates events at a regular (adjustable) frequency. +It derives from @ref{event-source}. +@deffn Reader id-of +@end deffn +@deffn Initarg :initial-delay +@end deffn +@deffn Reader initial-delay +@end deffn +@deffn Initarg :delay +@end deffn +@deffn Accessor delay +@end deffn +@end deftp + +@anchor{top-level} +@deftp Class top-level +Base class for @ref{window}s that can be moved and resized by the +user, and which normally have title bars. +@end deftp + +@anchor{widget} +@deftp Class widget +The widget class is the base class for all windowed user interface objects. It +derives from @ref{event-source}. +@end deftp + +@anchor{widget-with-items} +@deftp Class widget-with-items +The widget-with-items class is the base class for objects composed of sub-items. +It derives from @ref{widget}. +@deffn Initarg :items +@end deffn +@deffn Accessor items +@end deffn +@end deftp + +@anchor{window} +@deftp Class window +This is the base class for user-defined @ref{widget}s that serve as containers. +@deffn Reader layout-p +@end deffn +@deffn Initarg :layout +@end deffn +@deffn Accessor layout +@end deffn +@end deftp + + +@node layout types +@section layout types + +@strong{NOTE:} A future release will provide additional layout +manager classes. + +@anchor{layout-manager} +@deftp Class layout-manager style +Subclasses implement layout strategies on behalf of window objects. +@end deftp + +@anchor{flow-layout} +@deftp Class flow-layout spacing left-margin top-margin right-margin bottom-margin +This @ref{layout-manager} subclass arranges window children in a row +or column, with optional margins around the row/column and spacing in +between children. The layout can wrap the window children if desired +and the available horizontal (or vertical) space is constrained. +@end deftp + + +@node event functions +@section event functions + +@strong{NOTE:} There are (and will be) additional event methods defined +in future releases, they just aren't all documented or implemented at +this time. + +@deffn GenericFunction event-activate dispatcher widget time +Implement this to respond to an object being activated. +@end deffn + +@deffn GenericFunction event-arm dispatcher item time +Implement this to respond to an object about to be selected. +@end deffn + +@deffn GenericFunction event-close dispatcher widget time +Implement this to respond to an object being closed. +@end deffn + +@deffn GenericFunction event-dispose dispatcher widget time +Implement this to respond to an object being disposed (via +@ref{dispose}, not the garbage collector). +@end deffn + +@deffn GenericFunction event-key-down dispatcher widget time keycode char +Implement this to respond to a key down event. +@end deffn + +@deffn GenericFunction event-key-up dispatcher widget time keycode char +Implement this to respond to a key up event. +@end deffn + +@deffn GenericFunction event-mouse-double dispatcher widget time point button +Implement this to respond to a mouse double-click. +@end deffn + +@deffn GenericFunction event-mouse-down dispatcher widget time point button +Implement this to respond to a mouse down event. +@end deffn + +@deffn GenericFunction event-mouse-enter dispatcher widget time point button +Implement this to respond to a mouse passing into the bounds of an object. +@end deffn + +@deffn GenericFunction event-mouse-exit dispatcher widget time point button +Implement this to respond to a mouse leaving the bounds an object. +@end deffn + +@deffn GenericFunction event-mouse-hover dispatcher widget time point button +Implement this to respond to a mouse that stops moving for a period of time within an object. +@end deffn + +@deffn GenericFunction event-mouse-move dispatcher widget time point button +Implement this to respond to a mouse move event. +@end deffn + +@deffn GenericFunction event-mouse-up dispatcher widget time point button +Implement this to respond to a mouse up event. +@end deffn + +@deffn GenericFunction event-move dispatcher widget time point +Implement this to respond to an object being moved within its parent's coordinate system. +@end deffn + +@anchor{event-paint} +@deffn GenericFunction event-paint dispatcher widget time gc rect +Implement this to respond to paint requests. +@end deffn + +@deffn GenericFunction event-pre-modify dispatcher widget time keycode char span new-content +Implement this to respond to content (e.g., text) in an object about to be modified. +@end deffn + +@deffn GenericFunction event-resize dispatcher widget time size type +Implement this to respond to an object being resized. +@end deffn + +@deffn GenericFunction event-select dispatcher item time rect +Implement this to respond to an object (or item within) being selected. +@end deffn + +@deffn GenericFunction event-timer dispatcher timer time +Implement this to respond to a tick from a specific timer. +@end deffn + + +@node widget functions +@section widget functions + +@strong{NOTE:} There are (and will be) additional widget methods defined +in future releases, they just aren't all documented or implemented at +this time. + +@deffn GenericFunction ancestor-p ancestor descendant +Returns T if ancestor is an ancestor of descendant; nil otherwise. +@end deffn + +@deffn GenericFunction append-item object text image dispatcher +Adds the new item with the specified text to the object, and returns the newly-created item. +@end deffn + +@deffn GenericFunction append-submenu object text submenu dispatcher +Adds a submenu anchored to a parent menu and returns the corresponding item. +@end deffn + +@deffn GenericFunction check object flag +Sets the object into the checked state. +@end deffn + +@deffn GenericFunction checked-p object +Returns T if the object is in the checked state; nil otherwise. +@end deffn + +@deffn GenericFunction clear-item object index +Clears the item at the zero-based index. +@end deffn + +@deffn GenericFunction clear-span object sp +Clears the items whose zero-based indices lie within the specified span. +@end deffn + +@deffn GenericFunction client-size object +Returns a size object that describes the region of the object that can be drawn within or can display data. +@end deffn + +@deffn GenericFunction compute-style-flags object &rest style +Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports. +@end deffn + +@deffn GenericFunction compute-outer-size object desired-client-size +Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim. +@end deffn + +@deffn GenericFunction display-to-object object pnt +Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system. +@end deffn + +@deffn GenericFunction enable object flag +Enables or disables the object, causing it to be redrawn with its default look and allows it to be selected. +@end deffn + +@deffn GenericFunction enable-layout object flag +Cause the object to allow or disallow layout management. +@end deffn + +@deffn GenericFunction enabled-p object +Returns T if the object is enabled; nil otherwise. +@end deffn + +@deffn GenericFunction item-at object index +Return the item at the given zero-based index from the object. +@end deffn + +@deffn GenericFunction item-count object +Return the number of items possessed by the object. +@end deffn + +@deffn GenericFunction item-index object item +Return the zero-based index of the location of the other object in this object. +@end deffn + +@deffn GenericFunction item-owner item +Return the widget containing this item. +@end deffn + +@deffn GenericFunction layout object +Set the size and location of this object's children. +@end deffn + +@deffn GenericFunction location object +Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system. +@end deffn + +@deffn GenericFunction menu-bar object +Returns the menu object serving as the menubar for this object. +@end deffn + +@deffn GenericFunction object-to-display object pnt +Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates. +@end deffn + +@anchor{pack} +@deffn GenericFunction pack object +Causes the object to be resized to its preferred size. +@end deffn + +@deffn GenericFunction parent object +Returns the object's parent. +@end deffn + +@deffn GenericFunction preferred-size object width-hint height-hint +Returns a size object representing the object's 'preferred' size. +@end deffn + +@deffn GenericFunction redraw object +Causes the entire bounds of the object to be marked as needing to be redrawn +@end deffn + +@deffn GenericFunction running-p object +Returns T if the object is in event generation mode; nil otherwise. +@end deffn + +@deffn GenericFunction show object flag +Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order. +@end deffn + +@deffn GenericFunction size object +Returns a size object describing the size of the object in its parent's coordinate system. +@end deffn + +@deffn GenericFunction start object +Enable event generation at regular intervals. +@end deffn + +@deffn GenericFunction stop object +Stop producing events. +@end deffn + +@deffn GenericFunction text object +Returns the object's text. +@end deffn + +@deffn GenericFunction update object +Forces all outstanding paint requests for the object to be processed before this function returns. +@end deffn + +@deffn GenericFunction visible-p object +Returns T if the object is visible (not necessarily top-most); nil otherwise. +@end deffn + + +@node layout functions +@section layout functions + +@deffn GenericFunction compute-layout layout window width-hint height-hint +Returns a list of conses @code{(window . rectangle)} describing the +new bounds of each child window or control. A @ref{layout-manager} subclass +implements this method based on its particular layout strategy, taking +into account attributes set by the user. Certain Graphic-Forms functions +call this method to accomplish layout within a window. +@end deffn + +@deffn GenericFunction compute-size layout window width-hint height-hint +Computes and returns the new @ref{size} of the window's client area. A +@ref{layout-manager} subclass implements this method based on its +particular layout strategy, taking into account attributes set by the +user. The @ref{pack} function ultimately calls this method. +@end deffn + + +@node graphics types +@section graphics types + +@strong{NOTE:} A future release will provide additional graphics +classes. + +@deftp Structure color red green blue +This is a structure representing a color using three bytes in the RGB colorspace. +@end deftp + +@anchor{font} +@deftp Class font +This subclass of @ref{native-object} encapsulates a native font +object. @xref{font-metrics}. +@end deftp + +@anchor{font-metrics} +@deftp Structure font-metrics ascent descent leading avg-char-width max-char-width +This structure describes basic attributes of a font in terms that drawing code +may use to position graphical elements. @xref{font}. +@end deftp + +@deftp Class graphics-context +This subclass of @ref{native-object} wraps a native device context, +hence instances of this class are used to perform drawing operations. +One normally obtains a graphics-context via @ref{event-paint}. +@end deftp + +@deftp Class image-data +This subclass of @ref{native-object} maintains image attributes, +color, and pixel data. +@end deftp + +@node graphics functions +@section graphics functions + +@strong{NOTE:} There are (and will be) additional event methods defined +in future releases, they just aren't all documented or implemented at +this time. + +@deffn GenericFunction background-color object +Returns a color object corresponding to the current background color. +@end deffn + +@deffn GenericFunction data-obj object +Returns the data structure representing the raw form of the object. +@end deffn + +@deffn GenericFunction depth object +Returns the bits-per-pixel depth of the object. +@end deffn + +@deffn GenericFunction draw-filled-rectangle object rect +Fills the interior of the rectangle in the current background color. +@end deffn + +@deffn GenericFunction draw-image object im pnt +Draws the given image in the receiver at the specified coordinates. +@end deffn + +@deffn GenericFunction draw-text object text pnt +Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string. +@end deffn + +@deffn GenericFunction font object +Returns the current font. +@end deffn + +@deffn GenericFunction foreground-color object +Returns a color object corresponding to the current foreground color. +@end deffn + +@deffn GenericFunction metrics object +Returns a metrics object describing key attributes of the specified object. +@end deffn + +@deffn GenericFunction size object +Returns a size object describing the size of the object. +@end deffn + +@deffn GenericFunction transparency-mask object +Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency. +@end deffn Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Tue Mar 21 18:36:21 2006 @@ -51,7 +51,7 @@ time a policy for backwards compatibility will be published. The main project website: @* -@indicateurl{http://common-lisp.net/project/graphic-forms} +@url{http://common-lisp.net/project/graphic-forms} @section Dependencies @@ -59,47 +59,50 @@ @table @code @item ASDF -@indicateurl{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf} +@url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf} @item CFFI -@indicateurl{http://common-lisp.net/project/cffi} +@url{http://common-lisp.net/project/cffi} @item lw-compat -@indicateurl{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz} +@url{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz} @item Closer to MOP -@indicateurl{http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.tar.gz} +@url{http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.tar.gz} @item ImageMagick -@indicateurl{http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows-dll.exe} +@url{http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows-dll.exe} @item lisp-unit -@indicateurl{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html} +@url{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html} @end table @section Building the Library and Running Tests -For the time being, please see the @code{README.txt} file included in the +Please see the @code{README.txt} file included in the distribution for instructions on how to load the ASDF system and run tests. -@section Mailing Lists and Bug Reports +@section Support + + +@subsection Mailing Lists and Bug Reports Announcements mailing list: @* -@indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-announce} +@url{http://www.common-lisp.net/mailman/listinfo/graphic-forms-announce} Developer mailing list (for both users and maintainers): @* -@indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel} +@url{http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel} Source control log mailing list: @* -@indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-cvs} +@url{http://www.common-lisp.net/mailman/listinfo/graphic-forms-cvs} The bug tracking system: @* -@indicateurl{http://sourceforge.net/tracker/?group_id=20959&atid=120959} +@url{http://sourceforge.net/tracker/?group_id=20959&atid=120959} -@section Submitting Patches +@subsection Submitting Patches Please use the SourceForge patch tracking mechanism to contribute patches: -@indicateurl{http://sourceforge.net/tracker/?atid=826147&group_id=163034&func=browse} +@url{http://sourceforge.net/tracker/?atid=826147&group_id=163034&func=browse} Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Tue Mar 21 18:36:21 2006 @@ -10,6 +10,8 @@ @settitle Graphic-Forms Programming Reference @exampleindent 2 + + @c ============================= Macros ============================= @macro Function {args} @@ -27,6 +29,11 @@ @end deffn @end macro +@macro Reader {args} +@deffn {Reader} \args\ +@end deffn +@end macro + @macro GenericFunction {args} @deffn {Generic Function} \args\ @end deffn @@ -84,12 +91,6 @@ @c ==========================End Macros ============================= -@c Coallesce all the index types into one master index. -@syncodeindex fn cp -@syncodeindex ky cp -@syncodeindex tp cp -@syncodeindex vr cp - @copying Copyright @copyright{} 2006, Jack D. Unrue <jdunrue at gmail.com> @* @@ -135,7 +136,7 @@ @ifnottex @node Top -@top Graphic-Forms Programming Reference +@top Graphic-Forms Programming Reference (version 0.2.0) @insertcopying @end ifnottex @@ -143,25 +144,30 @@ @menu * Overview:: Basic information about Graphic-Forms. -* Packages:: Summary of the library packages. +* API:: Documentation of the library API. * Miscellaneous Topics:: Various topics germane to Windows programming and Graphic-Forms. * Glossary:: Terms and definitions. -* Master Index:: +* Types Index:: +* Function Index:: @end menu @contents @include overview.texinfo -@include glossary.texinfo -@include packages.texinfo +@include api.texinfo @include miscellaneous.texinfo +@include glossary.texinfo @c =================================================================== @c Index -@node Master Index -@unnumbered Master Index -@printindex cp +@node Types Index +@unnumbered Types Index +@printindex tp + +@node Function Index +@unnumbered Function Index +@printindex fn @bye

1 0

[graphic-forms-cvs] r63 - trunk
by junrue＠common-lisp.net 21 Mar '06

21 Mar '06

Author: junrue Date: Tue Mar 21 13:20:13 2006 New Revision: 63 Modified: trunk/build.lisp trunk/config.lisp trunk/tests.lisp Log: more build system cleanup Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Tue Mar 21 13:20:13 2006 @@ -36,7 +36,7 @@ ;;; public use. ;;; -(load "config.lisp") +(load "c:/projects/public/graphic-forms/config.lisp") (in-package #:graphic-forms-system) @@ -51,40 +51,10 @@ (setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) (setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) -(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") (defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) -(defvar *library-build-root* (concatenate 'string *library-root* "build/")) -(defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/")) -(defvar *closer-mop-build-dir* (concatenate 'string *library-build-root* "closer-mop/")) -(defvar *lw-compat-build-dir* (concatenate 'string *library-build-root* "lw-compat/")) - -(defvar *build-dirs* (list *cffi-build-dir* - *closer-mop-build-dir* - *lw-compat-build-dir* - *gf-build-dir*)) - (defun build () - + (setf cl-user::*asdf-cache* "c:/projects/public/build/") (configure-asdf) - - (when *external-build-dirs* - (mapc #'(lambda (dir-str) (ensure-directories-exist (parse-namestring dir-str))) *build-dirs*)) - -#| - (if *external-build-dirs* - (chdir *cffi-build-dir*)) - (asdf:operate 'asdf:load-op :cffi) - - (if *external-build-dirs* - (chdir *lw-compat-build-dir*)) - (asdf:operate 'asdf:load-op :lw-compat) - - (if *external-build-dirs* - (chdir *closer-mop-build-dir*)) - (asdf:operate 'asdf:load-op :closer-mop) -|# - - (if *external-build-dirs* - (chdir *gf-build-dir*)) + (pushnew *gf-dir* asdf:*central-registry* :test #'equal) (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit)) Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Tue Mar 21 13:20:13 2006 @@ -37,8 +37,6 @@ (in-package #:graphic-forms-system) -(defvar *external-build-dirs* nil) - (defvar *cffi-dir* "cffi-0.9.0/") (defvar *closer-mop-dir* "closer-mop/") (defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Tue Mar 21 13:20:13 2006 @@ -36,7 +36,5 @@ (load (compile-file *lisp-unit-file*)) (defun load-tests () - (if *external-build-dirs* - (chdir *gf-build-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests) (chdir *gf-tests-dir*))

1 0

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

21 Mar '06

Author: junrue Date: Tue Mar 21 03:00:29 2006 New Revision: 62 Added: trunk/docs/manual/miscellaneous.texinfo Modified: trunk/README.txt trunk/build.lisp trunk/docs/manual/glossary.texinfo trunk/docs/manual/overview.texinfo trunk/docs/manual/packages.texinfo trunk/docs/manual/reference.texinfo Log: documentation updates Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Tue Mar 21 03:00:29 2006 @@ -6,6 +6,12 @@ on the Windows(R) platform. Graphic-Forms is licensed under the terms of the BSD License. +Please provide feedback via the development mailing list: + http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel + +and/or patches via the patch tracker: + http://sourceforge.net/tracker/?atid=826147&group_id=163034&func=browse + Dependencies ------------ @@ -44,7 +50,7 @@ 4. Load ASDF into your Lisp image if it is not already present. -5. Execute the following forms from your REPL ( +5. Execute the following forms from your REPL (load "config.lisp") @@ -53,9 +59,9 @@ ;; (setf gfsys::*imagemagick-dir* "c:/path/to/your/ImageMagick/install/") - ;; Update these variables as needed for your specific environment to + ;; setf 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 these variables to nil. + ;; image already has these systems loaded, set the variables to nil. ;; ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* @@ -94,7 +100,11 @@ (asdf:operate 'asdf:load-op :graphic-forms-tests) - (chdir "c:/some/path/graphic-forms/src/tests/uitoolkit/") + ;; Change the working directory to the uitoolkit tests + ;; directory. + ;; + + (chdir "c:/example/path/graphic-forms/src/tests/uitoolkit/") ;; then execute one or more of the following: ;; Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Tue Mar 21 03:00:29 2006 @@ -31,11 +31,16 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; +;;; NOTE: This is local build configuration that I (Jack Unrue) +;;; use for development purposes only. It's not intended for +;;; public use. +;;; + (load "config.lisp") (in-package #:graphic-forms-system) -(defvar *library-root* "c:/third_party/") +(defvar *library-root* "c:/projects/third_party/") (defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) (defvar *project-root* "c:/projects/public/") @@ -44,6 +49,7 @@ (setf *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) (setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) +(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) (defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") (defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Tue Mar 21 03:00:29 2006 @@ -10,20 +10,23 @@ @node Glossary @chapter Glossary -Terms and definitions. +Terms and definitions. Content will be added in due time. @table @samp @item control -A control is a thing. +@cindex control +A control is a system-defined window class that accepts user input +and/or generates notification events. @item dialog -A dialog is something else. +@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. @item menu +@cindex menu A collection of menu items. @end table - -@cindex control -@cindex dialog -@cindex menu Added: trunk/docs/manual/miscellaneous.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/miscellaneous.texinfo Tue Mar 21 03:00:29 2006 @@ -0,0 +1,13 @@ + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@c =================================================================== +@c CHAPTER: Miscellaneous Topics + +@node Miscellaneous Topics +@chapter Miscellaneous Topics + +@strong{TBD} Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Tue Mar 21 03:00:29 2006 @@ -43,15 +43,45 @@ The remainder of this chapter provides basic information for programmers that want to use Graphic-Forms in their projects as well -as maintainers/contributors. +as contributors. + +@strong{Caution:} The information provided in this manual is subject +to change. The author and contributors reserve the right to make API +changes unless and until the interfaces are deemed stable, at which +time a policy for backwards compatibility will be published. The main project website: @* @indicateurl{http://common-lisp.net/project/graphic-forms} - @section Dependencies -The libraries that Graphic-Forms relies upon. +The libraries that Graphic-Forms relies upon are: + +@table @code +@item ASDF +@indicateurl{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf} + +@item CFFI +@indicateurl{http://common-lisp.net/project/cffi} + +@item lw-compat +@indicateurl{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz} + +@item Closer to MOP +@indicateurl{http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.tar.gz} + +@item ImageMagick +@indicateurl{http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows-dll.exe} + +@item lisp-unit +@indicateurl{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html} +@end table + + +@section Building the Library and Running Tests + +For the time being, please see the @code{README.txt} file included in the +distribution for instructions on how to load the ASDF system and run tests. @section Mailing Lists and Bug Reports @@ -72,8 +102,4 @@ @section Submitting Patches Please use the SourceForge patch tracking mechanism to contribute patches: - - -@section Running the Library Tests - -How to run unit-tests and ad-hoc tests. +@indicateurl{http://sourceforge.net/tracker/?atid=826147&group_id=163034&func=browse} Modified: trunk/docs/manual/packages.texinfo ============================================================================== --- trunk/docs/manual/packages.texinfo (original) +++ trunk/docs/manual/packages.texinfo Tue Mar 21 03:00:29 2006 @@ -12,17 +12,33 @@ General comments about the packages. -@section Intrinsics -@cindex Intrinsics Package - @section Graphics @cindex Graphics Package +Nickname: GFG + +This package represents graphical functionality, particularly drawing +operations. Support for the ImageMagick library is defined here. This +package along with GFW constitute the bulk of the public API for +Graphic-Forms. + @section System @cindex System Package +Nickname: GFS + +The symbols in this package correspond to system-level functionality, +examples of which include bindings for Win32 API functions and associated +constants. + @section Tests @cindex Tests Package +This package contains the symbols corresponding to test programs. + @section Widgets @cindex Widgets Package + +This package contains symbols for all of the widgets, event methods, +and other UI objects defined by Graphic-Forms. This package and GFG +together constitute the bulk of the public API. Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Tue Mar 21 03:00:29 2006 @@ -42,16 +42,20 @@ @end deftp @end macro -@macro GFI -@acronym{GFW} +@macro ASDF +@acronym{ASDF} +@end macro + +@macro CFFI +@acronym{CFFI} @end macro @macro GFG -@acronym{GFW} +@acronym{GFG} @end macro @macro GFS -@acronym{GFW} +@acronym{GFS} @end macro @macro GFW @@ -138,9 +142,11 @@ @majorheading Major Topics List @menu -* Overview:: Notes on using Graphic-Forms and how to get help. -* Glossary:: Terms and definitions. -* Packages:: Summary of the library packages. +* Overview:: Basic information about Graphic-Forms. +* Packages:: Summary of the library packages. +* Miscellaneous Topics:: Various topics germane to Windows programming + and Graphic-Forms. +* Glossary:: Terms and definitions. * Master Index:: @end menu @@ -149,6 +155,7 @@ @include overview.texinfo @include glossary.texinfo @include packages.texinfo +@include miscellaneous.texinfo @c =================================================================== @c Index

1 0

[graphic-forms-cvs] r61 - trunk
by junrue＠common-lisp.net 21 Mar '06

21 Mar '06

Author: junrue Date: Tue Mar 21 02:03:16 2006 New Revision: 61 Added: trunk/config.lisp Modified: trunk/README.txt trunk/build.lisp trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/tests.lisp Log: build system cleanup Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Tue Mar 21 02:03:16 2006 @@ -9,25 +9,106 @@ Dependencies ------------ -Graphic-Forms depends on the following systems: +Graphic-Forms depends on the following packages: - ASDF - - CFFI - - macro-utilities - - binary-data - + http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ -How To Build ------------- + - CFFI 0.9.0 + http://common-lisp.net/project/cffi/ + + - lw-compat + http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar… + + - closer-mop + http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.t… + + - ImageMagick 6.2.6.5-Q16 + http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-window… + + - lisp-unit + http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html + + +How To Configure and Build +-------------------------- + +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/". + +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. + +5. Execute the following forms from your REPL ( + + (load "config.lisp") + + ;; + ;; If ImageMagic is not installed in the default location, execute: + ;; + (setf gfsys::*imagemagick-dir* "c:/path/to/your/ImageMagick/install/") -Execute the following forms from your REPL: + ;; Update 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 these 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* - (load "build.lisp") - (gfsys::build) + ;; 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. + ;; + (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit) + +6. Proceed to the next section to run the tests, or start coding! + (note: I will add instructions in the future for building the + documentation) How To Run Tests And Samples ---------------------------- +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*)) + + (asdf:operate 'asdf:load-op :graphic-forms-tests) + + (chdir "c:/some/path/graphic-forms/src/tests/uitoolkit/") + + ;; then execute one or more of the following: + ;; + + (run-tests) ;; runs the unit tests (many more to be added) + + (gft::run-event-tester) + + (gft::run-image-tester) + + (gft::run-windlg) + + (gft::run-layout-tester) + + [the end] Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Tue Mar 21 02:03:16 2006 @@ -31,34 +31,23 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(defpackage #:graphic-forms-system - (:nicknames #:gfsys) - (:use :common-lisp :asdf)) +(load "config.lisp") (in-package #:graphic-forms-system) -(defvar *external-build-dirs* nil) - -(defvar *library-root* "c:/projects/third_party/") +(defvar *library-root* "c:/third_party/") +(defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) (defvar *project-root* "c:/projects/public/") -(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/")) - -(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/")) -(defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/")) -(defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") -(defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/")) +(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-0.9.0/")) +(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) +(setf *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") +(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) +(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) (defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") -(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/")) (defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) -(defvar *asdf-dirs* (list *cffi-dir* - *closer-mop-dir* - *lw-compat-dir* - *gf-dir*)) - (defvar *library-build-root* (concatenate 'string *library-root* "build/")) (defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/")) (defvar *closer-mop-build-dir* (concatenate 'string *library-build-root* "closer-mop/")) @@ -69,17 +58,14 @@ *lw-compat-build-dir* *gf-build-dir*)) -#+lispworks (defmacro chdir (path) - `(hcl:change-directory ,path)) -#+clisp (defmacro chdir (path) - `(ext:cd ,path)) - (defun build () - (mapc #'(lambda (dir-str) (pushnew dir-str asdf:*central-registry* :test #'equal)) *asdf-dirs*) + + (configure-asdf) + (when *external-build-dirs* (mapc #'(lambda (dir-str) (ensure-directories-exist (parse-namestring dir-str))) *build-dirs*)) - (ensure-directories-exist (parse-namestring *gf-doc-dir*)) +#| (if *external-build-dirs* (chdir *cffi-build-dir*)) (asdf:operate 'asdf:load-op :cffi) @@ -91,6 +77,7 @@ (if *external-build-dirs* (chdir *closer-mop-build-dir*)) (asdf:operate 'asdf:load-op :closer-mop) +|# (if *external-build-dirs* (chdir *gf-build-dir*)) Added: trunk/config.lisp ============================================================================== --- (empty file) +++ trunk/config.lisp Tue Mar 21 02:03:16 2006 @@ -0,0 +1,58 @@ +;;;; +;;;; config.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. +;;;; + +(defpackage #:graphic-forms-system + (:nicknames #:gfsys) + (:use :common-lisp :asdf)) + +(in-package #:graphic-forms-system) + +(defvar *external-build-dirs* nil) + +(defvar *cffi-dir* "cffi-0.9.0/") +(defvar *closer-mop-dir* "closer-mop/") +(defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") +(defvar *lw-compat-dir* "lw-compat/") +(defvar *gf-dir* "graphic-forms/") + +(defvar *lisp-unit-file* "lisp-unit") + +#+lispworks (defmacro chdir (path) + `(hcl:change-directory ,path)) +#+clisp (defmacro chdir (path) + `(ext:cd ,path)) + +(defun configure-asdf () + (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/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Tue Mar 21 02:03:16 2006 @@ -33,6 +33,10 @@ (in-package #:graphic-forms-system) +(defpackage #:graphic-forms.uitoolkit.tests + (:nicknames #:gft) + (:use :common-lisp :lisp-unit)) + (print "Graphic-Forms UI Toolkit Tests") (print "Copyright (c) 2006 by Jack D. Unrue") (print " ") Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Mar 21 02:03:16 2006 @@ -42,6 +42,7 @@ :version "0.2.0" :author "Jack D. Unrue" :licence "BSD" + :depends-on ("cffi" "lw-compat" "closer-mop") :components ((:module "src" :components Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Tue Mar 21 02:03:16 2006 @@ -33,14 +33,8 @@ (in-package #:graphic-forms-system) -(defvar *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) - (load (compile-file *lisp-unit-file*)) -(defpackage #:graphic-forms.uitoolkit.tests - (:nicknames #:gft) - (:use :common-lisp :lisp-unit)) - (defun load-tests () (if *external-build-dirs* (chdir *gf-build-dir*))

1 0

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

21 Mar '06

Author: junrue Date: Tue Mar 21 00:06:45 2006 New Revision: 60 Added: trunk/src/uitoolkit/widgets/timer.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.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/widget.lisp Log: implemented timer object and event handling -- crashes on CLISP need investigation Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Mar 21 00:06:45 2006 @@ -89,6 +89,7 @@ (:file "widget-generics") (:file "event-source") (:file "widget-utils") + (:file "timer") (:file "item") (:file "widget") (:file "control") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 21 00:06:45 2006 @@ -206,6 +206,7 @@ #:menu #:menu-item #:panel + #:timer #:top-level #:widget #:widget-with-items @@ -314,6 +315,7 @@ #:cut #:default-item #:defmenu + #:delay-of #:disabled-image #:dispatcher #:display-to-object @@ -353,6 +355,7 @@ #:event-resize #:event-select #:event-show + #:event-timer #:expand #:expanded-p #:focus-index @@ -364,6 +367,8 @@ #:header-visible-p #:iconify #:iconified-p + #:id-of + #:initial-delay-of #:horizontal-scrollbar #:image #:item-at @@ -412,6 +417,7 @@ #:retrieve-span #:right-margin-of #:run-default-message-loop + #:running-p #:scroll #:select #:select-all @@ -429,8 +435,10 @@ #:shutdown #:size #:spacing-of + #:start #:startup #:step-increment + #:stop #:style-of #:sub-menu #:text Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Mar 21 00:06:45 2006 @@ -37,6 +37,7 @@ (defparameter *event-tester-text* "Hello!") (defvar *event-counter* 0) (defvar *mouse-down-flag* nil) +(defvar *timer* nil) (defun exit-event-tester () (let ((w *event-tester-window*)) @@ -119,6 +120,14 @@ (gfs:point-y pnt) time (text-for-modifiers))) + +(defun text-for-timer (time) + (format nil + "~a timer tick id: ~d time: 0x~x ~s" + (incf *event-counter*) + (gfw:id-of *timer*) + time + (text-for-modifiers))) (defmethod gfw:event-key-down ((d event-tester-window-events) window time key-code char) (setf *event-tester-text* (text-for-key "down" time key-code char)) @@ -184,6 +193,33 @@ (setf *event-tester-text* (text-for-item (format nil "~a" widget) time "menu activated")) (gfw:redraw *event-tester-window*)) +(defmethod gfw:event-timer ((disp event-tester-echo-dispatcher) timer time) + (declare (ignore disp timer)) + (setf *event-tester-text* (text-for-timer time)) + (gfw:redraw *event-tester-window*)) + +(defun manage-file-menu (disp menu time) + (declare (ignore disp time)) + (let ((item (gfw:item-at menu 0))) + (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) + +(defun manage-timer (disp item time rect) + (declare (ignore disp item time rect)) + (if *timer* + (progn + (gfw:stop *timer*) + (setf *timer* nil) + (setf *event-tester-text* "timer stopped by user")) + (progn + (setf *timer* (make-instance 'gfw:timer :delay 1000 :dispatcher (make-instance 'event-tester-echo-dispatcher))) + (gfw:start *timer*) + (setf *event-tester-text* (format nil + "timer ~d started init delay: ~d delay ~d" + (gfw:id-of *timer*) + (gfw:initial-delay-of *timer*) + (gfw:delay-of *timer*))))) + (gfw:redraw *event-tester-window*)) + (defun run-event-tester-internal () (setf *event-tester-text* "Hello!") (setf *event-counter* 0) @@ -192,16 +228,15 @@ (menubar nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) :style '(:style-workspace))) - (setf menubar (gfw:defmenu ((:item "&File" :dispatcher echo-md - :submenu ((:item "&Open..." :dispatcher echo-md) - (:item "&Save..." :disabled :dispatcher echo-md) + (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu + :submenu ((:item "Timer" :callback #'manage-timer) (:item "" :separator) (:item "E&xit" :dispatcher exit-md))) - (:item "&Options" :dispatcher echo-md - :submenu ((:item "&Enabled" :checked :dispatcher echo-md) - (:item "&Tools" :dispatcher echo-md - :submenu ((:item "&Fonts" :dispatcher echo-md :disabled) - (:item "&Colors" :dispatcher echo-md))))) + (:item "&Test Menu" :dispatcher echo-md + :submenu ((:item "&Checked Item" :checked :dispatcher echo-md) + (:item "&Submenu" :dispatcher echo-md + :submenu ((:item "&Item A" :dispatcher echo-md :disabled) + (:item "&Item B" :dispatcher echo-md))))) (:item "&Help" :dispatcher echo-md :submenu ((:item "&About" :dispatcher echo-md)))))) (setf (gfw:menu-bar *event-tester-window*) menubar) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Mar 21 00:06:45 2006 @@ -562,6 +562,9 @@ (defconstant +tpm-noanimation+ #x4000) (defconstant +tpm-layoutrtl+ #x8000) +(defconstant +user-timer-maximum+ #x7FFFFFFF) +(defconstant +user-timer-minimum+ #x0000000A) + (defconstant +wm-create+ #x0001) (defconstant +wm-destroy+ #x0002) (defconstant +wm-move+ #x0003) @@ -595,6 +598,10 @@ (defconstant +wm-sysdeadchar+ #x0107) (defconstant +wm-keylast+ #x0109) ; for use with peek-message (defconstant +wm-command+ #x0111) +(defconstant +wm-syscommand+ #x0112) +(defconstant +wm-timer+ #x0113) +(defconstant +wm-hscroll+ #x0114) +(defconstant +wm-vscroll+ #x0115) (defconstant +wm-initmenu+ #x0116) (defconstant +wm-initmenupopup+ #x0117) (defconstant +wm-menuselect+ #x011F) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Mar 21 00:06:45 2006 @@ -166,10 +166,11 @@ #+lispworks (fli:define-foreign-function - (enum-child-windows "EnumChildWindows" :result-type :int) + (enum-child-windows "EnumChildWindows") ((hwnd :pointer) (func :pointer) - (lparam :long))) + (lparam :long)) + :result-type :int) #+clisp (ffi:def-call-out enum-child-windows @@ -326,6 +327,12 @@ (hwnd HANDLE)) (defcfun + ("KillTimer" kill-timer) + BOOL + (hwnd HANDLE) + (id UINT)) + +(defcfun ("LoadImageA" load-image) HANDLE (instance HANDLE) @@ -415,6 +422,47 @@ (by-pos BOOL) (item-info LPTR)) +;;; FIXME: uncomment this when CFFI callbacks can +;;; be tagged as stdcall or cdecl (only the latter +;;; is supported as of 0.9.0) +;;; +#| +(defcfun + ("SetTimer" set-timer) + UINT + (hwnd HANDLE) + (id UINT) + (elapse UINT) + (callback :pointer)) ;; TIMERPROC +|# + +#+lispworks +(fli:define-foreign-function + (set-timer "SetTimer") + ((hwnd :pointer) + (id :unsigned-int) + (elapse :unsigned-int) + (func :pointer)) + :result-type :unsigned-int) + +#+clisp +(ffi:def-call-out set-timer + (:name "SetTimer") + (:library "user32.dll") + (:language :stdc) + (:arguments (hwnd ffi:c-pointer) + (id ffi:uint) + (elapse ffi:uint) + (func (ffi:c-function + (:arguments + (hwnd ffi:c-pointer) + (msg ffi:uint) + (id ffi:uint) + (time ffi:long)) + (:return-type nil) + (:language :stdc-stdcall)))) + (:return-type ffi:uint)) + ;;; SetWindowLong is deprecated in favor of SetWindowLongPtr ;;; which can be used to write code compatible to both Win32 ;;; and Win64. But on Win32, SetWindowLongPtr is actually Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Tue Mar 21 00:06:45 2006 @@ -187,3 +187,8 @@ (:documentation "Implement this to respond to an object being shown.") (:method (dispatcher widget time) (declare (ignorable dispatcher widget time)))) + +(defgeneric event-timer (dispatcher timer time) + (:documentation "Implement this to respond to a tick from a specific timer.") + (:method (dispatcher timer time) + (declare (ignorable dispatcher timer time)))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Mar 21 00:06:45 2006 @@ -42,6 +42,10 @@ ;;; window procedures ;;; +;;; NOTE: these defcallback's work even without stdcall support in +;;; CFFI because Windows looks for wndprocs that are not stdcall +;;; and takes care of stack fixup + (cffi:defcallback uit_widgets_wndproc gfs::UINT ((hwnd gfs::HANDLE) @@ -128,7 +132,7 @@ (gfs::def-window-proc hwnd msg wparam lparam)) (defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) (if w @@ -166,7 +170,7 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam) - (declare (ignorable hwnd lparam)) + (declare (ignore hwnd lparam)) (let* ((tc (thread-context)) (menu (get-widget tc (cffi:make-pointer wparam)))) (unless (null menu) @@ -176,7 +180,7 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) - (declare (ignorable hwnd lparam)) ; FIXME: handle system menus + (declare (ignore hwnd lparam)) ; FIXME: handle system menus (let* ((tc (thread-context)) (item (get-menuitem tc (lo-word wparam)))) (unless (null item) @@ -186,12 +190,12 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (get-widget (thread-context) hwnd) ; has side-effect of setting handle slot 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (remove-widget (thread-context) hwnd) 0) @@ -262,7 +266,7 @@ (process-mouse-message #'event-mouse-move hwnd lparam btn-sym))) (defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) (when w @@ -271,7 +275,7 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) (if (and w (event-pre-move (dispatcher w) w (event-time tc))) @@ -279,7 +283,7 @@ 0))) (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd)) (gc (make-instance 'gfg:graphics-context))) @@ -329,13 +333,25 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) (if (and w (event-pre-resize (dispatcher w) w (event-time tc))) 1 0))) +(defmethod process-message (hwnd (msg (eql gfs::+wm-timer+)) wparam lparam) + (declare (ignore hwnd lparam)) + (let* ((tc (thread-context)) + (timer (get-timer tc wparam))) + (if (null timer) + (gfs::kill-timer (cffi:null-pointer) wparam) + (progn + (event-timer (dispatcher timer) timer (event-time tc)) + (when (<= (delay-of timer) 0) + (stop timer))))) + 0) + ;;; ;;; process-subclass-message methods ;;; @@ -347,7 +363,7 @@ (gfs::def-window-proc hwnd msg wparam lparam)))) (defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (remove-widget (thread-context) hwnd) (call-next-method)) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Mar 21 00:06:45 2006 @@ -46,6 +46,7 @@ (next-menuitem-id :initform 10000 :reader next-menuitem-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) + (timers-by-id :initform (make-hash-table :test #'equal)) (wip :initform nil)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) @@ -139,3 +140,20 @@ (let ((id (next-menuitem-id tc))) (incf (slot-value tc 'next-menuitem-id)) id)) + +(defmethod get-timer ((tc thread-context) id) + "Returns the timer identified by the specified (system-defined) id." + (gethash id (slot-value tc 'timers-by-id))) + +(defmethod put-timer ((tc thread-context) (timer timer)) + "Stores a timer using its id as the key." + (setf (gethash (id-of timer) (slot-value tc 'timers-by-id)) timer)) + +(defmethod remove-timer ((tc thread-context) (timer timer)) + "Removes the timer using its id as the key." + (maphash + #'(lambda (k v) + (declare (ignore v)) + (if (eql k (id-of timer)) + (remhash k (slot-value tc 'timers-by-id)))) + (slot-value tc 'timers-by-id))) Added: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/timer.lisp Tue Mar 21 00:06:45 2006 @@ -0,0 +1,122 @@ +;;;; +;;;; timer.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +#+lispworks +(fli:define-foreign-callable + ("timer_proc" :result-type :void :calling-convention :stdcall) + ((hwnd :pointer) + (msg :unsigned-int) + (id :unsigned-int) + (time :long)) + (process-message hwnd gfs::+wm-timer+ id time)) + +#+lispworks +(defun gf-set-timer (delay) + (gfs::set-timer (cffi:null-pointer) + 0 delay + (fli:make-pointer :symbol-name "timer_proc"))) + +#+clisp +(defun timer_proc (hwnd msg id time) + (declare (ignore msg)) + (process-message hwnd gfs::+wm-timer+ id time) + nil) + +#+clisp +(defun gf-set-timer (delay) + (gfs::set-timer nil 0 delay #'timer_proc)) + +(defun clamp-delay-values (init-delay delay) + "Adjust delay settings based on system-defined limits." + ;; + ;; SetTimer is going to impose them anyway, so might as + ;; well make the slot values agree with reality. + ;; On original WinXP (pre-SP1) and earlier, delay values less + ;; than USER_TIMER_MINIMUM get set to 1ms, which MS rectified + ;; in later releases. + ;; + (when (and (> init-delay 0) (< init-delay gfs::+user-timer-minimum+)) + (setf init-delay gfs::+user-timer-minimum+)) + (when (> init-delay gfs::+user-timer-maximum+) + (setf init-delay gfs::+user-timer-maximum+)) + (when (and (> delay 0) (< delay gfs::+user-timer-minimum+)) + (setf delay gfs::+user-timer-minimum+)) + (when (> delay gfs::+user-timer-maximum+) + (setf delay gfs::+user-timer-maximum+)) + (values init-delay delay)) + +(defmethod (setf delay-of) :around (value (self timer)) + (multiple-value-bind (init-delay delay) + (clamp-delay-values 0 value) + (declare (ignore init-delay)) + (if (/= delay (slot-value self 'delay)) + (setf (slot-value self 'delay) delay) + (let ((tc (thread-context)) + (new-id (gf-set-timer delay))) + (unless (or (not (running-p self)) (= new-id (id-of self))) + (remove-timer tc self) + (put-timer tc self)) + (setf (slot-value self 'id-of) new-id))))) + +(defmethod initialize-instance :after ((self timer) &key) + (if (null (delay-of self)) + (error 'gfs:toolkit-error :detail ":delay value required")) + (if (null (initial-delay-of self)) + (setf (slot-value self 'initial-delay) (delay-of self))) + (multiple-value-bind (init-delay delay) + (clamp-delay-values (initial-delay-of self) (delay-of self)) + (setf (slot-value self 'initial-delay) init-delay) + (setf (slot-value self 'delay) delay))) + +(defmethod start ((self timer)) + ;; use init-delay as the elapse interval for the very first + ;; tick; the interval will be adjusted (or the timer killed) + ;; as part of processing the first event + ;; + (let ((init-delay (initial-delay-of self)) + (delay (delay-of self))) + (if (> init-delay 0) + (setf delay init-delay)) + (let ((id (gf-set-timer delay))) + (if (zerop id) + (error 'gfs:win32-error :detail "set-timer failed")) + (setf (slot-value self 'id) id) + (put-timer (thread-context) self)))) + +(defmethod stop ((self timer)) + (remove-timer (thread-context) self)) ;; kill-timer will be called on the next tick + +(defmethod running-p ((self timer)) + (get-timer (thread-context) (id-of self))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Mar 21 00:06:45 2006 @@ -93,3 +93,17 @@ (defclass top-level (window) () (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) + +(defclass timer (event-source) + ((id + :reader id-of + :initform 0) + (initial-delay + :reader initial-delay-of + :initarg :initial-delay + :initform 1000) + (delay + :accessor delay-of + :initarg :delay + :initform 1000)) + (:documentation "A timer is a non-windowed object that generates events at a regular (adjustable) frequency.")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Mar 21 00:06:45 2006 @@ -282,6 +282,9 @@ (defgeneric retrieve-span (object) (:documentation "Returns the span object indicating the range of values that are valid for the object.")) +(defgeneric running-p (object) + (:documentation "Returns T if the object is in event generation mode; nil otherwise.")) + (defgeneric scroll (object dest-pnt src-rect children-too) (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting.")) @@ -327,9 +330,15 @@ (defgeneric size (object) (:documentation "Returns a size object describing the size of the object in its parent's coordinate system.")) +(defgeneric start (object) + (:documentation "Enable event generation at regular intervals.")) + (defgeneric step-increment (object) (:documentation "Return an integer representing the configured step size for the object.")) +(defgeneric stop (object) + (:documentation "Stop producing events.")) + (defgeneric text (object) (:documentation "Returns the object's text.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Mar 21 00:06:45 2006 @@ -98,7 +98,7 @@ (defmethod gfs:dispose ((w widget)) (unless (null (dispatcher w)) - (event-dispose (dispatcher w) w 0)) + (event-dispose (dispatcher w) w (event-time (thread-context)))) (let ((hwnd (gfs:handle w))) (if (not (gfs:null-handle-p hwnd)) (if (zerop (gfs::destroy-window hwnd))

1 0

[graphic-forms-cvs] r59 - trunk/src/intrinsics
by junrue＠common-lisp.net 20 Mar '06

20 Mar '06

Author: junrue Date: Mon Mar 20 15:50:04 2006 New Revision: 59 Removed: trunk/src/intrinsics/ Log: remaining cleanup from uitoolkit.system re-organization

1 0

[graphic-forms-cvs] r58 - in trunk: . src src/intrinsics/datastructs src/intrinsics/system src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 20 Mar '06

20 Mar '06

Author: junrue Date: Mon Mar 20 15:48:16 2006 New Revision: 58 Added: trunk/src/uitoolkit/system/clib.lisp trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/system/native-object.lisp trunk/src/uitoolkit/system/system-classes.lisp trunk/src/uitoolkit/system/system-generics.lisp Removed: trunk/src/intrinsics/datastructs/datastruct-classes.lisp trunk/src/intrinsics/datastructs/datastruct.lisp trunk/src/intrinsics/system/clib.lisp trunk/src/intrinsics/system/native-classes.lisp trunk/src/intrinsics/system/native-conditions.lisp trunk/src/intrinsics/system/native-object-generics.lisp trunk/src/intrinsics/system/native-object.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/image-unit-tests.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/font.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/graphics/magick-core-api.lisp trunk/src/uitoolkit/system/system-conditions.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: collapsed intrinsics package into uitoolkit.system Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Mar 20 15:48:16 2006 @@ -46,31 +46,22 @@ ((:module "src" :components ((:file "packages") - (:module "intrinsics" - :depends-on ("packages") - :components - ((:module "datastructs" - :components - ((:file "datastruct-classes") - (:file "datastruct"))) - (:module "system" - :components - ((:file "native-classes") - (:file "native-conditions") - (:file "native-object-generics") - (:file "clib") - (:file "native-object"))))) (:module "uitoolkit" - :depends-on ("intrinsics") + :depends-on ("packages") :components ((:module "system" :components ((:file "system-constants") + (:file "system-classes") (:file "system-conditions") + (:file "system-generics") (:file "system-types") + (:file "datastructs") + (:file "clib") (:file "gdi32") (:file "kernel32") (:file "user32") + (:file "native-object") (:file "system-utils"))) (:module "graphics" :depends-on ("system") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 15:48:16 2006 @@ -41,10 +41,11 @@ (:use #:common-lisp)) ;;; -;;; package for fundamental stuff shared across the library +;;; package for system-level functionality ;;; -(defpackage #:graphic-forms.intrinsics - (:nicknames #:gfi) +(defpackage #:graphic-forms.uitoolkit.system + (:nicknames #:gfs) + (:shadow #:atom #:boolean) (:use #:common-lisp) (:export @@ -57,7 +58,8 @@ ;; constants -;; methods, functions, and macros +;; methods, functions, macros + #:detail #:dispose #:disposed-p #:handle @@ -77,28 +79,7 @@ #:span-end ;; conditions - #:disposed-error)) - -;;; -;;; package for system-level functionality -;;; -(defpackage #:graphic-forms.uitoolkit.system - (:nicknames #:gfs) - (:shadow #:atom #:boolean) - (:use #:common-lisp) - (:export - -;; classes and structs - -;; constants - -;; methods, functions, macros - #:detail - #:with-compatible-dcs - #:with-hfont-selected - #:with-retrieved-dc - -;; conditions + #:disposed-error #:toolkit-error #:toolkit-warning #:win32-error Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Mar 20 15:48:16 2006 @@ -41,7 +41,7 @@ (defun exit-event-tester () (let ((w *event-tester-window*)) (setf *event-tester-window* nil) - (gfi:dispose w)) + (gfs:dispose w)) (gfw:shutdown 0)) (defclass event-tester-window-events (gfw:event-dispatcher) ()) @@ -51,7 +51,7 @@ (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-blue*) (let* ((sz (gfw:client-size window)) - (pnt (gfi:make-point :x 0 :y (floor (/ (gfi:size-height sz) 2))))) + (pnt (gfs:make-point :x 0 :y (floor (/ (gfs:size-height sz) 2))))) (gfg:draw-text gc *event-tester-text* pnt))) (defmethod gfw:event-close ((d event-tester-window-events) widget time) @@ -77,8 +77,8 @@ (incf *event-counter*) action button - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) time (text-for-modifiers))) @@ -106,8 +106,8 @@ "~a resize action: ~s size: (~d,~d) time: 0x~x ~s" (incf *event-counter*) (symbol-name type) - (gfi:size-width size) - (gfi:size-height size) + (gfs:size-width size) + (gfs:size-height size) time (text-for-modifiers))) @@ -115,8 +115,8 @@ (format nil "~a move point: (~d,~d) time: 0x~x ~s" (incf *event-counter*) - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) time (text-for-modifiers))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Mar 20 15:48:16 2006 @@ -39,22 +39,22 @@ (defmethod gfw:event-close ((d hellowin-events) window time) (declare (ignore time)) - (gfi:dispose window) + (gfs:dispose window) (gfw:shutdown 0)) (defmethod gfw:event-paint ((d hellowin-events) window time gc rect) (declare (ignore time)) - (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) + (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect) (setf (gfg:background-color gc) gfg:*color-red*) (setf (gfg:foreground-color gc) gfg:*color-green*) - (gfg:draw-text gc "Hello World!" (gfi:make-point))) + (gfg:draw-text gc "Hello World!" (gfs:make-point))) (defun exit-fn (disp item time rect) (declare (ignorable disp item time rect)) - (gfi:dispose *hello-win*) + (gfs:dispose *hello-win*) (setf *hello-win* nil) (gfw:shutdown 0)) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Mon Mar 20 15:48:16 2006 @@ -41,55 +41,55 @@ (defclass image-events (gfw:event-dispatcher) ()) (defun dispose-images () - (gfi:dispose *happy-image*) + (gfs:dispose *happy-image*) (setf *happy-image* nil) - (gfi:dispose *bw-image*) + (gfs:dispose *bw-image*) (setf *bw-image* nil) - (gfi:dispose *true-image*) + (gfs:dispose *true-image*) (setf *true-image* nil)) (defmethod gfw:event-close ((d image-events) window time) (declare (ignore window time)) (dispose-images) - (gfi:dispose *image-win*) + (gfs:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0)) (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) - (let ((pnt (gfi:make-point)) - (pixel-pnt1 (gfi:make-point)) - (pixel-pnt2 (gfi:make-point :x 0 :y 15))) + (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 (gfi:point-x pnt) 36) + (incf (gfs:point-x pnt) 36) (gfg:with-transparency (*happy-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) - (incf (gfi:point-x pnt) 36) + (incf (gfs:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt)) - (setf (gfi:point-x pnt) 0) - (incf (gfi:point-y pnt) 36) + (setf (gfs:point-x pnt) 0) + (incf (gfs:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) - (incf (gfi:point-x pnt) 24) + (incf (gfs:point-x pnt) 24) (gfg:with-transparency (*bw-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) - (incf (gfi:point-x pnt) 24) + (incf (gfs:point-x pnt) 24) (gfg:draw-image gc *bw-image* pnt)) - (setf (gfi:point-x pnt) 0) - (incf (gfi:point-y pnt) 20) + (setf (gfs:point-x pnt) 0) + (incf (gfs:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) - (incf (gfi:point-x pnt) 20) + (incf (gfs:point-x pnt) 20) (gfg:with-transparency (*true-image* pixel-pnt2) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) - (incf (gfi:point-x pnt) 20) + (incf (gfs:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) (defun exit-image-fn (disp item time rect) (declare (ignorable disp item time rect)) (dispose-images) - (gfi:dispose *image-win*) + (gfs:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0)) @@ -103,7 +103,7 @@ (gfg::load *true-image* "truecolor16x16.bmp") (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:style-workspace))) - (setf (gfw:size *image-win*) (gfi:make-size :width 250 :height 200)) + (setf (gfw:size *image-win*) (gfs:make-size :width 250 :height 200)) (setf (gfw:text *image-win*) "Image Tester") (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) Modified: trunk/src/tests/uitoolkit/image-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/image-unit-tests.lisp Mon Mar 20 15:48:16 2006 @@ -49,24 +49,24 @@ 0 0 (logior gfs::+lr-loadfromfile+ gfs::+lr-createdibsection+)))) - (if (gfi:null-handle-p hbmp) + (if (gfs:null-handle-p hbmp) (error 'gfs:win32-error :detail "load-image failed")) (setf d2 (gfg::image->data hbmp)) (assert-equal (gfg:depth d1) (gfg:depth d2) path) (let ((size1 (gfg:size d1)) (size2 (gfg:size d2))) - (assert-equal (gfi:size-width size1) (gfi:size-width size2) path) - (assert-equal (gfi:size-height size1) (gfi:size-height size2) path)) + (assert-equal (gfs:size-width size1) (gfs:size-width size2) path) + (assert-equal (gfs:size-height size1) (gfs:size-height size2) path)) (gfg:load im path) (setf d3 (gfg:data-obj im)) (assert-equal (gfg:depth d1) (gfg:depth d3) path) (let ((size1 (gfg:size d1)) (size2 (gfg:size d3))) - (assert-equal (gfi:size-width size1) (gfi:size-width size2) path) - (assert-equal (gfi:size-height size1) (gfi:size-height size2) path)) - (unless (gfi:disposed-p im) - (gfi:dispose im)) - (unless (gfi:null-handle-p hbmp) + (assert-equal (gfs:size-width size1) (gfs:size-width size2) path) + (assert-equal (gfs:size-height size1) (gfs:size-height size2) path)) + (unless (gfs:disposed-p im) + (gfs:dispose im)) + (unless (gfs:null-handle-p hbmp) (gfs::delete-object hbmp)))))) (define-test image-data-loading-test Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Mar 20 15:48:16 2006 @@ -46,7 +46,7 @@ (defun exit-layout-tester () (let ((w *layout-tester-win*)) (setf *layout-tester-win* nil) - (gfi:dispose w)) + (gfs:dispose w)) (gfw:shutdown 0)) (defclass layout-tester-events (gfw:event-dispatcher) ()) @@ -74,7 +74,7 @@ (defmethod gfw:preferred-size ((win test-panel) width-hint height-hint) (declare (ignore width-hint height-hint)) - (gfi:make-size :width 45 :height 45)) + (gfs:make-size :width 45 :height 45)) (defmethod gfw:text ((win test-panel)) (declare (ignore win)) @@ -151,7 +151,7 @@ do (if (string= (gfw:text k) text) (setf victim k)))) (unless (null victim) - (gfi:dispose victim) + (gfs:dispose victim) (gfw:layout *layout-tester-win*)))) (defclass visibility-child-dispatcher (gfw:event-dispatcher) ()) Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Mon Mar 20 15:48:16 2006 @@ -33,7 +33,7 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *minsize1* (gfi:make-size :width 20 :height 10)) +(defvar *minsize1* (gfs:make-size :width 20 :height 10)) (defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *minsize1*) (make-instance 'mock-widget :min-size *minsize1*) (make-instance 'mock-widget :min-size *minsize1*))) @@ -41,12 +41,12 @@ (defun validate-layout-rects (entries expected-rects) (let ((actual-rects (loop for entry in entries collect (cdr entry)))) (mapc #'(lambda (expected actual) - (let ((pnt-a (gfi:location actual)) - (sz-a (gfi:size actual))) - (assert-equal (gfi:point-x pnt-a) (first expected)) - (assert-equal (gfi:point-y pnt-a) (second expected)) - (assert-equal (gfi:size-width sz-a) (third expected)) - (assert-equal (gfi:size-height sz-a) (fourth expected)))) + (let ((pnt-a (gfs:location actual)) + (sz-a (gfs:size actual))) + (assert-equal (gfs:point-x pnt-a) (first expected)) + (assert-equal (gfs:point-y pnt-a) (second expected)) + (assert-equal (gfs:size-width sz-a) (third expected)) + (assert-equal (gfs:size-height sz-a) (fourth expected)))) expected-rects actual-rects))) @@ -62,8 +62,8 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) - (assert-equal 60 (gfi:size-width size)) - (assert-equal 10 (gfi:size-height size)) + (assert-equal 60 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) (validate-layout-rects data expected-rects))) (define-test flow-layout-test2 @@ -78,8 +78,8 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 20 (gfi:size-width size)) - (assert-equal 30 (gfi:size-height size)) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) (validate-layout-rects data expected-rects))) (define-test flow-layout-test3 @@ -146,8 +146,8 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) - (assert-equal 68 (gfi:size-width size)) - (assert-equal 10 (gfi:size-height size)) + (assert-equal 68 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) (validate-layout-rects data expected-rects))) (define-test flow-layout-test8 @@ -162,8 +162,8 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) - (assert-equal 20 (gfi:size-width size)) - (assert-equal 38 (gfi:size-height size)) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 38 (gfs:size-height size)) (validate-layout-rects data expected-rects))) (define-test flow-layout-test9 @@ -207,8 +207,8 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) - (assert-equal 63 (gfi:size-width size)) - (assert-equal 13 (gfi:size-height size)) + (assert-equal 63 (gfs:size-width size)) + (assert-equal 13 (gfs:size-height size)) (validate-layout-rects data expected-rects))) (define-test flow-layout-test12 @@ -226,6 +226,6 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 23 (gfi:size-width size)) - (assert-equal 33 (gfi:size-height size)) + (assert-equal 23 (gfs:size-width size)) + (assert-equal 33 (gfs:size-height size)) (validate-layout-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Mon Mar 20 15:48:16 2006 @@ -47,32 +47,32 @@ (actual-size :accessor actual-size-of :initarg :actual-size - :initform (gfi:make-size)) + :initform (gfs:make-size)) (max-size :accessor max-size-of :initarg :max-size - :initform (gfi:make-size :width +max-widget-size+ :height +max-widget-size+)) + :initform (gfs:make-size :width +max-widget-size+ :height +max-widget-size+)) (min-size :accessor min-size-of :initarg :min-size - :initform (gfi:make-size)))) + :initform (gfs:make-size)))) (defmethod initialize-instance :after ((widget mock-widget) &key) - (setf (slot-value widget 'gfi:handle) (cffi:make-pointer #xFFFFFFFF))) + (setf (slot-value widget 'gfs:handle) (cffi:make-pointer #xFFFFFFFF))) (defmethod gfw:minimum-size ((widget mock-widget)) - (gfi:make-size :width (gfi:size-width (min-size-of widget)) - :height (gfi:size-height (min-size-of widget)))) + (gfs:make-size :width (gfs:size-width (min-size-of widget)) + :height (gfs:size-height (min-size-of widget)))) (defmethod gfw:preferred-size ((widget mock-widget) width-hint height-hint) - (let ((size (gfi:make-size)) + (let ((size (gfs:make-size)) (min-size (min-size-of widget))) (if (< width-hint 0) - (setf (gfi:size-width size) (gfi:size-width min-size)) - (setf (gfi:size-width size) width-hint)) + (setf (gfs:size-width size) (gfs:size-width min-size)) + (setf (gfs:size-width size) width-hint)) (if (< height-hint 0) - (setf (gfi:size-height size) (gfi:size-height min-size)) - (setf (gfi:size-height size) height-hint)) + (setf (gfs:size-height size) (gfs:size-height min-size)) + (setf (gfs:size-height size) height-hint)) size)) (defmethod gfw:visible-p ((widget mock-widget)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Mar 20 15:48:16 2006 @@ -40,14 +40,14 @@ (defmethod gfw:event-close ((d main-win-events) window time) (declare (ignore time)) (setf *main-win* nil) - (gfi:dispose window) + (gfs:dispose window) (gfw:shutdown 0)) (defclass test-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-paint ((d test-win-events) window time gc rect) (declare (ignore time)) - (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) + (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect)) @@ -56,21 +56,21 @@ (defmethod gfw:event-close ((d test-mini-events) window time) (declare (ignore time)) - (gfi:dispose window)) + (gfs:dispose window)) (defclass test-borderless-events (test-win-events) ()) (defmethod gfw:event-mouse-down ((d test-borderless-events) window time point button) (declare (ignore time point button)) - (gfi:dispose window)) + (gfs:dispose window)) (defun create-borderless-win (disp item time rect) (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* :style '(:style-borderless)))) - (setf (gfw:location window) (gfi:make-point :x 400 :y 250)) - (setf (gfw:size window) (gfi:make-size :width 300 :height 250)) + (setf (gfw:location window) (gfs:make-point :x 400 :y 250)) + (setf (gfw:size window) (gfs:make-size :width 300 :height 250)) (gfw:show window t))) (defun create-miniframe-win (disp item time rect) @@ -78,8 +78,8 @@ (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :style '(:style-miniframe)))) - (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) - (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (setf (gfw:text window) "Mini Frame") (gfw:show window t))) @@ -88,14 +88,14 @@ (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :style '(:style-palette)))) - (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) - (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (setf (gfw:text window) "Palette") (gfw:show window t))) (defun exit-callback (disp item time rect) (declare (ignore disp item time rect)) - (gfi:dispose *main-win*) + (gfs:dispose *main-win*) (setf *main-win* nil) (gfw:shutdown 0)) Modified: trunk/src/uitoolkit/graphics/font.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font.lisp (original) +++ trunk/src/uitoolkit/graphics/font.lisp Mon Mar 20 15:48:16 2006 @@ -37,8 +37,8 @@ ;;; methods ;;; -(defmethod gfi:dispose ((fn font)) - (let ((hgdi (gfi:handle fn))) - (unless (gfi:null-handle-p hgdi) +(defmethod gfs:dispose ((fn font)) + (let ((hgdi (gfs:handle fn))) + (unless (gfs:null-handle-p hgdi) (gfs::delete-object hgdi))) - (setf (slot-value fn 'gfi:handle) nil)) + (setf (slot-value fn 'gfs:handle) nil)) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Mar 20 15:48:16 2006 @@ -76,16 +76,16 @@ (direct nil) (table nil))) ; vector of COLOR structs -(defclass image-data (gfi:native-object) () +(defclass image-data (gfs:native-object) () (:documentation "This class maintains image attributes, color, and pixel data.")) -(defclass font (gfi:native-object) () +(defclass font (gfs:native-object) () (:documentation "This class encapsulates a realized native font.")) -(defclass graphics-context (gfi:native-object) () +(defclass graphics-context (gfs:native-object) () (:documentation "This class represents the context associated with drawing primitives.")) -(defclass image (gfi:native-object) +(defclass image (gfs:native-object) ((transparency-pixel :accessor transparency-pixel-of :initarg :transparency-pixel @@ -116,8 +116,8 @@ (defmacro color-table (data) `(gfg::palette-table ,data)) -(defclass pattern (gfi:native-object) () +(defclass pattern (gfs:native-object) () (:documentation "This class represents a pattern to be used with a brush.")) -(defclass transform (gfi:native-object) () +(defclass transform (gfs:native-object) () (:documentation "This class specifies how coordinates are transformed.")) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 15:48:16 2006 @@ -41,41 +41,41 @@ ;;; methods ;;; -(defmethod gfi:dispose ((gc graphics-context)) - (gfs::delete-dc (gfi:handle gc)) - (setf (slot-value gc 'gfi:handle) nil)) +(defmethod gfs:dispose ((gc graphics-context)) + (gfs::delete-dc (gfs:handle gc)) + (setf (slot-value gc 'gfs:handle) nil)) (defmethod background-color ((gc graphics-context)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (gfs::get-bk-color (gfi:handle gc))) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (gfs::get-bk-color (gfs:handle gc))) (defmethod (setf background-color) ((clr color) (gc graphics-context)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (let ((hdc (gfi:handle gc)) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (let ((hdc (gfs:handle gc)) (hbrush (gfs::get-stock-object gfs::+dc-brush+)) (rgb (color-as-rgb clr))) (gfs::select-object hdc hbrush) (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb))) -(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfi:rectangle)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (let ((hdc (gfi:handle gc)) - (pnt (gfi:location rect)) - (size (gfi:size rect))) +(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfs:rectangle)) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (let ((hdc (gfs:handle gc)) + (pnt (gfs:location rect)) + (size (gfs:size rect))) (cffi:with-foreign-object (rect-ptr 'gfs::rect) (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) rect-ptr gfs::rect) - (setf gfs::top (gfi:point-y pnt)) - (setf gfs::left (gfi:point-x pnt)) - (setf gfs::bottom (+ (gfi:point-y pnt) (gfi:size-height size))) - (setf gfs::right (+ (gfi:point-x pnt) (gfi:size-width size))) + (setf gfs::top (gfs:point-y pnt)) + (setf gfs::left (gfs:point-x pnt)) + (setf gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size))) + (setf gfs::right (+ (gfs:point-x pnt) (gfs:size-width size))) (gfs::ext-text-out hdc - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) gfs::+eto-opaque+ rect-ptr "" @@ -85,19 +85,19 @@ ;;; ;;; TODO: support addressing elements within bitmap as if it were an array ;;; -(defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (if (gfi:disposed-p im) - (error 'gfi:disposed-error)) - (let ((gc-dc (gfi:handle gc)) - (himage (gfi:handle im)) +(defmethod draw-image ((gc graphics-context) (im image) (pnt gfs:point)) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (if (gfs:disposed-p im) + (error 'gfs:disposed-error)) + (let ((gc-dc (gfs:handle gc)) + (himage (gfs:handle im)) (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (if (not (null (transparency-pixel-of im))) - (let ((hmask (gfi:handle (transparency-mask im))) + (let ((hmask (gfs:handle (transparency-mask im))) (hcopy (clone-bitmap himage)) (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) (black (make-color :red 0 :green 0 :blue 0)) @@ -113,15 +113,15 @@ memdc 0 0 gfs::+blt-srcand+) (gfs::bit-blt gc-dc - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) gfs::width gfs::height memdc 0 0 gfs::+blt-srcand+) (gfs::bit-blt gc-dc - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) gfs::width gfs::height memdc2 @@ -129,29 +129,29 @@ (progn (gfs::select-object memdc himage) (gfs::bit-blt gc-dc - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) gfs::width gfs::height memdc 0 0 gfs::+blt-srccopy+))))) (gfs::delete-dc memdc))) -(defmethod draw-text ((gc graphics-context) text (pnt gfi:point)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) +(defmethod draw-text ((gc graphics-context) text (pnt gfs:point)) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) (cffi:with-foreign-object (rect-ptr 'gfs::rect) (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) rect-ptr gfs::rect) - (setf gfs::left (gfi:point-x pnt)) - (setf gfs::top (gfi:point-y pnt)) - (gfs::draw-text (gfi:handle gc) + (setf gfs::left (gfs:point-x pnt)) + (setf gfs::top (gfs:point-y pnt)) + (gfs::draw-text (gfs:handle gc) text -1 rect-ptr (logior gfs::+dt-calcrect+ gfs::+dt-singleline+) (cffi:null-pointer)) - (gfs::draw-text (gfi:handle gc) + (gfs::draw-text (gfs:handle gc) text (length text) rect-ptr @@ -162,14 +162,14 @@ (cffi:null-pointer))))) (defmethod foreground-color ((gc graphics-context)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (gfs::get-text-color (gfi:handle gc))) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (gfs::get-text-color (gfs:handle gc))) (defmethod (setf foreground-color) ((clr color) (gc graphics-context)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (let ((hdc (gfi:handle gc)) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (let ((hdc (gfs:handle gc)) (hpen (gfs::get-stock-object gfs::+dc-pen+)) (rgb (color-as-rgb clr))) (gfs::select-object hdc hpen) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Mar 20 15:48:16 2006 @@ -63,10 +63,10 @@ bc-ptr gfs::+dib-rgb-colors+)) (error 'gfs:win32-error :detail "get-di-bits failed <1>")) - (setf sz (gfi:make-size :width gfs::bcwidth :height gfs::bcheight)) + (setf sz (gfs:make-size :width gfs::bcwidth :height gfs::bcheight)) (setf data (make-image-data :bits-per-pixel gfs::bcbitcount :size sz)))) - (setf byte-count (* (bmp-pixel-row-length (gfi:size-width sz) (bits-per-pixel data)) - (gfi:size-height sz))) + (setf byte-count (* (bmp-pixel-row-length (gfs:size-width sz) (bits-per-pixel data)) + (gfs:size-height sz))) (setf raw-bits (cffi:foreign-alloc :unsigned-char :count byte-count)) (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) (cffi:with-foreign-slots ((gfs::bisize @@ -79,14 +79,14 @@ gfs::bmicolors) bi-ptr gfs::bitmapinfo) (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) - (setf gfs::biwidth (gfi:size-width sz)) - (setf gfs::biheight (gfi:size-height sz)) + (setf gfs::biwidth (gfs:size-width sz)) + (setf gfs::biheight (gfs:size-height sz)) (setf gfs::biplanes 1) (setf gfs::bibitcount (bits-per-pixel data)) (setf gfs::bicompression gfs::+bi-rgb+) (when (zerop (gfs::get-di-bits mem-dc hbmp - 0 (gfi:size-height sz) + 0 (gfs:size-height sz) raw-bits bi-ptr gfs::+dib-rgb-colors+)) @@ -140,14 +140,14 @@ gfs::biclrimp gfs::bmicolors) bi-ptr gfs::bitmapinfo) - (let* ((handle (gfi:handle data)) + (let* ((handle (gfs:handle data)) (sz (size data)) - (pix-count (* (gfi:size-width sz) (gfi:size-height sz))) + (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)) - (setf gfs::biwidth (gfi:size-width sz)) - (setf gfs::biheight (- 0 (gfi:size-height sz))) + (setf gfs::biwidth (gfs:size-width sz)) + (setf gfs::biheight (- 0 (gfs:size-height sz))) (setf gfs::biplanes 1) (setf gfs::bibitcount 32) ;; 32bpp even if original image file is not (setf gfs::bicompression gfs::+bi-rgb+) @@ -166,12 +166,12 @@ pix-bits-ptr (cffi:null-pointer) 0)) - (if (gfi:null-handle-p hbmp) + (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 (gfi:size-width sz) (gfi:size-height sz))) + (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 ((gfg::blue gfg::green gfg::red gfg::reserved) @@ -190,17 +190,17 @@ ;;; (defmethod depth ((data image-data)) - (let ((handle (gfi:handle data))) + (let ((handle (gfs:handle data))) (if (null handle) - (error 'gfi:disposed-error)) + (error 'gfs:disposed-error)) (cffi:foreign-slot-value handle 'magick-image 'depth))) -(defmethod gfi:dispose ((data image-data)) - (let ((victim (gfi:handle data))) +(defmethod gfs:dispose ((data image-data)) + (let ((victim (gfs:handle data))) (if (null victim) - (error 'gfi:disposed-error)) + (error 'gfs:disposed-error)) (destroy-image victim)) - (setf (slot-value data 'gfi:handle) nil)) + (setf (slot-value data 'gfs:handle) nil)) (defmethod load ((data image-data) path) (setf path (cond @@ -208,10 +208,10 @@ ((typep path 'string) path) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) - (let ((handle (gfi:handle data))) + (let ((handle (gfs:handle data))) (when (and (not (null handle)) (not (cffi:null-pointer-p handle))) (destroy-image handle) - (setf (slot-value data 'gfi:handle) nil) + (setf (slot-value data 'gfs:handle) nil) (setf handle nil)) (with-image-path (path info ex) (setf handle (read-image info ex)) @@ -221,48 +221,48 @@ (cffi:foreign-slot-value ex 'exception-info 'reason)))) (if (cffi:null-pointer-p handle) (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) - (setf (slot-value data 'gfi:handle) handle)))) + (setf (slot-value data 'gfs:handle) handle)))) (defmethod size ((data image-data)) - (let ((handle (gfi:handle data)) - (size (gfi:make-size))) + (let ((handle (gfs:handle data)) + (size (gfs:make-size))) (if (or (null handle) (cffi:null-pointer-p handle)) - (error 'gfi:disposed-error)) + (error 'gfs:disposed-error)) (cffi:with-foreign-slots ((rows columns) handle magick-image) - (setf (gfi:size-height size) rows) - (setf (gfi:size-width size) columns)) + (setf (gfs:size-height size) rows) + (setf (gfs:size-width size) columns)) size)) (defmethod (setf size) (size (data image-data)) - (let ((handle (gfi:handle data)) + (let ((handle (gfs:handle data)) (new-handle (cffi:null-pointer)) (ex (acquire-exception-info))) (if (or (null handle) (cffi:null-pointer-p handle)) - (error 'gfi:disposed-error)) + (error 'gfs:disposed-error)) (unwind-protect (progn (setf new-handle (resize-image handle - (gfi:size-width size) - (gfi:size-height size) + (gfs:size-width size) + (gfs:size-height size) (cffi:foreign-enum-value 'filter-types :lanczos) 1.0 ex)) - (if (gfi:null-handle-p new-handle) + (if (gfs:null-handle-p new-handle) (error 'gfs:toolkit-error :detail (format nil "could not resize: ~a" (cffi:foreign-slot-value ex 'exception-info 'reason)))) - (setf (slot-value data 'gfi:handle) new-handle) + (setf (slot-value data 'gfs:handle) new-handle) (destroy-image handle)) (destroy-exception-info ex)))) (defmethod print-object ((data image-data) stream) - (if (or (null (gfi:handle data)) (cffi:null-pointer-p (gfi:handle data))) - (error 'gfi:disposed-error)) + (if (or (null (gfs:handle data)) (cffi:null-pointer-p (gfs:handle data))) + (error 'gfs:disposed-error)) (let ((size (size data))) (print-unreadable-object (data stream :type t) ;; FIXME: dump palette info, too ;; - (format stream "width: ~a " (gfi:size-width size)) - (format stream "height: ~a " (gfi:size-height size)) + (format stream "width: ~a " (gfs:size-width size)) + (format stream "height: ~a " (gfs:size-height size)) (format stream "bits per pixel: ~a " (depth data))))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Mar 20 15:48:16 2006 @@ -49,7 +49,7 @@ (defun clone-bitmap (horig) (let ((hclone (cffi:null-pointer)) (nptr (cffi:null-pointer))) - (gfs:with-compatible-dcs (nptr memdc-src memdc-dest) + (gfs::with-compatible-dcs (nptr memdc-src memdc-dest) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object horig (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) @@ -65,21 +65,21 @@ ;;; methods ;;; -(defmethod gfi:dispose ((im image)) - (let ((hgdi (gfi:handle im))) - (unless (gfi:null-handle-p hgdi) +(defmethod gfs:dispose ((im image)) + (let ((hgdi (gfs:handle im))) + (unless (gfs:null-handle-p hgdi) (gfs::delete-object hgdi))) - (setf (slot-value im 'gfi:handle) nil)) + (setf (slot-value im 'gfs:handle) nil)) (defmethod data-obj ((im image)) - (when (gfi:disposed-p im) - (error 'gfi:disposed-error)) - (image->data (gfi:handle im))) + (when (gfs:disposed-p im) + (error 'gfs:disposed-error)) + (image->data (gfs:handle im))) (defmethod (setf data-obj) ((id image-data) (im image)) - (unless (gfi:disposed-p im) - (gfi:dispose im)) - (setf (slot-value im 'gfi:handle) (data->image id))) + (unless (gfs:disposed-p im) + (gfs:dispose im)) + (setf (slot-value im 'gfs:handle) (data->image id))) (defmethod load ((im image) path) (let ((data (make-instance 'image-data))) @@ -88,24 +88,24 @@ data)) (defmethod transparency-mask ((im image)) - (if (gfi:disposed-p im) - (error 'gfi:disposed-error)) + (if (gfs:disposed-p im) + (error 'gfs:disposed-error)) (let ((pixel-pnt (transparency-pixel-of im)) - (hbmp (gfi:handle im)) + (hbmp (gfs:handle im)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer)) (old-bg 0)) (unless (null pixel-pnt) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) - (if (gfi:null-handle-p hmask) + (if (gfs:null-handle-p hmask) (error 'gfs:win32-error :detail "create-bitmap failed")) (gfs::with-compatible-dcs (nptr memdc1 memdc2) (gfs::select-object memdc1 hbmp) (setf old-bg (gfs::set-bk-color memdc1 - (gfs::get-pixel memdc1 (gfi:point-x pixel-pnt) (gfi:point-y pixel-pnt)))) + (gfs::get-pixel memdc1 (gfs:point-x pixel-pnt) (gfs:point-y pixel-pnt)))) (gfs::select-object memdc2 hmask) (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) (gfs::set-bk-color memdc1 old-bg)))) Modified: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Mon Mar 20 15:48:16 2006 @@ -190,7 +190,7 @@ (error 'gfs:toolkit-error :detail "could not allocate Magick ImageInfo object")) (unwind-protect (cffi:with-foreign-string (str ,path) - (gfi::strncpy (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename) + (gfs::strncpy (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename) str (1- +magick-max-text-extent+)) ,@body)) Added: trunk/src/uitoolkit/system/clib.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/clib.lisp Mon Mar 20 15:48:16 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; clib.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.system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(defcfun + ("strncpy" strncpy) + :pointer + (dest :pointer) + (src :pointer) + (count :unsigned-int)) Added: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/datastructs.lisp Mon Mar 20 15:48:16 2006 @@ -0,0 +1,55 @@ +;;;; +;;;; datastructs.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.system) + +(defstruct point (x 0) (y 0) (z 0)) + +(defstruct size (width 0) (height 0) (depth 0)) + +(defstruct span (start 0) (end 0)) + +(defclass rectangle () + ((location + :accessor location + :initarg :location + :initform (make-point)) + (size + :accessor size + :initarg :size + :initform (make-size))) + (:documentation "Describes the perimeter of a rectangular region in a given coordinate system.")) + +(defmethod print-object ((obj rectangle) stream) + (print-unreadable-object (obj stream :type t) + (format stream "location: ~a size: ~a" (location obj) (size obj)))) Added: trunk/src/uitoolkit/system/native-object.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/native-object.lisp Mon Mar 20 15:48:16 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; native-object.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.system) + +(defmethod disposed-p ((obj native-object)) + (null (handle obj))) + +(defmacro null-handle-p (handle) + `(cffi:null-pointer-p ,handle)) Added: trunk/src/uitoolkit/system/system-classes.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/system-classes.lisp Mon Mar 20 15:48:16 2006 @@ -0,0 +1,41 @@ +;;;; +;;;; system-classes.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.system) + +(defclass native-object () + ((handle + :reader handle + :initarg :handle + :initform nil)) + (:documentation "This is the base class for all objects that have a native handle representation at the system level.")) Modified: trunk/src/uitoolkit/system/system-conditions.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-conditions.lisp (original) +++ trunk/src/uitoolkit/system/system-conditions.lisp Mon Mar 20 15:48:16 2006 @@ -47,6 +47,8 @@ (print-unreadable-object (obj stream :type t) (format stream "~s" (detail obj)))) +(define-condition disposed-error (error) ()) + (define-condition win32-error (toolkit-error) ((code :reader code :initarg :code :initform (get-last-error)))) Added: trunk/src/uitoolkit/system/system-generics.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/system-generics.lisp Mon Mar 20 15:48:16 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; system-generics.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.system) + +(defgeneric dispose (native-object) + (:documentation "Discards native resources and executes other cleanup code.")) + +(defgeneric disposed-p (native-object) + (:documentation "Returns T if the target has had dispose called; nil otherwise.")) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Mar 20 15:48:16 2006 @@ -44,7 +44,7 @@ (progn (setf ,hfont-old (gfs::select-object ,hdc ,hfont)) ,@body) - (unless (gfi:null-handle-p ,hfont-old) + (unless (gfs:null-handle-p ,hfont-old) (gfs::select-object ,hdc ,hfont-old)))))) (defmacro with-retrieved-dc ((hwnd hdc-var) &body body) @@ -52,7 +52,7 @@ (unwind-protect (progn (setf ,hdc-var (gfs::get-dc ,hwnd)) - (if (gfi:null-handle-p ,hdc-var) + (if (gfs:null-handle-p ,hdc-var) (error 'gfs:win32-error :detail "get-dc failed")) ,@body) (gfs::release-dc ,hwnd ,hdc-var)))) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Mon Mar 20 15:48:16 2006 @@ -68,22 +68,22 @@ (compute-style-flags btn style) (let ((hwnd (create-window gfs::+button-classname+ " " - (gfi:handle parent) + (gfs:handle parent) (logior std-style gfs::+ws-child+ gfs::+ws-visible+) ex-style))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value btn 'gfi:handle) hwnd))) + (setf (slot-value btn 'gfs:handle) hwnd))) (init-control btn)) (defmethod preferred-size ((btn button) width-hint height-hint) (let ((sz (widget-text-size btn gfs::+dt-singleline+ 0))) (if (>= width-hint 0) - (setf (gfi:size-width sz) width-hint) - (setf (gfi:size-width sz) (+ (gfi:size-width sz) 14))) + (setf (gfs:size-width sz) width-hint) + (setf (gfs:size-width sz) (+ (gfs:size-width sz) 14))) (if (>= height-hint 0) - (setf (gfi:size-height sz) height-hint) - (setf (gfi:size-height sz) (+ (gfi:size-height sz) 10))) + (setf (gfs:size-height sz) height-hint) + (setf (gfs:size-height sz) (+ (gfs:size-height sz) 10))) sz)) (defmethod text ((btn button)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Mar 20 15:48:16 2006 @@ -38,11 +38,11 @@ ;;; (defun init-control (ctrl) - (let ((hwnd (gfi:handle ctrl))) + (let ((hwnd (gfs:handle ctrl))) (subclass-wndproc hwnd) (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) - (unless (gfi:null-handle-p hfont) + (unless (gfs:null-handle-p hfont) (unless (zerop (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) @@ -54,10 +54,10 @@ ;;; (defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) - (if (gfi:disposed-p parent) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p parent) + (error 'gfs:disposed-error))) (defmethod preferred-size :before ((ctrl control) width-hint height-hint) (declare (ignorable width-hint height-hint)) - (if (gfi:disposed-p ctrl) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Mon Mar 20 15:48:16 2006 @@ -35,7 +35,7 @@ (defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer)) (gfw:event-arm . (gfw:event-source integer)) - (gfw:event-select . (gfw:item integer gfi:rectangle)))) + (gfw:event-select . (gfw:item integer gfs:rectangle)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Mar 20 15:48:16 2006 @@ -102,8 +102,8 @@ (w (get-widget tc hwnd)) (pnt (mouse-event-pnt tc))) (when w - (setf (gfi:point-x pnt) (lo-word lparam)) - (setf (gfi:point-y pnt) (hi-word lparam)) + (setf (gfs:point-x pnt) (lo-word lparam)) + (setf (gfs:point-y pnt) (hi-word lparam)) (funcall fn (dispatcher w) w (event-time tc) pnt btn-symbol))) 0) @@ -150,7 +150,7 @@ (event-select (dispatcher item) item (event-time tc) - (make-instance 'gfi:rectangle))))) ; FIXME + (make-instance 'gfs:rectangle))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) (t @@ -161,7 +161,7 @@ (event-select (dispatcher w) w (event-time tc) - (make-instance 'gfi:rectangle)))))) ; FIXME + (make-instance 'gfs:rectangle)))))) ; FIXME (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) @@ -284,17 +284,17 @@ (w (get-widget tc hwnd)) (gc (make-instance 'gfg:graphics-context))) (if w - (let ((rct (make-instance 'gfi:rectangle))) + (let ((rct (make-instance 'gfs:rectangle))) (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) (cffi:with-foreign-slots ((gfs::rcpaint-x gfs::rcpaint-y gfs::rcpaint-width gfs::rcpaint-height) ps-ptr gfs::paintstruct) - (setf (slot-value gc 'gfi:handle) (gfs::begin-paint hwnd ps-ptr)) - (setf (gfi:location rct) (gfi:make-point :x gfs::rcpaint-x + (setf (slot-value gc 'gfs:handle) (gfs::begin-paint hwnd ps-ptr)) + (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x :y gfs::rcpaint-y)) - (setf (gfi:size rct) (gfi:make-size :width gfs::rcpaint-width + (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) (unwind-protect (event-paint (dispatcher w) w (event-time tc) gc rct) @@ -355,6 +355,6 @@ ;;; event-dispatcher methods ;;; -(defmethod gfi:dispose ((d event-source)) +(defmethod gfs:dispose ((d event-source)) (setf (dispatcher d) nil) (call-next-method)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Mar 20 15:48:16 2006 @@ -48,24 +48,24 @@ (when (or (visible-p kid) (not win-visible)) (if vert-orient (progn - (incf total (gfi:size-height size)) - (if (< max (gfi:size-width size)) - (setf max (gfi:size-width size)))) + (incf total (gfs:size-height size)) + (if (< max (gfs:size-width size)) + (setf max (gfs:size-width size)))) (progn - (incf total (gfi:size-width size)) - (if (< max (gfi:size-height size)) - (setf max (gfi:size-height size)))))))) + (incf total (gfs:size-width size)) + (if (< max (gfs:size-height size)) + (setf max (gfs:size-height size)))))))) (unless (null kids) (incf total (* (spacing-of layout) (1- (length kids))))) (if vert-orient (progn (incf max (+ (left-margin-of layout) (right-margin-of layout))) (incf total (+ (top-margin-of layout) (bottom-margin-of layout))) - (gfi:make-size :width max :height total)) + (gfs:make-size :width max :height total)) (progn (incf total (+ (left-margin-of layout) (right-margin-of layout))) (incf max (+ (top-margin-of layout) (bottom-margin-of layout))) - (gfi:make-size :width total :height max))))) + (gfs:make-size :width total :height max))))) (defun flow-container-layout (layout visible kids width-hint height-hint) (let* ((flows nil) @@ -79,14 +79,14 @@ (wrap-coord (if vert-orient (left-margin-of layout) (top-margin-of layout)))) (loop for kid in kids do (let ((size (preferred-size kid -1 -1)) - (pnt (gfi:make-point))) + (pnt (gfs:make-point))) (when (or (visible-p kid) (not visible)) (if vert-orient (progn (when (and wrap (>= height-hint 0) (> (+ next-coord - (gfi:size-height size) + (gfs:size-height size) (bottom-margin-of layout)) height-hint)) (push (reverse curr-flow) flows) @@ -94,16 +94,16 @@ (setf next-coord (top-margin-of layout)) (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) - (setf (gfi:point-x pnt) wrap-coord) - (setf (gfi:point-y pnt) next-coord) - (if (< max-size (gfi:size-width size)) - (setf max-size (gfi:size-width size))) - (incf next-coord (+ (gfi:size-height size) spacing))) + (setf (gfs:point-x pnt) wrap-coord) + (setf (gfs:point-y pnt) next-coord) + (if (< max-size (gfs:size-width size)) + (setf max-size (gfs:size-width size))) + (incf next-coord (+ (gfs:size-height size) spacing))) (progn (when (and wrap (>= width-hint 0) (> (+ next-coord - (gfi:size-width size) + (gfs:size-width size) (right-margin-of layout)) width-hint)) (push (reverse curr-flow) flows) @@ -111,12 +111,12 @@ (setf next-coord (left-margin-of layout)) (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) - (setf (gfi:point-x pnt) next-coord) - (setf (gfi:point-y pnt) wrap-coord) - (if (< max-size (gfi:size-height size)) - (setf max-size (gfi:size-height size))) - (incf next-coord (+ (gfi:size-width size) spacing)))) - (push (cons kid (make-instance 'gfi:rectangle :size size :location pnt)) curr-flow)))) + (setf (gfs:point-x pnt) next-coord) + (setf (gfs:point-y pnt) wrap-coord) + (if (< max-size (gfs:size-height size)) + (setf max-size (gfs:size-height size))) + (incf next-coord (+ (gfs:size-width size) spacing)))) + (push (cons kid (make-instance 'gfs:rectangle :size size :location pnt)) curr-flow)))) (unless (null curr-flow) (push (reverse curr-flow) flows)) (loop for flow in (nreverse flows) append flow))) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Mon Mar 20 15:48:16 2006 @@ -38,5 +38,5 @@ (defmethod check :before ((it item) flag) (declare (ignore flag)) - (if (gfi:null-handle-p (gfi:handle it)) + (if (gfs:null-handle-p (gfs:handle it)) (error 'gfs:toolkit-error :detail "null owner handle"))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Mar 20 15:48:16 2006 @@ -79,17 +79,17 @@ (compute-style-flags label style) (let ((hwnd (create-window gfs::+static-classname+ " " - (gfi:handle parent) + (gfs:handle parent) (logior std-style gfs::+ws-child+ gfs::+ws-visible+) ex-style))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value label 'gfi:handle) hwnd))) + (setf (slot-value label 'gfs:handle) hwnd))) (init-control label)) (defmethod preferred-size ((label label) width-hint height-hint) - (let* ((hwnd (gfi:handle label)) + (let* ((hwnd (gfs:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (b-width (border-width label)) (sz nil) @@ -99,11 +99,11 @@ (setf flags (logior flags gfs::+dt-wordbreak+))) (setf sz (widget-text-size label flags width-hint)) (if (>= width-hint 0) - (setf (gfi:size-width sz) width-hint)) + (setf (gfs:size-width sz) width-hint)) (if (>= height-hint 0) - (setf (gfi:size-height sz) height-hint)) - (incf (gfi:size-width sz) (* b-width 2)) - (incf (gfi:size-height sz) (* b-width 2)) + (setf (gfs:size-height sz) height-hint)) + (incf (gfs:size-width sz) (* b-width 2)) + (incf (gfs:size-height sz) (* b-width 2)) sz)) (defmethod text ((label label)) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Mon Mar 20 15:48:16 2006 @@ -48,23 +48,23 @@ (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids do (let* ((rect (cdr k)) - (sz (gfi:size rect)) - (pnt (gfi:location rect))) - (if (gfi:null-handle-p hdwp) - (gfs::set-window-pos (gfi:handle (car k)) + (sz (gfs:size rect)) + (pnt (gfs:location rect))) + (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle (car k)) (cffi:null-pointer) - (gfi:point-x pnt) - (gfi:point-y pnt) - (gfi:size-width sz) - (gfi:size-height sz) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width sz) + (gfs:size-height sz) +window-pos-flags+) (setf hdwp (gfs::defer-window-pos hdwp - (gfi:handle (car k)) + (gfs:handle (car k)) (cffi:null-pointer) - (gfi:point-x pnt) - (gfi:point-y pnt) - (gfi:size-width sz) - (gfi:size-height sz) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width sz) + (gfs:size-height sz) +window-pos-flags+))))) - (unless (gfi:null-handle-p hdwp) + (unless (gfs:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp))))) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Mon Mar 20 15:48:16 2006 @@ -185,44 +185,44 @@ ;;; (defmethod check ((it menu-item) flag) - (let ((hmenu (gfi:handle it))) + (let ((hmenu (gfs:handle it))) (check-menuitem hmenu (item-id it) flag))) (defmethod checked-p ((it menu-item)) - (let ((hmenu (gfi:handle it))) - (if (gfi:null-handle-p hmenu) + (let ((hmenu (gfs:handle it))) + (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) (is-menuitem-checked hmenu (item-id it)))) -(defmethod gfi:dispose ((it menu-item)) +(defmethod gfs:dispose ((it menu-item)) (setf (dispatcher it) nil) (remove-menuitem (thread-context) it) (let ((id (item-id it)) (owner (item-owner it))) (unless (null owner) - (gfs::remove-menu (gfi:handle owner) id gfs::+mf-bycommand+) + (gfs::remove-menu (gfs:handle owner) id gfs::+mf-bycommand+) (let* ((index (item-index owner it)) (child-menu (sub-menu owner index))) (unless (null child-menu) - (gfi:dispose child-menu)))) + (gfs:dispose child-menu)))) (setf (item-id it) 0) - (setf (slot-value it 'gfi:handle) nil))) + (setf (slot-value it 'gfs:handle) nil))) (defmethod enable ((it menu-item) flag) (let ((bits 0)) (if flag (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-enabled+)) (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-grayed+))) - (gfs::enable-menu-item (gfi:handle it) (item-id it) bits))) + (gfs::enable-menu-item (gfs:handle it) (item-id it) bits))) (defmethod enabled-p ((it menu-item)) - (= (logand (get-menuitem-state (gfi:handle it) (item-id it)) + (= (logand (get-menuitem-state (gfs:handle it) (item-id it)) gfs::+mfs-enabled+) gfs::+mfs-enabled+)) (defmethod item-owner ((it menu-item)) - (let ((hmenu (gfi:handle it))) - (if (gfi:null-handle-p hmenu) + (let ((hmenu (gfs:handle it))) + (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) (let ((m (get-widget (thread-context) hmenu))) (if (null m) @@ -230,13 +230,13 @@ m))) (defmethod text ((it menu-item)) - (let ((hmenu (gfi:handle it))) - (if (gfi:null-handle-p hmenu) + (let ((hmenu (gfs:handle it))) + (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) (get-menuitem-text hmenu (item-id it)))) (defmethod (setf text) (str (it menu-item)) - (let ((hmenu (gfi:handle it))) - (if (gfi:null-handle-p hmenu) + (let ((hmenu (gfs:handle it))) + (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) (set-menuitem-text hmenu (item-id it) str))) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Mar 20 15:48:16 2006 @@ -204,10 +204,10 @@ (defmethod define-separator ((gen win32-menu-generator)) (let* ((owner (first (menu-stack-of gen))) (it (make-instance 'menu-item)) - (hmenu (gfi:handle owner))) + (hmenu (gfs:handle owner))) (put-menuitem (thread-context) it) (insert-separator hmenu) - (setf (slot-value it 'gfi:handle) hmenu) + (setf (slot-value it 'gfs:handle) hmenu) (vector-push-extend it (items owner)))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Mar 20 15:48:16 2006 @@ -111,10 +111,10 @@ (error 'gfs::win32-error :detail "insert-menu-item failed")))) (defun sub-menu (m index) - (if (gfi:disposed-p m) - (error 'gfi:disposed-error)) - (let ((hwnd (gfs::get-submenu (gfi:handle m) index))) - (if (not (gfi:null-handle-p hwnd)) + (if (gfs:disposed-p m) + (error 'gfs:disposed-error)) + (let ((hwnd (gfs::get-submenu (gfs:handle m) index))) + (if (not (gfs:null-handle-p hwnd)) (get-widget (thread-context) hwnd) nil))) @@ -133,7 +133,7 @@ (defmethod append-item ((owner menu) text image disp) (let* ((tc (thread-context)) (id (increment-menuitem-id tc)) - (hmenu (gfi:handle owner)) + (hmenu (gfs:handle owner)) (item (create-menuitem-with-callback hmenu disp))) (insert-menuitem hmenu id text (cffi:null-pointer)) (setf (item-id item) id) @@ -142,12 +142,12 @@ item)) (defmethod append-submenu ((parent menu) text (submenu menu) disp) - (if (or (gfi:disposed-p parent) (gfi:disposed-p submenu)) - (error 'gfi:disposed-error)) + (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu)) + (error 'gfs:disposed-error)) (let* ((tc (thread-context)) (id (increment-menuitem-id tc)) - (hparent (gfi:handle parent)) - (hmenu (gfi:handle submenu)) + (hparent (gfs:handle parent)) + (hmenu (gfs:handle submenu)) (item (make-instance 'menu-item :handle hparent))) (insert-submenu hparent id text (cffi:null-pointer) hmenu) (setf (item-id item) id) @@ -168,14 +168,14 @@ (defun menu-cleanup-callback (menu item) (let ((tc (thread-context))) - (remove-widget tc (gfi:handle menu)) + (remove-widget tc (gfs:handle menu)) (remove-menuitem tc item))) -(defmethod gfi:dispose ((m menu)) +(defmethod gfs:dispose ((m menu)) (visit-menu-tree m #'menu-cleanup-callback) - (let ((hwnd (gfi:handle m))) + (let ((hwnd (gfs:handle m))) (remove-widget (thread-context) hwnd) - (if (not (gfi:null-handle-p hwnd)) + (if (not (gfs:null-handle-p hwnd)) (if (zerop (gfs::destroy-menu hwnd)) (error 'gfs:win32-error :detail "destroy-menu failed")))) - (setf (slot-value m 'gfi:handle) nil)) + (setf (slot-value m 'gfs:handle) nil)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Mon Mar 20 15:48:16 2006 @@ -64,8 +64,8 @@ (defmethod initialize-instance :after ((win panel) &key parent style &allow-other-keys) (if (null parent) (error 'gfs:toolkit-error :detail "parent is required for panel")) - (if (gfi:disposed-p parent) - (error 'gfi:disposed-error)) + (if (gfs:disposed-p parent) + (error 'gfs:disposed-error)) (if (not (listp style)) (setf style (list style))) (init-window win +panel-window-classname+ #'register-panel-window-class style parent "")) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Mar 20 15:48:16 2006 @@ -41,10 +41,10 @@ (event-time :initform 0 :accessor event-time) (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) - (mouse-event-pnt :initform (gfi:make-point) :accessor mouse-event-pnt) - (move-event-pnt :initform (gfi:make-point) :accessor move-event-pnt) + (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) + (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) (next-menuitem-id :initform 10000 :reader next-menuitem-id) - (size-event-size :initform (gfi:make-size) :accessor size-event-size) + (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) (wip :initform nil)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) @@ -91,14 +91,14 @@ "Return the widget object corresponding to the specified native window handle." (let ((tmp-widget (slot-value tc 'wip))) (when tmp-widget - (setf (slot-value tmp-widget 'gfi:handle) hwnd) + (setf (slot-value tmp-widget 'gfs:handle) hwnd) (return-from get-widget tmp-widget))) - (unless (gfi:null-handle-p hwnd) + (unless (gfs:null-handle-p hwnd) (gethash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd)))) (defmethod put-widget ((tc thread-context) (w widget)) "Add the specified widget to the widget table using its native handle as the key." - (setf (gethash (cffi:pointer-address (gfi:handle w)) (slot-value tc 'widgets-by-hwnd)) w)) + (setf (gethash (cffi:pointer-address (gfs:handle w)) (slot-value tc 'widgets-by-hwnd)) w)) (defmethod remove-widget ((tc thread-context) hwnd) "Remove the widget object corresponding to the specified native window handle." Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Mon Mar 20 15:48:16 2006 @@ -110,17 +110,17 @@ (flatten style)) (values std-flags ex-flags))) -(defmethod gfi:dispose ((win top-level)) +(defmethod gfs:dispose ((win top-level)) (let ((m (menu-bar win))) (unless (null m) (visit-menu-tree m #'menu-cleanup-callback) - (remove-widget (thread-context) (gfi:handle m)))) + (remove-widget (thread-context) (gfs:handle m)))) (call-next-method)) (defmethod initialize-instance :after ((win top-level) &key owner style title &allow-other-keys) (unless (null owner) - (if (gfi:disposed-p owner) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error))) (if (null title) (setf title +default-window-title+)) (if (not (listp style)) @@ -128,12 +128,12 @@ (init-window win +toplevel-window-classname+ #'register-toplevel-window-class style owner title)) (defmethod menu-bar :before ((win top-level)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) (defmethod menu-bar ((win top-level)) - (let ((hmenu (gfs::get-menu (gfi:handle win)))) - (if (gfi:null-handle-p hmenu) + (let ((hmenu (gfs::get-menu (gfs:handle win)))) + (if (gfs:null-handle-p hmenu) (return-from menu-bar nil)) (let ((m (get-widget (thread-context) hmenu))) (if (null m) @@ -142,31 +142,31 @@ (defmethod (setf menu-bar) :before ((m menu) (win top-level)) (declare (ignore m)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) (defmethod (setf menu-bar) ((m menu) (win top-level)) - (let* ((hwnd (gfi:handle win)) + (let* ((hwnd (gfs:handle win)) (hmenu (gfs::get-menu hwnd)) (old-menu (get-widget (thread-context) hmenu))) - (unless (gfi:null-handle-p hmenu) + (unless (gfs:null-handle-p hmenu) (gfs::destroy-menu hmenu)) (unless (null old-menu) - (gfi:dispose old-menu)) - (gfs::set-menu hwnd (gfi:handle m)) + (gfs:dispose old-menu)) + (gfs::set-menu hwnd (gfs:handle m)) (gfs::draw-menu-bar hwnd))) (defmethod text :before ((win top-level)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) (defmethod text ((win top-level)) (get-widget-text win)) (defmethod (setf text) :before (str (win top-level)) (declare (ignore str)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) (defmethod (setf text) (str (win top-level)) (set-widget-text win str)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Mar 20 15:48:16 2006 @@ -36,7 +36,7 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) -(defclass event-source (gfi:native-object) +(defclass event-source (gfs:native-object) ((dispatcher :accessor dispatcher :initarg :dispatcher Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Mar 20 15:48:16 2006 @@ -57,7 +57,7 @@ (defun clear-all (w) (let ((count (gfw:item-count w))) (unless (zerop count) - (gfw:clear-span w (gfi:make-span :start 0 :end (1- count)))))) + (gfw:clear-span w (gfs:make-span :start 0 :end (1- count)))))) (defun create-window (class-name title parent-hwnd std-style ex-style) (cffi:with-foreign-string (cname-ptr class-name) @@ -84,10 +84,10 @@ (mapcan (function flatten) tree))) (defun get-widget-text (w) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)) (let* ((text "") - (hwnd (gfi:handle w)) + (hwnd (gfs:handle w)) (len (gfs::get-window-text-length hwnd))) (unless (zerop len) (incf len) @@ -105,10 +105,10 @@ gfs::windowtop) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) - (setf (gfi:point-x pnt) gfs::windowleft) - (setf (gfi:point-y pnt) gfs::windowtop)))) + (setf (gfs:point-x pnt) gfs::windowleft) + (setf (gfs:point-y pnt) gfs::windowtop)))) (defun outer-size (w sz) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) @@ -119,26 +119,26 @@ gfs::windowbottom) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) - (setf (gfi:size-width sz) (- gfs::windowright gfs::windowleft)) - (setf (gfi:size-height sz) (- gfs::windowbottom gfs::windowtop))))) + (setf (gfs:size-width sz) (- gfs::windowright gfs::windowleft)) + (setf (gfs:size-height sz) (- gfs::windowbottom gfs::windowtop))))) (defun set-widget-text (w str) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) - (gfs::set-window-text (gfi:handle w) str)) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)) + (gfs::set-window-text (gfs:handle w) str)) (defun widget-text-size (widget dt-flags width-hint) - (let* ((hwnd (gfi:handle widget)) + (let* ((hwnd (gfs:handle widget)) (str (text widget)) (len (length str)) - (sz (gfi:make-size)) + (sz (gfs:make-size)) (hfont nil)) (setf dt-flags (logior dt-flags gfs::+dt-calcrect+)) - (gfs:with-retrieved-dc (hwnd hdc) + (gfs::with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) - (gfs:with-hfont-selected (hdc hfont) + (gfs::with-hfont-selected (hdc hfont) (when (> len 0) (cffi:with-foreign-object (rect-ptr 'gfs::rect) (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) @@ -146,13 +146,13 @@ (if (> width-hint 0) (setf gfs::right width-hint)) (gfs::draw-text hdc str -1 rect-ptr dt-flags (cffi:null-pointer)) - (setf (gfi:size-width sz) (- gfs::right gfs::left)) - (setf (gfi:size-height sz) (- gfs::bottom gfs::top))))) - (when (or (zerop len) (zerop (gfi:size-height sz))) + (setf (gfs:size-width sz) (- gfs::right gfs::left)) + (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))) + (when (or (zerop len) (zerop (gfs:size-height sz))) (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) tm-ptr gfs::textmetrics) (if (zerop (gfs::get-text-metrics hdc tm-ptr)) (error 'gfs:win32-error :detail "get-text-metrics failed")) - (setf (gfi:size-height sz) (+ gfs::tmheight gfs::tmexternalleading))))))) + (setf (gfs:size-height sz) (+ gfs::tmheight gfs::tmexternalleading))))))) sz)) Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Mon Mar 20 15:48:16 2006 @@ -35,57 +35,57 @@ (defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher)) (declare (ignore text image disp)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod clear-item :before ((w widget-with-items) index) (declare (ignore index)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod clear-item ((w widget-with-items) index) (let ((it (item-at w index))) (delete it (items w) :test #'items-equal-p) - (if (gfi:disposed-p it) - (error 'gfi:disposed-error)) - (gfi:dispose it))) + (if (gfs:disposed-p it) + (error 'gfs:disposed-error)) + (gfs:dispose it))) -(defmethod clear-span :before ((w widget-with-items) (sp gfi:span)) +(defmethod clear-span :before ((w widget-with-items) (sp gfs:span)) (declare (ignore sp)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) -(defmethod clear-span ((w widget-with-items) (sp gfi:span)) - (dotimes (i (1+ (- (gfi:span-end sp) (gfi:span-start sp)))) - (clear-item w (gfi:span-start sp)))) +(defmethod clear-span ((w widget-with-items) (sp gfs:span)) + (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) + (clear-item w (gfs:span-start sp)))) (defmethod item-at :before ((w widget-with-items) index) (declare (ignore index)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod item-at ((w widget-with-items) index) (elt (items w) index)) (defmethod (setf item-at) :before (index (it item) (w widget-with-items)) (declare (ignorable index it)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod (setf item-at) (index (it item) (w widget-with-items)) (error 'gfs:toolkit-error :detail "not yet implemented")) (defmethod item-count :before ((w widget-with-items)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod item-count ((w widget-with-items)) (length (items w))) (defmethod item-index :before ((w widget-with-items) (it item)) (declare (ignore it)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod item-index ((w widget-with-items) (it item)) (let ((pos (position it (items w) :test #'items-equal-p))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Mar 20 15:48:16 2006 @@ -42,24 +42,24 @@ ;;; (defmethod ancestor-p :before ((ancestor widget) (descendant widget)) - (if (or (gfi:disposed-p ancestor) (gfi:disposed-p descendant)) - (error 'gfi:disposed-error))) + (if (or (gfs:disposed-p ancestor) (gfs:disposed-p descendant)) + (error 'gfs:disposed-error))) (defmethod ancestor-p ((ancestor widget) (descendant widget)) - (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+)) + (let* ((parent-hwnd (gfs::get-ancestor (gfs:handle descendant) gfs::+ga-parent+)) (parent (get-widget (thread-context) parent-hwnd))) - (if (cffi:pointer-eq (gfi:handle ancestor) parent-hwnd) + (if (cffi:pointer-eq (gfs:handle ancestor) parent-hwnd) (return-from ancestor-p t)) (if (null parent) (error 'gfs:toolkit-error :detail "no widget for parent handle")) (ancestor-p ancestor parent))) (defmethod border-width :before ((widget widget)) - (if (gfi:disposed-p widget) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error))) (defmethod border-width ((widget widget)) - (let* ((hwnd (gfi:handle widget)) + (let* ((hwnd (gfs:handle widget)) (bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) (when (logand bits gfs::+ws-ex-clientedge+) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxedge+))) @@ -71,16 +71,16 @@ 0)) (defmethod checked-p :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod checked-p ((w widget)) (declare (ignore w)) nil) (defmethod client-size :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod client-size ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) @@ -91,38 +91,38 @@ gfs::clientbottom) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) - (gfi:make-size :width (- gfs::clientright gfs::clientleft) + (gfs:make-size :width (- gfs::clientright gfs::clientleft) :height (- gfs::clientbottom gfs::clienttop))))) -(defmethod gfi:dispose ((w widget)) +(defmethod gfs:dispose ((w widget)) (unless (null (dispatcher w)) (event-dispose (dispatcher w) w 0)) - (let ((hwnd (gfi:handle w))) - (if (not (gfi:null-handle-p hwnd)) + (let ((hwnd (gfs:handle w))) + (if (not (gfs:null-handle-p hwnd)) (if (zerop (gfs::destroy-window hwnd)) (error 'gfs:win32-error :detail "destroy-window failed")))) - (setf (slot-value w 'gfi:handle) nil)) + (setf (slot-value w 'gfs:handle) nil)) (defmethod enable :before ((w widget) flag) (declare (ignore flag)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod enable ((w widget) flag) - (gfs::enable-window (gfi:handle w) (if (null flag) 0 1))) + (gfs::enable-window (gfs:handle w) (if (null flag) 0 1))) (defmethod enabled-p :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod enabled-p ((w widget)) - (not (zerop (gfs::is-window-enabled (gfi:handle w))))) + (not (zerop (gfs::is-window-enabled (gfs:handle w))))) (defmethod location :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod location ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) @@ -131,98 +131,98 @@ gfs::clienttop) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) (cffi:with-foreign-object (pnt-ptr 'gfs::point) (cffi:with-foreign-slots ((gfs::x gfs::y) pnt-ptr gfs::point) (setf gfs::x gfs::clientleft) (setf gfs::y gfs::clienttop) - (gfs::screen-to-client (gfi:handle w) pnt-ptr) - (gfi:make-point :x gfs::x :y gfs::y)))))) + (gfs::screen-to-client (gfs:handle w) pnt-ptr) + (gfs:make-point :x gfs::x :y gfs::y)))))) -(defmethod (setf location) :before ((pnt gfi:point) (w widget)) +(defmethod (setf location) :before ((pnt gfs:point) (w widget)) (declare (ignore pnt)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) -(defmethod (setf location) ((pnt gfi:point) (w widget)) - (if (zerop (gfs::set-window-pos (gfi:handle w) +(defmethod (setf location) ((pnt gfs:point) (w widget)) + (if (zerop (gfs::set-window-pos (gfs:handle w) (cffi:null-pointer) - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) 0 0 gfs::+swp-nosize+)) (error 'gfs:win32-error :detail "set-window-pos failed"))) (defmethod pack :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod pack ((w widget)) (setf (size w) (preferred-size w -1 -1))) (defmethod redraw :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod redraw ((w widget)) - (let ((hwnd (gfi:handle w))) - (unless (gfi:null-handle-p hwnd) + (let ((hwnd (gfs:handle w))) + (unless (gfs:null-handle-p hwnd) (gfs::invalidate-rect hwnd nil 1)))) (defmethod selected-p :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod selected-p ((w widget)) (declare (ignore w)) nil) (defmethod size :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod size ((w widget)) (client-size w)) -(defmethod (setf size) :before ((sz gfi:size) (w widget)) +(defmethod (setf size) :before ((sz gfs:size) (w widget)) (declare (ignore sz)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) -(defmethod (setf size) ((sz gfi:size) (w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) - (if (zerop (gfs::set-window-pos (gfi:handle w) +(defmethod (setf size) ((sz gfs:size) (w widget)) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)) + (if (zerop (gfs::set-window-pos (gfs:handle w) (cffi:null-pointer) 0 0 - (gfi:size-width sz) - (gfi:size-height sz) + (gfs:size-width sz) + (gfs:size-height sz) gfs::+swp-nomove+)) (error 'gfs:win32-error :detail "set-window-pos failed"))) (defmethod show :before ((w widget) flag) (declare (ignore flag)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod show ((w widget) flag) - (gfs::show-window (gfi:handle w) + (gfs::show-window (gfs:handle w) (if flag gfs::+sw-showna+ gfs::+sw-hide+))) (defmethod update :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod update ((w widget)) - (let ((hwnd (gfi:handle w))) - (unless (gfi:null-handle-p hwnd) + (let ((hwnd (gfs:handle w))) + (unless (gfs:null-handle-p hwnd) (gfs::update-window hwnd)))) (defmethod visible-p :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error))) (defmethod visible-p ((w widget)) - (not (zerop (gfs::is-window-visible (gfi:handle w))))) + (not (zerop (gfs::is-window-visible (gfs:handle w))))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Mar 20 15:48:16 2006 @@ -45,11 +45,11 @@ (compute-style-flags win style) (create-window classname text - (if (null parent) (cffi:null-pointer) (gfi:handle parent)) + (if (null parent) (cffi:null-pointer) (gfs:handle parent)) std-style ex-style)) (clear-widget-in-progress tc) - (let ((hwnd (gfi:handle win))) + (let ((hwnd (gfs:handle win))) (if (not hwnd) ; handle slot should have been set during create-window (error 'gfs:win32-error :detail "create-window failed")) (put-widget tc win)))) @@ -84,17 +84,17 @@ (let ((tc (thread-context))) (push-child-visitor-func tc func) (unwind-protect -#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win))) +#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle win))) (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address (gfi:handle win))) + (cffi:pointer-address (gfs:handle win))) #+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) (setf ptr (ffi:set-foreign-pointer (ffi:unsigned-foreign-address - (cffi:pointer-address (gfi:handle win))) + (cffi:pointer-address (gfs:handle win))) ptr)) (gfs::enum-child-windows ptr #'child_window_visitor - (cffi:pointer-address (gfi:handle win)))) + (cffi:pointer-address (gfs:handle win)))) (pop-child-visitor-func tc))) nil) @@ -152,40 +152,40 @@ ;; (let ((client-sz (client-size win)) (outer-sz (size win)) - (trim-sz (gfi:make-size :width (gfi:size-width desired-client-size) - :height (gfi:size-height desired-client-size)))) - (incf (gfi:size-width trim-sz) (- (gfi:size-width outer-sz) - (gfi:size-width client-sz))) - (incf (gfi:size-height trim-sz) (- (gfi:size-height outer-sz) - (gfi:size-height client-sz))) + (trim-sz (gfs:make-size :width (gfs:size-width desired-client-size) + :height (gfs:size-height desired-client-size)))) + (incf (gfs:size-width trim-sz) (- (gfs:size-width outer-sz) + (gfs:size-width client-sz))) + (incf (gfs:size-height trim-sz) (- (gfs:size-height outer-sz) + (gfs:size-height client-sz))) trim-sz)) (defmethod enable-layout :before ((win window) flag) (declare (ignore flag)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) (defmethod enable-layout ((win window) flag) (setf (slot-value win 'layout-p) flag) (if flag (let ((sz (client-size win))) - (perform-layout win (gfi:size-width sz) (gfi:size-height sz))))) + (perform-layout win (gfs:size-width sz) (gfs:size-height sz))))) (defmethod event-resize ((d event-dispatcher) (win window) time size type) (declare (ignorable d time size type)) (let ((sz (client-size win))) - (perform-layout win (gfi:size-width sz) (gfi:size-height sz)))) + (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) (defmethod location ((win window)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error)) - (let ((pnt (gfi:make-point))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error)) + (let ((pnt (gfs:make-point))) (outer-location win pnt) pnt)) (defmethod layout ((win window)) (let ((sz (client-size win))) - (perform-layout win (gfi:size-width sz) (gfi:size-height sz)))) + (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) (defmethod pack ((win window)) (perform-layout win -1 -1) @@ -201,9 +201,9 @@ (defmethod show ((win window) flag) (declare (ignore flag)) (call-next-method) - (gfs::update-window (gfi:handle win))) + (gfs::update-window (gfs:handle win))) (defmethod size ((win window)) - (let ((sz (gfi:make-size))) + (let ((sz (gfs:make-size))) (outer-size win sz) sz))

1 0

[graphic-forms-cvs] r57 - in trunk: docs/website src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 20 Mar '06

20 Mar '06

Author: junrue Date: Mon Mar 20 01:52:46 2006 New Revision: 57 Modified: trunk/docs/website/index.html trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/menu-language.lisp Log: last round of fixes before screenshot upload; renamed menu language macro to defmenu Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Mon Mar 20 01:52:46 2006 @@ -15,7 +15,7 @@ <div class="NavBar"> <a class="barfirst" href="http://awayrepl.blogspot.com/">News</a> - <a class="barcenter" href="screenshots.html">Screenshots</a> + <a class="barcenter" href="https://sourceforge.net/project/screenshots.php?group_id=163034">Screenshots</a> <a class="barcenter" href="download.html">Download</a> <a class="barcenter" href="docs.html">Documentation</a> <a class="barlast" href="http://sourceforge.net/tracker/?group_id=163034&atid=826145">Bug Database</a> Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 01:52:46 2006 @@ -332,7 +332,7 @@ #:cursor #:cut #:default-item - #:defmenusystem + #:defmenu #:disabled-image #:dispatcher #:display-to-object Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Mar 20 01:52:46 2006 @@ -192,18 +192,18 @@ (menubar nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) :style '(:style-workspace))) - (setf menubar (gfw:defmenusystem ((:item "&File" :dispatcher echo-md - :submenu ((:item "&Open..." :dispatcher echo-md) - (:item "&Save..." :disabled :dispatcher echo-md) - (:item "" :separator) - (:item "E&xit" :dispatcher exit-md))) - (:item "&Options" :dispatcher echo-md - :submenu ((:item "&Enabled" :checked :dispatcher echo-md) - (:item "&Tools" :dispatcher echo-md - :submenu ((:item "&Fonts" :dispatcher echo-md :disabled) - (:item "&Colors" :dispatcher echo-md))))) - (:item "&Help" :dispatcher echo-md - :submenu ((:item "&About" :dispatcher echo-md)))))) + (setf menubar (gfw:defmenu ((:item "&File" :dispatcher echo-md + :submenu ((:item "&Open..." :dispatcher echo-md) + (:item "&Save..." :disabled :dispatcher echo-md) + (:item "" :separator) + (:item "E&xit" :dispatcher exit-md))) + (:item "&Options" :dispatcher echo-md + :submenu ((:item "&Enabled" :checked :dispatcher echo-md) + (:item "&Tools" :dispatcher echo-md + :submenu ((:item "&Fonts" :dispatcher echo-md :disabled) + (:item "&Colors" :dispatcher echo-md))))) + (:item "&Help" :dispatcher echo-md + :submenu ((:item "&About" :dispatcher echo-md)))))) (setf (gfw:menu-bar *event-tester-window*) menubar) (gfw:show *event-tester-window* t))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Mar 20 01:52:46 2006 @@ -62,8 +62,8 @@ (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) :style '(:style-workspace))) - (setf menubar (gfw:defmenusystem ((:item "&File" - :submenu ((:item "E&xit" :callback #'exit-fn)))))) + (setf menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-fn)))))) (setf (gfw:menu-bar *hello-win*) menubar) (gfw:show *hello-win* t))) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Mon Mar 20 01:52:46 2006 @@ -105,8 +105,8 @@ :style '(:style-workspace))) (setf (gfw:size *image-win*) (gfi:make-size :width 250 :height 200)) (setf (gfw:text *image-win*) "Image Tester") - (setf menubar (gfw:defmenusystem ((:item "&File" - :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) + (setf menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) (gfw:show *image-win* t))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Mar 20 01:52:46 2006 @@ -293,38 +293,38 @@ (declare (ignore disp time)) (gfw:clear-all menu) (let ((it nil) - (margin-menu (gfw:defmenusystem ((:item "Left" - :callback #'enable-left-flow-margin-items - :submenu ((:item "Decrease" - :callback #'dec-left-flow-margin) - (:item "Increase" - :callback #'inc-left-flow-margin))) - (:item "Top" - :callback #'enable-top-flow-margin-items - :submenu ((:item "Decrease" - :callback #'dec-top-flow-margin) - (:item "Increase" - :callback #'inc-top-flow-margin))) - (:item "Right" - :callback #'enable-right-flow-margin-items - :submenu ((:item "Decrease" - :callback #'dec-right-flow-margin) - (:item "Increase" - :callback #'inc-right-flow-margin))) - (:item "Bottom" - :callback #'enable-bottom-flow-margin-items - :submenu ((:item "Decrease" - :callback #'dec-bottom-flow-margin) - (:item "Increase" - :callback #'inc-bottom-flow-margin)))))) - (orient-menu (gfw:defmenusystem ((:item "Horizontal" - :callback #'set-flow-horizontal) - (:item "Vertical" - :callback #'set-flow-vertical)))) - (spacing-menu (gfw:defmenusystem ((:item "Decrease" - :callback #'decrease-flow-spacing) - (:item "Increase" - :callback #'increase-flow-spacing))))) + (margin-menu (gfw:defmenu ((:item "Left" + :callback #'enable-left-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-left-flow-margin) + (:item "Increase" + :callback #'inc-left-flow-margin))) + (:item "Top" + :callback #'enable-top-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-top-flow-margin) + (:item "Increase" + :callback #'inc-top-flow-margin))) + (:item "Right" + :callback #'enable-right-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-right-flow-margin) + (:item "Increase" + :callback #'inc-right-flow-margin))) + (:item "Bottom" + :callback #'enable-bottom-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-bottom-flow-margin) + (:item "Increase" + :callback #'inc-bottom-flow-margin)))))) + (orient-menu (gfw:defmenu ((:item "Horizontal" + :callback #'set-flow-horizontal) + (:item "Vertical" + :callback #'set-flow-vertical)))) + (spacing-menu (gfw:defmenu ((:item "Decrease" + :callback #'decrease-flow-spacing) + (:item "Increase" + :callback #'increase-flow-spacing))))) (gfw:append-submenu menu "Margin" margin-menu nil) (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-items) (gfw:append-submenu menu "Spacing" spacing-menu #'enable-flow-spacing-items) @@ -352,27 +352,28 @@ :layout (make-instance 'gfw:flow-layout :spacing +spacing-delta+ :margins +margin-delta+))) - (setf menubar (gfw:defmenusystem ((:item "&File" - :submenu ((:item "E&xit" - :callback #'exit-layout-callback))) - (:item "&Children" - :submenu ((:item "Add" - :submenu ((:item "Button" :dispatcher add-btn-disp) - (:item "Label" :dispatcher add-text-label-disp) - (:item "Panel" :dispatcher add-panel-disp))) - (:item "Remove" :dispatcher rem-menu-disp - :submenu ((:item ""))) - (:item "Visible" :dispatcher vis-menu-disp - :submenu ((:item ""))))) - (:item "&Window" - :submenu ((:item "Modify Layout" :callback #'flow-mod-callback - :submenu ((:item ""))) - (:item "Select Layout" - :submenu ((:item "Flow"))) - (:item "Pack" :dispatcher pack-disp)))))) + (setf menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" + :callback #'exit-layout-callback))) + (:item "&Children" + :submenu ((:item "Add" + :submenu ((:item "Button" :dispatcher add-btn-disp) + (:item "Label" :dispatcher add-text-label-disp) + (:item "Panel" :dispatcher add-panel-disp))) + (:item "Remove" :dispatcher rem-menu-disp + :submenu ((:item ""))) + (:item "Visible" :dispatcher vis-menu-disp + :submenu ((:item ""))))) + (:item "&Window" + :submenu ((:item "Modify Layout" :callback #'flow-mod-callback + :submenu ((:item ""))) + (:item "Select Layout" + :submenu ((:item "Flow"))) + (:item "Pack" :dispatcher pack-disp)))))) (setf (gfw:menu-bar *layout-tester-win*) menubar) (dotimes (i 3) (add-layout-tester-widget 'gfw:button :push-button)) + (setf (gfw:text *layout-tester-win*) "Layout Tester") (gfw:pack *layout-tester-win*) (gfw:show *layout-tester-win* t))) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Mar 20 01:52:46 2006 @@ -103,12 +103,12 @@ (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) :style '(:style-workspace))) - (setf menubar (gfw:defmenusystem ((:item "&File" - :submenu ((:item "E&xit" :callback #'exit-callback))) - (:item "&Windows" - :submenu ((:item "&Borderless" :callback #'create-borderless-win) - (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Palette" :callback #'create-palette-win)))))) + (setf menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-callback))) + (:item "&Windows" + :submenu ((:item "&Borderless" :callback #'create-borderless-win) + (:item "&Mini Frame" :callback #'create-miniframe-win) + (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) (gfw:show *main-win* t))) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Mar 20 01:52:46 2006 @@ -38,14 +38,14 @@ ;;; #| -(gfw:defmenusystem ((:item "&File" :submenu ((:item "&Open...") - (:item "&Save..." :disabled) - (:item :separator) - (:item "E&xit" :callback #'some-fn))) - (:item "&Options" :submenu ((:item "&Enabled" :checked) - (:item "&Tools" :submenu ((:item "&Fonts" :disabled) - (:item "&Colors"))))) - (:item "&Help" :submenu ((:item "&About" :image some-image))))) +(gfw:defmenu ((:item "&File" :submenu ((:item "&Open...") + (:item "&Save..." :disabled) + (:item :separator) + (:item "E&xit" :callback #'some-fn))) + (:item "&Options" :submenu ((:item "&Enabled" :checked) + (:item "&Tools" :submenu ((:item "&Fonts" :disabled) + (:item "&Colors"))))) + (:item "&Help" :submenu ((:item "&About" :image some-image))))) |# ;;; @@ -224,7 +224,7 @@ ;;; top-level API for the menu language ;;; -(defmacro defmenusystem (sexp) +(defmacro defmenu (sexp) (let ((gen (gensym))) `(let ((,gen (make-instance 'win32-menu-generator))) ,@(generate-menusystem-code sexp gen)

1 0

[graphic-forms-cvs] r56 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 20 Mar '06

20 Mar '06

Author: junrue Date: Mon Mar 20 01:03:14 2006 New Revision: 56 Added: trunk/src/uitoolkit/widgets/label.lisp - copied, changed from r46, trunk/src/uitoolkit/widgets/text-label.lisp Removed: trunk/src/uitoolkit/widgets/text-label.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: reverted back to single label class which will distinguish text vs image via style flags Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Mar 20 01:03:14 2006 @@ -101,7 +101,7 @@ (:file "item") (:file "widget") (:file "control") - (:file "text-label") + (:file "label") (:file "button") (:file "widget-with-items") (:file "menu") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 01:03:14 2006 @@ -394,6 +394,7 @@ #:items #:key-down-p #:key-toggled-p + #:label #:layout #:layout-of #:layout-p Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Mar 20 01:03:14 2006 @@ -342,7 +342,7 @@ (add-btn-disp (make-instance 'add-child-dispatcher)) (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel :subtype :panel)) - (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label + (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher Copied: trunk/src/uitoolkit/widgets/label.lisp (from r46, trunk/src/uitoolkit/widgets/text-label.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/text-label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Mar 20 01:03:14 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; text-label.lisp +;;;; label.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -37,7 +37,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((label text-label) &rest style) +(defmethod compute-style-flags ((label label) &rest style) (declare (ignore label)) (let ((std-flags 0) (ex-flags 0)) @@ -72,7 +72,7 @@ (setf std-flags (logior std-flags gfs::+ss-left+))))) (values std-flags ex-flags))) -(defmethod initialize-instance :after ((label text-label) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((label label) &key parent style &allow-other-keys) (if (not (listp style)) (setf style (list style))) (multiple-value-bind (std-style ex-style) @@ -88,7 +88,7 @@ (init-control label)) -(defmethod preferred-size ((label text-label) width-hint height-hint) +(defmethod preferred-size ((label label) width-hint height-hint) (let* ((hwnd (gfi:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (b-width (border-width label)) @@ -106,8 +106,8 @@ (incf (gfi:size-height sz) (* b-width 2)) sz)) -(defmethod text ((label text-label)) +(defmethod text ((label label)) (get-widget-text label)) -(defmethod (setf text) (str (label text-label)) +(defmethod (setf text) (str (label label)) (set-widget-text label str)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Mar 20 01:03:14 2006 @@ -65,11 +65,8 @@ (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked.")) -(defclass image-label (control) () - (:documentation "This class represents non-selectable controls that display an image.")) - -(defclass text-label (control) () - (:documentation "This class represents non-selectable controls that display a string.")) +(defclass label (control) () + (:documentation "This class represents non-selectable controls that display a string or image.")) (defclass widget-with-items (widget) ((items

1 0

[graphic-forms-cvs] r55 - in trunk/src: . tests/uitoolkit uitoolkit/graphics
by junrue＠common-lisp.net 20 Mar '06

20 Mar '06

Author: junrue Date: Mon Mar 20 00:51:28 2006 New Revision: 55 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp Log: changed color constants to be defvars not defconstants Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:51:28 2006 @@ -124,11 +124,11 @@ #:transform ;; constants - #:+color-black+ - #:+color-blue+ - #:+color-green+ - #:+color-red+ - #:+color-white+ + #:*color-black* + #:*color-blue* + #:*color-green* + #:*color-red* + #:*color-white* ;; methods, functions, macros #:alpha Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Mar 20 00:51:28 2006 @@ -48,8 +48,8 @@ (defmethod gfw:event-paint ((d event-tester-window-events) window time gc rect) (declare (ignorable time rect)) - (setf (gfg:background-color gc) gfg:+color-white+) - (setf (gfg:foreground-color gc) gfg:+color-blue+) + (setf (gfg:background-color gc) gfg:*color-white*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) (let* ((sz (gfw:client-size window)) (pnt (gfi:make-point :x 0 :y (floor (/ (gfi:size-height sz) 2))))) (gfg:draw-text gc *event-tester-text* pnt))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Mar 20 00:51:28 2006 @@ -46,10 +46,10 @@ (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) :size (gfw:client-size window))) - (setf (gfg:background-color gc) gfg:+color-white+) + (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect) - (setf (gfg:background-color gc) gfg:+color-red+) - (setf (gfg:foreground-color gc) gfg:+color-green+) + (setf (gfg:background-color gc) gfg:*color-red*) + (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfi:make-point))) (defun exit-fn (disp item time rect) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Mar 20 00:51:28 2006 @@ -49,7 +49,7 @@ (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) :size (gfw:client-size window))) - (setf (gfg:background-color gc) gfg:+color-white+) + (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect)) (defclass test-mini-events (test-win-events) ()) Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Mon Mar 20 00:51:28 2006 @@ -34,12 +34,6 @@ (in-package :graphic-forms.uitoolkit.graphics) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) - (defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) - (defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) - (defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) - (defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) - (defmacro color-as-rgb (color) (let ((result (gensym))) `(let ((,result 0)) @@ -48,6 +42,12 @@ (setf (ldb (byte 8 16) ,result) (color-blue ,color)) ,result)))) +(defvar *color-black* (make-color :red 0 :green 0 :blue 0)) +(defvar *color-blue* (make-color :red 0 :green 0 :blue #xFF)) +(defvar *color-green* (make-color :red 0 :green #xFF :blue 0)) +(defvar *color-red* (make-color :red #xFF :green 0 :blue 0)) +(defvar *color-white* (make-color :red #xFF :green #xFF :blue #xFF)) + (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)))) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:51:28 2006 @@ -99,11 +99,13 @@ (if (not (null (transparency-pixel-of im))) (let ((hmask (gfi:handle (transparency-mask im))) (hcopy (clone-bitmap himage)) - (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) + (black (make-color :red 0 :green 0 :blue 0)) + (white (make-color :red #xFF :green #xFF :blue #xFF))) (gfs::select-object memdc hmask) (gfs::select-object memdc2 hcopy) - (gfs::set-bk-color memdc2 (color-as-rgb +color-black+)) - (gfs::set-text-color memdc2 (color-as-rgb +color-white+)) + (gfs::set-bk-color memdc2 (color-as-rgb black)) + (gfs::set-text-color memdc2 (color-as-rgb white)) (gfs::bit-blt memdc2 0 0 gfs::width

1 0