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