Context Navigation

fntcnv.lisp @ 253

Revision 253, 37.4 KB (checked in by rjs, 22 months ago)
Update.

Line
1	;;;--Mode:LISP; Package:FED--
2
3	;The functions in this file
4	;are used to convert between the various formats for fonts as used on the LISP
5	;Machine. There are currently three formats supported:
6	; KST format is used for communication with the PDP-10.
7	; FD (or Font Descriptor) Format is used as a machine resident format
8	; which is easily manipulated. The format consists of a 200
9	; element array with a leader. The elements of this array are
10	; themselves two dimensional arrays which contain the actual
11	; pixel values for the character.
12	; FONT (or internal) Format is the format actually used by the tv display
13	; routines. The format is fairly complicated and its direct
14	; use is not recommended when a conversion to FD format would
15	; be better.
16	; AL format is used for ALTO fonts.
17
18	;First some helping functions:
19
20	;Maximum raster width of an FD format font
21	(DEFUN MAX-RASTER-WIDTH (FONT-DESCRIPTOR &AUX (GUESS 0) TEMP)
22	(DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
23	(( CHAR-CODE 200) GUESS)
24	(COND ((SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
25	(SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 2 TEMP)))))))
26
27	;Maximum raster height of an FD format font
28	(DEFUN MAX-RASTER-HEIGHT (FONT-DESCRIPTOR &AUX (GUESS 0) TEMP)
29	(DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
30	(( CHAR-CODE 200) GUESS)
31	(COND ((SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
32	(SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 1 TEMP)))))))
33
34	;;; Memoizing version of FONT-INTO-FONT-DESCRIPTOR
35	;;; that wants a font name (symbol in FONTS:) rather than the font itself.
36	;;; The FONT-DESCRIPTOR property of the symbol holds the descriptor.
37	;;; The FONT-DESCRIBED property holds the font itself which the descriptor matches.
38	;;; If anyone changes the font, we can see that the old descriptor is no good.
39	(defun font-name-font-descriptor (fontname &aux fd)
40	(setq fd (get fontname 'font-descriptor))
41	(cond ((and fd (eq (get fontname 'font-described) (symeval fontname))))
42	(t (setq fd (font-into-font-descriptor (symeval fontname)))
43	(putprop fontname (symeval fontname) 'font-described)
44	(putprop fontname fd 'font-descriptor)))
45	fd)
46
47	;;; Set a font given a font descriptor. Keep the descriptor around.
48	;;; Forward the old definition of the font to the new one.
49	(defun font-name-set-font-and-descriptor (fontname font-descriptor)
50	(let ((oldfont (and (boundp fontname) (symeval fontname))))
51	(set fontname (font-descriptor-into-font font-descriptor))
52	(and oldfont (structure-forward oldfont (symeval fontname)))
53	(putprop fontname font-descriptor 'font-descriptor)
54	(putprop fontname (symeval fontname) 'font-described)
55	font-descriptor))
56
57	;Store a character in a font. Given a font and corresponding FD, both are
58	;updated by storing a given CD for a given character code.
59	;If the CD can be stored into the existing font, that is done.
60	;Otherwise, a new font is made from the updated FD and the old font forwarded to it.
61	(defun font-name-store-cd (fontname cd char-code &aux font)
62	(let ((width (array-dimension-n 2 cd))
63	(height (array-dimension-n 1 cd))
64	tem fd)
65	(setq fd (font-name-font-descriptor fontname))
66	(as-1 cd fd char-code)
67	(and (= char-code #/ )
68	(setf (fd-space-width fd) (cd-char-width cd)))
69	(cond ((or (not (boundp fontname))
70	(null (setq font (symeval fontname)))
71	(> width
72	(cond ((setq tem (font-indexing-table font))
73	(* (font-raster-width font)
74	(- (ar-1 tem (1+ char-code))
75	(ar-1 tem char-code))))
76	(t (font-raster-width font))))
77	(> height (font-raster-height font)))
78	(font-name-set-font-and-descriptor fontname fd))
79	(t (store-cd-in-font cd font char-code nil)))))
80
81	;Functions for referring to specified pixels of characters in an internal format font.
82
83	;ROW and COL are measured from top/left as usual. An alternative would be:
84	; COL is measured from the left, with Kerning hacked.
85	; ROW is positive above the baseline and negative below.
86	; (SETQ ROW (- (FONT-BASELINE FONT) ROW))
87	; (AND (SETQ TEM (FONT-LEFT-KERN-TABLE FONT))
88	; (SETQ COL (+ COL (AR-1 TEM CHAR))))
89	;However it looks like this would cause more trouble than it would save.
90	;Attempts to reference outside of the raster return 0, or barf if storing.
91	;Conceivably it might be good to not barf at attempts to store 0 out of bounds?
92
93	(DEFUN FONT-GET-PIXEL (FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR)))
94	(COND ((OR (< ROW 0)
95	(>= ROW (FONT-RASTER-HEIGHT FONT))
96	(< COL 0)
97	(COND ((SETQ TEM (FONT-INDEXING-TABLE FONT))
98	(SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
99	(SETQ COL (\ COL (FONT-RASTER-WIDTH FONT)))
100	(>= CHAR (AR-1 TEM NEXTCHAR)))
101	((>= COL (FONT-RASTER-WIDTH FONT)))))
102	0) ;out of bounds, return 0
103	(T
104	(DO ((FONT FONT (FONT-NEXT-PLANE FONT))
105	(PIXEL 0)
106	(PLANENUM 0 (1+ PLANENUM)))
107	((NULL FONT) PIXEL)
108	(SETQ PIXEL
109	(+ PIXEL (LSH (AR-1 FONT
110	(+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR)
111	(// ROW (FONT-RASTERS-PER-WORD FONT))))
112	(+ (* (FONT-RASTER-WIDTH FONT)
113	(\ ROW (FONT-RASTERS-PER-WORD FONT)))
114	COL)))
115	PLANENUM)))))))
116
117	(DEFUN FONT-SET-PIXEL (PIXEL FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR)))
118	(COND ((OR (< ROW 0)
119	(>= ROW (FONT-RASTER-HEIGHT FONT))
120	(< COL 0)
121	(COND ((SETQ TEM (FONT-INDEXING-TABLE FONT))
122	(SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
123	(SETQ COL (\ COL (FONT-RASTER-WIDTH FONT)))
124	(>= CHAR (AR-1 TEM NEXTCHAR)))
125	((>= COL (FONT-RASTER-WIDTH FONT)))))
126	(FERROR NIL "Store of ~C in ~S at ~O,~O out of character bounds" CHAR FONT ROW COL))
127	(T
128	(DO ((FONT FONT (FONT-NEXT-PLANE FONT))
129	(BIT PIXEL (LSH BIT -1)))
130	((NULL FONT) PIXEL)
131	(AS-1 BIT FONT
132	(+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR)
133	(// ROW (FONT-RASTERS-PER-WORD FONT))))
134	(+ (* (FONT-RASTER-WIDTH FONT)
135	(\ ROW (FONT-RASTERS-PER-WORD FONT)))
136	COL)))))))
137
138	;This function takes an FD format font and creates an internal format
139	; font from it. All of the hairy formats of the stored font
140	; are taken care of by this function so the user doesn't have
141	; to worry about them.
142
143	(DEFUN FONT-DESCRIPTOR-INTO-FONT (FONT-DESCRIPTOR
144	&OPTIONAL (NBR-PLANES-OUT NIL)
145	&AUX (FONT-OUT NIL)
146	(COL-INCR (COND ((FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) 2)
147	(T 1)))
148	(SPACE-WIDTH (OR (FD-SPACE-WIDTH FONT-DESCRIPTOR) 0))
149	(WIDTH (// SPACE-WIDTH COL-INCR))
150	(HEIGHT (FD-LINE-SPACING FONT-DESCRIPTOR))
151	(BASELINE (FD-BASELINE FONT-DESCRIPTOR))
152	(RASTER-WIDTH (// (+ (MAX-RASTER-WIDTH FONT-DESCRIPTOR)
153	(1- COL-INCR))
154	COL-INCR))
155	(RASTER-HEIGHT (MAX-RASTER-HEIGHT FONT-DESCRIPTOR))
156	(RASTERS-PER-WORD (// 32. (MIN 32. RASTER-WIDTH)))
157	(WORDS-PER-RASTER-ELEMENT (1+ (// (1- RASTER-HEIGHT) RASTERS-PER-WORD)))
158	(TOTAL-RASTER-ELEMENTS 200)
159	(BLINKER-WIDTH (// (FD-BLINKER-WIDTH FONT-DESCRIPTOR) COL-INCR))
160	(BLINKER-HEIGHT (FD-BLINKER-HEIGHT FONT-DESCRIPTOR))
161	(INDEXING-TABLE NIL)
162	(CHARS-EXIST-TABLE (MAKE-ARRAY NIL ART-1B 200))
163	TEMP ;General temporary
164	)
165
166	;Set up NBR-PLANES-OUT if defaulted
167	(COND ((NULL NBR-PLANES-OUT)
168	(SETQ NBR-PLANES-OUT COL-INCR)))
169
170	;Create INDEXING-TABLE if needed
171	(COND ((> RASTER-WIDTH 32.)
172	(SETQ INDEXING-TABLE (MAKE-ARRAY NIL 'ART-16B 201))
173	(AS-1 0 INDEXING-TABLE 0)
174	(DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
175	(( CHAR-CODE 200) (SETQ TOTAL-RASTER-ELEMENTS (AR-1 INDEXING-TABLE 200)))
176	(SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
177	(AS-1 (+ (AR-1 INDEXING-TABLE CHAR-CODE)
178	(COND ((NULL TEMP) 0)
179	(T (// (+ (ARRAY-DIMENSION-N 2 TEMP) 31.) 32.))))
180	INDEXING-TABLE (1+ CHAR-CODE)))
181	(SETQ RASTER-WIDTH 32.)))
182
183	;set up all the planes of the font
184	(DO ((I NBR-PLANES-OUT (1- I)))
185	((ZEROP I))
186
187	;Make up a (one-plane) font and make it's next plane be the last one we made
188	(SETQ TEMP (TV:MAKE-FONT MAKE-ARRAY (NIL 'ART-1B
189	(* TOTAL-RASTER-ELEMENTS
190	WORDS-PER-RASTER-ELEMENT 32.))))
191	(SETF (FONT-NEXT-PLANE TEMP) FONT-OUT)
192	(SETQ FONT-OUT TEMP)
193
194	;Now set all the other fields in the leader
195	(SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
196	(SETF (FONT-CHAR-WIDTH FONT-OUT) WIDTH)
197	(SETF (FONT-CHAR-HEIGHT FONT-OUT) HEIGHT)
198	(SETF (FONT-RASTER-WIDTH FONT-OUT) RASTER-WIDTH)
199	(SETF (FONT-RASTER-HEIGHT FONT-OUT) RASTER-HEIGHT)
200	(SETF (FONT-RASTERS-PER-WORD FONT-OUT) RASTERS-PER-WORD)
201	(SETF (FONT-WORDS-PER-CHAR FONT-OUT) WORDS-PER-RASTER-ELEMENT)
202	(SETF (FONT-BASELINE FONT-OUT) BASELINE)
203	(SETF (FONT-BLINKER-WIDTH FONT-OUT) BLINKER-WIDTH)
204	(SETF (FONT-BLINKER-HEIGHT FONT-OUT) BLINKER-HEIGHT)
205	(SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
206	(SETF (FONT-CHARS-EXIST-TABLE FONT-OUT) CHARS-EXIST-TABLE)
207	(SETF (FONT-INDEXING-TABLE FONT-OUT) INDEXING-TABLE))
208	(DO ((CHAR-CODE 0 (1+ CHAR-CODE))) (( CHAR-CODE 200))
209	(SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
210	(COND (TEMP
211	(STORE-CD-IN-FONT TEMP FONT-OUT CHAR-CODE
212	(FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR)))))
213	FONT-OUT)
214
215	;Store the data in CD into character number CHAR-CODE of FONT.
216	;It is assumed that the dimensions of the CD fit within the raster dimensions of the font.
217	;This is not recommended for users to call.
218	(DEFUN STORE-CD-IN-FONT (CD FONT CHAR-CODE &OPTIONAL (DOUBLE-WIDTH-P NIL) &AUX
219	(WIDTH (ARRAY-DIMENSION-N 2 CD))
220	(HEIGHT (ARRAY-DIMENSION-N 1 CD))
221	(FONT-HEIGHT (FONT-RASTER-HEIGHT FONT))
222	(FONT-WIDTH (FONT-RASTER-WIDTH FONT))
223	PIXEL
224	(COL-INCR (COND (DOUBLE-WIDTH-P 2) (T 1))))
225	;; Update the font's char-width-table, creating one if necessary.
226	(LET ((CW (// (+ (CD-CHAR-WIDTH CD)
227	(1- COL-INCR))
228	COL-INCR))
229	(FCW (FONT-CHAR-WIDTH FONT))
230	(FCWT (FONT-CHAR-WIDTH-TABLE FONT)))
231	(COND (FCWT
232	(AS-1 CW FCWT CHAR-CODE))
233	((NOT (= CW FCW))
234	(SETF (FONT-CHAR-WIDTH-TABLE FONT)
235	(SETQ FCWT (MAKE-ARRAY NIL ART-8B '(200))))
236	(AND DOUBLE-WIDTH-P
237	(SETF (FONT-CHAR-WIDTH-TABLE (FONT-NEXT-PLANE FONT))
238	FCWT))
239	(DO I 0 (1+ I) (= I 200)
240	(AS-1 FCW FCWT I))
241	(AS-1 CW FCWT CHAR-CODE)))
242	(AND (= CHAR-CODE #/ )
243	(SETF (FONT-CHAR-WIDTH FONT) CW)))
244	;; Update the font's left-kern table, creating one if necessary.
245	(LET ((CK (CD-CHAR-LEFT-KERN CD))
246	(FCKT (FONT-LEFT-KERN-TABLE FONT)))
247	(COND (FCKT (AS-1 CK FCKT CHAR-CODE))
248	((NOT (ZEROP CK))
249	(SETF (FONT-LEFT-KERN-TABLE FONT) ;MUST BE ART-32B BECAUSE LEFT-KERN
250	(SETQ FCKT (MAKE-ARRAY NIL ART-32B '(200)))) ;CAN BE NEGATIVE
251	(AND DOUBLE-WIDTH-P
252	(SETF (FONT-LEFT-KERN-TABLE (FONT-NEXT-PLANE FONT))
253	FCKT))
254	(AS-1 CK FCKT CHAR-CODE))))
255	;; Tell the font this char exists.
256	(ERRSET (AS-1 1 (FONT-CHARS-EXIST-TABLE FONT) CHAR-CODE) NIL)
257	;; In wide fonts, the raster width depends on the character, and is a multiple of 32.
258	(COND ((FONT-INDEXING-TABLE FONT)
259	(SETQ FONT-WIDTH (* (// (+ (ARRAY-DIMENSION-N 2 CD) 31.) 32.) 32.))))
260	;; Now copy the data.
261	(DO ((ROW 0 (1+ ROW)))
262	(( ROW FONT-HEIGHT))
263	(DO ((COL 0 (+ COL COL-INCR))
264	(PIXEL-COL 0 (1+ PIXEL-COL)))
265	(( PIXEL-COL FONT-WIDTH))
266	(SETQ PIXEL (COND ((OR (>= COL WIDTH) (>= ROW HEIGHT)) 0)
267	(DOUBLE-WIDTH-P
268	(+ (COND ((>= (1+ COL) WIDTH) 0)
269	(T (AR-2 CD ROW (1+ COL))))
270	(* 2 (AR-2 CD ROW COL))))
271	(T (AR-2 CD ROW COL))))
272	(FONT-SET-PIXEL PIXEL FONT CHAR-CODE
273	ROW PIXEL-COL))))
274
275	;Create an FD format font from an internal format font
276
277	(DEFUN FONT-INTO-FONT-DESCRIPTOR (FONT &OPTIONAL (DBL-WIDTH-P NIL)
278	&AUX (FONT-DESCRIPTOR (MAKE-FONT-DESCRIPTOR))
279	(LINE-SPACING (FONT-CHAR-HEIGHT FONT))
280	(RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT))
281	(BASELINE (FONT-BASELINE FONT))
282	(BLINKER-HEIGHT (FONT-BLINKER-HEIGHT FONT))
283	(BLINKER-WIDTH (FONT-BLINKER-WIDTH FONT))
284	(SPACE-WIDTH (FONT-CHAR-WIDTH FONT))
285	FONT-CHARS-EXIST-TABLE
286	TEMP RASTER-WIDTH CHARACTER-WIDTH LEFT-KERN PIXEL
287	)
288	(ERRSET (SETQ FONT-CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL)
289	(SETF (FD-NAME FONT-DESCRIPTOR) (FONT-NAME FONT))
290	(SETF (FD-LINE-SPACING FONT-DESCRIPTOR) LINE-SPACING)
291	(SETF (FD-BASELINE FONT-DESCRIPTOR)BASELINE)
292	(SETF (FD-BLINKER-HEIGHT FONT-DESCRIPTOR) BLINKER-HEIGHT)
293	(SETF (FD-BLINKER-WIDTH FONT-DESCRIPTOR) BLINKER-WIDTH)
294	(SETF (FD-SPACE-WIDTH FONT-DESCRIPTOR) SPACE-WIDTH)
295	(SETF (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) DBL-WIDTH-P)
296	(DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
297	(( CHAR-CODE 200))
298	(AND FONT-CHARS-EXIST-TABLE
299	(ZEROP (AR-1 FONT-CHARS-EXIST-TABLE CHAR-CODE))
300	(GO SKIP-CHAR))
301	(SETQ CHARACTER-WIDTH (COND ((SETQ TEMP (FONT-CHAR-WIDTH-TABLE FONT))
302	(AR-1 TEMP CHAR-CODE))
303	(T (FONT-CHAR-WIDTH FONT))))
304	(SETQ RASTER-WIDTH
305	(FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE))
306	(SETQ LEFT-KERN (COND ((SETQ TEMP (FONT-LEFT-KERN-TABLE FONT))
307	(AR-1 TEMP CHAR-CODE))
308	(T 0)))
309	(SETQ TEMP (MAKE-CHAR-DESCRIPTOR
310	MAKE-ARRAY (NIL 'ART-4B (LIST RASTER-HEIGHT RASTER-WIDTH))
311	CD-CHAR-WIDTH CHARACTER-WIDTH
312	CD-CHAR-LEFT-KERN LEFT-KERN))
313	(AS-1 TEMP FONT-DESCRIPTOR CHAR-CODE)
314	(COND (DBL-WIDTH-P (DO ((ROW 0 (1+ ROW)))
315	(( ROW RASTER-HEIGHT))
316	(DO ((COLI 0 (1+ COLI))
317	(COL 0 (+ 2 COL)))
318	(( COL RASTER-WIDTH))
319	(SETQ PIXEL (FONT-GET-PIXEL FONT CHAR-CODE ROW COLI))
320	(AS-2 PIXEL TEMP ROW COL)
321	(AS-2 (LSH PIXEL -1) TEMP ROW (1+ COL)))))
322	(T (DO ((ROW 0 (1+ ROW)))
323	(( ROW RASTER-HEIGHT))
324	(DO ((COL 0 (1+ COL)))
325	(( COL RASTER-WIDTH))
326	(AS-2 (FONT-GET-PIXEL FONT CHAR-CODE ROW COL)
327	TEMP ROW COL)))))
328	SKIP-CHAR)
329	FONT-DESCRIPTOR)
330
331	;; Read in a kst file and make and return a FONT-DESCRIPTOR,
332	;; which is an alternate convenient representation for a font.
333	(defun read-kst-into-font-descriptor (filename &optional fontname &aux stream fd)
334	(setq filename (fs:file-parse-name filename nil t ':kst))
335	(or fontname (setq fontname (funcall filename ':name)))
336	(and (stringp fontname) (setq fontname (intern fontname "FONTS")))
337	(setq stream (open filename '(:fixnum :in :byte-size 9.)))
338	(setq fd (make-font-descriptor fd-name fontname))
339	;; Discard KSTID.
340	(dotimes (i 4) (funcall stream ':tyi))
341	;; Discard column position adjust until I find out what it means.
342	(or (zerop (funcall stream ':tyi))
343	(ferror nil
344	"Nonzero column-position-adjust in font ~A -- what does that mean?"
345	fontname))
346	(setf (fd-space-width fd) 0) ;Just in case no space character.
347	(setf (fd-baseline fd) (funcall stream ':tyi))
348	(setf (fd-line-spacing fd) (read-kst-halfword stream))
349	(setf (fd-blinker-height fd)
350	(fd-line-spacing fd))
351	(setf (fd-name fd) fontname)
352	(let (kern char-code raster-width char-width byte-list byte-list-head cd tem
353	(line-height (fd-line-spacing fd)))
354	(do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
355	(setq kern (read-kst-halfword stream))
356	(setq char-code (read-kst-halfword stream))
357	(setq raster-width (read-kst-halfword stream))
358	(setq char-width (read-kst-halfword stream))
359	(setq cd (make-char-descriptor
360	make-array (nil art-1b (list line-height raster-width))))
361	(setf (cd-char-width cd) char-width)
362	(setf (cd-char-left-kern cd) kern)
363	(as-1 cd fd char-code)
364	(and (= char-code #/ )
365	(setf (fd-space-width fd) char-width))
366	;; read in the bits of the character
367	(setq byte-list nil
368	byte-list-head (list nil nil nil nil))
369	(dotimes (vpos line-height)
370	;; Read in the next row.
371	(dotimes (hpos raster-width)
372	;; If byte is exhausted, get next byte into (car byte-list)
373	(cond ((zerop (\ hpos 8))
374	(setq byte-list (read-kst-bytes stream byte-list byte-list-head))))
375	(setq tem (logand 1 (lsh (car byte-list) (- (\ hpos 8)))))
376	(as-2 tem cd vpos hpos)))))
377	(setf (fd-fill-pointer fd) 200)
378	;; Set width of blinker and space fields from the space character.
379	(setf (fd-blinker-width fd)
380	(fd-space-width fd))
381	(funcall stream ':close)
382	fd)
383
384	;; Read in a kst file and define a font.
385	;; The font name defaults from the file name.
386	(defun read-kst-into-font (filename &optional fontname
387	&aux stream font chars-exist-table
388	raster-width raster-height
389	rasters-per-word words-per-char)
390	(setq filename (fs:file-parse-name filename nil t ':kst))
391	(or fontname (setq fontname (funcall filename ':name)))
392	(and (stringp fontname) (setq fontname (intern fontname "FONTS")))
393	;; Read file once to determine font parameters.
394	(multiple-value (raster-width raster-height)
395	(read-kst-max-raster-width filename))
396	;; If this is a hairy wide font, then instead of writing it directly
397	;; make a font-descriptor and turn it into a font.
398	(cond ((> raster-width 32.)
399	(font-name-set-font-and-descriptor
400	fontname
401	(read-kst-into-font-descriptor filename fontname))
402	fontname)
403	(t
404	(setq rasters-per-word (// 32. raster-width))
405	(setq words-per-char (// (+ raster-height rasters-per-word -1) rasters-per-word))
406	;; Now that we know the parameters, allocate the font.
407	(setq font (tv:make-font make-array (nil art-1b (* words-per-char 32. 200))))
408	(setf (font-rasters-per-word font) rasters-per-word)
409	(setf (font-words-per-char font) words-per-char)
410	(setf (font-raster-width font) raster-width)
411	(setf (font-raster-height font) raster-height)
412	(setf (font-char-height font) raster-height)
413	(setf (font-blinker-height font) raster-height)
414	(setf (font-name font) fontname)
415	(setq chars-exist-table (make-array nil art-1b 200))
416	(setf (font-chars-exist-table font) chars-exist-table)
417	;; Now actually read in the data of the font.
418	(setq stream (open filename '(:fixnum :in :byte-size 9.)))
419	;; Discard KSTID.
420	(dotimes (i 4) (funcall stream ':tyi))
421	;; Discard column position adjust until I find out what it means.
422	(or (zerop (funcall stream ':tyi))
423	(ferror nil
424	"Nonzero column-position-adjust in font ~A -- what does that mean?"
425	fontname))
426	(setf (font-baseline font) (funcall stream ':tyi))
427	;; Discard line height (already determined).
428	(read-kst-halfword stream)
429	(let (kern char-code char-width char-raster-width
430	byte-list byte-list-head tem bit-pos word-pos
431	(line-height raster-height))
432	(do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
433	(setq kern (read-kst-halfword stream))
434	(setq char-code (read-kst-halfword stream))
435	;; While all chars have the same raster width in the lisp machine font,
436	;; we need the raster width stored in the kst file to read the kst file.
437	(setq char-raster-width (read-kst-halfword stream))
438	(setq char-width (read-kst-halfword stream))
439	(as-1 1 chars-exist-table char-code)
440	;; Now store the char width and left kern, creating the tables if nec.
441	(cond ((null (font-char-width font))
442	(setf (font-char-width font) char-width))
443	((font-char-width-table font)
444	(as-1 char-width (font-char-width-table font) char-code))
445	((= char-width (font-char-width font)))
446	(t (setf (font-char-width-table font)
447	(make-array nil art-16b 200))
448	(as-1 char-width (font-char-width-table font) char-code)))
449	(and (= char-code #/ )
450	(setf (font-char-width font) char-width))
451	(cond ((not (zerop kern))
452	(or (font-left-kern-table font)
453	(setf (font-left-kern-table font)
454	;; Use art-32b so can hold both signs.
455	(make-array nil art-32b 200)))
456	(as-1 kern (font-left-kern-table font) char-code)))
457	;; read in the bits of the character
458	(setq byte-list nil
459	byte-list-head (list nil nil nil nil))
460	(setq word-pos (* char-code words-per-char)
461	bit-pos 0)
462	(dotimes (vpos line-height)
463	;; Find next row in font - advance to word boundary if nec.
464	(and (> (+ bit-pos raster-width) 32.)
465	(setq bit-pos 0 word-pos (1+ word-pos)))
466	;; Read in that row.
467	(dotimes (hpos char-raster-width)
468	;; If byte is exhausted, get next byte into (car byte-list)
469	(cond ((zerop (\ hpos 8))
470	(setq byte-list (read-kst-bytes stream byte-list byte-list-head))))
471	(setq tem (logand 1 (lsh (car byte-list) (- (\ hpos 8)))))
472	(as-1 tem font (+ (lsh word-pos 5) bit-pos hpos)))
473	;; Advance past this row in the font.
474	(setq bit-pos (+ bit-pos raster-width)))
475	))
476	;; Set width of blinker and space fields from the space character.
477	(setf (font-blinker-width font)
478	(font-char-width font))
479	(set fontname font)
480	(putprop fontname filename 'kst-file)
481	(funcall stream ':close)
482	fontname)))
483
484	;; Scan a kst file and return two values which are the
485	;; raster width and raster height needed in a TV format font to contain that font.
486	(defun read-kst-max-raster-width (filename &aux stream
487	raster-height (raster-width 0)
488	char-raster-width)
489	(setq stream (open (fs:file-parse-name filename nil t ':kst) '(:fixnum :in :byte-size 9.)))
490	;; Discard KSTID.
491	(dotimes (i 4) (funcall stream ':tyi))
492	;; Discard column-position-adjust
493	(funcall stream ':tyi)
494	;; Discard baseline.
495	(funcall stream ':tyi)
496	;; Remember font line height as raster height.
497	(setq raster-height (read-kst-halfword stream))
498	;; Keep maxing raster widths of characters into raster-width
499	(setq raster-width 0)
500	(do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
501	;; Ignore char's left kern.
502	(read-kst-halfword stream)
503	;; Ignore its character code.
504	(read-kst-halfword stream)
505	;; Max in its raster width
506	(setq char-raster-width (read-kst-halfword stream))
507	(setq raster-width (max raster-width char-raster-width))
508	;; Ignore its character width.
509	(read-kst-halfword stream)
510	;; Skip the bits of the character
511	(prog ((bytes (* raster-height (// (+ char-raster-width 7) 8))))
512	(setq bytes (* 4 (// (+ bytes 3) 4)))
513	(dotimes (i bytes)
514	(funcall stream ':tyi))))
515	(funcall stream ':close)
516	(prog () (return raster-width raster-height)))
517
518	;; Fetch the next 8-bit byte where stream is a 9-bit byte stream.
519	;; byte-list-head should be a list of 4 things we can clobber.
520	;; byte-list is a tail of it.
521	;; We advance it, and if it is empty we fill byte-list-head
522	;; with four more 8-bit bytes and return that.
523	;; The car of our value is the next byte.
524	;; Save the value for the byte-list arg next time.
525	(defun read-kst-bytes (stream byte-list byte-list-head)
526	(or (cdr byte-list)
527	;; Exhausted the word - read another.
528	(let ((hwd1 (read-kst-halfword stream))
529	(hwd2 (read-kst-halfword stream)))
530	(setq byte-list byte-list-head)
531	;; Turn it into 4 8-bit bytes in byte-list.
532	(rplaca byte-list (ldb 1210 hwd1))
533	(rplaca (cdr byte-list) (ldb 0210 hwd1))
534	(rplaca (cddr byte-list)
535	(+ (lsh (ldb 0002 hwd1) 6)
536	(ldb 1406 hwd2)))
537	(rplaca (cdddr byte-list) (ldb 0410 hwd2))
538	byte-list)))
539
540	;; Read two 9-bit bytes from stream, make an 18-bit halfword,
541	;; and sign-extend it.
542	(defun read-kst-halfword (stream &aux hwd)
543	(setq hwd (+ (* (funcall stream ':tyi) 1000)
544	(funcall stream ':tyi)))
545	(cond ((bit-test hwd 400000)
546	(logior hwd -400000))
547	(t hwd)))
548
549	;; It would be good to check for chars that are all zero and
550	;; flush them, and also to compute the actual needed raster width and use it.
551	(defun write-font-into-kst (fontname &optional filename &aux stream font)
552	(and (stringp fontname) (setq fontname (intern fontname "FONTS")))
553	(setq filename (fs:file-parse-name filename nil t ':kst))
554	(setq font (symeval fontname))
555	(cond ((font-indexing-table font)
556	(let ((fd (font-name-font-descriptor fontname)))
557	(write-font-descriptor-into-kst fd filename)))
558	(t
559	(and (> (font-raster-height font)
560	(font-char-height font))
561	(format t "Warning: font raster height exceeds line height"))
562	(setq stream (open filename '(:fixnum :out :byte-size 9.)))
563	;; Write KSTID as 0.
564	(dotimes (i 4) (funcall stream ':tyo 0))
565	;; Write column position adjust as 0.
566	(funcall stream ':tyo 0)
567	;; Write baseline and height into second header word.
568	(funcall stream ':tyo (font-baseline font))
569	(write-kst-halfword stream (font-char-height font))
570	;; Then write out all the characters.
571	(let (kern-table char-width-table chars-exist-table
572	word-pos bit-pos byte-count byte
573	char-raster-width byte-list byte-list-head)
574	(setq kern-table (font-left-kern-table font)
575	char-width-table (font-char-width-table font))
576	(errset (setq chars-exist-table (font-chars-exist-table font)) nil)
577	(dotimes (char-code 200)
578	(and chars-exist-table
579	(zerop (ar-1 chars-exist-table char-code))
580	(go skip-char))
581	;; Each char must start with a word containing a 1.
582	(write-kst-halfword stream 0)
583	(write-kst-halfword stream 1)
584	;; left kern and char code fill the next word.
585	(write-kst-halfword stream
586	(or (and kern-table (ar-1 kern-table char-code)) 0))
587	(write-kst-halfword stream char-code)
588	;; Raster width and char width are the next word.
589	(setq char-raster-width (max 1 (font-char-min-raster-width font char-code)))
590	(write-kst-halfword stream char-raster-width)
591	(write-kst-halfword stream
592	(cond (char-width-table (or (ar-1 char-width-table char-code) 0))
593	(t (font-char-width font))))
594	;; Write out the bits of the character
595	;; Word-pos and bit-pos are used to point at a bit in the font.
596	(setq word-pos (* (font-words-per-char font) char-code))
597	(setq bit-pos 0 byte-count 0)
598	;; Byte-list and its head are used to accumulate 4 bytes
599	;; and then output them at once as a word.
600	;; This is needed because the stream wants 9-bit bytes.
601	(setq byte-list-head (list nil nil nil nil))
602	(setq byte-list byte-list-head)
603	(dotimes (vpos (font-char-height font))
604	;; Prepare to extract next row of char from font.
605	(and (> (+ bit-pos (font-raster-width font)) 32.)
606	(setq word-pos (1+ word-pos) bit-pos 0))
607	(setq byte 0)
608	;; Get the row a bit at a time and fill up 8-bit bytes.
609	;; Output the bytes when full. Output the excess at the end.
610	;; Count the bytes output with byte-count
611	(dotimes (hpos char-raster-width)
612	(cond ((and (= (\ hpos 8) 0) (not (zerop hpos)))
613	(setq byte-count (1+ byte-count))
614	(setq byte-list
615	(write-kst-byte stream byte byte-list byte-list-head))
616	(setq byte 0)))
617	(or ( vpos (font-raster-height font))
618	(setq byte (+ byte (lsh (ar-1 font
619	(+ (* 32. word-pos) hpos bit-pos))
620	(\ hpos 8))))))
621	(setq byte-count (1+ byte-count))
622	(setq byte-list (write-kst-byte stream byte byte-list byte-list-head))
623	(setq bit-pos (+ bit-pos (font-raster-width font))))
624	;; Pad to a word boundary.
625	(do () ((zerop (\ byte-count 4)))
626	(setq byte-list (write-kst-byte stream 0 byte-list byte-list-head))
627	(setq byte-count (1+ byte-count)))
628	skip-char)
629	;; Mark end of file with two -1 words.
630	(dotimes (i 8)
631	(funcall stream ':tyo -1)))
632	(close stream))))
633
634	(defun write-font-descriptor-into-kst (fd filename &aux stream)
635	(setq stream (open (fs:file-parse-name filename nil t ':kst)
636	'(:fixnum :out :byte-size 9.)))
637	;; Write KSTID as 0.
638	(dotimes (i 4) (funcall stream ':tyo 0))
639	;; Write column position adjust as 0.
640	(funcall stream ':tyo 0)
641	;; Write baseline and height into second header word.
642	(funcall stream ':tyo (fd-baseline fd))
643	(write-kst-halfword stream (fd-line-spacing fd))
644	;; Then write out all the characters.
645	(let (cd char-height byte-count byte byte-list byte-list-head)
646	(dotimes (char-code 200)
647	(cond ((and (setq cd (ar-1 fd char-code))
648	;; Wide fonts without chars-exist-tables can have 0-width chars.
649	(or (not (zerop (array-dimension-n 2 cd)))
650	(not (zerop (cd-char-width cd)))))
651	;; Each char must start with a word containing a 1.
652	(write-kst-halfword stream 0)
653	(write-kst-halfword stream 1)
654	;; left kern and char code fill the next word.
655	(write-kst-halfword stream (cd-char-left-kern cd))
656	(write-kst-halfword stream char-code)
657	;; Raster width and char width are the next word.
658	(write-kst-halfword stream (array-dimension-n 2 cd))
659	(write-kst-halfword stream (cd-char-width cd))
660	;; Write out the bits of the character
661	;; Byte-list and its head are used to accumulate 4 bytes
662	;; and then output them at once as a word.
663	;; This is needed because the stream wants 9-bit bytes.
664	(setq byte-list-head (list nil nil nil nil))
665	(setq byte-list byte-list-head)
666	(setq byte-count 0)
667	(setq char-height (array-dimension-n 1 cd))
668	(and (> char-height (fd-line-spacing fd))
669	(ferror nil "Character ~C height exceeds font line height in KST file"
670	char-code))
671	(dotimes (vpos (fd-line-spacing fd))
672	;; Prepare to extract next row of char from font.
673	(setq byte 0)
674	;; Get the row a bit at a time and fill up 8-bit bytes.
675	;; Output the bytes when full. Output the excess at the end.
676	;; Count the bytes output with byte-count
677	(dotimes (hpos (array-dimension-n 2 cd))
678	(cond ((and (= (\ hpos 8) 0) (not (zerop hpos)))
679	(setq byte-count (1+ byte-count))
680	(setq byte-list
681	(write-kst-byte stream byte byte-list byte-list-head))
682	(setq byte 0)))
683	(or ( vpos char-height)
684	(setq byte (+ byte (lsh (ar-2 cd vpos hpos) (\ hpos 8))))))
685	(setq byte-count (1+ byte-count))
686	(setq byte-list (write-kst-byte stream byte byte-list byte-list-head)))
687	;; Pad to a word boundary.
688	(do () ((zerop (\ byte-count 4)))
689	(setq byte-list (write-kst-byte stream 0 byte-list byte-list-head))
690	(setq byte-count (1+ byte-count))))))
691	;; Mark end of file with two -1 words.
692	(dotimes (i 8)
693	(funcall stream ':tyo -1)))
694	(close stream))
695
696	;; Write an 8-bit byte to the kst file. We pack 4 bytes per word.
697	;; The stream is assumed to want 9-bit bytes.
698	;; Byte-list-head should be a list of length 4 we can clobber.
699	;; byte-list should initially be the same thing; we return a new value to set it to.
700	(defun write-kst-byte (stream byte byte-list byte-list-head)
701	(rplaca byte-list byte)
702	(pop byte-list)
703	(cond ((null byte-list)
704	(setq byte-list byte-list-head)
705	(write-kst-halfword stream
706	(+ (lsh (first byte-list) 10.)
707	(lsh (second byte-list) 2.)
708	(ldb 0602 (third byte-list))))
709	(write-kst-halfword stream
710	(+ (lsh (ldb 0006 (third byte-list)) 12.)
711	(lsh (fourth byte-list) 4)))))
712	byte-list)
713
714	(defun write-kst-halfword (stream halfword)
715	(funcall stream ':tyo (ldb 1111 halfword))
716	(funcall stream ':tyo (ldb 0011 halfword)))
717
718	;; Compute the smallest raster width needed to store the specified char
719	;; as defined by the specified font.
720	;; low-level means we are looking at one sub-character in a wide font.
721	(defun font-char-min-raster-width (font char-code &optional low-level
722	&aux bit-pos word-pos tem
723	min-raster-width f-raster-width raster-height)
724	(cond ((and (not low-level)
725	(setq tem (font-indexing-table font)))
726	;; If it's a wide font, go by the number of vertical stripes,
727	;; but also see how wide the rightmost stripe really needs to be.
728	(max 0
729	(+ (* 32. (- (ar-1 tem (1+ char-code)) (ar-1 tem char-code)))
730	-32.
731	(font-char-min-raster-width font (1- (ar-1 tem (1+ char-code))) t))))
732	(t (setq word-pos (* char-code (font-words-per-char font))
733	bit-pos 0
734	min-raster-width 0
735	f-raster-width (font-raster-width font)
736	raster-height (font-raster-height font))
737	(dotimes (vpos raster-height)
738	(and (> (+ bit-pos f-raster-width) 32.)
739	(setq bit-pos 0 word-pos (1+ word-pos)))
740	(do ((hpos 0 (1+ hpos)) (index (+ bit-pos (lsh word-pos 5)) (1+ index)))
741	((= hpos f-raster-width))
742	(or (zerop (ar-1 font index))
743	(setq min-raster-width (max (1+ hpos) min-raster-width))))
744	(setq bit-pos (+ f-raster-width bit-pos)))
745	min-raster-width)))
746
747	;; ALTO .AL format
748	;; Load an ALTO font file into a font, the easy way, via a font descriptor
749	(DEFUN READ-AL-INTO-FONT (FILENAME &OPTIONAL FONTNAME)
750	(SETQ FILENAME (FS:FILE-PARSE-NAME FILENAME NIL T ':AL))
751	(OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME)))
752	(AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN FONTNAME "FONTS")))
753	(FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME
754	(READ-AL-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
755	(SYMEVAL FONTNAME))
756
757	;; Load an ALTO font file into a font descriptor
758	(DEFUN READ-AL-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME
759	&AUX FD STREAM ARRAY LINE-HEIGHT)
760	(SETQ FILENAME (FS:FILE-PARSE-NAME FILENAME NIL T ':AL))
761	(OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME)))
762	(AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN FONTNAME "FONTS")))
763	(SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME))
764	(SETF (FD-NAME FD) FONTNAME)
765	(SETQ STREAM (OPEN FILENAME '(:IN :FIXNUM)))
766	(UNWIND-PROTECT
767	(PROGN
768	(SETQ LINE-HEIGHT (FUNCALL STREAM ':TYI))
769	(SETF (FD-LINE-SPACING FD) LINE-HEIGHT)
770	(SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT)
771	(LET ((BASELINE-AND-MAX-WIDTH (FUNCALL STREAM ':TYI)))
772	(SETF (FD-BASELINE FD) (LDB 1007 BASELINE-AND-MAX-WIDTH))
773	(SETF (FD-SPACE-WIDTH FD) (LDB 0010 BASELINE-AND-MAX-WIDTH)))
774	(SETQ ARRAY (MAKE-ARRAY NIL 'ART-16B 1000. NIL '(0)))
775	(DO CH (FUNCALL STREAM ':TYI) (FUNCALL STREAM ':TYI) (NULL CH)
776	(ARRAY-PUSH-EXTEND ARRAY CH)))
777	(FUNCALL STREAM ':CLOSE))
778	(DO ((CH 0 (1+ CH))
779	(CD)
780	(CHAR-WIDTH))
781	(( CH 200))
782	(SETQ CHAR-WIDTH 0)
783	(DO ((IDX CH)
784	(XW))
785	(NIL)
786	(SETQ IDX (+ IDX (AREF ARRAY IDX)))
787	(SETQ XW (AREF ARRAY IDX))
788	(IF (ZEROP (PROG1 (LOGAND XW 1) (SETQ XW (// XW 2))))
789	(SETQ CHAR-WIDTH (+ CHAR-WIDTH 16.)
790	IDX XW)
791	(SETQ CHAR-WIDTH (+ CHAR-WIDTH XW))
792	(RETURN)))
793	(SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (NIL ART-1B (LIST LINE-HEIGHT CHAR-WIDTH))))
794	(SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH)
795	(AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH))
796	(SETF (CD-CHAR-LEFT-KERN CD) 0)
797	(ASET CD FD CH)
798	(READ-AL-INTO-FONT-DESCRIPTOR-1 CD ARRAY CH 0))
799	(SETF (FD-FILL-POINTER FD) 200)
800	;; Set width of blinker and space fields from the space character.
801	(SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD))
802	FD)
803
804	;;;IDX is the address of the character-pointer
805	(DEFUN READ-AL-INTO-FONT-DESCRIPTOR-1 (CD ARRAY IDX XOFF &AUX XW HD-AND-XH)
806	(SETQ IDX (+ IDX (AREF ARRAY IDX)))
807	(SETQ XW (AREF ARRAY IDX)
808	HD-AND-XH (AREF ARRAY (1+ IDX)))
809	(DO ((I (- IDX (LDB 0010 HD-AND-XH)) (1+ I))
810	(Y (LDB 1010 HD-AND-XH) (1+ Y)))
811	((= I IDX))
812	(DO ((BITS (AREF ARRAY I) (LSH BITS 1))
813	(X XOFF (1+ X)))
814	((ZEROP BITS))
815	(AND (BIT-TEST 100000 BITS)
816	(ASET 1 CD Y X))))
817	(OR (BIT-TEST 1 XW)
818	(READ-AL-INTO-FONT-DESCRIPTOR-1 CD ARRAY (// XW 2) (+ XOFF 16.))))
819
820	(DEFUN THICKEN-FONT-DESCRIPTOR (FD &OPTIONAL NEW-NAME &AUX LEN NFD)
821	(OR NEW-NAME (SETQ NEW-NAME (INTERN (STRING-APPEND (FD-NAME FD) #/B) "FONTS")))
822	(SETQ LEN (ARRAY-LENGTH FD)
823	NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (NIL ART-Q LEN)
824	FD-NAME NEW-NAME
825	FD-LINE-SPACING (FD-LINE-SPACING FD)
826	FD-BASELINE (FD-BASELINE FD)
827	FD-BLINKER-HEIGHT (FD-BLINKER-HEIGHT FD)
828	FD-BLINKER-WIDTH (FD-BLINKER-WIDTH FD)
829	FD-SPACE-WIDTH (FD-SPACE-WIDTH FD)))
830	(DO ((I 0 (1+ I))
831	(CD) (NCD))
832	(( I LEN))
833	(AND (SETQ CD (AREF FD I))
834	(LET ((WIDTH (ARRAY-DIMENSION-N 2 CD))
835	(HEIGHT (ARRAY-DIMENSION-N 1 CD)))
836	(SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (NIL ART-4B (LIST HEIGHT (1+ WIDTH)))
837	CD-CHAR-WIDTH (1+ (CD-CHAR-WIDTH CD))
838	CD-CHAR-LEFT-KERN (CD-CHAR-LEFT-KERN CD)))
839	(COPY-ARRAY-CONTENTS CD NCD)
840	(DOTIMES (J HEIGHT)
841	(DOTIMES (I WIDTH)
842	(ASET (LOGIOR (AREF CD J I) (AREF NCD J (1+ I))) NCD J (1+ I))))
843	(ASET NCD NFD I))))
844	NFD)
845
846	(DEFUN THICKEN-FONT (FONT-SYMBOL &AUX FD NFD NFS NFNT)
847	(SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL))
848	(SETQ NFD (THICKEN-FONT-DESCRIPTOR FD))
849	(SETQ NFS (FD-NAME NFD))
850	(SETQ NFNT (FONT-DESCRIPTOR-INTO-FONT NFD))
851	(SET NFS NFNT)
852	(PUTPROP NFS NFD 'FONT-DESCRIPTOR)
853	(PUTPROP NFS NFNT 'FONT-DESCRIBED)
854	NFS)

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format