;;;-*- 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 ;;; ------------------------------------------------------------------------------------- ;;; 10/11/88 TWE Added extra argument to :WRITE-LATEX. ;;; 6/21/88 TWE Fixed drawing to handle the user changing to thick or thin ;;; vectors. ;;; 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/16/88 TWE Changed to handle line thickness. ;;; 10/07/87 TWE Fixed to work with the edit operation. ;;; 7/20/87 TWE Update the :NAME method to reflect the shorter interaction pane. ;;; Also fixed up coordinate calculation by computing the gridified ;;; values for the initial point and length. ;;; 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. Also added the support for ;;; MINIMUM-X/Y to make the picture only as big as the user makes it. ;;; 6/09/87 TWE Fixed up RUBBER-BAND-VECTOR to work properly when the slope and ;;; Dy/Dx have already been specified. Previously, the arrowhead ;;; was in a poor initial position. ;;; 6/02/87 TWE Fixed aborting out while editing an object. ;;; 6/01/87 TWE Partial Fix for a bug in move mode. For in move mode, if one ;;; aborts out of the move, the object's image gets erased from the ;;; screen. To fix this, all of the functions that can be invoked by ;;; the :PICK-CORNER-FUNCTION method now return NIL for the abort ;;; case and non-NIL for all other cases. ;;; 5/29/87 TWE fixed up aborting out of the creation of a text stack object ;;; so that the aborting would erase the image too. Implemented menu ;;; item sequencing. ;;; 5/22/87 TWE Put in error checking for the CVV code. ;;; 5/19/87 TWE Implemented editing for vectors. ;;; 5/06/87 TWE Fixed up the width of the shaft to be more in tune with the widths ;;; of the edges of the other objects. ;;; 5/05/87 TWE Fixed up length calculation to make sure that it is positive. ;;; 4/30/87 TWE Fixed up the maximum-y calculation. ;;; 4/30/87 TWE Initial version going through module test. #| This file defines code to handle drawing lines with arrowheads on them. |# ;;; The following hairy constant is a table of slopes and other information ;;; used to determine the corresponding LaTeX slope when given a vector slope. ;;; The constant is a list of entries, with each entry consisting of a list ;;; constaining a slope, a delta-x, a delta-y and a slope difference. The ;;; delta-x and delta-y values are for LaTeX. The slope difference is used ;;; to determine when a match is found. It works as follows: ;;; LOOP through all entries starting with the second entry ;;; IF real slope < slope - slope difference THEN ;;; Previous entry was the correct one ;;; ENDIF ;;; ENDLOOP ;;; IF no match was found THEN ;;; choose the last entry ;;; ENDIF (DEFCONSTANT VECTOR-SLOPE-VALUES ;; First create a list entries contains slope delta-x and delta-y. Then sort the list ;; by order of slopes. (LET* ((SORTED-SLOPES (SORT (LOOP FOR DELTA-X FROM -4 TO 4 WITH ALL-VALUES = NIL FINALLY (RETURN ALL-VALUES) DO (LOOP FOR DELTA-Y FROM -4 TO 4 DO (WHEN (NOT (ZEROP DELTA-X)) (PUSH (LIST (/ (FLOAT DELTA-Y) DELTA-X) DELTA-X DELTA-Y) ALL-VALUES)))) #'> :KEY #'CAR)) ;; Remove duplicate slopes and reduce delta-x and delta-y by dividing by ;; the greatest common multiple (actually we let the rational arithmetic ;; package do this for us). (SINGLE-SLOPES (LOOP FOR OLD-SLOPE = NIL THEN SLOPE FOR (SLOPE DELTA-X DELTA-Y) IN SORTED-SLOPES WITH ALL-VALUES = NIL DO (WHEN (OR (NULL OLD-SLOPE) (NOT (= OLD-SLOPE SLOPE))) (PSETQ DELTA-X (DENOMINATOR (/ DELTA-Y DELTA-X)) DELTA-Y (NUMERATOR (/ DELTA-Y DELTA-X))) (PUSH (LIST SLOPE DELTA-X DELTA-Y) ALL-VALUES)) FINALLY (RETURN ALL-VALUES))) (FIRST-ITERATION (LIST (LIST MOST-NEGATIVE-SINGLE-FLOAT 0 -1 4))) LAST-ITERATION) ;; Construct the result by starting off with a first entry that corresponds to a downward ;; pointing vector, then the bulk of the slopes, and finally an entry that corresponds to ;; an upward pointing vector. (APPEND FIRST-ITERATION (LOOP FOR OLD-SLOPE = (* 3 -4) THEN SLOPE FOR OLD-DELTA-X = NIL THEN DELTA-X FOR OLD-DELTA-Y = NIL THEN DELTA-Y FOR (SLOPE DELTA-X DELTA-Y) IN SINGLE-SLOPES FINALLY (SETQ LAST-ITERATION (LIST (LIST (* SLOPE 2) 0 1 0))) COLLECTING (LIST SLOPE DELTA-X DELTA-Y (/ (- SLOPE OLD-SLOPE) 2))) LAST-ITERATION)) "2List of possible slopes for vectors.*") (DEFFLAVOR VECTOR-OBJECT () (BASIC-LINE-OBJECT BASIC-OBJECT) :SETTABLE-INSTANCE-VARIABLES :INITTABLE-INSTANCE-VARIABLES :GETTABLE-INSTANCE-VARIABLES) (DEFMETHOD (VECTOR-OBJECT :WRITE-LATEX) (LATEX-STREAM TEXIFY) "2Write the description of this object to a LaTeX file.*" (DECLARE (IGNORE TEXIFY)) (WHEN THICKNESS (FORMAT LATEX-STREAM (COND ((= THICKNESS *THIN-LINES*) "{\\thinlines ") ((= THICKNESS *THICK-LINES*) "{\\thicklines ") (T ;; The scale factor of 0.075mm was derived by looking at ;; thin and thick lines and lines of thickness .15mm and ;; .30mm and noting that they looked identical. (FORMAT NIL "{\\linethickness{~Dmm} " (* THICKNESS 0.075)))))) (FORMAT LATEX-STREAM "\\put(~F,~F){\\vector(~D,~D){~F}}" X-POSITION Y-POSITION DELTA-X DELTA-Y LENGTH) (WHEN THICKNESS (FORMAT LATEX-STREAM "}")) (TERPRI LATEX-STREAM)) (DEFMETHOD (VECTOR-OBJECT :WRITE-PICTURE) (PICTURE-STREAM) "2Write the description of this object to an auxilary file.*" ;; We write a string which, when read using the READ function, will create this object. (FORMAT PICTURE-STREAM "(MAKE-INSTANCE 'PICTURE:VECTOR-OBJECT ~ :X-POSITION ~D :Y-POSITION ~D ~ :DELTA-X ~D :DELTA-Y ~D ~ :LENGTH ~D ~ :THICKNESS ~D)~%" X-POSITION Y-POSITION DELTA-X DELTA-Y LENGTH THICKNESS)) (DEFMETHOD (VECTOR-OBJECT :TRANSLATE-UNITS) (NEW-OVER-OLD X-ORIGIN Y-ORIGIN) (SETQ LENGTH (* NEW-OVER-OLD LENGTH) X-POSITION (+ (* NEW-OVER-OLD (- X-POSITION X-ORIGIN)) X-ORIGIN) Y-POSITION (+ (* NEW-OVER-OLD (- Y-POSITION Y-ORIGIN)) Y-ORIGIN))) (DEFMETHOD (VECTOR-OBJECT :DRAW) (WINDOW &OPTIONAL (ALU NIL)) (IF ALU (SEND WINDOW :SETUP-INSTANCE-ENVIRONMENT (LIST 'DRAW-VECTOR-OBJECT SELF ALU)) ;;1ELSE* (SEND WINDOW :SETUP-INSTANCE-ENVIRONMENT (LIST 'DRAW-VECTOR-OBJECT SELF)))) (DEFMETHOD (VECTOR-OBJECT :NAME) () "Return a string which identifies the object." (FORMAT NIL "Vector starting at (~D,~D)~%of length ~D with slope ~D/~D" X-POSITION Y-POSITION LENGTH DELTA-X DELTA-Y)) (DEFMETHOD (VECTOR-OBJECT :SHORT-NAME) () "Return a narrow string which identifies the object." (FORMAT NIL "Vector ~ ~:[~2*~;at ~%(~,2F,~,2F)~]~ ~:[~2*~;~%Slope=~D/~D~]~ ~@[~%Length=~D~]" X-POSITION X-POSITION Y-POSITION DELTA-Y DELTA-Y DELTA-X LENGTH)) (DEFMETHOD (VECTOR-OBJECT :EDIT-FUNCTION) () "Returns the symbol which is the function to do editing for this object." 'DRAW-VECTOR) (DEFMETHOD (VECTOR-OBJECT :PICK-CORNER-FUNCTION) () 'PICK-VECTOR-POINT) (DEFMETHOD (VECTOR-OBJECT :REPLICATE) () "2Make a copy of this object.*" (MAKE-INSTANCE 'VECTOR-OBJECT :X-POSITION X-POSITION :Y-POSITION Y-POSITION :DELTA-X DELTA-X :DELTA-Y DELTA-Y :LENGTH LENGTH :THICKNESS THICKNESS)) (DEFUN SLOPE-TO-DEGREES (DELTA-X DELTA-Y) "2Convert the angle expressed by delta-x and delta-y to degrees.*" (IF (ZEROP DELTA-X) (IF (PLUSP DELTA-Y) 90.0 270.0) ;;1ELSE* (/ (* 180 (ATAN DELTA-Y DELTA-X)) PI))) (DEFUN X-Y-ROTATE (X Y THETA) "2Rotate the point (X,Y) by the angle theta. Theta is expressed in degrees.*" (LET ((SINT (SIND THETA)) (COST (COSD THETA))) (VALUES (- (* X COST) (* Y SINT)) (+ (* X SINT) (* Y COST))))) ;;; Primitive which just draws a vector on a window. (DEFUN SIMPLE-DRAW-VECTOR (WINDOW X Y &OPTIONAL (VECTOR-LENGTH 30) (DELTA-X 1.0D0) (DELTA-Y 0.0D0) (ALU (SEND WINDOW :CHAR-ALUF)) (THICKNESS 1) (HEAD-RELATIVE NIL)) "2Draw a vector on WINDOW at point (X,Y). VECTOR-LENGTH is the X part of the length. If DELTA-X is 0 then it is the Y part of the length. length in pixels of the entire vector. DELTA-X and DELTA-Y specify the slope of the vector. HEAD-RELATIVE NIL says that the end of the shaft is at (X,Y). Head-relative* 2T says that the tip of the arrowhead is at (X,Y).*" ;; Can only have thick lines on vertical/horizontal lines. (WHEN (> THICKNESS *THICK-LINES*) (WHEN (NOT (OR (ZEROP DELTA-X) (ZEROP DELTA-Y))) (SETQ THICKNESS *THICK-LINES*))) (IF (> THICKNESS 10) ;; There is an upper bound on the arrowhead. Beyond that limit, just draw a line ;; since that is what the user will see on the page. (SIMPLE-DRAW-LINE window X Y VECTOR-LENGTH DELTA-X DELTA-Y ALU THICKNESS) ;;ELSE (PROGN ;; The thickness used externally is really off by a factor of 2. Adjust ;; it so that we get a line which is of the proper thickness. (SETQ THICKNESS (TRUNCATE THICKNESS 2)) ;; Large thicknesses must be scaled again to make them look correct on the screen. ;; The problem here is that thin vectors are drawn with only one pixel of thickness, but ;; their comparative thickness on the page is much smaller. Thick vectors are also much ;; thicker on the screen than they appear on paper. What we are doing here is to ;; scale vectors thicker than `thick lines' to make them appear the same on the screen ;; as they appear on paper. This scaling, when combined with the problem of a small ;; upperbound on the arrowhead means that the number of different thicknesses of ;; vectors is very small. (WHEN (> THICKNESS (TRUNCATE *THICK-LINES* 2)) (SETQ THICKNESS (MAX (TRUNCATE *THICK-LINES* 2) (TRUNCATE (/ THICKNESS 2.55))))) (SETQ DELTA-Y (- DELTA-Y)) ;; Translate the vector length into the real length of the vector. (SETQ VECTOR-LENGTH (IF (ZEROP DELTA-X) VECTOR-LENGTH ;;1ELSE* ;; This calculation is based upon a simple length calculation for ;; the hypotenuse of a right triangle. The length we are given is ;; the length of the X component. The length of the Y component ;; is dY/dx * X. Given these two sides, we can compute the length ;; of the hypotenuse by taking the square root of the sum of the ;; squares of the other two sides. We can simplify this by ;; factoring out the X*X component, resulting in the formula ;; that we use for the actual calculation. (TRUNCATE (* (ABS VECTOR-LENGTH) (SQRT (+ (EXPT (/ DELTA-Y DELTA-X) 2) 1)))))) (SETQ THICKNESS (* .5 THICKNESS)) (LET* ((X-POINTS (MAKE-ARRAY 8.)) (Y-POINTS (MAKE-ARRAY 8.)) (X-ARROWHEAD-OFFSET (* THICKNESS 4.)) (Y-ARROWHEAD-OFFSET (* THICKNESS 4.)) (X-CENTER (- VECTOR-LENGTH X-ARROWHEAD-OFFSET)) (Y-CENTER 0)) ;; Imagine an arrow pointing to the right. ;; Upper left corner of shaft. (SETF (AREF X-POINTS 0) 0) (SETF (AREF Y-POINTS 0) (TRUNCATE (- THICKNESS))) ;; Upper right corner of shaft. (SETF (AREF X-POINTS 1) (- VECTOR-LENGTH X-ARROWHEAD-OFFSET)) (SETF (AREF Y-POINTS 1) (truncate (- THICKNESS))) ;; Upper left tip of arrowhead. (SETF (AREF X-POINTS 2) (- VECTOR-LENGTH X-ARROWHEAD-OFFSET)) (SETF (AREF Y-POINTS 2) (truncate (- Y-ARROWHEAD-OFFSET))) ;; Right tip of arrowhead. (SETF (AREF X-POINTS 3) VECTOR-LENGTH) (SETF (AREF Y-POINTS 3) 0) ;; Lower right tip of arrowhead. (SETF (AREF X-POINTS 4) (- VECTOR-LENGTH X-ARROWHEAD-OFFSET)) (SETF (AREF Y-POINTS 4) (truncate Y-ARROWHEAD-OFFSET)) ;; Lower right corner of shaft. (SETF (AREF X-POINTS 5) (- VECTOR-LENGTH X-ARROWHEAD-OFFSET)) (SETF (AREF Y-POINTS 5) (truncate THICKNESS)) ;; Lower left corner of shaft. (SETF (AREF X-POINTS 6) 0) (SETF (AREF Y-POINTS 6) (truncate THICKNESS)) ;; Back to the upper left corner of shaft. (SETF (AREF X-POINTS 7) 0) (SETF (AREF Y-POINTS 7) (truncate (- THICKNESS))) (DOTIMES (I 8) (INCF (AREF X-POINTS I) (IF HEAD-RELATIVE (- VECTOR-LENGTH) 0))) (WHEN HEAD-RELATIVE (DECF X-CENTER VECTOR-LENGTH)) ;; Now rotate the points. The origin is at (X,Y). (LET ((ANGLE (SLOPE-TO-DEGREES DELTA-X DELTA-Y))) (DOTIMES (I 8) (MULTIPLE-VALUE-BIND (X-PRIME Y-PRIME) (X-Y-ROTATE (AREF X-POINTS I) (AREF Y-POINTS I) ANGLE) (SETF (AREF X-POINTS I) (+ X X-PRIME)) (SETF (AREF Y-POINTS I) (+ Y Y-PRIME)))) (MULTIPLE-VALUE-BIND (X-PRIME Y-PRIME) (X-Y-ROTATE X-CENTER Y-CENTER ANGLE) (SETQ X-CENTER X-PRIME Y-CENTER Y-PRIME))) (SEND WINDOW :DRAW-FILLED-POLYGON (+ X X-CENTER) (+ Y Y-CENTER) X-POINTS Y-POINTS W:BLACK 8 ALU) ;; The center doesn't get drawn for some reason. Make sure that ;; it is filled in. (SEND WINDOW :DRAW-POINT (+ X X-CENTER) (+ Y Y-CENTER) ALU))))) (DEFUN DRAW-VECTOR-OBJECT (OBJECT &OPTIONAL (ALU W:CHAR-ALUF)) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((PIXEL-LENGTH (TRANSLATE-UNIT-TO-PIXEL (SEND OBJECT :LENGTH))) (PIXEL-X (TRANSLATE-X-UNIT-TO-PIXEL (SEND OBJECT :X-POSITION))) (PIXEL-Y (TRANSLATE-Y-UNIT-TO-PIXEL (SEND OBJECT :Y-POSITION)))) ;; Note that we do not translate the line-thickness since this is not in terms of ;; a specific dimension; it can only be thick or thin. (SIMPLE-DRAW-VECTOR SELF PIXEL-X PIXEL-Y PIXEL-LENGTH (SEND OBJECT :DELTA-X) (SEND OBJECT :DELTA-Y) ALU (OR (SEND OBJECT :THICKNESS) LINE-THICKNESS) (ZEROP PIXEL-LENGTH)))) (DEFCONSTANT VECTOR-END-POINT-MOUSE-DOCUMENTATION '(:MOUSE-L-1 "Pick a point for the blunt end of the vector" :MOUSE-M-1 "Abort out of this operation")) (DEFUN MOVE-VECTOR (OBJECT) "Use the mouse to move a vector to a new location." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (COND ((NULL (SEND OBJECT :X-POSITION)) (PICTURE-ERROR "An initial end point is not specified yet.") T) ((NULL (SEND OBJECT :LENGTH)) (PICTURE-ERROR "A vector length 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 #'(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) (DRAW-VECTOR-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) ;;ELSE (PROGN ;; Set the vector 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))))))) (DEFUN RUBBER-BAND-VECTOR (OBJECT) "Use the mouse to specify the length and slope of a vector." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (IF (NULL (SEND OBJECT :X-POSITION)) (PICTURE-ERROR "An initial end point is not specified yet.") ;;ELSE (LET* ((OLD-LENGTH (SEND OBJECT :LENGTH)) (OLD-PIXEL-LENGTH (TRANSLATE-UNIT-TO-PIXEL OLD-LENGTH)) (OLD-DELTA-X (SEND OBJECT :DELTA-X)) (OLD-DELTA-Y (SEND OBJECT :DELTA-Y)) (X-PIXEL-POSITION (TRANSLATE-UNIT-TO-PIXEL (SEND OBJECT :X-POSITION))) (Y-PIXEL-POSITION (TRANSLATE-UNIT-TO-PIXEL (SEND OBJECT :Y-POSITION))) USER-INPUT) (SEND SELF :TURN-ON-RUBBERBAND #'(LAMBDA (X Y) (MULTIPLE-VALUE-BIND (NEW-X NEW-Y) (SEND SELF :GRIDIFY-POINT X Y) (LET ((X-DIFFERENCE (- NEW-X X-PIXEL-POSITION)) (Y-DIFFERENCE (- NEW-Y Y-PIXEL-POSITION)) COMPUTED-DELTA-X COMPUTED-DELTA-Y COMPUTED-LENGTH) (IF (ZEROP X-DIFFERENCE) (SETQ COMPUTED-DELTA-X 0 COMPUTED-DELTA-Y (IF (PLUSP Y-DIFFERENCE) 1 -1) COMPUTED-LENGTH (MULTIPLE-VALUE-BIND (IGNORE Y-UNIT) (SEND SELF :GRIDIFY-MEASURE 0 (TRANSLATE-PIXEL-TO-UNIT (ABS Y-DIFFERENCE))) Y-UNIT)) ;;1ELSE* (MULTIPLE-VALUE-BIND (NEW-DELTA-X NEW-DELTA-Y) (COERCE-SLOPE X-DIFFERENCE Y-DIFFERENCE VECTOR-SLOPE-VALUES) (IF (ZEROP NEW-DELTA-X) (SETQ COMPUTED-DELTA-X 0 COMPUTED-DELTA-Y (IF (PLUSP Y-DIFFERENCE) 1 -1) COMPUTED-LENGTH (MULTIPLE-VALUE-BIND (IGNORE Y-UNIT) (SEND SELF :GRIDIFY-MEASURE 0 (TRANSLATE-PIXEL-TO-UNIT (ABS Y-DIFFERENCE))) Y-UNIT)) ;;1ELSE* (SETQ COMPUTED-DELTA-X NEW-DELTA-X COMPUTED-DELTA-Y NEW-DELTA-Y COMPUTED-LENGTH (MULTIPLE-VALUE-BIND (X-UNIT IGNORE) (SEND SELF :GRIDIFY-MEASURE (TRANSLATE-PIXEL-TO-UNIT (BEST-LINE-LENGTH X-PIXEL-POSITION Y-PIXEL-POSITION COMPUTED-DELTA-X COMPUTED-DELTA-Y NEW-X NEW-Y)) 0) X-UNIT))))) (SETF (SEND OBJECT :DELTA-X) COMPUTED-DELTA-X) (SETF (SEND OBJECT :DELTA-Y) COMPUTED-DELTA-Y) (SETF (SEND OBJECT :LENGTH ) COMPUTED-LENGTH) (SEND SELF :WRITE-OBJECT-STATUS OBJECT) (DRAW-VECTOR-OBJECT OBJECT W:ALU-XOR)))) ;; If an endpoint was previously specified then move the mouse there. (IF OLD-DELTA-X (CALCULATE-X1 X-PIXEL-POSITION OLD-DELTA-X OLD-PIXEL-LENGTH) ;;1ELSE* NIL) (IF (AND OLD-DELTA-X OLD-DELTA-Y) (CALCULATE-Y1 (TRANSLATE-Y-UNIT-TO-PIXEL (SEND OBJECT :Y-POSITION)) OLD-DELTA-X OLD-DELTA-Y OLD-PIXEL-LENGTH) ;;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 moving it. (SEND OBJECT :DRAW SELF) T) ;;ELSE (PROGN ;; Set the vector back the way it was. (SETF (SEND OBJECT :LENGTH ) OLD-LENGTH) (SETF (SEND OBJECT :DELTA-X) OLD-DELTA-X) (SETF (SEND OBJECT :DELTA-Y) OLD-DELTA-Y) NIL))))) (DEFUN PICK-VECTOR-POINT (OBJECT) "Pick an (X,Y) end point for a vector via the mouse." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (IF (AND (SEND OBJECT :X-POSITION) (SEND OBJECT :LENGTH)) (PROGN ;; The user has already specified the position. All ;; that is being done now is to change the position. (MOVE-VECTOR OBJECT)) ;;1ELSE* (MULTIPLE-VALUE-BIND (NEW-X NEW-Y) (MOUSE-SPECIFY-POINT OBJECT W:MOUSE-GLYPH-THICK-LINE-POINTER VECTOR-END-POINT-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 vector when the length has been specified. (WHEN (SEND OBJECT :LENGTH) (DRAW-VECTOR-OBJECT OBJECT)) T) ;;1ELSE* NIL)))) (DEFUN GET-KEYBOARD-VECTOR-DATA (OBJECT) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) "Get the exact dimensions of the vector from the user." (LET ((X-POSITION (OR (SEND OBJECT :X-POSITION) 10.0)) (Y-POSITION (OR (SEND OBJECT :Y-POSITION) 10.0)) (LENGTH (OR (SEND OBJECT :LENGTH) 10.0)) (DELTA-X (OR (SEND OBJECT :DELTA-X) 1)) (DELTA-Y (OR (SEND OBJECT :DELTA-Y) 0)) (CVV-ENDED-OK T) (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 X-POSITION) "X coordinate" :CONSTRAINT ,#'VALIDATE-WIDTH :DOCUMENTATION "X coordinate of one end of the vector.") (,(LOCF Y-POSITION) "Y coordinate" :CONSTRAINT ,#'VALIDATE-HEIGHT :DOCUMENTATION "Y coordinate of one end of the vector.") (,(LOCF LENGTH) "Length" :CONSTRAINT ,#'VALIDATE-HEIGHT :DOCUMENTATION "Running length of the vector.") (,(LOCF DELTA-X) "Delta-X" :TYPEP (INTEGER -4 4) :DOCUMENTATION "Delta-X part of the slope.") (,(LOCF DELTA-Y) "Delta-Y" :TYPEP (INTEGER -4 4) :DOCUMENTATION "Delta-Y part of the slope.")) :MARGIN-CHOICES '("Do It" ("Abort" (SIGNAL-CONDITION EH:ABORT-OBJECT))) :LABEL (FORMAT NIL "Enter dimensions of the vector in ~a" (GET 'UNIT-NAME-STRING BASE-UNIT)) ;; We need the extra space to display error messages in case the user tries ;; bad values. :EXTRA-WIDTH 25.) (EH:ABORT (SETQ CVV-ENDED-OK NIL)))) (WHEN CVV-ENDED-OK ;; If enough was specified then erase the old the vector. (WHEN (AND X-POSITION Y-POSITION LENGTH DELTA-X DELTA-Y) (DRAW-VECTOR-OBJECT OBJECT W:ALU-XOR)) (SETF (SEND OBJECT :X-POSITION) (FLOAT X-POSITION)) (SETF (SEND OBJECT :Y-POSITION) (FLOAT Y-POSITION)) (SETF (SEND OBJECT :LENGTH ) (FLOAT LENGTH)) (SETF (SEND OBJECT :DELTA-X ) DELTA-X) (SETF (SEND OBJECT :DELTA-Y ) DELTA-Y) ;; If enough was specified then draw the vector. (WHEN (AND X-POSITION Y-POSITION LENGTH DELTA-X DELTA-Y) (DRAW-VECTOR-OBJECT OBJECT))))) (DEFPARAMETER LAST-CHOSEN-VECTOR-THICKNESS NIL) (DEFPARAMETER VECTOR-THICKNESS-SPECIFY-STRING "Specify numeric vector thickness" "String used in the following menu-choose call to specify the thickness of a vector.") (DEFPARAMETER VECTOR-ICON-LENGTH (SEND W:DEFAULT-SCREEN :STRING-LENGTH VECTOR-THICKNESS-SPECIFY-STRING) "Length in pixels of a vector icon.") (DEFUN DRAW-VECTOR-ICON (ICON-OBJECT WINDOW X Y ITEM THICKNESS) (DECLARE (IGNORE ICON-OBJECT ITEM)) (LET ((INSIDE-LEFT (W:SHEET-INSIDE-LEFT WINDOW)) (INSIDE-TOP (W:SHEET-INSIDE-TOP WINDOW))) (SIMPLE-DRAW-VECTOR WINDOW (+ X INSIDE-LEFT) (+ Y 1 INSIDE-TOP) (1- VECTOR-ICON-LENGTH) 1 0 W:ALU-IOR THICKNESS NIL))) (DEFPARAMETER THIN-VECTOR-ICON (W:MAKE-SIMPLE-ICON 'DRAW-VECTOR-ICON "Thin" VECTOR-ICON-LENGTH *THIN-LINES* *THIN-LINES*) "Menu icon for a thin vector.") (DEFPARAMETER THICK-VECTOR-ICON (W:MAKE-SIMPLE-ICON 'DRAW-VECTOR-ICON "Thick" VECTOR-ICON-LENGTH *THICK-LINES* *THICK-LINES*) "Menu icon for a thick vector.") (DEFPARAMETER VECTOR-THICKNESS-MENU-ITEMS `((,THIN-VECTOR-ICON :VALUE ,*THIN-LINES* :DOCUMENTATION "Thin vector.") (,THICK-VECTOR-ICON :VALUE ,*THICK-LINES* :DOCUMENTATION "Thick vector.") (,VECTOR-THICKNESS-SPECIFY-STRING :VALUE :SPECIFY-OTHER-THICKNESS :DOCUMENTATION "Enter a specific vector thickness."))) (ZWEI:DEFINE-INDENTATION DRAW-SIMPLE-VECTOR (1 1)) (DEFUN GET-VECTOR-THICKNESS (OBJECT) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) "Get the vector thickness from the user." (MULTIPLE-VALUE-BIND (THICKNESS ITEM) (W:MENU-CHOOSE VECTOR-THICKNESS-MENU-ITEMS :LABEL "Specify a vector thickness" :DEFAULT-ITEM LAST-CHOSEN-VECTOR-THICKNESS) (IF ITEM (PROGN (WHEN (EQ THICKNESS :SPECIFY-OTHER-THICKNESS) ;; Let the user enter a thickness via a CVV window. (LET (THICKNESS-WINDOW (INITIAL-THICKNESS (TRUNCATE (OR (SEND OBJECT :THICKNESS) (SEND SELF :LINE-THICKNESS)) 2)) MAX-DISPLAYABLE-THICKNESS (CVV-ENDED-OK T) (THICKNESS-WINDOW-LABEL "Vector's appearance") (THICKNESS-WINDOW-TOO-THICK-LABEL "Vector's appearance - too thick") WAS-TOO-THICK) (SETQ THICKNESS INITIAL-THICKNESS) (UNWIND-PROTECT (FLET ((DRAW-SIMPLE-VECTOR (WINDOW VARIABLE OLD-VALUE NEW-VALUE) (DECLARE (IGNORE WINDOW VARIABLE OLD-VALUE)) (LET ((TOO-THICK (> NEW-VALUE (TRUNCATE MAX-DISPLAYABLE-THICKNESS 4)))) ;; Let the user know if we can't show all of the vector. (COND ((AND WAS-TOO-THICK (NOT TOO-THICK)) (SETQ WAS-TOO-THICK NIL) (SEND THICKNESS-WINDOW :SET-LABEL THICKNESS-WINDOW-LABEL)) ((AND (NOT WAS-TOO-THICK) TOO-THICK) (SETQ WAS-TOO-THICK T) (SEND THICKNESS-WINDOW :SET-LABEL THICKNESS-WINDOW-TOO-THICK-LABEL))) ;; Get rid of the trash on the window. (SEND THICKNESS-WINDOW :CLEAR-EOF) ;; Draw the vector at the indicated thickness. (DRAW-VECTOR-ICON NIL THICKNESS-WINDOW 1 (TRUNCATE MAX-DISPLAYABLE-THICKNESS 2) NIL (* 2 NEW-VALUE))))) (CONDITION-CASE () (PROGN ;; This window is used to show the user what a vector would look ;; like at the user-specified thickness. (SETQ THICKNESS-WINDOW (MAKE-INSTANCE 'W:WINDOW :INSIDE-WIDTH (1+ VECTOR-ICON-LENGTH) :HEIGHT 100. :LABEL "" :BLINKER-P NIL :EXPOSE-P NIL) MAX-DISPLAYABLE-THICKNESS (SEND THICKNESS-WINDOW :INSIDE-HEIGHT) WAS-TOO-THICK (> THICKNESS (TRUNCATE MAX-DISPLAYABLE-THICKNESS 4))) (SEND THICKNESS-WINDOW :SET-LABEL (IF WAS-TOO-THICK THICKNESS-WINDOW-TOO-THICK-LABEL ;;ELSE THICKNESS-WINDOW-LABEL)) (SEND THICKNESS-WINDOW :EXPOSE-NEAR '(:MOUSE)) (DRAW-SIMPLE-VECTOR NIL NIL NIL THICKNESS) (W:CHOOSE-VARIABLE-VALUES `((,(LOCF THICKNESS) "Vector thickness" :SIDE-EFFECT ,#'DRAW-SIMPLE-VECTOR :TYPEP (INTEGER 1 *) :DOCUMENTATION "Thickness of a vector.")) :NEAR-MODE `(:WINDOW ,THICKNESS-WINDOW) :MARGIN-CHOICES '("Do It" ("Abort" (SIGNAL-CONDITION EH:ABORT-OBJECT))) :LABEL "Enter dimensions of the vector multiples of thinlines." ;; We need the extra space to display error messages in ;; case the user tries bad values. :EXTRA-WIDTH 25.)) (EH:ABORT (SETQ CVV-ENDED-OK NIL)))) (SEND THICKNESS-WINDOW :DEACTIVATE)) (SETQ THICKNESS (IF CVV-ENDED-OK (* 2 THICKNESS) ;;ELSE INITIAL-THICKNESS)))) ;; Erase the object at its old thickness. (DRAW-VECTOR-OBJECT OBJECT W:ALU-XOR) (SEND OBJECT :SET-THICKNESS THICKNESS) (DRAW-VECTOR-OBJECT OBJECT) (SETQ LAST-CHOSEN-VECTOR-THICKNESS ITEM) T) ;;ELSE ;; No change. NIL))) (DEFCONSTANT VECTOR-ACTION-ITEM-LIST '(("Pick an end point" :VALUE PICK-VECTOR-POINT :DOCUMENTATION "Pick an end point of the vector via the mouse.") ("Length and slope" :BUTTONS ((NIL :VALUE RUBBER-BAND-VECTOR) () (NIL :VALUE GET-KEYBOARD-VECTOR-DATA)) :DOCUMENTATION (:MOUSE-L-1 "Specify the vector using the mouse" :MOUSE-R-1 "Enter the vector dimensions using the keyboard")) ("Vector thickness" :VALUE GET-VECTOR-THICKNESS :DOCUMENTATION "Specify vector thickness") ("Abort" :VALUE :ABORT :DOCUMENTATION "Quit without specifying a vector.") ("Done" :VALUE :DONE :DOCUMENTATION "Click here when you are done specifying a vector.")) "Menu item-list through which a user specifies a vector.") (DEFCONSTANT VECTOR-ITEM-SEQUENCING (GENERATE-ACTION-ITEM-SEQUENCE VECTOR-ACTION-ITEM-LIST '((NIL 1) (1 2) (2 5) (3 5)))) (DEFUN DRAW-VECTOR (&OPTIONAL (OLD-OBJECT NIL)) "Handles all interaction for drawing a vector." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((OBJECT NIL)) (IF OLD-OBJECT (SETQ OBJECT OLD-OBJECT) ;;1ELSE* (SETQ OBJECT (MAKE-INSTANCE 'VECTOR-OBJECT))) (IF (GET-OBJECT-DATA OBJECT VECTOR-ACTION-ITEM-LIST "Specify a vector" VECTOR-ITEM-SEQUENCING) (LET ((X0 (SEND OBJECT :X-POSITION)) (Y0 (SEND OBJECT :Y-POSITION)) (LENGTH (SEND OBJECT :LENGTH)) (DELTA-X (SEND OBJECT :DELTA-X)) (DELTA-Y (SEND OBJECT :DELTA-Y))) (IF (AND (NULL X0) (NULL Y0) (NULL LENGTH) (NULL DELTA-X) (NULL DELTA-Y)) ;; The vector needs to have all of its components specified. (PICTURE-ERROR "The ~a component of the vector must be specified." (COND ((NULL X0 ) "X position") ((NULL Y0 ) "Y position") ((NULL LENGTH ) "length") ((NULL DELTA-X) "Delta X") ((NULL DELTA-Y) "Delta Y"))) ;;1ELSE* (PROGN (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM) (SEND OBJECT :OBJECT-LIMITS SELF) (SETQ MAXIMUM-X-UNIT (MAX MAXIMUM-X-UNIT RIGHT ) MINIMUM-X-UNIT (MIN MINIMUM-X-UNIT LEFT ) MAXIMUM-Y-UNIT (MAX MAXIMUM-Y-UNIT TOP ) MINIMUM-Y-UNIT (MIN MINIMUM-Y-UNIT BOTTOM))) (WHEN (NULL OLD-OBJECT) (PUSH OBJECT DISPLAY-LIST))))) ;;1ELSE* ;; See if enough of the object's parameters were entered for it to be displayed. (WHEN (AND (SEND OBJECT :X-POSITION) (SEND OBJECT :Y-POSITION) (SEND OBJECT :LENGTH) (SEND OBJECT :DELTA-X) (SEND OBJECT :DELTA-Y)) ;; Don't XOR the object if the user aborted out of the menu for an existing object. (WHEN (NULL OLD-OBJECT) (SEND OBJECT :DRAW SELF W:ALU-XOR))))))