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

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

27 Mar '06

Author: junrue Date: Sun Mar 26 23:52:47 2006 New Revision: 74 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp Log: implemented draw-arc, draw-chord, and draw-filled-chord graphics functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Mar 26 23:52:47 2006 @@ -797,11 +797,62 @@ Returns the bits-per-pixel depth of the object. @end deffn +@anchor{draw-arc} +@deffn GenericFunction draw-arc self rect start-pnt end-pnt +Draws an arc whose curve is formed by the ellipse bound by +@code{rect}, in a counter-clockwise direction from the point +@code{start-point} where it intersects a radial originating at the +center of the bounding rectangle. The arc ends at the point +@code{end-pnt} where it intersects another radial also originating at +the center of the rectangle. The shape is drawn using the current pen +style, pen width, and foreground color. If @code{start-pnt} and +@code{end-pnt} are the same, a complete ellipse is drawn. See also +@ref{draw-chord}. +@end deffn + +@anchor{draw-chord} +@deffn GenericFunction draw-chord self rect start-pnt end-pnt +Draws a closed shape comprised of: +@itemize @bullet +@item +an arc whose curve is formed by the ellipse bound by @code{rect}, in a +counter-clockwise direction from the point @code{start-point} where it +intersects a radial originating at the center of the bounding +rectangle. The arc ends at the point @code{end-pnt} where it +intersects another radial also originating at the center of the +rectangle. +@item +a line drawn between start-pnt and end-pnt +@end itemize +The shape is drawn using the current pen style, pen width and +foreground color. If @code{start-pnt} and @code{end-pnt} are the +same, a complete ellipse is drawn. See also @ref{draw-arc}. +@end deffn + +@anchor{draw-filled-chord} +@deffn GenericFunction draw-filled-chord self rect start-pnt end-pnt +Draws a closed shape comprised of: +@itemize @bullet +@item +an arc whose curve is formed by the ellipse bound by @code{rect}, in a +counter-clockwise direction from the point @code{start-point} where it +intersects a radial originating at the center of the bounding +rectangle. The arc ends at the point @code{end-pnt} where it +intersects another radial also originating at the center of the +rectangle. +@item +a line drawn between start-pnt and end-pnt +@end itemize +The shape is drawn using the current pen style, pen width and +foreground color and filled with the current background color. If +@code{start-pnt} and @code{end-pnt} are the same, a complete ellipse +is drawn. +@end deffn + @deffn GenericFunction draw-filled-rectangle self rect Fills the interior of a rectangle in the current background color. The current foreground color, pen width, and pen style will be used to -draw an outline for the rectangle. See also @ref{background-color}, -@ref{foreground-color}, @ref{pen-style}, and @ref{pen-width}. +draw an outline for the rectangle. @end deffn @deffn GenericFunction draw-image self im pnt @@ -810,8 +861,7 @@ @deffn GenericFunction draw-rectangle self rect Draws the outline of a rectangle in the current foreground color, -using the current pen width and style. See also @ref{background-color}, -@ref{pen-style} and @ref{pen-width}. +using the current pen width and style. @end deffn @deffn GenericFunction draw-text self text pnt Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 26 23:52:47 2006 @@ -132,7 +132,9 @@ #:depth #:descent #:draw-arc + #:draw-chord #:draw-filled-arc + #:draw-filled-chord #:draw-filled-oval #:draw-filled-polygon #:draw-filled-rectangle Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Mar 26 23:52:47 2006 @@ -35,6 +35,20 @@ (defvar *drawing-dispatcher* nil) (defvar *drawing-win* nil) +(defvar *last-checked-drawing-item* nil) + +(defun update-drawing-item-check (item) + (unless (null *last-checked-drawing-item*) + (gfw:check *last-checked-drawing-item* nil)) + (gfw:check item t)) + +(defun find-checked-item (disp menu time) + (declare (ignore disp time)) + (dotimes (i (gfw:item-count menu)) + (let ((item (gfw:item-at menu i))) + (when (gfw:checked-p item) + (setf *last-checked-drawing-item* item) + (return))))) (defun drawing-exit-fn (disp item time rect) (declare (ignore disp item time rect)) @@ -62,6 +76,91 @@ (unless (null func) (funcall func gc)))) +(defun draw-arcs (gc) + (let ((rect-pnt (gfs:make-point :x 15 :y 10)) + (rect-size (gfs:make-size :width 80 :height 65)) + (start-pnt (gfs:make-point :x 15 :y 60)) + (end-pnt (gfs:make-point :x 75 :y 25)) + (delta-x 0) + (delta-y 0)) + + (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) + (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (setf delta-x (+ (gfs:size-width rect-size) 10)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 1) + (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + + (setf (gfs:point-x rect-pnt) 15) + (setf (gfs:point-x start-pnt) 15) + (setf (gfs:point-x end-pnt) 75) + (setf delta-y (gfs:size-height rect-size)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-y pnt) delta-y)) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) + (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (setf delta-x (+ (gfs:size-width rect-size) 10)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:dot)) + (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + + (setf (gfs:point-x rect-pnt) 15) + (setf (gfs:point-x start-pnt) 15) + (setf (gfs:point-x end-pnt) 75) + (setf delta-y (gfs:size-height rect-size)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-y pnt) delta-y)) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) + (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:dot)) + (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt))) + +(defun select-arcs (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) + (gfw:redraw *drawing-win*)) + (defun draw-rects (gc) (let ((pnt (gfs:make-point :x 15 :y 15)) (size (gfs:make-size :width 80 :height 65))) @@ -79,7 +178,7 @@ (setf (gfg:pen-width gc) 1) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:foreground-color gc) gfg:*color-green*) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) (setf (gfs:point-x pnt) 15) @@ -101,17 +200,21 @@ (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)))) (defun select-rects (disp item time rect) - (declare (ignore disp item time rect)) + (declare (ignore disp time rect)) + (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) (defun run-drawing-tester-internal () + (setf *last-checked-drawing-item* nil) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'drawing-exit-fn))) (:item "&Tests" - :submenu ((:item "&Rectangles" :checked :callback #'select-rects))))))) + :callback #'find-checked-item + :submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs) + (:item "&Rectangles" :callback #'select-rects))))))) (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) - (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) + (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* :style '(:style-workspace))) (setf (gfw:menu-bar *drawing-win*) menubar) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 26 23:52:47 2006 @@ -125,6 +125,48 @@ (gfs::delete-dc (gfs:handle self))) (setf (slot-value self 'gfs:handle) nil)) +(defmethod draw-arc ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((rect-pnt (gfs:location rect)) + (rect-size (gfs:size rect))) + (if (zerop (gfs::arc (gfs:handle self) + (gfs:point-x rect-pnt) + (gfs:point-y rect-pnt) + (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size)) + (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size)) + (gfs:point-x start-pnt) + (gfs:point-y start-pnt) + (gfs:point-x end-pnt) + (gfs:point-y end-pnt))) + (error 'gfs:win32-error :detail "arc failed")))) + +(defmethod draw-chord ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let* ((hdc (gfs:handle self)) + (tmp-hbr (gfs::get-stock-object gfs::+null-brush+)) + (orig-hbr (gfs::select-object hdc tmp-hbr))) + (unwind-protect + (draw-filled-chord self rect start-pnt end-pnt) + (gfs::select-object hdc orig-hbr)))) + +(defmethod draw-filled-chord ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((rect-pnt (gfs:location rect)) + (rect-size (gfs:size rect))) + (if (zerop (gfs::chord (gfs:handle self) + (gfs:point-x rect-pnt) + (gfs:point-y rect-pnt) + (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size)) + (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size)) + (gfs:point-x start-pnt) + (gfs:point-y start-pnt) + (gfs:point-x end-pnt) + (gfs:point-y end-pnt))) + (error 'gfs:win32-error :detail "arc failed")))) + (defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 26 23:52:47 2006 @@ -60,10 +60,10 @@ (defgeneric depth (self) (:documentation "Returns the bits-per-pixel depth of the object.")) -(defgeneric draw-arc (self rect start-pnt end-pnt direction) +(defgeneric draw-arc (self rect start-pnt end-pnt) (:documentation "Draws the outline of an elliptical arc within the specified rectangular area.")) -(defgeneric draw-chord (self rect start-pnt end-pnt direction) +(defgeneric draw-chord (self rect start-pnt end-pnt) (:documentation "Draws a region bounded by the intersection of an ellipse and a line segment.")) (defgeneric draw-filled-chord (self rect start-pnt end-pnt) @@ -81,7 +81,7 @@ (defgeneric draw-filled-rounded-rectangle (self rect arc-width arc-height) (:documentation "Fills the interior of the rectangle with rounded corners in the current background color.")) -(defgeneric draw-filled-wedge (self rect start-pnt end-pnt direction) +(defgeneric draw-filled-wedge (self rect start-pnt end-pnt) (:documentation "Fills the interior of an elliptical arc within the rectangle in the current background color.")) (defgeneric draw-focus (self rect) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 26 23:52:47 2006 @@ -40,6 +40,19 @@ (load-foreign-library "msimg32.dll") (defcfun + ("Arc" arc) + BOOL + (hdc HANDLE) + (leftrect INT) + (toprect INT) + (rightrect INT) + (bottomrect INT) + (startx INT) + (starty INT) + (endx INT) + (endy INT)) + +(defcfun ("BitBlt" bit-blt) BOOL (hdc HANDLE) @@ -53,6 +66,19 @@ (rop DWORD)) (defcfun + ("Chord" chord) + BOOL + (hdc HANDLE) + (rectleft INT) + (recttop INT) + (rectright INT) + (rectbottom INT) + (radial1x INT) + (radial1y INT) + (radial2x INT) + (radial2y INT)) + +(defcfun ("CreateBitmap" create-bitmap) HANDLE (width INT) @@ -234,6 +260,12 @@ (hgdiobj HANDLE)) (defcfun + ("SetArcDirection" set-arc-direction) + INT + (hdc HANDLE) + (direction INT)) + +(defcfun ("SetBkColor" set-bk-color) COLORREF (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 Sun Mar 26 23:52:47 2006 @@ -36,6 +36,9 @@ (defconstant +button-classname+ "button") (defconstant +static-classname+ "static") +(defconstant +ad-counterclockwise+ 1) +(defconstant +ad-clockwise+ 2) + (defconstant +bi-rgb+ 0) (defconstant +bi-rle8+ 1) (defconstant +bi-rle4+ 2)

1 0

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

27 Mar '06

