- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

[graphic-forms-cvs] r86 - in trunk: . src/demos/unblocked src/uitoolkit/graphics
by junrue＠common-lisp.net 03 Apr '06

03 Apr '06

Author: junrue Date: Mon Apr 3 01:13:51 2006 New Revision: 86 Added: trunk/src/demos/unblocked/tiles-panel.lisp - copied, changed from r85, trunk/src/demos/unblocked/unblocked-panel.lisp Removed: trunk/src/demos/unblocked/unblocked-panel.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp Log: initial tile painting implemented; fixed a bitmap leak in draw-image Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Apr 3 01:13:51 2006 @@ -64,7 +64,7 @@ ((:file "tiles") (:file "unblocked-model") (:file "scoreboard-panel") - (:file "unblocked-panel") + (:file "tiles-panel") (:file "unblocked-window"))))) (:module "tests" :components Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Mon Apr 3 01:13:51 2006 @@ -33,6 +33,10 @@ (in-package :graphic-forms.uitoolkit.tests) +(defconstant +level-label+ "Level:") +(defconstant +points-needed-label+ "Points Needed:") +(defconstant +score-label+ "Score:") + (defclass scoreboard-panel-events (gfw:event-dispatcher) ((label-font :accessor label-font-of @@ -54,6 +58,13 @@ (gfs:dispose tmp-font) (setf (label-font-of self) nil)))) +(defmethod gfw:event-paint ((self scoreboard-panel-events) window time gc rect) + (declare (ignore time rect)) + (setf (gfg:background-color gc) gfg:*color-black*) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) + :size (gfw:client-size window)))) + + (defmethod initialize-instance :after ((self scoreboard-panel-events) &key) (let ((gc (make-instance 'gfg:graphics-context)) (label-font-data (gfg:make-font-data :face-name "Tahoma" @@ -69,7 +80,7 @@ (setf font (make-instance 'gfg:font :gc gc :data label-font-data) (label-font-of self) font (gfg:font gc) font - extent-size (gfg:text-extent gc "Next Level Score:") + extent-size (gfg:text-extent gc +points-needed-label+) (gfs:size-width pref-size) (gfs:size-width extent-size) (gfs:size-height pref-size) (* (gfs:size-height extent-size) 4)) (setf font (make-instance 'gfg:font :gc gc :data value-font-data) Copied: trunk/src/demos/unblocked/tiles-panel.lisp (from r85, trunk/src/demos/unblocked/unblocked-panel.lisp) ============================================================================== --- trunk/src/demos/unblocked/unblocked-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Apr 3 01:13:51 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; unblocked-panel.lisp +;;;; tiles-panel.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -44,7 +44,7 @@ (gfs:make-point :x (floor (/ (gfs:point-x pnt) +tile-bmp-width+)) :y (floor (/ (gfs:point-y pnt) +tile-bmp-height+)))) -(defclass unblocked-panel-events (gfw:event-dispatcher) +(defclass tiles-panel-events (gfw:event-dispatcher) ((image-buffer :accessor image-buffer-of :initform (make-instance 'gfg:image :size (gfs:make-size :width (* +horz-tile-count+ @@ -55,7 +55,7 @@ :accessor tile-image-table-of :initform (make-hash-table :test #'equal)))) -(defmethod dispose ((self unblocked-panel-events)) +(defmethod dispose ((self tiles-panel-events)) (let ((image (image-buffer-of self)) (table (tile-image-table-of self))) (gfs:dispose image) @@ -66,11 +66,11 @@ (setf (image-buffer-of self) nil) (setf (tile-image-table-of self) nil)) -(defmethod gfw:event-paint ((self unblocked-panel-events) window time gc rect) +(defmethod gfw:event-paint ((self tiles-panel-events) window time gc rect) (declare (ignore window time rect)) (gfg:draw-image gc (image-buffer-of self) (gfs:make-point))) -(defmethod initialize-instance :after ((self unblocked-panel-events) &key) +(defmethod initialize-instance :after ((self tiles-panel-events) &key) (let ((table (tile-image-table-of self)) (kind 1)) (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "gold-tile.bmp" @@ -80,24 +80,28 @@ (setf (gethash kind table) image) (incf kind))))) -(defmethod update-buffer ((self unblocked-panel-events) tiles) +(defmethod update-buffer ((self tiles-panel-events) tiles) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) - (image-table (tile-image-table-of self))) + (image-table (tile-image-table-of self)) + (pixel-pnt (gfs:make-point))) (setf (gfg:background-color gc) gfg:*color-black*) (setf (gfg:foreground-color gc) gfg:*color-black*) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfg:size (image-buffer-of self)))) (map-tiles #'(lambda (pnt kind) - (let ((image (gethash kind image-table))) - (gfg:draw-image gc image (tiles->window pnt)))) - tiles))) + (unless (= kind 0) + (let ((image (gethash kind image-table))) + (gfg:with-transparency (image pixel-pnt) + (gfg:draw-image gc image (tiles->window pnt)))))) + tiles) + (gfs:dispose gc))) -(defclass unblocked-panel (gfw:panel) ()) +(defclass tiles-panel (gfw:panel) ()) -(defmethod gfs:dispose ((self unblocked-panel)) +(defmethod gfs:dispose ((self tiles-panel)) (dispose (gfw:dispatcher self)) (call-next-method)) -(defmethod gfw:preferred-size ((self unblocked-panel) width-hint height-hint) +(defmethod gfw:preferred-size ((self tiles-panel) width-hint height-hint) (declare (ignore width-hint height-hint)) (gfg:size (image-buffer-of (gfw:dispatcher self)))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Apr 3 01:13:51 2006 @@ -36,10 +36,17 @@ (defconstant +spacing+ 4) (defconstant +margin+ 4) +(defvar *scoreboard-panel* nil) +(defvar *tiles-panel* nil) (defvar *unblocked-win* nil) (defun new-unblocked (disp item time rect) - (declare (ignore disp item time rect))) + (declare (ignore disp item time rect)) + (let ((tiles-disp (gfw:dispatcher *tiles-panel*)) + (tiles (init-tiles +horz-tile-count+ +vert-tile-count+ 5))) + (collapse-tiles tiles) + (update-buffer tiles-disp tiles) + (gfw:redraw *tiles-panel*))) (defun restart-unblocked (disp item time rect) (declare (ignore disp item time rect))) @@ -49,6 +56,8 @@ (defun quit-unblocked (disp item time rect) (declare (ignore disp item time rect)) + (setf *scoreboard-panel* nil) + (setf *tiles-panel* nil) (gfs:dispose *unblocked-win*) (setf *unblocked-win* nil) (gfw:shutdown 0)) @@ -68,14 +77,17 @@ (:item "E&xit" :callback #'quit-unblocked))))))) (setf *unblocked-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'unblocked-win-events) :layout (make-instance 'gfw:flow-layout + :style :vertical :spacing +spacing+ - :margin +margin+) + :margins +margin+) :style '(:workspace))) (setf (gfw:menu-bar *unblocked-win*) menubar) - (make-instance 'scoreboard-panel :parent *unblocked-win* - :dispatcher (make-instance 'scoreboard-panel-events)) - (make-instance 'unblocked-panel :parent *unblocked-win* - :dispatcher (make-instance 'unblocked-panel-events)) + (setf *scoreboard-panel* (make-instance 'scoreboard-panel + :parent *unblocked-win* + :dispatcher (make-instance 'scoreboard-panel-events))) + (setf *tiles-panel* (make-instance 'tiles-panel + :parent *unblocked-win* + :dispatcher (make-instance 'tiles-panel-events))) (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") (gfw:pack *unblocked-win*) (gfw:show *unblocked-win* t))) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Apr 3 01:13:51 2006 @@ -333,40 +333,44 @@ (error 'gfs:disposed-error)) (let ((gc-dc (gfs:handle self)) (himage (gfs:handle im)) + (tr-mask nil) (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (if (not (null (transparency-pixel-of im))) - (let ((hmask (gfs:handle (transparency-mask im))) - (hcopy (clone-bitmap himage)) - (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) - (black (make-color :red 0 :green 0 :blue 0)) - (white (make-color :red #xFF :green #xFF :blue #xFF))) - (gfs::select-object memdc hmask) - (gfs::select-object memdc2 hcopy) - (gfs::set-bk-color memdc2 (color->rgb black)) - (gfs::set-text-color memdc2 (color->rgb white)) - (gfs::bit-blt memdc2 - 0 0 - gfs::width - gfs::height - memdc - 0 0 gfs::+blt-srcand+) - (gfs::bit-blt gc-dc - (gfs:point-x pnt) - (gfs:point-y pnt) - gfs::width - gfs::height - memdc - 0 0 gfs::+blt-srcand+) - (gfs::bit-blt gc-dc - (gfs:point-x pnt) - (gfs:point-y pnt) - gfs::width - gfs::height - memdc2 - 0 0 gfs::+blt-srcpaint+)) + (progn + (setf tr-mask (transparency-mask im)) + (let ((hmask (gfs:handle tr-mask)) + (hcopy (clone-bitmap himage)) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) + (black (make-color :red 0 :green 0 :blue 0)) + (white (make-color :red #xFF :green #xFF :blue #xFF))) + (gfs::select-object memdc hmask) + (gfs::select-object memdc2 hcopy) + (gfs::set-bk-color memdc2 (color->rgb black)) + (gfs::set-text-color memdc2 (color->rgb white)) + (gfs::bit-blt memdc2 + 0 0 + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfs:point-x pnt) + (gfs:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfs:point-x pnt) + (gfs:point-y pnt) + gfs::width + gfs::height + memdc2 + 0 0 gfs::+blt-srcpaint+)) + (gfs:dispose tr-mask)) (progn (gfs::select-object memdc himage) (gfs::bit-blt gc-dc

1 0

[graphic-forms-cvs] r85 - in trunk: . docs/manual src/demos src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Apr '06

03 Apr '06

Author: junrue Date: Sun Apr 2 23:24:46 2006 New Revision: 85 Added: trunk/src/demos/ trunk/src/demos/unblocked/ trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/blue-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/brown-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/gold-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/green-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/pink-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/red-tile.bmp (contents, props changed) Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image.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-generics.lisp Log: initial code for blocks game Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 2 23:24:46 2006 @@ -299,8 +299,30 @@ @anchor{top-level} @deftp Class top-level -Base class for @ref{window}s that can be moved and resized by the -user, and which normally have title bars. +Base class for @ref{window}s that are self-contained and parented to +the @ref{root-window}. Except for the @code{:palette} style, they are +normally resizable have title bars (also called 'captions'). +@deffn Initarg :style +The :style initarg is a list of keywords that define the overall +look-and-feel of the window being created. Applications may choose +from one of the following primary style keywords: +@table @code +@item :borderless +a window with a one-pixel border (so not really @emph{borderless} in the +strictest sense); no frame icon, system menu, minimize/maximize buttons, +or close buttons +@item :miniframe +a resizable window with a shorter than normal caption; has a close box +but no system menu or minimize/maximize buttons +@item :palette +similar to the @code{:miniframe} style, but in this case the window +does not have resize frame +@item :workspace +the standard top-level frame style with system menu, close box, and +minimize/maximize buttons; this window is resizable and normally hosts +the primary user interface for an application +@end table +@end deffn @end deftp @anchor{widget} Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Apr 2 23:24:46 2006 @@ -35,7 +35,15 @@ (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) - (:use :common-lisp :lisp-unit)) + (:use :common-lisp :lisp-unit) + (:export + #:run-drawing-tester + #:run-event-tester + #:run-hello-world + #:run-image-tester + #:run-layout-tester + #:run-windlg + #:unblocked)) (print "Graphic-Forms UI Toolkit Tests") (print "Copyright (c) 2006 by Jack D. Unrue") @@ -49,7 +57,16 @@ :components ((:module "src" :components - ((:module "tests" + ((:module "demos" + :components + ((:module "unblocked" + :components + ((:file "tiles") + (:file "unblocked-model") + (:file "scoreboard-panel") + (:file "unblocked-panel") + (:file "unblocked-window"))))) + (:module "tests" :components ((:module "uitoolkit" :components Added: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,87 @@ +;;;; +;;;; scoreboard-panel.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defclass scoreboard-panel-events (gfw:event-dispatcher) + ((label-font + :accessor label-font-of + :initform nil) + (value-font + :accessor value-font-of + :initform nil) + (size + :accessor size-of + :initform (gfs:make-size)))) + +(defmethod dispose ((self scoreboard-panel-events)) + (let ((tmp-font (label-font-of self))) + (unless (null tmp-font) + (gfs:dispose tmp-font) + (setf (label-font-of self) nil)) + (setf tmp-font (value-font-of self)) + (unless (null tmp-font) + (gfs:dispose tmp-font) + (setf (label-font-of self) nil)))) + +(defmethod initialize-instance :after ((self scoreboard-panel-events) &key) + (let ((gc (make-instance 'gfg:graphics-context)) + (label-font-data (gfg:make-font-data :face-name "Tahoma" + :point-size 14 + :style '(:bold))) + (value-font-data (gfg:make-font-data :face-name "Tahoma" + :point-size 14)) + (extent-size nil) + (pref-size (gfs:make-size)) + (font nil)) + (unwind-protect + (progn + (setf font (make-instance 'gfg:font :gc gc :data label-font-data) + (label-font-of self) font + (gfg:font gc) font + extent-size (gfg:text-extent gc "Next Level Score:") + (gfs:size-width pref-size) (gfs:size-width extent-size) + (gfs:size-height pref-size) (* (gfs:size-height extent-size) 4)) + (setf font (make-instance 'gfg:font :gc gc :data value-font-data) + (value-font-of self) font + (gfg:font gc) font + extent-size (gfg:text-extent gc (format nil "~c9,999,999" #\Tab))) + (incf (gfs:size-width pref-size) (gfs:size-width extent-size)) + (setf (size-of self) pref-size)) + (gfs:dispose gc)))) + +(defclass scoreboard-panel (gfw:panel) ()) + +(defmethod gfw:preferred-size ((self scoreboard-panel) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (size-of (gfw:dispatcher self))) Added: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/tiles.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,115 @@ +;;;; +;;;; tiles.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defstruct tile (kind 0) (location (gfs:make-point))) + +(defun init-tiles (width height kinds) + (let* ((tiles (make-array width :initial-element nil))) + (dotimes (i width) + (let ((column (make-array height :initial-element 0))) + (setf (aref tiles i) column) + (dotimes (j height) + (setf (aref column j) (random (1+ kinds)))))) + tiles)) + +(defun size-tiles (tiles) + (gfs:make-size :width (length tiles) :height (length (aref tiles 0)))) + +(defun map-tiles (func tiles) + (let ((size (size-tiles tiles))) + (dotimes (j (gfs:size-height size)) + (dotimes (i (gfs:size-width size)) + (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j)))) + (funcall func (gfs:make-point :x i :y j) kind)))))) + +(defun print-tiles (tiles) + (let ((size (size-tiles tiles))) + (dotimes (j (gfs:size-height size)) + (dotimes (i (gfs:size-width size)) + (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j)))) + (if (< kind 0) + (print " ") + (format t "~d " kind)))) + (format t "~%")))) + +(defun eql-point (pnt1 pnt2) + (and (= (gfs:point-x pnt1) (gfs:point-x pnt2)) + (= (gfs:point-y pnt1) (gfs:point-y pnt2)))) + +(defun obtain-tile (tiles pnt) + (let ((column (aref tiles (gfs:point-x pnt)))) + (aref column (gfs:point-y pnt)))) + +(defun neighbor-point (tiles orig-pnt delta-x delta-y) + (let ((size (size-tiles tiles)) + (new-x (+ (gfs:point-x orig-pnt) delta-x)) + (new-y (+ (gfs:point-y orig-pnt) delta-y))) + (unless (or (< new-x 0) + (< new-y 0) + (>= new-x (gfs:size-width size)) + (>= new-y (gfs:size-height size))) + (return-from neighbor-point (gfs:make-point :x new-x :y new-y))) + nil)) + +(defun neighbor-points (tiles orig-pnt) + (loop for pnt in (list (neighbor-point tiles orig-pnt 0 -1) + (neighbor-point tiles orig-pnt 0 1) + (neighbor-point tiles orig-pnt -1 0) + (neighbor-point tiles orig-pnt 1 0)) + when (not (null pnt)) + collect pnt)) + +(defun shape-tiles (tiles tile-pnt results) + (when (null (gethash tile-pnt results)) + (let ((kind (obtain-tile tiles tile-pnt))) + (setf (gethash tile-pnt results) kind) + (loop for pnt2 in (neighbor-points tiles tile-pnt) + when (= kind (obtain-tile tiles pnt2)) + do (shape-tiles tiles pnt2 results))))) + +(defun collapse-column (column-tiles) + (let ((new-column (make-array (length column-tiles) :initial-element 0)) + (new-index 0)) + (dotimes (i (length column-tiles)) + (let ((kind (aref column-tiles i))) + (unless (zerop kind) + (setf (aref new-column new-index) kind) + (incf new-index)))) + new-column)) + +(defun collapse-tiles (tiles) + (let ((size (size-tiles tiles))) + (dotimes (i (gfs:size-width size)) + (setf (aref tiles i) (collapse-column (aref tiles i)))))) Added: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; unblocked-model.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defconstant +max-tile-kinds+ 6) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +horz-tile-count+ 14) + (defconstant +vert-tile-count+ 9)) Added: trunk/src/demos/unblocked/unblocked-panel.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-panel.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,103 @@ +;;;; +;;;; unblocked-panel.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defconstant +tile-bmp-width+ 24) +(defconstant +tile-bmp-height+ 24) + +(defun tiles->window (pnt) + (gfs:make-point :x (* (gfs:point-x pnt) +tile-bmp-width+) + :y (* (gfs:point-y pnt) +tile-bmp-height+))) + +(defun window->tiles (pnt) + (gfs:make-point :x (floor (/ (gfs:point-x pnt) +tile-bmp-width+)) + :y (floor (/ (gfs:point-y pnt) +tile-bmp-height+)))) + +(defclass unblocked-panel-events (gfw:event-dispatcher) + ((image-buffer + :accessor image-buffer-of + :initform (make-instance 'gfg:image :size (gfs:make-size :width (* +horz-tile-count+ + +tile-bmp-width+) + :height (* +vert-tile-count+ + +tile-bmp-height+)))) + (tile-image-table + :accessor tile-image-table-of + :initform (make-hash-table :test #'equal)))) + +(defmethod dispose ((self unblocked-panel-events)) + (let ((image (image-buffer-of self)) + (table (tile-image-table-of self))) + (gfs:dispose image) + (maphash #'(lambda (kind image) + (declare (ignore kind)) + (gfs:dispose image)) + table)) + (setf (image-buffer-of self) nil) + (setf (tile-image-table-of self) nil)) + +(defmethod gfw:event-paint ((self unblocked-panel-events) window time gc rect) + (declare (ignore window time rect)) + (gfg:draw-image gc (image-buffer-of self) (gfs:make-point))) + +(defmethod initialize-instance :after ((self unblocked-panel-events) &key) + (let ((table (tile-image-table-of self)) + (kind 1)) + (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "gold-tile.bmp" + "green-tile.bmp" "pink-tile.bmp" "red-tile.bmp") + do (let ((image (make-instance 'gfg:image))) + (gfg:load image filename) + (setf (gethash kind table) image) + (incf kind))))) + +(defmethod update-buffer ((self unblocked-panel-events) tiles) + (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) + (image-table (tile-image-table-of self))) + (setf (gfg:background-color gc) gfg:*color-black*) + (setf (gfg:foreground-color gc) gfg:*color-black*) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) + :size (gfg:size (image-buffer-of self)))) + (map-tiles #'(lambda (pnt kind) + (let ((image (gethash kind image-table))) + (gfg:draw-image gc image (tiles->window pnt)))) + tiles))) + +(defclass unblocked-panel (gfw:panel) ()) + +(defmethod gfs:dispose ((self unblocked-panel)) + (dispose (gfw:dispatcher self)) + (call-next-method)) + +(defmethod gfw:preferred-size ((self unblocked-panel) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (gfg:size (image-buffer-of (gfw:dispatcher self)))) Added: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,84 @@ +;;;; +;;;; unblocked-window.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defconstant +spacing+ 4) +(defconstant +margin+ 4) + +(defvar *unblocked-win* nil) + +(defun new-unblocked (disp item time rect) + (declare (ignore disp item time rect))) + +(defun restart-unblocked (disp item time rect) + (declare (ignore disp item time rect))) + +(defun reveal-unblocked (disp item time rect) + (declare (ignore disp item time rect))) + +(defun quit-unblocked (disp item time rect) + (declare (ignore disp item time rect)) + (gfs:dispose *unblocked-win*) + (setf *unblocked-win* nil) + (gfw:shutdown 0)) + +(defclass unblocked-win-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp unblocked-win-events) window time) + (declare (ignore window time)) + (quit-unblocked disp nil nil nil)) + +(defun unblocked-startup () + (let ((menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "&New" :callback #'new-unblocked) + (:item "&Restart" :callback #'restart-unblocked) + (:item "Reveal &Move" :callback #'reveal-unblocked) + (:item "" :separator) + (:item "E&xit" :callback #'quit-unblocked))))))) + (setf *unblocked-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'unblocked-win-events) + :layout (make-instance 'gfw:flow-layout + :spacing +spacing+ + :margin +margin+) + :style '(:workspace))) + (setf (gfw:menu-bar *unblocked-win*) menubar) + (make-instance 'scoreboard-panel :parent *unblocked-win* + :dispatcher (make-instance 'scoreboard-panel-events)) + (make-instance 'unblocked-panel :parent *unblocked-win* + :dispatcher (make-instance 'unblocked-panel-events)) + (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") + (gfw:pack *unblocked-win*) + (gfw:show *unblocked-win* t))) + +(defun unblocked () + (gfw:startup "UnBlocked" #'unblocked-startup)) Added: trunk/src/tests/uitoolkit/blue-tile.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/brown-tile.bmp ============================================================================== 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 Sun Apr 2 23:24:46 2006 @@ -362,7 +362,7 @@ (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* - :style '(:style-workspace))) + :style '(:workspace))) (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Apr 2 23:24:46 2006 @@ -227,7 +227,7 @@ (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu :submenu ((:item "Timer" :callback #'manage-timer) (:item "" :separator) Added: trunk/src/tests/uitoolkit/gold-tile.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/green-tile.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Apr 2 23:24:46 2006 @@ -61,7 +61,7 @@ (defun run-hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) (setf (gfw:menu-bar *hello-win*) menubar) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Apr 2 23:24:46 2006 @@ -102,7 +102,7 @@ (gfg::load *bw-image* "blackwhite20x16.bmp") (gfg::load *true-image* "truecolor16x16.bmp") (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf (gfw:size *image-win*) (gfs:make-size :width 250 :height 200)) (setf (gfw:text *image-win*) "Image Tester") (setf menubar (gfw:defmenu ((:item "&File" Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Apr 2 23:24:46 2006 @@ -348,7 +348,7 @@ (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'layout-tester-events) - :style '(:style-workspace) + :style '(:workspace) :layout (make-instance 'gfw:flow-layout :spacing +spacing-delta+ :margins +margin-delta+))) Added: trunk/src/tests/uitoolkit/pink-tile.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/red-tile.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Apr 2 23:24:46 2006 @@ -73,7 +73,7 @@ (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* - :style '(:style-borderless)))) + :style '(:borderless)))) (setf (gfw:size window) (gfs:make-size :width 300 :height 250)) (gfw:center-on-owner window) (gfw:show window t))) @@ -82,7 +82,7 @@ (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* - :style '(:style-miniframe)))) + :style '(:miniframe)))) (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (setf (gfw:text window) "Mini Frame") @@ -92,7 +92,7 @@ (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* - :style '(:style-palette)))) + :style '(:palette)))) (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (setf (gfw:text window) "Palette") @@ -101,7 +101,7 @@ (defun run-windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) (:item "&Windows" Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Apr 2 23:24:46 2006 @@ -88,8 +88,11 @@ (:documentation "This class encapsulates a realized native font.")) (defclass graphics-context (gfs:native-object) - ((owns-dc - :accessor owns-dc + ((dc-destructor + :accessor dc-destructor-of + :initform nil) + (widget-handle + :accessor widget-handle-of :initform nil) (logbrush-style :accessor logbrush-style-of Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Apr 2 23:24:46 2006 @@ -179,6 +179,10 @@ (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 0 + gfs::right 0 + gfs::top 0 + gfs::bottom 0) (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))))))) @@ -228,9 +232,13 @@ (setf (orig-pen-handle-of self) nil) (gfs::delete-object (pen-handle-of self)) (setf (pen-handle-of self) nil) - (if (owns-dc self) - (gfs::delete-dc (gfs:handle self))) - (setf (slot-value self 'gfs:handle) nil)) + (let ((fn (dc-destructor-of self))) + (unless (null fn) + (if (null (widget-handle-of self)) + (funcall fn (gfs:handle self)) + (funcall fn (widget-handle-of self) (gfs:handle self))))) + (setf (widget-handle-of self) nil) + (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) (defmethod draw-arc ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) @@ -471,10 +479,20 @@ (setf (logbrush-color-of self) rgb) (update-pen-for-gc self))) -(defmethod initialize-instance :after ((self graphics-context) &key) +(defmethod initialize-instance :after ((self graphics-context) &key image widget &allow-other-keys) (when (null (gfs:handle self)) - (setf (owns-dc self) t) - (setf (slot-value self 'gfs:handle) (gfs::create-compatible-dc (cffi:null-pointer)))) + (let ((hdc (cffi:null-pointer))) + (if (null widget) + (progn + (setf hdc (gfs::create-compatible-dc (cffi:null-pointer))) + (setf (dc-destructor-of self) #'gfs::delete-dc)) + (progn + (setf hdc (gfs::get-dc (gfs:handle widget))) + (setf (dc-destructor-of self) #'gfs::release-dc) + (setf (widget-handle-of self) (gfs:handle widget)))) + (setf (slot-value self 'gfs:handle) hdc) + (unless (null image) + (gfs::select-object hdc (gfs:handle image))))) ;; ensure world-to-device transformation conformance (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+) (update-pen-for-gc self)) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Apr 2 23:24:46 2006 @@ -81,12 +81,44 @@ (gfs:dispose im)) (setf (slot-value im 'gfs:handle) (data->image id))) +(defmethod initialize-instance :after ((image image) &key size &allow-other-keys) + (unless (null size) + (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) + (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes + gfs::bibitcount gfs::bicompression) + bih-ptr gfs::bitmapinfoheader) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width size) + gfs::biheight (- (gfs:size-height size)) + gfs::biplanes 1 + gfs::bibitcount 32 + gfs::bicompression gfs::+bi-rgb+) + (let ((nptr (cffi:null-pointer)) + (hbmp (cffi:null-pointer))) + (cffi:with-foreign-object (buffer :pointer) + (gfs::with-compatible-dcs (nptr memdc) + (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) + (setf (slot-value image 'gfs:handle) hbmp)))))) + (defmethod load ((im image) path) (let ((data (make-instance 'image-data))) (load data path) (setf (data-obj im) data) data)) +(defmethod size ((image image)) + (if (gfs:disposed-p image) + (error 'gfs:disposed-error)) + (let ((size (gfs:make-size)) + (himage (gfs:handle image))) + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (setf (gfs:size-width size) gfs::width + (gfs:size-height size) gfs::height))) + size)) + (defmethod transparency-mask ((im image)) (if (gfs:disposed-p im) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun Apr 2 23:24:46 2006 @@ -37,7 +37,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((btn button) &rest style) +(defmethod compute-style-flags ((btn button) style) (declare (ignore btn)) (let ((std-flags 0) (ex-flags 0)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Sun Apr 2 23:24:46 2006 @@ -37,7 +37,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((label label) &rest style) +(defmethod compute-style-flags ((label label) style) (declare (ignore label)) (let ((std-flags 0) (ex-flags 0)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Sun Apr 2 23:24:46 2006 @@ -49,14 +49,14 @@ ;;; methods ;;; -(defmethod compute-style-flags ((self panel) &rest style) +(defmethod compute-style-flags ((self panel) style) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) (ex-flags 0)) (mapc #'(lambda (sym) (cond ;; styles that can be combined ;; - ((eq sym :style-border) + ((eq sym :border) (setf std-flags (logior std-flags gfs::+ws-border+))))) (gfs:flatten style)) (values std-flags ex-flags))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 2 23:24:46 2006 @@ -51,7 +51,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) &rest style) +(defmethod compute-style-flags ((win top-level) style) (declare (ignore win)) (let ((std-flags 0) (ex-flags 0)) @@ -60,40 +60,40 @@ ;; styles that can be combined ;; #| - ((eq sym :style-hscroll) + ((eq sym :hscroll) (setf std-flags (logior std-flags gfs::+ws-hscroll+))) - ((eq sym :style-max) + ((eq sym :max) (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :style-min) + ((eq sym :min) (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :style-resize) + ((eq sym :resize) (setf std-flags (logior std-flags gfs::+ws-thickframe+))) - ((eq sym :style-sysmenu) + ((eq sym :sysmenu) (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :style-title) + ((eq sym :title) (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :style-top) + ((eq sym :top) (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) - ((eq sym :style-vscroll) + ((eq sym :vscroll) (setf std-flags (logior std-flags gfs::+ws-vscroll+))) |# ;; pre-packaged combinations of window styles ;; - ((eq sym :style-borderless) + ((eq sym :borderless) (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-border+ gfs::+ws-popup+)) (setf ex-flags gfs::+ws-ex-topmost+)) - ((eq sym :style-palette) + ((eq sym :palette) (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popupwindow+ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-toolwindow+ gfs::+ws-ex-windowedge+))) - ((eq sym :style-miniframe) + ((eq sym :miniframe) (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popup+ @@ -102,7 +102,7 @@ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-appwindow+ gfs::+ws-ex-toolwindow+))) - ((eq sym :style-workspace) + ((eq sym :workspace) (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Apr 2 23:24:46 2006 @@ -105,7 +105,7 @@ (defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (self &rest style) +(defgeneric compute-style-flags (self style) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) (defgeneric compute-outer-size (self desired-client-size)

1 0

[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 31 Mar '06

31 Mar '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