;;;-*- 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/14/88 TWE Put support in place for read-only mode. ;;; 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 lines. ;;; 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. ;;; 7/06/87 TWE Moved common code to BASIC-LINE. ;;; 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-LINE to work properly when the slope and ;;; Dy/Dx have already been specified. Previously, the second ;;; endpoint 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 lines. ;;; 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/20/87 TWE Fixed up simple-draw-line to use the `GWIN' :draw-line method by ;;; adding in the extra arguments and specifying the thickness ;;; directly. This change simplified this function a lot. ;;; 4/16/87 TWE Changed TV package prefixes to W. ;;; 4/15/87 TWE Fixed up Y coordinate calculations so that + is up. ;;; 1/06/87 TWE Fixed the slope calculation by doing a PSETQ instead of a SETQ in ;;; the duplicate removal calculation. ;;; 12/31/86 TWE Initial creation. #| This file defines code to handle drawing lines. |# ;;; The following hairy constant is a table of slopes and other information ;;; used to determine the corresponding LaTeX slope when given a line 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 LINE-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 -6 TO 6 WITH ALL-VALUES = NIL FINALLY (RETURN ALL-VALUES) DO (LOOP FOR DELTA-Y FROM -6 TO 6 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 6))) LAST-ITERATION) ;; Construct the result by starting off with a first entry that corresponds to a downward ;; pointing line, then the bulk of the slopes, and finally an entry that corresponds to ;; an upward pointing line. (APPEND FIRST-ITERATION (LOOP FOR OLD-SLOPE = (* 3 -6) 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 lines.*") (DEFFLAVOR LINE-OBJECT () (BASIC-LINE-OBJECT BASIC-OBJECT) :SETTABLE-INSTANCE-VARIABLES :INITTABLE-INSTANCE-VARIABLES :GETTABLE-INSTANCE-VARIABLES) (DEFMETHOD (LINE-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){\\line(~D,~D){~F}}" X-POSITION Y-POSITION DELTA-X DELTA-Y LENGTH) (WHEN THICKNESS (FORMAT LATEX-STREAM "}")) (TERPRI LATEX-STREAM)) (DEFMETHOD (LINE-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:LINE-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 (LINE-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 (LINE-OBJECT :DRAW) (WINDOW &OPTIONAL (ALU NIL)) (IF ALU (SEND WINDOW :SETUP-INSTANCE-ENVIRONMENT (LIST 'DRAW-LINE-OBJECT SELF ALU)) ;;1ELSE* (SEND WINDOW :SETUP-INSTANCE-ENVIRONMENT (LIST 'DRAW-LINE-OBJECT SELF)))) (DEFMETHOD (LINE-OBJECT :NAME) () "Return a string which identifies the object." (FORMAT NIL "Line starting at (~D,~D)~%of length ~D with slope ~D/~D" X-POSITION Y-POSITION LENGTH DELTA-X DELTA-Y)) (DEFMETHOD (LINE-OBJECT :SHORT-NAME) () "Return a narrow string which identifies the object." (FORMAT NIL "Line ~ ~:[~2*~;at ~%(~,2F,~,2F)~]~ ~:[~2*~;~%Slope=~D/~D~]~ ~@[~%Length=~D~]" X-POSITION X-POSITION Y-POSITION DELTA-Y DELTA-Y DELTA-X LENGTH)) (DEFMETHOD (LINE-OBJECT :EDIT-FUNCTION) () "Returns the symbol which is the function to do editing for this object." 'DRAW-LINE) (DEFMETHOD (LINE-OBJECT :PICK-CORNER-FUNCTION) () 'PICK-LINE-POINT) (DEFMETHOD (LINE-OBJECT :REPLICATE) () "2Make a copy of this object.*" (MAKE-INSTANCE 'LINE-OBJECT :X-POSITION X-POSITION :Y-POSITION Y-POSITION :DELTA-X DELTA-X :DELTA-Y DELTA-Y :LENGTH LENGTH :THICKNESS THICKNESS)) ;;; Primitive which just draws a line on a window. (DEFUN SIMPLE-DRAW-LINE (WINDOW X0 Y0 LENGTH DELTA-X DELTA-Y &OPTIONAL (ALU W:ALU-IOR) (THICKNESS 1)) ;; 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*))) ;; 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 lines are drawn with only one pixel of thickness, but ;; their comparative thickness on the page is much smaller. Thick lines are also much ;; thicker on the screen than they appear on paper. What we are doing here is to ;; scale lines thicker than `thick lines' to make them appear the same on the screen ;; as they appear on paper. (WHEN (> THICKNESS (TRUNCATE *THICK-LINES* 2)) (SETQ THICKNESS (MAX (TRUNCATE *THICK-LINES* 2) (TRUNCATE (/ THICKNESS 2.55))))) ;; Need to calculate the end point first. (LET ((X1 (CALCULATE-X1 X0 DELTA-X LENGTH)) (Y1 (CALCULATE-Y1 Y0 DELTA-X DELTA-Y LENGTH))) (SEND WINDOW :DRAW-LINE X0 Y0 X1 Y1 THICKNESS W:BLACK ALU))) (DEFUN DRAW-LINE-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-LINE SELF PIXEL-X PIXEL-Y PIXEL-LENGTH (SEND OBJECT :DELTA-X) (SEND OBJECT :DELTA-Y) ALU (OR (SEND OBJECT :THICKNESS) LINE-THICKNESS)))) (DEFCONSTANT LINE-END-POINT-MOUSE-DOCUMENTATION '(:MOUSE-L-1 "Pick an end point of the line" :MOUSE-M-1 "Abort out of this operation")) (DEFUN MOVE-LINE (OBJECT) "Use the mouse to move a line 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 line 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-LINE-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 ;; Draw the object with a IOR alu after we have finished moving it. (PROGN (SEND OBJECT :DRAW SELF) T) ;;ELSE (PROGN ;; Set the line 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 COERCE-SLOPE (REAL-DELTA-X REAL-DELTA-Y SLOPE-TABLE) "2Coerce real slopes into ones that will be accepted by LaTeX.*" ;; Take care of the special case of a vertical line. (LET ((ACTUAL-DELTA-X NIL) (ACTUAL-DELTA-Y NIL) (REAL-SLOPE (/ REAL-DELTA-Y (FLOAT REAL-DELTA-X))) (SIGN-DELTA-X (SIGN REAL-DELTA-X)) (SIGN-DELTA-Y (SIGN REAL-DELTA-Y))) (LOOP FOR OLD-DELTA-X = (SECOND (FIRST SLOPE-TABLE)) THEN DELTA-X FOR OLD-DELTA-Y = (THIRD (FIRST SLOPE-TABLE)) THEN DELTA-Y FOR (SLOPE DELTA-X DELTA-Y SLOPE-DIFFERENCE) IN (CDR SLOPE-TABLE) DO (WHEN (< REAL-SLOPE (- SLOPE SLOPE-DIFFERENCE)) (RETURN (SETQ ACTUAL-DELTA-X OLD-DELTA-X ACTUAL-DELTA-Y OLD-DELTA-Y))) FINALLY (PROGN (SETQ ACTUAL-DELTA-X DELTA-X ACTUAL-DELTA-Y DELTA-Y))) (VALUES (FORCE-SIGN ACTUAL-DELTA-X SIGN-DELTA-X) (FORCE-SIGN ACTUAL-DELTA-Y SIGN-DELTA-Y)))) (DEFUN RUBBER-BAND-LINE (OBJECT) "Use the mouse to specify the length and slope of a line." (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 LINE-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-LINE-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 specifying the length. (SEND OBJECT :DRAW SELF) T) ;;ELSE (PROGN ;; Set the line 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-LINE-POINT (OBJECT) "Pick an (X,Y) end point for a line 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-LINE OBJECT)) ;;1ELSE* (MULTIPLE-VALUE-BIND (NEW-X NEW-Y) (MOUSE-SPECIFY-POINT OBJECT W:MOUSE-GLYPH-THICK-LINE-POINTER LINE-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)) T) ;;ELSE NIL)))) (DEFUN GET-KEYBOARD-LINE-DATA (OBJECT) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) "Get the exact dimensions of the line 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 line.") (,(LOCF Y-POSITION) "Y coordinate" :CONSTRAINT ,#'VALIDATE-HEIGHT :DOCUMENTATION "Y coordinate of one end of the line.") (,(LOCF LENGTH) "Length" :CONSTRAINT ,#'VALIDATE-HEIGHT :DOCUMENTATION "Running length of the line.") (,(LOCF DELTA-X) "Delta-X" :TYPEP (INTEGER -6 6) :DOCUMENTATION "Delta-X part of the slope.") (,(LOCF DELTA-Y) "Delta-Y" :TYPEP (INTEGER -6 6) :DOCUMENTATION "Delta-Y part of the slope.")) :MARGIN-CHOICES '("Do It" ("Abort" (SIGNAL-CONDITION EH:ABORT-OBJECT))) :LABEL (FORMAT NIL "Enter dimensions of the line 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 line. (WHEN (AND X-POSITION Y-POSITION LENGTH DELTA-X DELTA-Y) (DRAW-LINE-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 line. (WHEN (AND X-POSITION Y-POSITION LENGTH DELTA-X DELTA-Y) (DRAW-LINE-OBJECT OBJECT))))) (DEFPARAMETER LAST-CHOSEN-LINE-THICKNESS NIL) (DEFPARAMETER LINE-THICKNESS-SPECIFY-STRING "Specify numeric line thickness" "String used in the following menu-choose call to specify the thickness of a line.") (DEFPARAMETER LINE-ICON-LENGTH (SEND W:DEFAULT-SCREEN :STRING-LENGTH LINE-THICKNESS-SPECIFY-STRING) "Length in pixels of a line icon.") (DEFUN DRAW-LINE-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-LINE WINDOW (+ X INSIDE-LEFT) (+ Y 1 INSIDE-TOP) (1- LINE-ICON-LENGTH) 1 0 W:ALU-IOR THICKNESS))) (DEFPARAMETER THIN-LINE-ICON (W:MAKE-SIMPLE-ICON 'DRAW-LINE-ICON "Thin" LINE-ICON-LENGTH *THIN-LINES* *THIN-LINES*) "Menu icon for a thin line.") (DEFPARAMETER THICK-LINE-ICON (W:MAKE-SIMPLE-ICON 'DRAW-LINE-ICON "Thick" LINE-ICON-LENGTH *THICK-LINES* *THICK-LINES*) "Menu icon for a thick line.") (DEFPARAMETER LINE-THICKNESS-MENU-ITEMS `((,THIN-LINE-ICON :VALUE ,*THIN-LINES* :DOCUMENTATION "Thin line.") (,THICK-LINE-ICON :VALUE ,*THICK-LINES* :DOCUMENTATION "Thick line.") (,LINE-THICKNESS-SPECIFY-STRING :VALUE :SPECIFY-OTHER-THICKNESS :DOCUMENTATION "Enter a specific line thickness."))) (ZWEI:DEFINE-INDENTATION DRAW-SIMPLE-LINE (1 1)) (DEFUN GET-LINE-THICKNESS (OBJECT &OPTIONAL (DRAW-P T)) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) "Get the line thickness from the user." (MULTIPLE-VALUE-BIND (THICKNESS ITEM) (W:MENU-CHOOSE LINE-THICKNESS-MENU-ITEMS :LABEL "Specify a line thickness" :DEFAULT-ITEM LAST-CHOSEN-LINE-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) HALF-HEIGHT (THICKNESS-WINDOW-LABEL "Line's appearance") (THICKNESS-WINDOW-TOO-THICK-LABEL "Line's appearance - too thick") WAS-TOO-THICK) (SETQ THICKNESS INITIAL-THICKNESS) (UNWIND-PROTECT (FLET ((DRAW-SIMPLE-LINE (WINDOW VARIABLE OLD-VALUE NEW-VALUE) (DECLARE (IGNORE WINDOW VARIABLE OLD-VALUE)) (LET ((TOO-THICK (> NEW-VALUE MAX-DISPLAYABLE-THICKNESS))) ;; Let the user know if we can't show all of the line. (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 line at the indicated thickness. (DRAW-LINE-ICON NIL THICKNESS-WINDOW 1 HALF-HEIGHT NIL (* 2 NEW-VALUE))))) (CONDITION-CASE () (PROGN ;; This window is used to show the user what a line would look ;; like at the user-specified thickness. (SETQ THICKNESS-WINDOW (MAKE-INSTANCE 'W:WINDOW :INSIDE-WIDTH (1+ LINE-ICON-LENGTH) :HEIGHT 100. :LABEL "" :BLINKER-P NIL :EXPOSE-P NIL) HALF-HEIGHT (TRUNCATE (SEND THICKNESS-WINDOW :INSIDE-HEIGHT) 2) MAX-DISPLAYABLE-THICKNESS (truncate (* 2.55 (SEND THICKNESS-WINDOW :INSIDE-HEIGHT))) WAS-TOO-THICK (> THICKNESS (TRUNCATE MAX-DISPLAYABLE-THICKNESS 2))) (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-LINE NIL NIL NIL THICKNESS) (W:CHOOSE-VARIABLE-VALUES `((,(LOCF THICKNESS) "Line thickness" :SIDE-EFFECT ,#'DRAW-SIMPLE-LINE :TYPEP (INTEGER 1 *) :DOCUMENTATION "Thickness of a line.")) :NEAR-MODE `(:WINDOW ,THICKNESS-WINDOW) :MARGIN-CHOICES '("Do It" ("Abort" (SIGNAL-CONDITION EH:ABORT-OBJECT))) :LABEL "Enter dimensions of the line 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)))) (WHEN DRAW-P ;; Erase the old object. (SEND OBJECT :DRAW SELF W:ALU-XOR)) (SEND OBJECT :SET-THICKNESS THICKNESS) (WHEN DRAW-P (SEND OBJECT :DRAW SELF)) (SETQ LAST-CHOSEN-LINE-THICKNESS ITEM) T) ;;ELSE ;; No change. NIL))) (DEFUN SPECIFY-NEW-THICKNESS-DEFAULT () (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (IF READ-ONLY-PICTURE (PICTURE-ERROR "Picture is read-only") ;;ELSE (LET ((JUNK-OBJECT (MAKE-INSTANCE 'LINE-OBJECT :X-POSITION 0 :Y-POSITION 0 :THICKNESS (SEND SELF :LINE-THICKNESS)))) (WHEN (GET-LINE-THICKNESS JUNK-OBJECT NIL) (SETQ LINE-THICKNESS (SEND JUNK-OBJECT :THICKNESS)))))) (DEFCONSTANT LINE-ACTION-ITEM-LIST '(("Pick an end point" :VALUE PICK-LINE-POINT :DOCUMENTATION "Pick an end point of the line via the mouse.") ("Length and slope" :BUTTONS ((NIL :VALUE RUBBER-BAND-LINE) () (NIL :VALUE GET-KEYBOARD-LINE-DATA)) :DOCUMENTATION (:MOUSE-L-1 "Specify the line using the mouse" :MOUSE-R-1 "Enter the line dimensions using the keyboard")) ("Line thickness" :VALUE GET-LINE-THICKNESS :DOCUMENTATION "Specify line thickness") ("Abort" :VALUE :ABORT :DOCUMENTATION "Quit without specifying a line.") ("Done" :VALUE :DONE :DOCUMENTATION "Click here when you are done specifying a line.")) "Menu item-list through which a user specifies a line.") (DEFCONSTANT LINE-ITEM-SEQUENCING (GENERATE-ACTION-ITEM-SEQUENCE LINE-ACTION-ITEM-LIST '((NIL 1) (1 2) (2 5) (3 5)))) (DEFUN DRAW-LINE (&OPTIONAL (OLD-OBJECT NIL)) "Handles all interaction for drawing a line." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((OBJECT NIL)) (IF OLD-OBJECT (SETQ OBJECT OLD-OBJECT) ;;1ELSE* (SETQ OBJECT (MAKE-INSTANCE 'LINE-OBJECT))) (IF (GET-OBJECT-DATA OBJECT LINE-ACTION-ITEM-LIST "Specify a line" LINE-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 line needs to have all of its components specified. (PICTURE-ERROR "The ~a component of the line 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))))))