Author: junrue Date: Sun Mar 26 19:05:16 2006 New Revision: 73 Added: trunk/src/tests/uitoolkit/color-unit-tests.lisp trunk/src/tests/uitoolkit/graphics-context-unit-tests.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp Log: filled out pen-related slots and functions for graphics-context; implemented draw-rectangle function and started drawing tester program Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Mar 26 19:05:16 2006 @@ -699,6 +699,77 @@ This subclass of @ref{native-object} wraps a native device context, hence instances of this class are used to perform drawing operations. One normally obtains a graphics-context via @ref{event-paint}. +@anchor{miter-limit} +@deffn Accessor miter-limit +This accessor accepts or returns a floating point value that +describes the allowable ratio of miter length to line width, +which affects the behavior of the @code{:miter-join} pen style. +The miter length is the distance from the intersection of the +line walls on the inside of a join to the intersection of the +line walls on the outside of the same join. +The default value is @code{10.0}. +@end deffn +@anchor{pen-style} +@deffn Accessor pen-style +This accessor accepts or returns a list of pen style keywords. The +primary style keywords are: +@table @code +@item :alternate +Draws a line in which every other pixel is set. + +@item :dash +Draws a dashed line. + +@item :dashdot +Draws a line with alternating dashes and dots. + +@item :dashdotdot +Draws a line with alternating dashes and double dots. + +@item :dot +Draws a dotted line. + +@item :solid +Draws a solid line. +@end table + +One of the following end cap style keywords may also be specified: +@table @code +@item :flat-endcap +Line end caps will be flat. + +@item :round-endcap +Line end caps will be round. + +@item :square-endcap +Line end caps will be square. +@end table + +One of the following join style keywords may also be specified: +@table @code +@item :bevel-join +Line joins will be beveled. + +@item :miter-join +Line joins will be mitered if the ratio of miter length to line width +is within the @ref{miter-limit}. + +@item :round-join +Line joins will be rounded. +@end table + +The default pen style is equivalent to @code{(:flat :square-endcap +:round-bevel)}. + +Specifying @code{nil} for @code{pen-style} equates to selecting the +Win32 @sc{PS_NULL} pen style, meaning that the pen is invisible. +@end deffn +@anchor{pen-width} +@deffn Accessor pen-width +This accessor accepts or returns the pen width. The minimum allowed +value is 0, which translates to a 1 pixel-wide line drawn with an +optimized drawing algorithm. +@end deffn @end deftp @deftp Class image-data @@ -713,6 +784,7 @@ in future releases, they just aren't all documented or implemented at this time. +@anchor{background-color} @deffn GenericFunction background-color self Returns a color object corresponding to the current background color. @end deffn @@ -726,13 +798,22 @@ @end deffn @deffn GenericFunction draw-filled-rectangle self rect -Fills the interior of the rectangle in the current background color. +Fills the interior of a rectangle in the current background color. +The current foreground color, pen width, and pen style will be used to +draw an outline for the rectangle. See also @ref{background-color}, +@ref{foreground-color}, @ref{pen-style}, and @ref{pen-width}. @end deffn @deffn GenericFunction draw-image self im pnt Draws the given image in the receiver at the specified coordinates. @end deffn +@deffn GenericFunction draw-rectangle self rect +Draws the outline of a rectangle in the current foreground color, +using the current pen width and style. See also @ref{background-color}, +@ref{pen-style} and @ref{pen-width}. +@end deffn + @deffn GenericFunction draw-text self text pnt Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string. @@ -742,6 +823,7 @@ Returns the current font. @end deffn +@anchor{foreground-color} @deffn GenericFunction foreground-color self Returns a color object corresponding to the current foreground color. @end deffn Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Mar 26 19:05:16 2006 @@ -54,6 +54,8 @@ ((:module "uitoolkit" :components ((:file "mock-objects") + (:file "color-unit-tests") + (:file "graphics-context-unit-tests") (:file "image-unit-tests") (:file "layout-unit-tests") (:file "hello-world") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 26 19:05:16 2006 @@ -122,7 +122,7 @@ #:blue-shift #:clipped-p #:clipping-rectangle - #:color-as-rgb + #:color->rgb #:color-blue #:color-green #:color-red @@ -167,6 +167,8 @@ #:maximum-char-width #:metrics #:multiply + #:pen-style + #:pen-width #:red-mask #:red-shift #:rotate Added: trunk/src/tests/uitoolkit/color-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/color-unit-tests.lisp Sun Mar 26 19:05:16 2006 @@ -0,0 +1,45 @@ +;;;; +;;;; color-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) + +(define-test color-conversion-test + (let ((c1 (gfg:make-color)) + (c2 (gfg:make-color :red 12 :green 34 :blue 56)) + (c3 (gfg:make-color :red 255 :green 128 :blue 0)) + (c4 (gfg:make-color :red 255 :green 255 :blue 255))) + (loop for clr in (list c1 c2 c3 c4) + do (let ((rgb (gfg::color->rgb clr))) + (assert-equal (gfg:color-red clr) (gfg:color-red (gfg::rgb->color rgb))) + (assert-equal (gfg:color-green clr) (gfg:color-green (gfg::rgb->color rgb))) + (assert-equal (gfg:color-blue clr) (gfg:color-blue (gfg::rgb->color rgb))))))) Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Mar 26 19:05:16 2006 @@ -63,14 +63,42 @@ (funcall func gc)))) (defun draw-rects (gc) - (let ((pnt (gfs:make-point :x 10 :y 10)) + (let ((pnt (gfs:make-point :x 15 :y 15)) (size (gfs:make-size :width 80 :height 65))) + (setf (gfg:foreground-color gc) gfg:*color-blue*) (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 1) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) (setf (gfg:foreground-color gc) gfg:*color-green*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)))) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + + (setf (gfs:point-x pnt) 15) + (incf (gfs:point-y pnt) (+ (gfs:size-height size) 10)) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) + (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:dot)) + (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)))) (defun select-rects (disp item time rect) (declare (ignore disp item time rect)) @@ -88,6 +116,7 @@ :style '(:style-workspace))) (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") (gfw:show *drawing-win* t))) (defun run-drawing-tester () Added: trunk/src/tests/uitoolkit/graphics-context-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/graphics-context-unit-tests.lisp Sun Mar 26 19:05:16 2006 @@ -0,0 +1,66 @@ +;;;; +;;;; graphics-context-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) + +(define-test pen-styles-test + (let ((style1 nil) + (style2 '(:solid)) + (style3 '(:dash :flat-endcap)) + (style4 '(:dot :miter-join)) + (style5 '(:alternate :flat-endcap :bevel-join))) + (dotimes (width 3) + (assert-equal (logior gfs::+ps-cosmetic+ + gfs::+ps-null+) + (gfg::compute-pen-style style1 width) + (list style1 width)) + (assert-equal (logior (if (< width 2) gfs::+ps-cosmetic+ gfs::+ps-geometric+) + gfs::+ps-solid+) + (gfg::compute-pen-style style2 width) + (list style2 width)) + (assert-equal (logior gfs::+ps-geometric+ + gfs::+ps-dash+ + gfs::+ps-endcap-flat+) + (gfg::compute-pen-style style3 width) + (list style3 width)) + (assert-equal (logior gfs::+ps-geometric+ + gfs::+ps-dot+ + gfs::+ps-join-miter+) + (gfg::compute-pen-style style4 width) + (list style4 width)) + (assert-equal (logior gfs::+ps-geometric+ + gfs::+ps-alternate+ + gfs::+ps-endcap-flat+ + gfs::+ps-join-bevel+) + (gfg::compute-pen-style style5 width) + (list style5 width))))) Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Sun Mar 26 19:05:16 2006 @@ -34,13 +34,20 @@ (in-package :graphic-forms.uitoolkit.graphics) (eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro color-as-rgb (color) + (defmacro color->rgb (color) (let ((result (gensym))) `(let ((,result 0)) (setf (ldb (byte 8 0) ,result) (color-red ,color)) (setf (ldb (byte 8 8) ,result) (color-green ,color)) (setf (ldb (byte 8 16) ,result) (color-blue ,color)) - ,result)))) + ,result))) + + (defmacro rgb->color (colorref) + (let ((color (gensym))) + `(let ((,color (make-color :red (ldb (byte 8 0) ,colorref) + :green (ldb (byte 8 8) ,colorref) + :blue (ldb (byte 8 16) ,colorref)))) + ,color)))) (defvar *color-black* (make-color :red 0 :green 0 :blue 0)) (defvar *color-blue* (make-color :red 0 :green 0 :blue #xFF)) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Mar 26 19:05:16 2006 @@ -91,15 +91,18 @@ :initform gfs::+bs-solid+) (logbrush-color :accessor logbrush-color-of - :initform 0) ; initialize-instance sets this to black + :initform 0) (logbrush-hatch :accessor logbrush-hatch-of - :initform gfs::+hs-bdiagonal+) ; doesn't matter because +bs-solid+ is set + :initform gfs::+hs-bdiagonal+) + (miter-limit + :accessor miter-limit + :initform 10.0) (pen-style - :accessor pen-style-of - :initform (logior gfs::+ps-cosmetic+ gfs::+ps-solid+)) ; fast by default + :accessor pen-style + :initform '(:solid)) (pen-width - :accessor pen-width-of + :accessor pen-width :initform 1) (pen-handle :accessor pen-handle-of Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 26 19:05:16 2006 @@ -37,6 +37,44 @@ ;;; helper functions ;;; +(defun compute-pen-style (style width) + (let ((main-styles (list (cons :alternate gfs::+ps-alternate+) + (cons :dash gfs::+ps-dash+) + (cons :dashdotdot gfs::+ps-dashdotdot+) + (cons :dot gfs::+ps-dot+) + (cons :solid gfs::+ps-solid+))) + (endcap-styles (list (cons :flat-endcap gfs::+ps-endcap-flat+) + (cons :round-endcap gfs::+ps-endcap-round+) + (cons :square-endcap gfs::+ps-endcap-square+))) + (join-styles (list (cons :bevel-join gfs::+ps-join-bevel+) + (cons :miter-join gfs::+ps-join-miter+) + (cons :round-join gfs::+ps-join-round+))) + (native-style (if (> width 1) gfs::+ps-geometric+ gfs::+ps-cosmetic+)) + (tmp nil)) + (if (null style) + (return-from compute-pen-style (logior gfs::+ps-cosmetic+ gfs::+ps-null+))) + (setf tmp (intersection style (mapcar #'first main-styles))) + (if (/= (length tmp) 1) + (error 'gfs:toolkit-error :detail "one main pen style keyword is required")) + (setf native-style (logior native-style (cdr (assoc (car tmp) main-styles)))) + (setf tmp (intersection style (mapcar #'first endcap-styles))) + (if (> (length tmp) 1) + (error 'gfs:toolkit-error :detail "only one end cap pen style keyword is allowed")) + (setf native-style (logior native-style (if tmp + (cdr (assoc (car tmp) endcap-styles)) 0))) + (unless (null tmp) + (setf native-style (logior (logand native-style (lognot gfs::+ps-cosmetic+)) + gfs::+ps-geometric+))) + (setf tmp (intersection style (mapcar #'first join-styles))) + (if (> (length tmp) 1) + (error 'gfs:toolkit-error :detail "only one join pen style keyword is allowed")) + (setf native-style (logior native-style (if tmp + (cdr (assoc (car tmp) join-styles)) 0))) + (unless (null tmp) + (setf native-style (logior (logand native-style (lognot gfs::+ps-cosmetic+)) + gfs::+ps-geometric+))) + native-style)) + (defun update-pen-for-gc (gc) (cffi:with-foreign-object (lb-ptr 'gfs::logbrush) (cffi:with-foreign-slots ((gfs::style gfs::color gfs::hatch) lb-ptr gfs::logbrush) @@ -44,14 +82,15 @@ (setf gfs::color (logbrush-color-of gc)) (setf gfs::hatch (logbrush-hatch-of gc)) (let ((old-hpen (cffi:null-pointer)) - (new-hpen (gfs::ext-create-pen (pen-style-of gc) - (pen-width-of gc) + (new-hpen (gfs::ext-create-pen (compute-pen-style (pen-style gc) (pen-width gc)) + (pen-width gc) lb-ptr 0 (cffi:null-pointer)))) (if (gfs:null-handle-p new-hpen) (error 'gfs:win32-error :detail "ext-create-pen failed")) (setf (pen-handle-of gc) new-hpen) (setf old-hpen (gfs::select-object (gfs:handle gc) new-hpen)) + (gfs::set-miter-limit (gfs:handle gc) (miter-limit gc) (cffi:null-pointer)) (if (gfs:null-handle-p (orig-pen-handle-of gc)) (setf (orig-pen-handle-of gc) old-hpen) (unless (gfs:null-handle-p old-hpen) @@ -64,14 +103,14 @@ (defmethod background-color ((self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (gfs::get-bk-color (gfs:handle self))) + (rgb->color (gfs::get-bk-color (gfs:handle self)))) (defmethod (setf background-color) ((clr color) (self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((hdc (gfs:handle self)) (hbrush (gfs::get-stock-object gfs::+dc-brush+)) - (rgb (color-as-rgb clr))) + (rgb (color->rgb clr))) (gfs::select-object hdc hbrush) (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb))) @@ -157,8 +196,8 @@ (white (make-color :red #xFF :green #xFF :blue #xFF))) (gfs::select-object memdc hmask) (gfs::select-object memdc2 hcopy) - (gfs::set-bk-color memdc2 (color-as-rgb black)) - (gfs::set-text-color memdc2 (color-as-rgb white)) + (gfs::set-bk-color memdc2 (color->rgb black)) + (gfs::set-text-color memdc2 (color->rgb white)) (gfs::bit-blt memdc2 0 0 gfs::width @@ -217,12 +256,12 @@ (defmethod foreground-color ((self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (gfs::get-text-color (gfs:handle self))) + (rgb->color (gfs::get-text-color (gfs:handle self)))) (defmethod (setf foreground-color) ((clr color) (self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((rgb (color-as-rgb clr))) + (let ((rgb (color->rgb clr))) (gfs::set-text-color (gfs:handle self) rgb) (setf (logbrush-color-of self) rgb) (update-pen-for-gc self))) @@ -231,5 +270,16 @@ (when (null (gfs:handle self)) (setf (owns-dc self) t) (setf (slot-value self 'gfs:handle) (gfs::create-compatible-dc (cffi:null-pointer)))) - (setf (logbrush-color-of self) (color-as-rgb (make-color :red 0 :green 0 :blue 0))) + (update-pen-for-gc self)) + +(defmethod (setf pen-style) :around (style (self graphics-context)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (setf (slot-value self 'pen-style) style) + (update-pen-for-gc self)) + +(defmethod (setf pen-width) :around (width (self graphics-context)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (setf (slot-value self 'pen-width) width) (update-pen-for-gc self)) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 26 19:05:16 2006 @@ -33,155 +33,155 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defgeneric alpha (object) +(defgeneric alpha (self) (:documentation "Returns an integer representing an alpha value.")) -(defgeneric anti-alias (object) +(defgeneric anti-alias (self) (:documentation "Returns an int representing the current anti-alias setting.")) -(defgeneric background-color (object) +(defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) -(defgeneric background-pattern (object) +(defgeneric background-pattern (self) (:documentation "Returns a pattern object representing the current background pattern.")) -(defgeneric clipped-p (object) +(defgeneric clipped-p (self) (:documentation "Returns T if a clipping region is set; nil otherwise.")) -(defgeneric clipping-rectangle (object) +(defgeneric clipping-rectangle (self) (:documentation "Returns a rectangle object representing the current clipping rectangle.")) -(defgeneric copy-area (object src-rect dest-pnt) +(defgeneric copy-area (self src-rect dest-pnt) (:documentation "Copies a rectangular area of the source onto the destination.")) -(defgeneric data-obj (object) +(defgeneric data-obj (self) (:documentation "Returns the data structure representing the raw form of the object.")) -(defgeneric depth (object) +(defgeneric depth (self) (:documentation "Returns the bits-per-pixel depth of the object.")) -(defgeneric draw-arc (object rect start-pnt end-pnt direction) +(defgeneric draw-arc (self rect start-pnt end-pnt direction) (:documentation "Draws the outline of an elliptical arc within the specified rectangular area.")) -(defgeneric draw-chord (object rect start-pnt end-pnt direction) +(defgeneric draw-chord (self rect start-pnt end-pnt direction) (:documentation "Draws a region bounded by the intersection of an ellipse and a line segment.")) -(defgeneric draw-filled-wedge (object rect start-pnt end-pnt direction) - (:documentation "Fills the interior of an elliptical arc within the rectangle in the current background color.")) - -(defgeneric draw-filled-chord (object rect start-pnt end-pnt) +(defgeneric draw-filled-chord (self rect start-pnt end-pnt) (:documentation "Fills a region bounded by the intersection of an ellipse and a line segment.")) -(defgeneric draw-filled-oval (object rect) +(defgeneric draw-filled-oval (self rect) (:documentation "Fills the interior of the oval defined by a rectangle in the current background color.")) -(defgeneric draw-filled-polygon (object points) +(defgeneric draw-filled-polygon (self points) (:documentation "Fills the interior of the closed polygon defined by points in the current background color.")) -(defgeneric draw-filled-rectangle (object rect) - (:documentation "Fills the interior of the rectangle in the current background color.")) +(defgeneric draw-filled-rectangle (self rect) + (:documentation "Fills the interior of a rectangle in the current background color.")) -(defgeneric draw-filled-rounded-rectangle (object rect arc-width arc-height) +(defgeneric draw-filled-rounded-rectangle (self rect arc-width arc-height) (:documentation "Fills the interior of the rectangle with rounded corners in the current background color.")) -(defgeneric draw-focus (object rect) +(defgeneric draw-filled-wedge (self rect start-pnt end-pnt direction) + (:documentation "Fills the interior of an elliptical arc within the rectangle in the current background color.")) + +(defgeneric draw-focus (self rect) (:documentation "Draws a rectangle having the appearance of a focus rectangle.")) -(defgeneric draw-image (object im pnt) +(defgeneric draw-image (self im pnt) (:documentation "Draws the given image in the receiver at the specified coordinates.")) -(defgeneric draw-line (object pnt-1 pnt-2) +(defgeneric draw-line (self pnt-1 pnt-2) (:documentation "Draws a line using the foreground color between (x1, y1) and (x2, y2).")) -(defgeneric draw-oval (object rect) +(defgeneric draw-oval (self rect) (:documentation "Draws the outline of an oval in the foreground color with the specified rectangular area.")) -(defgeneric draw-point (object pnt) +(defgeneric draw-point (self pnt) (:documentation "Draws a pixel in the foreground color at the specified point.")) -(defgeneric draw-polygon (object points) +(defgeneric draw-polygon (self points) (:documentation "Draws the closed polygon defined by the list of points in the current foreground color.")) -(defgeneric draw-polyline (object points) +(defgeneric draw-polyline (self points) (:documentation "Draws the polyline defined by the list of points in the current foreground color.")) -(defgeneric draw-rectangle (object rect) - (:documentation "Draws the outline of the rectangle in the current foreground color.")) +(defgeneric draw-rectangle (self rect) + (:documentation "Draws the outline of a rectangle in the current foreground color.")) -(defgeneric draw-rounded-rectangle (object rect arc-width arc-height) +(defgeneric draw-rounded-rectangle (self rect arc-width arc-height) (:documentation "Draws the outline of the rectangle with rounded corners in the current foreground color.")) -(defgeneric draw-text (object text pnt) +(defgeneric draw-text (self text pnt) (:documentation "Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string.")) -(defgeneric fill-rule (object) +(defgeneric fill-rule (self) (:documentation "Returns an integer specifying the current fill rule.")) -(defgeneric font (object) +(defgeneric font (self) (:documentation "Returns the current font.")) -(defgeneric foreground-color (object) +(defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) -(defgeneric foreground-pattern (object) +(defgeneric foreground-pattern (self) (:documentation "Returns a pattern object representing the current foreground pattern.")) -(defgeneric invert (object) +(defgeneric invert (self) (:documentation "Returns a modified version of the object which is the mathematical inverse of the original.")) -(defgeneric line-cap-style (object) +(defgeneric line-cap-style (self) (:documentation "Returns an integer representing the line cap style.")) -(defgeneric line-dash-style (object) +(defgeneric line-dash-style (self) (:documentation "Returns a list of integers representing the line dash style.")) -(defgeneric line-join-style (object) +(defgeneric line-join-style (self) (:documentation "Returns an integer representing the line join style.")) -(defgeneric line-style (object) +(defgeneric line-style (self) (:documentation "Returns an integer representing the line style.")) -(defgeneric line-width (object) +(defgeneric line-width (self) (:documentation "Returns an integer representing the line width.")) -(defgeneric load (object path) +(defgeneric load (self path) (:documentation "Loads the object from filesystem data identified by the specified pathname or string.")) -(defgeneric matrix (object) +(defgeneric matrix (self) (:documentation "Returns a matrix that represents the transformation or other computation represented by the object.")) -(defgeneric metrics (object) +(defgeneric metrics (self) (:documentation "Returns a metrics object describing key attributes of the specified object.")) -(defgeneric multiply (object other) +(defgeneric multiply (self other) (:documentation "Returns a modified version of the object which is the result of multiplying the original with the other parameter.")) -(defgeneric rotate (object angle) +(defgeneric rotate (self angle) (:documentation "Returns a modified version of the object which is the result of rotating the original by the specified angle.")) -(defgeneric scale (object delta-x delta-y) +(defgeneric scale (self delta-x delta-y) (:documentation "Returns a modified version of the object which is the result of scaling the original by the specified mathematical vector.")) -(defgeneric size (object) +(defgeneric size (self) (:documentation "Returns a size object describing the size of the object.")) -(defgeneric text-anti-alias (object) +(defgeneric text-anti-alias (self) (:documentation "Returns an integer representing the text anti-alias setting.")) -(defgeneric text-extent (object str) +(defgeneric text-extent (self str) (:documentation "Returns the size of the rectangular area that would be covered by the string if drawn in the current font.")) -(defgeneric transform (object) +(defgeneric transform (self) (:documentation "Returns a transform object indicating how coordinates are transformed in the context of this object.")) -(defgeneric transform-coordinates (object pnts) +(defgeneric transform-coordinates (self pnts) (:documentation "Returns a list of point objects that are the result of applying a transformation against the specified list of points.")) -(defgeneric translate (object delta-x delta-y) +(defgeneric translate (self delta-x delta-y) (:documentation "Returns a modified version of the object which is the result of translating the original by the specified mathematical vector.")) -(defgeneric transparency-mask (object) +(defgeneric transparency-mask (self) (:documentation "Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency.")) -(defgeneric xor-mode-p (object) +(defgeneric xor-mode-p (self) (:documentation "Returns T if colors are combined in XOR mode; nil otherwise.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 26 19:05:16 2006 @@ -263,6 +263,13 @@ (color-use UINT)) (defcfun + ("SetMiterLimit" set-miter-limit) + BOOL + (hdc HANDLE) + (newlimit :float) + (oldlimit LPTR)) + +(defcfun ("SetTextColor" set-text-color) COLORREF (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 Sun Mar 26 19:05:16 2006 @@ -412,18 +412,18 @@ (defconstant +ps-insideframe+ 6) (defconstant +ps-userstyle+ 7) (defconstant +ps-alternate+ 8) -(defconstant +ps-style_mask+ #x0000000f) -(defconstant +ps-endcap_round+ #x00000000) -(defconstant +ps-endcap_square+ #x00000100) -(defconstant +ps-endcap_flat+ #x00000200) -(defconstant +ps-endcap_mask+ #x00000f00) -(defconstant +ps-join_round+ #x00000000) -(defconstant +ps-join_bevel+ #x00001000) -(defconstant +ps-join_miter+ #x00002000) -(defconstant +ps-join_mask+ #x0000f000) +(defconstant +ps-style-mask+ #x0000000f) +(defconstant +ps-endcap-round+ #x00000000) +(defconstant +ps-endcap-square+ #x00000100) +(defconstant +ps-endcap-flat+ #x00000200) +(defconstant +ps-endcap-mask+ #x00000f00) +(defconstant +ps-join-round+ #x00000000) +(defconstant +ps-join-bevel+ #x00001000) +(defconstant +ps-join-miter+ #x00002000) +(defconstant +ps-join-mask+ #x0000f000) (defconstant +ps-cosmetic+ #x00000000) (defconstant +ps-geometric+ #x00010000) -(defconstant +ps-type_mask+ #x000f0000) +(defconstant +ps-type-mask+ #x000f0000) (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1)

1 0

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

25 Mar '06

Author: junrue Date: Fri Mar 24 23:23:24 2006 New Revision: 72 Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/event.lisp Log: overhauled graphics-context to make use of ExtCreatePen for all pen attribute settings; updated wm-paint process-message accordingly Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Fri Mar 24 23:23:24 2006 @@ -52,18 +52,25 @@ (drawing-exit-fn self nil nil 0)) (defmethod gfw:event-paint ((self drawing-win-events) window time gc rect) - (declare (ignore window time)) + (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc rect) + (setf (gfg:foreground-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc + (make-instance 'gfs:rectangle :location (gfs:make-point) + :size (gfw:client-size window))) (let ((func (draw-func-of self))) (unless (null func) (funcall func gc)))) (defun draw-rects (gc) - (setf (gfg:background-color gc) gfg:*color-blue*) - (gfg:draw-filled-rectangle gc - (make-instance 'gfs:rectangle :location (gfs:make-point :x 10 :y 10) - :size (gfs:make-size :width 100 :height 75)))) + (let ((pnt (gfs:make-point :x 10 :y 10)) + (size (gfs:make-size :width 80 :height 65))) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:background-color gc) gfg:*color-green*) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:foreground-color gc) gfg:*color-green*) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)))) (defun select-rects (disp item time rect) (declare (ignore disp item time rect)) @@ -80,6 +87,7 @@ (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* :style '(:style-workspace))) (setf (gfw:menu-bar *drawing-win*) menubar) + (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (gfw:show *drawing-win* t))) (defun run-drawing-tester () Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Fri Mar 24 23:23:24 2006 @@ -47,6 +47,7 @@ (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-white*) + (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect) (setf (gfg:background-color gc) gfg:*color-red*) (setf (gfg:foreground-color gc) gfg:*color-green*) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 24 23:23:24 2006 @@ -54,6 +54,7 @@ (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-white*) + (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect)) (defclass test-mini-events (test-win-events) ()) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Fri Mar 24 23:23:24 2006 @@ -82,7 +82,31 @@ (defclass font (gfs:native-object) () (:documentation "This class encapsulates a realized native font.")) -(defclass graphics-context (gfs:native-object) () +(defclass graphics-context (gfs:native-object) + ((owns-dc + :accessor owns-dc + :initform nil) + (logbrush-style + :accessor logbrush-style-of + :initform gfs::+bs-solid+) + (logbrush-color + :accessor logbrush-color-of + :initform 0) ; initialize-instance sets this to black + (logbrush-hatch + :accessor logbrush-hatch-of + :initform gfs::+hs-bdiagonal+) ; doesn't matter because +bs-solid+ is set + (pen-style + :accessor pen-style-of + :initform (logior gfs::+ps-cosmetic+ gfs::+ps-solid+)) ; fast by default + (pen-width + :accessor pen-width-of + :initform 1) + (pen-handle + :accessor pen-handle-of + :initform (cffi:null-pointer)) + (orig-pen-handle + :accessor orig-pen-handle-of + :initform (cffi:null-pointer))) (:documentation "This class represents the context associated with drawing primitives.")) (defclass image (gfs:native-object) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Fri Mar 24 23:23:24 2006 @@ -37,33 +37,85 @@ ;;; helper functions ;;; +(defun update-pen-for-gc (gc) + (cffi:with-foreign-object (lb-ptr 'gfs::logbrush) + (cffi:with-foreign-slots ((gfs::style gfs::color gfs::hatch) lb-ptr gfs::logbrush) + (setf gfs::style (logbrush-style-of gc)) + (setf gfs::color (logbrush-color-of gc)) + (setf gfs::hatch (logbrush-hatch-of gc)) + (let ((old-hpen (cffi:null-pointer)) + (new-hpen (gfs::ext-create-pen (pen-style-of gc) + (pen-width-of gc) + lb-ptr 0 + (cffi:null-pointer)))) + (if (gfs:null-handle-p new-hpen) + (error 'gfs:win32-error :detail "ext-create-pen failed")) + (setf (pen-handle-of gc) new-hpen) + (setf old-hpen (gfs::select-object (gfs:handle gc) new-hpen)) + (if (gfs:null-handle-p (orig-pen-handle-of gc)) + (setf (orig-pen-handle-of gc) old-hpen) + (unless (gfs:null-handle-p old-hpen) + (gfs::delete-object old-hpen))))))) + ;;; ;;; methods ;;; -(defmethod gfs:dispose ((gc graphics-context)) - (gfs::delete-dc (gfs:handle gc)) - (setf (slot-value gc 'gfs:handle) nil)) - -(defmethod background-color ((gc graphics-context)) - (if (gfs:disposed-p gc) +(defmethod background-color ((self graphics-context)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (gfs::get-bk-color (gfs:handle gc))) + (gfs::get-bk-color (gfs:handle self))) -(defmethod (setf background-color) ((clr color) (gc graphics-context)) - (if (gfs:disposed-p gc) +(defmethod (setf background-color) ((clr color) (self graphics-context)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((hdc (gfs:handle gc)) + (let ((hdc (gfs:handle self)) (hbrush (gfs::get-stock-object gfs::+dc-brush+)) (rgb (color-as-rgb clr))) (gfs::select-object hdc hbrush) (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb))) -(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfs:rectangle)) - (if (gfs:disposed-p gc) +(defmethod gfs:dispose ((self graphics-context)) + (unless (gfs:null-handle-p (orig-pen-handle-of self)) + (gfs::select-object (gfs:handle self) (orig-pen-handle-of self))) + (setf (orig-pen-handle-of self) nil) + (gfs::delete-object (pen-handle-of self)) + (setf (pen-handle-of self) nil) + (if (owns-dc self) + (gfs::delete-dc (gfs:handle self))) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((hdc (gfs:handle gc)) + (let ((hdc (gfs:handle self)) + (pnt (gfs:location rect)) + (size (gfs:size rect))) + (gfs::rectangle hdc + (gfs:point-x pnt) + (gfs:point-y pnt) + (+ (gfs:point-x pnt) (gfs:size-width size)) + (+ (gfs:point-y pnt) (gfs:size-height size))))) + +(defmethod draw-rectangle ((self graphics-context) (rect gfs:rectangle)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let* ((hdc (gfs:handle self)) + (tmp-hbr (gfs::get-stock-object gfs::+null-brush+)) + (orig-hbr (gfs::select-object hdc tmp-hbr))) + (unwind-protect + (draw-filled-rectangle self rect) + (gfs::select-object hdc orig-hbr)))) + +;;; FIXME: consider preserving this version as a "fast path" +;;; rectangle filler. +;;; +#| +(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((hdc (gfs:handle self)) (pnt (gfs:location rect)) (size (gfs:size rect))) (cffi:with-foreign-object (rect-ptr 'gfs::rect) @@ -81,16 +133,17 @@ "" 0 (cffi:null-pointer)))))) +|# ;;; ;;; TODO: support addressing elements within bitmap as if it were an array ;;; -(defmethod draw-image ((gc graphics-context) (im image) (pnt gfs:point)) - (if (gfs:disposed-p gc) +(defmethod draw-image ((self graphics-context) (im image) (pnt gfs:point)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (if (gfs:disposed-p im) (error 'gfs:disposed-error)) - (let ((gc-dc (gfs:handle gc)) + (let ((gc-dc (gfs:handle self)) (himage (gfs:handle im)) (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) @@ -137,21 +190,21 @@ 0 0 gfs::+blt-srccopy+))))) (gfs::delete-dc memdc))) -(defmethod draw-text ((gc graphics-context) text (pnt gfs:point)) - (if (gfs:disposed-p gc) +(defmethod draw-text ((self graphics-context) text (pnt gfs:point)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (cffi:with-foreign-object (rect-ptr 'gfs::rect) (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) rect-ptr gfs::rect) (setf gfs::left (gfs:point-x pnt)) (setf gfs::top (gfs:point-y pnt)) - (gfs::draw-text (gfs:handle gc) + (gfs::draw-text (gfs:handle self) text -1 rect-ptr (logior gfs::+dt-calcrect+ gfs::+dt-singleline+) (cffi:null-pointer)) - (gfs::draw-text (gfs:handle gc) + (gfs::draw-text (gfs:handle self) text (length text) rect-ptr @@ -161,17 +214,22 @@ gfs::+dt-vcenter+) (cffi:null-pointer))))) -(defmethod foreground-color ((gc graphics-context)) - (if (gfs:disposed-p gc) +(defmethod foreground-color ((self graphics-context)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (gfs::get-text-color (gfs:handle gc))) + (gfs::get-text-color (gfs:handle self))) -(defmethod (setf foreground-color) ((clr color) (gc graphics-context)) - (if (gfs:disposed-p gc) +(defmethod (setf foreground-color) ((clr color) (self graphics-context)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((hdc (gfs:handle gc)) - (hpen (gfs::get-stock-object gfs::+dc-pen+)) - (rgb (color-as-rgb clr))) - (gfs::select-object hdc hpen) - (gfs::set-dc-pen-color hdc rgb) - (gfs::set-text-color hdc rgb))) + (let ((rgb (color-as-rgb clr))) + (gfs::set-text-color (gfs:handle self) rgb) + (setf (logbrush-color-of self) rgb) + (update-pen-for-gc self))) + +(defmethod initialize-instance :after ((self graphics-context) &key) + (when (null (gfs:handle self)) + (setf (owns-dc self) t) + (setf (slot-value self 'gfs:handle) (gfs::create-compatible-dc (cffi:null-pointer)))) + (setf (logbrush-color-of self) (color-as-rgb (make-color :red 0 :green 0 :blue 0))) + (update-pen-for-gc self)) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Mar 24 23:23:24 2006 @@ -99,6 +99,13 @@ (offset DWORD)) (defcfun + ("CreatePen" create-pen) + HANDLE + (style INT) + (width INT) + (color COLORREF)) + +(defcfun ("DeleteDC" delete-dc) BOOL (hdc HANDLE)) @@ -119,6 +126,15 @@ (params LPTR)) (defcfun + ("ExtCreatePen" ext-create-pen) + HANDLE + (style DWORD) + (width DWORD) + (logbrush LPTR) + (count DWORD) + (stylearray LPTR)) + +(defcfun ("ExtTextOutA" ext-text-out) BOOL (hdc HANDLE) @@ -203,6 +219,15 @@ (rop DWORD)) (defcfun + ("Rectangle" rectangle) + BOOL + (hdc HANDLE) + (x1 INT) + (y1 INT) + (x2 INT) + (y2 INT)) + +(defcfun ("SelectObject" select-object) HANDLE (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 Fri Mar 24 23:23:24 2006 @@ -61,6 +61,18 @@ (defconstant +blt-captureblt+ #x40000000) (defconstant +blt-nomirrorbitmap+ #x80000000) +(defconstant +bs-solid+ 0) +(defconstant +bs-null+ 1) +(defconstant +bs-hollow+ 1) +(defconstant +bs-hatched+ 2) +(defconstant +bs-pattern+ 3) +(defconstant +bs-indexed+ 4) +(defconstant +bs-dibpattern+ 5) +(defconstant +bs-dibpatternpt+ 6) +(defconstant +bs-pattern8x8+ 7) +(defconstant +bs-dibpattern8x8+ 8) +(defconstant +bs-monopattern+ 9) + (defconstant +bs-pushbutton+ #x00000000) (defconstant +bs-defpushbutton+ #x00000001) (defconstant +bs-checkbox+ #x00000002) @@ -208,6 +220,13 @@ (defconstant +gwl-exstyle+ -20) (defconstant +gwl-userdata+ -21) +(defconstant +hs-horizontal+ 0) +(defconstant +hs-vertical+ 1) +(defconstant +hs-fdiagonal+ 2) +(defconstant +hs-bdiagonal+ 3) +(defconstant +hs-cross+ 4) +(defconstant +hs-diagcross+ 5) + (defconstant +image-bitmap+ 0) (defconstant +image-icon+ 1) (defconstant +image-cursor+ 2) @@ -384,6 +403,28 @@ (defconstant +pm-qs-paint+ (ash +qs-paint+ 16)) (defconstant +pm-qs-sendmessage+ (ash +qs-sendmessage+ 16)) +(defconstant +ps-solid+ 0) +(defconstant +ps-dash+ 1) +(defconstant +ps-dot+ 2) +(defconstant +ps-dashdot+ 3) +(defconstant +ps-dashdotdot+ 4) +(defconstant +ps-null+ 5) +(defconstant +ps-insideframe+ 6) +(defconstant +ps-userstyle+ 7) +(defconstant +ps-alternate+ 8) +(defconstant +ps-style_mask+ #x0000000f) +(defconstant +ps-endcap_round+ #x00000000) +(defconstant +ps-endcap_square+ #x00000100) +(defconstant +ps-endcap_flat+ #x00000200) +(defconstant +ps-endcap_mask+ #x00000f00) +(defconstant +ps-join_round+ #x00000000) +(defconstant +ps-join_bevel+ #x00001000) +(defconstant +ps-join_miter+ #x00002000) +(defconstant +ps-join_mask+ #x0000f000) +(defconstant +ps-cosmetic+ #x00000000) +(defconstant +ps-geometric+ #x00010000) +(defconstant +ps-type_mask+ #x000f0000) + (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1) (defconstant +size-maximized+ 2) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Mar 24 23:23:24 2006 @@ -114,6 +114,11 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct logbrush + (style UINT) + (color COLORREF) + (hatch LONG)) + (defcstruct menuinfo (cbsize DWORD) (mask DWORD) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Mar 24 23:23:24 2006 @@ -285,9 +285,8 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) (declare (ignore wparam lparam)) (let* ((tc (thread-context)) - (w (get-widget tc hwnd)) - (gc (make-instance 'gfg:graphics-context))) - (if w + (widget (get-widget tc hwnd))) + (if widget (let ((rct (make-instance 'gfs:rectangle))) (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) (cffi:with-foreign-slots ((gfs::rcpaint-x @@ -295,14 +294,15 @@ gfs::rcpaint-width gfs::rcpaint-height) ps-ptr gfs::paintstruct) - (setf (slot-value gc 'gfs:handle) (gfs::begin-paint hwnd ps-ptr)) (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x - :y gfs::rcpaint-y)) + :y gfs::rcpaint-y)) (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width - :height gfs::rcpaint-height)) - (unwind-protect - (event-paint (dispatcher w) w (event-time tc) gc rct) - (gfs::end-paint hwnd ps-ptr))))) + :height gfs::rcpaint-height)) + (let* ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) + (unwind-protect + (event-paint (dispatcher widget) widget (event-time tc) gc rct) + (gfs:dispose gc) + (gfs::end-paint hwnd ps-ptr)))))) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0)

