-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathEDITFONT
541 lines (495 loc) · 28.2 KB
/
EDITFONT
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Feb-2025 12:28:41" {DSK}<home>matt>Interlisp>medley>lispusers>EDITFONT.;2 28339
:EDIT-BY "mth"
:CHANGES-TO (VARS EDITFONTCOMS)
:PREVIOUS-DATE "12-Jul-2022 14:18:56" {DSK}<home>matt>Interlisp>medley>lispusers>EDITFONT.;1)
(PRETTYCOMPRINT EDITFONTCOMS)
(RPAQQ EDITFONTCOMS
((* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL in order to compile this file. *)
(INITVARS (EF.MENU NIL)
(EF.TITLEMENU NIL))
(RECORDS CHARITEM)
(FNS EF.INIT EF.PROMPT EF.MESSAGE EF.CLOSEFN EF.CHARITEMS EF.BUTTONEVENTFN EF.WHENSELECTEDFN
EF.EDITBM EF.MIDDLEBUTTONFN EF.CHANGESIZE EF.DELETE EF.ENTER EF.REPLACE EF.SAVE EF.BLANK
COPYFONT READSTRIKEFONTFILE)
(FNS BLANKFONTCREATE EDITFONT)
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (BITSPERWORD 16)
(BYTESPERWORD 2))
(FILES (LOADCOMP)
FONT))
(P (EF.INIT))))
(* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL in order to compile this file. *)
(RPAQ? EF.MENU NIL)
(RPAQ? EF.TITLEMENU NIL)
(DECLARE%: EVAL@COMPILE
(RECORD CHARITEM (BITMAP (CHARCODE DUMMYFLG)))
)
(DEFINEQ
(EF.INIT
[LAMBDA NIL (* kbr%: "21-Oct-85 15:50")
(PROG NIL
[SETQ EF.MENU (create MENU
ITEMS _ '((CHANGESIZE 'EF.CHANGESIZE "Change size of character.")
(DELETE ''EF.DELETE "Delete character.")
(EDITBM ''EF.EDITBM "Edit character.")
(REPLACE ''EF.REPLACE
"Prompt for bitmap to replace character."]
(SETQ EF.TITLEMENU (create MENU
ITEMS _ '((SAVE 'EF.SAVE "Save EDITFONT's work back into font."])
(EF.PROMPT
[LAMBDA (STRING WINDOW) (* kbr%: "16-Oct-85 22:48")
(PROG (PROMPTW ANSWER)
(SETQ PROMPTW (GETPROMPTWINDOW WINDOW))
(CLEARW PROMPTW)
(PRIN1 STRING PROMPTW)
(PRIN1 " " PROMPTW)
(SETQ ANSWER (RESETLST
(RESETSAVE (TTYDISPLAYSTREAM PROMPTW))
(RESETSAVE (TTY.PROCESS (THIS.PROCESS)))
(TTYINREAD PROMPTW)))
(TERPRI PROMPTW)
(SETQ ANSWER (EVAL ANSWER))
(RETURN ANSWER])
(EF.MESSAGE
[LAMBDA (STRING WINDOW) (* kbr%: "16-Oct-85 22:50")
(PROG (PROMPTW)
(SETQ PROMPTW (GETPROMPTWINDOW WINDOW))
(PRIN1 STRING PROMPTW])
(EF.CLOSEFN
[LAMBDA (WINDOW) (* kbr%: "15-Dec-84 15:20")
(* Close EF Window. *)
(PROG NIL
[COND
((EQ (ASKUSER "Close Editfont Window?")
'N)
(RETURN 'DON'T]
(CLOSEW WINDOW) (* Break circularity.
*)
(WINDOWPROP WINDOW 'MENU NIL])
(EF.CHARITEMS
[LAMBDA (FONT FROMCHAR8CODE TOCHAR8CODE CHARSET) (* kbr%: "16-Oct-85 23:11")
(* Get CHARITEMS for FONT.
*)
(PROG (FROMCHARCODE TOCHARCODE OFFSETS DUMMYOFFSET DUMMYBITMAP OFFSET BITMAP CHARITEM CHARITEMS)
(* Get DUMMY CHARITEM *)
(* Interlisp assuming 256 is dummy is dumb now because of NS chars.
Maybe Kaplan and Nuyens will fix. *)
(SETQ DUMMYBITMAP (GETCHARBITMAP 256 FONT))
(SETQ CHARITEM (create CHARITEM
BITMAP _ DUMMYBITMAP
CHARCODE _ DUMMYINDEX
DUMMYFLG _ T))
(push CHARITEMS CHARITEM) (* Get ordinairy CHARITEMs.
*)
(SETQ FROMCHARCODE (IPLUS (ITIMES 256 CHARSET)
FROMCHAR8CODE))
(SETQ TOCHARCODE (IPLUS (ITIMES 256 CHARSET)
TOCHAR8CODE))
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of (\GETCHARSETINFO CHARSET FONT)))
(SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX))
(for I from TOCHARCODE to FROMCHARCODE by -1
do (SETQ OFFSET (\FGETOFFSET OFFSETS I))
[COND
((EQ OFFSET DUMMYOFFSET)
(SETQ CHARITEM (create CHARITEM
BITMAP _ DUMMYBITMAP
CHARCODE _ I
DUMMYFLG _ T)))
(T (SETQ BITMAP (GETCHARBITMAP I FONT))
(SETQ CHARITEM (create CHARITEM
BITMAP _ BITMAP
CHARCODE _ I
DUMMYFLG _ NIL]
(push CHARITEMS CHARITEM)) (* OKEY DOKEY *)
(RETURN CHARITEMS])
(EF.BUTTONEVENTFN
[LAMBDA (WINDOW) (* kbr%: "16-Oct-85 22:19")
(PROG (COMMAND)
(COND
((INSIDEP (DSPCLIPPINGREGION NIL WINDOW)
(LASTMOUSEX WINDOW)
(LASTMOUSEY WINDOW))
(MENUBUTTONFN WINDOW))
((SETQ COMMAND (MENU EF.TITLEMENU))
(APPLY* COMMAND WINDOW])
(EF.WHENSELECTEDFN
[LAMBDA (CHARITEM MENU KEY) (* kbr%: "16-Oct-85 22:26")
(PROG NIL
(COND
(CHARITEM (SELECTQ KEY
(LEFT (EF.EDITBM CHARITEM MENU))
(MIDDLE (EF.MIDDLEBUTTONFN CHARITEM MENU))
(* Do nothing. *)])
(EF.EDITBM
[LAMBDA (CHARITEM MENU) (* kbr%: "15-Dec-84 15:20")
(PROG (BITMAP CHARCODE DUMMYFLG)
(RESETLST
[RESETSAVE (SHADEITEM CHARITEM MENU BLACKSHADE)
`(SHADEITEM ,CHARITEM ,MENU ,WHITESHADE]
(SETQ BITMAP (fetch (CHARITEM BITMAP) of CHARITEM))
[COND
((AND (NOT (IEQP (fetch (CHARITEM CHARCODE) of CHARITEM)
DUMMYINDEX))
(fetch (CHARITEM DUMMYFLG) of CHARITEM))
(* Undummify this CHARITEM.
*)
(SETQ BITMAP (COPYALL BITMAP))
(UNINTERRUPTABLY
(replace (CHARITEM BITMAP) of CHARITEM with BITMAP)
(replace (CHARITEM DUMMYFLG) of CHARITEM with NIL))]
(EDITBM BITMAP))
(* Update MENU image. SHADEITEM's side effects above suffice if we only changed
one menu item. (I.e. we edited an ordinairy CHARITEM.) *)
(COND
((IEQP (fetch (CHARITEM CHARCODE) of CHARITEM)
DUMMYINDEX)
(UPDATE/MENU/IMAGE MENU)
(REDISPLAYW (WFROMMENU MENU])
(EF.MIDDLEBUTTONFN
[LAMBDA (CHARITEM MENU) (* kbr%: "15-Dec-84 15:20")
(PROG (COMMAND)
(SETQ COMMAND (MENU EF.MENU))
(COND
(COMMAND (APPLY* COMMAND CHARITEM MENU])
(EF.CHANGESIZE
[LAMBDA (CHARITEM MENU) (* kbr%: "16-Oct-85 23:03")
(* Change height & width of CHARITEM's
BITMAP *)
(PROG (HEIGHT WIDTH NEWBITMAP WINDOW)
(SETQ WINDOW (WFROMMENU MENU))
(SETQ HEIGHT (EF.PROMPT "New height?" WINDOW))
(COND
((NULL HEIGHT)
(EF.MESSAGE "Aborted." WINDOW)
(RETURN)))
(SETQ HEIGHT (EVAL HEIGHT))
(SETQ WIDTH (EF.PROMPT "New width?" WINDOW))
(COND
((NULL WIDTH)
(EF.MESSAGE "Aborted." WINDOW)
(RETURN)))
(SETQ WIDTH (EVAL WIDTH))
(SETQ NEWBITMAP (BITMAPCREATE WIDTH HEIGHT))
(BITBLT (fetch (CHARITEM BITMAP) of CHARITEM)
NIL NIL NEWBITMAP)
(UNINTERRUPTABLY
(replace (CHARITEM BITMAP) of CHARITEM with NEWBITMAP)
(replace (CHARITEM DUMMYFLG) of CHARITEM with NIL))
(UPDATE/MENU/IMAGE MENU)
(REDISPLAYW (WFROMMENU MENU])
(EF.DELETE
[LAMBDA (CHARITEM MENU) (* kbr%: "15-Dec-84 15:20")
(* Turn CHARITEM into dummy charitem.
*)
(PROG (WINDOW CHARITEMS DUMMYBITMAP)
(SETQ WINDOW (WFROMMENU MENU))
(SETQ CHARITEMS (WINDOWPROP WINDOW 'CHARITEMS))
[SETQ DUMMYBITMAP (fetch (CHARITEM BITMAP) of (CAR (LAST CHARITEMS]
(UNINTERRUPTABLY
(replace (CHARITEM BITMAP) of CHARITEM with DUMMYBITMAP)
(replace (CHARITEM DUMMYFLG) of CHARITEM with T))
(UPDATE/MENU/IMAGE MENU)
(REDISPLAYW (WFROMMENU MENU])
(EF.ENTER
[LAMBDA (CHARITEM MENU) (* kbr%: "15-Dec-84 15:20")
(* Enter BITMAP of CHARITEM.
*)
(PROG (NEWBITMAP)
(SETQ NEWBITMAP (EF.PROMPT "Enter new bitmap (evaluated):"))
(COND
((NULL NEWBITMAP)
(printout T "Aborted." T))
((type? BITMAP NEWBITMAP)
(UNINTERRUPTABLY
(replace (CHARITEM BITMAP) of CHARITEM with NEWBITMAP)
(replace (CHARITEM DUMMYFLG) of CHARITEM with NIL))
(UPDATE/MENU/IMAGE MENU)
(REDISPLAYW (WFROMMENU MENU)))
(T (LISPERROR "ILLEGAL ARG" NEWBITMAP])
(EF.REPLACE
[LAMBDA (CHARITEM MENU) (* kbr%: "16-Oct-85 23:04")
(* Replace BITMAP of CHARITEM.
*)
(PROG (BITMAP WINDOW)
(SETQ WINDOW (WFROMMENU MENU))
(SETQ BITMAP (EF.PROMPT "New bitmap?" WINDOW))
(COND
((NULL BITMAP)
(EF.MESSAGE "Aborted." WINDOW))
((type? BITMAP BITMAP)
(UNINTERRUPTABLY
(replace (CHARITEM BITMAP) of CHARITEM with BITMAP)
(replace (CHARITEM DUMMYFLG) of CHARITEM with NIL))
(UPDATE/MENU/IMAGE MENU)
(REDISPLAYW (WFROMMENU MENU)))
(T (LISPERROR "ILLEGAL ARG" BITMAP])
(EF.SAVE
[LAMBDA (WINDOW) (* kbr%: "21-Oct-85 15:39")
(* Save EDITFONT changes to FONT.
*)
(PROG (CHARITEMS FONT CB CBWIDTH CBHEIGHT WIDTHS OFFSETS HEIGHT WIDTH DUMMYOFFSET OFFSET BITMAP
FIRSTCHAR LASTCHAR CHARSET CSINFO)
(SETQ CHARITEMS (WINDOWPROP WINDOW 'CHARITEMS))
(SETQ FONT (WINDOWPROP WINDOW 'FONT)) (* New allocations. *)
(SETQ CBWIDTH 0)
(SETQ CBHEIGHT 0)
[for I from 0 to DUMMYINDEX as CHARITEM in CHARITEMS
when (OR (NOT (fetch (CHARITEM DUMMYFLG) of CHARITEM))
(IEQP I DUMMYINDEX)) do (SETQ BITMAP (fetch (CHARITEM BITMAP) of CHARITEM))
(SETQ CBWIDTH (IPLUS CBWIDTH (fetch (BITMAP BITMAPWIDTH
)
of BITMAP)))
(SETQ CBHEIGHT (IMAX CBHEIGHT (fetch (BITMAP
BITMAPHEIGHT
)
of BITMAP]
(SETQ CSINFO (create CHARSETINFO
CHARSETASCENT _ (fetch (FONTDESCRIPTOR \SFAscent) of FONT)
CHARSETDESCENT _ (fetch (FONTDESCRIPTOR \SFDescent) of FONT)))
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(* Store new info in allocations.
*)
(SETQ OFFSET 0)
[SETQ DUMMYOFFSET (IDIFFERENCE CBWIDTH (fetch (BITMAP BITMAPWIDTH)
of (fetch (CHARITEM BITMAP)
of (CAR (LAST CHARITEMS]
(SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
[for I from 0 to DUMMYINDEX as CHARITEM in CHARITEMS
do (SETQ BITMAP (fetch (CHARITEM BITMAP) of CHARITEM))
(SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP))
(SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP))
(\FSETWIDTH WIDTHS I WIDTH)
(COND
((AND (fetch (CHARITEM DUMMYFLG) of CHARITEM)
(NOT (IEQP I DUMMYINDEX)))
(\FSETOFFSET OFFSETS I DUMMYOFFSET))
(T (\FSETOFFSET OFFSETS I OFFSET)
(BITBLT BITMAP 0 0 CB OFFSET 0 WIDTH HEIGHT 'INPUT 'REPLACE)
(SETQ OFFSET (IPLUS OFFSET WIDTH] (* FIRSTCHAR & LASTCHAR.
(I wonder what you're suppose to do if
there aren't any chars?) *)
[SETQ FIRSTCHAR (\CHAR8CODE (fetch (CHARITEM CHARCODE)
of (for CHARITEM in CHARITEMS
thereis (NOT (fetch (CHARITEM DUMMYFLG) of CHARITEM]
[SETQ LASTCHAR (\CHAR8CODE (fetch (CHARITEM CHARCODE)
of (for CHARITEM in (REVERSE CHARITEMS)
thereis (NOT (fetch (CHARITEM DUMMYFLG) of CHARITEM]
[SETQ CHARSET (\CHARSET (fetch (CHARITEM CHARCODE) of (CAR CHARITEMS]
(* Store new info. *)
(UNINTERRUPTABLY
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with CB)
(replace (CHARSETINFO WIDTHS) of CSINFO with WIDTHS)
(replace (CHARSETINFO OFFSETS) of CSINFO with OFFSETS)
(\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with WIDTHS))
(* OKEY DOKEY. *)
])
(EF.BLANK
[LAMBDA (FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)
(* kbr%: "21-Oct-85 15:25")
(PROG (FONT CSINFO WIDTHS DUMMYWIDTH OFFSETS DUMMYOFFSET CB CBWIDTH CBHEIGHT)
(SETQ FAMILY (U-CASE FAMILY))
(COND
((NOT (FIXP SIZE))
(LISPERROR "ILLEGAL ARG" SIZE)))
(SETQ FACE (\FONTFACE FACE))
(COND
((NOT (SMALLP FIRSTCHAR))
(LISPERROR "ILLEGAL ARG" FIRSTCHAR)))
(COND
((NOT (SMALLP LASTCHAR))
(LISPERROR "ILLEGAL ARG" LASTCHAR)))
(COND
((NOT (SMALLP ASCENT))
(LISPERROR "ILLEGAL ARG" ASCENT)))
(COND
((NOT (SMALLP DESCENT))
(LISPERROR "ILLEGAL ARG" DESCENT)))
(COND
([NOT (OR (FIXP WIDTH)
(AND (LISTP WIDTH)
[NOT (for W in WIDTH thereis (NOT (FIXP W]
(IEQP (LENGTH WIDTH)
(IPLUS LASTCHAR (IMINUS FIRSTCHAR)
1 1]
(LISPERROR "ILLEGAL ARG" WIDTH))) (* WIDTHS. *)
(SETQ CSINFO (create CHARSETINFO
CHARSETASCENT _ ASCENT
CHARSETDESCENT _ DESCENT))
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
[COND
((LISTP WIDTH)
(SETQ DUMMYWIDTH (CAR (LAST WIDTH)))
(for I from 0 to (SUB1 FIRSTCHAR) do (\FSETWIDTH WIDTHS I DUMMYWIDTH))
(for I from FIRSTCHAR to LASTCHAR as W in WIDTH do (\FSETWIDTH WIDTHS I W))
(for I from (ADD1 LASTCHAR) to DUMMYINDEX do (\FSETWIDTH WIDTHS I DUMMYWIDTH)))
(T (for I from 0 to DUMMYINDEX do (\FSETWIDTH WIDTHS I WIDTH]
(* OFFSETS. *)
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
[for I from FIRSTCHAR to (ADD1 LASTCHAR) do (\FSETOFFSET OFFSETS (ADD1 I)
(IPLUS (\FGETOFFSET OFFSETS I)
(\FGETWIDTH WIDTHS I]
(SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS (ADD1 LASTCHAR)))
(for I from 0 to (SUB1 FIRSTCHAR) do (\FSETOFFSET OFFSETS I DUMMYOFFSET))
(for I from (ADD1 LASTCHAR) to DUMMYINDEX do (\FSETOFFSET OFFSETS I DUMMYOFFSET))
(* Characterbitmap CB.
*)
(SETQ CBHEIGHT (IPLUS ASCENT DESCENT))
(SETQ CBWIDTH (IPLUS (\FGETOFFSET OFFSETS DUMMYINDEX)
(\FGETWIDTH WIDTHS DUMMYINDEX)))
(SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with CB)
(* FONT. *)
(\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO))
[SETQ FONT
(create FONTDESCRIPTOR
FONTDEVICE _ 'DISPLAY
FONTFAMILY _ FAMILY
FONTSIZE _ SIZE
FONTFACE _ FACE
\SFAscent _ 0
\SFDescent _ 0
\SFHeight _ 0
ROTATION _ 0
FONTDEVICESPEC _ (LIST FAMILY SIZE FACE 0 'DISPLAY]
(replace (FONTDESCRIPTOR \SFAscent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFAscent)
of FONT)
(fetch (CHARSETINFO CHARSETASCENT)
of CSINFO)))
(replace (FONTDESCRIPTOR \SFDescent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFDescent)
of FONT)
(fetch (CHARSETINFO CHARSETDESCENT)
of CSINFO)))
[replace (FONTDESCRIPTOR \SFHeight) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFHeight)
of FONT)
(IPLUS (fetch (CHARSETINFO
CHARSETASCENT)
of CSINFO)
(fetch (CHARSETINFO
CHARSETDESCENT)
of CSINFO]
(\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT)
0 CSINFO)
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT))
(RETURN FONT])
(COPYFONT
[LAMBDA (FONT) (* jds "26-Aug-86 16:01")
(PROG (NEWFONT NEWCHARSETVECTOR OLDCHARSETVECTOR NEWCSINFO OLDCSINFO)
(SETQ NEWFONT (create FONTDESCRIPTOR using FONT))
(SETQ NEWCHARSETVECTOR (\ALLOCBLOCK (ADD1 \MAXCHARSET)
T))
(SETQ OLDCHARSETVECTOR (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT))
[for CHARSET from 0 to \MAXCHARSET
do (SETQ OLDCSINFO (\GETBASEPTR OLDCHARSETVECTOR (UNFOLD CHARSET 2)))
(COND
(OLDCSINFO [SETQ NEWCSINFO (create CHARSETINFO
CHARSETASCENT _ (fetch (CHARSETINFO
CHARSETASCENT)
of OLDCSINFO)
CHARSETDESCENT _ (fetch (CHARSETINFO
CHARSETDESCENT)
of OLDCSINFO)
CHARSETBITMAP _ (COPYALL (fetch (CHARSETINFO
CHARSETBITMAP)
of OLDCSINFO]
(\BLT (fetch (CHARSETINFO WIDTHS) of NEWCSINFO)
(fetch (CHARSETINFO WIDTHS) of OLDCSINFO)
(ADD1 DUMMYINDEX))
(\BLT (fetch (CHARSETINFO OFFSETS) of NEWCSINFO)
(fetch (CHARSETINFO OFFSETS) of OLDCSINFO)
(ADD1 DUMMYINDEX))
(replace (CHARSETINFO IMAGEWIDTHS) of NEWCSINFO with (fetch (CHARSETINFO
WIDTHS)
of NEWCSINFO))
(\RPLPTR NEWCHARSETVECTOR (UNFOLD CHARSET 2)
NEWCSINFO]
(RETURN NEWFONT])
(READSTRIKEFONTFILE
[LAMBDA (FAMILY SIZE FACE FILE FONT CHARSET)
(* ;; "Edited 12-Jul-2022 14:16 by rmk: Removed slightlly different implementations of \READSTRIKEFONTFILE and charset installation in favor of common code in FONT.")
(* ;; "Edited 12-Jul-2022 13:33 by rmk")
(* kbr%: "14-Oct-85 11:16")
(CL:UNLESS CHARSET (SETQ CHARSET 0)) (* ; "Returns fontdescriptor FONT. *")
(LET (STRM CSINFO)
(SETQ STRM (OPENSTREAM FILE 'INPUT 'OLD))
(\WIN STRM)
(SETQ CSINFO (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE))
(CLOSEF STRM) (* ;
"This part imitates \CREATEDISPLAYFONT *")
(CL:UNLESS FONT
[SETQ FONT
(create FONTDESCRIPTOR
FONTDEVICE _ 'DISPLAY
FONTFAMILY _ FAMILY
FONTSIZE _ SIZE
FONTFACE _ FACE
\SFAscent _ 0
\SFDescent _ 0
\SFHeight _ 0
ROTATION _ 0
FONTDEVICESPEC _ (LIST FAMILY SIZE FACE 0 'DISPLAY])
(\INSTALLCHARSETINFO FONT CSINFO CHARSET)
FONT])
)
(DEFINEQ
(BLANKFONTCREATE
[LAMBDA (FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)
(* mjs "27-Mar-85 14:48")
(EF.BLANK FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH])
(EDITFONT
[LAMBDA (FONT FROMCHARCODE TOCHARCODE CHARSET) (* ; "Edited 27-Jun-2022 10:47 by rmk")
(* mjs "27-Mar-85 14:48")
(* kbr%: "21-Oct-85 15:35")
(SETQ FONT (FONTCREATE FONT))
(CL:UNLESS FROMCHARCODE (SETQ FROMCHARCODE 0))
(CL:UNLESS TOCHARCODE (SETQ TOCHARCODE 255))
(CL:UNLESS CHARSET (SETQ CHARSET 0))
(PROG (CHARITEMS MENU TITLE HEIGHT WIDTH REGION POS WINDOW)
(SETQ CHARITEMS (EF.CHARITEMS FONT FROMCHARCODE TOCHARCODE CHARSET))
(SETQ MENU
(create MENU
MENUFONT _ FONT
CENTERFLG _ T
MENUCOLUMNS _ 16
ITEMS _ CHARITEMS
WHENSELECTEDFN _ (FUNCTION EF.WHENSELECTEDFN)))
[SETQ TITLE (PACK* (FONTPROP FONT 'FAMILY)
(FONTPROP FONT 'SIZE)
(PACKC (for ATOM in (FONTPROP FONT 'FACE) collect (CHCON1 ATOM]
(SETQ HEIGHT (HEIGHTIFWINDOW (fetch (MENU IMAGEHEIGHT) of MENU)
T))
(SETQ WIDTH (WIDTHIFWINDOW (fetch (MENU IMAGEWIDTH) of MENU)))
(SETQ POS (GETBOXPOSITION WIDTH HEIGHT))
(SETQ REGION (create REGION
LEFT _ (fetch (POSITION XCOORD) of POS)
BOTTOM _ (fetch (POSITION YCOORD) of POS)
WIDTH _ WIDTH
HEIGHT _ HEIGHT))
(SETQ WINDOW (CREATEW REGION TITLE))
(WINDOWPROP WINDOW 'CHARITEMS CHARITEMS)
(ADDMENU MENU WINDOW (create POSITION
XCOORD _ 0
YCOORD _ 0))
(WINDOWPROP WINDOW 'BUTTONEVENTFN 'EF.BUTTONEVENTFN])
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ BITSPERWORD 16)
(RPAQQ BYTESPERWORD 2)
(CONSTANTS (BITSPERWORD 16)
(BYTESPERWORD 2))
)
(FILESLOAD (LOADCOMP)
FONT)
)
(EF.INIT)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1325 25875 (EF.INIT 1335 . 2061) (EF.PROMPT 2063 . 2645) (EF.MESSAGE 2647 . 2859) (
EF.CLOSEFN 2861 . 3388) (EF.CHARITEMS 3390 . 5611) (EF.BUTTONEVENTFN 5613 . 6025) (EF.WHENSELECTEDFN
6027 . 6431) (EF.EDITBM 6433 . 7831) (EF.MIDDLEBUTTONFN 7833 . 8078) (EF.CHANGESIZE 8080 . 9299) (
EF.DELETE 9301 . 10066) (EF.ENTER 10068 . 10899) (EF.REPLACE 10901 . 11764) (EF.SAVE 11766 . 16439) (
EF.BLANK 16441 . 22066) (COPYFONT 22068 . 24508) (READSTRIKEFONTFILE 24510 . 25873)) (25876 28090 (
BLANKFONTCREATE 25886 . 26143) (EDITFONT 26145 . 28088)))))
STOP