;;;-*- 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 ;;; ------------------------------------------------------------------------------------- ;;; 11/01/88 TWE Fixed drawing of hollow boxes 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. ;;; 10/11/88 TWE Added code to :WRITE-LATEX to not texify the text at the user's ;;; request. ;;; 7/28/88 TWE Fixed SIMPLE-DRAW-DASHED-BOX to not go into an infinite loop if ;;; the dash-width was 0. This happens when one scales a dashed box ;;; down so it is very small. ;;; 6/21/88 TWE Fixed boxes so they get drawn with the correct thickness. ;;; 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. ;;; 6/13/88 TWE Fixed writing the .PIC file so that it saves the thickness too. ;;; 6/03/88 TWE Fixed copying boxes so that the thickness gets copied too. ;;; 5/25/88 TWE Changed to handle line thickness. ;;; 10/15/87 TWE Fixed the error checking to allow for a width with a zero value ;;; for the height, and flag that as an error. ;;; 9/29/87 TWE Fixed both box types to handle negative box dimensions. ;;; 9/10/87 TWE Fixed a problem with replicate losing the font. ;;; 8/31/87 TWE Deleted the redundant :DISTANCE-FROM-POINT method for ;;; dashed boxes. ;;; 7/20/87 TWE Fixed up the :NAME methods to also display the text and font. ;;; 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. Also added the support for ;;; MINIMUM-X/Y to make the picture only as big as the user makes it. ;;; 6/23/87 TWE Added support for fonts. Fixed up editing the size of dashed ;;; boxes. ;;; 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 the dash-width problem that occurs with large units. Also ;;; fixed up aborting out of the creation of hollow and dashed boxes ;;; 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 Added editing support for hollow and dashed boxes. ;;; 5/05/87 TWE Fixed problem with text in dashed boxes not being drawn. ;;; 4/30/87 TWE Fixed up the maximum-y calculation for hollow and dashed boxes. ;;; 4/16/87 TWE Changed TV package prefixes to W. ;;; 12/29/86 TWE Initial creation. Moved code from BASE #| This file defines code to handle hollow boxes and dashed boxes. |# ;;; Primitive which just draws a box on a window. (DEFUN DRAW-BOX (WINDOW LEFT TOP RIGHT BOTTOM &OPTIONAL (ALU W:ALU-IOR) (THICKNESS 1)) ;; Special care is taken to make sure that the box can be drawn. ;; Also, the coordinates specified are the pixels of the exterior part of the box. ;; 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. ;; 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)) (WHEN (> THICKNESS *THICK-LINES* 2) (SETQ THICKNESS (MAX *THICK-LINES* (TRUNCATE (/ THICKNESS 2.55))))) (WHEN (AND (NOT (= LEFT RIGHT)) (NOT (= TOP BOTTOM))) ;; Handle the cases where one makes one of the edges out of order. (WHEN (> TOP BOTTOM) (PSETQ TOP BOTTOM BOTTOM TOP)) (WHEN (> LEFT RIGHT) (PSETQ LEFT RIGHT RIGHT LEFT)) (WHEN (PLUSP (- BOTTOM TOP THICKNESS THICKNESS)) (LET ((INSIDE-LEFT (W:SHEET-INSIDE-LEFT WINDOW)) (INSIDE-TOP (W:SHEET-INSIDE-TOP WINDOW)) (INSIDE-RIGHT (W:SHEET-INSIDE-RIGHT WINDOW)) (INSIDE-BOTTOM (W:SHEET-INSIDE-BOTTOM WINDOW)) MINIMUM-SIZE) ;; Adjust to the edges of the window. (SETQ LEFT (+ LEFT INSIDE-LEFT) TOP (+ TOP INSIDE-TOP) RIGHT (+ RIGHT INSIDE-LEFT) BOTTOM (+ BOTTOM INSIDE-TOP)) ;; Clip to the inside edges of the window. (WHEN (< LEFT INSIDE-LEFT ) (SETQ LEFT INSIDE-LEFT)) (WHEN (< TOP INSIDE-TOP ) (SETQ TOP INSIDE-TOP)) (WHEN (> RIGHT INSIDE-RIGHT ) (SETQ RIGHT INSIDE-RIGHT)) (WHEN (> BOTTOM INSIDE-BOTTOM) (SETQ BOTTOM INSIDE-BOTTOM)) (WHEN (> LEFT INSIDE-RIGHT ) (SETQ LEFT INSIDE-RIGHT)) (WHEN (> TOP INSIDE-BOTTOM) (SETQ TOP INSIDE-BOTTOM)) (WHEN (< (SETQ MINIMUM-SIZE (MIN (- RIGHT LEFT) (- BOTTOM TOP))) (* 2 THICKNESS)) (SETQ THICKNESS (TRUNCATE MINIMUM-SIZE 2))) (W:PREPARE-SHEET (WINDOW) (IF (= (* 2 THICKNESS) MINIMUM-SIZE) ;; Simply draw a solid rectangle. (SYS:%DRAW-RECTANGLE (- RIGHT LEFT) (- BOTTOM TOP) LEFT TOP ALU WINDOW) ;;ELSE (SYS:%DRAW-RECTANGLE (+ (- RIGHT LEFT) 1) THICKNESS LEFT TOP ALU WINDOW) (SYS:%DRAW-RECTANGLE (+ (- RIGHT LEFT) 1) THICKNESS LEFT (+ (- BOTTOM THICKNESS) 1) ALU WINDOW) (SYS:%DRAW-RECTANGLE THICKNESS (+ (- BOTTOM TOP THICKNESS THICKNESS) 1) LEFT (+ TOP THICKNESS) ALU WINDOW) (SYS:%DRAW-RECTANGLE THICKNESS (+ (- BOTTOM TOP THICKNESS THICKNESS) 1) (- RIGHT (1- THICKNESS)) (+ TOP THICKNESS) ALU WINDOW))))))) (DEFFLAVOR HOLLOW-BOX-OBJECT () (BASIC-BOX-OBJECT) :INITTABLE-INSTANCE-VARIABLES :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES) (DEFMETHOD (HOLLOW-BOX-OBJECT :WRITE-LATEX) (LATEX-STREAM TEXIFY) "2Write the description of this object to a LaTeX file.*" (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){\\framebox(~F,~F)~:[~*~;[~A]~]~ ~2:*{\\shortstack~:[~*~;[~A]~]{~A}}}" ;; The X and Y positions point to the upper left corner of the box. ;; For LaTeX, these point to the lower left corner of the box. X-POSITION (- Y-POSITION HEIGHT) WIDTH HEIGHT (NOT (ZEROP (LENGTH POSITION))) POSITION (TEXIFY TEXT TEXT-FONT TEXIFY)) (WHEN THICKNESS (FORMAT LATEX-STREAM "}")) (TERPRI LATEX-STREAM)) (DEFMETHOD (HOLLOW-BOX-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:HOLLOW-BOX-OBJECT ~ :X-POSITION ~F :Y-POSITION ~F ~ :WIDTH ~F :HEIGHT ~F ~ :THICKNESS ~D ~ :POSITION ~S :TEXT ~S :TEXT-FONT ~S)~%" X-POSITION Y-POSITION WIDTH HEIGHT THICKNESS POSITION TEXT TEXT-FONT)) (DEFMETHOD (HOLLOW-BOX-OBJECT :TRANSLATE-UNITS) (NEW-OVER-OLD X-ORIGIN Y-ORIGIN) (SETQ WIDTH (* NEW-OVER-OLD WIDTH) HEIGHT (* NEW-OVER-OLD HEIGHT) X-POSITION (+ (* NEW-OVER-OLD (- X-POSITION X-ORIGIN)) X-ORIGIN) Y-POSITION (+ (* NEW-OVER-OLD (- Y-POSITION Y-ORIGIN)) Y-ORIGIN))) (DEFUN DRAW-BOX-OBJECT (OBJECT &OPTIONAL (ALU W:CHAR-ALUF)) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((PIXEL-WIDTH (TRANSLATE-UNIT-TO-PIXEL (SEND OBJECT :WIDTH))) (PIXEL-HEIGHT (TRANSLATE-UNIT-TO-PIXEL (SEND OBJECT :HEIGHT))) (PIXEL-X (TRANSLATE-X-UNIT-TO-PIXEL (SEND OBJECT :X-POSITION))) (PIXEL-Y (TRANSLATE-Y-UNIT-TO-PIXEL (SEND OBJECT :Y-POSITION)))) ;; Only try to draw a box when we have something to draw. (WHEN PIXEL-X ;; 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. (DRAW-BOX SELF PIXEL-X PIXEL-Y (+ PIXEL-X PIXEL-WIDTH) (+ PIXEL-Y PIXEL-HEIGHT) ALU (OR (SEND OBJECT :THICKNESS) LINE-THICKNESS)) ;; Be sure to draw the text if any is specified. (WHEN (NOT (ZEROP (LENGTH (SEND OBJECT :TEXT)))) (DISPLAY-TEXT OBJECT ALU))))) (DEFMETHOD (HOLLOW-BOX-OBJECT :DRAW) (WINDOW &OPTIONAL (ALU NIL)) (IF ALU (SEND WINDOW :SETUP-INSTANCE-ENVIRONMENT (LIST 'DRAW-BOX-OBJECT SELF ALU)) ;;1ELSE* (SEND WINDOW :SETUP-INSTANCE-ENVIRONMENT (LIST 'DRAW-BOX-OBJECT SELF)))) (DEFMETHOD (HOLLOW-BOX-OBJECT :NAME) () "Return a string which identifies the object." (FORMAT NIL "Hollow box at (~D,~D) that is ~D by ~D~ ~:[~;,~%text is \"~A\", font is ~A~]." X-POSITION Y-POSITION WIDTH HEIGHT (PLUSP (LENGTH TEXT)) (REMOVE-RETURNS TEXT) (DESCRIPTIVE-FONT-NAME TEXT-FONT))) (DEFMETHOD (HOLLOW-BOX-OBJECT :SHORT-NAME) () "Return a narrow string which identifies the object." (FORMAT NIL "Hollow box ~ ~:[~2*~;at ~%(~,2F,~,2F)~]~ ~:[~*~;~%Width=~D~]~ ~:[~*~;~%Height=~D~]" X-POSITION X-POSITION Y-POSITION (NOT (ZEROP WIDTH)) WIDTH (NOT (ZEROP HEIGHT)) HEIGHT)) (DEFMETHOD (HOLLOW-BOX-OBJECT :EDIT-FUNCTION) () "Returns the symbol which is the function to do editing for this object." 'DRAW-HOLLOW-BOX) (DEFMETHOD (HOLLOW-BOX-OBJECT :REPLICATE) () "2Make a copy of this object.*" (MAKE-INSTANCE 'HOLLOW-BOX-OBJECT :X-POSITION X-POSITION :Y-POSITION Y-POSITION :WIDTH WIDTH :HEIGHT HEIGHT :POSITION POSITION :TEXT TEXT :THICKNESS THICKNESS :TEXT-FONT TEXT-FONT)) (DEFUN RUBBER-BAND-BOX (OBJECT) "Use the mouse to specify the size of a box." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (IF (NULL (SEND OBJECT :X-POSITION)) (PICTURE-ERROR "A corner position is not specified yet.") ;;ELSE (LET* ((OLD-WIDTH (SEND OBJECT :WIDTH)) (OLD-HEIGHT (SEND OBJECT :HEIGHT)) (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 #'(LAMBDA (X Y) (MULTIPLE-VALUE-BIND (NEW-WIDTH NEW-HEIGHT) (SEND SELF :GRIDIFY-MEASURE (- (TRANSLATE-PIXEL-TO-UNIT X) X-POSITION) (- Y-POSITION (TRANSLATE-PIXEL-TO-UNIT Y))) (SETF (SEND OBJECT :WIDTH ) NEW-WIDTH) (SETF (SEND OBJECT :HEIGHT) NEW-HEIGHT) (SEND SELF :WRITE-OBJECT-STATUS OBJECT) (DRAW-BOX-OBJECT OBJECT W:ALU-XOR))) (IF OLD-WIDTH (+ (TRANSLATE-UNIT-TO-PIXEL OLD-WIDTH) OLD-X-PIXEL-POSITION) ;;1ELSE* NIL) (IF OLD-HEIGHT (+ (TRANSLATE-UNIT-TO-PIXEL OLD-HEIGHT) 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-WIDTH ;; Set the object back the way it was. (SETF (SEND OBJECT :WIDTH ) OLD-WIDTH) (SETF (SEND OBJECT :HEIGHT) OLD-HEIGHT) (SEND OBJECT :DRAW SELF)) NIL))))) (DEFUN ENTER-BOX-TEXT-LINES (OBJECT) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (ENTER-BASIC-BOX-TEXT-LINES OBJECT "Text Lines for the Hollow Box")) (DEFCONSTANT HOLLOW-BOX-ACTION-ITEM-LIST #| 1 |# '(("Pick a corner" :VALUE PICK-BOX-POINT :DOCUMENTATION "Pick a corner of the box.") #| 2 |# ("Box size" :BUTTONS ((NIL :VALUE RUBBER-BAND-BOX) () (NIL :VALUE GET-BOX-SIZE-DATA)) :DOCUMENTATION (:MOUSE-L-1 "Specify box size using the mouse" :MOUSE-R-1 "Enter the box dimensions using the keyboard")) #| 3 |# ("Lines of text" :VALUE ENTER-BOX-TEXT-LINES :DOCUMENTATION "Enter the lines of text to be placed inside the box.") #| 4 |# ("Text Position" :VALUE GET-BOX-POSITION-DATA :DOCUMENTATION "Specify how the text is to be positioned in the box.") #| 5 |# ("Text font" :VALUE GET-FONT-DATA :DOCUMENTATION "Specify a font for the text") #| 6 |# ("Line thickness" :VALUE GET-LINE-THICKNESS :DOCUMENTATION "Specify edge thickness") #| 7 |# ("Abort" :VALUE :ABORT :DOCUMENTATION "Quit without specifying a box.") #| 8 |# ("Done" :VALUE :DONE :DOCUMENTATION "Click here when you are done specifying a box.")) "Menu item-list through which a user specifies a hollow box.") (DEFCONSTANT HOLLOW-BOX-ITEM-SEQUENCING (GENERATE-ACTION-ITEM-SEQUENCE HOLLOW-BOX-ACTION-ITEM-LIST '((NIL 1) (1 2) (2 3) (3 4) (4 5) (5 8) (6 8)))) (DEFUN DRAW-HOLLOW-BOX (&OPTIONAL (OLD-OBJECT NIL)) "Handles all interaction for drawing a hollow box." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((OBJECT NIL)) (IF OLD-OBJECT (SETQ OBJECT OLD-OBJECT) ;;1ELSE* (SETQ OBJECT (MAKE-INSTANCE 'HOLLOW-BOX-OBJECT))) (IF (GET-OBJECT-DATA OBJECT HOLLOW-BOX-ACTION-ITEM-LIST "Specify a Hollow Box" HOLLOW-BOX-ITEM-SEQUENCING) (PROGN (IF (OR (ZEROP (SEND OBJECT :WIDTH)) (ZEROP (SEND OBJECT :HEIGHT)) (NULL (SEND OBJECT :X-POSITION)) (NULL (SEND OBJECT :Y-POSITION))) ;; The box needs to have a size and a position. (PICTURE-ERROR "The ~a component of the box must be specified." (COND ((ZEROP (SEND OBJECT :WIDTH )) "width") ((ZEROP (SEND OBJECT :HEIGHT )) "height") ((NULL (SEND OBJECT :X-POSITION)) "initial corner"))) ;;ELSE (PROGN (LET ((OBJECT-HEIGHT (SEND OBJECT :HEIGHT))) (WHEN (MINUSP OBJECT-HEIGHT) (SETF (SEND OBJECT :HEIGHT) (- OBJECT-HEIGHT)) (DECF (SEND OBJECT :Y-POSITION) OBJECT-HEIGHT))) (LET ((OBJECT-WIDTH (SEND OBJECT :WIDTH))) (WHEN (MINUSP OBJECT-WIDTH) (SETF (SEND OBJECT :WIDTH) (- OBJECT-WIDTH)) (INCF (SEND OBJECT :X-POSITION) OBJECT-WIDTH))) (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 (NOT (ZEROP (SEND OBJECT :WIDTH))) (NOT (ZEROP (SEND OBJECT :HEIGHT))) (SEND OBJECT :X-POSITION) (SEND OBJECT :Y-POSITION)) ;; 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)))))) #| Dashed box code. |# (DEFPARAMETER *DEFAULT-DASH-WIDTH* 10.0 "2Default dash width in millimeters.*") (DEFUN DEFAULT-DASH-WIDTH (UNIT) (* (/ *DEFAULT-DASH-WIDTH* (UNITS-PER-INCH :MILLIMETER)) (UNITS-PER-INCH UNIT))) (DEFFLAVOR DASHED-BOX-OBJECT ((DASH-WIDTH NIL :TYPE FLOAT-OR-NIL)) (BASIC-BOX-OBJECT) :INITTABLE-INSTANCE-VARIABLES :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES) (DEFMETHOD (DASHED-BOX-OBJECT :WRITE-LATEX) (LATEX-STREAM TEXIFY) "2Write the description of this object to a LaTeX file.*" (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){\\dashbox{~F}(~F,~F)~:[~*~;[~A]~]~ ~2:*{\\shortstack~:[~*~;[~A]~]{~A}}}" ;; The X and Y positions point to the upper left corner of the box. ;; For LaTeX, these point to the lower left corner of the box. X-POSITION (- Y-POSITION HEIGHT) DASH-WIDTH WIDTH HEIGHT (NOT (ZEROP (LENGTH POSITION))) POSITION (TEXIFY TEXT TEXT-FONT TEXIFY)) (WHEN THICKNESS (FORMAT LATEX-STREAM "}")) (TERPRI LATEX-STREAM)) (DEFMETHOD (DASHED-BOX-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:DASHED-BOX-OBJECT ~ :X-POSITION ~D :Y-POSITION ~D ~ :DASH-WIDTH ~D ~ :WIDTH ~D :HEIGHT ~D ~ :THICKNESS ~D ~ :POSITION ~S :TEXT ~S :TEXT-FONT ~S)~%" X-POSITION Y-POSITION DASH-WIDTH WIDTH HEIGHT THICKNESS POSITION TEXT TEXT-FONT)) (DEFMETHOD (DASHED-BOX-OBJECT :TRANSLATE-UNITS) (NEW-OVER-OLD X-ORIGIN Y-ORIGIN) (SETQ X-POSITION (+ (* NEW-OVER-OLD (- X-POSITION X-ORIGIN)) X-ORIGIN) Y-POSITION (+ (* NEW-OVER-OLD (- Y-POSITION Y-ORIGIN)) Y-ORIGIN) DASH-WIDTH (* NEW-OVER-OLD DASH-WIDTH) WIDTH (* NEW-OVER-OLD WIDTH) HEIGHT (* NEW-OVER-OLD HEIGHT))) (DEFMETHOD (DASHED-BOX-OBJECT :DRAW) (WINDOW &OPTIONAL (ALU NIL)) (IF ALU (SEND WINDOW :SETUP-INSTANCE-ENVIRONMENT (LIST 'DRAW-DASHED-BOX-OBJECT SELF ALU)) ;;1ELSE* (SEND WINDOW :SETUP-INSTANCE-ENVIRONMENT (LIST 'DRAW-DASHED-BOX-OBJECT SELF)))) (DEFMETHOD (DASHED-BOX-OBJECT :NAME) () "Return a string which identifies the object." (FORMAT NIL "Dashed box at (~D,~D) that is ~D by ~D.~ ~%Dash length is ~D~ ~:[~;,~%text is \"~A\", font is ~A~]." X-POSITION Y-POSITION WIDTH HEIGHT DASH-WIDTH (PLUSP (LENGTH TEXT)) (REMOVE-RETURNS TEXT) (DESCRIPTIVE-FONT-NAME TEXT-FONT))) (DEFMETHOD (DASHED-BOX-OBJECT :SHORT-NAME) () "Return a narrow string which identifies the object." (FORMAT NIL "Dashed box ~ ~:[~2*~;at ~%(~,2F,~,2F)~]~ ~:[~*~;~%Width=~D~]~ ~:[~*~;~%Height=~D~]" X-POSITION X-POSITION Y-POSITION (NOT (ZEROP WIDTH)) WIDTH (NOT (ZEROP HEIGHT)) HEIGHT)) (DEFMETHOD (DASHED-BOX-OBJECT :REPLICATE) () "2Make a copy of this object.*" (MAKE-INSTANCE 'DASHED-BOX-OBJECT :X-POSITION X-POSITION :Y-POSITION Y-POSITION :DASH-WIDTH DASH-WIDTH :WIDTH WIDTH :HEIGHT HEIGHT :POSITION POSITION :TEXT TEXT :THICKNESS THICKNESS :TEXT-FONT TEXT-FONT)) ;;; The following two functions are primitives used to draw a dashed box. ;;; Test case. #| (LET ((COLOR W:BLACK) (ALU W:ALU-XOR)) (LET ((LEFT 100) (TOP 500) (RIGHT 195) (BOTTOM 600)) (picture:SIMPLE-DRAW-DASHED-BOX tv:selected-window LEFT TOP RIGHT BOTTOM 15 ALU 2) (send tv:selected-window :draw-line LEFT (- TOP 3) RIGHT (- TOP 3) 2 COLOR ALU) (send tv:selected-window :draw-line LEFT (+ BOTTOM 3) RIGHT (+ BOTTOM 3) 2 COLOR ALU) (send tv:selected-window :draw-line (- LEFT 3) TOP (- LEFT 3) BOTTOM 2 COLOR ALU) (send tv:selected-window :draw-line (+ RIGHT 3) TOP (+ RIGHT 3) BOTTOM 2 COLOR ALU)) (LET ((LEFT 300) (TOP 500) (RIGHT 395) (BOTTOM 600)) (picture:SIMPLE-DRAW-DASHED-BOX tv:selected-window LEFT TOP RIGHT BOTTOM 15 ALU 4) (send tv:selected-window :draw-line LEFT (- TOP 3) RIGHT (- TOP 3) 2 COLOR ALU) (send tv:selected-window :draw-line LEFT (+ BOTTOM 3) RIGHT (+ BOTTOM 3) 2 COLOR ALU) (send tv:selected-window :draw-line (- LEFT 3) TOP (- LEFT 3) BOTTOM 2 COLOR ALU) (send tv:selected-window :draw-line (+ RIGHT 3) TOP (+ RIGHT 3) BOTTOM 2 COLOR ALU)) (LET ((LEFT 500) (TOP 500) (RIGHT 595) (BOTTOM 600)) (picture:SIMPLE-DRAW-DASHED-BOX tv:selected-window LEFT TOP RIGHT BOTTOM 15 ALU 6) (send tv:selected-window :draw-line LEFT (- TOP 3) RIGHT (- TOP 3) 2 COLOR ALU) (send tv:selected-window :draw-line LEFT (+ BOTTOM 3) RIGHT (+ BOTTOM 3) 2 COLOR ALU) (send tv:selected-window :draw-line (- LEFT 3) TOP (- LEFT 3) BOTTOM 2 COLOR ALU) (send tv:selected-window :draw-line (+ RIGHT 3) TOP (+ RIGHT 3) BOTTOM 2 COLOR ALU)) (LET ((LEFT 700) (TOP 500) (RIGHT 795) (BOTTOM 600)) (picture:SIMPLE-DRAW-DASHED-BOX tv:selected-window LEFT TOP RIGHT BOTTOM 15 ALU 8) (send tv:selected-window :draw-line LEFT (- TOP 3) RIGHT (- TOP 3) 2 COLOR ALU) (send tv:selected-window :draw-line LEFT (+ BOTTOM 3) RIGHT (+ BOTTOM 3) 2 COLOR ALU) (send tv:selected-window :draw-line (- LEFT 3) TOP (- LEFT 3) BOTTOM 2 COLOR ALU) (send tv:selected-window :draw-line (+ RIGHT 3) TOP (+ RIGHT 3) BOTTOM 2 COLOR ALU))) |# ;;; The following function only works for horizontal or vertical lines. ;;; Implementation note: an earlier implementation of this function ;;; called the :DRAW-DASHED-LINE method directly. Even though this was ;;; a very simple implementation, that method did a very poor job of drawing ;;; towards the end of the line segment. If there wasn't room for a full ;;; dash then none would be drawn. This makes dashed boxes look strange since ;;; most of them would have no corners. The current implementation of the ;;; following function calls the :DRAW-LINE method itself and will draw as much ;;; of a dash as it can when it gets to the end of the line segment. (DEFUN DRAW-THICK-DASHED-LINE (WINDOW X0 Y0 X1 Y1 &OPTIONAL (THICKNESS 1) COLOR (ALU W:ALU-IOR) (DASH-SPACING 20) &AUX (DASH-LENGTH (FLOOR DASH-SPACING 2))) (WHEN (NULL COLOR) (SETQ COLOR W:BLACK)) (COND ((ZEROP (- X0 X1)) ;; Vertical line. (LOOP WITH HALF-DASH = (TRUNCATE DASH-LENGTH 2) FOR FIRST-TIME = T THEN NIL FOR DASH-START FROM Y0 BELOW Y1 BY DASH-SPACING FOR DASH-END = (MIN (+ DASH-START DASH-LENGTH) Y1) DO (IF FIRST-TIME (PROGN (SEND WINDOW :DRAW-LINE X0 DASH-START X1 (- DASH-END HALF-DASH) THICKNESS COLOR ALU T) (DECF DASH-START HALF-DASH)) ;;1ELSE* (SEND WINDOW :DRAW-LINE X0 DASH-START X1 DASH-END THICKNESS COLOR ALU T)))) (T ; Horizontal (LOOP WITH HALF-DASH = (TRUNCATE DASH-LENGTH 2) FOR FIRST-TIME = T THEN NIL FOR DASH-START FROM X0 BELOW X1 BY DASH-SPACING FOR DASH-END = (MIN (+ DASH-START DASH-LENGTH) X1) DO (IF FIRST-TIME (PROGN (SEND WINDOW :DRAW-LINE DASH-START Y0 (- DASH-END HALF-DASH) Y1 THICKNESS COLOR ALU T) (DECF DASH-START HALF-DASH)) ;;1ELSE* (SEND WINDOW :DRAW-LINE DASH-START Y0 DASH-END Y1 THICKNESS COLOR ALU T)))))) (DEFUN SIMPLE-DRAW-DASHED-BOX (WINDOW LEFT TOP RIGHT BOTTOM DASH-WIDTH &OPTIONAL (ALU W:ALU-IOR) (THICKNESS 1)) "2Draw a box made out of dashes.*" ;; Also, the coordinates specified are the pixels of the exterior part of the box. ;; 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. (SETQ THICKNESS (TRUNCATE THICKNESS 2)) (WHEN (> THICKNESS (TRUNCATE *THICK-LINES* 2)) (SETQ THICKNESS (MAX (TRUNCATE *THICK-LINES* 2) (TRUNCATE (/ THICKNESS 2.55))))) (WHEN (AND (NOT (= LEFT RIGHT)) (NOT (= TOP BOTTOM)) (NOT (ZEROP DASH-WIDTH))) ;; Handle the cases where one makes one of the edges out of order. (WHEN (> TOP BOTTOM) (PSETQ TOP BOTTOM BOTTOM TOP)) (WHEN (> LEFT RIGHT) (PSETQ LEFT RIGHT RIGHT LEFT)) (WHEN (PLUSP (- BOTTOM TOP THICKNESS THICKNESS)) (LET ((INSIDE-WIDTH (W:SHEET-INSIDE-WIDTH WINDOW)) (INSIDE-HEIGHT (W:SHEET-INSIDE-HEIGHT WINDOW)) MINIMUM-SIZE) ;; Clip to the inside edges of the window. (WHEN (< LEFT 0) (SETQ LEFT 0)) (WHEN (< TOP 0) (SETQ TOP 0)) (WHEN (> RIGHT INSIDE-WIDTH ) (SETQ RIGHT INSIDE-WIDTH)) (WHEN (> BOTTOM INSIDE-HEIGHT) (SETQ BOTTOM INSIDE-HEIGHT)) (WHEN (> LEFT INSIDE-WIDTH ) (SETQ LEFT INSIDE-WIDTH)) (WHEN (> TOP INSIDE-HEIGHT) (SETQ TOP INSIDE-HEIGHT)) (WHEN (< (SETQ MINIMUM-SIZE (MIN (- RIGHT LEFT) (- BOTTOM TOP))) (* 2 THICKNESS)) (SETQ THICKNESS (TRUNCATE MINIMUM-SIZE 2))) (IF (= (* 2 THICKNESS) MINIMUM-SIZE) ;; The rectangle is too small, relative to the thickness. ;; Simply draw a solid rectangle. (W:PREPARE-SHEET (WINDOW) (SYS:%DRAW-RECTANGLE (- RIGHT LEFT) (- BOTTOM TOP) LEFT TOP ALU WINDOW)) ;;ELSE ;; Top edge. (DRAW-THICK-DASHED-LINE WINDOW LEFT (+ TOP (TRUNCATE THICKNESS 2) ) RIGHT (+ TOP (TRUNCATE THICKNESS 2) ) THICKNESS NIL ALU (* 2 DASH-WIDTH)) ;; Bottom edge. (DRAW-THICK-DASHED-LINE WINDOW LEFT (+ (- BOTTOM THICKNESS) (TRUNCATE THICKNESS 2)) RIGHT (+ (- BOTTOM THICKNESS) (TRUNCATE THICKNESS 2)) THICKNESS NIL ALU (* 2 DASH-WIDTH)) ;; Left edge. (DRAW-THICK-DASHED-LINE WINDOW (+ (TRUNCATE THICKNESS 2) LEFT) (+ TOP THICKNESS 1 ) (+ (TRUNCATE THICKNESS 2) LEFT) (- BOTTOM THICKNESS 1) THICKNESS NIL ALU (* 2 DASH-WIDTH)) ;; Right edge. (DRAW-THICK-DASHED-LINE WINDOW (- RIGHT (1- THICKNESS) (- (TRUNCATE THICKNESS 2)) 1) ; Left (+ TOP THICKNESS 1 ) ; Top (- RIGHT (1- THICKNESS) (- (TRUNCATE THICKNESS 2)) 1) ; Right (- BOTTOM THICKNESS 1) ; Bottom THICKNESS NIL ALU (* 2 DASH-WIDTH))))))) (DEFUN DRAW-DASHED-BOX-OBJECT (OBJECT &OPTIONAL (ALU W:CHAR-ALUF)) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((PIXEL-WIDTH (TRANSLATE-UNIT-TO-PIXEL (SEND OBJECT :WIDTH))) (PIXEL-HEIGHT (TRANSLATE-UNIT-TO-PIXEL (SEND OBJECT :HEIGHT))) (PIXEL-DASH-WIDTH (TRANSLATE-UNIT-TO-PIXEL (SEND OBJECT :DASH-WIDTH))) (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-DASHED-BOX SELF PIXEL-X PIXEL-Y (+ PIXEL-X PIXEL-WIDTH) (+ PIXEL-Y PIXEL-HEIGHT) PIXEL-DASH-WIDTH ALU (OR (SEND OBJECT :THICKNESS) LINE-THICKNESS))) ;; Be sure to draw the text if any is specified. (WHEN (NOT (ZEROP (LENGTH (SEND OBJECT :TEXT)))) (DISPLAY-TEXT OBJECT ALU))) (DEFUN RUBBER-BAND-DASHED-BOX (OBJECT) "Use the mouse to specify the size of a dashed box." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (IF (NULL (SEND OBJECT :X-POSITION)) (PICTURE-ERROR "A corner position is not specified yet.") ;;ELSE (LET* ((OLD-WIDTH (SEND OBJECT :WIDTH)) (OLD-HEIGHT (SEND OBJECT :HEIGHT)) (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 #'(LAMBDA (X Y) (MULTIPLE-VALUE-BIND (NEW-WIDTH NEW-HEIGHT) (SEND SELF :GRIDIFY-MEASURE (- (TRANSLATE-PIXEL-TO-UNIT X) X-POSITION) (- Y-POSITION (TRANSLATE-PIXEL-TO-UNIT Y))) (SETF (SEND OBJECT :WIDTH ) NEW-WIDTH) (SETF (SEND OBJECT :HEIGHT) NEW-HEIGHT) (SEND SELF :WRITE-OBJECT-STATUS OBJECT) (DRAW-DASHED-BOX-OBJECT OBJECT W:ALU-XOR))) (IF OLD-WIDTH (+ (TRANSLATE-UNIT-TO-PIXEL OLD-WIDTH) OLD-X-PIXEL-POSITION) ;;1ELSE* NIL) (IF OLD-HEIGHT (+ (TRANSLATE-UNIT-TO-PIXEL OLD-HEIGHT) 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-WIDTH ;; Set the object back the way it was. (SETF (SEND OBJECT :WIDTH ) OLD-WIDTH) (SETF (SEND OBJECT :HEIGHT) OLD-HEIGHT) (SEND OBJECT :DRAW SELF)) NIL))))) (DEFUN ENTER-DASHED-BOX-TEXT-LINES (OBJECT) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (ENTER-BASIC-BOX-TEXT-LINES OBJECT "Text Lines for the Dashed Box")) (DEFUN GET-DASH-WIDTH (OBJECT) (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((NEW-DASH-WIDTH (SEND OBJECT :DASH-WIDTH)) (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))) (CONDITION-CASE () (W:CHOOSE-VARIABLE-VALUES `((,(LOCF NEW-DASH-WIDTH) "Dash Width" :CONSTRAINT ,#'VALIDATE-WIDTH :DOCUMENTATION "Width of a single dash.")) :MARGIN-CHOICES '("Do It" ("Abort" (SIGNAL-CONDITION EH:ABORT-OBJECT))) :LABEL (FORMAT NIL "Enter the width of a dash 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 30.) (EH:ABORT (SETQ NEW-DASH-WIDTH NIL)))) (WHEN NEW-DASH-WIDTH ;;Erase the old one before we draw the new one. (DRAW-DASHED-BOX-OBJECT OBJECT W:ALU-XOR) (SETF (SEND OBJECT :DASH-WIDTH) NEW-DASH-WIDTH) (DRAW-DASHED-BOX-OBJECT OBJECT)))) (DEFCONSTANT DASHED-BOX-ACTION-ITEM-LIST #| 1 |# '(("Pick a corner" :VALUE PICK-BOX-POINT :DOCUMENTATION "Pick a corner of the dashed box.") #| 2 |# ("Box size" :BUTTONS ((NIL :VALUE RUBBER-BAND-DASHED-BOX) () (NIL :VALUE GET-BOX-SIZE-DATA)) :DOCUMENTATION (:MOUSE-L-1 "Specify dashed box size using the mouse" :MOUSE-R-1 "Enter the dashed box dimensions using the keyboard")) #| 3 |# ("Lines of text" :VALUE ENTER-DASHED-BOX-TEXT-LINES :DOCUMENTATION "Enter the lines of text to be placed inside the dashed box.") #| 4 |# ("Text Position" :VALUE GET-BOX-POSITION-DATA :DOCUMENTATION "Specify how the text is to be positioned in the dashed box.") #| 5 |# ("Text font" :VALUE GET-FONT-DATA :DOCUMENTATION "Specify a font for the text") #| 6 |# ("Dash Width" :VALUE GET-DASH-WIDTH :DOCUMENTATION "Enter the width of a dash using the keyboard.") #| 7 |# ("Line thickness" :VALUE GET-LINE-THICKNESS :DOCUMENTATION "Specify edge thickness") #| 8 |# ("Abort" :VALUE :ABORT :DOCUMENTATION "Quit without specifying a dashed box.") #| 9 |# ("Done" :VALUE :DONE :DOCUMENTATION "Click here when you are done specifying a dashed box.")) "Menu item-list through which a user specifies a dashed box.") (DEFCONSTANT DASHED-BOX-ITEM-SEQUENCING (GENERATE-ACTION-ITEM-SEQUENCE DASHED-BOX-ACTION-ITEM-LIST '((NIL 1) (1 2) (2 3) (3 4) (4 5) (5 6) (6 9) (7 9)))) (DEFUN DRAW-DASHED-BOX (&OPTIONAL (OLD-OBJECT NIL)) "Handles all interaction for drawing a dashed box." (DECLARE (SELF-FLAVOR PICTURE-WINDOW)) (LET ((OBJECT NIL)) (IF OLD-OBJECT (SETQ OBJECT OLD-OBJECT) ;;1ELSE* (SETQ OBJECT (MAKE-INSTANCE 'DASHED-BOX-OBJECT :DASH-WIDTH (DEFAULT-DASH-WIDTH BASE-UNIT)))) (IF (GET-OBJECT-DATA OBJECT DASHED-BOX-ACTION-ITEM-LIST "Specify a Dashed Box" DASHED-BOX-ITEM-SEQUENCING) (PROGN (IF (OR (ZEROP (SEND OBJECT :WIDTH)) (ZEROP (SEND OBJECT :HEIGHT)) (NULL (SEND OBJECT :X-POSITION)) (NULL (SEND OBJECT :Y-POSITION))) ;; The box needs to have some width and a position. (PROGN (PICTURE-ERROR "The ~a component of the box must be specified." (COND ((ZEROP (SEND OBJECT :WIDTH )) "width") ((ZEROP (SEND OBJECT :HEIGHT )) "height") ((NULL (SEND OBJECT :X-POSITION)) "initial corner")))) ;;ELSE (PROGN (LET ((OBJECT-HEIGHT (SEND OBJECT :HEIGHT))) (WHEN (MINUSP OBJECT-HEIGHT) (SETF (SEND OBJECT :HEIGHT) (- OBJECT-HEIGHT)) (DECF (SEND OBJECT :Y-POSITION) OBJECT-HEIGHT))) (LET ((OBJECT-WIDTH (SEND OBJECT :WIDTH))) (WHEN (MINUSP OBJECT-WIDTH) (SETF (SEND OBJECT :WIDTH) (- OBJECT-WIDTH)) (INCF (SEND OBJECT :X-POSITION) OBJECT-WIDTH))) (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))) (PUSH OBJECT DISPLAY-LIST)))) ;;1ELSE* ;; See if enough of the object's parameters were entered for it to be displayed. (WHEN (AND (NOT (ZEROP (SEND OBJECT :WIDTH))) (NOT (ZEROP (SEND OBJECT :HEIGHT))) (SEND OBJECT :X-POSITION) (SEND OBJECT :Y-POSITION)) ;; 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)))))) (DEFMETHOD (DASHED-BOX-OBJECT :EDIT-FUNCTION) () "Returns the symbol which is the function to do editing for this object." 'DRAW-DASHED-BOX)