1 0

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

24 Mar '06

Author: junrue Date: Fri Mar 24 16:59:39 2006 New Revision: 71 Added: trunk/src/tests/uitoolkit/drawing-tester.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp Log: started drawing test program Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Fri Mar 24 16:59:39 2006 @@ -60,4 +60,5 @@ (:file "event-tester") (:file "layout-tester") (:file "image-tester") + (:file "drawing-tester") (:file "windlg"))))))))) Added: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Fri Mar 24 16:59:39 2006 @@ -0,0 +1,86 @@ +;;;; +;;;; drawing-tester.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + +(defvar *drawing-dispatcher* nil) +(defvar *drawing-win* nil) + +(defun drawing-exit-fn (disp item time rect) + (declare (ignore disp item time rect)) + (gfs:dispose *drawing-win*) + (setf *drawing-win* nil) + (gfw:shutdown 0)) + +(defclass drawing-win-events (gfw:event-dispatcher) + ((draw-func + :accessor draw-func-of + :initform nil))) + +(defmethod gfw:event-close ((self drawing-win-events) window time) + (declare (ignore window time)) + (drawing-exit-fn self nil nil 0)) + +(defmethod gfw:event-paint ((self drawing-win-events) window time gc rect) + (declare (ignore window time)) + (setf (gfg:background-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc rect) + (let ((func (draw-func-of self))) + (unless (null func) + (funcall func gc)))) + +(defun draw-rects (gc) + (setf (gfg:background-color gc) gfg:*color-blue*) + (gfg:draw-filled-rectangle gc + (make-instance 'gfs:rectangle :location (gfs:make-point :x 10 :y 10) + :size (gfs:make-size :width 100 :height 75)))) + +(defun select-rects (disp item time rect) + (declare (ignore disp item time rect)) + (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) + (gfw:redraw *drawing-win*)) + +(defun run-drawing-tester-internal () + (let ((menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'drawing-exit-fn))) + (:item "&Tests" + :submenu ((:item "&Rectangles" :checked :callback #'select-rects))))))) + (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) + (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) + (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* + :style '(:style-workspace))) + (setf (gfw:menu-bar *drawing-win*) menubar) + (gfw:show *drawing-win* t))) + +(defun run-drawing-tester () + (gfw:startup "Drawing Tester" #'run-drawing-tester-internal)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 24 16:59:39 2006 @@ -37,12 +37,16 @@ (defclass main-win-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d main-win-events) window time) - (declare (ignore time)) +(defun windlg-exit-fn (disp item time rect) + (declare (ignore disp item time rect)) + (gfs:dispose *main-win*) (setf *main-win* nil) - (gfs:dispose window) (gfw:shutdown 0)) +(defmethod gfw:event-close ((self main-win-events) window time) + (declare (ignore window time)) + (windlg-exit-fn self nil nil 0)) + (defclass test-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-paint ((d test-win-events) window time gc rect) @@ -93,18 +97,12 @@ (setf (gfw:text window) "Palette") (gfw:show window t))) -(defun exit-callback (disp item time rect) - (declare (ignore disp item time rect)) - (gfs:dispose *main-win*) - (setf *main-win* nil) - (gfw:shutdown 0)) - (defun run-windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) :style '(:style-workspace))) (setf menubar (gfw:defmenu ((:item "&File" - :submenu ((:item "E&xit" :callback #'exit-callback))) + :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) (:item "&Windows" :submenu ((:item "&Borderless" :callback #'create-borderless-win) (:item "&Mini Frame" :callback #'create-miniframe-win) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Fri Mar 24 16:59:39 2006 @@ -60,12 +60,18 @@ (defgeneric depth (object) (:documentation "Returns the bits-per-pixel depth of the object.")) -(defgeneric draw-arc (object rect start-angle arc-angle) - (:documentation "Draws the outline of a circular or elliptical arc within the specified rectangular area.")) +(defgeneric draw-arc (object rect start-pnt end-pnt direction) + (:documentation "Draws the outline of an elliptical arc within the specified rectangular area.")) -(defgeneric draw-filled-arc (object rect start-angle arc-angle) +(defgeneric draw-chord (object rect start-pnt end-pnt direction) + (:documentation "Draws a region bounded by the intersection of an ellipse and a line segment.")) + +(defgeneric draw-filled-wedge (object rect start-pnt end-pnt direction) (:documentation "Fills the interior of an elliptical arc within the rectangle in the current background color.")) +(defgeneric draw-filled-chord (object rect start-pnt end-pnt) + (:documentation "Fills a region bounded by the intersection of an ellipse and a line segment.")) + (defgeneric draw-filled-oval (object rect) (:documentation "Fills the interior of the oval defined by a rectangle in the current background color."))

1 0

[graphic-forms-cvs] r70 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 24 Mar '06

24 Mar '06

Author: junrue Date: Fri Mar 24 02:38:26 2006 New Revision: 70 Added: trunk/src/uitoolkit/widgets/root-window.lisp Log: missed this in last checkin Added: trunk/src/uitoolkit/widgets/root-window.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/root-window.lisp Fri Mar 24 02:38:26 2006 @@ -0,0 +1,83 @@ +;;;; +;;;; root-window.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; methods +;;; + +(defmethod gfs:dispose ((self root-window)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod (setf dispatcher) (disp (self root-window)) + (declare (ignore disp)) + (error 'gfs:toolkit-error :detail "The root window cannot be assigned an event-dispatcher.")) + +(defmethod enable ((self root-window) flag) + (declare (ignore flag)) + (error 'gfs:toolkit-error :detail "The root window cannot be enabled or disabled.")) + +(defmethod enable-layout ((self root-window) flag) + (declare (ignore flag)) + (error 'gfs:toolkit-error :detail "The root window has no layout functionality.")) + +(defmethod initialize-instance :after ((self root-window) &key) + (setf (slot-value self 'gfs:handle) (gfs::get-desktop-window))) + +(defmethod (setf location) (pnt (self root-window)) + (declare (ignore pnt)) + (error 'gfs:toolkit-error :detail "The root window cannot be repositioned.")) + +(defmethod layout ((self root-window)) + (error 'gfs:toolkit-error :detail "The root window has no layout functionality.")) + +(defmethod owner ((self root-window)) + nil) + +(defmethod pack ((self root-window)) + (error 'gfs:toolkit-error :detail "The root window has no layout functionality.")) + +(defmethod parent ((self root-window)) + nil) + +(defmethod show ((self root-window) flag) + (declare (ignore flag)) + (error 'gfs:toolkit-error :detail "The root window cannot be shown or hidden.")) + +(defmethod text ((self root-window)) + (error 'gfs:toolkit-error :detail "The root window has no title.")) + +(defmethod (setf text) (str (self root-window)) + (declare (ignore str)) + (error 'gfs:toolkit-error :detail "The root window has no title."))

1 0

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

24 Mar '06

Author: junrue Date: Fri Mar 24 02:37:39 2006 New Revision: 69 Added: trunk/src/uitoolkit/widgets/display.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: formalized concepts of 'parent' vs. 'owner' and implemented associated functions and classes; implemented display class representing the monitor and provided access function; modified windlg test program to place the borderless window centered within the main window client area Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Mar 24 02:37:39 2006 @@ -186,6 +186,19 @@ @ref{widget}. @end deftp +@anchor{display} +@deftp Class display primary +Instances of this class describe characteristics of monitors attached +to the system. Applications may call @ref{obtain-displays} to get a +list of all @code{display}s (more than one if the system has multiple +monitors), or @ref{obtain-primary-display} to get the primary. It +derives from @ref{native-object}. +@deffn Reader primary-p +Returns T if the system regards this display as the primary +display; nil otherwise. +@end deffn +@end deftp + @anchor{event-dispatcher} @deftp Class event-dispatcher This is the base class of objects responsible for processing events on @@ -197,10 +210,17 @@ @anchor{event-source} @deftp Class event-source dispatcher -This is the base class for user interface objects that generate events. It -derives from @ref{native-object}. The @code{dispatcher} slot holds an -instance of @ref{event-dispatcher} that is responsible for processing -events on behalf of an @code{event-source}. +This is the base class for user interface objects that generate +events. It derives from @ref{native-object}. The @code{dispatcher} +slot holds an instance of @ref{event-dispatcher} that is responsible +for processing events on behalf of an @code{event-source}. +@deffn Initarg :callbacks +The @code{:callbacks} initarg value specifies an association list +where the @code{CAR} of each entry is the symbol of an @code{event-*} +method (e.g., @ref{event-select}) and the @code{CDR} is a function +pointer. As such, this constitutes a specification for a new +@ref{event-dispatcher} class and associated methods. +@end deffn @deffn Initarg :dispatcher @end deffn @deffn Accessor dispatcher @@ -208,8 +228,10 @@ @end deftp @anchor{item} -@deftp Class item -The item class is the base class for all non-windowed user interface objects. +@deftp Class item item-id +The @code{item} class is the base class for all non-windowed user +interface objects serving as subcomponents of a +@ref{widget-with-items} object. It derives from @ref{event-source}. @deffn Initarg :item-id @end deffn @deffn Accessor item-id @@ -221,6 +243,7 @@ display a string or image. @end deftp +@anchor{menu} @deftp Class menu The menu class represents a container for menu items and submenus. It derives from @ref{widget-with-items}. @@ -230,14 +253,38 @@ A subclass of @ref{item} representing a menu item. @end deftp +@anchor{panel} @deftp Class panel -Base class for @ref{window}s that are children of @ref{top-level} @ref{window}s (or -other panels). +Base class for @ref{window}s that are children of @ref{top-level} +@ref{window}s (or other panels). +@end deftp + +@anchor{root-window} +@deftp Class root-window +This class encapsulates the root of the desktop window hierarchy. Note +that applications may create multiple instances that are not +@code{eq}, yet all such instances will have the same underlying +handle, so they in fact refer to the same native object. Operations +on the root @ref{window} are somewhat constrained, therefore not all +functions normally implemented for other @ref{window} types are +available for this @ref{window} type. If an application attempts to +set @code{root-window} as the @ref{owner} of a dialog or +@ref{top-level}, a @ref{toolkit-error} will be thrown. +In a reply to an entry at +@url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, +Raymond Chen says: +@quotation +An owned window is not a child window. Disabling a parent also +disables children, but it does NOT disable owned windows. + +The desktop is the parent of all top-level windows, so disabling the +desktop disables everybody. The desktop is special that way. +@end quotation @end deftp @deftp Class timer -A timer is a non-windowed object that generates events at a regular (adjustable) frequency. -It derives from @ref{event-source}. +A timer is a non-windowed object that generates events at a regular +(adjustable) frequency. It derives from @ref{event-source}. @deffn Reader id-of @end deffn @deffn Initarg :initial-delay @@ -353,7 +400,8 @@ @end deffn @deffn GenericFunction event-move dispatcher widget time point -Implement this to respond to an object being moved within its parent's coordinate system. +Implement this to respond to an object being moved within its parent's +coordinate system. @end deffn @anchor{event-paint} @@ -365,6 +413,7 @@ Implement this to respond to an object being resized. @end deffn +@anchor{event-select} @deffn GenericFunction event-select dispatcher item time rect Implement this to respond to an object (or item within) being selected. @end deffn @@ -385,139 +434,225 @@ Returns T if ancestor is an ancestor of descendant; nil otherwise. @end deffn -@deffn GenericFunction append-item object text image dispatcher -Adds the new item with the specified text to the object, and returns the newly-created item. +@deffn GenericFunction append-item self text image dispatcher +Adds the new item with the specified text to the object, and returns +the newly-created item. @end deffn -@deffn GenericFunction append-submenu object text submenu dispatcher +@deffn GenericFunction append-submenu self text submenu dispatcher Adds a submenu anchored to a parent menu and returns the corresponding item. @end deffn -@deffn GenericFunction check object flag +@anchor{center-on-owner} +@deffn GenericFunction center-on-owner self +Position @code{self} such that it is centrally located relative to its +@ref{owner}, based on @code{self}'s current outermost size. +See also @ref{center-on-parent}. +@end deffn + +@anchor{center-on-parent} +@deffn GenericFunction center-on-parent self +Position @code{self} such that it is centrally located relative to its +@ref{parent}, based on @code{self}'s current outermost size. +See also @ref{center-on-owner}. +@end deffn + +@deffn GenericFunction check self flag Sets the object into the checked state. @end deffn -@deffn GenericFunction checked-p object +@deffn GenericFunction checked-p self Returns T if the object is in the checked state; nil otherwise. @end deffn -@deffn GenericFunction clear-item object index +@deffn GenericFunction clear-item self index Clears the item at the zero-based index. @end deffn -@deffn GenericFunction clear-span object sp +@deffn GenericFunction clear-span self sp Clears the items whose zero-based indices lie within the specified span. @end deffn -@deffn GenericFunction client-size object -Returns a size object that describes the region of the object that can be drawn within or can display data. +@deffn GenericFunction client-size self +Returns a size object that describes the region of the object that can +be drawn within or can display data. @end deffn -@deffn GenericFunction compute-style-flags object &rest style -Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports. +@deffn GenericFunction compute-style-flags self &rest style +Convert a list of keyword symbols to a pair of native bitmasks; the +first conveys normal/standard flags, whereas the second any extended +flags that the system supports. @end deffn -@deffn GenericFunction compute-outer-size object desired-client-size -Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim. +@deffn GenericFunction compute-outer-size self desired-client-size +Return a size object describing the dimensions of the area required to +enclose the specified desired client area and this object's trim. @end deffn -@deffn GenericFunction display-to-object object pnt -Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system. +@deffn GenericFunction display-to-object self pnt +Return a point that is the result of transforming the specified point +from display-relative coordinates to this object's coordinate system. @end deffn -@deffn GenericFunction enable object flag -Enables or disables the object, causing it to be redrawn with its default look and allows it to be selected. +@deffn GenericFunction enable self flag +Enables or disables the object, causing it to be redrawn with its +default look and allows it to be selected. @end deffn -@deffn GenericFunction enable-layout object flag +@deffn GenericFunction enable-layout self flag Cause the object to allow or disallow layout management. @end deffn -@deffn GenericFunction enabled-p object +@deffn GenericFunction enabled-p self Returns T if the object is enabled; nil otherwise. @end deffn -@deffn GenericFunction item-at object index +@deffn GenericFunction item-at self index Return the item at the given zero-based index from the object. @end deffn -@deffn GenericFunction item-count object +@deffn GenericFunction item-count self Return the number of items possessed by the object. @end deffn -@deffn GenericFunction item-index object item +@deffn GenericFunction item-index self item Return the zero-based index of the location of the other object in this object. @end deffn -@deffn GenericFunction item-owner item -Return the widget containing this item. -@end deffn - -@deffn GenericFunction layout object +@deffn GenericFunction layout self Set the size and location of this object's children. @end deffn -@deffn GenericFunction location object -Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system. +@deffn GenericFunction location self +Returns a point object describing the coordinates of the top-left +corner of the object in its parent's coordinate system. @xref{parent}. @end deffn -@deffn GenericFunction menu-bar object +@deffn GenericFunction menu-bar self Returns the menu object serving as the menubar for this object. @end deffn -@deffn GenericFunction object-to-display object pnt -Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates. +@deffn GenericFunction object-to-display self pnt +Return a point that is the result of transforming the specified point +from this object's coordinate system to display-relative coordinates. +@end deffn + +@anchor{obtain-displays} +@deffn Function obtain-displays +Returns a list of @ref{display} objects, each of which describes +a monitor attached to the system. The system specifies that one +of these is the primary @ref{display}. +@end deffn + +@anchor{obtain-primary-display} +@deffn Function obtain-primary-display +Return a @ref{display} object that is regarded by the system as +being the primary. +@end deffn + +@anchor{owner} +@deffn GenericFunction owner self +Returns the @code{owner} of @code{self}, which may be different from +@code{self}'s @ref{parent} because the window ownership hierarchy +includes the relationships between physically separate +@ref{top-level}s and dialogs. And it is possible for a window to be +unowned but still have a @ref{parent}. Consequently, calling +@ref{parent} on a @ref{top-level} will return an instance of +@ref{root-window}, but calling @ref{owner} may return @code{nil}. In +a reply to an entry at +@url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, +Raymond Chen says: +@quotation +An owned window is not a child window. Disabling a parent also +disables children, but it does NOT disable owned windows. + +The desktop is the parent of all top-level windows, so disabling the +desktop disables everybody. The desktop is special that way. +@end quotation @end deffn @anchor{pack} -@deffn GenericFunction pack object -Causes the object to be resized to its preferred size. +@deffn GenericFunction pack self +Causes @code{self} to be resized to its preferred @ref{size}. @end deffn -@deffn GenericFunction parent object -Returns the object's parent. +@anchor{parent} +@deffn GenericFunction parent self +Returns the @code{parent} of @code{self}. In the case of @ref{panel}s +and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or +@ref{top-level} window. In the case of a dialog or @ref{top-level}, +then a @ref{root-window} is returned. In the case of a @code{submenu}, +this will be the @ref{menu}'s ancestor in the hierarchy; but for a +menubar or context @ref{menu}, @code{parent} returns @code{nil}. In a +reply to an entry at +@url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, +Raymond Chen says: +@quotation +An owned window is not a child window. Disabling a parent also +disables children, but it does NOT disable owned windows. + +The desktop is the parent of all top-level windows, so disabling the +desktop disables everybody. The desktop is special that way. +@end quotation +@end deffn + +@deffn GenericFunction preferred-size self width-hint height-hint +Implement this function to return @code{self}'s preferred @ref{size}; +that is, the dimensions that @code{self} computes as being the best +fit for itself and/or its children. If one or both of +@code{width-hint} and @code{height-hint} are positive, then each such +parameter is used as a constraint on the @ref{size} calculation -- if +for example @code{width-hint} is some positive value, then @code{self} +must determine how tall it would be given that width. @end deffn -@deffn GenericFunction preferred-size object width-hint height-hint -Returns a size object representing the object's 'preferred' size. -@end deffn - -@deffn GenericFunction redraw object +@deffn GenericFunction redraw self Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn -@deffn GenericFunction running-p object +@deffn GenericFunction running-p self Returns T if the object is in event generation mode; nil otherwise. @end deffn -@deffn GenericFunction show object flag -Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order. +@deffn GenericFunction show self flag +Causes the object to be visible or hidden on the screen, but not +necessarily top-most in the display z-order. @end deffn -@deffn GenericFunction size object -Returns a size object describing the size of the object in its parent's coordinate system. +@deffn GenericFunction size self +Returns a size object describing the size of the object in its +parent's coordinate system. @end deffn -@deffn GenericFunction start object +@deffn GenericFunction start self Enable event generation at regular intervals. @end deffn -@deffn GenericFunction stop object +@deffn GenericFunction stop self Stop producing events. @end deffn -@deffn GenericFunction text object +@deffn GenericFunction text self Returns the object's text. @end deffn -@deffn GenericFunction update object -Forces all outstanding paint requests for the object to be processed before this function returns. +@deffn GenericFunction update self +Forces all outstanding paint requests for the object to be processed +before this function returns. @end deffn -@deffn GenericFunction visible-p object +@deffn GenericFunction visible-p self Returns T if the object is visible (not necessarily top-most); nil otherwise. @end deffn +@html +@deffn GenericFunction window->display self +Return the @ref{display} object representing the monitor that is nearest +to @code{self}. The @ref{rectangle} bounding @code{self} is not required +to intersect the returned @ref{display}. +@end deffn +@end html + @node layout functions @section layout functions @@ -578,46 +713,49 @@ in future releases, they just aren't all documented or implemented at this time. -@deffn GenericFunction background-color object +@deffn GenericFunction background-color self Returns a color object corresponding to the current background color. @end deffn -@deffn GenericFunction data-obj object +@deffn GenericFunction data-obj self Returns the data structure representing the raw form of the object. @end deffn -@deffn GenericFunction depth object +@deffn GenericFunction depth self Returns the bits-per-pixel depth of the object. @end deffn -@deffn GenericFunction draw-filled-rectangle object rect +@deffn GenericFunction draw-filled-rectangle self rect Fills the interior of the rectangle in the current background color. @end deffn -@deffn GenericFunction draw-image object im pnt +@deffn GenericFunction draw-image self im pnt Draws the given image in the receiver at the specified coordinates. @end deffn -@deffn GenericFunction draw-text object text pnt -Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string. +@deffn GenericFunction draw-text self text pnt +Draws the given string in the current font and foreground color, with +(x, y) being the top-left coordinate of a bounding box for the string. @end deffn -@deffn GenericFunction font object +@deffn GenericFunction font self Returns the current font. @end deffn -@deffn GenericFunction foreground-color object +@deffn GenericFunction foreground-color self Returns a color object corresponding to the current foreground color. @end deffn -@deffn GenericFunction metrics object +@deffn GenericFunction metrics self Returns a metrics object describing key attributes of the specified object. @end deffn -@deffn GenericFunction size object +@deffn GenericFunction size self Returns a size object describing the size of the object. @end deffn -@deffn GenericFunction transparency-mask object -Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency. +@deffn GenericFunction transparency-mask self +Returns an image object that will serve as the transparency mask for +the original image, based on the original image's assigned +transparency. @end deffn Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Mar 24 02:37:39 2006 @@ -88,6 +88,7 @@ (:file "event-generics") (:file "layout-generics") (:file "widget-generics") + (:file "display") (:file "event-source") (:file "widget-utils") (:file "timer") @@ -102,6 +103,7 @@ (:file "menu-language") (:file "event") (:file "window") + (:file "root-window") (:file "top-level") (:file "panel") (:file "layout") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Mar 24 02:37:39 2006 @@ -198,6 +198,7 @@ #:button #:caret #:control + #:display #:event-dispatcher #:event-source #:flow-layout @@ -206,6 +207,7 @@ #:menu #:menu-item #:panel + #:root-window #:timer #:top-level #:widget @@ -292,6 +294,8 @@ #:border-width #:bottom-margin-of #:caret + #:center-on-owner + #:center-on-parent #:check #:check-all #:checked-p @@ -400,12 +404,16 @@ #:move-below #:moveable-p #:object-to-display + #:obtain-displays + #:obtain-primary-display + #:owner #:pack #:page-increment #:parent #:paste #:peer #:preferred-size + #:primary-p #:redraw #:redrawing-p #:remove-all Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 24 02:37:39 2006 @@ -69,8 +69,8 @@ (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* :style '(:style-borderless)))) - (setf (gfw:location window) (gfs:make-point :x 400 :y 250)) (setf (gfw:size window) (gfs:make-size :width 300 :height 250)) + (gfw:center-on-owner window) (gfw:show window t))) (defun create-miniframe-win (disp item time rect) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Mar 24 02:37:39 2006 @@ -92,6 +92,8 @@ (defconstant +cbm-init+ #x04) +(defconstant +cchdevicename+ 32) + (defconstant +color-scrollbar+ 0) (defconstant +color-background+ 1) (defconstant +color-activecaption+ 2) @@ -279,6 +281,12 @@ (defconstant +mns-notifybypos+ #x08000000) (defconstant +mns-checkorbmp+ #x04000000) +(defconstant +monitor-defaulttonull+ #x00000000) +(defconstant +monitor-defaulttoprimary+ #x00000001) +(defconstant +monitor-defaulttonearest+ #x00000002) + +(defconstant +monitorinfoof-primary+ #x00000001) + (defconstant +obm-lfarrowi+ 32734) (defconstant +obm-rgarrowi+ 32735) (defconstant +obm-dnarrowi+ 32736) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Mar 24 02:37:39 2006 @@ -65,6 +65,7 @@ (defctype LPVOID :long) (defctype LRESULT :unsigned-long) (defctype SHORT :unsigned-short) +(defctype TCHAR :char) (defctype UINT :unsigned-int) (defctype ULONG :unsigned-long) (defctype WORD :short) @@ -165,6 +166,13 @@ (right LONG) (bottom LONG)) +(defcstruct monitorinfoex + (cbsize UINT) + (monitor rect) + (work rect) + (flags DWORD) + (device TCHAR :count 32)) ; CCHDEVICENAME + (defcstruct rgbquad (rgbblue BYTE) (rgbgreen BYTE) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Fri Mar 24 02:37:39 2006 @@ -187,6 +187,47 @@ (lparam ffi:long)) (:return-type ffi:int)) +;;; FIXME: uncomment this when CFFI callbacks can +;;; be tagged as stdcall or cdecl (only the latter +;;; is supported as of 0.9.0) +;;; +#| +(defcfun + ("EnumDisplayMonitors" enum-display-monitors) + BOOL + (hdc HANDLE) + (cliprect LPTR) + (enumproc LPTR) + (data LPARAM)) +|# + +#+lispworks +(fli:define-foreign-function + (enum-display-monitors "EnumDisplayMonitors") + ((hdc :pointer) + (cliprect :pointer) + (enumproc :pointer) + (data :long)) + :result-type :int) + +#+clisp +(ffi:def-call-out enum-display-monitors + (:name "EnumDisplayMonitors") + (:library "user32.dll") + (:language :stdc) + (:arguments (hdc ffi:c-pointer) + (cliprect ffi:c-pointer) + (func (ffi:c-function + (:arguments + (hmonitor ffi:c-pointer) + (hdc ffi:c-pointer) + (monitorrect ffi:c-pointer) + (data ffi:long)) + (:return-type ffi:int) + (:language :stdc-stdcall))) + (data ffi:c-pointer)) + (:return-type ffi:int)) + (defcfun ("GetAncestor" get-ancestor) HANDLE @@ -229,6 +270,10 @@ (hwnd HANDLE)) (defcfun + ("GetDesktopWindow" get-desktop-window) + HANDLE) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT)) @@ -261,6 +306,17 @@ (filter-max UINT)) (defcfun + ("GetMonitorInfoA" get-monitor-info) + BOOL + (hmonitor HANDLE) + (monitor-info LPTR)) + +(defcfun + ("GetParent" get-parent) + HANDLE + (hwnd HANDLE)) + +(defcfun ("GetSubMenu" get-submenu) HANDLE (hwnd HANDLE) @@ -349,6 +405,12 @@ (type UINT)) (defcfun + ("MonitorFromWindow" monitor-from-window) + HANDLE + (hwnd HANDLE) + (flags DWORD)) + +(defcfun ("PeekMessageA" peek-message) BOOL (msg LPTR) Added: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/display.lisp Fri Mar 24 02:37:39 2006 @@ -0,0 +1,133 @@ +;;;; +;;;; display.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; helper functions +;;; + +#+lispworks +(fli:define-foreign-callable + ("display_visitor" :result-type :integer :calling-convention :stdcall) + ((hmonitor :pointer) + (hdc :pointer) + (monitorrect :pointer) + (data :long)) + (declare (ignore hdc monitorrect)) + (call-display-visitor-func (thread-context) hmonitor data) + 1) + +#+clisp +(defun display_visitor (hmonitor hdc monitorrect data) + (declare (ignore hdc monitorrect)) + (call-display-visitor-func (thread-context) hmonitor data) + 1) + +(defun visit-displays (func) + ;; + ;; supplied closure should expect three parameters: + ;; display handle + ;; flag data + ;; + (let ((tc (thread-context))) + (setf (display-visitor-func tc) func) + (unwind-protect +#+lispworks (let ((ptr (fli:make-pointer :address 0))) + (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) +#+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) + (gfs::enum-display-monitors ptr ptr #'display_visitor 0)) + (setf (display-visitor-func tc) nil))) + nil) + +(defun obtain-displays () + (let ((display-list nil)) + (visit-displays #'(lambda (hmonitor data) + (let ((pflag (= (logand data gfs::+monitorinfoof-primary+) + gfs::+monitorinfoof-primary+)) + (display (make-instance 'display :handle hmonitor))) + (setf (slot-value display 'primary) pflag) + (push display display-list)))) + display-list)) + +(defun obtain-primary-display () + (find-if #'primary-p (obtain-displays))) + +;;; +;;; methods +;;; + +(defmethod client-size ((self display)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((size (gfs::make-size))) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::work) + mi-ptr gfs::monitorinfoex) + (gfs::get-monitor-info (gfs:handle self) mi-ptr) + (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::work))) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) + rect-ptr gfs::rect) + (setf (gfs:size-width size) (- gfs::right gfs::left)) + (setf (gfs:size-height size) (- gfs::bottom gfs::top)))))) + size)) + +(defmethod gfs:dispose ((self display)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod size ((self display)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((size (gfs::make-size))) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor) + mi-ptr gfs::monitorinfoex) + (gfs::get-monitor-info (gfs:handle self) mi-ptr) + (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::monitor))) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) + rect-ptr gfs::rect) + (setf (gfs:size-width size) (- gfs::right gfs::left)) + (setf (gfs:size-height size) (- gfs::bottom gfs::top)))))) + size)) + +(defmethod text ((self display)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((name "")) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::device) + mi-ptr gfs::monitorinfoex) + (gfs::get-monitor-info (gfs:handle self) mi-ptr) + (let ((str-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::device))) + (setf name (cffi:foreign-string-to-lisp str-ptr (1- gfs::+cchdevicename+)))))) + name)) Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Fri Mar 24 02:37:39 2006 @@ -65,11 +65,19 @@ :specializers (make-specializer-list class arg-info)))) class)) -(defmethod initialize-instance :after ((src event-source) &key callbacks &allow-other-keys) - "The :callbacks parameter specifies an association list where the CAR is the \ -name of an event-* method (e.g., event-select) and the CDR is a function \ -pointer. As such, this constitutes a specification for a new event-dispatcher \ -object and associated methods." +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((self event-source) &key callbacks &allow-other-keys) (unless (null callbacks) (let ((class (define-dispatcher callbacks))) - (setf (dispatcher src) (make-instance (class-name class)))))) + (setf (dispatcher self) (make-instance (class-name class)))))) + +(defmethod owner :before ((self event-source)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod parent :before ((self event-source)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Fri Mar 24 02:37:39 2006 @@ -198,7 +198,7 @@ (setf (dispatcher it) nil) (remove-menuitem (thread-context) it) (let ((id (item-id it)) - (owner (item-owner it))) + (owner (owner it))) (unless (null owner) (gfs::remove-menu (gfs:handle owner) id gfs::+mf-bycommand+) (let* ((index (item-index owner it)) @@ -220,7 +220,7 @@ gfs::+mfs-enabled+) gfs::+mfs-enabled+)) -(defmethod item-owner ((it menu-item)) +(defmethod owner ((it menu-item)) (let ((hmenu (gfs:handle it))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Fri Mar 24 02:37:39 2006 @@ -49,7 +49,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win panel) &rest style) +(defmethod compute-style-flags ((self panel) &rest style) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) (ex-flags 0)) (mapc #'(lambda (sym) @@ -61,11 +61,11 @@ (flatten style)) (values std-flags ex-flags))) -(defmethod initialize-instance :after ((win panel) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((self panel) &key parent style &allow-other-keys) (if (null parent) (error 'gfs:toolkit-error :detail "parent is required for panel")) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) (if (not (listp style)) (setf style (list style))) - (init-window win +panel-window-classname+ #'register-panel-window-class style parent "")) + (init-window self +panel-window-classname+ #'register-panel-window-class style parent "")) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Fri Mar 24 02:37:39 2006 @@ -35,6 +35,7 @@ (defclass thread-context () ((child-visitor-stack :initform nil) + (display-visitor-func :initform nil :accessor display-visitor-func) (image-loaders-by-type :initform (make-hash-table :test #'equal)) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) @@ -88,6 +89,11 @@ "Pop the top of the child window visitor function stack; returns the closure if the stack was not already empty." (pop (slot-value tc 'child-visitor-stack))) +(defmethod call-display-visitor-func ((tc thread-context) hmonitor data) + (let ((func (display-visitor-func tc))) + (unless (null func) + (funcall func hmonitor data)))) + (defmethod get-widget ((tc thread-context) hwnd) "Return the widget object corresponding to the specified native window handle." (let ((tmp-widget (slot-value tc 'wip))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Mar 24 02:37:39 2006 @@ -33,6 +33,12 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defclass display (gfs:native-object) + ((primary + :reader primary-p + :initform nil)) + (:documentation "Instances of this class describe characteristics of monitors attached to the system.")) + (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) @@ -91,6 +97,9 @@ (defclass panel (window) () (:documentation "Base class for windows that are children of top-level windows (or other panels).")) +(defclass root-window (window) () + (:documentation "This class encapsulates the root of the desktop window hierarchy.")) + (defclass top-level (window) () (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Mar 24 02:37:39 2006 @@ -33,344 +33,353 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric accelerator (object) +(defgeneric accelerator (self) (:documentation "Returns a bitmask indicating the key and any modifiers corresponding to the accelerator set for this object.")) -(defgeneric activate (object) +(defgeneric activate (self) (:documentation "If the object is visible, move it to the top of the display z-order and request the window manager to set it active.")) -(defgeneric alignment (object) +(defgeneric alignment (self) (:documentation "Returns a keyword symbol describing the position of internal content within the object.")) (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (object text image dispatcher) +(defgeneric append-item (self text image dispatcher) (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) -(defgeneric append-submenu (object text submenu dispatcher) +(defgeneric append-submenu (self text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) -(defgeneric background-color (object) +(defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) -(defgeneric border-width (object) +(defgeneric border-width (self) (:documentation "Returns the object's border width.")) -(defgeneric caret (object) +(defgeneric caret (self) (:documentation "Returns the object's caret.")) -(defgeneric caret-position (object) +(defgeneric caret-position (self) (:documentation "Returns a point describing the line number and character position of the caret.")) -(defgeneric check (object flag) +(defgeneric center-on-owner (self) + (:documentation "Position self such that it is centrally located relative to its owner.")) + +(defgeneric center-on-parent (self) + (:documentation "Position self such that it is centrally located relative to its parent.")) + +(defgeneric check (self flag) (:documentation "Sets the object into the checked state.")) -(defgeneric check-all (object flag) +(defgeneric check-all (self flag) (:documentation "Sets all items in this object to the checked state.")) -(defgeneric checked-p (object) +(defgeneric checked-p (self) (:documentation "Returns T if the object is in the checked state; nil otherwise.")) -(defgeneric clear-item (object index) +(defgeneric clear-item (self index) (:documentation "Clears the item at the zero-based index.")) -(defgeneric clear-selection (object) +(defgeneric clear-selection (self) (:documentation "Sets the object's selection status to empty or not selected.")) -(defgeneric clear-span (object sp) +(defgeneric clear-span (self sp) (:documentation "Clears the items whose zero-based indices lie within the specified span.")) -(defgeneric client-size (object) +(defgeneric client-size (self) (:documentation "Returns a size object that describes the region of the object that can be drawn within or can display data.")) -(defgeneric column-at (object index) +(defgeneric column-at (self index) (:documentation "Returns the column object at the zero-based index.")) -(defgeneric column-count (object) +(defgeneric column-count (self) (:documentation "Returns the number of columns displayed by the object.")) -(defgeneric column-index (object col) +(defgeneric column-index (self col) (:documentation "Return the zero-based index of the location of the column in this object.")) -(defgeneric column-order (object) +(defgeneric column-order (self) (:documentation "Returns a list of zero-based indices, each of whose positions represents the column creation order and whose element value represents the current column order.")) -(defgeneric columns (object) +(defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (object &rest style) +(defgeneric compute-style-flags (self &rest style) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) -(defgeneric compute-outer-size (object desired-client-size) +(defgeneric compute-outer-size (self desired-client-size) (:documentation "Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim.")) -(defgeneric copy (object) +(defgeneric copy (self) (:documentation "Copies the current selection to the clipboard.")) -(defgeneric cursor (object) +(defgeneric cursor (self) (:documentation "Returns the cursor object associated with this object.")) -(defgeneric cut (object) +(defgeneric cut (self) (:documentation "Copies the current selection to the clipboard and removes it from the object.")) -(defgeneric default-item (object) +(defgeneric default-item (self) (:documentation "Returns the item in this object that has the default emphasis.")) -(defgeneric disabled-image (object) +(defgeneric disabled-image (self) (:documentation "Returns the image used to render this item with a disabled look.")) -(defgeneric display-to-object (object pnt) +(defgeneric display-to-object (self pnt) (:documentation "Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system.")) -(defgeneric echo-char (object) +(defgeneric echo-char (self) (:documentation "Returns the character that will be displayed when the user types text, or nil if no echo character has been set.")) -(defgeneric enable (object flag) +(defgeneric enable (self flag) (:documentation "Enables or disables the object, causing it to be redrawn with its default look and allows it to be selected.")) -(defgeneric enable-layout (object flag) +(defgeneric enable-layout (self flag) (:documentation "Cause the object to allow or disallow layout management.")) -(defgeneric enable-redraw (object flag) +(defgeneric enable-redraw (self flag) (:documentation "Cause the object to resume or suspend painting.")) -(defgeneric enabled-p (object) +(defgeneric enabled-p (self) (:documentation "Returns T if the object is enabled; nil otherwise.")) -(defgeneric expand (object deep flag) +(defgeneric expand (self deep flag) (:documentation "Set the object (and optionally it's children) to the expanded or collapsed state.")) -(defgeneric expanded-p (object) +(defgeneric expanded-p (self) (:documentation "Returns T if the object is in the expanded state; nil otherwise.")) -(defgeneric focus-index (object) +(defgeneric focus-index (self) (:documentation "Return a zero-based index of the object's sub-item that has focus; nil otherwise.")) -(defgeneric focus-p (object) +(defgeneric focus-p (self) (:documentation "Returns T if this object has the keyboard focus; nil otherwise.")) -(defgeneric foreground-color (object) +(defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) -(defgeneric give-focus (object) +(defgeneric give-focus (self) (:documentation "Causes this object to have the keyboard focus.")) -(defgeneric grid-line-width (object) +(defgeneric grid-line-width (self) (:documentation "Returns the width of a grid line.")) -(defgeneric header-height (object) +(defgeneric header-height (self) (:documentation "Returns the height of the item's header.")) -(defgeneric header-visible-p (object) +(defgeneric header-visible-p (self) (:documentation "Returns T if the object's header is visible; nil otherwise.")) -(defgeneric horizontal-scrollbar (object) +(defgeneric horizontal-scrollbar (self) (:documentation "Returns T if this object currently has a horizontal scrollbar; nil otherwise.")) -(defgeneric iconify (object flag) +(defgeneric iconify (self flag) (:documentation "Set the object to the iconified or restored state.")) -(defgeneric iconified-p (object) +(defgeneric iconified-p (self) (:documentation "Returns T if the object is in its iconified state.")) -(defgeneric image (object) +(defgeneric image (self) (:documentation "Returns the object's image object if it has one, or nil otherwise.")) -(defgeneric item-at (object index) +(defgeneric item-at (self index) (:documentation "Return the item at the given zero-based index from the object.")) -(defgeneric item-count (object) +(defgeneric item-count (self) (:documentation "Return the number of items possessed by the object.")) -(defgeneric item-height (object) +(defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) -(defgeneric item-index (object item) +(defgeneric item-index (self item) (:documentation "Return the zero-based index of the location of the other object in this object.")) -(defgeneric item-owner (item) - (:documentation "Return the widget containing this item.")) - -(defgeneric layout (object) +(defgeneric layout (self) (:documentation "Set the size and location of this object's children.")) -(defgeneric lines-visible-p (object) +(defgeneric lines-visible-p (self) (:documentation "Returns T if the object's lines are visible; nil otherwise.")) -(defgeneric location (object) +(defgeneric location (self) (:documentation "Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system.")) -(defgeneric lock (object flag) +(defgeneric lock (self flag) (:documentation "Prevents or enables modification of the object's contents.")) -(defgeneric locked-p (object) +(defgeneric locked-p (self) (:documentation "Returns T if this object's contents are locked from being modified.")) -(defgeneric maximize (object flag) +(defgeneric maximize (self flag) (:documentation "Set the object (or restore it from) the maximized state (not necessarily the same as the maximum size).")) -(defgeneric maximized-p (object) +(defgeneric maximized-p (self) (:documentation "Returns T if the object is in its maximized state (not necessarily the same as the maximum size); nil otherwise.")) -(defgeneric maximum-size (object) +(defgeneric maximum-size (self) (:documentation "Returns a size object describing the largest size this object can exist.")) -(defgeneric menu-bar (object) +(defgeneric menu-bar (self) (:documentation "Returns the menu object serving as the menubar for this object.")) -(defgeneric minimum-size (object) +(defgeneric minimum-size (self) (:documentation "Returns a size object describing the smallest size this object can exist.")) -(defgeneric mouse-over-image (object) +(defgeneric mouse-over-image (self) (:documentation "Returns the image displayed when the mouse is hovering over this object.")) -(defgeneric move-above (object other) +(defgeneric move-above (self other) (:documentation "Moves this object above the other object in the drawing order.")) -(defgeneric move-below (object other) +(defgeneric move-below (self other) (:documentation "Moves this object below the other object in the drawing order.")) -(defgeneric moveable-p (object) +(defgeneric moveable-p (self) (:documentation "Returns T if the object is moveable; nil otherwise.")) -(defgeneric object-to-display (object pnt) +(defgeneric object-to-display (self pnt) (:documentation "Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates.")) -(defgeneric pack (object) +(defgeneric owner (self) + (:documentation "Returns self's owner (which is not necessarily the same as parent).")) + +(defgeneric pack (self) (:documentation "Causes the object to be resized to its preferred size.")) -(defgeneric page-increment (object) +(defgeneric page-increment (self) (:documentation "Return an integer representing the configured page size for the object.")) -(defgeneric parent (object) +(defgeneric parent (self) (:documentation "Returns the object's parent.")) -(defgeneric paste (object) +(defgeneric paste (self) (:documentation "Copies content from the clipboard into the object.")) -(defgeneric peer (object) +(defgeneric peer (self) (:documentation "Returns the visual object associated with this object (not the underlying window system handle).")) -(defgeneric preferred-size (object width-hint height-hint) +(defgeneric preferred-size (self width-hint height-hint) (:documentation "Returns a size object representing the object's 'preferred' size.")) -(defgeneric redraw (object) +(defgeneric redraw (self) (:documentation "Causes the entire bounds of the object to be marked as needing to be redrawn")) -(defgeneric redrawing-p (object) +(defgeneric redrawing-p (self) (:documentation "Returns T if the object is set to allow processing of paint events.")) -(defgeneric remove-all (object) +(defgeneric remove-all (self) (:documentation "Removes all items from the object.")) -(defgeneric remove-item (object index) +(defgeneric remove-item (self index) (:documentation "Removes the item at the zero-based index from the object.")) -(defgeneric remove-span (object sp) +(defgeneric remove-span (self sp) (:documentation "Removes the sequence of items represented by the specified span object.")) -(defgeneric reparentable-p (object) +(defgeneric reparentable-p (self) (:documentation "Returns T if the window system allows this object to be reparented; nil otherwise.")) -(defgeneric replace-selection (object content) +(defgeneric replace-selection (self content) (:documentation "Replaces the content of the current selection with new content.")) -(defgeneric resizable-p (object) +(defgeneric resizable-p (self) (:documentation "Returns T if the object is resizable; nil otherwise.")) -(defgeneric retrieve-span (object) +(defgeneric retrieve-span (self) (:documentation "Returns the span object indicating the range of values that are valid for the object.")) -(defgeneric running-p (object) +(defgeneric running-p (self) (:documentation "Returns T if the object is in event generation mode; nil otherwise.")) -(defgeneric scroll (object dest-pnt src-rect children-too) +(defgeneric scroll (self dest-pnt src-rect children-too) (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting.")) -(defgeneric select (object flag) +(defgeneric select (self flag) (:documentation "Set this object into (or take it out of) the selected state.")) -(defgeneric select-all (object flag) +(defgeneric select-all (self flag) (:documentation "Set all items of this object into (or take them out of) the selected state.")) -(defgeneric selected-p (object) +(defgeneric selected-p (self) (:documentation "Returns T if the object is in the selected state; nil otherwise.")) -(defgeneric selection-count (object) +(defgeneric selection-count (self) (:documentation "Returns the number of this object's items that are selected.")) -(defgeneric selection-index (object) +(defgeneric selection-index (self) (:documentation "Returns the zero-based index of the currently-selected item, or nil if no item is selected.")) -(defgeneric selection-indices (object) +(defgeneric selection-indices (self) (:documentation "Returns a list of zero-based indices identifying the selected items within this object.")) -(defgeneric selection-span (object) +(defgeneric selection-span (self) (:documentation "Returns a span object describing the start and end indices of the object selection.")) -(defgeneric show (object flag) +(defgeneric show (self flag) (:documentation "Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order.")) -(defgeneric show-column (object col) +(defgeneric show-column (self col) (:documentation "This object's colums are scrolled until the specified column is visible.")) -(defgeneric show-header (object flag) +(defgeneric show-header (self flag) (:documentation "Causes the object's header to be made visible or hidden.")) -(defgeneric show-item (object index) +(defgeneric show-item (self index) (:documentation "This object's items are scrolled until the specified item is visible.")) -(defgeneric show-lines (object flag) +(defgeneric show-lines (self flag) (:documentation "Causes the object's lines to be made visible or hidden.")) -(defgeneric show-selection (object) +(defgeneric show-selection (self) (:documentation "This object's items are scrolled until the selection is visible.")) -(defgeneric size (object) +(defgeneric size (self) (:documentation "Returns a size object describing the size of the object in its parent's coordinate system.")) -(defgeneric start (object) +(defgeneric start (self) (:documentation "Enable event generation at regular intervals.")) -(defgeneric step-increment (object) +(defgeneric step-increment (self) (:documentation "Return an integer representing the configured step size for the object.")) -(defgeneric stop (object) +(defgeneric stop (self) (:documentation "Stop producing events.")) -(defgeneric text (object) +(defgeneric text (self) (:documentation "Returns the object's text.")) -(defgeneric text-height (object) +(defgeneric text-height (self) (:documentation "Returns the height of the object's text field.")) -(defgeneric text-limit (object) +(defgeneric text-limit (self) (:documentation "Returns the number of characters that the object's text field is capable of holding.")) -(defgeneric thumb-size (object) +(defgeneric thumb-size (self) (:documentation "Returns an integer representing the width (or height) of this object's thumb.")) -(defgeneric tooltip-text (object) +(defgeneric tooltip-text (self) (:documentation "Returns the text that will appear within a tooltip when the mouse hovers over this object.")) -(defgeneric top-index (object) +(defgeneric top-index (self) (:documentation "Returns the zero-based index of the item currently at the top of the object.")) -(defgeneric traverse (object arg) +(defgeneric traverse (self arg) (:documentation "Execute a traversal action within this object.")) -(defgeneric traverse-order (object) +(defgeneric traverse-order (self) (:documentation "Returns a list of this object's layout-managed children in the order in which tab traversal would visit them.")) -(defgeneric update (object) +(defgeneric update (self) (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns.")) -(defgeneric vertical-scrollbar (object) +(defgeneric vertical-scrollbar (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise.")) -(defgeneric visible-item-count (object) +(defgeneric visible-item-count (self) (:documentation "Return the number of items that are currently visible in the object.")) -(defgeneric visible-p (object) +(defgeneric visible-p (self) (:documentation "Returns T if the object is visible (not necessarily top-most); nil otherwise.")) + +(defgeneric window->display (self) + (:documentation "Return the display object representing the monitor that is nearest to self.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Mar 24 02:37:39 2006 @@ -37,6 +37,31 @@ ;;; helper functions ;;; +(defun centered-coord-inside (ancest-coord ancest-size desc-size) + (+ ancest-coord (floor (- (/ ancest-size 2) (/ desc-size 2))))) + +(defun centered-coord-outside (ancest-coord ancest-size desc-size) + (- ancest-coord (floor (/ (- desc-size ancest-size) 2)))) + +(defun center-object (ancestor descendant) + (let* ((ancest-size (client-size ancestor)) + (ancest-width (gfs:size-width ancest-size)) + (ancest-height (gfs:size-height ancest-size)) + (ancest-pnt (location ancestor)) + (desc-size (size descendant)) + (desc-width (gfs:size-width desc-size)) + (desc-height (gfs:size-height desc-size)) + (new-x 0) + (new-y 0)) + (incf (gfs:point-y ancest-pnt) (- (gfs:size-height (size ancestor)) ancest-height)) + (if (> ancest-width desc-width) + (setf new-x (centered-coord-inside (gfs:point-x ancest-pnt) ancest-width desc-width)) + (setf new-x (centered-coord-outside (gfs:point-x ancest-pnt) ancest-width desc-width))) + (if (> ancest-height desc-height) + (setf new-y (centered-coord-inside (gfs:point-y ancest-pnt) ancest-height desc-height)) + (setf new-y (centered-coord-outside (gfs:point-y ancest-pnt) ancest-height desc-height))) + (setf (location descendant) (gfs:make-point :x new-x :y new-y)))) + ;;; ;;; widget methods ;;; @@ -70,6 +95,23 @@ (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) 0)) +(defmethod center-on-owner :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod center-on-owner ((self widget)) + (let ((owner (owner self))) + (if (null owner) + nil + (center-object owner self)))) + +(defmethod center-on-parent :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod center-on-parent ((self widget)) + (center-object (parent self) self)) + (defmethod checked-p :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) @@ -155,6 +197,21 @@ gfs::+swp-nosize+)) (error 'gfs:win32-error :detail "set-window-pos failed"))) +(defmethod owner ((self widget)) + ;; I know the following is confusing, but the docs + ;; for MSDN state that GetParent() returns the owner + ;; when the window in question is a top-level, + ;; whereas for child windows the owner and parent + ;; are the same. + ;; + ;; And since GetParent() can return owners, this + ;; means it can return NULL, too. + ;; + (let ((hwnd (gfs::get-parent (gfs:handle self)))) + (if (gfs:null-handle-p hwnd) + nil + (get-widget (thread-context) hwnd)))) + (defmethod pack :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) @@ -162,6 +219,20 @@ (defmethod pack ((w widget)) (setf (size w) (preferred-size w -1 -1))) +(defmethod parent ((self widget)) + ;; Unlike the owner method, this method should + ;; only return nil if self is the root window, + ;; which is taken care of by a specialization + ;; on root-window (see root-window.lisp). + ;; + (let* ((hwnd (gfs::get-ancestor (gfs:handle self) gfs::+ga-parent+)) + (widget (get-widget (thread-context) hwnd))) + (when (null widget) + (if (cffi:pointer-eq hwnd (gfs::get-desktop-window)) + (setf widget (make-instance 'root-window :handle hwnd)) + (error 'gfs:toolkit-error :detail "no widget for hwnd"))) + widget)) + (defmethod redraw :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Mar 24 02:37:39 2006 @@ -207,3 +207,13 @@ (let ((sz (gfs:make-size))) (outer-size win sz) sz)) + +(defmethod window->display :before ((self top-level)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod window->display ((self top-level)) + (let* ((hmonitor (gfs::monitor-from-window (gfs:handle self) gfs::+monitor-defaulttonearest+)) + (display (make-instance 'display))) + (setf (slot-value display 'gfs:handle) hmonitor) + display))

1 0

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

22 Mar '06

Author: junrue Date: Wed Mar 22 10:28:06 2006 New Revision: 68 Modified: trunk/docs/website/index.html trunk/src/tests/uitoolkit/image-unit-tests.lisp Log: temporarily shut off image-data-loading-test because image->data is not currently implemented Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Mar 22 10:28:06 2006 @@ -57,8 +57,7 @@ <h3>Status</h3> - <p>The first release will be version 0.2.0 and should be - available shortly.</p> + <p>The first release, version 0.2.0, is now available.</p> <p>This library is in the early implementation stage. Brave souls who experiment with the code should expect significant API and Modified: trunk/src/tests/uitoolkit/image-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/image-unit-tests.lisp Wed Mar 22 10:28:06 2006 @@ -69,5 +69,7 @@ (unless (gfs:null-handle-p hbmp) (gfs::delete-object hbmp)))))) +#| (define-test image-data-loading-test (mapc #'image-data-tester '("blackwhite20x16.bmp" "happy.bmp" "truecolor16x16.bmp"))) +|#

