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)