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

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

17 Aug '06

Author: junrue Date: Thu Aug 17 17:55:50 2006 New Revision: 218 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layout-generics.lisp trunk/src/uitoolkit/widgets/layout.lisp Log: implemented and documented gfw:layout-attribute function Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Thu Aug 17 17:55:50 2006 @@ -551,8 +551,12 @@ @item :large Identifies the largest image of the @var{icon-bundle}. @item :small -Identifies the smallest image of the @var{icon-bundle}. +Identifies the smallest image of the @var{icon-bundle}.@*@* @end table +@strong{Note:} there are actually four icon sizes that Windows +defines for various contexts. A future release will add keywords to +better distinguish amongst all four, and to help ensure the correct +sizes are chosen when an icon-bundle is passed to @sc{(setf gfw:image)}. @end table To find out how many images are stored in @var{icon-bundle}, and hence what constitutes a valid range of subscripts for this function, Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Thu Aug 17 17:55:50 2006 @@ -735,12 +735,28 @@ @end deftp @anchor{layout-manager} -@deftp Class layout-manager style left-margin top-margin right-margin bottom-margin -Subclasses implement layout strategies on behalf of window -objects. Every layout manager allows optional margins (specified in -pixels) within the perimeter of the container being managed.@*@* The -values accepted by the @code{:style} initarg vary depending on the -actual @code{layout-manager} subclass being used. +@deftp Class layout-manager bottom-margin data left-margin right-margin top-margin style +Subclasses implement layout strategies to manage space within containers. +@table @var +@item bottom-margin +This slot holds a margin value in pixels for the bottom side of +the container. +@item data +This slot holds a @sc{alist} of pairs, each one associating a +@sc{plist} of layout-specific attributes with an item from a +container. +@item left-margin +This slot holds a margin value in pixels for the left side of +the container. +@item right-margin +This slot holds a margin value in pixels for the right side of +the container. +@item style +The values appropriate for this slot are subclass-specific. +@item top-margin +This slot holds a margin value in pixels for the top side of +the container. +@end table @deffn Initarg :horizontal-margins This initarg accepts a horizontal margin value that is applied to both the left and right sides of the container. @@ -1665,40 +1681,104 @@ @node layout functions @subsection layout functions -These functions comprise the protocol for @ref{layout-manager}s. As -such, they are not normally called by application code, but instead -are the concern of layout-manager implementers. - -The @code{width-hint} and @code{height-hint} parameters are a -mechanism to express the @emph{what-if} scenario where the total width -or height of the container is fixed; the proper response is to -calculate the container's desired dimension on the opposite -axis. While this behavior is primarily the concern of child windows -and/or controls, layout manager implementations should look for -non-negative values for either @code{width-hint} or -@code{height-hint}, indicating that the container's size is -constrained. +The functions @ref{compute-layout}, @ref{compute-size}, and +@ref{perform} comprise the internal protocol for +@ref{layout-manager}s. As such, they are not normally called by +application code, being instead the concern of layout-manager +implementations. The @var{width-hint} and @var{height-hint} parameters +passed to the following functions are a mechanism to express the +@emph{what-if} scenario where the total width or height of the +container is fixed; the proper response is to calculate the +container's desired dimension on the opposite axis. While this +behavior is primarily the concern of child windows and/or controls, +layout manager implementations should look for non-negative values for +either @var{width-hint} or @var{height-hint}, indicating that the +container's size is constrained. @anchor{compute-layout} -@deffn GenericFunction compute-layout layout container width-hint height-hint -Returns a list of conses @code{(child . rectangle)} describing the -new bounds of each child window or control. A @ref{layout-manager} subclass +@deffn GenericFunction compute-layout @ref{layout-manager} container width-hint height-hint +Returns a list of pairs @code{(item rectangle)} describing the +new bounds of each child within @var{container}. A layout-manager subclass implements this method based on its particular layout strategy, taking -into account attributes set by the user. Certain Graphic-Forms functions -call this method to accomplish layout within a container. +into account attributes set by the user via @ref{layout-attribute}. Certain +Graphic-Forms functions call this method to accomplish layout within a container. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item container +The @var{layout-manager} arranges the elements of @var{container}. +@item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. +@item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. +@end table @end deffn -@deffn GenericFunction compute-size layout container width-hint height-hint +@anchor{compute-size} +@deffn GenericFunction compute-size @ref{layout-manager} container width-hint height-hint Computes and returns the new @ref{size} of the @code{container}'s -client area. A @ref{layout-manager} subclass implements this method +client area. A 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. +attributes set by the user via @ref{layout-attribute}. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item container +The @var{layout-manager} arranges the elements of @var{container}. +@item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. +@item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. +@end table @end deffn -@deffn GenericFunction perform layout container width-hint height-hint +@anchor{layout-attribute} +@defun layout-attribute @ref{layout-manager} thing symbol => value +(setf (@strong{layout-attribute} @var{layout-manager} @var{thing} @var{symbol}) @var{value})@*@* +This function returns @var{value} if the attribute named by @var{symbol} +is set in @var{layout-manager}; @sc{nil} otherwise. The corresponding +@sc{setf} function allows the attribute to be set. Each layout-manager +subclass supports 0 or more attributes that apply to each @var{thing}. +This function does not restrict application code +from querying or setting attributes that are not supported by the +layout manager. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item thing +The object being managed by @var{layout-manager}. +@item symbol +A @sc{symbol} identifying an item-specific attribute supported +by @var{layout-manager}. +@item value +The data of an attribute which configures the behavior of @var{layout-manager}. +@end table +@end defun + +@anchor{perform} +@deffn GenericFunction perform @var{layout-manager} container width-hint height-hint Calls @ref{compute-layout} for @code{container} and then moves and resizes @code{container}'s children. Layout subclasses may override -this method -- most derivations should call @sc{CALL-NEXT-METHOD} to -allow the base implementation to execute. +this method -- however, most derivations should call @sc{CALL-NEXT-METHOD} +to allow the base implementation to execute. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item container +The @var{layout-manager} arranges the elements of @var{container}. +@item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. +@item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. +@end table @end deffn Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 17 17:55:50 2006 @@ -440,6 +440,7 @@ #:key-toggled-p #:label #:layout + #:layout-attribute #:layout-of #:layout-p #:left-margin-of 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 Thu Aug 17 17:55:50 2006 @@ -54,6 +54,25 @@ expected-rects actual-rects))) +(define-test layout-attributes-test + (let ((widget1 (make-instance 'mock-widget :handle 1234)) + (widget2 (make-instance 'mock-widget :handle 5678))) + (let ((data1 `(,(cffi:make-pointer 1234) (a 1 b 2))) + (data2 `(,(cffi:make-pointer 5678) (a 10 c 30))) + (layout (make-instance 'gfw:layout-manager))) + (setf (slot-value layout 'gfw::data) (list data1 data2)) + (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) + (assert-equal 2 (gfw:layout-attribute layout widget1 'b)) + (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) + (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (setf (gfw:layout-attribute layout widget1 'b) 66 + (gfw:layout-attribute layout widget2 'd) 100) + (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) + (assert-equal 66 (gfw:layout-attribute layout widget1 'b)) + (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) + (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (assert-equal 100 (gfw:layout-attribute layout widget2 'd))))) + (define-test flow-layout-test1 ;; orient: horizontal ;; normalize: disabled Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Thu Aug 17 17:55:50 2006 @@ -57,8 +57,8 @@ :initarg :min-size :initform (gfs:make-size)))) -(defmethod initialize-instance :after ((widget mock-widget) &key) - (setf (slot-value widget 'gfs:handle) (cffi:make-pointer #xFFFFFFFF))) +(defmethod initialize-instance :after ((widget mock-widget) &key handle &allow-other-keys) + (setf (slot-value widget 'gfs:handle) (cffi:make-pointer (or handle #xFFFFFFFF)))) (defmethod gfw:location ((widget mock-widget)) (gfs:make-point)) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Thu Aug 17 17:55:50 2006 @@ -104,7 +104,7 @@ (load-bmp-data stream t t))))) (defun loader (path) - (let* ((file-type (string-downcase (pathname-type path))) + (let* ((file-type (pathname-type path)) (helper (cond ((string-equal file-type "bmp") #'load-bmp-data) ((string-equal file-type "ico") #'load-icon-data) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Thu Aug 17 17:55:50 2006 @@ -53,8 +53,11 @@ (bottom-margin :accessor bottom-margin-of :initarg :bottom-margin - :initform 0)) - (:documentation "Subclasses implement layout strategies on behalf of window objects.")) + :initform 0) + (data + :accessor data-of + :initform nil)) + (:documentation "Subclasses implement layout strategies to manage space within windows.")) (defclass flow-layout (layout-manager) ((spacing Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Thu Aug 17 17:55:50 2006 @@ -33,11 +33,16 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric compute-size (layout win width-hint height-hint) +(defgeneric compute-size (self win width-hint height-hint) (:documentation "Computes and returns the size of the window's client area based on the layout's strategy.")) -(defgeneric compute-layout (layout win width-hint height-hint) +(defgeneric compute-layout (self win width-hint height-hint) (:documentation "Returns a list of conses (window . rectangle) describing the new bounds of each child window.")) -(defgeneric perform (layout window widget-hint height-hint) +(defgeneric obtain-default (self) + (:documentation "Returns an instance representing default values to be used when none is supplied by the application.") + (:method (self) + (declare (ignorable self)))) + +(defgeneric perform (self window widget-hint height-hint) (:documentation "Moves and resizes window children based on layout strategy.")) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Thu Aug 17 17:55:50 2006 @@ -40,6 +40,30 @@ gfs::+swp-nocopybits+))) ;;; +;;; helper functions +;;; + +(defun layout-attribute (layout widget name) + "Return the value associated with name for widget; or NIL if no value is set." + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) + (unless attrs + (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) + (getf (first (rest attrs)) name))) + +(defun set-layout-attribute (layout widget name value) + "Sets a value associated with name for widget in the specified layout." + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) + (unless attrs + (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) + (setf (getf (first (rest attrs)) name) value))) + +(defsetf layout-attribute set-layout-attribute) + +;;; ;;; methods ;;; @@ -48,16 +72,16 @@ &allow-other-keys) (setf (style-of layout) (if (listp style) style (list style))) (unless (null margins) - (setf (left-margin-of layout) margins) - (setf (right-margin-of layout) margins) - (setf (top-margin-of layout) margins) - (setf (bottom-margin-of layout) margins)) + (setf (left-margin-of layout) margins + (right-margin-of layout) margins + (top-margin-of layout) margins + (bottom-margin-of layout) margins)) (unless (null horizontal-margins) - (setf (left-margin-of layout) horizontal-margins) - (setf (right-margin-of layout) horizontal-margins)) + (setf (left-margin-of layout) horizontal-margins + (right-margin-of layout) horizontal-margins)) (unless (null vertical-margins) - (setf (top-margin-of layout) vertical-margins) - (setf (bottom-margin-of layout) vertical-margins))) + (setf (top-margin-of layout) vertical-margins + (bottom-margin-of layout) vertical-margins))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) "Calls compute-layout for a container and then handles the actual moving and resizing of its children."

1 0

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

13 Aug '06