1 0

[graphic-forms-cvs] r67 - tags/release-0.2.0
by junrue＠common-lisp.net 22 Mar '06

22 Mar '06

Author: junrue Date: Tue Mar 21 19:30:34 2006 New Revision: 67 Added: tags/release-0.2.0/ - copied from r66, trunk/ Log: tagging the 0.2.0 release

1 0

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

22 Mar '06

Author: junrue Date: Tue Mar 21 19:27:07 2006 New Revision: 66 Modified: trunk/README.txt trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp Log: final tweaks prior to 0.2.0 release Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Tue Mar 21 19:27:07 2006 @@ -31,6 +31,44 @@ http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html +Known Problems +-------------- + +Aside from the fact that there are a myriad number of classes, functions, +and features in general that are not yet implemented, this section lists +known problems in this release: + +1. When running the layout-tester application on CLISP, you may experience + intermittent GPFs given sufficient playing around with window sizing, + or adding/removing/hiding/showing controls if the flow layout is set to + wrap. + + This problem needs further in-depth investigation. + +2. When running the event-tester application on CLISP, you may experience + intermittent GPFs after selecting File | Start Timer to start the + timer test. + + This problem needs further in-depth investigation. + +3. Image loading currently requires installation of the ImageMagick + library as described in the next section. I have tested with Windows + BMP files (and this is what the image-tester application displays). + ImageMagick itself supports many image formats, but Graphic-Forms + has not been tested with all of them. Therefore, images may not + display properly, expecially when a transparency is selected. + +4. The event-tester application's menu definition specifies that the + Test Menu | Submenu | Item A item should be disabled but it does + not get disabled. However, the GFW:ENABLE function does otherwise + work correctly for menu items. + +5. Graphic-Forms supports CLISP 2.38 and LispWorks 4.4.6. The + intention is to support additional Lisp vendors, but currently + the library will not run on anything but CLISP or LW due to some + vendor-specific features that have to be used. + + How To Configure and Build -------------------------- Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Tue Mar 21 19:27:07 2006 @@ -131,6 +131,7 @@ ;;; (defmethod append-item ((owner menu) text image disp) + (declare (ignore image)) ; FIXME: temporary measure until we support images in menu items (let* ((tc (thread-context)) (id (increment-menuitem-id tc)) (hmenu (gfs:handle owner)) Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Tue Mar 21 19:27:07 2006 @@ -72,9 +72,6 @@ (if (gfs:disposed-p w) (error 'gfs:disposed-error))) -(defmethod (setf item-at) (index (it item) (w widget-with-items)) - (error 'gfs:toolkit-error :detail "not yet implemented")) - (defmethod item-count :before ((w widget-with-items)) (if (gfs:disposed-p w) (error 'gfs:disposed-error)))

