graphic-forms-cvs March 2006

graphic-forms-cvs@common-lisp.net

2 participants
62 discussions

[graphic-forms-cvs] r84 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 01 Apr '06

01 Apr '06

Author: junrue Date: Fri Mar 31 18:21:19 2006 New Revision: 84 Modified: trunk/docs/manual/api.texinfo 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-types.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented :tab and :mnemonic text drawing styles; implemented text-extent method and refactored widgets package at the same time Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Mar 31 18:21:19 2006 @@ -1027,9 +1027,23 @@ using the current pen width and style. @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. +@deffn GenericFunction draw-text self text point &optional style tab-width +Draws @code{text} in the current font and foreground color, with +@code{point} being the top-left coordinate of a bounding box for the +string. The optional @code{style} parameter is a list containing the +following text style keywords: +@table @code +@item :mnemonic +underline the mnemonic character (specified in the original string +by preceding the character with an ampersand @samp{&}) +@item :tab +expand tabs when the string is rendered; by default the tab-width +is 8 characters, but the optional @code{tab-width} parameter may +be used to specify a different width +@item :transparent +@emph{This style is not yet implemented.} the background of the +rectangular area where text is drawn will not be modified +@end table @end deffn @deffn GenericFunction font self @@ -1041,12 +1055,27 @@ Returns a color object corresponding to the current foreground color. @end deffn -@deffn GenericFunction metrics self -Returns a metrics object describing key attributes of the specified object. +@deffn GenericFunction metrics self font +Returns a @ref{font-metrics} object describing key attributes of @code{font}. @end deffn @deffn GenericFunction size self -Returns a size object describing the size of the object. +Returns a size object describing the dimensions of the object. +@end deffn + +@deffn GenericFunction text-extent self text &optional style tab-width +Returns the size of a rectangular that would enclose @code{text} if it +were drawn in the current font. The optional @code{style} parameter is +a list containing the following text style keywords: +@table @code +@item :mnemonic +underline the mnemonic character (specified in the original string +by preceding the character with an ampersand @samp{&}) +@item :tab +expand tabs when the string is rendered; by default the tab-width +is 8 characters, but the optional @code{tab-width} parameter may +be used to specify a different width +@end table @end deffn @deffn GenericFunction transparency-mask self 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 31 18:21:19 2006 @@ -272,34 +272,51 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) -(defun draw-a-string (gc pnt face-name pt-size style) +(defun draw-a-string (gc pnt text face-name pt-size font-style text-style) (let* ((font (make-instance 'gfg:font :gc gc :data (gfg:make-font-data :face-name face-name - :style style + :style font-style :point-size pt-size))) (metrics (gfg:metrics gc font))) + (if (or (null text) (zerop (length text))) + (setf text face-name)) (unwind-protect (progn (setf (gfg:font gc) font) - (gfg:draw-text gc face-name pnt) + (gfg:draw-text gc text pnt text-style) (gfs:make-point :x (gfs:point-x pnt) :y (+ (gfs:point-y pnt) (gfg:height metrics)))) (gfs:dispose font)))) (defun draw-strings (gc) (setf (gfg:foreground-color gc) gfg:*color-blue*) (let ((pnt (gfs:make-point :x 2 :y 0))) - (setf pnt (draw-a-string gc pnt "Times New Roman" 10 nil)) - (setf pnt (draw-a-string gc pnt "Times New Roman" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Times New Roman" 18 '(:strikeout))) - (setf pnt (draw-a-string gc pnt "Tahoma" 10 nil)) - (setf pnt (draw-a-string gc pnt "Tahoma" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Tahoma" 18 '(:strikeout))) - (setf pnt (draw-a-string gc pnt "Lucida Console" 10 nil)) - (setf pnt (draw-a-string gc pnt "Lucida Console" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Lucida Console" 18 '(:strikeout))) - (setf pnt (draw-a-string gc pnt "Courier New" 10 nil)) - (setf pnt (draw-a-string gc pnt "Courier New" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Courier New" 18 '(:strikeout))))) + (setf pnt (draw-a-string gc pnt nil "Times New Roman" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Times New Roman" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Times New Roman" 18 '(:strikeout) nil)) + (setf pnt (draw-a-string gc pnt nil "Tahoma" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Tahoma" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Tahoma" 18 '(:strikeout) nil)) + (setf pnt (draw-a-string gc pnt nil "Lucida Console" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Lucida Console" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Lucida Console" 18 '(:strikeout) nil)) + (setf pnt (draw-a-string gc pnt nil "Courier New" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Courier New" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Courier New" 18 '(:strikeout) nil)) + + (setf (gfs:point-x pnt) (+ (floor (/ (gfs:size-width (gfw:client-size *drawing-win*)) 2)) 10)) + (setf (gfs:point-y pnt) 0) + (setf pnt (draw-a-string gc pnt (format nil "tab~ctab~ctab" #\Tab #\Tab) "Verdana" 10 nil '(:tab))) + (setf pnt (draw-a-string gc pnt (format nil "even~cmore~ctabs" #\Tab #\Tab) "Verdana" 10 nil '(:tab))) + (setf pnt (draw-a-string gc pnt " " "Verdana" 10 nil nil)) + (setf pnt (draw-a-string gc pnt "and a &mnemonic" "Verdana" 10 nil '(:mnemonic))))) + +#| + (setf pnt (draw-a-string gc pnt " " "Arial" 18 nil nil)) + (draw-a-string gc pnt "transparent" "Arial" 18 '(:bold) nil) + (incf (gfs:point-x pnt) 50) + (setf (gfg:foreground-color gc) gfg:*color-red*) + (draw-a-string gc pnt "text" "Arial" 10 '(:bold) '(:transparent)) +|# (defun select-text (disp item time rect) (declare (ignore disp time rect)) 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 31 18:21:19 2006 @@ -152,6 +152,44 @@ (error 'gfs:win32-error :detail (format nil "~a failed" name)))) (cffi:foreign-free array)))) +(defun compute-draw-text-style (style) + (let ((flags (logior gfs::+dt-noclip+ gfs::+dt-noprefix+ gfs::+dt-singleline+ gfs::+dt-vcenter+))) + (unless (null style) + (loop for sym in style + do (cond + ((eq sym :mnemonic) + (setf flags (logand flags (lognot gfs::+dt-noprefix+)))) + ((eq sym :tab) + (setf flags (logior flags gfs::+dt-expandtabs+))) + ;; FIXME: the :transparent style needs to be implemented + ;; + ((eq sym :transparent))))) + flags)) + +(defun text-bounds (hdc str dt-flags tab-width) + (let ((len (length str)) + (sz (gfs:make-size))) + (when (> len 0) + (cffi:with-foreign-object (dt-ptr 'gfs::drawtextparams) + (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin) + dt-ptr gfs::drawtextparams) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::drawtextparams)) + (setf gfs::tablength tab-width) + (setf gfs::leftmargin 0) + (setf gfs::rightmargin 0) + (cffi:with-foreign-object (rect-ptr 'gfs::rect) + (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) rect-ptr gfs::rect) + (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) + (setf (gfs:size-width sz) (- gfs::right gfs::left)) + (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))))) + (when (or (zerop len) (zerop (gfs:size-height sz))) + (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) + (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) tm-ptr gfs::textmetrics) + (if (zerop (gfs::get-text-metrics hdc tm-ptr)) + (error 'gfs:win32-error :detail "get-text-metrics failed")) + (setf (gfs:size-height sz) (+ gfs::tmheight gfs::tmexternalleading))))) + sz)) + (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-null-brush ((gc) &body body) (let ((hdc (gensym)) @@ -385,29 +423,35 @@ (with-null-brush (self) (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size))) -(defmethod draw-text ((self graphics-context) text (pnt gfs:point)) +(defmethod draw-text ((self graphics-context) text (pnt gfs:point) &optional style tab-width) (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 self) - text - -1 - rect-ptr - (logior gfs::+dt-calcrect+ gfs::+dt-singleline+) - (cffi:null-pointer)) - (gfs::draw-text (gfs:handle self) - text - (length text) - rect-ptr - (logior gfs::+dt-noclip+ - gfs::+dt-noprefix+ - gfs::+dt-singleline+ - gfs::+dt-vcenter+) - (cffi:null-pointer))))) + (let ((flags (compute-draw-text-style style)) + (tb-width (if (null tab-width) 0 tab-width))) + (cffi:with-foreign-object (dt-ptr 'gfs::drawtextparams) + (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin) + dt-ptr gfs::drawtextparams) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::drawtextparams)) + (setf gfs::tablength tb-width) + (setf gfs::leftmargin 0) + (setf gfs::rightmargin 0) + (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-ex (gfs:handle self) + text + -1 + rect-ptr + (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+))) + dt-ptr) + (gfs::draw-text-ex (gfs:handle self) + text + (length text) + rect-ptr + flags + dt-ptr))))))) (defmethod (setf font) ((font font) (self graphics-context)) (if (gfs:disposed-p self) @@ -466,3 +510,11 @@ (error 'gfs:disposed-error)) (setf (slot-value self 'pen-width) width) (update-pen-for-gc self)) + +(defmethod text-extent ((self graphics-context) str &optional style tab-width) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (text-bounds (gfs:handle self) + str + (compute-draw-text-style style) + (if (or (null tab-width) (< tab-width 0)) 0 tab-width))) 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 31 18:21:19 2006 @@ -33,27 +33,9 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defgeneric alpha (self) - (:documentation "Returns an integer representing an alpha value.")) - -(defgeneric anti-alias (self) - (:documentation "Returns an int representing the current anti-alias setting.")) - (defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) -(defgeneric background-pattern (self) - (:documentation "Returns a pattern object representing the current background pattern.")) - -(defgeneric clipped-p (self) - (:documentation "Returns T if a clipping region is set; nil otherwise.")) - -(defgeneric clipping-rectangle (self) - (:documentation "Returns a rectangle object representing the current clipping rectangle.")) - -(defgeneric copy-area (self src-rect dest-pnt) - (:documentation "Copies a rectangular area of the source onto the destination.")) - (defgeneric data-obj (self) (:documentation "Returns the data structure representing the raw form of the object.")) @@ -120,8 +102,8 @@ (defgeneric draw-rounded-rectangle (self rect size) (:documentation "Draws the outline of the rectangle with rounded corners.")) -(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 draw-text (self text pnt &optional style tab-width) + (:documentation "Draws the given string in the current font and foreground color.")) (defgeneric font (self) (:documentation "Returns the current font.")) @@ -129,65 +111,17 @@ (defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) -(defgeneric foreground-pattern (self) - (:documentation "Returns a pattern object representing the current foreground pattern.")) - -(defgeneric invert (self) - (:documentation "Returns a modified version of the object which is the mathematical inverse of the original.")) - -(defgeneric line-cap-style (self) - (:documentation "Returns an integer representing the line cap style.")) - -(defgeneric line-dash-style (self) - (:documentation "Returns a list of integers representing the line dash style.")) - -(defgeneric line-join-style (self) - (:documentation "Returns an integer representing the line join style.")) - -(defgeneric line-style (self) - (:documentation "Returns an integer representing the line style.")) - -(defgeneric line-width (self) - (:documentation "Returns an integer representing the line width.")) - (defgeneric load (self path) (:documentation "Loads the object from filesystem data identified by the specified pathname or string.")) -(defgeneric matrix (self) - (:documentation "Returns a matrix that represents the transformation or other computation represented by the object.")) - (defgeneric metrics (self font) - (:documentation "Returns a metrics object describing key attributes of the specified font.")) - -(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 (self angle) - (:documentation "Returns a modified version of the object which is the result of rotating the original by the specified angle.")) - -(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.")) + (:documentation "Returns a font-metrics object describing key attributes of the specified font.")) (defgeneric size (self) (:documentation "Returns a size object describing the size of the object.")) -(defgeneric text-anti-alias (self) - (:documentation "Returns an integer representing the text anti-alias setting.")) - -(defgeneric text-extent (self str) +(defgeneric text-extent (self str &optional style tab-width) (:documentation "Returns the size of the rectangular area that would be covered by the string if drawn in the current font.")) -(defgeneric transform (self) - (:documentation "Returns a transform object indicating how coordinates are transformed in the context of this object.")) - -(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 (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 (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 (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 Fri Mar 31 18:21:19 2006 @@ -147,7 +147,7 @@ (hdc HANDLE)) (defcfun - ("DrawTextExA" draw-text) + ("DrawTextExA" draw-text-ex) INT (hdc HANDLE) (text :string) 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 31 18:21:19 2006 @@ -114,6 +114,13 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct drawtextparams + (cbsize UINT) + (tablength INT) + (leftmargin INT) + (rightmargin INT) + (lengthdrawn UINT)) + (defcstruct logbrush (style UINT) (color COLORREF) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Mar 31 18:21:19 2006 @@ -77,7 +77,7 @@ (init-control btn)) (defmethod preferred-size ((btn button) width-hint height-hint) - (let ((sz (widget-text-size btn gfs::+dt-singleline+ 0))) + (let ((sz (widget-text-size btn gfs::+dt-singleline+))) (if (>= width-hint 0) (setf (gfs:size-width sz) width-hint) (setf (gfs:size-width sz) (+ (gfs:size-width sz) 14))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Mar 31 18:21:19 2006 @@ -97,7 +97,7 @@ gfs::+dt-expandtabs+))) (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf sz (widget-text-size label flags width-hint)) + (setf sz (widget-text-size label flags)) (if (>= width-hint 0) (setf (gfs:size-width sz) width-hint)) (if (>= height-hint 0) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Mar 31 18:21:19 2006 @@ -122,30 +122,10 @@ (error 'gfs:disposed-error)) (gfs::set-window-text (gfs:handle w) str)) -(defun widget-text-size (widget dt-flags width-hint) - (let* ((hwnd (gfs:handle widget)) - (str (text widget)) - (len (length str)) - (sz (gfs:make-size)) - (hfont nil)) - (setf dt-flags (logior dt-flags gfs::+dt-calcrect+)) +(defun widget-text-size (widget dt-flags) + (let ((hwnd (gfs:handle widget)) + (hfont nil)) (gfs::with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs::with-hfont-selected (hdc hfont) - (when (> len 0) - (cffi:with-foreign-object (rect-ptr 'gfs::rect) - (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) - rect-ptr gfs::rect) - (if (> width-hint 0) - (setf gfs::right width-hint)) - (gfs::draw-text hdc str -1 rect-ptr dt-flags (cffi:null-pointer)) - (setf (gfs:size-width sz) (- gfs::right gfs::left)) - (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))) - (when (or (zerop len) (zerop (gfs:size-height sz))) - (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) - (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) - tm-ptr gfs::textmetrics) - (if (zerop (gfs::get-text-metrics hdc tm-ptr)) - (error 'gfs:win32-error :detail "get-text-metrics failed")) - (setf (gfs:size-height sz) (+ gfs::tmheight gfs::tmexternalleading))))))) - sz)) + (gfg::text-bounds hdc (text widget) dt-flags 0)))))

1 0

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

30 Mar '06

Author: junrue Date: Thu Mar 30 00:35:00 2006 New Revision: 83 Added: trunk/etc/font-test.doc (contents, props changed) Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/font-data.lisp trunk/src/uitoolkit/graphics/font.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/magick-core-api.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp Log: implemented font selection into graphics contexts; changed data->font to take gc param in anticipation of printer support Added: trunk/etc/font-test.doc ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Thu Mar 30 00:35:00 2006 @@ -272,9 +272,34 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) +(defun draw-a-string (gc pnt face-name pt-size style) + (let* ((font (make-instance 'gfg:font :gc gc + :data (gfg:make-font-data :face-name face-name + :style style + :point-size pt-size))) + (metrics (gfg:metrics gc font))) + (unwind-protect + (progn + (setf (gfg:font gc) font) + (gfg:draw-text gc face-name pnt) + (gfs:make-point :x (gfs:point-x pnt) :y (+ (gfs:point-y pnt) (gfg:height metrics)))) + (gfs:dispose font)))) + (defun draw-strings (gc) (setf (gfg:foreground-color gc) gfg:*color-blue*) - (gfg:draw-text gc "This is a placeholder." (gfs:make-point))) + (let ((pnt (gfs:make-point :x 2 :y 0))) + (setf pnt (draw-a-string gc pnt "Times New Roman" 10 nil)) + (setf pnt (draw-a-string gc pnt "Times New Roman" 14 '(:italic :bold :underline))) + (setf pnt (draw-a-string gc pnt "Times New Roman" 18 '(:strikeout))) + (setf pnt (draw-a-string gc pnt "Tahoma" 10 nil)) + (setf pnt (draw-a-string gc pnt "Tahoma" 14 '(:italic :bold :underline))) + (setf pnt (draw-a-string gc pnt "Tahoma" 18 '(:strikeout))) + (setf pnt (draw-a-string gc pnt "Lucida Console" 10 nil)) + (setf pnt (draw-a-string gc pnt "Lucida Console" 14 '(:italic :bold :underline))) + (setf pnt (draw-a-string gc pnt "Lucida Console" 18 '(:strikeout))) + (setf pnt (draw-a-string gc pnt "Courier New" 10 nil)) + (setf pnt (draw-a-string gc pnt "Courier New" 14 '(:italic :bold :underline))) + (setf pnt (draw-a-string gc pnt "Courier New" 18 '(:strikeout))))) (defun select-text (disp item time rect) (declare (ignore disp time rect)) Modified: trunk/src/uitoolkit/graphics/font-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font-data.lisp (original) +++ trunk/src/uitoolkit/graphics/font-data.lisp Thu Mar 30 00:35:00 2006 @@ -52,7 +52,7 @@ (return-from compute-font-pitch gfs::+variable-pitch+)) gfs::+default-pitch+) -(defun data->font (data) +(defun data->font (hdc data) (let ((hfont (cffi:null-pointer)) (style (font-data-style data))) (cffi:with-foreign-object (lf-ptr 'gfs::logfont) @@ -61,7 +61,10 @@ gfs::lfstrikeout gfs::lfcharset gfs::lfoutprec gfs::lfpitchandfamily gfs::lffacename) lf-ptr gfs::logfont) - (setf gfs::lfheight (- 0 (font-data-point-size data))) + (setf gfs::lfheight (- (floor (+ (/ (* (font-data-point-size data) + (gfs::get-device-caps hdc gfs::+logpixelsy+)) + 72) + 0.5)))) (setf gfs::lfweight (compute-font-weight style)) (setf gfs::lfitalic (if (null (find :italic style)) 0 1)) (setf gfs::lfunderline (if (null (find :underline style)) 0 1)) @@ -70,9 +73,9 @@ (setf gfs::lfoutprec (compute-font-precis style)) (setf gfs::lfpitchandfamily (compute-font-pitch style)) (cffi:with-foreign-string (str (font-data-face-name data)) - (gfs::strncpy (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename) - str - (1- gfs::+lf-facesize+)))) + (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename))) + (gfs::strncpy lffacename-ptr str (1- gfs::+lf-facesize+)) + (setf (cffi:mem-aref lffacename-ptr :char (1- gfs::+lf-facesize+)) 0)))) (setf hfont (gfs::create-font-indirect lf-ptr)) (if (gfs:null-handle-p hfont) (error 'gfs:win32-error :detail "create-font-indirect failed"))) Modified: trunk/src/uitoolkit/graphics/font.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font.lisp (original) +++ trunk/src/uitoolkit/graphics/font.lisp Thu Mar 30 00:35:00 2006 @@ -42,3 +42,6 @@ (unless (gfs:null-handle-p hgdi) (gfs::delete-object hgdi))) (setf (slot-value fn 'gfs:handle) nil)) + +(defmethod initialize-instance :after ((font font) &key gc data &allow-other-keys) + (setf (slot-value font 'gfs:handle) (data->font (gfs:handle gc) data))) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Thu Mar 30 00:35:00 2006 @@ -40,7 +40,7 @@ (blue 0)) (defstruct font-data - (char-set 1) ; gfg:+default-charset+ (ie., the default for the machine) + (char-set 0) (face-name "") (point-size 10) (style nil)) @@ -63,8 +63,7 @@ (defmacro height (metrics) `(+ (gfg::font-metrics-ascent ,metrics) - (gfg::font-metrics-descent ,metrics) - (gfg::font-metrics-leading ,metrics))) + (gfg::font-metrics-descent ,metrics))) (defmacro average-char-width (metrics) `(gfg::font-metrics-avg-char-width ,metrics)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Thu Mar 30 00:35:00 2006 @@ -409,6 +409,11 @@ gfs::+dt-vcenter+) (cffi:null-pointer))))) +(defmethod (setf font) ((font font) (self graphics-context)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::select-object (gfs:handle self) (gfs:handle font))) + (defmethod foreground-color ((self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) @@ -430,6 +435,26 @@ (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+) (update-pen-for-gc self)) +(defmethod metrics ((self graphics-context) (font font)) + (if (or (gfs:disposed-p self) (gfs:disposed-p font)) + (error 'gfs:disposed-error)) + (let ((hdc (gfs:handle self)) + (hfont (gfs:handle font)) + (metrics nil)) + (gfs::with-hfont-selected (hdc hfont) + (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) + (cffi:with-foreign-slots ((gfs::tmascent gfs::tmdescent gfs::tmexternalleading + gfs::tmavgcharwidth gfs::tmmaxcharwidth) + tm-ptr gfs::textmetrics) + (if (zerop (gfs::get-text-metrics hdc tm-ptr)) + (error 'gfs:win32-error :detail "get-text-metrics failed")) + (setf metrics (make-font-metrics :ascent gfs::tmascent + :descent gfs::tmdescent + :leading gfs::tmexternalleading + :avg-char-width gfs::tmavgcharwidth + :max-char-width gfs::tmmaxcharwidth))))) + metrics)) + (defmethod (setf pen-style) :around (style (self graphics-context)) (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 Thu Mar 30 00:35:00 2006 @@ -123,9 +123,6 @@ (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 (self) - (:documentation "Returns an integer specifying the current fill rule.")) - (defgeneric font (self) (:documentation "Returns the current font.")) @@ -159,8 +156,8 @@ (defgeneric matrix (self) (:documentation "Returns a matrix that represents the transformation or other computation represented by the object.")) -(defgeneric metrics (self) - (:documentation "Returns a metrics object describing key attributes of the specified object.")) +(defgeneric metrics (self font) + (:documentation "Returns a metrics object describing key attributes of the specified font.")) (defgeneric multiply (self other) (:documentation "Returns a modified version of the object which is the result of multiplying the original with the other parameter.")) Modified: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Thu Mar 30 00:35:00 2006 @@ -190,9 +190,9 @@ (error 'gfs:toolkit-error :detail "could not allocate Magick ImageInfo object")) (unwind-protect (cffi:with-foreign-string (str ,path) - (gfs::strncpy (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename) - str - (1- +magick-max-text-extent+)) - ,@body)) + (let ((filename-ptr (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename))) + (gfs::strncpy filename-ptr str (1- +magick-max-text-extent+)) + (setf (cffi:mem-aref filename-ptr :char (1- +magick-max-text-extent+)) 0)) + ,@body) (destroy-image-info ,info) - (destroy-exception-info ,ex)))) + (destroy-exception-info ,ex))))) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Thu Mar 30 00:35:00 2006 @@ -202,6 +202,12 @@ (hdc HANDLE)) (defcfun + ("GetDeviceCaps" get-device-caps) + INT + (hdc HANDLE) + (index INT)) + +(defcfun ("GetDIBits" get-di-bits) INT (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Mar 30 00:35:00 2006 @@ -792,3 +792,47 @@ (defconstant +default-pitch+ 0) (defconstant +fixed-pitch+ 1) (defconstant +variable-pitch+ 2) + +;;; +;;; device parameters for get-device-caps +;;; +(defconstant +driverversion+ 0) +(defconstant +technology+ 2) +(defconstant +horzsize+ 4) +(defconstant +vertsize+ 6) +(defconstant +horzres+ 8) +(defconstant +vertres+ 10) +(defconstant +bitspixel+ 12) +(defconstant +planes+ 14) +(defconstant +numbrushes+ 16) +(defconstant +numpens+ 18) +(defconstant +nummarkers+ 20) +(defconstant +numfonts+ 22) +(defconstant +numcolors+ 24) +(defconstant +pdevicesize+ 26) +(defconstant +curvecaps+ 28) +(defconstant +linecaps+ 30) +(defconstant +polygonalcaps+ 32) +(defconstant +textcaps+ 34) +(defconstant +clipcaps+ 36) +(defconstant +rastercaps+ 38) +(defconstant +aspectx+ 40) +(defconstant +aspecty+ 42) +(defconstant +aspectxy+ 44) +(defconstant +logpixelsx+ 88) +(defconstant +logpixelsy+ 90) +(defconstant +sizepalette+ 104) +(defconstant +numreserved+ 106) +(defconstant +colorres+ 108) +(defconstant +physicalwidth+ 110) +(defconstant +physicalheight+ 111) +(defconstant +physicaloffsetx+ 112) +(defconstant +physicaloffsety+ 113) +(defconstant +scalingfactorx+ 114) +(defconstant +scalingfactory+ 115) +(defconstant +vrefresh+ 116) +(defconstant +desktopvertres+ 117) +(defconstant +desktophorzres+ 118) +(defconstant +bltalignment+ 119) +(defconstant +shadeblendcaps+ 120) +(defconstant +colormgmtcaps+ 121) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Mar 30 00:35:00 2006 @@ -125,14 +125,14 @@ (lfescapement LONG) (lforientation LONG) (lfweight LONG) - (lfitalic LONG) - (lfunderline LONG) - (lfstrikeout LONG) - (lfcharset LONG) - (lfoutprec LONG) - (lfclipprec LONG) - (lfquality LONG) - (lfpitchandfamily LONG) + (lfitalic BYTE) + (lfunderline BYTE) + (lfstrikeout BYTE) + (lfcharset BYTE) + (lfoutprec BYTE) + (lfclipprec BYTE) + (lfquality BYTE) + (lfpitchandfamily BYTE) (lffacename TCHAR :count 32)) ; LF_FACESIZE is 32 (defcstruct menuinfo

1 0

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

29 Mar '06

Author: junrue Date: Tue Mar 28 23:30:00 2006 New Revision: 82 Added: trunk/src/uitoolkit/graphics/font-data.lisp trunk/src/uitoolkit/graphics/graphics-constants.lisp Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.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/system/system-utils.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented font-data structure and data->font converter function, as a precursor to allowing fonts to be selected in graphics contexts Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 28 23:30:00 2006 @@ -689,6 +689,68 @@ object. @xref{font-metrics}. @end deftp +@anchor{font-data} +@deftp Structure font-data char-set face-name point-size style +This structure describes basic attributes of a font that the system font mapper +can use to match a logical @ref{font}.@*@* +The @code{face-name} slot holds the text name of the requested font. +For example, @samp{Times New Roman}.@*@* +The @code{char-set} slot identifies the character set of the requested +font. It can be one of the following values: +@itemize @bullet +@item @code{+ansi-charset+} +@item @code{+arabic-charset+} +@item @code{+baltic-charset+} +@item @code{+chinesebig5-charset+} +@item @code{+default-charset+} +@item @code{+easteurope-charset+} +@item @code{+gb2312-charset+} +@item @code{+greek-charset+} +@item @code{+hangeul-charset+} +@item @code{+hangul-charset+} +@item @code{+hebrew-charset+} +@item @code{+johab-charset+} +@item @code{+mac-charset+} +@item @code{+oem-charset+} +@item @code{+russian-charset+} +@item @code{+shiftjis-charset+} +@item @code{+symbol-charset+} +@item @code{+thai-charset+} +@item @code{+turkish-charset+} +@item @code{+vietnamese-charset+} +@end itemize +@strong{Note:} a future release will include Unicode support by +default; in the meantime, the actual character range is currently +limited to @sc{ascii}.@*@* +The @code{point-size} slot holds the font's point size. The +special value @code{0} instructs the mapper to return a font in the +default size defined for the corresponding face name and style.@*@* +The @code{style} slot holds a list of keywords that further specify attributes +of the requested font. One or more of the following may be specified: +@itemize @bullet +@item one of the following font weight keywords: +@itemize @minus +@item @code{:bold} specifies that the font should be bold +@item @code{:normal} specifies that the font should be normal weight (this is the default) +@end itemize +@item one of the following pitch keywords: +@itemize @minus +@item @code{:fixed} to request a fixed-width font +@item @code{:variable} to request a variable-width font +@end itemize +@item one of the following precision keywords: +@itemize @minus +@item @code{:truetype-only} requests that only a TrueType@registeredsymbol{} font should +be returned +@item @code{:outline} may be specified to request an outline +font or a TrueType@registeredsymbol{} font +@end itemize +@item @code{:italic} may be included to request an italic effect +@item @code{:strikeout} may be included to request a strike-through effect +@item @code{:underline} may be included to request an underline effect +@end itemize +@end deftp + @anchor{font-metrics} @deftp Structure font-metrics ascent descent leading avg-char-width max-char-width This structure describes basic attributes of a font in terms that drawing code Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Tue Mar 28 23:30:00 2006 @@ -126,7 +126,7 @@ @titlepage @title Graphic-Forms Programming Reference -@c @subtitle Version 0.2.0 +@c @subtitle Version 0.3 @c @author Jack D. Unrue @page @@ -136,7 +136,7 @@ @ifnottex @node Top -@top Graphic-Forms Programming Reference (version 0.2) +@top Graphic-Forms Programming Reference (version 0.3) @insertcopying @end ifnottex Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Mar 28 23:30:00 2006 @@ -69,12 +69,14 @@ :components ((:file "magick-core-types") (:file "magick-core-api") + (:file "graphics-constants") (:file "graphics-classes") (:file "graphics-generics") (:file "color") (:file "palette") (:file "image-data") (:file "image") + (:file "font-data") (:file "font") (:file "graphics-context"))) (:module "widgets" Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 28 23:30:00 2006 @@ -62,6 +62,7 @@ #:detail #:dispose #:disposed-p + #:flatten #:handle #:location #:make-point @@ -77,6 +78,7 @@ #:size-width #:span-start #:span-end + #:zero-mem ;; conditions #:disposed-error @@ -96,6 +98,7 @@ ;; classes and structs #:font + #:font-data #:font-metrics #:graphics-context #:image @@ -155,6 +158,10 @@ #:draw-text #:fill-rule #:font + #:font-data-char-set + #:font-data-face-name + #:font-data-point-size + #:font-data-style #:foreground-color #:foreground-pattern #:green-mask @@ -169,6 +176,8 @@ #:line-width #:load #:make-color + #:make-font-data + #:make-image-data #:matrix #:maximum-char-width #:metrics Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Tue Mar 28 23:30:00 2006 @@ -272,6 +272,16 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) +(defun draw-strings (gc) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (gfg:draw-text gc "This is a placeholder." (gfs:make-point))) + +(defun select-text (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-strings) + (gfw:redraw *drawing-win*)) + (defun draw-wedges (gc) (let* ((rect-pnt (gfs:make-point :x 5 :y 10)) (rect-size (gfs:make-size :width 80 :height 65)) @@ -305,7 +315,8 @@ (:item "&Ellipses" :callback #'select-ellipses) (:item "&Lines and Polylines" :callback #'select-lines) (:item "&Pie Wedges" :callback #'select-wedges) - (:item "&Rectangles" :callback #'select-rects))))))) + (:item "&Rectangles" :callback #'select-rects) + (:item "&Text" :callback #'select-text))))))) (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Tue Mar 28 23:30:00 2006 @@ -37,12 +37,17 @@ (defclass hellowin-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d hellowin-events) window time) - (declare (ignore time)) - (gfs:dispose window) +(defun exit-fn (disp item time rect) + (declare (ignorable disp item time rect)) + (gfs:dispose *hello-win*) + (setf *hello-win* nil) (gfw:shutdown 0)) -(defmethod gfw:event-paint ((d hellowin-events) window time gc rect) +(defmethod gfw:event-close ((disp hellowin-events) window time) + (declare (ignore window)) + (exit-fn disp nil time nil)) + +(defmethod gfw:event-paint ((disp hellowin-events) window time gc rect) (declare (ignore time)) (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfw:client-size window))) @@ -53,12 +58,6 @@ (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) -(defun exit-fn (disp item time rect) - (declare (ignorable disp item time rect)) - (gfs:dispose *hello-win*) - (setf *hello-win* nil) - (gfw:shutdown 0)) - (defun run-hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) Added: trunk/src/uitoolkit/graphics/font-data.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/font-data.lisp Tue Mar 28 23:30:00 2006 @@ -0,0 +1,79 @@ +;;;; +;;;; font-data.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.graphics) + +(defun compute-font-weight (style) + (if (null (find :bold style)) + gfs::+fw-normal+ + gfs::+fw-bold+)) + +(defun compute-font-precis (style) + (if (find :truetype-only style) + (return-from compute-font-precis gfs::+out-tt-only-precis+)) + (if (find :outline style) + (return-from compute-font-precis gfs::+out-outline-precis+)) + gfs::+out-default-precis+) + +(defun compute-font-pitch (style) + (if (find :fixed style) + (return-from compute-font-pitch gfs::+fixed-pitch+)) + (if (find :variable style) + (return-from compute-font-pitch gfs::+variable-pitch+)) + gfs::+default-pitch+) + +(defun data->font (data) + (let ((hfont (cffi:null-pointer)) + (style (font-data-style data))) + (cffi:with-foreign-object (lf-ptr 'gfs::logfont) + (gfs:zero-mem lf-ptr gfs::logfont) + (cffi:with-foreign-slots ((gfs::lfheight gfs::lfweight gfs::lfitalic gfs::lfunderline + gfs::lfstrikeout gfs::lfcharset gfs::lfoutprec + gfs::lfpitchandfamily gfs::lffacename) + lf-ptr gfs::logfont) + (setf gfs::lfheight (- 0 (font-data-point-size data))) + (setf gfs::lfweight (compute-font-weight style)) + (setf gfs::lfitalic (if (null (find :italic style)) 0 1)) + (setf gfs::lfunderline (if (null (find :underline style)) 0 1)) + (setf gfs::lfstrikeout (if (null (find :strikeout style)) 0 1)) + (setf gfs::lfcharset (font-data-char-set data)) + (setf gfs::lfoutprec (compute-font-precis style)) + (setf gfs::lfpitchandfamily (compute-font-pitch style)) + (cffi:with-foreign-string (str (font-data-face-name data)) + (gfs::strncpy (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename) + str + (1- gfs::+lf-facesize+)))) + (setf hfont (gfs::create-font-indirect lf-ptr)) + (if (gfs:null-handle-p hfont) + (error 'gfs:win32-error :detail "create-font-indirect failed"))) + hfont)) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Tue Mar 28 23:30:00 2006 @@ -39,6 +39,12 @@ (green 0) (blue 0)) + (defstruct font-data + (char-set 1) ; gfg:+default-charset+ (ie., the default for the machine) + (face-name "") + (point-size 10) + (style nil)) + (defstruct font-metrics (ascent 0) (descent 0) Added: trunk/src/uitoolkit/graphics/graphics-constants.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/graphics-constants.lisp Tue Mar 28 23:30:00 2006 @@ -0,0 +1,59 @@ +;;;; +;;;; graphics-constants.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.graphics) + +;;; The following are transcribed from WinGDI.h; +;;; specify one of them as the value of the char-set +;;; slot in the font-data structure. +;;; +(defconstant +ansi-charset+ 0) +(defconstant +default-charset+ 1) +(defconstant +symbol-charset+ 2) +(defconstant +shiftjis-charset+ 128) +(defconstant +hangeul-charset+ 129) +(defconstant +hangul-charset+ 129) +(defconstant +gb2312-charset+ 134) +(defconstant +chinesebig5-charset+ 136) +(defconstant +oem-charset+ 255) +(defconstant +johab-charset+ 130) +(defconstant +hebrew-charset+ 177) +(defconstant +arabic-charset+ 178) +(defconstant +greek-charset+ 161) +(defconstant +turkish-charset+ 162) +(defconstant +vietnamese-charset+ 163) +(defconstant +thai-charset+ 222) +(defconstant +easteurope-charset+ 238) +(defconstant +russian-charset+ 204) +(defconstant +mac-charset+ 77) +(defconstant +baltic-charset+ 186) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Tue Mar 28 23:30:00 2006 @@ -426,6 +426,8 @@ (when (null (gfs:handle self)) (setf (owns-dc self) t) (setf (slot-value self 'gfs:handle) (gfs::create-compatible-dc (cffi:null-pointer)))) + ;; ensure world-to-device transformation conformance + (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+) (update-pen-for-gc self)) (defmethod (setf pen-style) :around (style (self graphics-context)) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Mar 28 23:30:00 2006 @@ -125,6 +125,11 @@ (offset DWORD)) (defcfun + ("CreateFontIndirectA" create-font-indirect) + HANDLE + (logfont LPTR)) + +(defcfun ("CreatePen" create-pen) HANDLE (style INT) @@ -349,6 +354,12 @@ (color-use UINT)) (defcfun + ("SetGraphicsMode" set-graphics-mode) + INT + (hdc HANDLE) + (mode INT)) + +(defcfun ("SetMiterLimit" set-miter-limit) BOOL (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Mar 28 23:30:00 2006 @@ -192,13 +192,31 @@ (defconstant +eto-opaque+ #x0002) (defconstant +eto-clipped+ #x0004) -(defconstant +eto-glyph_index+ #x0010) +(defconstant +eto-glyph-index+ #x0010) (defconstant +eto-rtlreading+ #x0080) (defconstant +eto-numericslocal+ #x0400) (defconstant +eto-numericslatin+ #x0800) (defconstant +eto-ignorelanguage+ #x1000) (defconstant +eto-pdy+ #x2000) +(defconstant +ff-dontcare+ #x0000) +(defconstant +ff-roman+ #x0010) +(defconstant +ff-swiss+ #x0020) +(defconstant +ff-modern+ #x0030) +(defconstant +ff-script+ #x0040) +(defconstant +ff-decorative+ #x0050) + +(defconstant +fw-dontcare+ 0) +(defconstant +fw-thin+ 100) +(defconstant +fw-extralight+ 200) +(defconstant +fw-light+ 300) +(defconstant +fw-normal+ 400) +(defconstant +fw-medium+ 500) +(defconstant +fw-semibold+ 600) +(defconstant +fw-bold+ 700) +(defconstant +fw-extrabold+ 800) +(defconstant +fw-heavy+ 900) + (defconstant +ga-parent+ 1) (defconstant +ga-root+ 2) (defconstant +ga-rootowner+ 3) @@ -215,6 +233,10 @@ (defconstant +gcw-atom+ -32) (defconstant +gclp-hiconsm+ -34) +(defconstant +gm-compatible+ 1) +(defconstant +gm-advanced+ 2) +(defconstant +gm-last+ 3) + (defconstant +gwlp-wndproc+ -4) (defconstant +gwlp-hinstance+ -6) (defconstant +gwl-hwndparent+ -8) @@ -235,6 +257,9 @@ (defconstant +image-cursor+ 2) (defconstant +image-enhmetafile+ 3) +(defconstant +lf-facesize+ 32) +(defconstant +lf-fullfacesize+ 64) + (defconstant +lr-defaultcolor+ #x0000) (defconstant +lr-monochrome+ #x0001) (defconstant +lr-color+ #x0002) @@ -368,6 +393,18 @@ (defconstant +ocr-hand+ 32649) (defconstant +ocr-appstarting+ 32650) +(defconstant +out-default-precis+ 0) +(defconstant +out-string-precis+ 1) +(defconstant +out-character-precis+ 2) +(defconstant +out-stroke-precis+ 3) +(defconstant +out-tt-precis+ 4) +(defconstant +out-device-precis+ 5) +(defconstant +out-raster-precis+ 6) +(defconstant +out-tt-only-precis+ 7) +(defconstant +out-outline-precis+ 8) +(defconstant +out-screen-outline-precis+ 9) +(defconstant +out-ps-only-precis+ 10) + (defconstant +qs-key+ #x0001) (defconstant +qs-mousemove+ #x0002) (defconstant +qs-mousebutton+ #x0004) @@ -751,3 +788,7 @@ (defconstant +default-gui-font+ 17) (defconstant +dc-brush+ 18) (defconstant +dc-pen+ 19) + +(defconstant +default-pitch+ 0) +(defconstant +fixed-pitch+ 1) +(defconstant +variable-pitch+ 2) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Mar 28 23:30:00 2006 @@ -119,6 +119,22 @@ (color COLORREF) (hatch LONG)) +(defcstruct logfont + (lfheight LONG) + (lfwidth LONG) + (lfescapement LONG) + (lforientation LONG) + (lfweight LONG) + (lfitalic LONG) + (lfunderline LONG) + (lfstrikeout LONG) + (lfcharset LONG) + (lfoutprec LONG) + (lfclipprec LONG) + (lfquality LONG) + (lfpitchandfamily LONG) + (lffacename TCHAR :count 32)) ; LF_FACESIZE is 32 + (defcstruct menuinfo (cbsize DWORD) (mask DWORD) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Tue Mar 28 23:30:00 2006 @@ -34,6 +34,23 @@ (in-package :graphic-forms.uitoolkit.system) ;;; +;;; convenience functions +;;; + +(defun flatten (tree) + (if (cl:atom tree) + (list tree) + (mapcan (function flatten) tree))) + +;;; lifted from lispbuilder-windows/windows/util.lisp +;;; author: Frank Buss +;;; +(defmacro zero-mem (object type) + (let ((i (gensym))) + `(loop for ,i from 0 below (foreign-type-size (quote ,type)) do + (setf (mem-aref ,object :char ,i) 0)))) + +;;; ;;; convenience macros ;;; Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Mar 28 23:30:00 2006 @@ -41,7 +41,7 @@ (declare (ignore btn)) (let ((std-flags 0) (ex-flags 0)) - (setf style (flatten style)) + (setf style (gfs:flatten style)) ;; FIXME: check whether any of the primary button ;; styles were specified, default to :push-button ;; Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Mar 28 23:30:00 2006 @@ -41,7 +41,7 @@ (declare (ignore label)) (let ((std-flags 0) (ex-flags 0)) - (setf style (flatten style)) + (setf style (gfs:flatten style)) (unless (or (find :beginning style) (find :center style) (find :end style)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Tue Mar 28 23:30:00 2006 @@ -58,7 +58,7 @@ ;; ((eq sym :style-border) (setf std-flags (logior std-flags gfs::+ws-border+))))) - (flatten style)) + (gfs:flatten style)) (values std-flags ex-flags))) (defmethod initialize-instance :after ((self panel) &key parent style &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Mar 28 23:30:00 2006 @@ -107,7 +107,7 @@ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) (setf ex-flags 0)))) - (flatten style)) + (gfs:flatten style)) (values std-flags ex-flags))) (defmethod gfs:dispose ((win top-level)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Mar 28 23:30:00 2006 @@ -76,13 +76,6 @@ (cffi:null-pointer) 0)))) -;;; FIXME: move this to a common, non-UI module -;;; -(defun flatten (tree) - (if (atom tree) - (list tree) - (mapcan (function flatten) tree))) - (defun get-widget-text (w) (if (gfs:disposed-p w) (error 'gfs:disposed-error))

1 0

[graphic-forms-cvs] r81 - trunk/src/uitoolkit/system
by junrue＠common-lisp.net 28 Mar '06

28 Mar '06

Author: junrue Date: Tue Mar 28 14:44:59 2006 New Revision: 81 Modified: trunk/src/uitoolkit/system/gdi32.lisp Log: added missing binding for SetPixel Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Mar 28 14:44:59 2006 @@ -356,6 +356,14 @@ (oldlimit LPTR)) (defcfun + ("SetPixel" set-pixel) + COLORREF + (hdc HANDLE) + (x INT) + (y INT) + (color COLORREF)) + +(defcfun ("SetTextColor" set-text-color) COLORREF (hdc HANDLE)

1 0

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

28 Mar '06

Author: junrue Date: Tue Mar 28 14:42:29 2006 New Revision: 80 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/graphics/graphics-context.lisp Log: implemented draw-point drawing function Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 28 14:42:29 2006 @@ -900,7 +900,8 @@ @end deffn @deffn GenericFunction draw-image self image point -Draws @code{image} in the receiver at the specified @ref{point}. +Draws @code{image} in the receiver where @code{point} identifies the +position of the upper-left corner of the image. @end deffn @deffn GenericFunction draw-line self start-point end-point @@ -915,6 +916,10 @@ current pen style, pen width, and foreground color. @end deffn +@deffn GenericFunction draw-point self point +Draws a pixel at @code{point} in the current foreground color. +@end deffn + @deffn GenericFunction draw-poly-bezier self start-point points Draws a sequence of connected B@'ezier curves starting with @code{start-point}. @code{points} is a list of lists, each sublist containing three points, Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Tue Mar 28 14:42:29 2006 @@ -343,6 +343,14 @@ (with-null-brush (self) (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))) +(defmethod draw-point ((self graphics-context) pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::set-pixel (gfs:handle self) + (gfs:point-x pnt) + (gfs:point-y pnt) + (color->rgb (foreground-color self)))) + (defmethod draw-poly-bezier ((self graphics-context) start-pnt points) (if (gfs:disposed-p self) (error 'gfs:disposed-error))

