;;;-*- 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 ;;; ------------------------------------------------------------------------------------- ;;; 1/03/89 TWE Changed REMOVE-RETURNS to allow for another character to be the ;;; replacement character. ;;; 10/11/88 TWE Fixed move-box to understand non-bordered boxes too. ;;; 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. ;;; 5/25/88 TWE Changed to handle line thickness. ;;; 7/20/87 TWE Moved remove-returns from TEXT to here. This allows text in a ;;; box or hollow box to be described consistently with text stacks. ;;; Fixed up infinite loop for boxes. ;;; 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/23/87 TWE Initial creation. Moved code from BOX. #| This file contains code which is common to hollow and dashed boxes. |# (DEFUN REMOVE-RETURNS (STRING &OPTIONAL (REPLACEMENT-CHARACTER #\|)) "2Translate return characters into the REPLACEMENT-CHARACTER.*" (SUBSTITUTE REPLACEMENT-CHARACTER #\RETURN STRING :TEST #'CHAR=)) (DEFFLAVOR BASIC-BOX-OBJECT ( ;; Width and height are expressed in terms of the current unit (for example, millimeters). (WIDTH 0.0 :TYPE FLOAT) (HEIGHT 0.0 :TYPE FLOAT) (THICKNESS NIL :TYPE INTEGER-OR-NIL)) (POSITION-MIXIN TEXT-MIXIN BASIC-OBJECT) :INITTABLE-INSTANCE-VARIABLES :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES) (DEFMETHOD (BASIC-BOX-OBJECT :DRAW-TEXT) (WINDOW &OPTIONAL (ALU NIL)) (IF ALU (SEND WINDOW :SETUP-INSTANCE-ENVIRONMENT (LIST 'DISPLAY-TEXT SELF ALU)) ;;1ELSE* (SEND WINDOW :SETUP-INSTANCE-ENVIRONMENT (LIST 'DISPLAY-TEXT SELF)))) (DEFMETHOD (BASIC-BOX-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)) (DISTANCE-FROM-BOX X Y X-POSITION Y-POSITION (+ X-POSITION WIDTH) (- Y-POSITION HEIGHT))) (DEFMETHOD (BASIC-BOX-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)) ;; Note that the (X,Y) position of the box is the upper left corner. ;; This makes the maximum Y value of the box the Y-POSITION. (VALUES X-POSITION Y-POSITION (+ X-POSITION WIDTH) (- Y-POSITION HEIGHT))) (DEFCONSTANT CORNER-MOUSE-DOCUMENTATION '(:MOUSE-L-1 "Pick a corner of the box" :MOUSE-M-1 "Abort out of this operation")) (DEFMETHOD (BASIC-BOX-OBJECT :PICK-CORNER-FUNCTION) () 'PICK-BOX-POINT) (DEFUN PICK-BOX-POINT (OBJECT) "Pick an (X,Y) point for a box via the mouse." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (IF (AND (SEND OBJECT :X-POSITION) (SEND OBJECT :WIDTH)) (PROGN ;; The user has already specified the position. All ;; that is being done now is to change the position. (MOVE-BOX OBJECT)) ;;ELSE (MULTIPLE-VALUE-BIND (NEW-X NEW-Y) (MOUSE-SPECIFY-POINT OBJECT W:MOUSE-GLYPH-HOLLOW-BOX-POINTER CORNER-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 box when the width and height have been specified. (WHEN (SEND OBJECT :WIDTH) (SEND OBJECT :DRAW SELF)) T) ;;1ELSE* NIL)))) (DEFUN GET-BOX-SIZE-DATA (OBJECT) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) "Get the exact dimensions of the object from the user." (LET ((OBJECT-WIDTH (IF (ZEROP (SEND OBJECT :WIDTH )) 2.0 (SEND OBJECT :WIDTH ))) (OBJECT-HEIGHT (IF (ZEROP (SEND OBJECT :HEIGHT)) 2.0 (SEND OBJECT :HEIGHT))) (PICTURE-BASE-UNIT BASE-UNIT)) (FLET ((VALIDATE-WIDTH (WINDOW CVV-VARIABLE OLD-VALUE NEW-VALUE) (DECLARE (IGNORE WINDOW CVV-VARIABLE OLD-VALUE)) (VALIDATE-PAGE-WIDTH NEW-VALUE PICTURE-BASE-UNIT)) (VALIDATE-HEIGHT (WINDOW CVV-VARIABLE OLD-VALUE NEW-VALUE) (DECLARE (IGNORE WINDOW CVV-VARIABLE OLD-VALUE)) (VALIDATE-PAGE-HEIGHT NEW-VALUE PICTURE-BASE-UNIT))) (CONDITION-CASE () (W:CHOOSE-VARIABLE-VALUES `((,(LOCF OBJECT-WIDTH) "Width" :CONSTRAINT ,#'VALIDATE-WIDTH :DOCUMENTATION "Width of the box.") (,(LOCF OBJECT-HEIGHT) "Height" :CONSTRAINT ,#'VALIDATE-HEIGHT :DOCUMENTATION "Height of the box.")) :MARGIN-CHOICES '("Do It" ("Abort" (SIGNAL-CONDITION EH:ABORT-OBJECT))) :LABEL (FORMAT NIL "Enter size for a box in ~a" (GET 'UNIT-NAME-STRING PICTURE-BASE-UNIT))) (EH:ABORT (SETQ OBJECT-WIDTH NIL)))) (IF OBJECT-WIDTH (PROGN (WHEN (SEND OBJECT :X-POSITION) ;; Erase the box only if it is there. (SEND OBJECT :DRAW SELF W:ALU-XOR)) (SETF (SEND OBJECT :WIDTH ) OBJECT-WIDTH) (SETF (SEND OBJECT :HEIGHT) OBJECT-HEIGHT) ;; If the corner position hasn't been specified then don't draw the box. (WHEN (SEND OBJECT :X-POSITION) (SEND OBJECT :DRAW SELF)) T) ;;ELSE NIL))) (DEFUN GET-BOX-POSITION-DATA (OBJECT) "2Obtain text position data from the user and redisplay the text, if any exists.*" (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((OLD-POSITION (SEND OBJECT :POSITION)) (NEW-POSITION (GET-POSITION-DATA OBJECT)) (TEXT (SEND OBJECT :TEXT))) ;; Only update the display when we have a position and there is text. ;; If the user aborts out of GET-POSITION-DATA then the position will be nil. (WHEN (AND NEW-POSITION (NOT (ZEROP (LENGTH TEXT)))) ;; Erase the text before we display it at the new position. (SETF (SEND OBJECT :POSITION) OLD-POSITION) (DISPLAY-TEXT OBJECT W:ALU-ANDCA) (SETF (SEND OBJECT :POSITION) NEW-POSITION) (DISPLAY-TEXT OBJECT)))) (DEFUN MOVE-BOX (OBJECT) "Use the mouse to move a box to a new location." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (COND ((NULL (SEND OBJECT :X-POSITION)) (PICTURE-ERROR "A corner position is not specified yet.") T) ((NULL (SEND OBJECT :WIDTH)) (PICTURE-ERROR "A box size 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 (COND ((TYPEP OBJECT 'DASHED-BOX-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-DASHED-BOX-OBJECT) OBJECT W:ALU-XOR))) ((TYPEP OBJECT 'HOLLOW-BOX-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-BOX-OBJECT) OBJECT W:ALU-XOR))) ((TYPEP OBJECT 'EMPTY-BOX-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-EMPTY-BOX-OBJECT) OBJECT W:ALU-XOR))) (T (ERROR "Internal picture error. Trying to move unknown object ~A" OBJECT))) (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) ;;ELSE (PROGN ;; Set the box 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 ENTER-BASIC-BOX-TEXT-LINES (OBJECT DOCUMENTATION-STRING) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((OLD-TEXT (SEND OBJECT :TEXT)) (TEXT-LINES (ENTER-TEXT-LINES OBJECT DOCUMENTATION-STRING))) (WHEN TEXT-LINES (WHEN (NOT (ZEROP (LENGTH OLD-TEXT))) ;; Erase the old text before we display the new text. (SETF (SEND OBJECT :TEXT) OLD-TEXT) (DISPLAY-TEXT OBJECT W:ALU-ANDCA)) (SETF (SEND OBJECT :TEXT) TEXT-LINES) (WHEN (NOT (ZEROP (LENGTH TEXT-LINES))) (DISPLAY-TEXT OBJECT)))))