; -*- Mode:LISP; Package:BOXER; Base:8.;fonts:cptfont -*- ;; (C) Copyright 1985 Massachusetts Institute of Technology ;; ;; Permission to use, copy, modify, distribute, and sell this software ;; and its documentation for any purpose is hereby granted without fee, ;; provided that the above copyright notice appear in all copies and that ;; both that copyright notice and this permission notice appear in ;; supporting documentation, and that the name of M.I.T. not be used in ;; advertising or publicity pertaining to distribution of the software ;; without specific, written prior permission. M.I.T. makes no ;; representations about the suitability of this software for any ;; purpose. It is provided "as is" without express or implied warranty. ;; ;;;; DRAWING-ON-WINDOW (DEFVAR %DRAWING-WINDOW NIL "Inside of a drawing-on-window, this variable is bound to the window which was given as an argument to drawing-on window, makes sense right.") (DEFVAR %DRAWING-ARRAY NIL "Inside of a drawing-on-window, this variable is bound to %drawing-window's screen-array (Note that this value is valid because drawing-on-window does a prepare-sheet of drawing-window.") (DEFVAR %DRAWING-FONT-MAP NIL "Inside of a drawing-on-window, this variable is bound to %drawing-window's font-map.") (DEFVAR %ORIGIN-X-OFFSET 0 "Inside of a drawing-on-window, this variable is bound to x-offset of the current drawing origin from the screen's actual x origin. With-origin-at rebinds this variable (and %origin-y-offset) to change the screen position of the drawing origin.") (DEFVAR %ORIGIN-Y-OFFSET 0 "Inside of a drawing-on-window, this variable is bound to y-offset of the current drawing origin from the screen's actual y origin. With-origin-at rebinds this variable (and %origin-y-offset) to change the screen position of the drawing origin.") (DEFVAR %CLIP-LEF 0) (DEFVAR %CLIP-TOP 0) (DEFVAR %CLIP-RIG 0) (DEFVAR %CLIP-BOT 0) ;;; DRAWING-ON-WINDOW is an &body macro which all the drawing macros in this ;;; must be called inside of. It basically prepares the window to be drawn on ;;; and binds all the magic variables that the drawing macros need including ;;; the bootstrapping of the clipping and coordinate scaling variables. (DEFMACRO DRAWING-ON-WINDOW ((WINDOW) &BODY BODY) (ONCE-ONLY (WINDOW) `(TV:PREPARE-SHEET (,WINDOW) (DRAWING-ON-WINDOW-WITHOUT-PREPARE-SHEET (,WINDOW) . ,BODY)))) ;;; DRAWING-ON-WINDOW-WITHOUT-PREPARE-SHEET is a variant of Drawing-On-Window ;;; which does everything Drawing-On-Window does except that it does not do a ;;; tv:prepare-sheet of the window. Unless you really know what you are doing ;;; you should only use this inside the :BLINK method for a blinker. (DEFMACRO DRAWING-ON-WINDOW-WITHOUT-PREPARE-SHEET ((WINDOW) &BODY BODY) (ONCE-ONLY (WINDOW) `(LET ((%DRAWING-WINDOW ,WINDOW) (%DRAWING-ARRAY (TV:SHEET-SCREEN-ARRAY ,WINDOW)) (%DRAWING-FONT-MAP (TV:SHEET-FONT-MAP ,WINDOW))) %DRAWING-WINDOW %DRAWING-ARRAY %DRAWING-FONT-MAP ;Bound but never... (DRAWING-ON-WINDOW-BOOTSTRAP-CLIPPING-AND-SCALING ((TV:SHEET-INSIDE-LEFT ,WINDOW) (TV:SHEET-INSIDE-TOP ,WINDOW) (TV:SHEET-INSIDE-WIDTH ,WINDOW) (TV:SHEET-INSIDE-HEIGHT ,WINDOW)) . ,BODY)))) ;;; WITH-FONT-MAP-BOUND is meant to be used by all those functions (like BOX-BORDER-FN's ;;; that have to be called in an environment where the font map is supposed to be bound but ;;; nothing else (like all those wonderful drawing type things and stuff) needs to be bound (DEFMACRO WITH-FONT-MAP-BOUND ((WINDOW) &BODY BODY) `(LET ((%DRAWING-FONT-MAP (TV:SHEET-FONT-MAP ,WINDOW))) %DRAWING-FONT-MAP ;bound but never used etc. . ,BODY)) ;;; The normal functions for binding the clipping and scaling variables depend ;;; on the already existing values of those variables. This means that those ;;; variables need to be specially boot-strapped. (DEFMACRO DRAWING-ON-WINDOW-BOOTSTRAP-CLIPPING-AND-SCALING ((X Y WID HEI) &BODY BODY) `(LET* ((%CLIP-LEF ,X) (%CLIP-TOP ,Y) (%CLIP-RIG (+ %CLIP-LEF ,WID)) (%CLIP-BOT (+ %CLIP-TOP ,HEI)) (%ORIGIN-X-OFFSET ,X) (%ORIGIN-Y-OFFSET ,Y)) %CLIP-RIG %CLIP-BOT %ORIGIN-X-OFFSET %ORIGIN-Y-OFFSET ;Bound but never... . ,BODY)) ;;; WITH-DRAWING-INSIDE-REGION is the function people should call to wall off ;;; a sub-region of the current region to draw in. This is an &body macro which ;;; sets things up such that all drawing macros evaluated inside the body of the ;;; macro will draw in the coordinate frame of that region, and will be clipped ;;; to the boundaries of the region. (DEFMACRO WITH-DRAWING-INSIDE-REGION ((X Y WID HEI) &BODY BODY) `(WITH-CLIPPING-INSIDE (,X ,Y ,WID ,HEI) (WITH-ORIGIN-AT (,X ,Y) . ,BODY))) (DEFMACRO WITH-ORIGIN-AT ((X Y) &BODY BODY) `(LET ((%ORIGIN-X-OFFSET (SCALE-X ,X)) (%ORIGIN-Y-OFFSET (SCALE-Y ,Y))) %ORIGIN-X-OFFSET %ORIGIN-Y-OFFSET . ,BODY)) (DEFMACRO WITH-CLIPPING-INSIDE ((X Y WID HEI) &BODY BODY) `(LET* ((%CLIP-LEF (MAX %CLIP-LEF (SCALE-X ,X))) (%CLIP-TOP (MAX %CLIP-TOP (SCALE-Y ,Y))) (%CLIP-RIG (MIN %CLIP-RIG (+ %CLIP-LEF ,WID))) (%CLIP-BOT (MIN %CLIP-BOT (+ %CLIP-TOP ,HEI)))) %CLIP-RIG %CLIP-BOT . ,BODY)) (DEFMACRO SCALE-X (X) `(+ ,X %ORIGIN-X-OFFSET)) (DEFMACRO SCALE-Y (Y) `(+ ,Y %ORIGIN-Y-OFFSET)) (DEFMACRO CLIP-X (SCALED-X) `(MAX %CLIP-LEF (MIN ,SCALED-X %CLIP-RIG))) (DEFMACRO CLIP-Y (SCALED-Y) `(MAX %CLIP-TOP (MIN ,SCALED-Y %CLIP-BOT))) (DEFMACRO X-OUT-OF-BOUNDS? (SCALED-X) `(OR (< ,SCALED-X %CLIP-LEF) (> ,SCALED-X %CLIP-RIG))) (DEFMACRO Y-OUT-OF-BOUNDS? (SCALED-Y) `(OR (< ,SCALED-Y %CLIP-TOP) (> ,SCALED-Y %CLIP-BOT))) (DEFMACRO SIGN-OF-NO (X) `(IF (PLUSP ,X) 1 -1)) ;; NOTE,, do anything to make the code that does clipping faster and ;; less readable and I will cut your fingers right off. Understand, you ;; may find this overly simple, but I like to be able to figure out what ;; the hell is going on with drawing code since its so hard to debug. (DEFMACRO DRAW-RECTANGLE (ALU WID HEI X Y) `(LET* ((CLIPPED-X (CLIP-X (SCALE-X ,X))) (CLIPPED-Y (CLIP-Y (SCALE-Y ,Y))) (CLIPPED-WID (- (CLIP-X (+ CLIPPED-X (ABS ,WID))) CLIPPED-X)) (CLIPPED-HEI (- (CLIP-Y (+ CLIPPED-Y (ABS ,HEI))) CLIPPED-Y))) (OR (ZEROP CLIPPED-WID) ;%draw-rectangle bombs out (ZEROP CLIPPED-HEI) ;if wid or hei is 0.. (TV:%DRAW-RECTANGLE CLIPPED-WID CLIPPED-HEI CLIPPED-X CLIPPED-Y ,ALU %DRAWING-WINDOW)))) (DEFMACRO SLOPE (X0 Y0 X1 Y1) `(// (FLOAT (- (SCALE-Y ,Y1) (SCALE-Y ,Y0))) (FLOAT (- (SCALE-X ,X1) (SCALE-X ,X0))))) (DEFMACRO ISLOPE (X0 Y0 X1 Y1) `(// (FLOAT (- (SCALE-X ,X1) (SCALE-X ,X0))) (FLOAT (- (SCALE-Y ,Y1) (SCALE-Y ,Y0))))) (DEFMACRO DRAW-LINE (X0 Y0 X1 Y1 ALU END-POINT?) `(LET* ((CLIPPED-X0 (CLIP-X (SCALE-X ,X0))) (CLIPPED-Y0 (CLIP-Y (SCALE-Y ,Y0))) (CLIPPED-X1 (CLIP-X (SCALE-X ,X1))) (CLIPPED-Y1 (CLIP-Y (SCALE-Y ,Y1))) (X0-CUTOFF (- (SCALE-X ,X0) CLIPPED-X0)) (Y0-CUTOFF (- (SCALE-Y ,Y0) CLIPPED-Y0)) (X1-CUTOFF (- (SCALE-X ,X1) CLIPPED-X1)) (Y1-CUTOFF (- (SCALE-Y ,Y1) CLIPPED-Y1))) (COND ((OR (AND (PLUSP X0-CUTOFF) (PLUSP X1-CUTOFF)) ;;line is totally clipped (AND (PLUSP Y0-CUTOFF) (PLUSP Y1-CUTOFF)))) (T (COND ((PLUSP X0-CUTOFF) ;; clipped on a vertical edge (SETQ CLIPPED-Y0 (FIX (- (SCALE-Y ,Y0) (* X0-CUTOFF (SLOPE ,X0 ,Y0 ,X1 ,Y1)))))) ((PLUSP X1-CUTOFF) ;; clipped on a vertical edge (SETQ CLIPPED-Y1 (FIX (- (SCALE-Y ,Y1) (* X1-CUTOFF (SLOPE ,X0 ,Y0 ,X1 ,Y1)))))) ((PLUSP Y0-CUTOFF) ;; clipped on a horizontal edge (SETQ CLIPPED-X0 (FIX (- (SCALE-X ,X0) (* Y0-CUTOFF (ISLOPE ,X0 ,Y0 ,X1 ,Y1)))))) ((PLUSP Y1-CUTOFF) ;; clipped on a horizontal edge (SETQ CLIPPED-X1 (FIX (- (SCALE-X ,X1) (* Y1-CUTOFF (ISLOPE ,X0 ,Y0 ,X1 ,Y1))))))) (SYS:%DRAW-LINE CLIPPED-X0 CLIPPED-Y0 CLIPPED-X1 CLIPPED-Y1 ,ALU ,END-POINT? %DRAWING-WINDOW))))) (DEFMACRO BITBLT-TO-SCREEN (ALU WID HEI FROM-ARRAY FROM-X FROM-Y TO-X TO-Y) `(LET* ((SCALED-TO-X (SCALE-X ,TO-X)) (SCALED-TO-Y (SCALE-Y ,TO-Y)) (CLIPPED-TO-X (CLIP-X SCALED-TO-X)) (CLIPPED-TO-Y (CLIP-Y SCALED-TO-Y)) (+WID (ABS ,WID)) (+HEI (ABS ,HEI)) (LEF-OVERRUN (MAX 0 (- SCALED-TO-X CLIPPED-TO-X))) (TOP-OVERRUN (MAX 0 (- SCALED-TO-Y CLIPPED-TO-Y))) (RIG-OVERRUN (MAX 0 (- (+ CLIPPED-TO-X +WID) (CLIP-X (+ CLIPPED-TO-X +WID))))) (BOT-OVERRUN (MAX 0 (- (+ CLIPPED-TO-Y +HEI) (CLIP-Y (+ CLIPPED-TO-Y +HEI))))) (CLIPPED-WID (* (SIGN-OF-NO ,WID) (MAX 0 (- +WID LEF-OVERRUN RIG-OVERRUN)))) (CLIPPED-HEI (* (SIGN-OF-NO ,HEI) (MAX 0 (- +HEI TOP-OVERRUN BOT-OVERRUN))))) (OR (ZEROP CLIPPED-WID) ;%draw-rectangle bombs out (ZEROP CLIPPED-HEI) ;if wid or hei is 0.. (BITBLT ,ALU CLIPPED-WID CLIPPED-HEI ,FROM-ARRAY (+ ,FROM-X LEF-OVERRUN) (+ ,FROM-Y TOP-OVERRUN) %DRAWING-ARRAY CLIPPED-TO-X CLIPPED-TO-Y)))) (DEFMACRO BITBLT-WITHIN-SCREEN (ALU WID HEI FROM-X FROM-Y TO-X TO-Y) `(LET* ((SCALED-FROM-X (SCALE-X ,FROM-X)) (SCALED-FROM-Y (SCALE-Y ,FROM-Y)) (SCALED-TO-X (SCALE-X ,TO-X)) (SCALED-TO-Y (SCALE-Y ,TO-Y)) (CLIPPED-FROM-X (CLIP-X SCALED-FROM-X)) (CLIPPED-FROM-Y (CLIP-Y SCALED-FROM-Y)) (CLIPPED-TO-X (CLIP-X SCALED-TO-X)) (CLIPPED-TO-Y (CLIP-Y SCALED-TO-Y)) (+WID (ABS ,WID)) (+HEI (ABS ,HEI)) (LEF-OVERRUN (MAX 0 (- SCALED-FROM-X CLIPPED-FROM-X) (- SCALED-TO-X CLIPPED-TO-X))) (TOP-OVERRUN (MAX 0 (- SCALED-FROM-Y CLIPPED-FROM-Y) (- SCALED-TO-Y CLIPPED-TO-Y))) (RIG-OVERRUN (MAX 0 (- (+ CLIPPED-FROM-X +WID) (CLIP-X (+ CLIPPED-FROM-X +WID))) (- (+ CLIPPED-TO-X +WID) (CLIP-X (+ CLIPPED-TO-X +WID))))) (BOT-OVERRUN (MAX 0 (- (+ CLIPPED-FROM-Y +HEI) (CLIP-Y (+ CLIPPED-FROM-Y +HEI))) (- (+ CLIPPED-TO-Y +HEI) (CLIP-Y (+ CLIPPED-TO-Y +HEI))))) (CLIPPED-WID (* (SIGN-OF-NO ,WID) (MAX 0 (- +WID LEF-OVERRUN RIG-OVERRUN)))) (CLIPPED-HEI (* (SIGN-OF-NO ,HEI) (MAX 0 (- +HEI TOP-OVERRUN BOT-OVERRUN))))) (OR (ZEROP CLIPPED-WID) (ZEROP CLIPPED-HEI) (BITBLT ,ALU CLIPPED-WID CLIPPED-HEI %DRAWING-ARRAY CLIPPED-FROM-X CLIPPED-FROM-Y %DRAWING-ARRAY CLIPPED-TO-X CLIPPED-TO-Y)))) (DEFMACRO BITBLT-MOVE-REGION (WID HEI FROM-X FROM-Y DELTA-X DELTA-Y) (ONCE-ONLY (WID HEI FROM-X FROM-Y DELTA-X DELTA-Y) `(WITH-CLIPPING-INSIDE ((MIN ,FROM-X (+ ,FROM-X ,DELTA-X)) (MIN ,FROM-Y (+ ,FROM-Y ,DELTA-Y)) (+ (MAX ,FROM-X (+ ,FROM-X ,DELTA-X)) (ABS ,WID)) (+ (MAX ,FROM-Y (+ ,FROM-Y ,DELTA-Y)) (ABS ,HEI))) ;; First we move the stuff from its old place to its new place. (BITBLT-WITHIN-SCREEN TV:ALU-SETA (* (- (SIGN-OF-NO ,DELTA-X)) (ABS ,WID)) (* (- (SIGN-OF-NO ,DELTA-Y)) (ABS ,HEI)) ,FROM-X ,FROM-Y (+ ,FROM-X ,DELTA-X) (+ ,FROM-Y ,DELTA-Y)) ;; Now we erase the part of the screen which is no longer covered. (DRAW-RECTANGLE TV:ALU-ANDCA (ABS ,DELTA-X) ,HEI (COND ((PLUSP ,DELTA-X) ,FROM-X) ((> (ABS ,DELTA-X) ,WID) ,FROM-X) ;;If the region we're moving is partly ;;not displayed due to clipping we have to ;;clear out stuff specially. This has a ;;few bugs, but it works better than with ;;out it. ((> (+ ,WID ,FROM-X %ORIGIN-X-OFFSET) %CLIP-RIG) (+ %CLIP-RIG ,DELTA-X (- %ORIGIN-X-OFFSET))) (T (+ ,FROM-X ,WID ,DELTA-X))) ,FROM-Y) (DRAW-RECTANGLE TV:ALU-ANDCA ,WID (ABS ,DELTA-Y) ,FROM-X (COND ((PLUSP ,DELTA-Y) ,FROM-Y) ((> (ABS ,DELTA-Y) ,HEI) ,FROM-Y) ;; likewise a clipping hack ((> (+ ,HEI ,FROM-Y %ORIGIN-Y-OFFSET) %CLIP-BOT) (+ %CLIP-BOT ,DELTA-Y (- %ORIGIN-Y-OFFSET))) (T (+ ,FROM-Y ,HEI ,DELTA-Y))))))) ;; BIND-FONT-VALUES-FOR-FAST-CHA-MACROS is a special form which must surround ;; all calls to the fast character macros. It takes a font-no, maps that no ;; into an actual font, and binds other information about the font that the ;; fast character macros need. (DEFMACRO BIND-FONT-VALUES-FOR-FAST-CHA-MACROS (FONT-NO &BODY BODY) `(LET* ((%DRAWING-FONT (AREF %DRAWING-FONT-MAP ,FONT-NO)) (%DRAWING-FIT (TV:FONT-INDEXING-TABLE %DRAWING-FONT)) (%DRAWING-FONT-CHA-WID (TV:FONT-CHAR-WIDTH %DRAWING-FONT)) (%DRAWING-FONT-CHA-WID-TABLE (TV:FONT-CHAR-WIDTH-TABLE %DRAWING-FONT))) (DECLARE (SPECIAL %DRAWING-FONT %DRAWING-FIT %DRAWING-FONT-CHA-WID %DRAWING-FONT-CHA-WID-TABLE)) . ,BODY)) (DEFVAR *CLIPPED-CHA-DRAWING-ARRAY* (TV:MAKE-SHEET-BIT-ARRAY TV:MAIN-SCREEN 200 200) "Used as a temporary array in blting clipped characters") (DEFMACRO DRAW-CLIPPED-CHA (ALU CODE X Y) ;; This is somewhat of a hack. It is used to draw characters into ;; boxes that get clipped. I think that half a character is better ;; than none, so I draw the whole char into a special array, then copy ;; the portion I want out onto the screen. I must be careful to erase ;; the array so that funnyness doesn't happen. `(PROGN (TV:%DRAW-RECTANGLE 200 200 0 0 TV:ALU-ANDCA *CLIPPED-CHA-DRAWING-ARRAY*) (TV:%DRAW-CHAR %DRAWING-FONT ,CODE 0 0 ,ALU *CLIPPED-CHA-DRAWING-ARRAY*) (BITBLT ,ALU (MIN (- %CLIP-RIG ,X)(FAST-CHA-WID ,CODE)) (MIN (- %CLIP-BOT ,Y)(FAST-CHA-HEI)) *CLIPPED-CHA-DRAWING-ARRAY* 0 0 %DRAWING-ARRAY ,X ,Y))) (DEFVAR *DRAW-CLIPPED-CHAS?* T) (DEFMACRO FAST-DRAW-CHA (ALU CODE X Y) (ONCE-ONLY (ALU CODE X Y) `(COND ((NOT (Y-OUT-OF-BOUNDS? (+ ,Y (FAST-CHA-HEI)))) ; (COND ((NULL %DRAWING-FIT) (IF (NOT (X-OUT-OF-BOUNDS? (+ ,X (FAST-CHA-WID ,CODE)))) (TV:%DRAW-CHAR %DRAWING-FONT ,CODE ,X ,Y ,ALU %DRAWING-WINDOW) (IF (AND *DRAW-CLIPPED-CHAS?* (NOT (X-OUT-OF-BOUNDS? ,X))) (DRAW-CLIPPED-CHA ,ALU ,CODE ,X ,Y)))) ; (T ; ;; This is an extra wide character from a variable wid ; ;; font. Draw as many slices of it as there is room for. ; (LET ((SLICE-WIDTH (// (TV:SHEET-BITS-PER-PIXEL %DRAWING-WINDOW) ; (FONT-RASTER-WIDTH %DRAWING-FONT))) ; (SLICE-OFFSET-LIMIT (AREF %DRAWING-FIT (1+ ,CODE)))) ; (DO ((SLICE-OFFSET (AREF %DRAWING-FIT ,CODE) (1+ SLICE-OFFSET)) ; (SLICE-X ,X (+ SLICE-X SLICE-WIDTH)) ; (SLICE-Y ,Y)) ; ((OR (= SLICE-OFFSET SLICE-OFFSET-LIMIT) ; (X-OUT-OF-BOUNDS? (+ SLICE-X SLICE-WIDTH)))) ; (TV:%DRAW-CHAR ; %DRAWING-FONT SLICE-OFFSET ; SLICE-X SLICE-Y ,ALU %DRAWING-WINDOW))))) ((AND *DRAW-CLIPPED-CHAS?* (Y-OUT-OF-BOUNDS? (+ ,Y (FAST-CHA-HEI))) (NOT (Y-OUT-OF-BOUNDS? ,Y)) (NOT (X-OUT-OF-BOUNDS? ,X))) (DRAW-CLIPPED-CHA ,ALU ,CODE ,X ,Y))))) (DEFMACRO FAST-CHA-WID (CODE) `(IF (NOT (NULL %DRAWING-FONT-CHA-WID-TABLE)) (AREF %DRAWING-FONT-CHA-WID-TABLE ,CODE) %DRAWING-FONT-CHA-WID)) (DEFMACRO FAST-CHA-HEI () `(FONT-CHAR-HEIGHT %DRAWING-FONT)) ;; Drawing characters and strings. All of these take their font argument as ;; a font-no in the %drawing-window's font-map. They take their character ;; code argument as a Lispm character code. (DEFUN DRAW-CHA (ALU FONT-NO CODE REGION-X REGION-Y) (BIND-FONT-VALUES-FOR-FAST-CHA-MACROS FONT-NO (COND ((ZEROP (CTRL-CODE CODE)) (FAST-DRAW-CHA ALU CODE (SCALE-X REGION-X) (SCALE-Y REGION-Y))) (T (FAST-DRAW-CHA ALU *CONTROL-CHARACTER-DISPLAY-PREFIX* (SCALE-X REGION-X) (SCALE-Y REGION-Y)) (FAST-DRAW-CHA ALU (CHA-CODE-NO-CTRL CODE) (SCALE-X (+ 9 REGION-X)) (SCALE-Y REGION-Y)))))) (DEFMACRO DRAW-STRING (ALU FONT-NO STRING REGION-X REGION-Y) (ONCE-ONLY (STRING REGION-X REGION-Y) `(BIND-FONT-VALUES-FOR-FAST-CHA-MACROS ,FONT-NO (LET ((X (SCALE-X ,REGION-X)) (Y (SCALE-Y ,REGION-Y))) (DOTIMES (I (STRING-LENGTH ,STRING)) (LET ((CODE (GLOBAL:CHARACTER (SUBSTRING ,STRING I (+ I 1))))) (FAST-DRAW-CHA ,ALU CODE X Y) (INCF X (FAST-CHA-WID CODE)))))))) ;; MACROS for calculating the width of characters and strings. (DEFMACRO CHA-WID (FONT-NO CODE) `(BIND-FONT-VALUES-FOR-FAST-CHA-MACROS ,FONT-NO (COND ((ZEROP (CTRL-CODE ,CODE)) (FAST-CHA-WID ,CODE)) (T (+ (FAST-CHA-WID *CONTROL-CHARACTER-DISPLAY-PREFIX*) (FAST-CHA-WID ,CODE)))))) (DEFMACRO STRING-WID (FONT-NO STRING) (ONCE-ONLY (STRING) `(BIND-FONT-VALUES-FOR-FAST-CHA-MACROS ,FONT-NO (LET ((WID 0) (CODE)) (DOTIMES (I (STRING-LENGTH ,STRING)) (SETQ CODE (GLOBAL:CHARACTER (SUBSTRING ,STRING I (1+ I))) WID (+ WID (FAST-CHA-WID CODE)))) WID)))) (DEFMACRO CHA-HEI (FONT-NO) `(BIND-FONT-VALUES-FOR-FAST-CHA-MACROS ,FONT-NO (FAST-CHA-HEI))) (DEFMACRO STRING-HEI (FONT-NO) `(BIND-FONT-VALUES-FOR-FAST-CHA-MACROS ,FONT-NO (FAST-CHA-HEI)))