1 0

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

28 Mar '06

Author: junrue Date: Tue Mar 28 13:16:14 2006 New Revision: 79 Modified: trunk/docs/manual/api.texinfo 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 Log: implemented rounded rectangle drawing functions; refactored drawing-tester program Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 28 13:16:14 2006 @@ -891,6 +891,14 @@ draw an outline for the rectangle. @end deffn +@deffn GenericFunction draw-filled-rounded-rectangle self rect arc-size +Fills the interior of a rectangle with rounded corners in the current +background color. The current foreground color, pen width, and pen +style will be used to draw an outline for the rectangle. The rounding +of the corners is determined by an ellipse whose height and width are +determined by @code{arc-size}. +@end deffn + @deffn GenericFunction draw-image self image point Draws @code{image} in the receiver at the specified @ref{point}. @end deffn @@ -940,6 +948,13 @@ nothing. See also @ref{draw-polygon}. @end deffn +@deffn GenericFunction draw-rounded-rectangle self rect arc-size +Draws the outline of a rectangle with rounded corners using the +current foreground color, pen width, and pen style. The rounding of +the corners is determined by an ellipse whose height and width are +determined by @code{arc-size}. +@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. Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Tue Mar 28 13:16:14 2006 @@ -76,215 +76,93 @@ (unless (null func) (funcall func gc)))) -(defun draw-bezier-test (gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 pen-styles) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) (first pen-styles)) - (gfg:draw-bezier gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) (second pen-styles)) - (gfg:draw-bezier gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 90) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 90) - :y (gfs:point-y end-pnt)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 90) - :y (gfs:point-y ctrl-pnt-1)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 90) - :y (gfs:point-y ctrl-pnt-2))) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) (third pen-styles)) - (gfg:draw-bezier gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 180) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 180) - :y (gfs:point-y end-pnt)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 180) - :y (gfs:point-y ctrl-pnt-1)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 180) - :y (gfs:point-y ctrl-pnt-2))) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-bezier gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 270) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 270) - :y (gfs:point-y end-pnt)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 270) - :y (gfs:point-y ctrl-pnt-1)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 270) - :y (gfs:point-y ctrl-pnt-2)))) - -(defun draw-line-test (gc start-pnt end-pnt pen-styles) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) (first pen-styles)) - (gfg:draw-line gc start-pnt end-pnt) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) (second pen-styles)) - (gfg:draw-line gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 90) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 90) - :y (gfs:point-y end-pnt))) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) (third pen-styles)) - (gfg:draw-line gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 180) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 180) - :y (gfs:point-y end-pnt))) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-line gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 270) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 270) - :y (gfs:point-y end-pnt)))) - -(defun draw-lines-test (gc draw-fn points pen-styles) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) (first pen-styles)) - (funcall draw-fn gc points) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) (second pen-styles)) - (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 90) - :y (gfs:point-y pnt))) - points)) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) (third pen-styles)) - (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 180) - :y (gfs:point-y pnt))) - points)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 270) - :y (gfs:point-y pnt))) - points))) - -(defun draw-rectangular-tests (gc filled-draw-fn unfilled-draw-fn) - (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)) - (funcall filled-draw-fn 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)) - (funcall filled-draw-fn 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) - (funcall filled-draw-fn 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)) - (funcall filled-draw-fn 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)) - (funcall unfilled-draw-fn 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)) - (funcall unfilled-draw-fn 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)) - (funcall unfilled-draw-fn 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)) - (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)))) +(defun clone-point (orig) + (gfs:make-point :x (gfs:point-x orig) :y (gfs:point-y orig))) -(defun draw-ellipses (gc) - (draw-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse)) +(defun clone-size (orig) + (gfs:make-size :width (gfs:size-width orig) :height (gfs:size-height orig))) -(defun select-ellipses (disp item time rect) - (declare (ignore disp time rect)) - (update-drawing-item-check item) - (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) - (gfw:redraw *drawing-win*)) +(defun set-gc-params (gc column filled) + (ecase column + (0 + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:background-color gc) gfg:*color-green*) + (if filled + (progn + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join))) + (progn + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap))))) + (1 + (setf (gfg:pen-width gc) 3) + (if filled + (setf (gfg:pen-style gc) '(:solid)) + (setf (gfg:pen-style gc) '(:dot)))) + (2 + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid))) + (3 + (setf (gfg:foreground-color gc) (gfg:background-color gc))))) + +(defun draw-rectangular (gc rect arc-size delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (if arc-size + (funcall draw-fn gc rect arc-size) + (funcall draw-fn gc rect)) + (incf (gfs:point-x (gfs:location rect)) delta-x))) + +(defun draw-start-end (gc start-pnt end-pnt delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc start-pnt end-pnt) + (loop for pnt in (list start-pnt end-pnt) do (incf (gfs:point-x pnt) delta-x)))) + +(defun draw-rect-start-end (gc rect start-pnt end-pnt delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc rect start-pnt end-pnt) + (loop for pnt in (list start-pnt end-pnt) do (incf (gfs:point-x pnt) delta-x)) + (incf (gfs:point-x (gfs:location rect)) delta-x))) + +(defun draw-points (gc points delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc points) + (loop for pnt in points do (incf (gfs:point-x pnt) delta-x)))) + +(defun draw-start-points (gc start-pnt points delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc start-pnt points) + (loop for pnt in (append (list start-pnt) points) do (incf (gfs:point-x pnt) delta-x)))) + +(defun draw-start-end-controls (gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 delta-x draw-fn) + (dotimes (i 4) + (set-gc-params gc i nil) + (funcall draw-fn gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) + (loop for pnt in (list start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) do (incf (gfs:point-x pnt) delta-x)))) (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))) + (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) + (rect-size (gfs:make-size :width 80 :height 65)) + (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (start-pnt (gfs:make-point :x 15 :y 60)) + (end-pnt (gfs:make-point :x 75 :y 25)) + (delta-x (+ (gfs:size-width rect-size) 10)) + (delta-y (+ (gfs:size-height rect-size) 10))) + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-filled-chord t) + (incf (gfs:point-y rect-pnt) delta-y) + (incf (gfs:point-y start-pnt) delta-y) + (incf (gfs:point-y end-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-chord nil) + (incf (gfs:point-y rect-pnt) delta-y) + (incf (gfs:point-y start-pnt) delta-y) + (incf (gfs:point-y end-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil))) (defun select-arcs (disp item time rect) (declare (ignore disp time rect)) @@ -297,9 +175,7 @@ (end-pnt (gfs:make-point :x 70 :y 32)) (ctrl-pnt-1 (gfs:make-point :x 40 :y 0)) (ctrl-pnt-2 (gfs:make-point :x 40 :y 65))) - (setf (gfg:background-color gc) gfg:*color-green*) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (draw-bezier-test gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 '((:dashdotdot :bevel-join) (:solid) (:solid))) + (draw-start-end-controls gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 85 #'gfg:draw-bezier) (let ((poly-pnts (list (list (gfs:make-point :x 40 :y 100) (gfs:make-point :x 35 :y 200) (gfs:make-point :x 300 :y 180)) @@ -309,7 +185,7 @@ (setf (gfg:foreground-color gc) gfg:*color-blue*) (setf (gfg:pen-width gc) 3) (setf (gfg:pen-style gc) '(:dot :square-endcap)) - (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 100) poly-pnts)))) + (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 110) poly-pnts)))) (defun select-beziers (disp item time rect) (declare (ignore disp time rect)) @@ -317,29 +193,54 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers) (gfw:redraw *drawing-win*)) +(defun draw-ellipses (gc) + (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) + (rect-size (gfs:make-size :width 80 :height 65)) + (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (delta-x (+ (gfs:size-width rect-size) 10)) + (delta-y (+ (gfs:size-height rect-size) 10))) + (draw-rectangular gc rect nil delta-x #'gfg:draw-filled-ellipse t) + (incf (gfs:point-y rect-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil))) + +(defun select-ellipses (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) + (gfw:redraw *drawing-win*)) + (defun draw-lines (gc) - (let ((orig-points (list (gfs:make-point :x 15 :y 60) - (gfs:make-point :x 75 :y 30) - (gfs:make-point :x 40 :y 10)))) - (setf (gfg:background-color gc) gfg:*color-green*) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (draw-lines-test gc #'gfg:draw-filled-polygon orig-points '((:dashdotdot :bevel-join) (:solid) (:solid))) - (draw-lines-test gc - #'gfg:draw-polygon - (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) - :y (+ (gfs:point-y pnt) 60))) - orig-points) - '((:dot :round-join :flat-endcap) (:dot) (:solid))) - (draw-lines-test gc - #'gfg:draw-polyline - (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) - :y (+ (gfs:point-y pnt) 120))) - orig-points) - '((:dot :round-join :flat-endcap) (:dot) (:solid))) - (let ((tmp (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) - :y (+ (gfs:point-y pnt) 180))) - orig-points))) - (draw-line-test gc (first tmp) (second tmp) '((:dot :round-join :flat-endcap) (:dot) (:solid)))))) + (let ((pnt-1 (gfs:make-point :x 15 :y 60)) + (pnt-2 (gfs:make-point :x 75 :y 30)) + (pnt-3 (gfs:make-point :x 40 :y 10)) + (delta-x 75) + (delta-y 60)) + (draw-points gc + (list (clone-point pnt-1) (clone-point pnt-2) (clone-point pnt-3)) + delta-x + #'gfg:draw-filled-polygon + t) + (draw-points gc + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) delta-y))) + (list pnt-1 pnt-2 pnt-3)) + delta-x + #'gfg:draw-polygon + nil) + (draw-points gc + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) (* delta-y 2)))) + (list pnt-1 pnt-2 pnt-3)) + delta-x + #'gfg:draw-polyline + nil) + (draw-start-end gc + (gfs:make-point :x (gfs:point-x pnt-1) :y (+ (gfs:point-y pnt-1) (* delta-y 3))) + (gfs:make-point :x (gfs:point-x pnt-2) :y (+ (gfs:point-y pnt-2) (* delta-y 3))) + delta-x + #'gfg:draw-line + nil))) (defun select-lines (disp item time rect) (declare (ignore disp time rect)) @@ -348,7 +249,22 @@ (gfw:redraw *drawing-win*)) (defun draw-rects (gc) - (draw-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle)) + (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) + (rect-size (gfs:make-size :width 80 :height 50)) + (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (delta-x (+ (gfs:size-width rect-size) 10)) + (delta-y (+ (gfs:size-height rect-size) 10)) + (arc-size (gfs:make-size :width 10 :height 10))) + (draw-rectangular gc rect arc-size delta-x #'gfg:draw-filled-rounded-rectangle t) + (incf (gfs:point-y rect-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rectangular gc rect nil delta-x #'gfg:draw-filled-rectangle t) + (incf (gfs:point-y rect-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rectangular gc rect arc-size delta-x #'gfg:draw-rounded-rectangle nil) + (incf (gfs:point-y rect-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil))) (defun select-rects (disp item time rect) (declare (ignore disp time rect)) @@ -357,58 +273,20 @@ (gfw:redraw *drawing-win*)) (defun draw-wedges (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 35 :y 75)) - (end-pnt (gfs:make-point :x 85 :y 35)) - (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-pie-wedge 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-pie-wedge 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-pie-wedge 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-pie-wedge 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) 35) - (setf (gfs:point-x end-pnt) 85) - (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-pie-wedge 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-pie-wedge 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-pie-wedge 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-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt))) + (let* ((rect-pnt (gfs:make-point :x 5 :y 10)) + (rect-size (gfs:make-size :width 80 :height 65)) + (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (delta-x (+ (gfs:size-width rect-size) 10)) + (delta-y (gfs:size-height rect-size)) + (start-pnt (gfs:make-point :x 35 :y 75)) + (end-pnt (gfs:make-point :x 85 :y 35))) + + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-filled-pie-wedge t) + (incf (gfs:point-y rect-pnt) delta-y) + (incf (gfs:point-y start-pnt) delta-y) + (incf (gfs:point-y end-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil))) (defun select-wedges (disp item time rect) (declare (ignore disp time rect)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Tue Mar 28 13:16:14 2006 @@ -107,6 +107,19 @@ (+ (gfs:point-y pnt) (gfs:size-height size)))) (error 'gfs:toolkit-error :detail (format nil "~a failed" name))))) +(defun call-rounded-rect-function (fn name hdc rect arc-size) + (let ((pnt (gfs:location rect)) + (size (gfs:size rect))) + (if (zerop (funcall fn + 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)) + (gfs:size-width arc-size) + (gfs:size-height arc-size))) + (error 'gfs:toolkit-error :detail (format nil "~a failed" name))))) + (defun call-rect-and-range-function (fn name hdc rect start-pnt end-pnt) (let ((rect-pnt (gfs:location rect)) (rect-size (gfs:size rect))) @@ -232,45 +245,6 @@ (error 'gfs:disposed-error)) (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect)) -(defmethod draw-line ((self graphics-context) start-pnt end-pnt) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) - -(defmethod draw-pie-wedge ((self graphics-context) rect start-pnt end-pnt) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (with-null-brush (self) - (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))) - -(defmethod draw-poly-bezier ((self graphics-context) start-pnt points) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (unless (null points) - (let ((tmp (loop for triplet in points - append (list (second triplet) (third triplet) (first triplet))))) - (push start-pnt tmp) - (call-points-function #'gfs::poly-bezier "poly-bezier" (gfs:handle self) tmp)))) - -(defmethod draw-polygon ((self graphics-context) points) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (unless (< (length points) 3) - (with-null-brush (self) - (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points)))) - -(defmethod draw-polyline ((self graphics-context) points) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (unless (< (length points) 2) - (call-points-function #'gfs::polyline "polyline" (gfs:handle self) points))) - -(defmethod draw-rectangle ((self graphics-context) (rect gfs:rectangle)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (with-null-brush (self) - (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))) - ;;; FIXME: consider preserving this version as a "fast path" ;;; rectangle filler. ;;; @@ -298,6 +272,11 @@ (cffi:null-pointer)))))) |# +(defmethod draw-filled-rounded-rectangle ((self graphics-context) rect size) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size)) + ;;; ;;; TODO: support addressing elements within bitmap as if it were an array ;;; @@ -353,6 +332,51 @@ 0 0 gfs::+blt-srccopy+))))) (gfs::delete-dc memdc))) +(defmethod draw-line ((self graphics-context) start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) + +(defmethod draw-pie-wedge ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))) + +(defmethod draw-poly-bezier ((self graphics-context) start-pnt points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (null points) + (let ((tmp (loop for triplet in points + append (list (second triplet) (third triplet) (first triplet))))) + (push start-pnt tmp) + (call-points-function #'gfs::poly-bezier "poly-bezier" (gfs:handle self) tmp)))) + +(defmethod draw-polygon ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 3) + (with-null-brush (self) + (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points)))) + +(defmethod draw-polyline ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 2) + (call-points-function #'gfs::polyline "polyline" (gfs:handle self) points))) + +(defmethod draw-rectangle ((self graphics-context) rect) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))) + +(defmethod draw-rounded-rectangle ((self graphics-context) rect size) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size))) + (defmethod draw-text ((self graphics-context) text (pnt gfs:point)) (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 Tue Mar 28 13:16:14 2006 @@ -87,7 +87,7 @@ (defgeneric draw-filled-rectangle (self rect) (:documentation "Fills the interior of a rectangle in the current background color.")) -(defgeneric draw-filled-rounded-rectangle (self rect arc-width arc-height) +(defgeneric draw-filled-rounded-rectangle (self rect size) (:documentation "Fills the interior of the rectangle with rounded corners.")) (defgeneric draw-filled-wedge (self rect start-pnt end-pnt) @@ -117,7 +117,7 @@ (defgeneric draw-rectangle (self rect) (:documentation "Draws the outline of a rectangle in the current foreground color.")) -(defgeneric draw-rounded-rectangle (self rect arc-width arc-height) +(defgeneric draw-rounded-rectangle (self rect size) (:documentation "Draws the outline of the rectangle with rounded corners.")) (defgeneric draw-text (self text pnt) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Mar 28 13:16:14 2006 @@ -297,6 +297,17 @@ (y2 INT)) (defcfun + ("RoundRect" round-rect) + BOOL + (hdc HANDLE) + (rectleft INT) + (recttop INT) + (rectright INT) + (rectbottom INT) + (width INT) + (height INT)) + +(defcfun ("SelectObject" select-object) HANDLE (hdc HANDLE)

1 0

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

28 Mar '06

Author: junrue Date: Tue Mar 28 00:30:06 2006 New Revision: 78 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 Log: implemented pie wedge drawing functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 28 00:30:06 2006 @@ -798,41 +798,41 @@ @end deffn @anchor{draw-arc} -@deffn GenericFunction draw-arc self rect start-pnt end-pnt +@deffn GenericFunction draw-arc self rect start-point end-point 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 +@code{end-point} 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 +style, pen width, and foreground color. If @code{start-point} and +@code{end-point} are the same, a complete ellipse is drawn. See also @ref{draw-chord}. @end deffn -@deffn GenericFunction draw-bezier self start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 -Draws a B@'ezier curve between @code{start-pnt} and @code{end-pnt} -using @code{ctrl-pnt-1} and @code{ctrl-pnt-2} as the control -points. The curve is drawn using the current pen style, pen widget, +@deffn GenericFunction draw-bezier self start-point end-point ctrl-point-1 ctrl-point-2 +Draws a B@'ezier curve between @code{start-point} and @code{end-point} +using @code{ctrl-point-1} and @code{ctrl-point-2} as the control +points. The curve is drawn using the current pen style, pen width, and foreground color. @end deffn @anchor{draw-chord} -@deffn GenericFunction draw-chord self rect start-pnt end-pnt +@deffn GenericFunction draw-chord self rect start-point end-point 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 +rectangle. The arc ends at the point @code{end-point} where it intersects another radial also originating at the center of the rectangle. @item -a line drawn between start-pnt and end-pnt +a line drawn between start-point and end-point @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 +foreground color. If @code{start-point} and @code{end-point} are the same, a complete ellipse is drawn. See also @ref{draw-arc}. @end deffn @@ -843,22 +843,22 @@ @end deffn @anchor{draw-filled-chord} -@deffn GenericFunction draw-filled-chord self rect start-pnt end-pnt +@deffn GenericFunction draw-filled-chord self rect start-point end-point 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 +rectangle. The arc ends at the point @code{end-point} where it intersects another radial also originating at the center of the rectangle. @item -a line drawn between start-pnt and end-pnt +a line drawn between start-point and end-point @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 +@code{start-point} and @code{end-point} are the same, a complete ellipse is drawn. @end deffn @@ -869,6 +869,14 @@ color. @end deffn +@deffn GenericFunction draw-filled-pie-wedge self rect start-point end-point +Fills a pie-shaped wedge whose arc is defined by the ellipse bound by +@code{rect} and its intersection with the radials defined by +@code{start-point} and @code{end-point}. The shape is drawn using the +current pen style, pen width, and foreground color, and filled with +the current background color. +@end deffn + @deffn GenericFunction draw-filled-polygon self points Fills the interior of a closed shape comprised by the line segments defined by @code{points} in the current background color. The current @@ -892,8 +900,15 @@ current pen style, pen width, and foreground color. @end deffn -@deffn GenericFunction draw-poly-bezier self start-pnt points -Draws a sequence of connected B@'ezier curves starting with @code{start-pnt}. +@deffn GenericFunction draw-pie-wedge self rect start-point end-point +Draws a pie-shaped wedge whose arc is defined by the ellipse bound +by @code{rect} and its intersection with the radials defined by +@code{start-point} and @code{end-point}. The shape is drawn using the +current pen style, pen width, and foreground color. +@end deffn + +@deffn GenericFunction draw-poly-bezier self start-point points +Draws a sequence of connected B@'ezier curves starting with @code{start-point}. @code{points} is a list of lists, each sublist containing three points, where: @itemize @bullet @@ -903,7 +918,7 @@ @code{(second points)} and @code{(third points)} are the segment's control points. @end itemize -The aggregate curve is drawn using the current pen style, pen widget, +The combined curve is drawn using the current pen style, pen width, and foreground color. @end deffn Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 28 00:30:06 2006 @@ -138,12 +138,14 @@ #:draw-filled-arc #:draw-filled-chord #:draw-filled-ellipse + #:draw-filled-pie-wedge #:draw-filled-polygon #:draw-filled-rectangle #:draw-filled-rounded-rectangle #:draw-focus #:draw-image #:draw-line + #:draw-pie-wedge #:draw-point #:draw-poly-bezier #:draw-polygon Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Tue Mar 28 00:30:06 2006 @@ -356,6 +356,66 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) +(defun draw-wedges (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 35 :y 75)) + (end-pnt (gfs:make-point :x 85 :y 35)) + (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-pie-wedge 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-pie-wedge 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-pie-wedge 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-pie-wedge 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) 35) + (setf (gfs:point-x end-pnt) 85) + (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-pie-wedge 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-pie-wedge 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-pie-wedge 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-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt))) + +(defun select-wedges (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges) + (gfw:redraw *drawing-win*)) + (defun run-drawing-tester-internal () (setf *last-checked-drawing-item* nil) (let ((menubar (gfw:defmenu ((:item "&File" @@ -366,6 +426,7 @@ (:item "&B�zier Curves" :callback #'select-beziers) (:item "&Ellipses" :callback #'select-ellipses) (:item "&Lines and Polylines" :callback #'select-lines) + (:item "&Pie Wedges" :callback #'select-wedges) (:item "&Rectangles" :callback #'select-rects))))))) (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Tue Mar 28 00:30:06 2006 @@ -216,6 +216,11 @@ (error 'gfs:disposed-error)) (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect)) +(defmethod draw-filled-pie-wedge ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt)) + (defmethod draw-filled-polygon ((self graphics-context) points) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) @@ -232,6 +237,12 @@ (error 'gfs:disposed-error)) (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) +(defmethod draw-pie-wedge ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))) + (defmethod draw-poly-bezier ((self graphics-context) start-pnt points) (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 Tue Mar 28 00:30:06 2006 @@ -78,6 +78,9 @@ (defgeneric draw-filled-ellipse (self rect) (:documentation "Fills the interior of the ellipse defined by a rectangle.")) +(defgeneric draw-filled-pie-wedge (self rect start-pnt end-pnt) + (:documentation "Filles the interior of a pie-shaped wedge.")) + (defgeneric draw-filled-polygon (self points) (:documentation "Fills the interior of the closed polygon defined by points.")) @@ -90,12 +93,15 @@ (defgeneric draw-filled-wedge (self rect start-pnt end-pnt) (:documentation "Fills the interior of an elliptical arc within the rectangle.")) -(defgeneric draw-image (self im pnt) - (:documentation "Draws the given image in the receiver at the specified coordinates.")) +(defgeneric draw-image (self image pnt) + (:documentation "Draws an image at the specified coordinates.")) (defgeneric draw-line (self start-pnt end-pnt) (:documentation "Draws a line using the foreground color between start-pnt and end-pnt.")) +(defgeneric draw-pie-wedge (self rect start-pnt end-pnt) + (:documentation "Draws a pie-shaped wedge defined by the intersection of an ellipse and two radials.")) + (defgeneric draw-point (self pnt) (:documentation "Draws a pixel in the foreground color at the specified point.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Mar 28 00:30:06 2006 @@ -43,10 +43,10 @@ ("Arc" arc) BOOL (hdc HANDLE) - (leftrect INT) - (toprect INT) - (rightrect INT) - (bottomrect INT) + (rectleft INT) + (recttop INT) + (rectright INT) + (rectbottom INT) (startx INT) (starty INT) (endx INT) @@ -155,10 +155,10 @@ ("Ellipse" ellipse) BOOL (hdc HANDLE) - (leftrect INT) - (toprect INT) - (rightrect INT) - (bottomrect INT)) + (rectleft INT) + (recttop INT) + (rectright INT) + (rectbottom INT)) (defcfun ("ExtCreatePen" ext-create-pen) @@ -254,6 +254,19 @@ (rop DWORD)) (defcfun + ("Pie" pie) + BOOL + (hdc HANDLE) + (rectleft INT) + (recttop INT) + (rightrect INT) + (bottomrect INT) + (radial1x INT) + (radial1y INT) + (radial2x INT) + (radial2y INT)) + +(defcfun ("PolyBezier" poly-bezier) BOOL (hdc HANDLE)

1 0

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

28 Mar '06

Author: junrue Date: Mon Mar 27 20:34:51 2006 New Revision: 77 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 Log: implement bezier curve drawing functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Mar 27 20:34:51 2006 @@ -810,6 +810,13 @@ @ref{draw-chord}. @end deffn +@deffn GenericFunction draw-bezier self start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 +Draws a B@'ezier curve between @code{start-pnt} and @code{end-pnt} +using @code{ctrl-pnt-1} and @code{ctrl-pnt-2} as the control +points. The curve is drawn using the current pen style, pen widget, +and foreground color. +@end deffn + @anchor{draw-chord} @deffn GenericFunction draw-chord self rect start-pnt end-pnt Draws a closed shape comprised of: @@ -885,6 +892,21 @@ current pen style, pen width, and foreground color. @end deffn +@deffn GenericFunction draw-poly-bezier self start-pnt points +Draws a sequence of connected B@'ezier curves starting with @code{start-pnt}. +@code{points} is a list of lists, each sublist containing three points, +where: +@itemize @bullet +@item +@code{(first points)} is the current segment's end point +@item +@code{(second points)} and @code{(third points)} are the segment's +control points. +@end itemize +The aggregate curve is drawn using the current pen style, pen widget, +and foreground color. +@end deffn + @anchor{draw-polygon} @deffn GenericFunction draw-polygon self points Draws a series of connected line segments determined by the list of Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 27 20:34:51 2006 @@ -132,6 +132,7 @@ #:depth #:descent #:draw-arc + #:draw-bezier #:draw-chord #:draw-ellipse #:draw-filled-arc @@ -144,6 +145,7 @@ #:draw-image #:draw-line #:draw-point + #:draw-poly-bezier #:draw-polygon #:draw-polyline #:draw-rectangle Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Mar 27 20:34:51 2006 @@ -76,6 +76,44 @@ (unless (null func) (funcall func gc)))) +(defun draw-bezier-test (gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 pen-styles) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) (first pen-styles)) + (gfg:draw-bezier gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) (second pen-styles)) + (gfg:draw-bezier gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 90) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 90) + :y (gfs:point-y end-pnt)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 90) + :y (gfs:point-y ctrl-pnt-1)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 90) + :y (gfs:point-y ctrl-pnt-2))) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) (third pen-styles)) + (gfg:draw-bezier gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 180) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 180) + :y (gfs:point-y end-pnt)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 180) + :y (gfs:point-y ctrl-pnt-1)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 180) + :y (gfs:point-y ctrl-pnt-2))) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-bezier gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 270) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 270) + :y (gfs:point-y end-pnt)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 270) + :y (gfs:point-y ctrl-pnt-1)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 270) + :y (gfs:point-y ctrl-pnt-2)))) + (defun draw-line-test (gc start-pnt end-pnt pen-styles) (setf (gfg:foreground-color gc) gfg:*color-blue*) (setf (gfg:pen-width gc) 5) @@ -254,6 +292,31 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (gfw:redraw *drawing-win*)) +(defun draw-beziers (gc) + (let ((start-pnt (gfs:make-point :x 10 :y 32)) + (end-pnt (gfs:make-point :x 70 :y 32)) + (ctrl-pnt-1 (gfs:make-point :x 40 :y 0)) + (ctrl-pnt-2 (gfs:make-point :x 40 :y 65))) + (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (draw-bezier-test gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 '((:dashdotdot :bevel-join) (:solid) (:solid))) + (let ((poly-pnts (list (list (gfs:make-point :x 40 :y 100) + (gfs:make-point :x 35 :y 200) + (gfs:make-point :x 300 :y 180)) + (list (gfs:make-point :x 260 :y 190) + (gfs:make-point :x 140 :y 150) + (gfs:make-point :x 80 :y 200))))) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:dot :square-endcap)) + (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 100) poly-pnts)))) + +(defun select-beziers (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers) + (gfw:redraw *drawing-win*)) + (defun draw-lines (gc) (let ((orig-points (list (gfs:make-point :x 15 :y 60) (gfs:make-point :x 75 :y 30) @@ -300,6 +363,7 @@ (:item "&Tests" :callback #'find-checked-item :submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs) + (:item "&B�zier Curves" :callback #'select-beziers) (:item "&Ellipses" :callback #'select-ellipses) (:item "&Lines and Polylines" :callback #'select-lines) (:item "&Rectangles" :callback #'select-rects))))))) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 27 20:34:51 2006 @@ -186,6 +186,14 @@ (error 'gfs:disposed-error)) (call-rect-and-range-function #'gfs::arc "arc" (gfs:handle self) rect start-pnt end-pnt)) +(defmethod draw-bezier ((self graphics-context) start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-points-function #'gfs::poly-bezier + "poly-bezier" + (gfs:handle self) + (list start-pnt ctrl-pnt-1 ctrl-pnt-2 end-pnt))) + (defmethod draw-chord ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) @@ -224,6 +232,15 @@ (error 'gfs:disposed-error)) (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) +(defmethod draw-poly-bezier ((self graphics-context) start-pnt points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (null points) + (let ((tmp (loop for triplet in points + append (list (second triplet) (third triplet) (first triplet))))) + (push start-pnt tmp) + (call-points-function #'gfs::poly-bezier "poly-bezier" (gfs:handle self) tmp)))) + (defmethod draw-polygon ((self graphics-context) points) (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 Mon Mar 27 20:34:51 2006 @@ -63,6 +63,9 @@ (defgeneric draw-arc (self rect start-pnt end-pnt) (:documentation "Draws the outline of an elliptical arc within the specified rectangular area.")) +(defgeneric draw-bezier (self start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) + (:documentation "Draws a Bezier curve between start-pnt and end-pnt.")) + (defgeneric draw-chord (self rect start-pnt end-pnt) (:documentation "Draws a region bounded by the intersection of an ellipse and a line segment.")) @@ -96,6 +99,9 @@ (defgeneric draw-point (self pnt) (:documentation "Draws a pixel in the foreground color at the specified point.")) +(defgeneric draw-poly-bezier (self start-pnt points) + (:documentation "Draws a series of connected Bezier curves.")) + (defgeneric draw-polygon (self points) (:documentation "Draws the closed polygon defined by the list of points.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 27 20:34:51 2006 @@ -254,6 +254,13 @@ (rop DWORD)) (defcfun + ("PolyBezier" poly-bezier) + BOOL + (hdc HANDLE) + (points LPTR) + (count DWORD)) + +(defcfun ("Polygon" polygon) BOOL (hdc HANDLE)

1 0

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

28 Mar '06

Author: junrue Date: Mon Mar 27 18:29:40 2006 New Revision: 76 Modified: trunk/docs/manual/api.texinfo 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 Log: implement line, polyline, and polygon drawing functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Mar 27 18:29:40 2006 @@ -862,14 +862,45 @@ color. @end deffn +@deffn GenericFunction draw-filled-polygon self points +Fills the interior of a closed shape comprised by the line segments +defined by @code{points} in the current background color. The current +foreground color, pen width, and pen style will be used to draw the +line segments. If @code{points} contains less than three points, then +this function does nothing. +@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. @end deffn -@deffn GenericFunction draw-image self im pnt -Draws the given image in the receiver at the specified coordinates. +@deffn GenericFunction draw-image self image point +Draws @code{image} in the receiver at the specified @ref{point}. +@end deffn + +@deffn GenericFunction draw-line self start-point end-point +Draws a line from @code{start-point} to @code{end-point} using the +current pen style, pen width, and foreground color. +@end deffn + +@anchor{draw-polygon} +@deffn GenericFunction draw-polygon self points +Draws a series of connected line segments determined by the list of +@code{points} using the current pen style, pen width, and foreground +color. The last point in the list is connected with the first. If +@code{points} contains less than three points, then this function does +nothing. See also @ref{draw-polyline}. +@end deffn + +@anchor{draw-polyline} +@deffn GenericFunction draw-polyline self points +Draws a series of connected line segments determined by the list of +@code{points} using the current pen style, pen width, and foreground +color. The last point in the list is not connected with the first. If +@code{points} contains less than two points, then this function does +nothing. See also @ref{draw-polygon}. @end deffn @deffn GenericFunction draw-rectangle self rect Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Mar 27 18:29:40 2006 @@ -76,7 +76,53 @@ (unless (null func) (funcall func gc)))) -(defun draw-simple-rectangular-tests (gc filled-draw-fn unfilled-draw-fn) +(defun draw-line-test (gc start-pnt end-pnt pen-styles) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) (first pen-styles)) + (gfg:draw-line gc start-pnt end-pnt) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) (second pen-styles)) + (gfg:draw-line gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 90) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 90) + :y (gfs:point-y end-pnt))) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) (third pen-styles)) + (gfg:draw-line gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 180) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 180) + :y (gfs:point-y end-pnt))) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-line gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 270) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 270) + :y (gfs:point-y end-pnt)))) + +(defun draw-lines-test (gc draw-fn points pen-styles) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) (first pen-styles)) + (funcall draw-fn gc points) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) (second pen-styles)) + (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 90) + :y (gfs:point-y pnt))) + points)) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) (third pen-styles)) + (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 180) + :y (gfs:point-y pnt))) + points)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 270) + :y (gfs:point-y pnt))) + points))) + +(defun draw-rectangular-tests (gc filled-draw-fn unfilled-draw-fn) (let ((pnt (gfs:make-point :x 15 :y 15)) (size (gfs:make-size :width 80 :height 65))) @@ -107,7 +153,6 @@ (setf (gfg:pen-style gc) '(:dot)) (funcall unfilled-draw-fn 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)) (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) @@ -116,7 +161,7 @@ (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)))) (defun draw-ellipses (gc) - (draw-simple-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse)) + (draw-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse)) (defun select-ellipses (disp item time rect) (declare (ignore disp time rect)) @@ -209,8 +254,38 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (gfw:redraw *drawing-win*)) +(defun draw-lines (gc) + (let ((orig-points (list (gfs:make-point :x 15 :y 60) + (gfs:make-point :x 75 :y 30) + (gfs:make-point :x 40 :y 10)))) + (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (draw-lines-test gc #'gfg:draw-filled-polygon orig-points '((:dashdotdot :bevel-join) (:solid) (:solid))) + (draw-lines-test gc + #'gfg:draw-polygon + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) 60))) + orig-points) + '((:dot :round-join :flat-endcap) (:dot) (:solid))) + (draw-lines-test gc + #'gfg:draw-polyline + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) 120))) + orig-points) + '((:dot :round-join :flat-endcap) (:dot) (:solid))) + (let ((tmp (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) 180))) + orig-points))) + (draw-line-test gc (first tmp) (second tmp) '((:dot :round-join :flat-endcap) (:dot) (:solid)))))) + +(defun select-lines (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-lines) + (gfw:redraw *drawing-win*)) + (defun draw-rects (gc) - (draw-simple-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle)) + (draw-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle)) (defun select-rects (disp item time rect) (declare (ignore disp time rect)) @@ -226,6 +301,7 @@ :callback #'find-checked-item :submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs) (:item "&Ellipses" :callback #'select-ellipses) + (:item "&Lines and Polylines" :callback #'select-lines) (:item "&Rectangles" :callback #'select-rects))))))) (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 27 18:29:40 2006 @@ -55,11 +55,11 @@ (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")) + (error 'gfs:toolkit-error :detail "main pen style keyword [:alternate | :dash | :dashdotdot | :dot | :solid] 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")) + (error 'gfs:toolkit-error :detail "only one end cap pen style keyword [:flat-endcap | :round-endcap | :square-endcap] is allowed")) (setf native-style (logior native-style (if tmp (cdr (assoc (car tmp) endcap-styles)) 0))) (unless (null tmp) @@ -67,7 +67,7 @@ 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")) + (error 'gfs:toolkit-error :detail "only one join pen style keyword [:bevel-join | :miter-join | :round-join] is allowed")) (setf native-style (logior native-style (if tmp (cdr (assoc (car tmp) join-styles)) 0))) (unless (null tmp) @@ -122,6 +122,23 @@ (gfs:point-y end-pnt))) (error 'gfs:win32-error :detail (format nil "~a failed" name))))) +(defun call-points-function (fn name hdc points) + (let* ((count (length points)) + (array (cffi:foreign-alloc 'gfs::point :count count))) + (unwind-protect + (progn + (loop for pnt in points + with i = 0 + do (progn + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:mem-aref array 'gfs::point i) gfs::point) + (setf gfs::x (gfs:point-x pnt)) + (setf gfs::y (gfs:point-y pnt))) + (incf i))) + (if (zerop (funcall fn hdc array count)) + (error 'gfs:win32-error :detail (format nil "~a failed" name)))) + (cffi:foreign-free array)))) + (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-null-brush ((gc) &body body) (let ((hdc (gensym)) @@ -173,13 +190,13 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (with-null-brush (self) - (draw-filled-chord self rect start-pnt end-pnt))) + (call-rect-and-range-function #'gfs::chord "chord" (gfs:handle self) rect start-pnt end-pnt))) (defmethod draw-ellipse ((self graphics-context) rect) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (with-null-brush (self) - (draw-filled-ellipse self rect))) + (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect))) (defmethod draw-filled-chord ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) @@ -191,16 +208,40 @@ (error 'gfs:disposed-error)) (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect)) +(defmethod draw-filled-polygon ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 3) + (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points))) + (defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect)) +(defmethod draw-line ((self graphics-context) start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) + +(defmethod draw-polygon ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 3) + (with-null-brush (self) + (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points)))) + +(defmethod draw-polyline ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 2) + (call-points-function #'gfs::polyline "polyline" (gfs:handle self) points))) + (defmethod draw-rectangle ((self graphics-context) (rect gfs:rectangle)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (with-null-brush (self) - (draw-filled-rectangle self rect))) + (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))) ;;; FIXME: consider preserving this version as a "fast path" ;;; rectangle filler. Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Mar 27 18:29:40 2006 @@ -76,43 +76,37 @@ (:documentation "Fills the interior of the ellipse defined by a rectangle.")) (defgeneric draw-filled-polygon (self points) - (:documentation "Fills the interior of the closed polygon defined by points in the current background color.")) + (:documentation "Fills the interior of the closed polygon defined by points.")) (defgeneric draw-filled-rectangle (self rect) (:documentation "Fills the interior of a rectangle in the current background color.")) (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.")) + (:documentation "Fills the interior of the rectangle with rounded corners.")) (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) - (:documentation "Draws a rectangle having the appearance of a focus rectangle.")) + (:documentation "Fills the interior of an elliptical arc within the rectangle.")) (defgeneric draw-image (self im pnt) (:documentation "Draws the given image in the receiver at the specified coordinates.")) -(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 (self rect) - (:documentation "Draws the outline of an oval in the foreground color with the specified rectangular area.")) +(defgeneric draw-line (self start-pnt end-pnt) + (:documentation "Draws a line using the foreground color between start-pnt and end-pnt.")) (defgeneric draw-point (self pnt) (:documentation "Draws a pixel in the foreground color at the specified point.")) (defgeneric draw-polygon (self points) - (:documentation "Draws the closed polygon defined by the list of points in the current foreground color.")) + (:documentation "Draws the closed polygon defined by the list of points.")) (defgeneric draw-polyline (self points) - (:documentation "Draws the polyline defined by the list of points in the current foreground color.")) + (:documentation "Draws the polyline defined by the list of points.")) (defgeneric draw-rectangle (self rect) (:documentation "Draws the outline of a rectangle in the current foreground color.")) (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.")) + (:documentation "Draws the outline of the rectangle with rounded corners.")) (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.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 27 18:29:40 2006 @@ -254,6 +254,20 @@ (rop DWORD)) (defcfun + ("Polygon" polygon) + BOOL + (hdc HANDLE) + (points LPTR) + (count INT)) + +(defcfun + ("Polyline" polyline) + BOOL + (hdc HANDLE) + (points LPTR) + (count INT)) + +(defcfun ("Rectangle" rectangle) BOOL (hdc HANDLE)

1 0

[graphic-forms-cvs] r75 - 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: Mon Mar 27 01:21:13 2006 New Revision: 75 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 Log: implemented ellipse drawing functions; refactored shape drawing code Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Mar 27 01:21:13 2006 @@ -829,6 +829,12 @@ same, a complete ellipse is drawn. See also @ref{draw-arc}. @end deffn +@deffn GenericFunction draw-ellipse self rect +Draws the outline of an ellipse whose center is the center of +@code{rect}. The shape is drawn using the current pen style, pen +width, and foreground color. +@end deffn + @anchor{draw-filled-chord} @deffn GenericFunction draw-filled-chord self rect start-pnt end-pnt Draws a closed shape comprised of: @@ -849,6 +855,13 @@ is drawn. @end deffn +@deffn GenericFunction draw-filled-ellipse self rect +Fills the interior of an ellipse whose center is the center of +@code{rect}. The shape is drawn using the current pen style, pen +width, and foreground color, and filled with the current background +color. +@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 Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 27 01:21:13 2006 @@ -133,16 +133,16 @@ #:descent #:draw-arc #:draw-chord + #:draw-ellipse #:draw-filled-arc #:draw-filled-chord - #:draw-filled-oval + #:draw-filled-ellipse #:draw-filled-polygon #:draw-filled-rectangle #:draw-filled-rounded-rectangle #:draw-focus #:draw-image #:draw-line - #:draw-oval #:draw-point #:draw-polygon #:draw-polyline Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Mar 27 01:21:13 2006 @@ -76,6 +76,54 @@ (unless (null func) (funcall func gc)))) +(defun draw-simple-rectangular-tests (gc filled-draw-fn unfilled-draw-fn) + (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)) + (funcall filled-draw-fn 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)) + (funcall filled-draw-fn 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) + (funcall filled-draw-fn 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)) + (funcall filled-draw-fn 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)) + (funcall unfilled-draw-fn 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)) + (funcall unfilled-draw-fn 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)) + (funcall unfilled-draw-fn 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)) + (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)))) + +(defun draw-ellipses (gc) + (draw-simple-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse)) + +(defun select-ellipses (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) + (gfw:redraw *drawing-win*)) + (defun draw-arcs (gc) (let ((rect-pnt (gfs:make-point :x 15 :y 10)) (rect-size (gfs:make-size :width 80 :height 65)) @@ -162,42 +210,7 @@ (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))) - - (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:background-color gc)) - (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)))) + (draw-simple-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle)) (defun select-rects (disp item time rect) (declare (ignore disp time rect)) @@ -212,6 +225,7 @@ (:item "&Tests" :callback #'find-checked-item :submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs) + (:item "&Ellipses" :callback #'select-ellipses) (:item "&Rectangles" :callback #'select-rects))))))) (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 27 01:21:13 2006 @@ -96,6 +96,45 @@ (unless (gfs:null-handle-p old-hpen) (gfs::delete-object old-hpen))))))) +(defun call-rect-function (fn name hdc rect) + (let ((pnt (gfs:location rect)) + (size (gfs:size rect))) + (if (zerop (funcall fn + 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)))) + (error 'gfs:toolkit-error :detail (format nil "~a failed" name))))) + +(defun call-rect-and-range-function (fn name hdc rect start-pnt end-pnt) + (let ((rect-pnt (gfs:location rect)) + (rect-size (gfs:size rect))) + (if (zerop (funcall fn + hdc + (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 (format nil "~a failed" name))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-null-brush ((gc) &body body) + (let ((hdc (gensym)) + (tmp-hbr (gensym)) + (orig-hbr (gensym))) + `(let* ((,hdc (gfs:handle ,gc)) + (,tmp-hbr (gfs::get-stock-object gfs::+null-brush+)) + (,orig-hbr (gfs::select-object ,hdc ,tmp-hbr))) + (unwind-protect + (progn + ,@body) + (gfs::select-object ,hdc ,orig-hbr)))))) + ;;; ;;; methods ;;; @@ -128,66 +167,40 @@ (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")))) + (call-rect-and-range-function #'gfs::arc "arc" (gfs:handle self) rect start-pnt end-pnt)) (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)))) + (with-null-brush (self) + (draw-filled-chord self rect start-pnt end-pnt))) + +(defmethod draw-ellipse ((self graphics-context) rect) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (draw-filled-ellipse self rect))) (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")))) + (call-rect-and-range-function #'gfs::chord "chord" (gfs:handle self) rect start-pnt end-pnt)) + +(defmethod draw-filled-ellipse ((self graphics-context) rect) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect)) (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))) - (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))))) + (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect)) (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)))) + (with-null-brush (self) + (draw-filled-rectangle self rect))) ;;; FIXME: consider preserving this version as a "fast path" ;;; rectangle filler. Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Mar 27 01:21:13 2006 @@ -66,11 +66,14 @@ (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-ellipse (self rect) + (:documentation "Draws an ellipse defined by a rectangle.")) + (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 (self rect) - (:documentation "Fills the interior of the oval defined by a rectangle in the current background color.")) +(defgeneric draw-filled-ellipse (self rect) + (:documentation "Fills the interior of the ellipse defined by a rectangle.")) (defgeneric draw-filled-polygon (self points) (:documentation "Fills the interior of the closed polygon defined by points in the current background color.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 27 01:21:13 2006 @@ -152,6 +152,15 @@ (params LPTR)) (defcfun + ("Ellipse" ellipse) + BOOL + (hdc HANDLE) + (leftrect INT) + (toprect INT) + (rightrect INT) + (bottomrect INT)) + +(defcfun ("ExtCreatePen" ext-create-pen) HANDLE (style DWORD)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

graphic-forms-cvs March 2006