home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / grfdfs.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  20.1 KB  |  520 lines
  1. ;; -*- Mode:LISP; Package:BOXER; Base:10.;fonts:cptfont,cptfontb; -*-
  2. #|
  3.  
  4.              Copyright 1984 Massachusetts Institute of Technology
  5.  
  6.  Permission to use, copy, modify, distribute, and sell this software
  7.  and its documentation for any purpose is hereby granted without fee,
  8.  provided that the above copyright notice appear in all copies and that
  9.  both that copyright notice and this permission notice appear in
  10.  supporting documentation, and that the name of M.I.T. not be used in
  11.  advertising or publicity pertaining to distribution of the software
  12.  without specific, written prior permission.  M.I.T. makes no
  13.  representations about the suitability of this software for any
  14.  purpose.  It is provided "as is" without express or implied warranty.
  15.  
  16.  
  17.                                          +-Data--+
  18.                 This file is part of the | BOXER | system
  19.                                          +-------+
  20.  
  21.     This contains all of the Interface between Graphics sheets
  22.     and the rest of the  BOXER Editor.  The functions and methods
  23.     which manipulate pixels (as opposed  to graphics objects) can
  24.     also be found here  In particular, the functions which are
  25.     used to draw lines, regions, etc are here.
  26.  
  27. |#
  28.  
  29. ;;; get the offsets right
  30.  
  31. (DEFMACRO WITH-TURTLE-SLATE-ORIGINS (SCREEN-BOX &BODY BODY)
  32.   ;; this macro sets x and y coordinates of top left of turtle array
  33.   ;; not that the a SCREEN-SHEET may NOT have been allocated if this has been called BEFORE
  34.   ;; Redisplay has had a chnace to run
  35.   `(LET ((SCREEN-SHEET (TELL-CHECK-NIL ,SCREEN-BOX :SCREEN-SHEET)))
  36.      (UNLESS (NULL SCREEN-SHEET)
  37.        (MULTIPLE-VALUE-BIND (BOX-X-OFFSET BOX-Y-OFFSET)
  38.        (TELL ,SCREEN-BOX :POSITION)
  39.      (MULTIPLE-VALUE-BIND (SHEET-X SHEET-Y)
  40.          (GRAPHICS-SCREEN-SHEET-OFFSETS SCREEN-SHEET)
  41.        (LET ((%ORIGIN-X-OFFSET (+ (TV:SHEET-INSIDE-LEFT *BOXER-PANE*)
  42.                       BOX-X-OFFSET
  43.                       SHEET-X))
  44.          (%ORIGIN-Y-OFFSET (+ (TV:SHEET-INSIDE-TOP *BOXER-PANE*)
  45.                       BOX-Y-OFFSET
  46.                       SHEET-Y)))
  47.          (PROGN . ,BODY)))))))
  48.  
  49. (DEFVAR *SCRUNCH-FACTOR* 1
  50.   "the factor used to normalize the Y-coordinates so that squares really are")
  51.  
  52. (DEFUN MAKE-GRAPHICS-SHEET (WID HEI &OPTIONAL BOX)
  53.   (%MAKE-GRAPHICS-SHEET WID HEI (TV:MAKE-SHEET-BIT-ARRAY *BOXER-PANE* WID HEI) BOX))
  54.  
  55. (DEFUN MAKE-GRAPHICS-SCREEN-SHEET (ACTUAL-OBJ &OPTIONAL (X-OFFSET 0.) (Y-OFFSET 0.))
  56.   (%MAKE-G-SCREEN-SHEET ACTUAL-OBJ X-OFFSET Y-OFFSET))
  57.  
  58. (DEFUN GRAPHICS-SCREEN-SHEET-OFFSETS (GRAPHICS-SCREEN-SHEET)
  59.   (VALUES (GRAPHICS-SCREEN-SHEET-X-OFFSET GRAPHICS-SCREEN-SHEET)
  60.       (GRAPHICS-SCREEN-SHEET-Y-OFFSET GRAPHICS-SCREEN-SHEET)))
  61.   
  62. (DEFUN SET-GRAPHICS-SCREEN-SHEET-X-OFFSET (GRAPHICS-SCREEN-SHEET NEW-X-OFFSET)
  63.   (SETF (GRAPHICS-SCREEN-SHEET-X-OFFSET GRAPHICS-SCREEN-SHEET) NEW-X-OFFSET))
  64.  
  65. (DEFUN SET-GRAPHICS-SCREEN-SHEET-Y-OFFSET (GRAPHICS-SCREEN-SHEET NEW-Y-OFFSET)
  66.   (SETF (GRAPHICS-SCREEN-SHEET-Y-OFFSET GRAPHICS-SCREEN-SHEET) NEW-Y-OFFSET))
  67.  
  68. ;;accessors for graphics boxes
  69.  
  70. (DEFMETHOD (GRAPHICS-BOX :BIT-ARRAY) ()
  71.   (GRAPHICS-SHEET-BIT-ARRAY GRAPHICS-SHEET))
  72.  
  73. (DEFMETHOD (GRAPHICS-BOX :GRAPHICS-SHEET) ()
  74.   GRAPHICS-SHEET)
  75.  
  76. (DEFUN DRAWING-WIDTH (GRAPHICS-SHEET)
  77.   ;; Returns the width of the area of a bit-array for a graphics
  78.   ;; box.  Note that this doesn't have to be = to
  79.   ;; ARRAY-DIMENSION-N because of BITBLT's multiple of 32.
  80.   ;; requirement
  81.   (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET))
  82.  
  83. (DEFUN DRAWING-HEIGHT (GRAPHICS-SHEET)
  84.   (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET))
  85.  
  86. (DEFMETHOD (GRAPHICS-BOX :BIT-ARRAY-WID) ()
  87.   (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET))
  88.  
  89. (DEFMETHOD (GRAPHICS-BOX :BIT-ARRAY-HEI) ()
  90.   (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET))
  91.  
  92. (DEFMETHOD (GRAPHICS-BOX :GRAPHICS-SHEET-SIZE) ()
  93.   (VALUES (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET)
  94.       (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET)))
  95.  
  96. (DEFMETHOD (GRAPHICS-BOX :DRAW-MODE) ()
  97.   (GRAPHICS-SHEET-DRAW-MODE GRAPHICS-SHEET))
  98.  
  99. (DEFMETHOD (GRAPHICS-BOX :SET-DRAW-MODE) (NEW-MODE)
  100.   (SETF (GRAPHICS-SHEET-DRAW-MODE GRAPHICS-SHEET) NEW-MODE))
  101.  
  102. (DEFMETHOD (GRAPHICS-BOX :CLEAR-BOX) ()
  103.   (DOLIST (SCREEN-BOX (GET-VISIBLE-SCREEN-OBJS  SELF))
  104.     (UNLESS (EQ ':SHRUNK (TELL SCREEN-BOX :DISPLAY-STYLE))
  105.       (DRAWING-ON-TURTLE-SLATE SCREEN-BOX
  106.     (TV:%DRAW-RECTANGLE (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET)
  107.                 (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET)
  108.                 (SCALE-X 0)
  109.                 (SCALE-Y 0)
  110.                 TV:ALU-ANDCA
  111.                 %DRAWING-ARRAY))))
  112.   (TV:%DRAW-RECTANGLE (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET)
  113.               (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET)
  114.               0
  115.               0
  116.               TV:ALU-ANDCA
  117.               (GRAPHICS-SHEET-BIT-ARRAY GRAPHICS-SHEET)))
  118.  
  119. (DEFMETHOD (GRAPHICS-BOX :ERASE-FROM-SCREEN) ()
  120.   (DRAWING-ON-WINDOW (*BOXER-PANE*)
  121.     (DOLIST (SCREEN-BOX (GET-VISIBLE-SCREEN-OBJS SELF))
  122.       (UNLESS (EQ ':SHRUNK (TELL SCREEN-BOX :DISPLAY-STYLE))
  123.     (WITH-TURTLE-SLATE-ORIGINS SCREEN-BOX
  124.       (TV:%DRAW-RECTANGLE
  125.         (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET)
  126.         (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET)
  127.         %ORIGIN-X-OFFSET
  128.         %ORIGIN-Y-OFFSET
  129.         TV:ALU-ANDCA
  130.         %DRAWING-WINDOW))))))
  131.  
  132. (DEFMETHOD (GRAPHICS-BOX :CLEARSCREEN) ()
  133.   (TELL SELF :CLEAR-BOX)
  134.   (DOLIST (TURTLE (GRAPHICS-SHEET-OBJECT-LIST GRAPHICS-SHEET))
  135.     (IF (TELL TURTLE :SHOWN-P)
  136.     (TELL TURTLE :DRAW))))
  137.  
  138. (DEFMETHOD (GRAPHICS-BOX :COPY) ()
  139.   (LET ((NEW-BOX (MAKE-INITIALIZED-GRAPHICS-BOX ':FIXED-WID (DRAWING-WIDTH GRAPHICS-SHEET)
  140.                         ':FIXED-HEI (DRAWING-HEIGHT GRAPHICS-SHEET)))
  141.     (BOX-STREAM (MAKE-BOX-STREAM SELF)))
  142.     (TELL NEW-BOX :SET-CONTENTS-FROM-STREAM BOX-STREAM T)
  143.     (WHEN (NOT-NULL PORTS)
  144.       (PUSH (CONS SELF NEW-BOX) .LINK-TARGET-ALIST.))
  145.     (BITBLT TV:ALU-SETA (DRAWING-WIDTH GRAPHICS-SHEET) (DRAWING-HEIGHT GRAPHICS-SHEET)
  146.         (GRAPHICS-SHEET-BIT-ARRAY GRAPHICS-SHEET) 0 0
  147.         (TELL NEW-BOX :BIT-ARRAY) 0 0)
  148.     (tell new-box :export-all-variables)
  149.     NEW-BOX))
  150.  
  151. (DEFMETHOD (GRAPHICS-BOX :COMPLEMENT) ()
  152.   (TV:%DRAW-RECTANGLE (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET)
  153.               (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET)
  154.               0
  155.               0
  156.               TV:ALU-XOR
  157.               (GRAPHICS-SHEET-BIT-ARRAY GRAPHICS-SHEET))
  158.   (TELL SELF :MODIFIED))
  159.  
  160. ;;;ED -- I've never used these and don't know if they work
  161. (DEFMETHOD (GRAPHICS-BOX :FILL-FROM-GRAPHICS-BOX) (FROM-BOX)
  162.   (LET* ((FROM-SHEET (TELL FROM-BOX :GRAPHICS-SHEET))
  163.      (FROM-WID (GRAPHICS-SHEET-DRAW-WID FROM-SHEET));need these values if we want to erase
  164.      (FROM-HEI (GRAPHICS-SHEET-DRAW-HEI FROM-SHEET));unused space in the destination
  165.      (TO-WID (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET))
  166.      (TO-HEI (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET)))
  167.     FROM-WID FROM-HEI                ;bound but never used
  168.     (BITBLT TV:ALU-SETA (MIN FROM-WID TO-WID) (MIN TO-HEI FROM-HEI)
  169.         (GRAPHICS-SHEET-BIT-ARRAY FROM-SHEET)
  170.         0 0 (GRAPHICS-SHEET-BIT-ARRAY GRAPHICS-SHEET) 0 0))
  171.   (TELL SELF :MODIFIED))
  172.  
  173. (DEFMETHOD (GRAPHICS-BOX :PLACE-STAMP-WITH-CLIPPING) (FROM-BOX X Y &OPTIONAL(ALU TV:ALU-SETA))
  174.   (LET* ((FROM-SHEET (TELL FROM-BOX :GRAPHICS-SHEET))
  175.      (FROM-WID (GRAPHICS-SHEET-DRAW-WID FROM-SHEET));need these values if we want to erase
  176.      (FROM-HEI (GRAPHICS-SHEET-DRAW-HEI FROM-SHEET));unused space in the destination
  177.      (TO-WID (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET))
  178.      (TO-HEI (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET)))
  179.     (BITBLT ALU (MIN FROM-WID (- TO-WID X)) (MIN FROM-HEI (- TO-HEI Y))
  180.         (GRAPHICS-SHEET-BIT-ARRAY FROM-SHEET)
  181.         0 0 (GRAPHICS-SHEET-BIT-ARRAY GRAPHICS-SHEET) X Y))
  182.   (TELL SELF :MODIFIED))
  183.  
  184. (DEFUN MAKE-GRAPHICS-BOX (&OPTIONAL (WID *DEFAULT-GRAPHICS-BOX-WID*)
  185.                         (HEI *DEFAULT-GRAPHICS-BOX-HEI*))
  186.   (LET ((GB (MAKE-INITIALIZED-GRAPHICS-BOX ':FIXED-WID WID ':FIXED-HEI HEI)))
  187.         GB))
  188.  
  189. ;;; low level drawing utilities
  190.  
  191. ;;Following functions divide a floating point coordinate
  192. ;;position into a "screen" [integer multiple of screen size] and
  193. ;;fraction of screen from the left or bottom edge.  NOTE that
  194. ;;ALL these functions are meant to operate on ARRAY coords
  195.  
  196. ;;; drawing defs
  197.  
  198. (DEFVAR %BIT-ARRAY NIL
  199.   "The bit-array of the graphics-box being operated on")
  200.  
  201. (DEFVAR %DRAWING-WIDTH NIL
  202.   "The width of the bit-array of the graphics box in which we are allowed to draw")
  203.  
  204. (DEFVAR %DRAWING-HEIGHT NIL
  205.   "The height of the bit-array of the graphics box in which we are allowed to draw")
  206.  
  207. (DEFVAR %GRAPHICS-BOX NIL
  208.   "The graphics box which is being operated on.")
  209.  
  210. (DEFVAR %DRAW-MODE NIL
  211.   "Draw-mode of the graphics box in which we are allowed to draw")
  212.  
  213. (DEFMACRO WITH-GRAPHICS-VARS-BOUND (TO-BOX &BODY BODY)
  214. "This macro sets up an environment where commonly used parameters of the graphics box are bound. "
  215.   `(LET* ((GR-SHEET (TELL ,TO-BOX :GRAPHICS-SHEET))
  216.       (%BIT-ARRAY (GRAPHICS-SHEET-BIT-ARRAY GR-SHEET))
  217.       (%DRAWING-WIDTH (1- (GRAPHICS-SHEET-DRAW-WID GR-SHEET)))
  218.       (%DRAWING-HEIGHT (1- (GRAPHICS-SHEET-DRAW-HEI GR-SHEET)))
  219.       (%GRAPHICS-BOX ,TO-BOX)
  220.         (%DRAW-MODE (GRAPHICS-SHEET-DRAW-MODE GR-SHEET)))
  221.      (PROGN . ,BODY)))
  222.  
  223. ;; Here is the line drawing stuff
  224.  
  225. ;;; This is the highest level drawing command.
  226.  
  227. (DEFUN CK-MODE-DRAW-LINE (FROM-X FROM-Y TO-X TO-Y &OPTIONAL (ALU TV:ALU-XOR))
  228.  (IF (EQ %DRAW-MODE ':WRAP)
  229.      (DRAW-WRAP-LINE FROM-X FROM-Y TO-X TO-Y ALU)
  230.      (DRAW-WINDOW-LINE FROM-X FROM-Y TO-X TO-Y ALU)))
  231.  
  232. (DEFSUBST OUT-OF-RANGE? (X0 Y0 X1 Y1)
  233.   (OR (AND (< X0 0) (< X1 0))
  234.       (AND (> X0 %DRAWING-WIDTH) (> X1 %DRAWING-WIDTH))
  235.       (AND (< Y1 0) (< Y0 0))
  236.       (AND (> Y0 %DRAWING-HEIGHT) (> Y1 %DRAWING-HEIGHT))))
  237.  
  238. (DEFUN DRAW-WINDOW-LINE (X0 Y0 X1 Y1 ALU)
  239.  (UNLESS (OUT-OF-RANGE? X0 Y0 X1 Y1)
  240.    (DRAW-VECTOR-WITH-CLIPPING X0 Y0 X1 Y1 ALU)))
  241.  
  242. (DEFSUBST WINDOW-CLIP-X (X-POS)
  243.  (MIN (1- %DRAWING-WIDTH) (MAX X-POS 0)))
  244.  
  245. (DEFSUBST WINDOW-CLIP-Y (Y-POS)
  246.   (MIN (1- %DRAWING-HEIGHT) (MAX Y-POS 0)))
  247.  
  248. ;;; This works in some tricky places where gregor's routine doesn't
  249. (DEFUN CALC-CLIPPED-VECTOR (X0 Y0 X1 Y1)
  250.   (COND ((AND (POINT-IN-ARRAY? X0 Y0) (POINT-IN-ARRAY? X1 Y1))
  251.      (VALUES X0 Y0 X1 Y1))                
  252.     ((= X0 X1) 
  253.      (VALUES X0 (WINDOW-CLIP-Y Y0) X1 (WINDOW-CLIP-Y Y1)))
  254.     ((= Y0 Y1)
  255.      (VALUES (WINDOW-CLIP-X X0) Y0 (WINDOW-CLIP-X X1) Y0))
  256.     (T
  257.      (LET ((X-LENGTH (FLOAT (- X1 X0))) (Y-LENGTH (FLOAT (- Y1 Y0)))
  258.            (CLIPPED-X0 (WINDOW-CLIP-X X0))
  259.            (CLIPPED-Y0 (WINDOW-CLIP-Y Y0))
  260.            (CLIPPED-X1 (WINDOW-CLIP-X X1))
  261.            (CLIPPED-Y1 (WINDOW-CLIP-Y Y1)))
  262.        (IF (< (// (FLOAT (- CLIPPED-X1 X0))
  263.               X-LENGTH)
  264.           (// (FLOAT (- CLIPPED-Y1 Y0))
  265.               Y-LENGTH))
  266.            (SETQ CLIPPED-Y1 (+ Y0 (* (- CLIPPED-X1 X0)
  267.                      (// Y-LENGTH X-LENGTH))))
  268.            (SETQ CLIPPED-X1 (+ X0 (* (- CLIPPED-Y1 Y0)
  269.                      (// X-LENGTH Y-LENGTH)))))
  270.        (IF (< (// (FLOAT (- X1 CLIPPED-X0))
  271.               X-LENGTH)
  272.           (// (FLOAT (- Y1 CLIPPED-Y0))
  273.               Y-LENGTH))
  274.            (SETQ CLIPPED-Y0 (- Y1 (* (- X1 CLIPPED-X0)
  275.                      (// Y-LENGTH X-LENGTH))))
  276.            (SETQ CLIPPED-X0 (- X1 (* (- Y1 CLIPPED-Y0)
  277.                      (// X-LENGTH Y-LENGTH)))))
  278.        (WHEN (POINT-IN-ARRAY? (FIXR CLIPPED-X0) (FIXR CLIPPED-Y0))
  279.          (VALUES (FIXR CLIPPED-X0) (FIXR CLIPPED-Y0)
  280.              (FIXR CLIPPED-X1) (FIXR CLIPPED-Y1)))))))
  281.  
  282. ;;; This function clips a vector and draws it both to the
  283. ;;; graphics-box bit array and to each visible screen object.
  284.  
  285. (DEFUN DRAW-VECTOR-WITH-CLIPPING (X0 Y0 X1 Y1 ALU)
  286.   (MULTIPLE-VALUE-BIND (CLIPPED-X0 CLIPPED-Y0 CLIPPED-X1 CLIPPED-Y1)
  287.       (CALC-CLIPPED-VECTOR X0 Y0 X1 Y1)
  288.     (WHEN CLIPPED-X0
  289.     (DRAW-VECTOR CLIPPED-X0 CLIPPED-Y0 CLIPPED-X1 CLIPPED-Y1 ALU))))
  290.  
  291. ;;; The following does not check clipping --- use with care !!!
  292.  
  293. (DEFUN DRAW-VECTOR (CLIPPED-X0 CLIPPED-Y0 CLIPPED-X1 CLIPPED-Y1 ALU)
  294.   (LET ((END-POINT? (NOT (= ALU TV:ALU-XOR))))
  295.     (WITHOUT-INTERRUPTS
  296.       (WHEN (GRAPHICS-BOX? %GRAPHICS-BOX)
  297.     (DOLIST (SCREEN-BOX (GET-VISIBLE-SCREEN-OBJS  %GRAPHICS-BOX))
  298.       (UNLESS (EQ ':SHRUNK (TELL SCREEN-BOX :DISPLAY-STYLE))
  299.          (DRAWING-ON-TURTLE-SLATE SCREEN-BOX
  300.           (SYS:%DRAW-LINE (SCALE-X CLIPPED-X0) (SCALE-Y CLIPPED-Y0)
  301.                   (SCALE-X CLIPPED-X1) (SCALE-Y CLIPPED-Y1)
  302.                   ALU END-POINT? %DRAWING-ARRAY)))))
  303.       (SYS:%DRAW-LINE CLIPPED-X0 CLIPPED-Y0 CLIPPED-X1 CLIPPED-Y1
  304.               ALU END-POINT? %BIT-ARRAY))))
  305.   
  306. (DEFUN DRAW-WRAP-LINE (FROM-X FROM-Y TO-X TO-Y &OPTIONAL (ALU TV:ALU-XOR))
  307.        "Draws vector allowing wraparound. Arguments in ARRAY coordinates."
  308.        (LET ((FROM-SCREEN-X (SCREEN-X FROM-X))
  309.          (FROM-SCREEN-Y (SCREEN-Y FROM-Y))
  310.          (TO-SCREEN-X (SCREEN-X TO-X))
  311.          (TO-SCREEN-Y (SCREEN-Y TO-Y)))
  312.         (LET ((FROM-FRACTION-X (SCREEN-FRACTION-X FROM-SCREEN-X FROM-X))
  313.           (FROM-FRACTION-Y (SCREEN-FRACTION-Y FROM-SCREEN-Y FROM-Y))
  314.           (TO-FRACTION-X (SCREEN-FRACTION-X TO-SCREEN-X TO-X))
  315.           (TO-FRACTION-Y (SCREEN-FRACTION-Y TO-SCREEN-Y TO-Y)))
  316.                  ;;Split up into screens and fractions of screens, then hand off
  317.                  ;;to WRAP-SCREEN-VECTOR.
  318.          (WRAP-SCREEN-VECTOR FROM-SCREEN-X FROM-FRACTION-X
  319.                      FROM-SCREEN-Y FROM-FRACTION-Y
  320.                      TO-SCREEN-X TO-FRACTION-X
  321.                      TO-SCREEN-Y TO-FRACTION-Y
  322.                      ALU))))
  323.  
  324. (DEFUN SCREEN-X (WRAP-X)
  325.   (IF (MINUSP WRAP-X)
  326.        (1- (FIX (// WRAP-X %DRAWING-WIDTH))) ;PERHAPS 1+
  327.        (FIX (// WRAP-X %DRAWING-WIDTH))))
  328.  
  329. (DEFUN SCREEN-Y (WRAP-Y)
  330.   (IF (MINUSP WRAP-Y)
  331.       (1- (FIX (// WRAP-Y %DRAWING-HEIGHT)))
  332.       (FIX (// WRAP-Y %DRAWING-HEIGHT))))
  333.  
  334. (DEFUN SCREEN-FRACTION-X (SCREEN-WIDS WRAP-X)
  335.   (// (FLOAT (- WRAP-X (* SCREEN-WIDS %DRAWING-WIDTH)))
  336.       %DRAWING-WIDTH))
  337.  
  338. (DEFUN SCREEN-FRACTION-Y (SCREEN-HEIS WRAP-Y)
  339.   (// (FLOAT (- WRAP-Y (* SCREEN-HEIS %DRAWING-HEIGHT)))
  340.       %DRAWING-HEIGHT))
  341.  
  342. (DEFUN WRAP-SCREEN-VECTOR (FROM-SCREEN-X FROM-FRACTION-X FROM-SCREEN-Y FROM-FRACTION-Y
  343.                TO-SCREEN-X   TO-FRACTION-X   TO-SCREEN-Y   TO-FRACTION-Y
  344.                ALU 
  345.                &AUX TO-EDGE-X SIGN-X TO-EDGE-Y SIGN-Y
  346.                FROM-EDGE-FRACTION TO-EDGE-FRACTION)
  347.        (WITHOUT-INTERRUPTS
  348.      (COND ((NOT (= FROM-SCREEN-X TO-SCREEN-X))
  349.               ;; Vector crosses a X screen edge.
  350.               (LET ((CHANGE-X (+ (- TO-SCREEN-X FROM-SCREEN-X)
  351.                  (- TO-FRACTION-X FROM-FRACTION-X)))
  352.                     (CHANGE-Y (+ (- TO-SCREEN-Y FROM-SCREEN-Y)
  353.                  (- TO-FRACTION-Y FROM-FRACTION-Y))))
  354.         (IF (PLUSP CHANGE-X)
  355.             (SETQ SIGN-X 1.
  356.               TO-EDGE-X (- 1.0 FROM-FRACTION-X)
  357.               FROM-EDGE-FRACTION 1.0
  358.               TO-EDGE-FRACTION 0.0)
  359.             (SETQ SIGN-X -1.
  360.               TO-EDGE-X (- FROM-FRACTION-X)
  361.               FROM-EDGE-FRACTION 0.0
  362.               TO-EDGE-FRACTION 1.0))
  363.         ;; compute the X and Y coordinates to split the vector at the X edge
  364.         (LET* ((EDGE-FRACTION-Y (+ FROM-FRACTION-Y
  365.                        (* TO-EDGE-X (// CHANGE-Y CHANGE-X))))
  366.                (EDGE-SCREEN-Y FROM-SCREEN-Y)
  367.                (FIX-EDGE-FRACTION (FIX EDGE-FRACTION-Y)))
  368.           (INCF EDGE-SCREEN-Y FIX-EDGE-FRACTION)
  369.           (SETQ EDGE-FRACTION-Y (- EDGE-FRACTION-Y (FLOAT FIX-EDGE-FRACTION)))
  370.           ;; draw a vector from the FROM point to the edge...
  371.           (WRAP-SCREEN-VECTOR FROM-SCREEN-X FROM-FRACTION-X 
  372.                       FROM-SCREEN-Y FROM-FRACTION-Y
  373.                       FROM-SCREEN-X FROM-EDGE-FRACTION
  374.                       EDGE-SCREEN-Y EDGE-FRACTION-Y
  375.                       ALU)
  376.           ;;  ...and then continue on to the TO point
  377.           (WRAP-SCREEN-VECTOR (+ FROM-SCREEN-X SIGN-X) 
  378.                       TO-EDGE-FRACTION 
  379.                       EDGE-SCREEN-Y EDGE-FRACTION-Y 
  380.                       TO-SCREEN-X TO-FRACTION-X 
  381.                       TO-SCREEN-Y TO-FRACTION-Y
  382.                       ALU))))
  383.          ((NOT (= FROM-SCREEN-Y TO-SCREEN-Y))
  384.           ;; Vector crosses a Y screen edge
  385.           (LET ((CHANGE-X (+ (- TO-SCREEN-X FROM-SCREEN-X)
  386.                  (- TO-FRACTION-X FROM-FRACTION-X)))
  387.                     (CHANGE-Y (+ (- TO-SCREEN-Y FROM-SCREEN-Y)
  388.                  (- TO-FRACTION-Y FROM-FRACTION-Y))))
  389.         (IF (PLUSP CHANGE-Y)
  390.             (SETQ SIGN-Y 1.        
  391.               TO-EDGE-Y (- 1.0 FROM-FRACTION-Y)
  392.               FROM-EDGE-FRACTION 1.0
  393.               TO-EDGE-FRACTION 0.0)
  394.             (SETQ SIGN-Y -1.
  395.               TO-EDGE-Y (- FROM-FRACTION-Y)
  396.               FROM-EDGE-FRACTION 0.0
  397.               TO-EDGE-FRACTION 1.0))
  398.         ;; compute the X and Y coordinates to split the vector at the Y edge
  399.         (LET* ((EDGE-FRACTION-X (+ FROM-FRACTION-X
  400.                        (* TO-EDGE-Y (// CHANGE-X CHANGE-Y))))
  401.                (EDGE-SCREEN-X FROM-SCREEN-X)
  402.                (FIX-EDGE-FRACTION (FIX EDGE-FRACTION-X)))
  403.           (INCF EDGE-SCREEN-X FIX-EDGE-FRACTION)
  404.           (SETQ EDGE-FRACTION-X (- EDGE-FRACTION-X (FLOAT FIX-EDGE-FRACTION)))
  405.           ;; draw a vector from the FROM point to the edge...
  406.           (WRAP-SCREEN-VECTOR FROM-SCREEN-X FROM-FRACTION-X
  407.                       FROM-SCREEN-Y FROM-FRACTION-Y
  408.                       EDGE-SCREEN-X EDGE-FRACTION-X
  409.                       FROM-SCREEN-Y FROM-EDGE-FRACTION
  410.                       ALU)
  411.           ;;  ...and then continue on to the TO point
  412.           (WRAP-SCREEN-VECTOR EDGE-SCREEN-X            EDGE-FRACTION-X
  413.                       (+ FROM-SCREEN-Y SIGN-Y) TO-EDGE-FRACTION
  414.                       TO-SCREEN-X TO-FRACTION-X
  415.                       TO-SCREEN-Y TO-FRACTION-Y
  416.                       ALU))))
  417.          (T                    ;looks like its cool to draw the line as is
  418.           (LET ((X0 (FIXR (* %DRAWING-WIDTH FROM-FRACTION-X)))
  419.             (Y0 (FIXR (* %DRAWING-HEIGHT FROM-FRACTION-Y)))
  420.             (X1 (FIXR (* %DRAWING-WIDTH TO-FRACTION-X)))
  421.             (Y1 (FIXR (* %DRAWING-HEIGHT TO-FRACTION-Y))))
  422.         (DRAW-VECTOR X0 Y0 X1 Y1 ALU))))))
  423.  
  424. ;;; This function draw a list of vectors and strings.  The below
  425. ;;; is what draws a turtle's shape given its vector list
  426. ;;; repesentation.  I think the iteration construct could be
  427. ;;; written more cleanly.
  428.  
  429. (DEFCONST *DEFAULT-GRAPHICS-FONT* FONTS:TVFONT
  430.   "The font used for drawing in graphics boxes")
  431.  
  432. (DEFCONST *FONT-WIDTH* (FONT-CHAR-WIDTH *DEFAULT-GRAPHICS-FONT*))
  433.  
  434. (DEFCONST *FONT-HEIGHT* (FONT-CHAR-HEIGHT *DEFAULT-GRAPHICS-FONT*))
  435.  
  436. (DEFUN DRAW-VECTOR-LIST (V-LIST SIZE START-X START-Y HEADING &OPTIONAL (ALU TV:ALU-XOR))
  437.   (D-V-L-ITER V-LIST START-X START-Y (* SIZE (COSD HEADING)) (* SIZE (SIND HEADING)) 'D ALU))
  438.  
  439. (DEFUN D-V-L-ITER (V-LIST START-X START-Y COS-HEAD SIN-HEAD PEN ALU)
  440.     (DO ()
  441.     ((NULL V-LIST))
  442.     (COND 
  443.       ((MEMQ (FIRST V-LIST) '(UP :UP :ERASE ERASE))
  444.        (SETQ PEN 'U V-LIST (CDR V-LIST)))
  445.       ((MEMQ (FIRST V-LIST) '(DOWN XOR :DOWN :XOR))
  446.        (SETQ PEN 'D V-LIST (CDR V-LIST)))
  447.       ((STRINGP (FIRST V-LIST))
  448.        (WHEN (EQ PEN 'D)
  449.          (LET ((XPOS (FIXR (+ 3. START-X))) (YPOS (FIXR (1+ START-Y))))
  450.          (DRAW-STRING-TO-GBOX (FIRST V-LIST) XPOS YPOS)))
  451.        (SETQ V-LIST (CDR V-LIST)))
  452.       ;; compatibility with an old format.  remove this soon 6/30/85
  453.       ((LISTP (FIRST V-LIST))
  454.        (WHEN (EQ PEN 'D)
  455.          (LET ((XPOS (FIXR (+ 3. START-X))) (YPOS (FIXR (1+ START-Y))))
  456.          (DRAW-STRING-TO-GBOX (CAR (FIRST V-LIST)) XPOS YPOS)))
  457.        (SETQ V-LIST (CDR V-LIST)))
  458.       (T
  459.        (LET ((END-X (+ START-X
  460.                (* (FIRST V-LIST) COS-HEAD)
  461.                (* (SECOND V-LIST) (- SIN-HEAD))))
  462.          (END-Y (+ START-Y
  463.                (* (+ (* (FIRST V-LIST) SIN-HEAD)
  464.                  (* (SECOND V-LIST) COS-HEAD))
  465.                   *SCRUNCH-FACTOR*))))
  466.          (WHEN (EQ PEN 'D)
  467.            (DRAW-WINDOW-LINE (FIXR START-X) (FIXR START-Y)
  468.                   (FIXR END-X) (FIXR END-Y) ALU))
  469.          (SETQ START-X END-X START-Y END-Y V-LIST (CDDR V-LIST)))))))
  470.  
  471. ;;; drawing chars on graphics windows
  472.  
  473. (DEFSUBST CLIP-STRING (STRING X-POS)
  474.   (LET ((NEW-LENGTH (MIN (STRING-LENGTH STRING)
  475.              (FIXR (// (- %DRAWING-WIDTH X-POS) *FONT-WIDTH*)))))
  476.     (SUBSTRING STRING 0 NEW-LENGTH)))
  477.  
  478. ;;; no CR's
  479. (DEFUN DRAW-SIMPLE-STRING-TO-GBOX (STRING X-POS Y-POS ALU)
  480.   (IF (NOT (AND (POINT-IN-ARRAY? X-POS Y-POS)
  481.         (POINT-IN-ARRAY? X-POS (+ Y-POS *FONT-HEIGHT*))))
  482.       NIL ;;; can not print string at all
  483.       (LET* ((CLIPPED-STRING (CLIP-STRING STRING X-POS))
  484.          (CHAR-LIST (MAPCAR (FUNCTION CHARACTER)
  485.                 (LISTARRAY CLIPPED-STRING))))
  486.     (WITHOUT-INTERRUPTS
  487.       ;;; draw to the bit array
  488.       (LET ((CURSOR X-POS))
  489.         (DOLIST (CHAR CHAR-LIST)
  490.           (SYS:%DRAW-CHAR *DEFAULT-GRAPHICS-FONT*
  491.                   CHAR CURSOR Y-POS ALU %BIT-ARRAY)
  492.           (SETQ CURSOR (+ CURSOR *FONT-WIDTH*))))
  493.       ;;; draw to each visible screen object
  494.       (WHEN (GRAPHICS-BOX? %GRAPHICS-BOX)
  495.         (DRAWING-ON-WINDOW (*BOXER-PANE*)
  496.           (DOLIST (SCREEN-BOX (GET-VISIBLE-SCREEN-OBJS  %GRAPHICS-BOX))
  497.         (UNLESS (EQ ':SHRUNK (TELL SCREEN-BOX :DISPLAY-STYLE))
  498.           (WITH-TURTLE-SLATE-ORIGINS SCREEN-BOX    ;
  499.             (LET ((CURSOR-X (+ X-POS %ORIGIN-X-OFFSET))
  500.               (CURSOR-Y (+ Y-POS %ORIGIN-Y-OFFSET)))
  501.               (DOLIST (CHAR CHAR-LIST)
  502.             (SYS:%DRAW-CHAR *DEFAULT-GRAPHICS-FONT*
  503.                     CHAR CURSOR-X CURSOR-Y ALU %DRAWING-ARRAY)
  504.             (SETQ CURSOR-X (+ CURSOR-X *FONT-WIDTH*)))
  505.               )))))))
  506.     CLIPPED-STRING)))
  507.  
  508. ;;; CR's are allowed
  509. (DEFUN DRAW-STRING-TO-GBOX (STRING X-POS START-Y-POS &OPTIONAL (ALU TV:ALU-XOR))
  510.   (LOOP WITH START = 0
  511.     WITH Y-POS = START-Y-POS
  512.     FOR INDEX FROM 0 TO (1- (STRING-LENGTH STRING))
  513.     FOR CHA = (AREF STRING INDEX)
  514.     WHEN (OR (CHAR= CHA #\CR) (CHAR= CHA #\LINE))
  515.       DO (DRAW-SIMPLE-STRING-TO-GBOX (NSUBSTRING STRING START INDEX) X-POS Y-POS ALU)
  516.          (SETQ START (1+ INDEX)
  517.            Y-POS (+ Y-POS *FONT-HEIGHT*))
  518.     FINALLY
  519.       (DRAW-SIMPLE-STRING-TO-GBOX (NSUBSTRING STRING START INDEX) X-POS Y-POS ALU)))
  520.