home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / draw.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  16.4 KB  |  416 lines
  1. ; -*- Mode:LISP; Package:BOXER; Base:8.;fonts:cptfont -*- 
  2.  
  3. ;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;
  5. ;; Permission to use, copy, modify, distribute, and sell this software
  6. ;; and its documentation for any purpose is hereby granted without fee,
  7. ;; provided that the above copyright notice appear in all copies and that
  8. ;; both that copyright notice and this permission notice appear in
  9. ;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;; advertising or publicity pertaining to distribution of the software
  11. ;; without specific, written prior permission.  M.I.T. makes no
  12. ;; representations about the suitability of this software for any
  13. ;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;
  15.  
  16. ;;;; DRAWING-ON-WINDOW
  17.  
  18. (DEFVAR %DRAWING-WINDOW NIL
  19.   "Inside of a drawing-on-window, this variable is bound to the window which
  20.    was given as an argument to drawing-on window, makes sense right.")
  21.  
  22. (DEFVAR %DRAWING-ARRAY NIL
  23.   "Inside of a drawing-on-window, this variable is bound to %drawing-window's
  24.    screen-array (Note that this value is valid because drawing-on-window does
  25.    a prepare-sheet of drawing-window.")
  26.  
  27. (DEFVAR %DRAWING-FONT-MAP NIL
  28.   "Inside of a drawing-on-window, this variable is bound to %drawing-window's
  29.    font-map.")  
  30.  
  31. (DEFVAR %ORIGIN-X-OFFSET 0
  32.   "Inside of a drawing-on-window, this variable is bound to x-offset of the
  33.    current drawing origin from the screen's actual x origin. With-origin-at
  34.    rebinds this variable (and %origin-y-offset) to change the screen position
  35.    of the drawing origin.")
  36.  
  37. (DEFVAR %ORIGIN-Y-OFFSET 0
  38.   "Inside of a drawing-on-window, this variable is bound to y-offset of the
  39.    current drawing origin from the screen's actual y origin. With-origin-at
  40.    rebinds this variable (and %origin-y-offset) to change the screen position
  41.    of the drawing origin.")
  42.  
  43. (DEFVAR %CLIP-LEF 0)
  44. (DEFVAR %CLIP-TOP 0)
  45. (DEFVAR %CLIP-RIG 0)
  46. (DEFVAR %CLIP-BOT 0)
  47.  
  48.  
  49. ;;; DRAWING-ON-WINDOW is an &body macro which all the drawing macros in this
  50. ;;; must be called inside of. It basically prepares the window to be drawn on
  51. ;;; and binds all the magic variables that the drawing macros need including
  52. ;;; the bootstrapping of the clipping and coordinate scaling variables.
  53.  
  54. (DEFMACRO DRAWING-ON-WINDOW ((WINDOW) &BODY BODY)
  55.   (ONCE-ONLY (WINDOW)
  56.     `(TV:PREPARE-SHEET (,WINDOW)
  57.        (DRAWING-ON-WINDOW-WITHOUT-PREPARE-SHEET (,WINDOW) . ,BODY))))
  58.  
  59. ;;; DRAWING-ON-WINDOW-WITHOUT-PREPARE-SHEET is a variant of Drawing-On-Window
  60. ;;; which does everything Drawing-On-Window does except that it does not do a
  61. ;;; tv:prepare-sheet of the window. Unless you really know what you are doing
  62. ;;; you should only use this inside the :BLINK method for a blinker.
  63.  
  64. (DEFMACRO DRAWING-ON-WINDOW-WITHOUT-PREPARE-SHEET ((WINDOW) &BODY BODY)
  65.   (ONCE-ONLY (WINDOW)
  66.     `(LET ((%DRAWING-WINDOW ,WINDOW)
  67.        (%DRAWING-ARRAY (TV:SHEET-SCREEN-ARRAY ,WINDOW))
  68.        (%DRAWING-FONT-MAP (TV:SHEET-FONT-MAP ,WINDOW)))
  69.        %DRAWING-WINDOW %DRAWING-ARRAY %DRAWING-FONT-MAP       ;Bound but never...
  70.        (DRAWING-ON-WINDOW-BOOTSTRAP-CLIPPING-AND-SCALING ((TV:SHEET-INSIDE-LEFT ,WINDOW)
  71.                               (TV:SHEET-INSIDE-TOP  ,WINDOW)
  72.                               (TV:SHEET-INSIDE-WIDTH ,WINDOW)
  73.                               (TV:SHEET-INSIDE-HEIGHT ,WINDOW))
  74.      . ,BODY))))
  75.  
  76. ;;; WITH-FONT-MAP-BOUND is meant to be used by all those functions (like BOX-BORDER-FN's
  77. ;;; that have to be called in an environment where the font map is supposed to be bound but
  78. ;;; nothing else (like all those wonderful drawing type things and stuff) needs to be bound
  79.  
  80. (DEFMACRO WITH-FONT-MAP-BOUND ((WINDOW) &BODY BODY)
  81.   `(LET ((%DRAWING-FONT-MAP (TV:SHEET-FONT-MAP ,WINDOW)))
  82.      %DRAWING-FONT-MAP                ;bound but never used etc.
  83.      . ,BODY))
  84.  
  85. ;;; The normal functions for binding the clipping and scaling variables depend
  86. ;;; on the already existing values of those variables. This means that those
  87. ;;; variables need to be specially boot-strapped.
  88.  
  89. (DEFMACRO DRAWING-ON-WINDOW-BOOTSTRAP-CLIPPING-AND-SCALING ((X Y WID HEI) &BODY BODY)
  90.   `(LET* ((%CLIP-LEF ,X)
  91.       (%CLIP-TOP ,Y)
  92.       (%CLIP-RIG (+ %CLIP-LEF ,WID))
  93.       (%CLIP-BOT (+ %CLIP-TOP ,HEI))
  94.       (%ORIGIN-X-OFFSET ,X)
  95.       (%ORIGIN-Y-OFFSET ,Y))
  96.      %CLIP-RIG %CLIP-BOT %ORIGIN-X-OFFSET %ORIGIN-Y-OFFSET ;Bound but never...
  97.      . ,BODY))
  98.  
  99.  
  100.  
  101. ;;; WITH-DRAWING-INSIDE-REGION is the function people should call to wall off
  102. ;;; a sub-region of the current region to draw in. This is an &body macro which
  103. ;;; sets things up such that all drawing macros evaluated inside the body of the
  104. ;;; macro will draw in the coordinate frame of that region, and will be clipped
  105. ;;; to the boundaries of the region.
  106.  
  107. (DEFMACRO WITH-DRAWING-INSIDE-REGION ((X Y WID HEI) &BODY BODY)
  108.   `(WITH-CLIPPING-INSIDE (,X ,Y ,WID ,HEI)
  109.      (WITH-ORIGIN-AT (,X ,Y)
  110.        . ,BODY)))
  111.  
  112. (DEFMACRO WITH-ORIGIN-AT ((X Y) &BODY BODY)
  113.   `(LET ((%ORIGIN-X-OFFSET (SCALE-X ,X))
  114.      (%ORIGIN-Y-OFFSET (SCALE-Y ,Y)))
  115.      %ORIGIN-X-OFFSET %ORIGIN-Y-OFFSET
  116.      . ,BODY))
  117.  
  118. (DEFMACRO WITH-CLIPPING-INSIDE ((X Y WID HEI) &BODY BODY)
  119.   `(LET* ((%CLIP-LEF (MAX %CLIP-LEF (SCALE-X ,X)))
  120.       (%CLIP-TOP (MAX %CLIP-TOP (SCALE-Y ,Y)))
  121.       (%CLIP-RIG (MIN %CLIP-RIG (+ %CLIP-LEF ,WID)))
  122.       (%CLIP-BOT (MIN %CLIP-BOT (+ %CLIP-TOP ,HEI))))
  123.      %CLIP-RIG %CLIP-BOT
  124.      . ,BODY))
  125.  
  126.  
  127. (DEFMACRO SCALE-X (X)
  128.   `(+ ,X %ORIGIN-X-OFFSET))
  129.  
  130. (DEFMACRO SCALE-Y (Y)
  131.   `(+ ,Y %ORIGIN-Y-OFFSET))
  132.  
  133. (DEFMACRO CLIP-X (SCALED-X)
  134.   `(MAX %CLIP-LEF (MIN ,SCALED-X %CLIP-RIG)))
  135.  
  136. (DEFMACRO CLIP-Y (SCALED-Y)
  137.   `(MAX %CLIP-TOP (MIN ,SCALED-Y %CLIP-BOT)))
  138.  
  139. (DEFMACRO X-OUT-OF-BOUNDS? (SCALED-X)
  140.   `(OR (< ,SCALED-X %CLIP-LEF) (> ,SCALED-X %CLIP-RIG)))
  141.  
  142. (DEFMACRO Y-OUT-OF-BOUNDS? (SCALED-Y)
  143.   `(OR (< ,SCALED-Y %CLIP-TOP) (> ,SCALED-Y %CLIP-BOT)))
  144.  
  145. (DEFMACRO SIGN-OF-NO (X)
  146.   `(IF (PLUSP ,X) 1 -1))
  147.  
  148.  
  149.  
  150. ;; NOTE,, do anything to make the code that does clipping faster and
  151. ;; less readable and I will cut your fingers right off. Understand, you
  152. ;; may find this overly simple, but I like to be able to figure out what
  153. ;; the hell is going on with drawing code since its so hard to debug.
  154.  
  155. (DEFMACRO DRAW-RECTANGLE (ALU WID HEI X Y)
  156.   `(LET* ((CLIPPED-X (CLIP-X (SCALE-X ,X)))
  157.       (CLIPPED-Y (CLIP-Y (SCALE-Y ,Y)))
  158.       (CLIPPED-WID (- (CLIP-X (+ CLIPPED-X (ABS ,WID))) CLIPPED-X))
  159.       (CLIPPED-HEI (- (CLIP-Y (+ CLIPPED-Y (ABS ,HEI))) CLIPPED-Y)))
  160.      (OR (ZEROP CLIPPED-WID)                    ;%draw-rectangle bombs out
  161.      (ZEROP CLIPPED-HEI)                    ;if wid or hei is 0..
  162.      (TV:%DRAW-RECTANGLE CLIPPED-WID CLIPPED-HEI
  163.                  CLIPPED-X CLIPPED-Y
  164.                  ,ALU %DRAWING-WINDOW))))
  165.  
  166. (DEFMACRO SLOPE (X0 Y0 X1 Y1)
  167.   `(// (FLOAT (- (SCALE-Y ,Y1) (SCALE-Y ,Y0))) (FLOAT (- (SCALE-X ,X1) (SCALE-X ,X0)))))
  168.  
  169. (DEFMACRO ISLOPE (X0 Y0 X1 Y1)
  170.   `(// (FLOAT (- (SCALE-X ,X1) (SCALE-X ,X0))) (FLOAT (- (SCALE-Y ,Y1) (SCALE-Y ,Y0)))))
  171.  
  172. (DEFMACRO DRAW-LINE (X0 Y0 X1 Y1 ALU END-POINT?)
  173.   `(LET* ((CLIPPED-X0 (CLIP-X (SCALE-X ,X0)))
  174.       (CLIPPED-Y0 (CLIP-Y (SCALE-Y ,Y0)))
  175.       (CLIPPED-X1 (CLIP-X (SCALE-X ,X1)))
  176.       (CLIPPED-Y1 (CLIP-Y (SCALE-Y ,Y1)))
  177.       (X0-CUTOFF (- (SCALE-X ,X0) CLIPPED-X0))
  178.       (Y0-CUTOFF (- (SCALE-Y ,Y0) CLIPPED-Y0))
  179.       (X1-CUTOFF (- (SCALE-X ,X1) CLIPPED-X1))
  180.       (Y1-CUTOFF (- (SCALE-Y ,Y1) CLIPPED-Y1)))
  181.      (COND ((OR (AND (PLUSP X0-CUTOFF) (PLUSP X1-CUTOFF))
  182.         ;;line is totally clipped
  183.         (AND (PLUSP Y0-CUTOFF) (PLUSP Y1-CUTOFF))))
  184.        (T
  185.         (COND
  186.           ((PLUSP X0-CUTOFF)
  187.            ;; clipped on a vertical edge
  188.            (SETQ CLIPPED-Y0
  189.              (FIX (- (SCALE-Y ,Y0) (* X0-CUTOFF (SLOPE ,X0 ,Y0 ,X1 ,Y1))))))
  190.           ((PLUSP X1-CUTOFF)
  191.            ;; clipped on a vertical edge
  192.            (SETQ CLIPPED-Y1
  193.              (FIX (- (SCALE-Y ,Y1) (* X1-CUTOFF (SLOPE ,X0 ,Y0 ,X1 ,Y1))))))
  194.           ((PLUSP Y0-CUTOFF)
  195.            ;; clipped on a horizontal edge
  196.            (SETQ CLIPPED-X0
  197.              (FIX (- (SCALE-X ,X0) (* Y0-CUTOFF (ISLOPE ,X0 ,Y0 ,X1 ,Y1))))))
  198.           ((PLUSP Y1-CUTOFF)
  199.            ;; clipped on a horizontal edge
  200.            (SETQ CLIPPED-X1
  201.              (FIX (- (SCALE-X ,X1) (* Y1-CUTOFF (ISLOPE ,X0 ,Y0 ,X1 ,Y1)))))))
  202.         (SYS:%DRAW-LINE CLIPPED-X0 CLIPPED-Y0
  203.                 CLIPPED-X1 CLIPPED-Y1
  204.                 ,ALU ,END-POINT? %DRAWING-WINDOW)))))
  205.  
  206. (DEFMACRO BITBLT-TO-SCREEN (ALU WID HEI FROM-ARRAY FROM-X FROM-Y TO-X TO-Y)
  207.   `(LET* ((SCALED-TO-X (SCALE-X ,TO-X))
  208.       (SCALED-TO-Y (SCALE-Y ,TO-Y))
  209.       (CLIPPED-TO-X (CLIP-X SCALED-TO-X))
  210.       (CLIPPED-TO-Y (CLIP-Y SCALED-TO-Y))
  211.       (+WID (ABS ,WID))
  212.       (+HEI (ABS ,HEI))
  213.       (LEF-OVERRUN (MAX 0 (- SCALED-TO-X CLIPPED-TO-X)))
  214.       (TOP-OVERRUN (MAX 0 (- SCALED-TO-Y CLIPPED-TO-Y)))
  215.       (RIG-OVERRUN (MAX 0 (- (+ CLIPPED-TO-X +WID) (CLIP-X (+ CLIPPED-TO-X +WID)))))
  216.       (BOT-OVERRUN (MAX 0 (- (+ CLIPPED-TO-Y +HEI) (CLIP-Y (+ CLIPPED-TO-Y +HEI)))))
  217.       (CLIPPED-WID (* (SIGN-OF-NO ,WID) (MAX 0 (- +WID LEF-OVERRUN RIG-OVERRUN))))
  218.       (CLIPPED-HEI (* (SIGN-OF-NO ,HEI) (MAX 0 (- +HEI TOP-OVERRUN BOT-OVERRUN)))))
  219.      (OR (ZEROP CLIPPED-WID)                    ;%draw-rectangle bombs out
  220.      (ZEROP CLIPPED-HEI)                    ;if wid or hei is 0..
  221.      (BITBLT ,ALU CLIPPED-WID CLIPPED-HEI
  222.          ,FROM-ARRAY   (+ ,FROM-X LEF-OVERRUN) (+ ,FROM-Y TOP-OVERRUN)
  223.          %DRAWING-ARRAY CLIPPED-TO-X  CLIPPED-TO-Y))))
  224.  
  225. (DEFMACRO BITBLT-WITHIN-SCREEN (ALU WID HEI FROM-X FROM-Y TO-X TO-Y)
  226.   `(LET* ((SCALED-FROM-X (SCALE-X ,FROM-X))
  227.       (SCALED-FROM-Y (SCALE-Y ,FROM-Y))
  228.       (SCALED-TO-X (SCALE-X ,TO-X))
  229.       (SCALED-TO-Y (SCALE-Y ,TO-Y))
  230.       (CLIPPED-FROM-X (CLIP-X SCALED-FROM-X))
  231.       (CLIPPED-FROM-Y (CLIP-Y SCALED-FROM-Y))
  232.       (CLIPPED-TO-X (CLIP-X SCALED-TO-X))
  233.       (CLIPPED-TO-Y (CLIP-Y SCALED-TO-Y))
  234.       (+WID (ABS ,WID))
  235.       (+HEI (ABS ,HEI))
  236.       (LEF-OVERRUN (MAX 0 (- SCALED-FROM-X CLIPPED-FROM-X) (- SCALED-TO-X CLIPPED-TO-X)))
  237.       (TOP-OVERRUN (MAX 0 (- SCALED-FROM-Y CLIPPED-FROM-Y) (- SCALED-TO-Y CLIPPED-TO-Y)))
  238.       (RIG-OVERRUN (MAX 0
  239.                 (- (+ CLIPPED-FROM-X +WID) (CLIP-X (+ CLIPPED-FROM-X +WID)))
  240.                 (- (+ CLIPPED-TO-X +WID) (CLIP-X (+ CLIPPED-TO-X +WID)))))
  241.       (BOT-OVERRUN (MAX 0
  242.                 (- (+ CLIPPED-FROM-Y +HEI) (CLIP-Y (+ CLIPPED-FROM-Y +HEI)))
  243.                 (- (+ CLIPPED-TO-Y +HEI) (CLIP-Y (+ CLIPPED-TO-Y +HEI)))))
  244.       (CLIPPED-WID (* (SIGN-OF-NO ,WID) (MAX 0 (- +WID LEF-OVERRUN RIG-OVERRUN))))
  245.       (CLIPPED-HEI (* (SIGN-OF-NO ,HEI) (MAX 0 (- +HEI TOP-OVERRUN BOT-OVERRUN)))))
  246.      (OR (ZEROP CLIPPED-WID)
  247.      (ZEROP CLIPPED-HEI)
  248.      (BITBLT ,ALU CLIPPED-WID CLIPPED-HEI
  249.          %DRAWING-ARRAY CLIPPED-FROM-X CLIPPED-FROM-Y
  250.          %DRAWING-ARRAY CLIPPED-TO-X   CLIPPED-TO-Y))))
  251.  
  252. (DEFMACRO BITBLT-MOVE-REGION (WID HEI FROM-X FROM-Y DELTA-X DELTA-Y)
  253.   (ONCE-ONLY (WID HEI FROM-X FROM-Y DELTA-X DELTA-Y)
  254.     `(WITH-CLIPPING-INSIDE ((MIN ,FROM-X (+ ,FROM-X ,DELTA-X))
  255.                 (MIN ,FROM-Y (+ ,FROM-Y ,DELTA-Y))
  256.                 (+ (MAX ,FROM-X (+ ,FROM-X ,DELTA-X)) (ABS ,WID))
  257.                 (+ (MAX ,FROM-Y (+ ,FROM-Y ,DELTA-Y)) (ABS ,HEI)))
  258.        ;; First we move the stuff from its old place to its new place.
  259.        (BITBLT-WITHIN-SCREEN TV:ALU-SETA
  260.                  (* (- (SIGN-OF-NO ,DELTA-X)) (ABS ,WID))
  261.                  (* (- (SIGN-OF-NO ,DELTA-Y)) (ABS ,HEI))
  262.                  ,FROM-X ,FROM-Y
  263.                  (+ ,FROM-X ,DELTA-X) (+ ,FROM-Y ,DELTA-Y))
  264.        ;; Now we erase the part of the screen which is no longer covered.
  265.        (DRAW-RECTANGLE TV:ALU-ANDCA
  266.                (ABS ,DELTA-X)
  267.                ,HEI
  268.                (COND ((PLUSP ,DELTA-X) ,FROM-X)
  269.                  ((> (ABS ,DELTA-X) ,WID) ,FROM-X)
  270.                  ;;If the region we're moving is partly
  271.                  ;;not displayed due to clipping we have to
  272.                  ;;clear out stuff specially.  This has a
  273.                  ;;few bugs, but it works better than with
  274.                  ;;out it.
  275.                  ((> (+ ,WID ,FROM-X  %ORIGIN-X-OFFSET) %CLIP-RIG)
  276.                   (+ %CLIP-RIG ,DELTA-X (- %ORIGIN-X-OFFSET)))
  277.                  (T (+ ,FROM-X ,WID ,DELTA-X)))
  278.                ,FROM-Y)
  279.        (DRAW-RECTANGLE TV:ALU-ANDCA
  280.                ,WID
  281.                (ABS ,DELTA-Y)
  282.                ,FROM-X
  283.                (COND ((PLUSP ,DELTA-Y) ,FROM-Y)
  284.                  ((> (ABS ,DELTA-Y) ,HEI) ,FROM-Y)
  285.                  ;; likewise a clipping hack
  286.                  ((> (+ ,HEI ,FROM-Y %ORIGIN-Y-OFFSET) %CLIP-BOT)
  287.                   (+ %CLIP-BOT ,DELTA-Y (- %ORIGIN-Y-OFFSET)))
  288.                  (T (+ ,FROM-Y ,HEI ,DELTA-Y)))))))
  289.  
  290.  
  291.  
  292. ;; BIND-FONT-VALUES-FOR-FAST-CHA-MACROS is a special form which must surround
  293. ;; all calls to the fast character macros. It takes a font-no, maps that no
  294. ;; into an actual font, and binds other information about the font that the
  295. ;; fast character macros need.
  296.  
  297. (DEFMACRO BIND-FONT-VALUES-FOR-FAST-CHA-MACROS (FONT-NO &BODY BODY)
  298.   `(LET* ((%DRAWING-FONT (AREF %DRAWING-FONT-MAP ,FONT-NO))
  299.       (%DRAWING-FIT  (TV:FONT-INDEXING-TABLE %DRAWING-FONT))
  300.       (%DRAWING-FONT-CHA-WID (TV:FONT-CHAR-WIDTH %DRAWING-FONT))
  301.       (%DRAWING-FONT-CHA-WID-TABLE (TV:FONT-CHAR-WIDTH-TABLE %DRAWING-FONT)))
  302.      (DECLARE (SPECIAL %DRAWING-FONT
  303.                %DRAWING-FIT
  304.                %DRAWING-FONT-CHA-WID
  305.                %DRAWING-FONT-CHA-WID-TABLE))
  306.      . ,BODY))
  307.  
  308. (DEFVAR *CLIPPED-CHA-DRAWING-ARRAY*
  309.   (TV:MAKE-SHEET-BIT-ARRAY TV:MAIN-SCREEN 200 200)
  310.   "Used as a temporary array in blting clipped characters")
  311.  
  312. (DEFMACRO DRAW-CLIPPED-CHA (ALU CODE X Y)
  313.   ;; This is somewhat of a hack.  It is used to draw characters into
  314.   ;; boxes that get clipped.  I think that half a character is better
  315.   ;; than none, so I draw the whole char into a special array, then copy
  316.   ;; the portion I want out onto the screen.  I must be careful to erase
  317.   ;; the array so that funnyness doesn't happen.
  318.   `(PROGN
  319.      (TV:%DRAW-RECTANGLE 200 200 0 0 TV:ALU-ANDCA *CLIPPED-CHA-DRAWING-ARRAY*)
  320.      (TV:%DRAW-CHAR %DRAWING-FONT ,CODE 0 0 ,ALU *CLIPPED-CHA-DRAWING-ARRAY*)
  321.      (BITBLT ,ALU
  322.          (MIN (- %CLIP-RIG ,X)(FAST-CHA-WID ,CODE))
  323.          (MIN (- %CLIP-BOT ,Y)(FAST-CHA-HEI))
  324.          *CLIPPED-CHA-DRAWING-ARRAY* 0 0 %DRAWING-ARRAY ,X ,Y)))
  325.  
  326. (DEFVAR *DRAW-CLIPPED-CHAS?* T)
  327.  
  328. (DEFMACRO FAST-DRAW-CHA (ALU CODE X Y)
  329.   (ONCE-ONLY (ALU CODE X Y)
  330.     `(COND ((NOT (Y-OUT-OF-BOUNDS? (+ ,Y (FAST-CHA-HEI))))
  331. ;        (COND ((NULL %DRAWING-FIT)
  332.            (IF (NOT (X-OUT-OF-BOUNDS? (+ ,X (FAST-CHA-WID ,CODE))))
  333.                (TV:%DRAW-CHAR %DRAWING-FONT ,CODE ,X ,Y ,ALU %DRAWING-WINDOW)
  334.                (IF (AND *DRAW-CLIPPED-CHAS?*
  335.                 (NOT (X-OUT-OF-BOUNDS? ,X)))
  336.                (DRAW-CLIPPED-CHA ,ALU ,CODE ,X ,Y))))
  337. ;          (T
  338. ;           ;; This is an extra wide character from a variable wid
  339. ;           ;; font. Draw as many slices of it as there is room for.
  340. ;           (LET ((SLICE-WIDTH (// (TV:SHEET-BITS-PER-PIXEL %DRAWING-WINDOW)
  341. ;                      (FONT-RASTER-WIDTH %DRAWING-FONT)))
  342. ;             (SLICE-OFFSET-LIMIT (AREF %DRAWING-FIT (1+ ,CODE))))
  343. ;             (DO ((SLICE-OFFSET (AREF %DRAWING-FIT ,CODE) (1+ SLICE-OFFSET))
  344. ;              (SLICE-X ,X (+ SLICE-X SLICE-WIDTH))
  345. ;              (SLICE-Y ,Y))
  346. ;             ((OR (= SLICE-OFFSET SLICE-OFFSET-LIMIT)
  347. ;                  (X-OUT-OF-BOUNDS? (+ SLICE-X SLICE-WIDTH))))
  348. ;               (TV:%DRAW-CHAR
  349. ;             %DRAWING-FONT SLICE-OFFSET
  350. ;             SLICE-X SLICE-Y ,ALU %DRAWING-WINDOW)))))
  351.  
  352.        ((AND *DRAW-CLIPPED-CHAS?*
  353.          (Y-OUT-OF-BOUNDS? (+ ,Y (FAST-CHA-HEI)))
  354.          (NOT (Y-OUT-OF-BOUNDS? ,Y))
  355.          (NOT (X-OUT-OF-BOUNDS? ,X)))
  356.         (DRAW-CLIPPED-CHA ,ALU ,CODE ,X ,Y)))))
  357.  
  358. (DEFMACRO FAST-CHA-WID (CODE)
  359.   `(IF (NOT (NULL %DRAWING-FONT-CHA-WID-TABLE))
  360.        (AREF %DRAWING-FONT-CHA-WID-TABLE ,CODE)
  361.        %DRAWING-FONT-CHA-WID))
  362.  
  363. (DEFMACRO FAST-CHA-HEI ()
  364.   `(FONT-CHAR-HEIGHT %DRAWING-FONT))
  365.  
  366. ;; Drawing characters and strings. All of these take their font argument as
  367. ;; a font-no in the %drawing-window's font-map. They take their character
  368. ;; code argument as a Lispm character code.
  369.  
  370. (DEFUN DRAW-CHA (ALU FONT-NO CODE REGION-X REGION-Y)
  371.   (BIND-FONT-VALUES-FOR-FAST-CHA-MACROS FONT-NO
  372.      (COND ((ZEROP (CTRL-CODE CODE))
  373.         (FAST-DRAW-CHA ALU CODE (SCALE-X REGION-X) (SCALE-Y REGION-Y)))
  374.        (T
  375.         (FAST-DRAW-CHA ALU *CONTROL-CHARACTER-DISPLAY-PREFIX*
  376.                (SCALE-X REGION-X) (SCALE-Y REGION-Y))
  377.         (FAST-DRAW-CHA ALU (CHA-CODE-NO-CTRL CODE)
  378.                (SCALE-X (+ 9 REGION-X)) (SCALE-Y REGION-Y))))))
  379.  
  380. (DEFMACRO DRAW-STRING (ALU FONT-NO STRING REGION-X REGION-Y)
  381.   (ONCE-ONLY (STRING REGION-X REGION-Y)
  382.     `(BIND-FONT-VALUES-FOR-FAST-CHA-MACROS ,FONT-NO
  383.        (LET ((X (SCALE-X ,REGION-X))
  384.          (Y (SCALE-Y ,REGION-Y)))
  385.      (DOTIMES (I (STRING-LENGTH ,STRING))
  386.        (LET ((CODE (GLOBAL:CHARACTER (SUBSTRING ,STRING I (+ I 1)))))
  387.          (FAST-DRAW-CHA ,ALU CODE X Y)
  388.          (INCF X (FAST-CHA-WID CODE))))))))
  389.   
  390. ;; MACROS for calculating the width of characters and strings.
  391.  
  392. (DEFMACRO CHA-WID (FONT-NO CODE)
  393.   `(BIND-FONT-VALUES-FOR-FAST-CHA-MACROS  ,FONT-NO
  394.      (COND ((ZEROP (CTRL-CODE ,CODE))
  395.         (FAST-CHA-WID ,CODE))
  396.        (T (+ (FAST-CHA-WID *CONTROL-CHARACTER-DISPLAY-PREFIX*) (FAST-CHA-WID ,CODE))))))
  397.  
  398. (DEFMACRO STRING-WID (FONT-NO STRING)
  399.   (ONCE-ONLY (STRING)
  400.     `(BIND-FONT-VALUES-FOR-FAST-CHA-MACROS  ,FONT-NO
  401.        (LET ((WID 0) (CODE))
  402.      (DOTIMES (I (STRING-LENGTH ,STRING))
  403.        (SETQ CODE (GLOBAL:CHARACTER (SUBSTRING ,STRING I (1+ I)))
  404.          WID  (+ WID (FAST-CHA-WID CODE))))
  405.      WID))))
  406.  
  407. (DEFMACRO CHA-HEI (FONT-NO)
  408.   `(BIND-FONT-VALUES-FOR-FAST-CHA-MACROS ,FONT-NO
  409.      (FAST-CHA-HEI)))
  410.  
  411. (DEFMACRO STRING-HEI (FONT-NO)
  412.   `(BIND-FONT-VALUES-FOR-FAST-CHA-MACROS ,FONT-NO
  413.      (FAST-CHA-HEI)))
  414.  
  415.  
  416.