;;; TV ROUTINES NOT INSTALLED IN THE MAIN PACKAGE (YET) -*-LISP-*- ; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;ROW and COL are measured from top/left as usual. An alternative would be: ; COL is measured from the left, with Kerning hacked. ; ROW is positive above the baseline and negative below. ; (SETQ ROW (- (FONT-BASELINE FONT) ROW)) ; (AND (SETQ TEM (FONT-LEFT-KERN-TABLE FONT)) ; (SETQ COL (+ COL (AR-1 TEM CHAR)))) ;However it looks like this would cause more trouble than it would save. ;Attempts to reference outside of the raster return 0, or barf if storing. ;Conceivably it might be good to not barf at attempts to store 0 out of bounds? (DEFUN TV-GET-FONT-PIXEL (FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR))) (COND ((OR (< ROW 0) (>= ROW (FONT-RASTER-HEIGHT FONT)) (< COL 0) (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT)) (SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT)))) (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT))) (>= CHAR (AR-1 TEM NEXTCHAR))) ((>= COL (FONT-RASTER-WIDTH FONT))))) 0) ;out of bounds, return 0 (T (DO ((FONT FONT (FONT-NEXT-PLANE FONT)) (PIXEL 0) (PLANENUM 0 (1+ PLANENUM))) ((NULL FONT) PIXEL) (SETQ PIXEL (+ PIXEL (LSH (AR-1 FONT (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR) (// ROW (FONT-RASTERS-PER-WORD FONT)))) (+ (* (FONT-RASTER-WIDTH FONT) (\ ROW (FONT-RASTERS-PER-WORD FONT))) COL))) PLANENUM))))))) (DEFUN TV-STORE-FONT-PIXEL (PIXEL FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR))) (COND ((OR (< ROW 0) (>= ROW (FONT-RASTER-HEIGHT FONT)) (< COL 0) (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT)) (SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT)))) (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT))) (>= CHAR (AR-1 TEM NEXTCHAR))) ((>= COL (FONT-RASTER-WIDTH FONT))))) (FERROR NIL "Store of ~C in ~S at ~O,~O out of character bounds" CHAR FONT ROW COL)) (T (DO ((FONT FONT (FONT-NEXT-PLANE FONT)) (BIT PIXEL (LSH BIT -1))) ((NULL FONT) PIXEL) (AS-1 BIT FONT (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR) (// ROW (FONT-RASTERS-PER-WORD FONT)))) (+ (* (FONT-RASTER-WIDTH FONT) (\ ROW (FONT-RASTERS-PER-WORD FONT))) COL))))))) (DEFUN TV-MAKE-SIDEWAYS-CHAR (FONT1 FONT2 CHAR &AUX (NEWWIDTH (1- (FONT-RASTER-HEIGHT FONT1))) (NEWHEIGHT (1- (FONT-RASTER-HEIGHT FONT2)))) (DO ROW NEWWIDTH (1- ROW) (< ROW 0) (DO COL NEWHEIGHT (1- COL) (< COL 0) (TV-STORE-FONT-PIXEL (TV-GET-FONT-PIXEL FONT1 CHAR ROW COL) FONT2 CHAR COL (- NEWWIDTH ROW))))) (DEFUN TV-MAKE-SIDEWAYS-FONT (FONT1 &AUX FONT2 RASTER-HEIGHT RASTER-WIDTH RASTERS-PER-WORD WORDS-PER-CHAR EXTRAWIDE IXT RESULT TEM) (COND ((SETQ TEM (FONT-CHAR-WIDTH-TABLE FONT1)) ;RASTER-HEIGHT IS THE WIDTH OF (SETQ RASTER-HEIGHT 0) ;THE WIDEST CHAR IN THE OLD FONT (DO I 0 (1+ I) (= I 200) ;(WHICH IS SLIGHTLY IN EXCESS) (SETQ RASTER-HEIGHT (MAX RASTER-HEIGHT (AR-1 TEM I))))) ((NOT (NULL (FONT-INDEXING-TABLE FONT1))) (SETQ RASTER-HEIGHT (FONT-CHAR-WIDTH FONT1))) ;(THIS SLIGHTLY IN EXCESS ALSO) ((SETQ RASTER-HEIGHT (FONT-RASTER-WIDTH FONT1)))) ;EASY CASE, USE EXACT NUM (COND ((> (SETQ RASTER-WIDTH (FONT-RASTER-HEIGHT FONT1)) 16.) (SETQ EXTRAWIDE (// (+ RASTER-WIDTH 15.) 16.) ;NUMBER OF COLUMNS PER CHARACTER RASTER-WIDTH 16.) ;IN MULTI-COLUMN MODE (SETQ IXT (MAKE-ARRAY NIL 'ART-16B 201)) (DO I 0 (1+ I) (= I 201) (AS-1 (* I EXTRAWIDE) IXT I)))) (SETQ RASTERS-PER-WORD (// 32. RASTER-WIDTH) WORDS-PER-CHAR (// (+ RASTER-HEIGHT (1- RASTERS-PER-WORD)) RASTERS-PER-WORD)) (DO ((FONT1 FONT1 (FONT-NEXT-PLANE FONT1))) ;MAKE ARRAYS FOR EACH PLANE ((NULL FONT1) (SETQ FONT2 RESULT)) (SETQ TEM (MAKE-FONT MAKE-ARRAY (NIL 'ART-1B (* 32. 200 WORDS-PER-CHAR (OR EXTRAWIDE 1))))) (COND ((NULL RESULT) (SETQ RESULT TEM)) (T (SETF (FONT-NEXT-PLANE FONT2) TEM))) (SETQ FONT2 TEM) (SETF (FONT-CHAR-HEIGHT FONT2) (FONT-CHAR-HEIGHT FONT1)) (SETF (FONT-CHAR-WIDTH FONT2) (FONT-CHAR-WIDTH FONT1)) (SETF (FONT-RASTER-HEIGHT FONT2) RASTER-HEIGHT) (SETF (FONT-RASTER-WIDTH FONT2) RASTER-WIDTH) (SETF (FONT-RASTERS-PER-WORD FONT2) RASTERS-PER-WORD) (SETF (FONT-WORDS-PER-CHAR FONT2) WORDS-PER-CHAR) (SETF (FONT-BASELINE FONT2) (FONT-BASELINE FONT1)) (SETF (FONT-CHAR-WIDTH-TABLE FONT2) (FONT-CHAR-WIDTH-TABLE FONT1)) (SETF (FONT-LEFT-KERN-TABLE FONT2) (FONT-LEFT-KERN-TABLE FONT1)) (SETF (FONT-BLINKER-WIDTH FONT2) (FONT-BLINKER-WIDTH FONT1)) (SETF (FONT-BLINKER-HEIGHT FONT2) (FONT-BLINKER-HEIGHT FONT1)) (SETF (FONT-INDEXING-TABLE FONT2) IXT)) (DO I 0 (1+ I) (= I 200) (TV-MAKE-SIDEWAYS-CHAR FONT1 FONT2 I)) FONT2) ;Routine for making fonts to work with doubled horizontal resolution. ;Alternating bits are taken from two planes. We use 2-bit pixels to access ;this, which isn't really right but that's what we'll do for now. (DEFUN TV-MAKE-DBL-HOR-CHAR (FONT1 FONT2 CHAR IXT &AUX WID) (SETQ WID (COND ((NULL IXT) (FONT-RASTER-WIDTH FONT2)) (T (* (FONT-RASTER-WIDTH FONT2) (- (AR-1 IXT (1+ CHAR)) (AR-1 IXT CHAR)))))) (DO ROW (1- (FONT-RASTER-HEIGHT FONT1)) (1- ROW) (< ROW 0) (DO COL 0 (1+ COL) (>= COL WID) (TV-STORE-FONT-PIXEL (+ (* (TV-GET-FONT-PIXEL FONT1 CHAR ROW (* COL 2)) 2) (TV-GET-FONT-PIXEL FONT1 CHAR ROW (1+ (* COL 2)))) FONT2 CHAR ROW COL)))) ;This could be slightly smarter about extrawide characters (DEFUN TV-MAKE-DBL-HOR-FONT (FONT1 &AUX FONT2 RASTER-HEIGHT RASTER-WIDTH RASTERS-PER-WORD WORDS-PER-CHAR EXTRAWIDE IXT CWT LKT RESULT MXW TEM) (SETQ RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT1)) ;SAME HEIGHT (SETQ RASTER-WIDTH (FONT-RASTER-WIDTH FONT1)) ;WORK ON COMPUTING WIDTH (COND ((NOT (NULL (SETQ TEM (FONT-INDEXING-TABLE FONT1)))) (SETQ MXW 0) (DO I 0 (1+ I) (= I 200) (SETQ MXW (MAX (- (AR-1 TEM (1+ I)) (AR-1 TEM I)) MXW))) (SETQ RASTER-WIDTH (* RASTER-WIDTH MXW)))) (COND ((> (SETQ RASTER-WIDTH (// (1+ RASTER-WIDTH) 2)) 16.) (SETQ EXTRAWIDE (// (+ RASTER-WIDTH 15.) 16.) ;NUMBER OF COLUMNS PER CHARACTER RASTER-WIDTH 16.) ;IN MULTI-COLUMN MODE (SETQ IXT (MAKE-ARRAY NIL 'ART-16B 201)) (DO I 0 (1+ I) (= I 201) (AS-1 (* I EXTRAWIDE) IXT I)))) (SETQ RASTERS-PER-WORD (// 32. RASTER-WIDTH) WORDS-PER-CHAR (// (+ RASTER-HEIGHT (1- RASTERS-PER-WORD)) RASTERS-PER-WORD)) (COND ((SETQ TEM (FONT-CHAR-WIDTH-TABLE FONT1)) (SETQ CWT (MAKE-ARRAY NIL 'ART-16B 200)) (DO I 0 (1+ I) (= I 200) (AS-1 (// (1+ (AR-1 TEM I)) 2) CWT I)))) (COND ((SETQ TEM (FONT-LEFT-KERN-TABLE FONT1)) (SETQ LKT (MAKE-ARRAY NIL 'ART-Q 200)) (DO I 0 (1+ I) (= I 200) (AS-1 (// (1+ (AR-1 TEM I)) 2) LKT I)))) (DO I 2 (1- I) (= I 0) ;MAKE 2 FONT ARRAYS (SETQ TEM (MAKE-FONT MAKE-ARRAY (NIL 'ART-1B (* 32. 200 WORDS-PER-CHAR (OR EXTRAWIDE 1))))) (COND ((NULL RESULT) (SETQ RESULT TEM)) (T (SETF (FONT-NEXT-PLANE FONT2) TEM))) (SETQ FONT2 TEM) (SETF (FONT-CHAR-HEIGHT FONT2) (FONT-CHAR-HEIGHT FONT1)) (SETF (FONT-CHAR-WIDTH FONT2) (// (1+ (FONT-CHAR-WIDTH FONT1)) 2)) (SETF (FONT-RASTER-HEIGHT FONT2) RASTER-HEIGHT) (SETF (FONT-RASTER-WIDTH FONT2) RASTER-WIDTH) (SETF (FONT-RASTERS-PER-WORD FONT2) RASTERS-PER-WORD) (SETF (FONT-WORDS-PER-CHAR FONT2) WORDS-PER-CHAR) (SETF (FONT-BASELINE FONT2) (FONT-BASELINE FONT1)) (SETF (FONT-CHAR-WIDTH-TABLE FONT2) CWT) (SETF (FONT-LEFT-KERN-TABLE FONT2) LKT) (SETF (FONT-BLINKER-WIDTH FONT2) (// (1+ (FONT-BLINKER-WIDTH FONT1)) 2)) (SETF (FONT-BLINKER-HEIGHT FONT2) (FONT-BLINKER-HEIGHT FONT1)) (SETF (FONT-INDEXING-TABLE FONT2) IXT)) (SETQ FONT2 RESULT) (DO I 0 (1+ I) (= I 200) (TV-MAKE-DBL-HOR-CHAR FONT1 FONT2 I IXT)) FONT2) ;"HPM" Gray font routines - after Hans Moravec ;This code is probably too simple-minded. It does scaling so as to take full advantage ;in each character of the number of gray levels available, but in order to win ;it may really need to heuristically identify lines (which presently get fuzzed ;by quantization noise.) Also, should support non-integral ratios, e.g. 2/3. (DECLARE (SPECIAL TV-MAKE-GRAY-ARRAY)) ;time saver since have to make 2 passes (DEFUN TV-MAKE-GRAY-CHAR (FONT1 FONT2 CHAR X-RATIO Y-RATIO RANGE &AUX VAL WIDTH (MAXVAL 0)) (SETQ WIDTH (COND ((NULL (SETQ VAL (FONT-INDEXING-TABLE FONT2))) (FONT-RASTER-WIDTH FONT2)) ((* (FONT-RASTER-WIDTH FONT2) (- (AR-1 VAL (1+ CHAR)) (AR-1 VAL CHAR)))))) ;First pass. Extract pixels, store into TV-MAKE-GRAY-ARRAY, get max. (DO ROW (1- (FONT-RASTER-HEIGHT FONT2)) (1- ROW) (< ROW 0) (DO COL (1- WIDTH) (1- COL) (< COL 0) (SETQ VAL 0) (DO ((ROW1 (* ROW Y-RATIO) (1+ ROW1)) (RC1 Y-RATIO (1- RC1))) ((= RC1 0)) (DO ((COL1 (* COL X-RATIO) (1+ COL1)) (CC1 X-RATIO (1- CC1))) ((= CC1 0)) (SETQ VAL (+ VAL (TV-GET-FONT-PIXEL FONT1 CHAR ROW1 COL1))))) (AS-2 VAL TV-MAKE-GRAY-ARRAY ROW COL) (SETQ MAXVAL (MAX MAXVAL VAL)))) ;Second pass, store scaled values into new font. (DO ROW (1- (FONT-RASTER-HEIGHT FONT2)) (1- ROW) (< ROW 0) (DO COL (1- WIDTH) (1- COL) (< COL 0) (TV-STORE-FONT-PIXEL (// (* (AR-2 TV-MAKE-GRAY-ARRAY ROW COL) RANGE) (1+ MAXVAL)) FONT2 CHAR ROW COL)))) ;This routine is simple-minded about width. Should really figure it out better. (DEFUN TV-MAKE-GRAY-FONT (FONT1 &OPTIONAL (X-RATIO 2) (Y-RATIO 2) (N-PLANES 2) &AUX FONT2 RASTER-HEIGHT RASTER-WIDTH RASTERS-PER-WORD WORDS-PER-CHAR EXTRAWIDE IXT TEM RANGE RESULT TV-MAKE-GRAY-ARRAY) (SETQ RANGE (LSH 1 N-PLANES)) ;PIXEL VALUES FROM 0 TO (1- RANGE) (SETQ RASTER-HEIGHT (// (+ (FONT-RASTER-HEIGHT FONT1) ;SCALE THE RASTER HEIGHT (1- Y-RATIO)) Y-RATIO)) (COND ((SETQ TEM (FONT-CHAR-WIDTH-TABLE FONT1)) ;RASTER-WIDTH IS THE WIDTH OF (SETQ RASTER-WIDTH 0) ;THE WIDEST CHAR IN THE OLD FONT (DO I 0 (1+ I) (= I 200) ;(WHICH IS SLIGHTLY IN EXCESS) (SETQ RASTER-WIDTH (MAX RASTER-WIDTH (AR-1 TEM I))))) ((NOT (NULL (FONT-INDEXING-TABLE FONT1))) (SETQ RASTER-WIDTH (FONT-CHAR-WIDTH FONT1))) ;(THIS SLIGHTLY IN EXCESS ALSO) ((SETQ RASTER-WIDTH (FONT-RASTER-WIDTH FONT1)))) ;EASY CASE, USE EXACT NUM (SETQ RASTER-WIDTH (// (+ RASTER-WIDTH (1- X-RATIO)) ;NOW SCALE THE WIDTH X-RATIO)) (COND ((> RASTER-WIDTH 16.) (SETQ EXTRAWIDE (// (+ RASTER-WIDTH 15.) 16.) RASTER-WIDTH 16.) (SETQ IXT (MAKE-ARRAY NIL 'ART-16B 201)) (DO I 0 (1+ I) (= I 201) (AS-1 (* I EXTRAWIDE) IXT I)))) (SETQ RASTERS-PER-WORD (// 32. RASTER-WIDTH) WORDS-PER-CHAR (// (+ RASTER-HEIGHT (1- RASTERS-PER-WORD)) RASTERS-PER-WORD)) (DO ((I N-PLANES (1- I))) ;MAKE ARRAYS FOR EACH PLANE ((ZEROP I) (SETQ FONT2 RESULT)) (SETQ TEM (MAKE-FONT MAKE-ARRAY (NIL 'ART-1B (* 32. 200 WORDS-PER-CHAR (OR EXTRAWIDE 1))))) (COND ((NULL RESULT) (SETQ RESULT TEM)) (T (SETF (FONT-NEXT-PLANE FONT2) TEM))) (SETQ FONT2 TEM) (SETF (FONT-CHAR-HEIGHT FONT2) (// (+ (FONT-CHAR-HEIGHT FONT1) (1- Y-RATIO)) Y-RATIO)) (SETF (FONT-CHAR-WIDTH FONT2) (// (+ (FONT-CHAR-WIDTH FONT1) (1- X-RATIO)) X-RATIO)) (SETF (FONT-RASTER-HEIGHT FONT2) RASTER-HEIGHT) (SETF (FONT-RASTER-WIDTH FONT2) RASTER-WIDTH) (SETF (FONT-RASTERS-PER-WORD FONT2) RASTERS-PER-WORD) (SETF (FONT-WORDS-PER-CHAR FONT2) WORDS-PER-CHAR) (SETF (FONT-BASELINE FONT2) (// (+ (FONT-BASELINE FONT1) (1- Y-RATIO)) Y-RATIO)) (SETF (FONT-CHAR-WIDTH-TABLE FONT2) (AND (SETQ TEM (FONT-CHAR-WIDTH-TABLE FONT1)) (DO ((CWT (MAKE-ARRAY NIL 'ART-16B 200)) (I 0 (1+ I))) ((= I 200) CWT) (AS-1 (// (+ (AR-1 TEM I) (1- X-RATIO)) X-RATIO) CWT I)))) (SETF (FONT-LEFT-KERN-TABLE FONT2) (AND (SETQ TEM (FONT-LEFT-KERN-TABLE FONT1)) (DO ((LKT (MAKE-ARRAY NIL 'ART-16B 200)) (I 0 (1+ I))) ((= I 200) LKT) (AS-1 (// (+ (AR-1 TEM I) (1- X-RATIO)) X-RATIO) LKT I)))) (SETF (FONT-BLINKER-WIDTH FONT2) (// (+ (FONT-BLINKER-WIDTH FONT1) (1- X-RATIO)) X-RATIO)) (SETF (FONT-BLINKER-HEIGHT FONT2) (// (+ (FONT-BLINKER-HEIGHT FONT1) (1- Y-RATIO)) Y-RATIO)) (SETF (FONT-INDEXING-TABLE FONT2) IXT)) (SETQ TV-MAKE-GRAY-ARRAY (MAKE-ARRAY NIL 'ART-8B (LIST 200 200))) (DO I 0 (1+ I) (= I 200) (TV-MAKE-GRAY-CHAR FONT1 FONT2 I X-RATIO Y-RATIO RANGE)) (RETURN-ARRAY TV-MAKE-GRAY-ARRAY) FONT2) ;NEW TABLES OF FONT NAMES AND RELATIONS? NOT YET? ;ALSO FUNCTIONS TO SWITCH EVERYTHING OVER TO SIDEWAYS AND BACK AGAIN. ;NEED A FONT-CONVERSION ROUTINE WHICH DOES HORIZONTAL INTERLEAVING (SEE H)