1 0

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

22 Mar '06

Author: junrue Date: Tue Mar 21 19:00:04 2006 New Revision: 65 Modified: trunk/README.txt trunk/build.lisp trunk/docs/manual/api.texinfo trunk/docs/manual/overview.texinfo trunk/docs/manual/reference.texinfo Log: final doc updates prior to 0.2.0 release Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Tue Mar 21 19:00:04 2006 @@ -1,20 +1,15 @@ + Graphic-Forms README for version 0.2.0 Copyright (c) 2006, Jack D. Unrue -All rights reserved. Graphic-Forms is a user interface library implemented in Common Lisp focusing on the Windows(R) platform. Graphic-Forms is licensed under the terms of the BSD License. -Please provide feedback via the development mailing list: - http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel - -and/or patches via the patch tracker: - http://sourceforge.net/tracker/?atid=826147&group_id=163034&func=browse - Dependencies ------------ + Graphic-Forms depends on the following packages: - ASDF @@ -26,7 +21,7 @@ - lw-compat http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar… - - closer-mop + - Closer to MOP http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.t… - ImageMagick 6.2.6.5-Q16 @@ -39,6 +34,9 @@ How To Configure and Build -------------------------- +NOTE: in a future release, this project will be packaged for use +with asdf-install. + 1. Install ImageMagick 6.2.6.5-Q16 (note in particular that it is the Q16 version that is needed, not the Q8 version). The default installation directory is "c:/Program Files/ImageMagick-6.2.6-Q16/". @@ -120,5 +118,17 @@ (gft::run-layout-tester) +Support and Feedback +-------------------- + +Please provide feedback via the development mailing list: + http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel + +Bug reports via the bug tracking system: + http://sourceforge.net/tracker/?group_id=163034&atid=826147 + +Patches via the patch tracker: + http://sourceforge.net/tracker/?group_id=163034&atid=826147 + [the end] Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Tue Mar 21 19:00:04 2006 @@ -40,21 +40,45 @@ (in-package #:graphic-forms-system) -(defvar *library-root* "c:/projects/third_party/") -(defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) -(defvar *project-root* "c:/projects/public/") - -(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-0.9.0/")) -(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) -(setf *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") -(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) -(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(defvar *library-root* "c:/projects/third_party/") +(defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) +(defvar *project-root* "c:/projects/public/") -(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) +(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-0.9.0/")) +(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) +(setf *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") +(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) +(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) +(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) + +(defvar *asdf-system-connections-dir* (concatenate 'string *asdf-repo-root* "asdf-system-connections/")) +(defvar *cl-containers-dir* (concatenate 'string *asdf-repo-root* "cl-containers/")) +(defvar *cl-graph-dir* (concatenate 'string *asdf-repo-root* "cl-graph/")) +(defvar *cl-mathstats-dir* (concatenate 'string *asdf-repo-root* "cl-mathstats/")) +(defvar *metabang-bind-dir* (concatenate 'string *asdf-repo-root* "metabang-bind/")) +(defvar *metatilities-dir* (concatenate 'string *asdf-repo-root* "metatilities/")) +(defvar *moptilities-dir* (concatenate 'string *asdf-repo-root* "moptilities/")) +(defvar *tinaa-dir* (concatenate 'string *asdf-repo-root* "tinaa/")) + +(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") (configure-asdf) (pushnew *gf-dir* asdf:*central-registry* :test #'equal) +#| + (pushnew *tinaa-dir* asdf:*central-registry* :test #'equal) + (pushnew *cl-graph-dir* asdf:*central-registry* :test #'equal) + (pushnew *asdf-system-connections-dir* asdf:*central-registry* :test #'equal) + (pushnew *cl-mathstats-dir* asdf:*central-registry* :test #'equal) + (pushnew *cl-containers-dir* asdf:*central-registry* :test #'equal) + (pushnew *metatilities-dir* asdf:*central-registry* :test #'equal) + (pushnew *moptilities-dir* asdf:*central-registry* :test #'equal) + (pushnew *metabang-bind-dir* asdf:*central-registry* :test #'equal) + (asdf:operate 'asdf:load-op :tinaa) +|# (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit)) + +#| + (tinaa:document-system 'asdf :graphic-forms-uitoolkit "c:/projects/public/testing/") +|# Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 21 19:00:04 2006 @@ -186,14 +186,21 @@ @ref{widget}. @end deftp +@anchor{event-dispatcher} @deftp Class event-dispatcher -This is the base class for objects process events on behalf of user interface objects. +This is the base class of objects responsible for processing events on +behalf of @ref{widget}s. Applications define subclasses of +@code{event-dispatcher} and implement one or more of the @ref{event +functions} specializing on each such application-defined subclass in +order to implement desired behavior. @end deftp @anchor{event-source} @deftp Class event-source dispatcher This is the base class for user interface objects that generate events. It -derives from @ref{native-object}. +derives from @ref{native-object}. The @code{dispatcher} slot holds an +instance of @ref{event-dispatcher} that is responsible for processing +events on behalf of an @code{event-source}. @deffn Initarg :dispatcher @end deffn @deffn Accessor dispatcher @@ -337,18 +344,6 @@ Implement this to respond to a mouse down event. @end deffn -@deffn GenericFunction event-mouse-enter dispatcher widget time point button -Implement this to respond to a mouse passing into the bounds of an object. -@end deffn - -@deffn GenericFunction event-mouse-exit dispatcher widget time point button -Implement this to respond to a mouse leaving the bounds an object. -@end deffn - -@deffn GenericFunction event-mouse-hover dispatcher widget time point button -Implement this to respond to a mouse that stops moving for a period of time within an object. -@end deffn - @deffn GenericFunction event-mouse-move dispatcher widget time point button Implement this to respond to a mouse move event. @end deffn @@ -366,10 +361,6 @@ Implement this to respond to paint requests. @end deffn -@deffn GenericFunction event-pre-modify dispatcher widget time keycode char span new-content -Implement this to respond to content (e.g., text) in an object about to be modified. -@end deffn - @deffn GenericFunction event-resize dispatcher widget time size type Implement this to respond to an object being resized. @end deffn Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Tue Mar 21 19:00:04 2006 @@ -99,10 +99,10 @@ @url{http://www.common-lisp.net/mailman/listinfo/graphic-forms-cvs} The bug tracking system: @* -@url{http://sourceforge.net/tracker/?group_id=20959&atid=120959} +@url{http://sourceforge.net/tracker/?group_id=163034&atid=826145} @subsection Submitting Patches -Please use the SourceForge patch tracking mechanism to contribute patches: -@url{http://sourceforge.net/tracker/?atid=826147&group_id=163034&func=browse} +Please use the following patch tracking mechanism to contribute patches: +@url{http://sourceforge.net/tracker/?group_id=163034&atid=826147} Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Tue Mar 21 19:00:04 2006 @@ -136,7 +136,7 @@ @ifnottex @node Top -@top Graphic-Forms Programming Reference (version 0.2.0) +@top Graphic-Forms Programming Reference (version 0.2) @insertcopying @end ifnottex

1 0