[graphic-forms-cvs] r73 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Mon Mar 27 00:05:17 UTC 2006
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}.
+ at anchor{miter-limit}
+ at 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}.
+ at end deffn
+ at anchor{pen-style}
+ at deffn Accessor pen-style
+This accessor accepts or returns a list of pen style keywords. The
+primary style keywords are:
+ at table @code
+ at item :alternate
+Draws a line in which every other pixel is set.
+
+ at item :dash
+Draws a dashed line.
+
+ at item :dashdot
+Draws a line with alternating dashes and dots.
+
+ at item :dashdotdot
+Draws a line with alternating dashes and double dots.
+
+ at item :dot
+Draws a dotted line.
+
+ at item :solid
+Draws a solid line.
+ at end table
+
+One of the following end cap style keywords may also be specified:
+ at table @code
+ at item :flat-endcap
+Line end caps will be flat.
+
+ at item :round-endcap
+Line end caps will be round.
+
+ at item :square-endcap
+Line end caps will be square.
+ at end table
+
+One of the following join style keywords may also be specified:
+ at table @code
+ at item :bevel-join
+Line joins will be beveled.
+
+ at item :miter-join
+Line joins will be mitered if the ratio of miter length to line width
+is within the @ref{miter-limit}.
+
+ at item :round-join
+Line joins will be rounded.
+ at 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.
+ at end deffn
+ at anchor{pen-width}
+ at 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.
+ at 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.
+ at 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},
+ at 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
+ at 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},
+ at ref{pen-style} and @ref{pen-width}.
+ at 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
+ at 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)
More information about the Graphic-forms-cvs
mailing list