;;;-*- Mode:Common-Lisp; Package:PICTURES; Base:10 -*- ;;; ;;; ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 149149 ;;; AUSTIN, TEXAS 78714-9149 ;;; ;;; Copyright (C)1987,1988,1989,1990 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; Authors: Delmar Hager, James Dutton, Teri Crowe ;;; Contributors: Kerry Kimbrough, Patrick Hogan, Eric Mielke (in-package "PICTURES") (export '( make-rectangle make-filled-rectangle make-filled-rectangle-edge rectangle-origin-x rectangle-origin-y rectangle-width rectangle-height rectangle-size ) 'pictures) ;Rectangle Class Definition: (defclass pictures::rectangle (polygon) () (:documentation "A graphic that represents a rectangle in object coordinates.")) ;Filled-Rectangle Class Definition: (defclass filled-rectangle ( rectangle filled-polygon) () (:documentation "Filled rectangle class in pictures")) ;Filled-Rectangle-Edge Class Definition: (defclass filled-rectangle-edge ( rectangle filled-polygon-edge) () (:documentation "Filled rectangle edge class in pictures")) (defun make-rectangle (x-min y-min width height &rest options ) "Make a rectangle with the with the given X-MIN, Y-MIN, WIDTH and HEIGHT. The following keyword OPTIONS are allowed: GSTATE PARENT SENESITIVITY TRANSFORM PLIST" (DECLARE (VALUES rectangle)) (APPLY #'MAKE-INSTANCE 'rectangle :point-seq (complete-rectangle x-min y-min (+ x-min width) (+ y-min height)) options)) (defun make-filled-rectangle (x-min y-min width height &rest options ) "Make a filled-rectangle with with the given X-MIN, Y-MIN, WIDTH and HEIGHT. The following keyword OPTIONS are allowed: GSTATE PARENT SENESITIVITY TRANSFORM PLIST" (DECLARE (VALUES filled-rectangle)) (APPLY #'MAKE-INSTANCE 'filled-rectangle :point-seq (complete-rectangle x-min y-min (+ x-min width) (+ y-min height)) options)) (defun make-filled-rectangle-edge (x-min y-min width height &rest options ) "Make a filled-rectangle-edge with the given X-MIN, Y-MIN, WIDTH and HEIGHT. The following keyword OPTIONS are allowed: GSTATE PARENT SENESITIVITY TRANSFORM PLIST EDGE-GSTATE" (DECLARE (VALUES filled-rectangle-edge)) (APPLY #'MAKE-INSTANCE 'filled-rectangle-edge :point-seq (complete-rectangle x-min y-min (+ x-min width) (+ y-min height)) options)) ; Graphic methods for rectangle graphics (DEFMETHOD rectangle-origin-x ((rectangle rectangle)) (DECLARE (VALUES (type ocoord x))) (vertex-x rectangle 0) ) (DEFMETHOD (SETF rectangle-origin-x) (origin-x (rectangle rectangle) ) (LET ((difference (- origin-x (vertex-x rectangle 0)))) (extent-changed rectangle) (DOTIMES (pos 4 origin-x) (SETF (vertex-x rectangle pos) (+ difference (vertex-x rectangle pos)) )))) (DEFMETHOD rectangle-origin-y ((rectangle rectangle)) (DECLARE (VALUES (type ocoord y))) (vertex-y rectangle 0)) (DEFMETHOD (SETF rectangle-origin-y) (origin-y (rectangle rectangle) ) (LET ((difference (- origin-y (vertex-y rectangle 0)))) (extent-changed rectangle) (DOTIMES (pos 4 origin-y) (SETF (vertex-y rectangle pos) (+ difference (vertex-y rectangle pos)) )))) (DEFMETHOD rectangle-width ((rectangle rectangle)) (with-slots (vertices) rectangle (VALUES (distance (vertex-x rectangle 0) (vertex-y rectangle 0) (vertex-x rectangle 1) (vertex-y rectangle 1))))) (DEFMETHOD (SETF rectangle-width) (width (rectangle rectangle)) (with-slots (vertices ) rectangle (extent-changed rectangle) (MULTIPLE-VALUE-BIND (x y dx dy) (compute-point (VERTEX-X RECTANGLE 0)(VERTEX-Y RECTANGLE 0) (vertex-x rectangle 1)(vertex-y rectangle 1) width) (SETF (vertex-x rectangle 1) x) (SETF (vertex-y rectangle 1) y) (SETF (vertex-x rectangle 2) (+ (vertex-x rectangle 2) dx)) (SETF (vertex-y rectangle 2) (+ (vertex-y rectangle 2) dy)))) rectangle) (DEFMETHOD rectangle-height ((rectangle rectangle)) (with-slots (vertices ) rectangle (VALUES (distance (vertex-x rectangle 0) (vertex-y rectangle 0) (vertex-x rectangle 3) (vertex-y rectangle 3))))) (DEFMETHOD (SETF rectangle-height) (height (rectangle rectangle)) (with-slots (vertices ) rectangle (extent-changed rectangle) (MULTIPLE-VALUE-BIND (x y dx dy) (compute-point (VERTEX-X RECTANGLE 0)(VERTEX-Y RECTANGLE 0) (vertex-x rectangle 3)(vertex-y rectangle 3) height) (SETF (vertex-x rectangle 3) x) (SETF (vertex-y rectangle 3) y) (SETF (vertex-x rectangle 2) (+ (vertex-x rectangle 2) dx)) (SETF (vertex-y rectangle 2) (+ (vertex-y rectangle 2) dy))) rectangle)) (DEFMETHOD rectangle-size ((rectangle rectangle)) (VALUES (distance (vertex-x rectangle 0) (vertex-y rectangle 0) (vertex-x rectangle 1) (vertex-y rectangle 1)) (distance (vertex-x rectangle 0) (vertex-y rectangle 0) (vertex-x rectangle 3) (vertex-y rectangle 3)) )) (DEFMETHOD normalize-graphic :around ((rectangle rectangle)) (with-slots (vertices transform) rectangle (extent-changed rectangle) (WHEN (AND transform (= (t12 transform)(t21 transform) 0)) (with-slots (vertices transform) rectangle (transform-point-seq transform vertices) (SETF transform nil)) ) transform)) (DEFUN compute-point (x1 y1 x2 y2 distance) (LET* (x y) (IF (= x1 x2) (VALUES x1 (+ y1 distance) 0 (- (+ y1 distance) y2 )) (progn (SETF y (- y1 (* distance (SIN (ATAN (/ (- y1 y2)(- x1 x2))))))) (SETF x (- x1 (* distance (COS (ATAN (/ (- y1 y2)(- x1 x2))))))) (VALUES x y (- x x2) (- y y2)))))) (DEFUN distance (x1 y1 x2 y2) "the distance between two points" (SQRT (+ (* (- x1 x2)(- x1 x2))(* (- y1 y2)(- y1 y2))))) ;Method: draw-graphic ; Draw the RECTANGLE object in the given VIEW. If MIN-X, MIN-Y, WIDTH, and HEIGHT ; are given, then only parts of the object that lie within the given rectangle ; need to be drawn. (defmethod draw-graphic ((rectangle rectangle) (view view) &optional min-x min-y width height) (declare (type (or null wcoord) min-x min-y width height)) (with-slots (vertices extent transform) rectangle (WHEN (visible-p rectangle) (LET ((world-transform (graphic-world-transform rectangle))) (with-vector temp-vertices (copy-to-vector vertices temp-vertices) (transform-point-seq world-transform temp-vertices) (if (AND world-transform (= (t12 world-transform)(t21 world-transform) 0)) (view-draw-rectangle view ; Yes, use draw-rectangle to draw it (min-value-vector temp-vertices 0) (min-value-vector temp-vertices 1) (- (max-value-vector temp-vertices 0)(min-value-vector temp-vertices 0)) (- (max-value-vector temp-vertices 1)(min-value-vector temp-vertices 1)) (graphic-gstate rectangle)) (view-draw-polygon view ; No, use draw-polygon to draw it temp-vertices (graphic-gstate rectangle)) ) )) rectangle))) ;Method: draw-graphic ; Draw the FILLED-RECTANGLE object in the given VIEW. If MIN-X, MIN-Y, WIDTH, and HEIGHT ; are given, then only parts of the object that lie within the given rectangle ; need to be drawn. (defmethod draw-graphic ((rectangle filled-rectangle) (view view) &optional min-x min-y width height) (declare (type (or null wcoord) min-x min-y width height)) (with-slots (vertices transform extent) rectangle (WHEN (visible-p rectangle) (LET ((world-transform (graphic-world-transform rectangle))) (with-vector temp-vertices (copy-to-vector vertices temp-vertices) (transform-point-seq (graphic-world-transform rectangle) temp-vertices) (if (AND world-transform (= (t12 world-transform)(t21 world-transform) 0)) (view-draw-filled-rectangle view ; Yes, use draw-rectangle to draw it (min-value-vector temp-vertices 0) (min-value-vector temp-vertices 1) (- (max-value-vector temp-vertices 0)(min-value-vector temp-vertices 0)) (- (max-value-vector temp-vertices 1)(min-value-vector temp-vertices 1)) (graphic-gstate rectangle)) (view-draw-filled-polygon view ; No, use draw-polygon to draw it temp-vertices (graphic-gstate rectangle))) ))) )) ;Method: draw-graphic ; Draw the FILLED-RECTANGLE-EDGE object by first drawing the interior and then ; boundary. If MIN-X, MIN-Y, WIDTH, and HEIGHT are given, then only parts of ; the object that lie within the given rectangle need to be drawn. (defmethod draw-graphic ((rectangle filled-rectangle-edge) (view view) &optional min-x min-y width height) (declare (type (or null wcoord) min-x min-y width height)) (with-slots (edge-gstate extent) rectangle (WHEN (visible-p rectangle) (LET ((world-transform (graphic-world-transform rectangle))) (with-slots (vertices transform) rectangle (with-vector temp-vertices (copy-to-vector vertices temp-vertices) (transform-point-seq (graphic-world-transform rectangle) temp-vertices) ; Yes, use draw-fillrectangle to Draw the interior (if (AND world-transform (= (t12 world-transform)(t21 world-transform) 0)) (progn (view-draw-filled-rectangle view (min-value-vector temp-vertices 0) (min-value-vector temp-vertices 1) (- (max-value-vector temp-vertices 0)(min-value-vector temp-vertices 0)) (- (max-value-vector temp-vertices 1)(min-value-vector temp-vertices 1)) (graphic-gstate rectangle)) ; Draw the boundary (view-draw-rectangle view (min-value-vector temp-vertices 0) (min-value-vector temp-vertices 1) (- (max-value-vector temp-vertices 0)(min-value-vector temp-vertices 0)) (- (max-value-vector temp-vertices 1)(min-value-vector temp-vertices 1)) (edge-gstate rectangle))) (PROGN (view-draw-filled-polygon view ; No, use draw-fillpolygon to draw the interior temp-vertices (graphic-gstate rectangle)) (view-draw-polygon view ; Draw the boundary temp-vertices (edge-gstate rectangle)))))))))) (defmethod scale-transform ((graphic rectangle) scale-x scale-y &optional (fixed-x 0) (fixed-y 0)) (declare (type (or (satisfies plusp) (satisfies zerop)) scale-x scale-y)) (declare (type ocoord fixed-x fixed-y)) (declare (values transform)) (graphic-damage graphic) ; Damage from old graphic (with-slots (transform) graphic (UNLESS (AND transform (= (t12 transform)(t21 transform) 0)) (COND ((= scale-x 1) (SETF scale-x scale-y)) ((= scale-y 1) (SETF scale-y scale-x)) ((< scale-x scale-y)(SETF scale-x scale-y)) (t (SETF scale-y scale-x)))) (when (null transform) ; If no transform (setf transform (make-transform))) ; Create one (graphic-stack-purge *transform-stack* graphic) ; Notify the transform stack (PROG1 (scale-transform transform ; Scale it scale-x scale-y fixed-x fixed-y) (extent-changed graphic)) ; Notify graphic his extent may have changed (graphic-damage graphic) ; Damage from new graphic transform)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;Private Method: complete-rectangle ; Compute and return the world coordinates of all four vertices of the given RECTANGLE. ; Also returns the X and Y lengths of the diagonal. (defun complete-rectangle (x1 y1 x3 y3 &aux x2 y2 x4 y4) (PSETF x2 x3 y2 y1 y4 y3 x4 x1) (VALUES (vector x1 y1 x2 y2 x3 y3 x4 y4)) ) ; X and Y lengths of the diagonal ;; private method to determine if a rectangle is ortagonal (DEFMETHOD orthogonal ((rectangle rectangle) (view view)) (with-slots (vertices) rectangle (LET ((x1 (VERTEX-X RECTANGLE 0) ) (y1 (VERTEX-Y RECTANGLE 0)) (x3 (vertex-x rectangle 2)) (y3 (vertex-y rectangle 2)) (epsilon (view-pixel-size view))) ; World size of one pixel in this view (if (or (<= (abs (- x1 x3)) epsilon) ; Is rectangle orthogonal? (<= (abs (- y1 y3)) epsilon)) t nil)))) (DEFUN point-in-rectangle (x y xmin ymin height width ) "this function determines if a given point is within the extent bound of a graphic" (And (>= x xmin ) (<= x (+ xmin height)) (>= y ymin) (<= y (+ ymin width))))