[graphic-forms-cvs] r71 - in trunk: . src/tests/uitoolkit src/uitoolkit/graphics
junrue at common-lisp.net
junrue at common-lisp.net
Fri Mar 24 21:59:39 UTC 2006
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."))
More information about the Graphic-forms-cvs
mailing list