Author: junrue Date: Sun Aug 13 23:15:27 2006 New Revision: 217 Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: fixed graphics plugin lookup by extension to be case-insensitive Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Sun Aug 13 23:15:27 2006 @@ -104,7 +104,7 @@ (load-bmp-data stream t t))))) (defun loader (path) - (let* ((file-type (pathname-type path)) + (let* ((file-type (string-downcase (pathname-type path))) (helper (cond ((string-equal file-type "bmp") #'load-bmp-data) ((string-equal file-type "ico") #'load-icon-data) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Sun Aug 13 23:15:27 2006 @@ -40,7 +40,7 @@ (unless *magick-initialized* (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) - (if (gethash (pathname-type path) gfg:*image-file-types*) + (if (gethash (string-downcase (pathname-type path)) gfg:*image-file-types*) (with-image-path ((if (typep path 'pathname) (namestring path) path) info ex) (let ((images-ptr (read-image info ex))) (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))

1 0

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

13 Aug '06

Author: junrue Date: Sun Aug 13 23:07:35 2006 New Revision: 216 Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Log: implemented icon file loading in default graphics plugin Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Aug 13 23:07:35 2006 @@ -362,7 +362,6 @@ (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") -#+load-imagemagick-plugin (setf (gfw:image *drawing-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *drawing-win* t))) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Aug 13 23:07:35 2006 @@ -253,6 +253,7 @@ (:item "&Help" :dispatcher echo-md :submenu ((:item "&About" :dispatcher echo-md)))))) (setf (gfw:menu-bar *event-tester-window*) menubar) + (setf (gfw:image *event-tester-window*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *event-tester-window* t))) (defun event-tester () Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Aug 13 23:07:35 2006 @@ -109,6 +109,7 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) + (setf (gfw:image *image-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *image-win* t))) (defun image-tester () Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Aug 13 23:07:35 2006 @@ -441,6 +441,7 @@ (dotimes (i 3) (add-layout-tester-widget 'gfw:button :push-button)) (setf (gfw:text *layout-tester-win*) "Layout Tester") + (setf (gfw:image *layout-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (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 Sun Aug 13 23:07:35 2006 @@ -246,6 +246,7 @@ (:item "&Mini Frame" :callback #'create-miniframe-win) (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) + (setf (gfw:image *main-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *main-win* t))) (defun windlg () Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Sun Aug 13 23:07:35 2006 @@ -45,13 +45,15 @@ (defmacro bitmap-pixel-row-length (width bit-count) `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) -(defun load-bmp-data (stream) - (let* ((header (read-value 'BITMAPFILEHEADER stream)) - (info (read-value 'BASE-BITMAPINFOHEADER stream)) +(defun load-bmp-data (stream &optional no-header-p half-height-p) + (unless no-header-p + (read-value 'BITMAPFILEHEADER stream)) + (let* ((info (read-value 'BASE-BITMAPINFOHEADER stream)) (data (make-instance 'default-data-plugin :handle info))) - (declare (ignore header)) (unless (= (biCompression info) gfs::+bi-rgb+) (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + (if half-height-p + (setf (biHeight info) (/ (biHeight info) 2))) ;; load color table ;; @@ -93,7 +95,13 @@ (list data))) (defun load-icon-data (stream) - (declare (ignore stream))) + (let ((offsets (loop for i upto (1- (idCount (read-value 'ICONDIR stream))) + for entry = (read-value 'ICONDIRENTRY stream) + collect (ideImageOffset entry)))) + (loop for offset in offsets + append (progn + (file-position stream offset) + (load-bmp-data stream t t))))) (defun loader (path) (let* ((file-type (pathname-type path))

1 0

[graphic-forms-cvs] r215 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/graphics/plugins/imagemagick src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sun Aug 13 22:04:18 2006 New Revision: 215 Modified: trunk/README.txt trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/default.ico trunk/src/tests/uitoolkit/drawing-tester.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/graphics/icon-bundle.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed problems in multiple-image icon bundles and in the ImageMagick plugin Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Aug 13 22:04:18 2006 @@ -157,21 +157,26 @@ (asdf:operate 'asdf:load-op :graphic-forms-tests) - ;; execute one or more of the following: + ;; execute demos and test programs ;; + (gft:unblocked) - (in-package :gft) - (run-tests) ;; runs the unit tests (many more to be added) + (gft:textedit) + + (gft:drawing-tester) - (gft::run-drawing-tester) + (gft:event-tester) - (gft::run-event-tester) + (gft:image-tester) - (gft::run-image-tester) + (gft:layout-tester) - (gft::run-windlg) + (gft:windlg) - (gft::run-layout-tester) + ;; execute the unit-tests + ;; + (in-package :gft) + (run-tests) Support and Feedback Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sun Aug 13 22:04:18 2006 @@ -1333,6 +1333,16 @@ scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn +@deffn GenericFunction image self => @ref{image} + +(setf (@strong{image} @var{self}) @var{image})@* + +Returns the image currently associated with @var{self}. The @sc{setf} function +changes the image. If @var{self} is a @ref{window}, then this function returns +an @ref{icon-bundle}. And in that case, the @sc{setf} function accepts either +an image or an icon-bundle. +@end deffn + @deffn GenericFunction item-index self item Return the zero-based index of the location of the other object in this object. @end deffn Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 13 22:04:18 2006 @@ -37,14 +37,14 @@ (:nicknames #:gft) (:use :common-lisp :lisp-unit) (:export - #:run-drawing-tester - #:run-event-tester - #:run-hello-world - #:run-image-tester - #:run-layout-tester - #:run-windlg + #:drawing-tester + #:event-tester + #:hello-world + #:image-tester + #:layout-tester #:textedit - #:unblocked)) + #:unblocked + #:windlg)) (print "Graphic-Forms UI Toolkit Tests") (print "Copyright (c) 2006 by Jack D. Unrue") Modified: trunk/src/tests/uitoolkit/default.ico ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Aug 13 22:04:18 2006 @@ -342,7 +342,7 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges) (gfw:redraw *drawing-win*)) -(defun run-drawing-tester-internal () +(defun drawing-tester-internal () (setf *last-checked-drawing-item* nil) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'drawing-exit-fn))) @@ -362,7 +362,9 @@ (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") +#+load-imagemagick-plugin + (setf (gfw:image *drawing-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *drawing-win* t))) -(defun run-drawing-tester () - (gfw:startup "Drawing Tester" #'run-drawing-tester-internal)) +(defun drawing-tester () + (gfw:startup "Drawing Tester" #'drawing-tester-internal)) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Aug 13 22:04:18 2006 @@ -233,7 +233,7 @@ (gfw:delay-of *timer*))))) (gfw:redraw *event-tester-window*)) -(defun run-event-tester-internal () +(defun event-tester-internal () (setf *event-tester-text* "Hello!") (setf *event-counter* 0) (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) @@ -255,5 +255,5 @@ (setf (gfw:menu-bar *event-tester-window*) menubar) (gfw:show *event-tester-window* t))) -(defun run-event-tester () - (gfw:startup "Event Tester" #'run-event-tester-internal)) +(defun event-tester () + (gfw:startup "Event Tester" #'event-tester-internal)) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Aug 13 22:04:18 2006 @@ -56,7 +56,7 @@ (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) -(defun run-hello-world-internal () +(defun hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) :style '(:frame))) @@ -65,5 +65,5 @@ (setf (gfw:menu-bar *hello-win*) menubar) (gfw:show *hello-win* t))) -(defun run-hello-world () - (gfw:startup "Hello World" #'run-hello-world-internal)) +(defun hello-world () + (gfw:startup "Hello World" #'hello-world-internal)) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Aug 13 22:04:18 2006 @@ -93,7 +93,7 @@ (setf *image-win* nil) (gfw:shutdown 0)) -(defun run-image-tester-internal () +(defun image-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((menubar nil)) (setf *happy-image* (make-instance 'gfg:image)) @@ -111,5 +111,5 @@ (setf (gfw:menu-bar *image-win*) menubar) (gfw:show *image-win* t))) -(defun run-image-tester () - (gfw:startup "Image Tester" #'run-image-tester-internal)) +(defun image-tester () + (gfw:startup "Image Tester" #'image-tester-internal)) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Aug 13 22:04:18 2006 @@ -387,7 +387,7 @@ (declare (ignorable disp item)) (exit-layout-tester)) -(defun run-layout-tester-internal () +(defun layout-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (setf *widget-counter* 0) (let ((menubar nil) @@ -444,5 +444,5 @@ (gfw:pack *layout-tester-win*) (gfw:show *layout-tester-win* t))) -(defun run-layout-tester () - (gfw:startup "Layout Tester" #'run-layout-tester-internal)) +(defun layout-tester () + (gfw:startup "Layout Tester" #'layout-tester-internal)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Aug 13 22:04:18 2006 @@ -228,7 +228,7 @@ (declare (ignore disp item)) (open-dlg "Modeless" '(:modeless))) -(defun run-windlg-internal () +(defun windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) :style '(:workspace))) @@ -248,5 +248,5 @@ (setf (gfw:menu-bar *main-win*) menubar) (gfw:show *main-win* t))) -(defun run-windlg () - (gfw:startup "Window/Dialog Tester" #'run-windlg-internal)) +(defun windlg () + (gfw:startup "Window/Dialog Tester" #'windlg-internal)) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 22:04:18 2006 @@ -164,7 +164,9 @@ (resource-id (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) ((typep file 'pathname) - (setf image-list (list (make-instance 'image :file file)))) + (let ((data (load-image-data file))) + (setf image-list (loop for entry in data + collect (make-instance 'gfg:image :handle (data->image entry)))))) ((listp images) (setf image-list images))) (when image-list Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Sun Aug 13 22:04:18 2006 @@ -149,6 +149,11 @@ (images :pointer)) ;; Image* (defcfun + ("GetImageListLength" get-image-list-length) + :unsigned-long + (images :pointer)) ;; Image* + +(defcfun ("GetNextImageInList" get-next-image-in-list) :pointer ;; Image* (images :pointer)) ;; Image* Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Sun Aug 13 22:04:18 2006 @@ -41,15 +41,15 @@ (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) (if (gethash (pathname-type path) gfg:*image-file-types*) - (with-image-path (path info ex) + (with-image-path ((if (typep path 'pathname) (namestring path) path) info ex) (let ((images-ptr (read-image info ex))) (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) (error 'gfs:toolkit-error :detail (format nil "exception reason: ~s" (cffi:foreign-slot-value ex 'exception-info 'reason)))) - (loop for ptr = (get-next-image-in-list images-ptr) - until (cffi:null-pointer-p ptr) - collect (make-instance 'magic-data-plugin :handle ptr)))) + (loop for ptr = images-ptr then (get-next-image-in-list ptr) + while (and ptr (not (gfs:null-handle-p ptr))) + collect (make-instance 'magick-data-plugin :handle ptr)))) nil)) (push #'loader gfg::*image-plugins*) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Aug 13 22:04:18 2006 @@ -480,6 +480,10 @@ (defconstant +icc-standard-classes+ #x00004000) (defconstant +icc-link-class+ #x00008000) +(defconstant +icon-small+ 0) +(defconstant +icon-big+ 1) +(defconstant +icon-small2+ 2) + (defconstant +idok+ 1) (defconstant +idcancel+ 2) (defconstant +idabort+ 3) @@ -1004,6 +1008,12 @@ (defconstant +wm-chartoitem+ #x002F) (defconstant +wm-setfont+ #x0030) (defconstant +wm-getfont+ #x0031) +(defconstant +wm-contextmenu+ #x007B) +(defconstant +wm-stylechanging+ #x007C) +(defconstant +wm-stylechanged+ #x007D) +(defconstant +wm-displaychange+ #x007E) +(defconstant +wm-geticon+ #x007F) +(defconstant +wm-seticon+ #x0080) (defconstant +wm-ncmousemove+ #x00A0) (defconstant +wm-nclbuttondown+ #x00A1) (defconstant +wm-nclbuttonup+ #x00A2) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Aug 13 22:04:18 2006 @@ -210,6 +210,15 @@ (defmethod enabled-p ((w widget)) (not (zerop (gfs::is-window-enabled (gfs:handle w))))) +(defmethod image :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod (setf image) :before (image (self widget)) + (declare (ignore image)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) (setf (slot-value w 'style) (if (listp style) style (list style)))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Aug 13 22:04:18 2006 @@ -165,43 +165,65 @@ (delete-kbdnav-widget (thread-context) self) (call-next-method)) -(defmethod enable-layout :before ((win window) flag) +(defmethod enable-layout :before ((self window) flag) (declare (ignore flag)) - (if (gfs:disposed-p win) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod enable-layout ((win window) flag) - (setf (slot-value win 'layout-p) flag) - (if (and flag (layout-of win)) - (let ((sz (client-size win))) - (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) +(defmethod enable-layout ((self window) flag) + (setf (slot-value self 'layout-p) flag) + (if (and flag (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod event-resize ((d event-dispatcher) (win window) size type) +(defmethod event-resize ((d event-dispatcher) (self window) size type) (declare (ignore size type)) - (unless (null (layout-of win)) - (let ((sz (client-size win))) - (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) + (unless (null (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod focus-p :before ((win window)) - (if (gfs:disposed-p win) +(defmethod focus-p :before ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod focus-p ((win window)) +(defmethod focus-p ((self window)) (let ((focus-hwnd (gfs::get-focus))) - (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle win))))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle self))))) -(defmethod give-focus :before ((win window)) - (if (gfs:disposed-p win) +(defmethod give-focus :before ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod give-focus ((win window)) - (gfs::set-focus (gfs:handle win))) +(defmethod give-focus ((self window)) + (gfs::set-focus (gfs:handle self))) -(defmethod location ((win window)) - (if (gfs:disposed-p win) +(defmethod image ((self window)) + (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0)) + (large (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-big+ 0)) + (handles nil)) + (unless (zerop small) + (push (cffi:make-pointer small) handles)) + (unless (zerop large) + (push (cffi:make-pointer large) handles)) + (make-instance 'gfg:icon-bundle :handle handles))) + +(defmethod (setf image) ((image gfg:image) (self window)) + (setf (image self) (make-instance 'gfg:icon-bundle :images (list image)))) + +(defmethod (setf image) ((bundle gfg:icon-bundle) (self window)) + (let ((hwnd (gfs:handle self)) + (small (gfg::icon-handle-ref bundle :small)) + (large (gfg::icon-handle-ref bundle :large))) + (unless (gfs:null-handle-p small) + (gfs::send-message hwnd gfs::+wm-seticon+ gfs::+icon-small+ (cffi:pointer-address small))) + (unless (gfs:null-handle-p large) + (gfs::send-message hwnd gfs::+wm-seticon+ gfs::+icon-big+ (cffi:pointer-address large))))) + +(defmethod location ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((pnt (gfs:make-point))) - (outer-location win pnt) + (outer-location self pnt) pnt)) (defmethod layout ((self window))

1 0

[graphic-forms-cvs] r214 - in trunk/src: tests/uitoolkit uitoolkit/graphics
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sun Aug 13 17:28:31 2006 New Revision: 214 Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: implemented setf icon-image-ref unit-test, fixed bug Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 17:28:31 2006 @@ -99,3 +99,22 @@ (validate-image (gfg:icon-image-ref bundle :large) size 8)) (gfs:dispose bundle)) (assert-true (gfs:disposed-p bundle)))) + +(define-test setf-images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle + :images (list (make-instance 'gfg:image :file (merge-pathnames "happy.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))))) + (happy-image (make-instance 'gfg:image :file (merge-pathnames "happy.bmp"))) + (bw-image (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp"))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16))) + (unwind-protect + (progn + (assert-equal 2 (gfg:icon-bundle-length bundle)) + (setf (gfg:icon-image-ref bundle 0) bw-image) + (setf (gfg:icon-image-ref bundle 1) happy-image) + (assert-equal 2 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) bw-size 16000000) + (validate-image (gfg:icon-image-ref bundle 1) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 17:28:31 2006 @@ -114,6 +114,9 @@ (hicon->image (icon-handle-ref bundle index))) (defun set-icon-image (bundle index image) + (let ((hicon (icon-handle-ref bundle index))) + (if (and (not (gfs:null-handle-p hicon)) (listp (gfs:handle bundle))) + (gfs::destroy-icon hicon))) (setf (icon-handle-ref bundle index) (image->hicon image))) (defsetf icon-image-ref set-icon-image)

1 0

[graphic-forms-cvs] r213 - in trunk: . src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sun Aug 13 17:13:54 2006 New Revision: 213 Modified: trunk/build.lisp trunk/config.lisp trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/tests.lisp Log: implemented icon-bundle unit-tests and fixed a few more bugs found as a result Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Aug 13 17:13:54 2006 @@ -52,8 +52,9 @@ (setf *lisp-unit-file* (concatenate 'string *gf-dir* "src/external-libraries/lisp-unit/lisp-unit")) (setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) (setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")) - -(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) +(setf *textedit-dir* (concatenate 'string *gf-dir* "src/demos/textedit/")) +(setf *unblocked-dir* (concatenate 'string *gf-dir* "src/demos/unblocked/")) +(setf *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Sun Aug 13 17:13:54 2006 @@ -39,15 +39,18 @@ (in-package #:graphic-forms-system) -(defvar *binary-data-dir* (merge-pathnames "src/external-libraries/practicals-1.0.3/binary-data/")) (defvar *cells-dir* "cells/") (defvar *cffi-dir* "cffi-060606/") (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") -(defvar *macro-utilities-dir* "macro-utilities/") (defvar *gf-dir* "graphic-forms/") +(defvar *binary-data-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/binary-data/") +(defvar *macro-utilities-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/macro-utilities/") +(defvar *textedit-dir* "graphic-forms/src/demos/textedit/") +(defvar *unblocked-dir* "graphic-forms/src/demos/unblocked/") +(defvar *gf-tests-dir* "graphic-forms/src/tests/uitoolkit/") -(defvar *lisp-unit-file* "lisp-unit") +(defvar *lisp-unit-file* "graphic-forms/src/external-libraries/practicals-1.0.3/lisp-unit.lisp") (defun configure-asdf () (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Aug 13 17:13:54 2006 @@ -35,7 +35,6 @@ (defvar *textedit-control* nil) (defvar *textedit-win* nil) -(defvar *textedit-startup-dir* nil) (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*"))) @@ -152,7 +151,8 @@ (defun about-textedit (disp item) (declare (ignore disp item)) - (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*))) + (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) + (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) (dlg (make-instance 'gfw:dialog :owner *textedit-win* :dispatcher (make-instance 'textedit-about-dialog-events) :layout (make-instance 'gfw:flow-layout @@ -219,12 +219,6 @@ (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit"))) (defun textedit-startup () -#+clisp - (setf *textedit-startup-dir* (ext:cd)) -#+lispworks - (setf *textedit-startup-dir* (hcl:get-working-directory)) -#+sbcl - (setf *textedit-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu :submenu ((:item "&New" :callback #'textedit-file-new) (:item "&Open..." :callback #'textedit-file-open) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Aug 13 17:13:54 2006 @@ -82,15 +82,13 @@ (defmethod initialize-instance :after ((self tiles-panel-events) &key buffer-size) (declare (ignorable buffer-size)) - (let ((table (tile-image-table-of self)) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) + (table (tile-image-table-of self)) (kind 1)) (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp" "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp") do (let ((image (make-instance 'gfg:image))) - (gfg:load image (merge-pathnames (concatenate 'string - "src/demos/unblocked/" - filename) - (unblocked-startup-dir))) + (gfg:load image (merge-pathnames filename)) (setf (gethash kind table) image) (incf kind))))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Aug 13 17:13:54 2006 @@ -39,13 +39,9 @@ (defconstant +revealed-duration+ 2000) ; millis (defvar *scoreboard-panel* nil) -(defvar *unblocked-startup-dir* nil) (defvar *tiles-panel* nil) (defvar *unblocked-win* nil) -(defun unblocked-startup-dir () - *unblocked-startup-dir*) - (defun get-tiles-panel () *tiles-panel*) @@ -106,7 +102,8 @@ (defun about-unblocked (disp item) (declare (ignore disp item)) - (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*))) + (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) + (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) (dlg (make-instance 'gfw:dialog :owner *unblocked-win* :dispatcher (make-instance 'unblocked-about-dialog-events) :layout (make-instance 'gfw:flow-layout @@ -162,12 +159,6 @@ (gfw:show dlg t))) (defun unblocked-startup () -#+clisp - (setf *unblocked-startup-dir* (ext:cd)) -#+lispworks - (setf *unblocked-startup-dir* (hcl:get-working-directory)) -#+sbcl - (setf *unblocked-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "&New" :callback #'new-unblocked) (:item "&Restart" :callback #'restart-unblocked) Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 17:13:54 2006 @@ -32,3 +32,70 @@ ;;;; (in-package :graphic-forms.uitoolkit.tests) + +(define-test bmp-file-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle :file (merge-pathnames "happy.bmp"))) + (size (gfs:make-size :width 32 :height 32))) + (unwind-protect + (progn + (assert-equal 1 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) size 8) + (validate-image (gfg:icon-image-ref bundle :large) size 8) + (validate-image (gfg:icon-image-ref bundle :small) size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle + :images (list (make-instance 'gfg:image :file (merge-pathnames "happy.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16)) + (tc-size (gfs:make-size :width 16 :height 16))) + (unwind-protect + (progn + (assert-equal 3 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) happy-size 8) + (validate-image (gfg:icon-image-ref bundle 1) bw-size 8) + (validate-image (gfg:icon-image-ref bundle 2) tc-size 16000000) + (validate-image (gfg:icon-image-ref bundle :small) tc-size 8) + (validate-image (gfg:icon-image-ref bundle :large) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test push-images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle)) + (happy-image (make-instance 'gfg:image :file (merge-pathnames "happy.bmp"))) + (bw-image (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp"))) + (tc-image (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16)) + (tc-size (gfs:make-size :width 16 :height 16)) + (bw-point (gfs:make-point :x 0 :y 15))) + (unwind-protect + (progn + (gfg:push-icon-image bw-image bundle bw-point) + (gfg:push-icon-image tc-image bundle) + (gfg:push-icon-image happy-image bundle) + (assert-equal 3 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) happy-size 8) + (validate-image (gfg:icon-image-ref bundle 1) tc-size 16000000) + (validate-image (gfg:icon-image-ref bundle 2) bw-size 8) + (validate-image (gfg:icon-image-ref bundle :small) tc-size 8) + (validate-image (gfg:icon-image-ref bundle :large) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test system-icon-bundle-test + (let ((size (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxicon+) + :height (gfs::get-system-metrics gfs::+sm-cyicon+))) + (bundle (make-instance 'gfg:icon-bundle :system gfg:+warning-icon+))) + (unwind-protect + (progn + (assert-equal 1 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) size 8) + (validate-image (gfg:icon-image-ref bundle :small) size 8) + (validate-image (gfg:icon-image-ref bundle :large) size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Aug 13 17:13:54 2006 @@ -34,5 +34,8 @@ (in-package :graphic-forms.uitoolkit.tests) (defun validate-image (image expected-size expected-depth) - (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) - (assert-equal expected-depth (gfg:depth image))) + (declare (ignore expected-depth)) + (assert-false (null image)) + (assert-false (gfs:disposed-p image)) + ;; (assert-equal expected-depth (gfg:depth image)) ; FIXME: image->data needed + (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 17:13:54 2006 @@ -67,7 +67,8 @@ (let ((im (hicon->image hicon)) (extent 0)) (unwind-protect - (setf extent (gfs:size-height (gfg:size im))) + (let ((size (gfg:size im))) + (setf extent (* (gfs:size-height size) (gfs:size-width size)))) (gfs:dispose im)) extent)) @@ -130,7 +131,8 @@ (error 'gfs:disposed-error)) (let ((tmp (gfs:handle bundle))) (push (image->hicon image transparency-pixel) tmp) - (setf (slot-value bundle 'gfs:handle) tmp))) + (setf (slot-value bundle 'gfs:handle) tmp)) + bundle) ;;; ;;; methods @@ -165,6 +167,4 @@ (when image-list (let ((tr-pnt (or transparency-pixel (gfs:make-point)))) (setf (slot-value self 'gfs:handle) (loop for tmp-image in image-list - collect (image->hicon tmp-image tr-pnt)))))) - (unless (gfs:handle self) - (error 'gfs:toolkit-error :detail "could not initialize icon bundle"))) + collect (image->hicon tmp-image tr-pnt))))))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Aug 13 17:13:54 2006 @@ -34,8 +34,7 @@ (in-package #:graphic-forms-system) (defun load-tests () -#+lispworks - (hcl:change-directory *gf-dir*) + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests) (load (concatenate 'string *gf-tests-dir* "test-utils")) (load (concatenate 'string *gf-tests-dir* "mock-objects"))

1 0

[graphic-forms-cvs] r212 - in trunk: . src/external-libraries/lisp-unit src/tests/uitoolkit
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sun Aug 13 01:52:01 2006 New Revision: 212 Added: trunk/src/external-libraries/lisp-unit/ trunk/src/external-libraries/lisp-unit/lisp-unit.lisp trunk/src/external-libraries/lisp-unit/readme.txt Modified: trunk/README.txt trunk/build.lisp trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/tests.lisp Log: upgraded to latest lisp-unit, now bundling lisp-unit under external-libraries Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Aug 13 01:52:01 2006 @@ -14,6 +14,7 @@ - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ + *note: ASDF is bundled with SBCL* - Cells (latest from CVS) http://www.common-lisp.net/project/cells/ @@ -27,12 +28,20 @@ - Closer to MOP http://common-lisp.net/project/closer/downloads.html - - ImageMagick 6.2.6.5-Q16 - http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-window… +The following libraries are bundled with Graphic-Forms, thus do not need +to be downloaded separately: + + - Practical Common Lisp Chapter08 and Chapter24 + http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz - lisp-unit http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html +The following libraries are optional: + + - ImageMagick 6.2.6.5-Q16 + http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-window… + Supported Common Lisp Implementations ------------------------------------- Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Aug 13 01:52:01 2006 @@ -49,7 +49,7 @@ (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (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")) +(setf *lisp-unit-file* (concatenate 'string *gf-dir* "src/external-libraries/lisp-unit/lisp-unit")) (setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) (setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 13 01:52:01 2006 @@ -31,6 +31,8 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; +(load gfsys::*lisp-unit-file*) + (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) (:use :common-lisp :lisp-unit) @@ -78,16 +80,7 @@ ((:module "uitoolkit" :serial t :components - ((:file "test-utils") - (:file "mock-objects") - (:file "color-unit-tests") - (:file "graphics-context-unit-tests") - (:file "image-unit-tests") - (:file "icon-bundle-unit-tests") - (:file "layout-unit-tests") - (:file "widget-unit-tests") - (:file "misc-unit-tests") - (:file "hello-world") + ((:file "hello-world") (:file "event-tester") (:file "layout-tester") (:file "image-tester") Added: trunk/src/external-libraries/lisp-unit/lisp-unit.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/lisp-unit/lisp-unit.lisp Sun Aug 13 01:52:01 2006 @@ -0,0 +1,429 @@ +;;;-*- Mode: Lisp; Package: LISP-UNIT -*- + +#| +Copyright (c) 2004-2005 Christopher K. Riesbeck + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. +|# + + +;;; A test suite package, modelled after JUnit. +;;; Author: Chris Riesbeck +;;; +;;; Update history: +;;; +;;; 04/07/06 added ~<...~> to remaining error output forms [CKR] +;;; 04/06/06 added ~<...~> to compact error output better [CKR] +;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported +;;; by Daniel Edward Burke) [CKR] +;;; 02/08/06 added newlines to error output [CKR] +;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR] +;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR] +;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger, +;;; 11/07/05 added *use-debugger* and assert-predicate [DFB] +;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR] +;;; 08/30/05 added license notice [CKR] +;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR] +;;; 02/21/05 removed length check from SET-EQUAL [CKR] +;;; 02/17/05 added RUN-ALL-TESTS [CKR] +;;; 01/18/05 added ASSERT-EQUAL back in [CKR] +;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR] +;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR] +;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR] +;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR] +;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR] +;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR] +;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR] +;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR] +;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR] +;;; 12/02/04 changed to group tests under packages [CKR] +;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR] +;;; 11/30/04 improved error handling and summarization [CKR] +;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR] +;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR] +;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR] +;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR] +;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR] +;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR] +;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR] +;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR] + + +#| +How to use +---------- + +1. Read the documentation in lisp-unit.html. + +2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many +examples. If you want, start your test file with (REMOVE-TESTS) to +clear any previously defined tests. + +2. Load this file. + +2. (use-package :lisp-unit) + +3. Load your code file and your file of tests. + +4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! -- +or simply (RUN-TESTS) to run all defined tests. + +A summary of how many tests passed and failed will be printed, +with details on the failures. + +Note: Nothing is compiled until RUN-TESTS is expanded. Redefining +functions or even macros does not require reloading any tests. + +For more information, see lisp-unit.html. + +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Packages +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(cl:defpackage #:lisp-unit + (:use #:common-lisp) + (:export #:define-test #:run-all-tests #:run-tests + #:assert-eq #:assert-eql #:assert-equal #:assert-equalp + #:assert-error #:assert-expands #:assert-false + #:assert-equality #:assert-prints #:assert-true + #:get-test-code #:get-tests + #:remove-all-tests #:remove-tests + #:logically-equal #:set-equal + #:use-debugger + #:with-test-listener) + ) + +(in-package #:lisp-unit) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Globals +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *test-listener* nil) + +(defparameter *tests* (make-hash-table)) + +;;; Used by RUN-TESTS to collect summary statistics +(defvar *test-count* 0) +(defvar *pass-count* 0) + +;;; Set by RUN-TESTS for use by SHOW-FAILURE +(defvar *test-name* nil) + +;;; If nil, errors in tests are caught and counted. +;;; If :ask, user is given option of entering debugger or not. +;;; If true and not :ask, debugger is entered. +(defparameter *use-debugger* nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; DEFINE-TEST + +(defmacro define-test (name &body body) + `(progn + (store-test-code ',name ',body) + ',name)) + +;;; ASSERT macros + +(defmacro assert-eq (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'eq)) + +(defmacro assert-eql (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'eql)) + +(defmacro assert-equal (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'equal)) + +(defmacro assert-equalp (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'equalp)) + +(defmacro assert-error (condition form &rest extras) + (expand-assert :error form (expand-error-form form) + condition extras)) + +(defmacro assert-expands (&environment env expansion form &rest extras) + (expand-assert :macro form + (expand-macro-form form #+lispworks nil #-lispworks env) + expansion extras)) + +(defmacro assert-false (form &rest extras) + (expand-assert :result form form nil extras)) + +(defmacro assert-equality (test expected form &rest extras) + (expand-assert :equal form form expected extras :test test)) + +(defmacro assert-prints (output form &rest extras) + (expand-assert :output form (expand-output-form form) + output extras)) + +(defmacro assert-true (form &rest extras) + (expand-assert :result form form t extras)) + + +(defun expand-assert (type form body expected extras &key (test #'eql)) + `(internal-assert + ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test)) + +(defun expand-error-form (form) + `(handler-case ,form + (condition (error) error))) + +(defun expand-output-form (form) + (let ((out (gensym))) + `(let* ((,out (make-string-output-stream)) + (*standard-output* (make-broadcast-stream *standard-output* ,out))) + ,form + (get-output-stream-string ,out)))) + +(defun expand-macro-form (form env) + `(macroexpand-1 ',form ,env)) + +(defun expand-extras (extras) + `#'(lambda () + (list ,@(mapcan #'(lambda (form) (list `',form form)) extras)))) + + +;;; RUN-TESTS + +(defmacro run-all-tests (package &rest tests) + `(let ((*package* (find-package ',package))) + (run-tests + ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package)) + tests)))) + +(defmacro run-tests (&rest names) + `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names)))) + +(defun get-test-thunks (names &optional (package *package*)) + (mapcar #'(lambda (name) (get-test-thunk name package)) + names)) + +(defun get-test-thunk (name package) + (assert (get-test-code name package) (name package) + "No test defined for ~S in package ~S" name package) + (list name (coerce `(lambda () ,@(get-test-code name)) 'function))) + +(defun use-debugger (&optional (flag t)) + (setq *use-debugger* flag)) + +;;; WITH-TEST-LISTENER +(defmacro with-test-listener (listener &body body) + `(let ((*test-listener* #',listener)) ,@body)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Public functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun get-test-code (name &optional (package *package*)) + (let ((table (get-package-table package))) + (unless (null table) + (gethash name table)))) + +(defun get-tests (&optional (package *package*)) + (let ((l nil) + (table (get-package-table package))) + (cond ((null table) nil) + (t + (maphash #'(lambda (key val) + (declare (ignore val)) + (push key l)) + table) + (sort l #'string< :key #'string))))) + + +(defun remove-tests (names &optional (package *package*)) + (let ((table (get-package-table package))) + (unless (null table) + (if (null names) + (clrhash table) + (dolist (name names) + (remhash name table)))))) + +(defun remove-all-tests (&optional (package *package*)) + (if (null package) + (clrhash *tests*) + (remhash (find-package package) *tests*))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Private functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; DEFINE-TEST support + +(defun get-package-table (package &key create) + (let ((table (gethash (find-package package) *tests*))) + (or table + (and create + (setf (gethash package *tests*) + (make-hash-table)))))) + +(defun get-test-name (form) + (if (atom form) form (cadr form))) + +(defun store-test-code (name code &optional (package *package*)) + (setf (gethash name + (get-package-table package :create t)) + code)) + + +;;; ASSERTION support + +(defun internal-assert (type form code-thunk expected-thunk extras test) + (let* ((expected (multiple-value-list (funcall expected-thunk))) + (actual (multiple-value-list (funcall code-thunk))) + (passed (test-passed-p type expected actual test))) + + (incf *test-count*) + (when passed + (incf *pass-count*)) + + (record-result passed type form expected actual extras) + + passed)) + +(defun record-result (passed type form expected actual extras) + (funcall (or *test-listener* 'default-listener) + passed type *test-name* form expected actual + (and extras (funcall extras)) + *test-count* *pass-count*)) + +(defun default-listener + (passed type name form expected actual extras test-count pass-count) + (declare (ignore test-count pass-count)) + (unless passed + (show-failure type (get-failure-message type) + name form expected actual extras))) + +(defun test-passed-p (type expected actual test) + (ecase type + (:error + (or (eql (car actual) (car expected)) + (typep (car actual) (car expected)))) + (:equal + (and (<= (length expected) (length actual)) + (every test expected actual))) + (:macro + (equal (car actual) (car expected))) + (:output + (string= (string-trim '(#\newline #\return #\space) + (car actual)) + (car expected))) + (:result + (logically-equal (car actual) (car expected))) + )) + + +;;; RUN-TESTS support + +(defun run-test-thunks (test-thunks) + (unless (null test-thunks) + (let ((total-test-count 0) + (total-pass-count 0) + (total-error-count 0)) + (dolist (test-thunk test-thunks) + (multiple-value-bind (test-count pass-count error-count) + (run-test-thunk (car test-thunk) (cadr test-thunk)) + (incf total-test-count test-count) + (incf total-pass-count pass-count) + (incf total-error-count error-count))) + (unless (null (cdr test-thunks)) + (show-summary 'total total-test-count total-pass-count total-error-count)) + (values)))) + +(defun run-test-thunk (*test-name* thunk) + (if (null thunk) + (format t "~& Test ~S not found" *test-name*) + (prog ((*test-count* 0) + (*pass-count* 0) + (error-count 0)) + (handler-bind + ((error #'(lambda (e) + (let ((*print-escape* nil)) + (setq error-count 1) + (format t "~& ~S: ~W" *test-name* e)) + (if (use-debugger-p e) e (go exit))))) + (funcall thunk) + (show-summary *test-name* *test-count* *pass-count*)) + exit + (return (values *test-count* *pass-count* error-count))))) + +(defun use-debugger-p (e) + (and *use-debugger* + (or (not (eql *use-debugger* :ask)) + (y-or-n-p "~A -- debug?" e)))) + +;;; OUTPUT support + +(defun get-failure-message (type) + (case type + (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}") + (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + )) + +(defun show-failure (type msg name form expected actual extras) + (format t "~&~@[~S: ~]~S failed: " name form) + (format t msg expected actual) + (format t "~{~& ~S => ~S~}~%" extras) + type) + +(defun show-summary (name test-count pass-count &optional error-count) + (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]." + name pass-count (- test-count pass-count) error-count)) + +(defun collect-form-values (form values) + (mapcan #'(lambda (form-arg value) + (if (constantp form-arg) + nil + (list form-arg value))) + (cdr form) + values)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Useful equality predicates for tests +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; (LOGICALLY-EQUAL x y) => true or false +;;; Return true if x and y both false or both true + +(defun logically-equal (x y) + (eql (not x) (not y))) + +;;; (SET-EQUAL l1 l2 :test) => true or false +;;; Return true if every element of l1 is an element of l2 +;;; and vice versa. + +(defun set-equal (l1 l2 &key (test #'equal)) + (and (listp l1) + (listp l2) + (subsetp l1 l2 :test test) + (subsetp l2 l1 :test test))) + + +(provide "lisp-unit") Added: trunk/src/external-libraries/lisp-unit/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/lisp-unit/readme.txt Sun Aug 13 01:52:01 2006 @@ -0,0 +1,7 @@ + +This directory contains the source file implementing the lisp-unit +unit-test library. Copyright (c) 2004-2005 Christopher K. Riesbeck + +The website for this library is: + + http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 01:52:01 2006 @@ -32,7 +32,3 @@ ;;;; (in-package :graphic-forms.uitoolkit.tests) - - - - Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Aug 13 01:52:01 2006 @@ -33,8 +33,6 @@ (in-package :graphic-forms.uitoolkit.tests) -#| (defun validate-image (image expected-size expected-depth) (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) (assert-equal expected-depth (gfg:depth image))) -|# Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Aug 13 01:52:01 2006 @@ -33,9 +33,16 @@ (in-package #:graphic-forms-system) -(load (compile-file *lisp-unit-file*)) - (defun load-tests () #+lispworks (hcl:change-directory *gf-dir*) - (asdf:operate 'asdf:load-op :graphic-forms-tests)) + (asdf:operate 'asdf:load-op :graphic-forms-tests) + (load (concatenate 'string *gf-tests-dir* "test-utils")) + (load (concatenate 'string *gf-tests-dir* "mock-objects")) + (load (concatenate 'string *gf-tests-dir* "color-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "graphics-context-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "image-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "misc-unit-tests")))

1 0

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

12 Aug '06

Author: junrue Date: Sat Aug 12 23:55:37 2006 New Revision: 211 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: fixed icon-handle-ref to not re-order handles, removed doc language about load order preservation, implemented and documented push-icon-image Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 12 23:55:37 2006 @@ -539,25 +539,20 @@ @defun icon-image-ref @ref{icon-bundle} subscript => @ref{image} (setf (@strong{icon-image-ref} @var{icon-bundle} @var{subscript}) @var{image})@*@* This function uses an integer or keyword -based @var{subscript} to address -the images comprising @var{icon-bundle}, either to retrieve an image -or add/replace an image via @sc{setf}. +the images comprising @var{icon-bundle}. @table @var @item icon-bundle Contains images to be used for frame decorations. @item subscript This argument can be zero-based, in which case @var{icon-bundle} -is treated as though it were an array of images. Add a new image -by specifying @var{subscript} 0.@*@* -Alternatively, @var{subscript} -can be one of the following keywords:@*@* +is treated as though it were an array of images. Alternatively, +@var{subscript} can be one of the following keywords:@*@* @table @code @item :large Identifies the largest image of the @var{icon-bundle}. @item :small -Identifies the smallest image of the @var{icon-bundle}.@*@* +Identifies the smallest image of the @var{icon-bundle}. @end table -Note that adding an image addressed by one of these -keywords will succeed, but the result may be counter-intuitive. @end table To find out how many images are stored in @var{icon-bundle}, and hence what constitutes a valid range of subscripts for this function, @@ -588,6 +583,21 @@ where @var{self} is a @ref{graphics-context}. @end deffn +@defun push-icon-image @ref{image} @ref{icon-bundle} &optional transparency-pixel => icon-bundle +Use this function to prepend a new image to an existing icon-bundle. +Note that @var{icon-bundle} takes ownership of @var{image}. +@table @var +@item image +The new image to be prepended. +@item icon-bundle +The icon-bundle to receive @var{image}. +@item transparency-pixel +A @ref{point} object identifying a pixel in @var{image} with the color to +be used for transparency. If not specified, the pixel at @code{(0, 0)} will +be used. +@end table +@end defun + @deffn GenericFunction size self => @ref{size} Returns a size object describing the dimensions of @var{self}. @end deffn Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 12 23:55:37 2006 @@ -265,7 +265,7 @@ This is the base class for user interface objects that generate events@footnote{Actually, events are generated by underlying native window objects, which are represented in the class hierarchy by -the event-source class}. It derives from @ref{native-object}. +the event-source class.}. It derives from @ref{native-object}. @table @var @item callback-event-name This is an (@code{:allocation :class}) slot that holds a symbol @@ -792,10 +792,10 @@ Implement this method to respond to @var{widget} being activated. For a @ref{top-level} @ref{window} or @ref{dialog}, this means that @var{widget} was brought to the foreground and its trim (titlebar and -border) was highlighted to indicate that it is now the active -window. For a @ref{menu}, it means that the user has clicked on the -@ref{item} invoking @ref{widget} and it is about to be shown; this is -an opportunity to update the menu's contents. @xref{event-deactivate}. +border) became highlighted. For a @ref{menu}, it means that the user +has clicked on the @ref{item} invoking @ref{widget} and it is about +to be shown; this is an opportunity to update the menu's contents. +@xref{event-deactivate}. @table @var @event-dispatcher-arg @item widget @@ -841,8 +841,8 @@ @deffn GenericFunction event-dispose dispatcher widget Implement this method to respond to @var{widget} being disposed (explicitly -via @ref{dispose}, not collected via the garbage collector). This -event function is called while the contents of @var{widget} are still +via @ref{dispose}; this event is not associated with garbage collection). +This event function is called while the contents of @var{widget} are still valid. @table @var @event-dispatcher-arg Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 12 23:55:37 2006 @@ -208,6 +208,7 @@ #:multiply #:pen-style #:pen-width + #:push-icon-image #:rgb->color #:red-mask #:red-shift Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sat Aug 12 23:55:37 2006 @@ -71,10 +71,6 @@ (gfs:dispose im)) extent)) -;;; Note: this function needs to return a place not -;;; just a handle, to facilitate a defsetf further -;;; on below -;;; (defun icon-handle-ref (bundle index) (let ((handles (gfs:handle bundle))) (unless handles @@ -86,16 +82,16 @@ (elt handles index) (error 'gfs:toolkit-error :detail "invalid image index")) (if (zerop index) - (gfs:handle bundle) + handles (error 'gfs:toolkit-error :detail "invalid image index")))) ((eql index :small) (if (listp handles) - (first (stable-sort handles #'< :key #'icon-extent)) - (gfs:handle bundle))) + (first (sort (copy-list handles) #'< :key #'icon-extent)) + handles)) ((eql index :large) (if (listp handles) - (first (last (stable-sort handles #'< :key #'icon-extent))) - (gfs:handle bundle))) + (first (sort (copy-list handles) #'> :key #'icon-extent)) + handles)) (t (error 'gfs:toolkit-error :detail "an integer index, or one of :small or :large, is required"))))) @@ -129,6 +125,13 @@ (length handles) 1))) +(defun push-icon-image (image bundle &optional transparency-pixel) + (if (gfs:disposed-p image) + (error 'gfs:disposed-error)) + (let ((tmp (gfs:handle bundle))) + (push (image->hicon image transparency-pixel) tmp) + (setf (slot-value bundle 'gfs:handle) tmp))) + ;;; ;;; methods ;;;

1 0

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

12 Aug '06

Author: junrue Date: Sat Aug 12 01:44:13 2006 New Revision: 210 Added: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/system-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-tests.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: icon-bundle testing and bug fixing Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat Aug 12 01:44:13 2006 @@ -14,9 +14,9 @@ of the package names are prefixed with @code{graphic-forms.uitoolkit}. @menu -* graphics package:: -* system package:: -* widgets package:: +* GFS package:: +* GFG package:: +* GFW package:: @end menu @include graphics-api.texinfo Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,15 +5,15 @@ @c Copyright (c) 2006, Jack D. Unrue -@node graphics package, widgets package, system package, API -@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 and GFW together constitute the bulk of the public API. +@node GFG package +@section GFG package +@cindex GFG package + +Full package name: @emph{graphic-forms.uitoolkit.graphics} + +This package contains the symbols corresponding to graphics-related +classes, drawing operations, and meta-data. This package and +@sc{gfw} together comprise the bulk of the library API. @menu * graphics types:: @@ -205,23 +205,26 @@ Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN documentation for further discussion of standard icon sizes, color depths and file format.@*@* +The implementation of @code{icon-bundle} includes the concept of +there being large and small versions. The actual size to be used +depends on the context in which the icon is needed. To retrieve +or set an individual image, call @ref{icon-image-ref}. To find +out how many @ref{image}s are stored, call @ref{icon-bundle-length}.@*@* @code{icon-bundle} derives from @ref{native-object}. @deffn Initarg :file This initarg accepts a @sc{cl:pathname} identifying a file -with @ref{image-data} to be loaded, as described for the @ref{image} -class @code{:file} initarg. Note that the @sc{ico} format can -store multiple icons, all of which will be loaded. Application -code should not assume that load order is preserved. Since +with in a supported format to be loaded, as described for the +image class @code{:file} initarg. Note that the @sc{ico} format +can store multiple images, all of which will be loaded. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the -proper transparency @ref{color}; by default, the pixel color at -@code{(0, 0)} in each image will be used. @emph{FIXME: link -to documentation of graphics plugins here}. +proper transparency @ref{color}; or else by default, the pixel +color at @code{(0, 0)} in each image will be used. @emph{FIXME: +link to documentation of graphics plugins here}. @end deffn @deffn Initarg :images -This initarg accepts a @sc{cl:list} of image objects. Application -code should not assume that image order is preserved. Since +This initarg accepts a @sc{cl:list} of image objects. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, the application may either @sc{setf} @ref{transparency-pixel} for each image ahead of time (especially @@ -527,28 +530,38 @@ Returns a color object corresponding to the current foreground color. @end deffn -@anchor{icon-image} -@defun icon-image @ref{icon-bundle} index => @ref{image} -This function uses an integer or keyword -based @var{index} to address -the images comprising an icon-bundle, either to retrieve an image -or add/replace an image via @sc{setf}. Application code should not -assume that image load order was preserved when this function is called. +@anchor{icon-bundle-length} +@defun icon-bundle-length @ref{icon-bundle} => integer +Returns a count of the number of icon handles held by @var{icon-bundle}. +@end defun + +@anchor{icon-image-ref} +@defun icon-image-ref @ref{icon-bundle} subscript => @ref{image} +(setf (@strong{icon-image-ref} @var{icon-bundle} @var{subscript}) @var{image})@*@* +This function uses an integer or keyword -based @var{subscript} to address +the images comprising @var{icon-bundle}, either to retrieve an image +or add/replace an image via @sc{setf}. @table @var @item icon-bundle -This is an icon-bundle containing images to be updated or retrieved. -@item index -This argument can be a zero-based, with new images added by -specifying @var{index} 0. Or @var{index} can be one of the following -keywords: +Contains images to be used for frame decorations. +@item subscript +This argument can be zero-based, in which case @var{icon-bundle} +is treated as though it were an array of images. Add a new image +by specifying @var{subscript} 0.@*@* +Alternatively, @var{subscript} +can be one of the following keywords:@*@* @table @code @item :large -Specifies the largest image of the icon-bundle. +Identifies the largest image of the @var{icon-bundle}. @item :small -Specifies the smallest image of the icon-bundle. +Identifies the smallest image of the @var{icon-bundle}.@*@* @end table +Note that adding an image addressed by one of these +keywords will succeed, but the result may be counter-intuitive. @end table -To find out how many images are stored in an icon-bundle, call -@ref{size}. +To find out how many images are stored in @var{icon-bundle}, and hence +what constitutes a valid range of subscripts for this function, +call @ref{icon-bundle-length}. @end defun @anchor{load} Modified: trunk/docs/manual/system-api.texinfo ============================================================================== --- trunk/docs/manual/system-api.texinfo (original) +++ trunk/docs/manual/system-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,16 +5,16 @@ @c Copyright (c) 2006, Jack D. Unrue -@node system package, graphics package, , API -@section system package -@cindex system package +@node GFS package +@section GFS package +@cindex GFS package -Nickname: GFS +Full package name: @emph{graphic-forms.uitoolkit.system} The symbols in this package correspond to system-level functionality, -examples of which include bindings for Win32 API functions and associated -constants. The majority of the symbols herein are not exported, except for -a few fundamental types and methods +such as foreign function declarations for the Win32 @sc{api}. The +majority of the symbols herein are not exported, except +for a few fundamental types, conditions, and methods. @menu * system types:: Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,15 +5,16 @@ @c Copyright (c) 2006, Jack D. Unrue -@node widgets package, , graphics package, API -@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. +@node GFW package +@section GFW package +@cindex GFW package + +Full package name: @emph{graphic-forms.uitoolkit.widgets} + +This package contains symbols for user interface widget +classes, event-handling methods, and management functions. This +package and @sc{gfg} together constitute the bulk of the library +API. @menu * event functions:: Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sat Aug 12 01:44:13 2006 @@ -65,6 +65,7 @@ ((:file "textedit-document") (:file "textedit-window"))) (:module "unblocked" + :serial t :components ((:file "tiles") (:file "unblocked-model") @@ -75,11 +76,14 @@ (:module "tests" :components ((:module "uitoolkit" + :serial t :components - ((:file "mock-objects") + ((:file "test-utils") + (:file "mock-objects") (:file "color-unit-tests") (:file "graphics-context-unit-tests") (:file "image-unit-tests") + (:file "icon-bundle-unit-tests") (:file "layout-unit-tests") (:file "widget-unit-tests") (:file "misc-unit-tests") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 12 01:44:13 2006 @@ -188,7 +188,8 @@ #:green-mask #:green-shift #:height - #:icon-image + #:icon-bundle-length + #:icon-image-ref #:invert #:leading #:line-cap-style Added: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sat Aug 12 01:44:13 2006 @@ -0,0 +1,38 @@ +;;;; +;;;; icon-bundle-unit-tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + + + + Added: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sat Aug 12 01:44:13 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; test-utils.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +#| +(defun validate-image (image expected-size expected-depth) + (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) + (assert-equal expected-depth (gfg:depth image))) +|# Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sat Aug 12 01:44:13 2006 @@ -41,11 +41,28 @@ (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) (gfs::zero-mem info-ptr gfs::iconinfo) (if (zerop (gfs::get-icon-info hicon info-ptr)) - (error 'gfs::win32-error :detail "get-icon-info failed")) + (error 'gfs:win32-error :detail "get-icon-info failed")) (cffi:with-foreign-slots ((gfs::hmask gfs::hcolor) info-ptr gfs::iconinfo) (gfs::delete-object gfs::hmask) (make-instance 'image :handle gfs::hcolor)))) +(defun image->hicon (image &optional point) + (unless (typep point 'gfs:point) + (setf point (transparency-pixel-of image)) + (unless point + (setf point (gfs:make-point)))) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (setf gfs::flag 1) + (with-image-transparency (image point) + (setf gfs::hcolor (gfs:handle image)) + (setf gfs::hmask (gfs:handle (transparency-mask image))) + (let ((hicon (gfs::create-icon-indirect info-ptr))) + (if (gfs:null-handle-p hicon) + (error 'gfs:win32-error :detail "create-icon-indirect failed")) + hicon))))) + (defun icon-extent (hicon) (let ((im (hicon->image hicon)) (extent 0)) @@ -54,30 +71,63 @@ (gfs:dispose im)) extent)) -(defun icon-handle (bundle index) +;;; Note: this function needs to return a place not +;;; just a handle, to facilitate a defsetf further +;;; on below +;;; +(defun icon-handle-ref (bundle index) (let ((handles (gfs:handle bundle))) (unless handles (error 'gfs:disposed-error)) (cond ((typep index 'integer) - (if (zerop index) - (if (listp handles) + (if (listp handles) + (if (< index (length handles)) (elt handles index) - handles))) + (error 'gfs:toolkit-error :detail "invalid image index")) + (if (zerop index) + (gfs:handle bundle) + (error 'gfs:toolkit-error :detail "invalid image index")))) ((eql index :small) (if (listp handles) (first (stable-sort handles #'< :key #'icon-extent)) - handles)) + (gfs:handle bundle))) ((eql index :large) (if (listp handles) (first (last (stable-sort handles #'< :key #'icon-extent))) - handles)) + (gfs:handle bundle))) (t (error 'gfs:toolkit-error :detail "an integer index, or one of :small or :large, is required"))))) -(defun icon-image (bundle index) - (hicon->image (icon-handle bundle index))) +(defsetf icon-handle-ref (bundle index) (hicon) + `(progn + (if (gfs:null-handle-p ,hicon) + (error 'gfs:disposed-error)) + (cond + ((listp (gfs:handle ,bundle)) + (replace (gfs:handle ,bundle) (list ,hicon) :start1 ,index)) + ((and (zerop ,index) (not (null (gfs:handle ,bundle)))) + (setf (slot-value ,bundle 'gfs:handle) ,hicon)) + (t + (error 'gfs:toolkit-error :detail "illegal arguments for (setf icon-handle-ref)"))) + ,hicon)) + +(defun icon-image-ref (bundle index) + (hicon->image (icon-handle-ref bundle index))) + +(defun set-icon-image (bundle index image) + (setf (icon-handle-ref bundle index) (image->hicon image))) + +(defsetf icon-image-ref set-icon-image) + +(defun icon-bundle-length (bundle) + (let ((handles (gfs:handle bundle))) + (unless handles + (error 'gfs:disposed-error)) + (if (listp handles) + (length handles) + 1))) ;;; ;;; methods @@ -104,26 +154,14 @@ (otherwise nil)))) (cond (resource-id - (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) - (file - (let ((tmp-image (make-instance 'image))) - (setf image-list (load tmp-image file)))) - (images - (setf image-list images))) + (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) + ((typep file 'pathname) + (setf image-list (list (make-instance 'image :file file)))) + ((listp images) + (setf image-list images))) (when image-list - (let ((handles nil) - (default-pnt (gfs:make-point))) - (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) - (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) - (gfs::zero-mem info-ptr gfs::iconinfo) - (setf gfs::flag 1) - (loop for tmp-image in image-list - do (with-image-transparency (tmp-image (or transparency-pixel default-pnt)) - (setf gfs::hcolor (gfs:handle tmp-image)) - (setf gfs::hmask (gfs:handle (transparency-mask tmp-image))) - (let ((hicon (gfs::create-icon-indirect info-ptr))) - (unless (gfs:null-handle-p hicon) - (push hicon handles))))))) - (setf (slot-value self 'gfs:handle) handles)))) + (let ((tr-pnt (or transparency-pixel (gfs:make-point)))) + (setf (slot-value self 'gfs:handle) (loop for tmp-image in image-list + collect (image->hicon tmp-image tr-pnt)))))) (unless (gfs:handle self) (error 'gfs:toolkit-error :detail "could not initialize icon bundle")))

1 0

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

11 Aug '06

Author: junrue Date: Fri Aug 11 15:47:54 2006 New Revision: 209 Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/overview.texinfo Log: added note about SBCL support Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Fri Aug 11 15:47:54 2006 @@ -1,4 +1,12 @@ + +. SBCL 0.9.15 is now a supported Common Lisp implementation. Graphic-Forms + includes a small patch to enable the stdcall calling convention for alien + callbacks, located in src/external-libraries/sbcl-callback-patch + + +============================================================================== + Release 0.4.0 of Graphic-Forms, a Common Lisp library for Windows GUI programming, is now available. This is an alpha release, meaning that the feature set and API have not yet stabilized. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Fri Aug 11 15:47:54 2006 @@ -37,7 +37,8 @@ Supported Common Lisp Implementations ------------------------------------- -Graphic-Forms currently supports CLISP 2.38 and LispWorks 4.4.6. +Graphic-Forms currently supports CLISP 2.38, LispWorks 4.4.6, and SBCL 0.9.15 +(the latter with a small patch). Known Problems Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Fri Aug 11 15:47:54 2006 @@ -52,8 +52,11 @@ Graphic-Forms is currently developed and tested with: @itemize @bullet -@item CLISP 2.38 +@item CLISP 2.38 or later @item LispWorks 4.4.6 +@item SBCL 0.9.15 or later@footnote{a small patch to enable the +@sc{stdcall} calling convention for callbacks is temporarily +bundled with Graphic-Forms, see @code{src/external-libraries/sbcl-callback-patch/}} @end itemize @@ -61,7 +64,7 @@ @itemize @bullet @item XP SP2 -@item Vista (testing on Beta 2 is in-progress as of this release) +@item Vista@footnote{testing on Beta 2 is in-progress as of this release} @end itemize

1 0

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

10 Aug '06

Author: junrue Date: Thu Aug 10 22:28:29 2006 New Revision: 207 Modified: trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: last of the tweaks for SBCL Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Thu Aug 10 22:28:29 2006 @@ -223,6 +223,8 @@ (setf *textedit-startup-dir* (ext:cd)) #+lispworks (setf *textedit-startup-dir* (hcl:get-working-directory)) +#+sbcl + (setf *textedit-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu :submenu ((:item "&New" :callback #'textedit-file-new) (:item "&Open..." :callback #'textedit-file-open) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Thu Aug 10 22:28:29 2006 @@ -166,6 +166,8 @@ (setf *unblocked-startup-dir* (ext:cd)) #+lispworks (setf *unblocked-startup-dir* (hcl:get-working-directory)) +#+sbcl + (setf *unblocked-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "&New" :callback #'new-unblocked) (:item "&Restart" :callback #'restart-unblocked) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu Aug 10 22:28:29 2006 @@ -307,7 +307,7 @@ (defmethod redraw ((self widget)) (let ((hwnd (gfs:handle self))) (unless (gfs:null-handle-p hwnd) - (gfs::invalidate-rect hwnd nil 1)))) + (gfs::invalidate-rect hwnd (cffi:null-pointer) 1)))) (defmethod resizable-p :before ((self widget)) (if (gfs:disposed-p self)

1 0

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

10 Aug '06

Author: junrue Date: Thu Aug 10 18:06:32 2006 New Revision: 206 Modified: trunk/src/uitoolkit/widgets/window.lisp Log: fixed a regression for clisp caused by renaming the child window visitor callback Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 18:06:32 2006 @@ -224,7 +224,7 @@ (cffi:pointer-address hwnd)) #+clisp (gfs::enum-child-windows hwnd - #'child_window_visitor + #'child-window-visitor (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc))))

1 0

[graphic-forms-cvs] r205 - in trunk: . src/external-libraries/sbcl-callback-patch src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Aug '06

10 Aug '06

Author: junrue Date: Thu Aug 10 17:33:31 2006 New Revision: 205 Added: trunk/src/external-libraries/sbcl-callback-patch/ trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp trunk/src/external-libraries/sbcl-callback-patch/readme.txt Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/window.lisp Log: integrated stdcall callback patch for SBCL and implemented various enum procs for SBCL Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 17:33:31 2006 @@ -47,8 +47,13 @@ ((:module "src" :components ((:file "packages") +#+sbcl (:module "external-libraries" + :components + ((:module "sbcl-callback-patch" + :components + ((:file "callback-hacking"))))) (:module "uitoolkit" - :depends-on ("packages") + :depends-on ("packages" #+sbcl "external-libraries") :components ((:module "system" :serial t Added: trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp Thu Aug 10 17:33:31 2006 @@ -0,0 +1,125 @@ +;;;; +;;;; hacking.lisp +;;;; +;;;; Compiler and runtime damage for callbacks +;;;; +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-VM") + +(sb-ext:without-package-locks + (defun alien-callback-assembler-wrapper (index return-type arg-types &optional (stack-offset 0)) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (declare (ignore arg-types)) + (let* ((segment (make-segment)) + (eax eax-tn) + (edx edx-tn) + (ebp ebp-tn) + (esp esp-tn) + ([ebp-8] (make-ea :dword :base ebp :disp -8)) + ([ebp-4] (make-ea :dword :base ebp :disp -4))) + (assemble (segment) + (inst push ebp) ; save old frame pointer + (inst mov ebp esp) ; establish new frame + (inst mov eax esp) ; + (inst sub eax 8) ; place for result + (inst push eax) ; arg2 + (inst add eax 16) ; arguments + (inst push eax) ; arg1 + (inst push (ash index 2)) ; arg0 + (inst push (get-lisp-obj-address #'enter-alien-callback)) ; function + (inst mov eax (foreign-symbol-address "funcall3")) + (inst call eax) + ;; now put the result into the right register + (cond + ((and (alien-integer-type-p return-type) + (eql (alien-type-bits return-type) 64)) + (inst mov eax [ebp-8]) + (inst mov edx [ebp-4])) + ((or (alien-integer-type-p return-type) + (alien-pointer-type-p return-type) + (alien-type-= #.(parse-alien-type 'system-area-pointer nil) + return-type)) + (inst mov eax [ebp-8])) + ((alien-single-float-type-p return-type) + (inst fld [ebp-8])) + ((alien-double-float-type-p return-type) + (inst fldd [ebp-8])) + ((alien-void-type-p return-type)) + (t + (error "unrecognized alien type: ~A" return-type))) + (inst mov esp ebp) ; discard frame + (inst pop ebp) ; restore frame pointer + (inst ret stack-offset)) + (finalize-segment segment) + ;; Now that the segment is done, convert it to a static + ;; vector we can point foreign code to. + (let ((buffer (sb-assem::segment-buffer segment))) + (make-static-vector (length buffer) + :element-type '(unsigned-byte 8) + :initial-contents buffer))))) + +(in-package "SB-ALIEN") + +(defun %alien-callback-sap (specifier result-type argument-types function wrapper &optional (call-type :cdecl)) + (let ((key (list specifier function call-type))) + (or (gethash key *alien-callbacks*) + (setf (gethash key *alien-callbacks*) + (let* ((index (fill-pointer *alien-callback-trampolines*)) + ;; Aside from the INDEX this is known at + ;; compile-time, which could be utilized by + ;; having the two-stage assembler tramp & + ;; wrapper mentioned in [1] above: only the + ;; per-function tramp would need assembler at + ;; runtime. Possibly we could even pregenerate + ;; the code and just patch the index in later. + (assembler-wrapper (alien-callback-assembler-wrapper + index result-type argument-types + (if (eq call-type :stdcall) + (* 4 (length argument-types)) + 0)))) + (vector-push-extend + (alien-callback-lisp-trampoline wrapper function) + *alien-callback-trampolines*) + (let ((sap (vector-sap assembler-wrapper))) + (push (cons sap (make-callback-info :specifier specifier + :function function + :wrapper wrapper + :index index)) + *alien-callback-info*) + sap)))))) + +(sb-ext:without-package-locks + (defmacro alien-callback (specifier function &optional (call-type :cdecl) &environment env) + "Returns an alien-value with of alien ftype SPECIFIER, that can be passed to +an alien function as a pointer to the FUNCTION. If a callback for the given +SPECIFIER and FUNCTION already exists, it is returned instead of consing a new +one." + ;; Pull out as much work as is convenient to macro-expansion time, specifically + ;; everything that can be done given just the SPECIFIER and ENV. + (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env) + `(%sap-alien + (%alien-callback-sap ',specifier ',result-type ',argument-types + ,function + (or (gethash ',specifier *alien-callback-wrappers*) + (setf (gethash ',specifier *alien-callback-wrappers*) + ,(alien-callback-lisp-wrapper-lambda + specifier result-type argument-types env))) ,call-type) + ',(parse-alien-type specifier env))))) + +#| +(sb-alien::alien-callback (function int int int) #'+ :stdcall) + => #<SB-ALIEN-INTERNALS:ALIEN-VAUE :SAP ... :TYPE ...> +(alien-funcall-stdcall * 3 4) => 9 +"Hey everybody, callbacks work!" +|# + +;;; EOF Added: trunk/src/external-libraries/sbcl-callback-patch/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/sbcl-callback-patch/readme.txt Thu Aug 10 17:33:31 2006 @@ -0,0 +1,8 @@ +This directory contains callback-hacking.lisp, authored by +Alastair Bridgewater. This code updates an SBCL image such +that stdcall callbacks are supported. + +The full distribution including sample code is available from: + + http://www.lisphacker.com/files/lisp-winapi.tgz + http://www.lisphacker.com/files/hello-win32.tgz Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Aug 10 17:33:31 2006 @@ -45,9 +45,9 @@ :unicode :ascii)) -(defctype ATOM :unsigned-short) ; shadowed in defpackage +(defctype ATOM :unsigned-short) ; shadowed in gfs: package (defctype BOOL :int) -(defctype BOOLEAN :char) ; shadowed in defpackage +(defctype BOOLEAN :char) ; shadowed in gfs: package (defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) (defctype DWORD :unsigned-long) @@ -73,6 +73,26 @@ (defctype WORD :short) (defctype WPARAM :unsigned-int) +#+sbcl +(sb-alien:define-alien-type enumchildproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long))) + +#+sbcl +(sb-alien:define-alien-type enumthreadwndproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long))) + +#+sbcl +(sb-alien:define-alien-type monitorsenumproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:long))) + (defcstruct actctx (cbsize ULONG) (flags DWORD) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 17:33:31 2006 @@ -223,6 +223,12 @@ (lparam ffi:long)) (:return-type ffi:int)) +#+sbcl +(sb-alien:define-alien-routine ("EnumChildWindows" enum-child-windows) sb-alien:int + (hwnd sb-alien:system-area-pointer) + (func enumchildproc) + (lparam sb-alien:long)) + ;;; FIXME: uncomment this when CFFI callbacks can ;;; be tagged as stdcall or cdecl (only the latter ;;; is supported as of 0.9.0) @@ -264,6 +270,13 @@ (data ffi:c-pointer)) (:return-type ffi:int)) +#+sbcl +(sb-alien:define-alien-routine ("EnumDisplayMonitors" enum-display-monitors) sb-alien:int + (hdc sb-alien:system-area-pointer) + (rect sb-alien:system-area-pointer) + (func monitorsenumproc) + (lparam sb-alien:long)) + ;;; FIXME: uncomment this when CFFI callbacks can ;;; be tagged as stdcall or cdecl (only the latter ;;; is supported as of 0.9.0) @@ -300,6 +313,12 @@ (lparam ffi:long)) (:return-type ffi:int)) +#+sbcl +(sb-alien:define-alien-routine ("EnumThreadWindows" enum-thread-windows) sb-alien:int + (id sb-alien:unsigned-long) + (func enumthreadwndproc) + (lparam sb-alien:unsigned-long)) + (defcfun ("GetAncestor" get-ancestor) HANDLE Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Thu Aug 10 17:33:31 2006 @@ -48,12 +48,22 @@ (call-display-visitor-func (thread-context) hmonitor data) 1) -#+clisp -(defun display_visitor (hmonitor hdc monitorrect data) +(defun display-visitor (hmonitor hdc monitorrect data) (declare (ignore hdc monitorrect)) (call-display-visitor-func (thread-context) hmonitor data) 1) +#+sbcl +(defvar *monitors-enum-proc* + (sb-alien::alien-callback + (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:long) + #'display-visitor + :stdcall)) + (defun query-display-info (hmonitor) (let ((info nil)) (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) @@ -87,9 +97,14 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#+lispworks (let ((ptr (fli:make-pointer :address 0))) +#+sbcl + (let ((ptr (cffi:null-pointer))) + (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0)) +#+lispworks + (let ((ptr (fli:make-pointer :address 0))) (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) -#+clisp (gfs::enum-display-monitors nil nil #'display_visitor nil) +#+clisp + (gfs::enum-display-monitors nil nil #'display-visitor nil) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -104,26 +119,31 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -#+lispworks -(fli:define-foreign-callable - ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) +(defun top-level-window-visitor (hwnd lparam) + (declare (ignore lparam)) (let* ((tc (thread-context)) (win (get-widget tc hwnd))) (unless (null win) (call-top-level-visitor-func tc win))) 1) -#+clisp -(defun top_level_window_visitor (hwnd lparam) - (declare (ignore lparam)) - (let* ((tc (thread-context)) - (win (get-widget tc hwnd))) - (unless (null win) - (call-top-level-visitor-func tc win))) +#+lispworks +(fli:define-foreign-callable + ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) + ((hwnd :pointer) + (lparam :long)) + (top-level-window-visitor hwnd lparam) 1) +#+sbcl +(defvar *enum-thread-wnd-proc* + (sb-alien::alien-callback + (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long) + #'top-level-window-visitor + :stdcall)) + (defun maptoplevels (func) ;; ;; func should expect one parameter: @@ -132,12 +152,18 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#+lispworks (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (fli:make-pointer :symbol-name "top_level_window_visitor") - 0) -#+clisp (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - #'top_level_window_visitor - 0) +#+sbcl + (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (sb-alien:alien-sap *enum-thread-wnd-proc*) + 0) +#+lispworks + (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (fli:make-pointer :symbol-name "top_level_window_visitor") + 0) +#+clisp + (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + #'top-level-window-visitor + 0) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) (setf (top-level-visitor-results tc) nil) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 17:33:31 2006 @@ -60,34 +60,31 @@ (put-kbdnav-widget tc win)) (put-widget tc win)))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro child-visitor-proper (hwnd lparam) - (let ((tc (gensym)) - (tmp-list (gensym)) - (child (gensym)) - (parent (gensym)) - (ancestor-hwnd (gensym))) - `(let* ((,tc (thread-context)) - (,child (get-widget ,tc ,hwnd)) - (,parent (get-widget ,tc (cffi:make-pointer ,lparam)))) - (unless (or (null ,parent) (null ,child)) - (let ((,ancestor-hwnd (gfs::get-ancestor (gfs:handle ,child) gfs::+ga-parent+)) - (,tmp-list (child-visitor-results ,tc))) - (if (cffi:pointer-eq (gfs:handle ,parent) ,ancestor-hwnd) - (setf (child-visitor-results ,tc) (push (call-child-visitor-func ,tc ,parent ,child) ,tmp-list))))))))) +(defun child-window-visitor (hwnd lparam) + (let* ((tc (thread-context)) + (child (get-widget tc hwnd)) + (parent (get-widget tc (cffi:make-pointer lparam)))) + (unless (or (null parent) (null child)) + (let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)) + (tmp-list (child-visitor-results tc))) + (if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd) + (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list)))))) + 1) #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) ((hwnd :pointer) (lparam :long)) - (child-visitor-proper hwnd lparam) + (child-window-visitor hwnd lparam) 1) -#+clisp -(defun child_window_visitor (hwnd lparam) - (child-visitor-proper hwnd lparam) - 1) +#+sbcl +(defvar *enum-child-proc* + (sb-alien::alien-callback + (sb-alien:function sb-alien:int sb-alien:system-area-pointer sb-alien:long) + #'child-window-visitor + :stdcall)) (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) @@ -213,22 +210,22 @@ (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) (defmethod mapchildren ((self window) func) - (let ((tc (thread-context))) + (let ((tc (thread-context)) + (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect +#+sbcl + (gfs::enum-child-windows hwnd + (sb-alien:alien-sap *enum-child-proc*) + (cffi:pointer-address hwnd)) #+lispworks - (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle self))) + (gfs::enum-child-windows hwnd (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address (gfs:handle self))) + (cffi:pointer-address hwnd)) #+clisp - (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) - (setf ptr (ffi:set-foreign-pointer - (ffi:unsigned-foreign-address - (cffi:pointer-address (gfs:handle self))) - ptr)) - (gfs::enum-child-windows ptr - #'child_window_visitor - (cffi:pointer-address (gfs:handle self)))) + (gfs::enum-child-windows hwnd + #'child_window_visitor + (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) (setf (child-visitor-results tc) nil)

1 0

[graphic-forms-cvs] r204 - in trunk: . src src/demos/unblocked src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Aug '06

10 Aug '06

Author: junrue Date: Thu Aug 10 02:08:05 2006 New Revision: 204 Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/clib.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/label.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-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: initial phase of SBCL port completed Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 02:08:05 2006 @@ -51,6 +51,7 @@ :depends-on ("packages") :components ((:module "system" + :serial t :components ((:file "system-constants") (:file "system-classes") @@ -74,8 +75,10 @@ (:file "graphics-generics") (:file "color") (:file "palette") - (:file "image-data") - (:file "image") + (:file "image-data" + :depends-on ("graphics-classes")) + (:file "image" + :depends-on ("graphics-classes")) (:file "icon-bundle" :depends-on ("graphics-constants" "image")) (:file "font-data") @@ -85,10 +88,12 @@ :components ((:file "graphics-plugin-packages") #-skip-default-plugin (:module "default" + :serial t :components ((:file "file-formats") (:file "default-data-plugin"))) #+load-imagemagick-plugin (:module "imagemagick" + :serial t :components ((:file "magick-core-types") (:file "magick-core-api") @@ -96,6 +101,7 @@ :depends-on ("magick-core-types" "magick-core-api")))))))) (:module "widgets" :depends-on ("graphics") + :serial t :components ((:file "widget-constants") (:file "widget-classes") Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Thu Aug 10 02:08:05 2006 @@ -33,9 +33,9 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +level-label+ "Level:") -(defconstant +points-needed-label+ "Points Needed:") -(defconstant +score-label+ "Score:") +(defparameter *level-label* "Level:") +(defparameter *points-needed-label* "Points Needed:") +(defparameter *score-label* "Score:") (defconstant +scoreboard-text-margin+ 2) @@ -73,7 +73,7 @@ (buffer-size (gfs:make-size))) (unwind-protect (progn - (setf (gfs:size-width buffer-size) (* (+ (length +points-needed-label+) + (setf (gfs:size-width buffer-size) (* (+ (length *points-needed-label*) 2 ; space between label and value 9) ; number of value characters (gfg:average-char-width metrics))) @@ -112,9 +112,9 @@ (unwind-protect (progn (clear-buffer self gc) - (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (game-score)) - (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (game-level)) - (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (game-points-needed))) + (draw-scoreboard-row gc 1 image-size label-font *score-label* value-font (game-score)) + (draw-scoreboard-row gc 0 image-size label-font *level-label* value-font (game-level)) + (draw-scoreboard-row gc 2 image-size label-font *points-needed-label* value-font (game-points-needed))) (gfs:dispose gc)))) (defclass scoreboard-panel (gfw:panel) ()) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 10 02:08:05 2006 @@ -233,6 +233,10 @@ (defpackage #:graphic-forms.uitoolkit.widgets (:nicknames #:gfw) (:use #:common-lisp) +#+sbcl + (:import-from :sb-mop :ensure-generic-function) +#-sbcl + (:import-from :clos :ensure-generic-function) (:export ;; classes and structs Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Aug 10 02:08:05 2006 @@ -33,12 +33,13 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defconstant +btn-text-before+ "Push Me") -(defconstant +btn-text-after+ "Again!") -(defconstant +edit-text+ "something to edit") -(defconstant +label-text+ "Label") -(defconstant +margin-delta+ 4) -(defconstant +spacing-delta+ 3) +(defparameter *btn-text-before* "Push Me") +(defparameter *btn-text-after* "Again!") +(defparameter *edit-text* "something to edit") +(defparameter *label-text* "Label") + +(defconstant +margin-delta+ 4) +(defconstant +spacing-delta+ 3) (defvar *widget-counter* 0) @@ -93,10 +94,10 @@ (if (null flag) (progn (setf flag t) - (format nil "~d ~a" (id be) +btn-text-before+)) + (format nil "~d ~a" (id be) *btn-text-before*)) (progn (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) + (format nil "~d ~a" (id be) *btn-text-after*)))))) (defun add-layout-tester-widget (widget-class subtype) (let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) @@ -119,7 +120,7 @@ ((eql subtype :single-line-edit) (setf w (make-instance widget-class :parent *layout-tester-win* - :text (format nil "~d ~a" (id be) +edit-text+)))) + :text (format nil "~d ~a" (id be) *edit-text*)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here @@ -135,7 +136,7 @@ :parent *layout-tester-win* :dispatcher be :style '(:sunken))) - (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+))) + (setf (gfw:text w) (format nil "~d ~a" (id be) *label-text*))) (t (setf w (make-instance widget-class :parent *layout-tester-win* Modified: trunk/src/uitoolkit/system/clib.lisp ============================================================================== --- trunk/src/uitoolkit/system/clib.lisp (original) +++ trunk/src/uitoolkit/system/clib.lisp Thu Aug 10 02:08:05 2006 @@ -36,6 +36,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cffi)) +(load-foreign-library "msvcrt.dll") + (defcfun ("strncpy" strncpy) :pointer Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Thu Aug 10 02:08:05 2006 @@ -167,16 +167,6 @@ (hdc HANDLE)) (defcfun - ("DrawTextExA" draw-text-ex) - INT - (hdc HANDLE) - (text :string) - (count INT) - (rect LPTR) - (format UINT) - (params LPTR)) - -(defcfun ("Ellipse" ellipse) BOOL (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Aug 10 02:08:05 2006 @@ -36,20 +36,20 @@ ;;; ;;; control class names ;;; -(defconstant +button-classname+ "button") -(defconstant +edit-classname+ "edit") -(defconstant +static-classname+ "static") +(defparameter *button-classname* "button") +(defparameter *edit-classname* "edit") +(defparameter *static-classname* "static") ;;; ;;; registered message names ;;; -(defconstant +lbselchstringa+ "commdlg_LBSelChangedNotify") -(defconstant +sharevistringa+ "commdlg_ShareViolation") -(defconstant +fileokstringa+ "commdlg_FileNameOK") -(defconstant +colorokstringa+ "commdlg_ColorOK") -(defconstant +setrgbstringa+ "commdlg_SetRGBColor") -(defconstant +helpmsgstringa+ "commdlg_help") -(defconstant +findmsgstringa+ "commdlg_FindReplace") +(defparameter *lbselchstringa* "commdlg_LBSelChangedNotify") +(defparameter *sharevistringa* "commdlg_ShareViolation") +(defparameter *fileokstringa* "commdlg_FileNameOK") +(defparameter *colorokstringa* "commdlg_ColorOK") +(defparameter *setrgbstringa* "commdlg_SetRGBColor") +(defparameter *helpmsgstringa* "commdlg_help") +(defparameter *findmsgstringa* "commdlg_FindReplace") (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 02:08:05 2006 @@ -154,6 +154,16 @@ (hwnd HANDLE)) (defcfun + ("DrawTextExA" draw-text-ex) + INT + (hdc HANDLE) + (text :string) + (count INT) + (rect LPTR) + (format UINT) + (params LPTR)) + +(defcfun ("EnableMenuItem" enable-menu-item) BOOL (hmenu HANDLE) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Thu Aug 10 02:08:05 2006 @@ -79,7 +79,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::+button-classname+ + (let ((hwnd (create-window gfs::*button-classname* (or text " ") (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu Aug 10 02:08:05 2006 @@ -33,17 +33,18 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +default-dialog-title+ " ") -(defconstant +dlgwindowextra+ 48) +(defparameter *default-dialog-title* " ") -(defvar *disabled-top-levels* nil) +(defconstant +dlgwindowextra+ 48) + +(defvar *disabled-top-levels* nil) ;;; ;;; helper functions ;;; (defun register-dialog-class () - (register-window-class +dialog-classname+ + (register-window-class *dialog-classname* (cffi:get-callback 'uit_widgets_wndproc) (logior gfs::+cs-dblclks+ gfs::+cs-savebits+ @@ -167,7 +168,7 @@ (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) (if (null text) - (setf text +default-dialog-title+)) + (setf text *default-dialog-title*)) ;; NOTE: do not allow apps to specify the desktop window as the ;; owner of the dialog; it would cause the desktop to become ;; disabled. @@ -179,7 +180,7 @@ ;; walk up the ancestors until one is found. Only top level hwnds can ;; be owners. ;; - (init-window self +dialog-classname+ #'register-dialog-class owner text)) + (init-window self *dialog-classname* #'register-dialog-class owner text)) (defmethod show ((self dialog) flag) (let ((app-modal (find :application-modal (style-of self))) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Thu Aug 10 02:08:05 2006 @@ -97,7 +97,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::+edit-classname+ + (let ((hwnd (create-window gfs::*edit-classname* (or text "") (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Thu Aug 10 02:08:05 2006 @@ -33,10 +33,10 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source)) - (gfw:event-arm . (gfw:event-source)) - (gfw:event-modify . (gfw:event-source)) - (gfw:event-select . (gfw:event-source)))) +(defparameter *callback-info* '((gfw:event-activate . (gfw:event-source)) + (gfw:event-arm . (gfw:event-source)) + (gfw:event-modify . (gfw:event-source)) + (gfw:event-select . (gfw:event-source)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) @@ -45,12 +45,12 @@ (defun define-dispatcher-for-callbacks (callbacks) (let ((*print-gensym* nil) - (class (clos:ensure-class (gentemp "EDCLASS" :gfgen) + (class (c2mop:ensure-class (gentemp "EDCLASS" :gfgen) :direct-superclasses '(event-dispatcher)))) (loop for pair in callbacks do (let* ((method-sym (car pair)) (fn (cdr pair)) - (arg-info (cdr (assoc method-sym +callback-info+))) + (arg-info (cdr (assoc method-sym *callback-info*))) (args nil)) `(unless (or (symbolp ,fn) (functionp ,fn)) (error 'gfs:toolkit-error @@ -61,7 +61,7 @@ method-sym))) (dotimes (i (1+ (length arg-info))) (push (gentemp "ARG" :gfgen) args)) - (c2mop:ensure-method (clos:ensure-generic-function method-sym :lambda-list args) + (c2mop:ensure-method (ensure-generic-function method-sym :lambda-list args) `(lambda ,args (funcall ,fn ,@args)) :specializers (make-specializer-list class arg-info)))) class)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Thu Aug 10 02:08:05 2006 @@ -152,7 +152,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags label image separator text) - (let ((hwnd (create-window gfs::+static-classname+ + (let ((hwnd (create-window gfs::*static-classname* (or text " ") (gfs:handle parent) (logior std-style) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Thu Aug 10 02:08:05 2006 @@ -41,7 +41,7 @@ (declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items (let ((info-mask (logior gfs::+miim-id+ (if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+) - (if hchildmenu gfs::+miim-submenu+))) + (if hchildmenu gfs::+miim-submenu+ 0))) (info-type (if label 0 gfs::+mft-separator+)) (info-state (logior (if checked gfs::+mfs-checked+ 0) (if disabled gfs::+mfs-disabled+ 0)))) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Thu Aug 10 02:08:05 2006 @@ -33,14 +33,14 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +panel-window-classname+ "GraphicFormsPanel") +(defparameter *panel-window-classname* "GraphicFormsPanel") ;;; ;;; helper functions ;;; (defun register-panel-window-class () - (register-window-class +panel-window-classname+ + (register-window-class *panel-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ -1)) @@ -70,4 +70,4 @@ (error 'gfs:toolkit-error :detail "parent is required for panel")) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) - (init-window self +panel-window-classname+ #'register-panel-window-class parent "")) + (init-window self *panel-window-classname* #'register-panel-window-class parent "")) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Aug 10 02:08:05 2006 @@ -59,35 +59,42 @@ ;; TODO: change this when CLISP acquires MT support ;; -#+clisp (defvar *the-thread-context* nil) +;; TODO: change this once we understand SBCL MT support +;; +#+(or clisp sbcl) +(defvar *the-thread-context* nil) -#+clisp (defun thread-context () - (when (null *the-thread-context*) - (setf *the-thread-context* (make-instance 'thread-context)) - (init-utility-hwnd *the-thread-context*)) - *the-thread-context*) - -#+clisp (defun dispose-thread-context () - (let ((hwnd (utility-hwnd *the-thread-context*))) - (unless (gfs:null-handle-p hwnd) - (gfs::destroy-window hwnd))) - (setf *the-thread-context* nil)) - -#+lispworks (defun thread-context () - (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) - (when (null tc) - (setf tc (make-instance 'thread-context)) - (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) - (init-utility-hwnd tc)) - tc)) - -#+lispworks (defun dispose-thread-context () - (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) - (if tc - (let ((hwnd (utility-hwnd tc))) - (unless (gfs:null-handle-p hwnd) - (gfs::destroy-window hwnd))))) - (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) +#+(or clisp sbcl) +(defun thread-context () + (when (null *the-thread-context*) + (setf *the-thread-context* (make-instance 'thread-context)) + (init-utility-hwnd *the-thread-context*)) + *the-thread-context*) + +#+(or clisp sbcl) +(defun dispose-thread-context () + (let ((hwnd (utility-hwnd *the-thread-context*))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))) + (setf *the-thread-context* nil)) + +#+lispworks +(defun thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (when (null tc) + (setf tc (make-instance 'thread-context)) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) + (init-utility-hwnd tc)) + tc)) + +#+lispworks +(defun dispose-thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (if tc + (let ((hwnd (utility-hwnd tc))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))))) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) (defmethod init-utility-hwnd ((tc thread-context)) (register-toplevel-noerasebkgnd-window-class) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Aug 10 02:08:05 2006 @@ -33,20 +33,20 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +default-window-title+ "New Window") +(defparameter *default-window-title* "New Window") ;;; ;;; helper functions ;;; (defun register-toplevel-erasebkgnd-window-class () - (register-window-class +toplevel-erasebkgnd-window-classname+ + (register-window-class *toplevel-erasebkgnd-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ gfs::+color-appworkspace+)) (defun register-toplevel-noerasebkgnd-window-class () - (register-window-class +toplevel-noerasebkgnd-window-classname+ + (register-window-class *toplevel-noerasebkgnd-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ -1)) @@ -138,11 +138,11 @@ (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) (if (null text) - (setf text +default-window-title+)) - (let ((classname +toplevel-noerasebkgnd-window-classname+) + (setf text *default-window-title*)) + (let ((classname *toplevel-noerasebkgnd-window-classname*) (register-func #'register-toplevel-noerasebkgnd-window-class)) (when (find :workspace (style-of win)) - (setf classname +toplevel-erasebkgnd-window-classname+) + (setf classname *toplevel-erasebkgnd-window-classname*) (setf register-func #'register-toplevel-erasebkgnd-window-class)) (init-window win classname register-func owner text))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Aug 10 02:08:05 2006 @@ -79,20 +79,22 @@ (translate-and-dispatch msg-ptr) nil))) -#+clisp (defun startup (thread-name start-fn) - (declare (ignore thread-name)) - (funcall start-fn) - (message-loop #'default-message-filter)) - -#+lispworks (defun startup (thread-name start-fn) - (hcl:add-special-free-action 'gfs::native-object-special-action) - (when (null (mp:list-all-processes)) - (mp:initialize-multiprocessing)) - (mp:process-run-function thread-name - nil - (lambda () - (funcall start-fn) - (message-loop #'default-message-filter)))) +#+(or clisp sbcl) +(defun startup (thread-name start-fn) + (declare (ignore thread-name)) + (funcall start-fn) + (message-loop #'default-message-filter)) + +#+lispworks +(defun startup (thread-name start-fn) + (hcl:add-special-free-action 'gfs::native-object-special-action) + (if (null (mp:list-all-processes)) + (mp:initialize-multiprocessing)) + (mp:process-run-function thread-name + nil + (lambda () + (funcall start-fn) + (message-loop #'default-message-filter)))) (defun shutdown (exit-code) (gfs::post-quit-message exit-code)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 02:08:05 2006 @@ -33,10 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +dialog-classname+ "GraphicFormsDialog") - (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") - (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")) +(defparameter *dialog-classname* "GraphicFormsDialog") +(defparameter *toplevel-erasebkgnd-window-classname* "GraphicFormsTopLevelEraseBkgnd") +(defparameter *toplevel-noerasebkgnd-window-classname* "GraphicFormsTopLevelNoEraseBkgnd") ;;; ;;; helper functions @@ -145,7 +144,7 @@ (color nil)) (cffi:with-foreign-pointer-as-string (str-ptr 64) (gfs::get-class-name hwnd str-ptr 64) - (if (string= (cffi:foreign-string-to-lisp str-ptr) +toplevel-erasebkgnd-window-classname+) + (if (string= (cffi:foreign-string-to-lisp str-ptr) *toplevel-erasebkgnd-window-classname*) (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) color))

1 0

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

09 Aug '06

Author: junrue Date: Thu Aug 10 00:15:08 2006 New Revision: 203 Added: trunk/src/tests/uitoolkit/default.ico (contents, props changed) trunk/src/uitoolkit/graphics/icon-bundle.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-constants.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp Log: implemented and documented icon-bundle class and related functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Aug 10 00:15:08 2006 @@ -2028,21 +2028,24 @@ in the @code{<Alt><Tab>} task switching dialog, and in the Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN documentation for further discussion of standard icon sizes, color -depths and file format. @code{icon-bundle} derives from @ref{native-object}. +depths and file format.@*@* +@code{icon-bundle} derives from @ref{native-object}. @deffn Initarg :file This initarg accepts a @sc{cl:pathname} identifying a file with @ref{image-data} to be loaded, as described for the @ref{image} -class @code{:file} initarg. Note that the @sc{.ico} format can -store multiple icons, all of which will be loaded. Since +class @code{:file} initarg. Note that the @sc{ico} format can +store multiple icons, all of which will be loaded. Application +code should not assume that load order is preserved. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the proper transparency @ref{color}; by default, the pixel color at -@code{(0, 0)} in each image will be used. @emph{FIXME: link to -documentation of graphics plugins here}. +@code{(0, 0)} in each image will be used. @emph{FIXME: link +to documentation of graphics plugins here}. @end deffn @deffn Initarg :images -This initarg accepts a @sc{cl:list} of image objects. Since +This initarg accepts a @sc{cl:list} of image objects. Application +code should not assume that image order is preserved. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, the application may either @sc{setf} @ref{transparency-pixel} for each image ahead of time (especially @@ -2346,6 +2349,30 @@ Returns a color object corresponding to the current foreground color. @end deffn +@anchor{icon-image} +@defun icon-image @ref{icon-bundle} index => @ref{image} +This function uses an integer or keyword -based @var{index} to address +the images comprising an icon-bundle, either to retrieve an image +or add/replace an image via @sc{setf}. Application code should not +assume that image load order was preserved when this function is called. +@table @var +@item icon-bundle +This is an icon-bundle containing images to be updated or retrieved. +@item index +This argument can be a zero-based, with new images added by +specifying @var{index} 0. Or @var{index} can be one of the following +keywords: +@table @code +@item :large +Specifies the largest image of the icon-bundle. +@item :small +Specifies the smallest image of the icon-bundle. +@end table +@end table +To find out how many images are stored in an icon-bundle, call +@ref{size}. +@end defun + @anchor{load} @deffn GenericFunction load self path => list Certain graphics objects have a persistent representation, which may @@ -2356,6 +2383,13 @@ returns @var{self} plus any additional instances in a @sc{list}, ordered the same as they are read from @var{path}. @emph{Note:} @sc{gfg:load} shadows @sc{cl:load}. +@table @var +@item self +The graphics object that will be populated with data. +@item path +A @sc{cl:pathname} identifying a file with graphics data appropriate +for @var{self}. +@end table @end deffn @deffn GenericFunction metrics self font => @ref{font-metrics} Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 00:15:08 2006 @@ -76,6 +76,8 @@ (:file "palette") (:file "image-data") (:file "image") + (:file "icon-bundle" + :depends-on ("graphics-constants" "image")) (:file "font-data") (:file "font") (:file "graphics-context") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 10 00:15:08 2006 @@ -109,6 +109,7 @@ #:font-data #:font-metrics #:graphics-context + #:icon-bundle #:image #:image-data #:image-data-plugin @@ -123,6 +124,11 @@ #:*color-red* #:*color-white* #:*image-file-types* + #:+application-icon+ + #:+error-icon+ + #:+information-icon+ + #:+question-icon+ + #:+warning-icon+ ;; methods, functions, macros #:accepts-file-p @@ -182,6 +188,7 @@ #:green-mask #:green-shift #:height + #:icon-image #:invert #:leading #:line-cap-style Added: trunk/src/tests/uitoolkit/default.ico ============================================================================== Binary file. No diff available. Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Thu Aug 10 00:15:08 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; classes.lisp +;;;; graphics-classes.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -127,12 +127,15 @@ :initform (cffi:null-pointer))) (:documentation "This class represents the context associated with drawing primitives.")) +(defclass icon-bundle (gfs:native-object) () + (:documentation "This class encapsulates a set of Win32 icon handles.")) + (defclass image (gfs:native-object) ((transparency-pixel :accessor transparency-pixel-of :initarg :transparency-pixel :initform nil)) - (:documentation "This class wraps a native image object.")) + (:documentation "This class encapsulates a Win32 bitmap handle.")) (defmacro blue-mask (data) `(gfg::palette-blue-mask ,data)) Modified: trunk/src/uitoolkit/graphics/graphics-constants.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-constants.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-constants.lisp Thu Aug 10 00:15:08 2006 @@ -57,3 +57,13 @@ (defconstant +russian-charset+ 204) (defconstant +mac-charset+ 77) (defconstant +baltic-charset+ 186) + +;;; The following are from WinUser.h; specify one of +;;; them as the value of the :system keyword arg when +;;; creating an icon-bundle +;;; +(defconstant +application-icon+ 32512) +(defconstant +error-icon+ 32513) +(defconstant +information-icon+ 32516) +(defconstant +question-icon+ 32514) +(defconstant +warning-icon+ 32515) Added: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Thu Aug 10 00:15:08 2006 @@ -0,0 +1,129 @@ +;;;; +;;;; icon-bundle.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.graphics) + +;;; +;;; helper functions +;;; + +(defun hicon->image (hicon) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (if (zerop (gfs::get-icon-info hicon info-ptr)) + (error 'gfs::win32-error :detail "get-icon-info failed")) + (cffi:with-foreign-slots ((gfs::hmask gfs::hcolor) info-ptr gfs::iconinfo) + (gfs::delete-object gfs::hmask) + (make-instance 'image :handle gfs::hcolor)))) + +(defun icon-extent (hicon) + (let ((im (hicon->image hicon)) + (extent 0)) + (unwind-protect + (setf extent (gfs:size-height (gfg:size im))) + (gfs:dispose im)) + extent)) + +(defun icon-handle (bundle index) + (let ((handles (gfs:handle bundle))) + (unless handles + (error 'gfs:disposed-error)) + (cond + ((typep index 'integer) + (if (zerop index) + (if (listp handles) + (elt handles index) + handles))) + ((eql index :small) + (if (listp handles) + (first (stable-sort handles #'< :key #'icon-extent)) + handles)) + ((eql index :large) + (if (listp handles) + (first (last (stable-sort handles #'< :key #'icon-extent))) + handles)) + (t + (error 'gfs:toolkit-error + :detail "an integer index, or one of :small or :large, is required"))))) + +(defun icon-image (bundle index) + (hicon->image (icon-handle bundle index))) + +;;; +;;; methods +;;; + +(defmethod gfs:dispose ((self icon-bundle)) + (let ((handles (gfs:handle self))) + (setf (slot-value self 'gfs:handle) nil) + ;; note: if handles is a cffi:pointer, then self was + ;; instantiated as a system icon and we don't need + ;; to destroy the handle + ;; + (if (and handles (listp handles)) + (loop for hicon in handles do (gfs::destroy-icon hicon))))) + +(defmethod initialize-instance :after ((self icon-bundle) &key file images system transparency-pixel) + (let ((image-list nil) + (resource-id (case system + (#.+application-icon+ (cffi:make-pointer system)) + (#.+error-icon+ (cffi:make-pointer system)) + (#.+information-icon+ (cffi:make-pointer system)) + (#.+question-icon+ (cffi:make-pointer system)) + (#.+warning-icon+ (cffi:make-pointer system)) + (otherwise nil)))) + (cond + (resource-id + (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) + (file + (let ((tmp-image (make-instance 'image))) + (setf image-list (load tmp-image file)))) + (images + (setf image-list images))) + (when image-list + (let ((handles nil) + (default-pnt (gfs:make-point))) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (setf gfs::flag 1) + (loop for tmp-image in image-list + do (with-image-transparency (tmp-image (or transparency-pixel default-pnt)) + (setf gfs::hcolor (gfs:handle tmp-image)) + (setf gfs::hmask (gfs:handle (transparency-mask tmp-image))) + (let ((hicon (gfs::create-icon-indirect info-ptr))) + (unless (gfs:null-handle-p hicon) + (push hicon handles))))))) + (setf (slot-value self 'gfs:handle) handles)))) + (unless (gfs:handle self) + (error 'gfs:toolkit-error :detail "could not initialize icon bundle"))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Thu Aug 10 00:15:08 2006 @@ -83,10 +83,10 @@ (gfs:dispose self)) (setf (slot-value self 'gfs:handle) (data->image id))) -(defmethod initialize-instance :after ((image image) &key file size &allow-other-keys) +(defmethod initialize-instance :after ((self image) &key file size &allow-other-keys) (cond (file - (load image file)) + (load self file)) (size (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) @@ -104,19 +104,19 @@ (cffi:with-foreign-object (buffer :pointer) (gfs::with-compatible-dcs (nptr memdc) (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) - (setf (slot-value image 'gfs:handle) hbmp))))))) + (setf (slot-value self 'gfs:handle) hbmp))))))) -(defmethod load ((im image) path) +(defmethod load ((self image) path) (let ((data (make-instance 'image-data))) (load data path) - (setf (data-object im) data) + (setf (data-object self) data) data)) -(defmethod size ((image image)) - (if (gfs:disposed-p image) +(defmethod size ((self image)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((size (gfs:make-size)) - (himage (gfs:handle image))) + (himage (gfs:handle self))) (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) @@ -124,17 +124,17 @@ (gfs:size-height size) gfs::height))) size)) -(defmethod transparency-mask ((im image)) - (if (gfs:disposed-p im) +(defmethod transparency-mask ((self image)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((pixel-pnt (transparency-pixel-of im)) - (hbmp (gfs:handle im)) + (let ((pixel-pnt (transparency-pixel-of self)) + (hbmp (gfs:handle self)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer))) (if pixel-pnt (progn (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (gfs::get-object (gfs:handle self) (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 (gfs:null-handle-p hmask) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Aug 10 00:15:08 2006 @@ -171,8 +171,8 @@ (flag BOOL) (hotspotx DWORD) (hotspoty DWORD) - (maskbm HANDLE) - (colorbm HANDLE)) + (hmask HANDLE) + (hcolor HANDLE)) (defctype iconinfo-pointer :pointer) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 00:15:08 2006 @@ -347,6 +347,12 @@ HANDLE) (defcfun + ("GetIconInfo" get-icon-info) + BOOL + (hicon HANDLE) + (iconinfo LPTR)) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT))

1 0

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

08 Aug '06

Author: junrue Date: Tue Aug 8 01:47:29 2006 New Revision: 202 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp Log: further work towards supporting icon display Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Aug 8 01:47:29 2006 @@ -2020,11 +2020,76 @@ @end deffn @end deftp +@anchor{icon-bundle} +@deftp Class icon-bundle +This class encapsulates a collection of Win32 icon handles. +Icons are used to decorate @ref{window} title bars, to represent +a file or application on the desktop, to represent an application +in the @code{<Alt><Tab>} task switching dialog, and in the +Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN +documentation for further discussion of standard icon sizes, color +depths and file format. @code{icon-bundle} derives from @ref{native-object}. +@deffn Initarg :file +This initarg accepts a @sc{cl:pathname} identifying a file +with @ref{image-data} to be loaded, as described for the @ref{image} +class @code{:file} initarg. Note that the @sc{.ico} format can +store multiple icons, all of which will be loaded. Since +@code{icon-bundle} needs a transparency mask for each image in +order to create Windows icons, a value may be supplied for the +@code{:transparency-pixel} initarg of this class to select the +proper transparency @ref{color}; by default, the pixel color at +@code{(0, 0)} in each image will be used. @emph{FIXME: link to +documentation of graphics plugins here}. +@end deffn +@deffn Initarg :images +This initarg accepts a @sc{cl:list} of image objects. Since +@code{icon-bundle} needs a transparency mask for each image in +order to create Windows icons, the application may either @sc{setf} +@ref{transparency-pixel} for each image ahead of time (especially +important when the pixel location is different from one image +to the next), or provide a value for the @code{:transparency-pixel} +initarg of this class; or else by default, the pixel color at +@code{(0, 0)} in each image will be used. +@end deffn +@deffn Initarg :system +This initarg causes the @code{icon-bundle} to be loaded with a +system-provided standard icon, identified by one of the following +constants: +@table @code +@item +application-icon+ +Default application icon. +@item +error-icon+ +Icon for error notifications. +@item +information-icon+ +Icon for informational notifications. +@item +question-icon+ +Icon to be used when prompting the user for more input. +@item +warning-icon+ +Icon for warning notifications. +@end table +@end deffn +@deffn Initarg :transparency-pixel +This initarg is similar in purpose to the same initarg for +the image class, except that in this case the specified @ref{point} +applies to all images (except pre-defined system icons) +encapsulated by the @code{icon-bundle} object. +@end deffn +@end deftp + @anchor{image} -@deftp Class image -This subclass of @ref{native-object} wraps a native image object. -Instances may be drawn directly via a graphics-context (see -@ref{draw-image}) or set as the content of a @ref{label} control. +@deftp Class image transparency-pixel +This subclass of @ref{native-object} wraps a Win32 bitmap handle. +Instances may be drawn using @ref{draw-image} or displayed within +certain @ref{control}s such as a @ref{label}. Images may originate +from a variety of formats. @emph{FIXME: link to documentation +of graphics plugins here}. +@table @var +@anchor{transparency-pixel} +@item transparency-pixel +This slot holds a @ref{point} that identifies a pixel within the +image whose color will be used by @ref{transparency-mask}. +@xref{with-image-transparency}. +@end table @deffn Initarg :file Supply a path to a file containing image data to be loaded. @end deffn @@ -2036,9 +2101,28 @@ @end deftp @anchor{image-data} -@deftp Class image-data -This subclass of @ref{native-object} maintains image attributes, -color, and pixel data. @xref{image}. +@deftp Class image-data data-plugin +This class represents an image in an external format. Such formats +may be loaded (via the @ref{load} method) and then converted to an +@ref{image} object by the @ref{data-object} @sc{setf} function.@*@* +@code{image-data} serves as an integration point between Graphic-Forms +and third-party graphics libraries such as ImageMagick. @emph{FIXME: +link to documentation of graphics plugins here}. +@table @var +@item data-plugin +This slot holds a subclass of @ref{image-data-plugin} encapsulating +format and functionality from a particular third-party graphics library. +Many of the features offered by @code{image-data} are delegated to +this plugin object. +@end table +@end deftp + +@anchor{image-data-plugin} +@deftp Class image-data-plugin +This is a base class for plugin objects that encapsulate third-party +library representations of images. @emph{FIXME: +link to documentation of graphics plugins here}. It derives from +@ref{native-object}. @end deftp @node graphics functions @@ -2053,6 +2137,7 @@ Returns a color object corresponding to the current background color. @end deffn +@anchor{data-object} @deffn GenericFunction data-object self &optional gc => object Returns the data structure representing the raw data form of the object. The @code{gc} argument must be supplied when calling this @@ -2261,6 +2346,7 @@ Returns a color object corresponding to the current foreground color. @end deffn +@anchor{load} @deffn GenericFunction load self path => list Certain graphics objects have a persistent representation, which may be deserialized with the appropriate implementation of this function. @@ -2296,8 +2382,16 @@ @end table @end deffn -@deffn GenericFunction transparency-mask self +@anchor{transparency-mask} +@deffn GenericFunction transparency-mask self => @ref{image} 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 + +@anchor{with-image-transparency} +@defmac with-image-transparency (image point) &body body +This macro wraps @var{body} in an @sc{unwind-protect} form with +@var{point} set as the @ref{transparency-pixel} for @var{image}. +Any existing point set in @var{image} is restored. +@end defmac Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Aug 8 01:47:29 2006 @@ -167,6 +167,15 @@ (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc (templname :string)) +(defcstruct iconinfo + (flag BOOL) + (hotspotx DWORD) + (hotspoty DWORD) + (maskbm HANDLE) + (colorbm HANDLE)) + +(defctype iconinfo-pointer :pointer) + (defcstruct initcommoncontrolsex (size DWORD) (icc DWORD)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Aug 8 01:47:29 2006 @@ -72,6 +72,11 @@ (ch UINT)) (defcfun + ("CreateIconIndirect" create-icon-indirect) + HANDLE + (iconinfo iconinfo-pointer)) + +(defcfun ("CreateMenu" create-menu) HANDLE) @@ -124,6 +129,11 @@ (lp LPARAM)) (defcfun + ("DestroyIcon" destroy-icon) + BOOL + (hicon HANDLE)) + +(defcfun ("DestroyMenu" destroy-menu) BOOL (hwnd HANDLE)) @@ -487,6 +497,12 @@ (name LPTR)) ; LPTR to make it easier to pass constants like +obm-checkboxes+ (defcfun + ("LoadIconA" load-icon) + HANDLE + (instance HANDLE) + (name LPCTSTR)) + +(defcfun ("LoadImageA" load-image) HANDLE (instance HANDLE)

1 0

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

07 Aug '06

Author: junrue Date: Mon Aug 7 12:14:19 2006 New Revision: 201 Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: refactored plugin loading to accomodate multiple-image formats Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Aug 7 12:14:19 2006 @@ -2261,12 +2261,24 @@ Returns a color object corresponding to the current foreground color. @end deffn -@deffn GenericFunction metrics self font -Returns a @ref{font-metrics} object describing key attributes of @code{font}. +@deffn GenericFunction load self path => list +Certain graphics objects have a persistent representation, which may +be deserialized with the appropriate implementation of this function. +@var{self} will be re-initialized with data loaded from @var{path}. +Certain serialized object formats (e.g., @sc{ico}) may actually +describe multiple instances. To facilitate such formats, @code{load} +returns @var{self} plus any additional instances in a @sc{list}, +ordered the same as they are read from @var{path}. @emph{Note:} +@sc{gfg:load} shadows @sc{cl:load}. @end deffn -@deffn GenericFunction size self -Returns a size object describing the dimensions of the object. +@deffn GenericFunction metrics self font => @ref{font-metrics} +Returns a font-metrics object describing key attributes of @var{font}, +where @var{self} is a @ref{graphics-context}. +@end deffn + +@deffn GenericFunction size self => @ref{size} +Returns a size object describing the dimensions of @var{self}. @end deffn @deffn GenericFunction text-extent self text &optional style tab-width Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Aug 7 12:14:19 2006 @@ -50,7 +50,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.3.0" + :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cells") Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Aug 7 12:14:19 2006 @@ -39,7 +39,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.3.0" + :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Aug 7 12:14:19 2006 @@ -90,6 +90,7 @@ (defclass image-data () ((data-plugin :reader data-plugin-of + :initarg :data-plugin :initform nil)) (:documentation "This class maintains image attributes, color, and pixel data.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Aug 7 12:14:19 2006 @@ -78,11 +78,11 @@ ;;; helper functions ;;; -(defun find-image-plugin (path) - (loop for acceptor in *image-plugins* - for plugin = (funcall acceptor path) - until plugin - finally (return plugin))) +(defun load-image-data (path) + (loop for loader in *image-plugins* + for data = (funcall loader path) + until data + finally (return data))) (defun image->data (hbmp) (declare (ignore hbmp))) #| @@ -193,14 +193,16 @@ ((typep path 'string) (namestring (merge-pathnames path))) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) - - (let ((plugin (data-plugin-of self))) - (unless plugin - (setf plugin (find-image-plugin path))) - (unless plugin + (let ((plugin (data-plugin-of self)) + (plugins nil)) + (if plugin + (setf plugins (load plugin path)) + (setf plugins (load-image-data path))) + (unless plugins (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path))) - (load plugin path) - (setf (slot-value self 'data-plugin) plugin))) + (setf (slot-value self 'data-plugin) (first plugins)) + (append (list self) (loop for p in (rest plugins) + collect (make-instance 'image-data :data-plugin p))))) (defmethod size ((self image-data)) (size (data-plugin-of self))) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Mon Aug 7 12:14:19 2006 @@ -45,22 +45,66 @@ (defmacro bitmap-pixel-row-length (width bit-count) `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) -(defun accepts-file-p (path) - (cond - ((parse-namestring path)) ; syntax check - ((typep path 'pathname) - (setf path (namestring path))) - (t - (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) - (let ((ext (pathname-type path))) -; (if (or (string-equal ext "ico") (string-equal ext "bmp")) - (if (string-equal ext "bmp") - (let ((plugin (make-instance 'default-data-plugin))) - (gfg:load plugin path) - plugin) - nil))) +(defun load-bmp-data (stream) + (let* ((header (read-value 'BITMAPFILEHEADER stream)) + (info (read-value 'BASE-BITMAPINFOHEADER stream)) + (data (make-instance 'default-data-plugin :handle info))) + (declare (ignore header)) + (unless (= (biCompression info) gfs::+bi-rgb+) + (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + + ;; load color table + ;; + (let ((used (biClrUsed info)) + (rgbs nil)) + (ecase (biBitCount info) + (1 + (setf rgbs (make-array 2))) + (4 + (if (or (= used 0) (= used 16)) + (setf rgbs (make-array 16)) + (setf rgbs (make-array used)))) + (8 + (if (or (= used 0) (= used 256)) + (setf rgbs (make-array 256)) + (setf rgbs (make-array used)))) + (16 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (24 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (32 + (unless (/= used 0) + (setf rgbs (make-array used))))) + (dotimes (i (length rgbs)) + (let ((quad (read-value 'RGBQUAD stream))) + (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) + :green (rgbGreen quad) + :blue (rgbBlue quad))))) + (setf (palette-of data) (gfg:make-palette :direct nil :table rgbs))) + + ;; load pixel bits + ;; + (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) + (setf (pixels-of data) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) + (read-sequence (pixels-of data) stream)) + + (list data))) + +(defun load-icon-data (stream) + (declare (ignore stream))) + +(defun loader (path) + (let* ((file-type (pathname-type path)) + (helper (cond + ((string-equal file-type "bmp") #'load-bmp-data) + ((string-equal file-type "ico") #'load-icon-data) + (t (return-from loader nil))))) + (with-open-file (stream path :element-type '(unsigned-byte 8)) + (funcall helper stream)))) -(push #'accepts-file-p gfg::*image-plugins*) +(push #'loader gfg::*image-plugins*) (defmethod gfg:data->image ((self default-data-plugin)) (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) @@ -99,55 +143,6 @@ (declare (ignore param)) (cffi:foreign-free bi-ptr)) -(defmethod gfg:load ((self default-data-plugin) path) - (with-open-file (in path :element-type '(unsigned-byte 8)) - (let ((header (read-value 'BITMAPFILEHEADER in)) - (info (read-value 'BASE-BITMAPINFOHEADER in))) - (declare (ignore header)) - (unless (= (biCompression info) gfs::+bi-rgb+) - (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) - - ;; load color table - ;; - (let ((used (biClrUsed info)) - (rgbs nil)) - (ecase (biBitCount info) - (1 - (setf rgbs (make-array 2))) - (4 - (if (or (= used 0) (= used 16)) - (setf rgbs (make-array 16)) - (setf rgbs (make-array used)))) - (8 - (if (or (= used 0) (= used 256)) - (setf rgbs (make-array 256)) - (setf rgbs (make-array used)))) - (16 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (24 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (32 - (unless (/= used 0) - (setf rgbs (make-array used))))) - (dotimes (i (length rgbs)) - (let ((quad (read-value 'RGBQUAD in))) - (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) - :green (rgbGreen quad) - :blue (rgbBlue quad))))) - (setf (palette-of self) (gfg:make-palette :direct nil :table rgbs))) - - ;; load pixel bits - ;; - (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) - (setf (pixels-of self) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) - (read-sequence (pixels-of self) in)) - - ;; complete load - ;; - (setf (slot-value self 'gfs:handle) info)))) - (defmethod gfg:size ((self default-data-plugin)) (let ((info (gfs:handle self))) (unless info Modified: trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Mon Aug 7 12:14:19 2006 @@ -138,3 +138,22 @@ (rgbGreen BYTE) (rgbRed BYTE) (rgbReserved BYTE))) + +;;; +;;; Win32 GDI Icon Formats +;;; + +(define-binary-class ICONDIR () + ((idReserved WORD) + (idType WORD) + (idCount WORD))) ; ICONDIRENTRY array read separately + +(define-binary-class ICONDIRENTRY () + ((ideWidth BYTE) + (ideHeight BYTE) + (ideColorCount BYTE) + (ideReserved BYTE) + (idePlanes WORD) + (ideBitCount WORD) + (ideBytesInRes DWORD) + (ideImageOffset DWORD))) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Mon Aug 7 12:14:19 2006 @@ -140,6 +140,20 @@ (floor quant 257)) ;;; +;;; translated from list.h +;;; + +(defcfun + ("GetFirstImageInList" get-first-image-in-list) + :pointer ;; Image* + (images :pointer)) ;; Image* + +(defcfun + ("GetNextImageInList" get-next-image-in-list) + :pointer ;; Image* + (images :pointer)) ;; Image* + +;;; ;;; translated from magick.h ;;; Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Mon Aug 7 12:14:19 2006 @@ -36,23 +36,23 @@ (defclass magick-data-plugin (gfg:image-data-plugin) () (:documentation "ImageMagick library plugin for the graphics package.")) -(defun accepts-file-p (path) +(defun loader (path) (unless *magick-initialized* (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) - (cond - ((parse-namestring path)) ; syntax check - ((typep path 'pathname) - (setf path (namestring path))) - (t - (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) (if (gethash (pathname-type path) gfg:*image-file-types*) - (let ((plugin (make-instance 'magick-data-plugin))) - (gfg:load plugin path) - plugin) + (with-image-path (path info ex) + (let ((images-ptr (read-image info ex))) + (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) + (error 'gfs:toolkit-error :detail (format nil + "exception reason: ~s" + (cffi:foreign-slot-value ex 'exception-info 'reason)))) + (loop for ptr = (get-next-image-in-list images-ptr) + until (cffi:null-pointer-p ptr) + collect (make-instance 'magic-data-plugin :handle ptr)))) nil)) -(push #'accepts-file-p gfg::*image-plugins*) +(push #'loader gfg::*image-plugins*) (defmethod gfg:data->image ((self magick-data-plugin)) (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) @@ -128,22 +128,6 @@ (destroy-image victim))) (setf (slot-value self 'gfs:handle) nil)) -(defmethod gfg:load ((self magick-data-plugin) path) - (let ((handle (gfs:handle self))) - (when (and handle (not (cffi:null-pointer-p handle))) - (destroy-image handle) - (setf (slot-value self 'gfs:handle) nil) - (setf handle nil)) - (with-image-path (path info ex) - (setf handle (read-image info ex)) - (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) - (error 'gfs:toolkit-error :detail (format nil - "exception reason: ~s" - (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 self 'gfs:handle) handle)))) - (defmethod gfg:size ((self magick-data-plugin)) (let ((handle (gfs:handle self)) (size (gfs:make-size)))

1 0

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

04 Aug '06

Author: junrue Date: Fri Aug 4 22:50:30 2006 New Revision: 200 Modified: trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-types.lisp Log: default graphics data plugin is now working for BMPs Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Aug 4 22:50:30 2006 @@ -193,6 +193,7 @@ #:make-color #:make-font-data #:make-image-data + #:make-palette #:matrix #:maximum-char-width #:metrics Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Fri Aug 4 22:50:30 2006 @@ -79,7 +79,10 @@ (green-shift 0) (blue-shift 0) (direct nil) - (table nil))) ; vector of COLOR structs + (table nil)) ; vector of COLOR structs + + (defmacro color-table (data) + `(gfg::palette-table ,data))) (defclass image-data-plugin (gfs:native-object) () (:documentation "Graphics library plugin implementation objects.")) @@ -151,9 +154,6 @@ (defmacro red-shift (data) `(gfg::palette-red-shift ,data)) -(defmacro color-table (data) - `(gfg::palette-table ,data)) - (defclass pattern (gfs:native-object) () (:documentation "This class represents a pattern to be used with a brush.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Fri Aug 4 22:50:30 2006 @@ -34,7 +34,9 @@ (in-package :graphic-forms.uitoolkit.graphics) (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *image-plugins* nil)) + (defvar *image-plugins* nil) + + (cffi:defctype bmp-pointer :pointer)) ;; ;; list the superset of file extensions for formats that any @@ -193,10 +195,8 @@ (error 'gfs:toolkit-error :detail "pathname or string required")))) (let ((plugin (data-plugin-of self))) - (when plugin - (gfs:dispose plugin) - (setf (slot-value self 'data-plugin) nil)) - (setf plugin (find-image-plugin path)) + (unless plugin + (setf plugin (find-image-plugin path))) (unless plugin (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path))) (load plugin path) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Fri Aug 4 22:50:30 2006 @@ -33,9 +33,18 @@ (in-package :graphic-forms.uitoolkit.graphics.default) -(defclass default-data-plugin (gfg:image-data-plugin) () +(defclass default-data-plugin (gfg:image-data-plugin) + ((palette + :accessor palette-of + :initform nil) + (pixels + :accessor pixels-of + :initform nil)) (:documentation "Default library plugin for the graphics package.")) +(defmacro bitmap-pixel-row-length (width bit-count) + `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) + (defun accepts-file-p (path) (cond ((parse-namestring path)) ; syntax check @@ -44,10 +53,146 @@ (t (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) (let ((ext (pathname-type path))) - (if (or (string-equal ext "ico") (string-equal ext "bmp")) +; (if (or (string-equal ext "ico") (string-equal ext "bmp")) + (if (string-equal ext "bmp") (let ((plugin (make-instance 'default-data-plugin))) (gfg:load plugin path) plugin) nil))) (push #'accepts-file-p gfg::*image-plugins*) + +(defmethod gfg:data->image ((self default-data-plugin)) + (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) + (hbmp (cffi:null-pointer))) + (unwind-protect + (cffi:with-foreign-object (pix-bits-ptr :pointer) + (setf hbmp (gfs::create-dib-section screen-dc + self + gfs::+dib-rgb-colors+ + pix-bits-ptr + (cffi:null-pointer) + 0)) + (if (gfs:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-dib-section failed")) + (let ((plugin-pixels (pixels-of self)) + (ptr (cffi:mem-ref pix-bits-ptr :pointer))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref ptr :uint8 i) (aref plugin-pixels i))))) + (gfs::release-dc (cffi:null-pointer) screen-dc)) + hbmp)) + +(defmethod gfg:depth ((self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (biBitCount info))) + +(defmethod gfs:dispose ((self default-data-plugin)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod cffi:free-translated-object (pixels-ptr (name (eql 'gfs::bitmap-pixels-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free pixels-ptr)) + +(defmethod cffi:free-translated-object (bi-ptr (name (eql 'gfs::bitmap-info-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free bi-ptr)) + +(defmethod gfg:load ((self default-data-plugin) path) + (with-open-file (in path :element-type '(unsigned-byte 8)) + (let ((header (read-value 'BITMAPFILEHEADER in)) + (info (read-value 'BASE-BITMAPINFOHEADER in))) + (declare (ignore header)) + (unless (= (biCompression info) gfs::+bi-rgb+) + (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + + ;; load color table + ;; + (let ((used (biClrUsed info)) + (rgbs nil)) + (ecase (biBitCount info) + (1 + (setf rgbs (make-array 2))) + (4 + (if (or (= used 0) (= used 16)) + (setf rgbs (make-array 16)) + (setf rgbs (make-array used)))) + (8 + (if (or (= used 0) (= used 256)) + (setf rgbs (make-array 256)) + (setf rgbs (make-array used)))) + (16 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (24 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (32 + (unless (/= used 0) + (setf rgbs (make-array used))))) + (dotimes (i (length rgbs)) + (let ((quad (read-value 'RGBQUAD in))) + (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) + :green (rgbGreen quad) + :blue (rgbBlue quad))))) + (setf (palette-of self) (gfg:make-palette :direct nil :table rgbs))) + + ;; load pixel bits + ;; + (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) + (setf (pixels-of self) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) + (read-sequence (pixels-of self) in)) + + ;; complete load + ;; + (setf (slot-value self 'gfs:handle) info)))) + +(defmethod gfg:size ((self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (gfs:make-size :width (biWidth info) :height (biHeight info)))) + +(defmethod (setf gfg:size) (size (self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (setf (biWidth info) (gfs:size-width size) + (biHeight info) (gfs:size-height size))) + size) + +(defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) + (name (eql 'gfs::bitmap-pixels-pointer))) + (let* ((plugin-pixels (pixels-of lisp-obj)) + (pixels-ptr (cffi:foreign-alloc :uint8 :count (length plugin-pixels)))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref pixels-ptr :uint8 i) (aref plugin-pixels i))) + pixels-ptr)) + +(defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) + (name (eql 'gfs::bitmapinfo-pointer))) + (let ((bi-ptr (cffi:foreign-alloc 'gfs::bitmapinfo))) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes gfs::bibitcount + gfs::bicompression gfs::bmicolors) + bi-ptr gfs::bitmapinfo) + (gfs::zero-mem bi-ptr gfs::bitmapinfo) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biplanes 1 + gfs::bibitcount (gfg:depth lisp-obj) + gfs::bicompression gfs::+bi-rgb+) + (let ((im-size (gfg:size lisp-obj))) + (setf gfs::biwidth (gfs:size-width im-size) + gfs::biheight (gfs:size-height im-size))) + (let ((colors (gfg:color-table (palette-of lisp-obj))) + (ptr (cffi:foreign-slot-pointer bi-ptr 'gfs::bitmapinfo 'gfs::bmicolors))) + (dotimes (i (length colors)) + (let ((clr (aref colors i))) + (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen + gfs::rgbred gfs::rgbreserved) + (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbblue (gfg:color-blue clr) + gfs::rgbgreen (gfg:color-green clr) + gfs::rgbred (gfg:color-red clr) + gfs::rgbreserved 0)))))) + bi-ptr)) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Fri Aug 4 22:50:30 2006 @@ -55,7 +55,6 @@ (push #'accepts-file-p gfg::*image-plugins*) (defmethod gfg:data->image ((self magick-data-plugin)) - "Convert the image-data object to a bitmap and return the native handle." (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth @@ -127,7 +126,7 @@ (let ((victim (gfs:handle self))) (unless (or (null victim) (cffi:null-pointer-p victim)) (destroy-image victim))) - (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) + (setf (slot-value self 'gfs:handle) nil)) (defmethod gfg:load ((self magick-data-plugin) path) (let ((handle (gfs:handle self))) @@ -176,4 +175,5 @@ 'reason)))) (setf (slot-value self 'gfs:handle) new-handle) (destroy-image handle)) - (destroy-exception-info ex)))) + (destroy-exception-info ex))) + size) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Aug 4 22:50:30 2006 @@ -117,7 +117,7 @@ (hdc HANDLE) (pheader LPTR) (option DWORD) - (pinit LPTR) + (pinit bitmap-pixels-pointer) (pbmp LPTR) (usage UINT)) @@ -125,7 +125,7 @@ ("CreateDIBSection" create-dib-section) HANDLE (hdc HANDLE) - (bmi LPTR) + (bmi bitmapinfo-pointer) (usage UINT) (values LPTR) ;; VOID ** (section HANDLE) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Aug 4 22:50:30 2006 @@ -114,6 +114,9 @@ (biclrimp DWORD) (bmicolors BYTE :count 1024)) ; allocate space for max palette (256 RGBQUADs) +(defctype bitmapinfo-pointer :pointer) +(defctype bitmap-pixels-pointer :pointer) + (defcstruct bitmapinfoheader (bisize DWORD) (biwidth LONG)

1 0

[graphic-forms-cvs] r199 - in trunk: . src/external-libraries src/external-libraries/practicals-1.0.3 src/external-libraries/practicals-1.0.3/Chapter08 src/external-libraries/practicals-1.0.3/Chapter24 src/uitoolkit/graphics src/uitoolkit/graphics/plugins src/uitoolkit/graphics/plugins/default
by junrue＠common-lisp.net 02 Aug '06

02 Aug '06

Author: junrue Date: Wed Aug 2 17:37:56 2006 New Revision: 199 Added: trunk/src/external-libraries/ trunk/src/external-libraries/practicals-1.0.3/ trunk/src/external-libraries/practicals-1.0.3/Chapter08/ trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter24/ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp trunk/src/external-libraries/practicals-1.0.3/LICENSE trunk/src/external-libraries/practicals-1.0.3/readme.txt trunk/src/uitoolkit/graphics/plugins/default/ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Modified: trunk/build.lisp trunk/config.lisp trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Log: initial work on default graphics data plugin Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Wed Aug 2 17:37:56 2006 @@ -44,14 +44,16 @@ (defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) (defvar *project-root* "c:/projects/public/") -(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) -(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/")) -(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) -(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) -(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) +(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/")) +(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) +(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) +(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) +(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) +(setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")) -(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) +(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Wed Aug 2 17:37:56 2006 @@ -39,16 +39,20 @@ (in-package #:graphic-forms-system) -(defvar *cells-dir* "cells/") -(defvar *cffi-dir* "cffi-060606/") -(defvar *closer-mop-dir* "closer-mop/") -(defvar *lw-compat-dir* "lw-compat/") -(defvar *gf-dir* "graphic-forms/") +(defvar *binary-data-dir* (merge-pathnames "src/external-libraries/practicals-1.0.3/binary-data/")) +(defvar *cells-dir* "cells/") +(defvar *cffi-dir* "cffi-060606/") +(defvar *closer-mop-dir* "closer-mop/") +(defvar *lw-compat-dir* "lw-compat/") +(defvar *macro-utilities-dir* "macro-utilities/") +(defvar *gf-dir* "graphic-forms/") -(defvar *lisp-unit-file* "lisp-unit") +(defvar *lisp-unit-file* "lisp-unit") (defun configure-asdf () - (pushnew *cells-dir* asdf:*central-registry* :test #'equal) - (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) - (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) - (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal)) + (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) + (pushnew *cells-dir* asdf:*central-registry* :test #'equal) + (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) + (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) + (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal) + (pushnew *macro-utilities-dir* asdf:*central-registry* :test #'equal)) Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Aug 2 17:37:56 2006 @@ -42,7 +42,7 @@ :version "0.3.0" :author "Jack D. Unrue" :licence "BSD" - :depends-on ("cffi" "lw-compat" "closer-mop") + :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") :components ((:module "src" :components @@ -82,14 +82,16 @@ (:module "plugins" :components ((:file "graphics-plugin-packages") -#+load-imagemagick-plugin - (:module "imagemagick" - ; :depends-on ("graphics") - :components - ((:file "magick-core-types") - (:file "magick-core-api") - (:file "magick-data-plugin" - :depends-on ("magick-core-types" "magick-core-api")))))))) +#-skip-default-plugin (:module "default" + :components + ((:file "file-formats") + (:file "default-data-plugin"))) +#+load-imagemagick-plugin (:module "imagemagick" + :components + ((:file "magick-core-types") + (:file "magick-core-api") + (:file "magick-data-plugin" + :depends-on ("magick-core-types" "magick-core-api")))))))) (:module "widgets" :depends-on ("graphics") :components Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,14 @@ +(defpackage :com.gigamonkeys.chapter-8-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.chapter-8-system) + +(defsystem chapter-8 + :name "chapter-8" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Code from Chapter 8 of Practical Common Lisp" + :long-description "" + :depends-on ("macro-utilities")) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,17 @@ +(defpackage :com.gigamonkeys.macro-utilities-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.macro-utilities-system) + +(defsystem macro-utilities + :name "macro-utilities" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Utilities for writing macros" + :long-description "" + :components + ((:file "packages") + (:file "macro-utilities" :depends-on ("packages"))) + :depends-on ()) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,28 @@ +(in-package :com.gigamonkeys.macro-utilities) + +(defmacro with-gensyms ((&rest names) &body body) + `(let ,(loop for n in names collect `(,n (make-symbol ,(string n)))) + ,@body)) + +(defmacro once-only ((&rest names) &body body) + (let ((gensyms (loop for n in names collect (gensym (string n))))) + `(let (,@(loop for g in gensyms collect `(,g (gensym)))) + `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) + ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) + ,@body))))) + +(defun spliceable (value) + (if value (list value))) + +(defmacro ppme (form &environment env) + (progn + (write (macroexpand-1 form env) + :length nil + :level nil + :circle nil + :pretty t + :gensym nil + :right-margin 83 + :case :downcase) + nil)) + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,11 @@ +(in-package :cl-user) + +(defpackage :com.gigamonkeys.macro-utilities + (:use :common-lisp) + (:export + :with-gensyms + :with-gensymed-defuns + :once-only + :spliceable + :ppme)) + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,17 @@ +(defpackage :com.gigamonkeys.binary-data-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.binary-data-system) + +(defsystem binary-data + :name "binary-data" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Parser for binary data files. " + :long-description "" + :components + ((:file "packages") + (:file "binary-data" :depends-on ("packages"))) + :depends-on (:macro-utilities)) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,160 @@ +(in-package :com.gigamonkeys.binary-data) + +(defvar *in-progress-objects* nil) + +(defconstant +null+ (code-char 0)) + +(defgeneric read-value (type stream &key) + (:documentation "Read a value of the given type from the stream.")) + +(defgeneric write-value (type stream value &key) + (:documentation "Write a value as the given type to the stream.")) + +(defgeneric read-object (object stream) + (:method-combination progn :most-specific-last) + (:documentation "Fill in the slots of object from stream.")) + +(defgeneric write-object (object stream) + (:method-combination progn :most-specific-last) + (:documentation "Write out the slots of object to the stream.")) + +(defmethod read-value ((type symbol) stream &key) + (let ((object (make-instance type))) + (read-object object stream) + object)) + +(defmethod write-value ((type symbol) stream value &key) + (assert (typep value type)) + (write-object value stream)) + + +;;; Binary types + +(defmacro define-binary-type (name (&rest args) &body spec) + (with-gensyms (type stream value) + `(progn + (defmethod read-value ((,type (eql ',name)) ,stream &key ,@args) + (declare (ignorable ,@args)) + ,(type-reader-body spec stream)) + (defmethod write-value ((,type (eql ',name)) ,stream ,value &key ,@args) + (declare (ignorable ,@args)) + ,(type-writer-body spec stream value))))) + +(defun type-reader-body (spec stream) + (ecase (length spec) + (1 (destructuring-bind (type &rest args) (mklist (first spec)) + `(read-value ',type ,stream ,@args))) + (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec)) + `(let ((,in ,stream)) ,@body))))) + +(defun type-writer-body (spec stream value) + (ecase (length spec) + (1 (destructuring-bind (type &rest args) (mklist (first spec)) + `(write-value ',type ,stream ,value ,@args))) + (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec)) + `(let ((,out ,stream) (,v ,value)) ,@body))))) + + +;;; Binary classes + +(defmacro define-generic-binary-class (name (&rest superclasses) slots read-method) + (with-gensyms (objectvar streamvar) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get ',name 'slots) ',(mapcar #'first slots)) + (setf (get ',name 'superclasses) ',superclasses)) + + (defclass ,name ,superclasses + ,(mapcar #'slot->defclass-slot slots)) + + ,read-method + + (defmethod write-object progn ((,objectvar ,name) ,streamvar) + (declare (ignorable ,streamvar)) + (with-slots ,(new-class-all-slots slots superclasses) ,objectvar + ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots)))))) + +(defmacro define-binary-class (name (&rest superclasses) slots) + (with-gensyms (objectvar streamvar) + `(define-generic-binary-class ,name ,superclasses ,slots + (defmethod read-object progn ((,objectvar ,name) ,streamvar) + (declare (ignorable ,streamvar)) + (with-slots ,(new-class-all-slots slots superclasses) ,objectvar + ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots)))))) + +(defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options) + (with-gensyms (typevar objectvar streamvar) + `(define-generic-binary-class ,name ,superclasses ,slots + (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key) + (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots) + (let ((,objectvar + (make-instance + ,@(or (cdr (assoc :dispatch options)) + (error "Must supply :disptach form.")) + ,@(mapcan #'slot->keyword-arg slots)))) + (read-object ,objectvar ,streamvar) + ,objectvar)))))) + +(defun as-keyword (sym) (intern (string sym) :keyword)) + +(defun normalize-slot-spec (spec) + (list (first spec) (mklist (second spec)))) + +(defun mklist (x) (if (listp x) x (list x))) + +(defun slot->defclass-slot (spec) + (let ((name (first spec))) + `(,name :initarg ,(as-keyword name) :accessor ,name))) + +(defun slot->read-value (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(setf ,name (read-value ',type ,stream ,@args)))) + +(defun slot->write-value (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(write-value ',type ,stream ,name ,@args))) + +(defun slot->binding (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(,name (read-value ',type ,stream ,@args)))) + +(defun slot->keyword-arg (spec) + (let ((name (first spec))) + `(,(as-keyword name) ,name))) + +;;; Keeping track of inherited slots + +(defun direct-slots (name) + (copy-list (get name 'slots))) + +(defun inherited-slots (name) + (loop for super in (get name 'superclasses) + nconc (direct-slots super) + nconc (inherited-slots super))) + +(defun all-slots (name) + (nconc (direct-slots name) (inherited-slots name))) + +(defun new-class-all-slots (slots superclasses) + "Like all slots but works while compiling a new class before slots +and superclasses have been saved." + (nconc (mapcan #'all-slots superclasses) (mapcar #'first slots))) + +;;; In progress Object stack + +(defun current-binary-object () + (first *in-progress-objects*)) + +(defun parent-of-type (type) + (find-if #'(lambda (x) (typep x type)) *in-progress-objects*)) + +(defmethod read-object :around (object stream) + (declare (ignore stream)) + (let ((*in-progress-objects* (cons object *in-progress-objects*))) + (call-next-method))) + +(defmethod write-object :around (object stream) + (declare (ignore stream)) + (let ((*in-progress-objects* (cons object *in-progress-objects*))) + (call-next-method))) + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,14 @@ +(defpackage :com.gigamonkeys.chapter-24-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.chapter-24-system) + +(defsystem chapter-24 + :name "chapter-24" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Code from Chapter 24 of Practical Common Lisp" + :long-description "" + :depends-on ("binary-data")) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,13 @@ +(in-package :cl-user) + +(defpackage :com.gigamonkeys.binary-data + (:use :common-lisp :com.gigamonkeys.macro-utilities) + (:export :define-binary-class + :define-tagged-binary-class + :define-binary-type + :read-value + :write-value + :*in-progress-objects* + :parent-of-type + :current-binary-object + :+null+)) Added: trunk/src/external-libraries/practicals-1.0.3/LICENSE ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/LICENSE Wed Aug 2 17:37:56 2006 @@ -0,0 +1,29 @@ +Copyright (c) 2005, Peter Seibel All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of the Peter Seibel 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 COPYRIGHT HOLDERS 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 DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR 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. Added: trunk/src/external-libraries/practicals-1.0.3/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/readme.txt Wed Aug 2 17:37:56 2006 @@ -0,0 +1,12 @@ +This directory contains a subset of the source code for +_Practical Common Lisp_ by Peter Seibel. The subset consists +of the code from two chapters of that book: Chapter 8 defining +a set of macro utilities that is needed by the binary file +input/output library featured in Chapter 24. + +The LICENSE file contains Peter Seibel's license statement +for this code. + +The complete distribution may be downloaded from: + + http://gigamonkeys.com/book/practicals-1.0.3.zip Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Wed Aug 2 17:37:56 2006 @@ -33,7 +33,8 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defvar *image-plugins* nil) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *image-plugins* nil)) ;; ;; list the superset of file extensions for formats that any Added: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,53 @@ +;;;; +;;;; default-data-plugin.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.graphics.default) + +(defclass default-data-plugin (gfg:image-data-plugin) () + (:documentation "Default library plugin for the graphics package.")) + +(defun accepts-file-p (path) + (cond + ((parse-namestring path)) ; syntax check + ((typep path 'pathname) + (setf path (namestring path))) + (t + (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) + (let ((ext (pathname-type path))) + (if (or (string-equal ext "ico") (string-equal ext "bmp")) + (let ((plugin (make-instance 'default-data-plugin))) + (gfg:load plugin path) + plugin) + nil))) + +(push #'accepts-file-p gfg::*image-plugins*) Added: trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,140 @@ +;;;; +;;;; file-formats.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.graphics.default) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :com.gigamonkeys.binary-data)) + +;;; +;;; fundamental binary types used by image definitions +;;; + +;; This utility was copied from Peter Seibel's id3v2 package, +;; renamed to signify that it is for big-endian values. +;; +(define-binary-type unsigned-integer-be (bytes bits-per-byte) + (:reader (in) + (loop with value = 0 + for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do + (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) + finally (return value))) + (:writer (out value) + (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte + do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) + +;; This utility is based on the same unsigned-integer binary type, +;; but this one is for little-endian types. +;; +(define-binary-type unsigned-integer-le (bytes bits-per-byte) + (:reader (in) + (loop with value = 0 + for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte do + (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) + finally (return value))) + (:writer (out value) + (loop for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte + do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) + +;;; aliases for single-byte and 32-bit types with names +;;; matching the GDI docs +;;; +(define-binary-type BYTE () (unsigned-integer-le :bytes 1 :bits-per-byte 8)) +(define-binary-type DWORD () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type FXPT2DOT30 () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type LONG () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type WORD () (unsigned-integer-le :bytes 2 :bits-per-byte 8)) + +;;; +;;; Win32 GDI Bitmap Formats +;;; + +(define-binary-class BITMAPFILEHEADER () + ((bfType WORD) + (bfSize DWORD) + (bfReserved1 WORD) + (bfReserved2 WORD) + (bfOffBits DWORD))) + +(define-binary-class CIEXYZ () + ((ciexyzX FXPT2DOT30) + (ciexyzY FXPT2DOT30) + (ciexyzZ FXPT2DOT30))) + +(define-binary-class CIEXYZTRIPLE () + ((ciexyzRed CIEXYZ) + (ciexyzGreen CIEXYZ) + (ciexyzBlue CIEXYZ))) + +(define-tagged-binary-class BASE-BITMAPINFOHEADER () + ((biSize DWORD) + (biWidth LONG) + (biHeight LONG) + (biPlanes WORD) + (biBitCount WORD) + (biCompression DWORD) + (biSizeImage DWORD) + (biXPelsPerMeter LONG) + (biYPelsPerMeter LONG) + (biClrUsed DWORD) + (biClrImportant DWORD)) + (:dispatch + (ecase biSize + (40 'BITMAPINFOHEADER) + (120 'BITMAPV4HEADER) + (124 'BITMAPV5HEADER)))) + +(define-binary-class BITMAPINFOHEADER (BASE-BITMAPINFOHEADER) ()) + +(define-binary-class BITMAPV4HEADER (BASE-BITMAPINFOHEADER) + ((bv4RedMask DWORD) + (bv4GreenMask DWORD) + (bv4BlueMask DWORD) + (bv4AlphaMask DWORD) + (bv4CSType DWORD) + (bv4Endpoints CIEXYZTRIPLE) + (bv4GammaRed DWORD) + (bv4GammaGreen DWORD) + (bv4GammaBlue DWORD))) + +(define-binary-class BITMAPV5HEADER (BITMAPV4HEADER) + ((bv5Intent DWORD) + (bv5ProfileData DWORD) + (bv5ProfileSize DWORD) + (bv5Reserved DWORD))) + +(define-binary-class RGBQUAD () + ((rgbBlue BYTE) + (rgbGreen BYTE) + (rgbRed BYTE) + (rgbReserved BYTE))) Modified: trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Wed Aug 2 17:37:56 2006 @@ -34,10 +34,10 @@ (in-package #:cl-user) ;;; -;;; package for base Win32 graphics plugin +;;; package for default Win32 graphics plugin ;;; -(defpackage #:graphic-forms.uitoolkit.graphics.win32 - (:nicknames #:gfgw32) +(defpackage #:graphic-forms.uitoolkit.graphics.default + (:nicknames #:gfgd) (:shadow #:load #:type) (:use #:common-lisp) (:export

1 0