;;;-*- Mode:Common-Lisp; Package:PICTURE; Base:10; Fonts:(MEDFNB HL12B HL12BI) -*- ;;; This software was developed at the Texas Instruments Corporation ;;; and is provided "as-is". Texas Instruments Corporation and the ;;; author disclaim all warranties on the software, including without ;;; limitation, all implied warranties of merchantability and fitness. ;;; ;;; This software does not contain any technical data or information ;;; that is proprietary in nature. It may be copied, modified, and ;;; distributed on a non-profit basis and with the inclusion of this ;;; notice. ;;; ;;; Copyright (C) 1989, Texas Instruments Incorporated. ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 9/20/88 TWE Fixed a bug in the initial mouse position when changing the ;;; diameter of a circle. ;;; 6/15/88 TWE Fixed drawing to copy the object to the picture window when the ;;; user has specified enough parameters (instead of XORing the ;;; object and interfering with other objects). This keeps the user ;;; from having to refresh the screen so often. ;;; 7/17/87 TWE Fixed up so that the user can see the coordinate being specified ;;; when a single point is specified. ;;; 6/29/87 TWE Fixed up the argument VARIABLE to be CVV-VARIABLE to get around ;;; a compiler warning message. ;;; 6/22/87 TWE Fixed bad flavor in a defmethod. ;;; 6/19/86 TWE Initial creation. #| This file defines items which are common to hollow and filled circles. |# (DEFFLAVOR CIRCLE-OBJECT ((DIAMETER NIL :TYPE FLOAT-OR-NIL)) (BASIC-OBJECT) :INITTABLE-INSTANCE-VARIABLES :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES) (DEFCONSTANT MAX-HOLLOW-CIRCLE-DIAMETER (TRANSLATE-UNIT-TO-PIXEL-INTERNAL 40.0 :POINT)) (DEFCONSTANT MAX-FILLED-CIRCLE-DIAMETER (TRANSLATE-UNIT-TO-PIXEL-INTERNAL 15.0 :POINT)) (DEFMETHOD (CIRCLE-OBJECT :PICK-CORNER-FUNCTION) () 'PICK-CIRCLE-POINT) (DEFMETHOD (CIRCLE-OBJECT :TRANSLATE-UNITS) (NEW-OVER-OLD X-ORIGIN Y-ORIGIN) (SETQ DIAMETER (* NEW-OVER-OLD DIAMETER) X-POSITION (+ (* NEW-OVER-OLD (- X-POSITION X-ORIGIN)) X-ORIGIN) Y-POSITION (+ (* NEW-OVER-OLD (- Y-POSITION Y-ORIGIN)) Y-ORIGIN))) (DEFMETHOD (CIRCLE-OBJECT :DISTANCE-FROM-POINT) (WINDOW X Y) "Returns the smallest distance that this object is from the point (X,Y). X and Y are measured in terms of the current unit. If the point (X,Y) is inside of the object then 0.0 is returned." (DECLARE (IGNORE WINDOW)) ;; Compute the distance from the center to the point, but subtract off the ;; radius to make the distance be from the nearest point on the circle to ;; the specified (X,Y) point. The idea is that we are computing the distance ;; from the point to the edge of the circle. (ABS (- (W:DIST X Y X-POSITION Y-POSITION) (/ DIAMETER 2.0)))) (DEFMETHOD (CIRCLE-OBJECT :OBJECT-LIMITS) (WINDOW) "Returns the minimum and maximum limits of this object. The values returned are the left top right and bottom unit values." (DECLARE (IGNORE WINDOW)) (LET ((RADIUS (/ DIAMETER 2.0))) (VALUES (- X-POSITION RADIUS) (+ Y-POSITION RADIUS) (+ X-POSITION RADIUS) (- Y-POSITION RADIUS)))) (DEFCONSTANT CENTER-MOUSE-DOCUMENTATION '(:MOUSE-L-1 "Pick the center of the circle" :MOUSE-M-1 "Abort out of this operation")) (DEFUN PICK-CIRCLE-POINT (OBJECT) "Pick an (X,Y) point for a circle via the mouse." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((HOLLOW-P (TYPEP OBJECT 'HOLLOW-CIRCLE-OBJECT))) (IF (AND (SEND OBJECT :X-POSITION) (SEND OBJECT :DIAMETER)) ;; The user has already specified the position. All ;; that is being done now is to change the position. (MOVE-CIRCLE OBJECT) ;;1ELSE* (MULTIPLE-VALUE-BIND (NEW-X NEW-Y) (MOUSE-SPECIFY-POINT OBJECT (IF HOLLOW-P W:MOUSE-GLYPH-HOLLOW-CIRCLE-POINTER ;;1ELSE* W:MOUSE-GLYPH-SOLID-CIRCLE-POINTER) CENTER-MOUSE-DOCUMENTATION) (IF NEW-X (PROGN (MULTIPLE-VALUE-BIND (X-UNIT Y-UNIT) (SEND SELF :GRIDIFY-MEASURE (TRANSLATE-PIXEL-TO-UNIT NEW-X) (TRANSLATE-PIXEL-TO-UNIT NEW-Y)) (SETF (SEND OBJECT :X-POSITION) X-UNIT) (SETF (SEND OBJECT :Y-POSITION) Y-UNIT)) ;; Only draw the circle when the diameter has been specified. (WHEN (SEND OBJECT :DIAMETER) (SEND OBJECT :DRAW SELF)) T) ;;1ELSE* NIL))))) (DEFUN MOVE-CIRCLE (OBJECT) "Use the mouse to move a circle to a new location." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (COND ((NULL (SEND OBJECT :X-POSITION)) (PICTURE-ERROR "A center position is not specified yet.") T) ((NULL (SEND OBJECT :DIAMETER)) (PICTURE-ERROR "A diameter is not specified yet.") T) (T (LET ((OLD-X-POSITION (SEND OBJECT :X-POSITION)) (OLD-Y-POSITION (SEND OBJECT :Y-POSITION)) USER-INPUT) (SEND SELF :TURN-ON-RUBBERBAND (IF (TYPEP OBJECT 'HOLLOW-CIRCLE-OBJECT) #'(LAMBDA (X Y) (MULTIPLE-VALUE-BIND (X-UNIT Y-UNIT) (SEND SELF :GRIDIFY-MEASURE (TRANSLATE-PIXEL-TO-UNIT X) (TRANSLATE-PIXEL-TO-UNIT Y)) (SETF (SEND OBJECT :X-POSITION) X-UNIT) (SETF (SEND OBJECT :Y-POSITION) Y-UNIT)) (SEND SELF :WRITE-OBJECT-STATUS OBJECT) (FUNCALL (SYMBOL-FUNCTION 'DRAW-HOLLOW-CIRCLE-OBJECT) OBJECT W:ALU-XOR)) ;;1ELSE* FILLED-CIRCLE-OBJECT #'(LAMBDA (X Y) (MULTIPLE-VALUE-BIND (X-UNIT Y-UNIT) (SEND SELF :GRIDIFY-MEASURE (TRANSLATE-PIXEL-TO-UNIT X) (TRANSLATE-PIXEL-TO-UNIT Y)) (SETF (SEND OBJECT :X-POSITION) X-UNIT) (SETF (SEND OBJECT :Y-POSITION) Y-UNIT)) (SEND SELF :WRITE-OBJECT-STATUS OBJECT) (FUNCALL (SYMBOL-FUNCTION 'DRAW-FILLED-CIRCLE-OBJECT) OBJECT W:ALU-XOR))) (TRANSLATE-X-UNIT-TO-PIXEL OLD-X-POSITION) (TRANSLATE-Y-UNIT-TO-PIXEL OLD-Y-POSITION)) (SETQ USER-INPUT (READ-MOUSE-XY-INPUT)) ;; Turn off rubberbanding. (SEND SELF :TURN-OFF-RUBBERBAND) (IF USER-INPUT (PROGN ;; Draw the object with a IOR alu after we have finished moving it. (SEND OBJECT :DRAW SELF) T) ;;1ELSE* (PROGN ;; Set the circle back the way it was. (SEND OBJECT :DRAW SELF W:ALU-XOR) (SETF (SEND OBJECT :X-POSITION) OLD-X-POSITION) (SETF (SEND OBJECT :Y-POSITION) OLD-Y-POSITION) (SEND OBJECT :DRAW SELF W:ALU-XOR) NIL)))))) (DEFUN RUBBER-BAND-CIRCLE (OBJECT) "Use the mouse to specify the size of a circle." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (IF (NULL (SEND OBJECT :X-POSITION)) (PICTURE-ERROR "A center position is not specified yet.") ;;ELSE (LET* ((OLD-DIAMETER (SEND OBJECT :DIAMETER)) (MAX-DIAMETER (TRANSLATE-PIXEL-TO-UNIT (IF (TYPEP OBJECT 'HOLLOW-CIRCLE-OBJECT) MAX-HOLLOW-CIRCLE-DIAMETER ;;1ELSE* MAX-FILLED-CIRCLE-DIAMETER))) (X-POSITION (SEND OBJECT :X-POSITION)) (Y-POSITION (SEND OBJECT :Y-POSITION)) (OLD-X-PIXEL-POSITION (TRANSLATE-X-UNIT-TO-PIXEL X-POSITION)) (OLD-Y-PIXEL-POSITION (TRANSLATE-Y-UNIT-TO-PIXEL Y-POSITION)) USER-INPUT) (SEND SELF :TURN-ON-RUBBERBAND (IF (TYPEP OBJECT 'HOLLOW-CIRCLE-OBJECT) #'(LAMBDA (X Y) (MULTIPLE-VALUE-BIND (NEW-X-EDGE NEW-Y-EDGE) (SEND SELF :GRIDIFY-MEASURE (- (TRANSLATE-PIXEL-TO-UNIT X) X-POSITION) (- Y-POSITION (TRANSLATE-PIXEL-TO-UNIT Y))) (SETF (SEND OBJECT :DIAMETER ) (MIN MAX-DIAMETER (* 2 (W:DIST 0.0 0.0 NEW-X-EDGE NEW-Y-EDGE)))) (SEND SELF :WRITE-OBJECT-STATUS OBJECT) (FUNCALL (SYMBOL-FUNCTION 'DRAW-HOLLOW-CIRCLE-OBJECT) OBJECT W:ALU-XOR))) ;;1ELSE* FILLED-CIRCLE-OBJECT #'(LAMBDA (X Y) (MULTIPLE-VALUE-BIND (NEW-X-EDGE NEW-Y-EDGE) (SEND SELF :GRIDIFY-MEASURE (- (TRANSLATE-PIXEL-TO-UNIT X) X-POSITION) (- Y-POSITION (TRANSLATE-PIXEL-TO-UNIT Y))) (SETF (SEND OBJECT :DIAMETER ) (MIN MAX-DIAMETER (* 2 (W:DIST 0.0 0.0 NEW-X-EDGE NEW-Y-EDGE)))) (SEND SELF :WRITE-OBJECT-STATUS OBJECT) (FUNCALL (SYMBOL-FUNCTION 'DRAW-FILLED-CIRCLE-OBJECT) OBJECT W:ALU-XOR)))) (IF OLD-DIAMETER (TRUNCATE (+ (/ (TRANSLATE-UNIT-TO-PIXEL OLD-DIAMETER) 2.0) OLD-X-PIXEL-POSITION)) ;;1ELSE* NIL) (IF OLD-DIAMETER OLD-Y-PIXEL-POSITION ;;1ELSE* NIL)) (SETQ USER-INPUT (READ-MOUSE-XY-INPUT)) ;; Turn off rubberbanding. (SEND SELF :TURN-OFF-RUBBERBAND) (IF USER-INPUT (PROGN ;; Draw the object with a IOR alu after we have finished sizing it. (SEND OBJECT :DRAW SELF) T) ;;ELSE (PROGN ;; Erase the object from the screen. (SEND OBJECT :DRAW SELF W:ALU-XOR) (WHEN OLD-DIAMETER ;; Set the circle back the way it was. (SETF (SEND OBJECT :DIAMETER) OLD-DIAMETER) (SEND OBJECT :DRAW SELF)) NIL))))) (DEFUN VALIDATE-CIRCLE-DIAMETER (VALUE DIMENSION OBJECT) (IF (NOT (NUMBERP VALUE)) "The value must be a number." ;;1ELSE* (LET ((MAXIMUM-IN-UNITS (* (IF (TYPEP OBJECT 'HOLLOW-CIRCLE-OBJECT) MAX-HOLLOW-CIRCLE-DIAMETER ;;1ELSE* MAX-FILLED-CIRCLE-DIAMETER) (UNITS-PER-INCH DIMENSION)))) (COND ((> VALUE MAXIMUM-IN-UNITS) (FORMAT NIL "Must not be greater than ~D." MAXIMUM-IN-UNITS)) (T NIL))))) (DEFUN GET-CIRCLE-SIZE-DATA (OBJECT) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) "Get the exact dimensions of the circle from the user." (LET ((DIAMETER (IF (OR (NULL (SEND OBJECT :DIAMETER)) (ZEROP (SEND OBJECT :DIAMETER))) 2.0 ;;1ELSE* (SEND OBJECT :DIAMETER))) (PICTURE-BASE-UNIT BASE-UNIT)) (FLET ((VALIDATE-DIAMETER (WINDOW CVV-VARIABLE OLD-VALUE NEW-VALUE) (DECLARE (IGNORE WINDOW CVV-VARIABLE OLD-VALUE)) (VALIDATE-CIRCLE-DIAMETER NEW-VALUE PICTURE-BASE-UNIT OBJECT))) (CONDITION-CASE () (W:CHOOSE-VARIABLE-VALUES `((,(LOCF DIAMETER) "Diameter" :CONSTRAINT ,#'VALIDATE-DIAMETER :DOCUMENTATION "Diameter of the circle.")) :MARGIN-CHOICES '("Do It" ("Abort" (SIGNAL-CONDITION EH:ABORT-OBJECT))) :LABEL (FORMAT NIL "Enter diameter for circle in ~a" (GET 'UNIT-NAME-STRING PICTURE-BASE-UNIT))) (EH:ABORT (SETQ DIAMETER NIL)))) (IF DIAMETER (PROGN (WHEN (AND (SEND OBJECT :X-POSITION) (SEND OBJECT :DIAMETER)) ;; Erase the circle only if it is there. (SEND OBJECT :DRAW SELF W:ALU-XOR)) (SETF (SEND OBJECT :DIAMETER) DIAMETER) ;; If the center position hasn't been specified then don't draw the circle. (WHEN (SEND OBJECT :X-POSITION) (SEND OBJECT :DRAW SELF)) T) ;;ELSE NIL)))