Context Navigation

xfed.lisp @ 252

Revision 252, 45.7 KB (checked in by rjs, 22 months ago)
Initial versions.

Line
1	;;; --LISP--
2
3	(SPECIAL FED-WINDOW FED-FD-ALIST FED-WINDOW-CLASS)
4
5	(OR (BOUNDP 'FED-WINDOW)
6	(SETQ FED-WINDOW NIL))
7
8	(ENDF HEAD)
9
10	(DECLARE (SPECIAL BOX-X-SIZE BOX-Y-SIZE MARGINS
11	FED-CURSOR-X FED-CURSOR-Y FED-CURSOR-ON
12	WINDOW-X-POS WINDOW-Y-POS
13	WINDOW-X-SIZE WINDOW-Y-SIZE
14	MIN-CHANGED-X MIN-CHANGED-Y MAX-CHANGED-X MAX-CHANGED-Y
15	CHAR-BOX-X1 CHAR-BOX-X2 CHAR-BOX-Y1 CHAR-BOX-Y2 CHAR-BOX-Y3
16	DISPLAYED-CHAR-BOX-X1 DISPLAYED-CHAR-BOX-X2
17	DISPLAYED-CHAR-BOX-Y1 DISPLAYED-CHAR-BOX-Y2 DISPLAYED-CHAR-BOX-Y3
18	TYPEOUT-STREAM CLOBBERED-P
19	WINDOW-ARRAY CHARACTER CHARACTER-ARRAY SAMPLE-STRING))
20
21	(DEFCLASS FED-WINDOW-CLASS WINDOW-WITH-PC-PPR-CLASS
22	(BOX-X-SIZE BOX-Y-SIZE
23	LEFT-MARGIN TOP-MARGIN RIGHT-MARGIN BOTTOM-MARGIN MARGINS
24	FED-CURSOR-X FED-CURSOR-Y FED-CURSOR-ON
25	WINDOW-X-POS WINDOW-Y-POS
26	WINDOW-X-SIZE WINDOW-Y-SIZE
27	MIN-CHANGED-X MIN-CHANGED-Y MAX-CHANGED-X MAX-CHANGED-Y
28	CHAR-BOX-X1 CHAR-BOX-X2 CHAR-BOX-Y1 CHAR-BOX-Y2 CHAR-BOX-Y3
29	DISPLAYED-CHAR-BOX-X1 DISPLAYED-CHAR-BOX-X2
30	DISPLAYED-CHAR-BOX-Y1 DISPLAYED-CHAR-BOX-Y2 DISPLAYED-CHAR-BOX-Y3
31	TYPEOUT-STREAM CLOBBERED-P
32	WINDOW-ARRAY FONT CHARACTER CHARACTER-ARRAY SAMPLE-STRING))
33
34	;This is the top level of FED.
35	;We create a FED WINDOW and select it, so that type-in is directed at it.
36	;All type in is then handled by FED-COMMAND.
37	(DEFUN FED (&OPTIONAL (SCREEN TV-DEFAULT-SCREEN) (WIDTH 1000) (HEIGHT 1000) &AUX FRAME)
38	(OR FED-WINDOW
39	(PROGN (SETQ FED-WINDOW
40	(<- FED-WINDOW-CLASS ':NEW ':SCREEN SCREEN))
41	(SETQ FRAME (<- SI:WINDOW-SINGLE-FRAME-CLASS ':NEW))
42	(<- FRAME ':FIND-SPACE WIDTH HEIGHT WIDTH HEIGHT)
43	(<- FRAME ':PANE<- FED-WINDOW)))
44	(WINDOW-SELECT FED-WINDOW)
45	(PROCESS-WAIT "Select" #'(LAMBDA () (EQ CURRENT-PROCESS SELECTED-PROCESS))))
46
47	;Create a FED WINDOW.
48	(DEFMETHOD (FED-WINDOW-CLASS :BORN) ()
49	(OR SI:PROCESS (SETQ SI:PROCESS '(:NEW FED-TOP-LEVEL)))
50	(SETQ FED-CURSOR-X 0 FED-CURSOR-Y 0)
51	(SETQ BOX-X-SIZE 14 BOX-Y-SIZE 14)
52	(SETQ WINDOW-X-SIZE 0 WINDOW-Y-SIZE 0)
53	(SETQ WINDOW-X-POS 0 WINDOW-Y-POS 0)
54	(SETQ MIN-CHANGED-X WINDOW-X-SIZE
55	MIN-CHANGED-Y WINDOW-Y-SIZE
56	MAX-CHANGED-X 0 MAX-CHANGED-Y 0)
57	(OR MARGINS (SETQ MARGINS (LIST NIL NIL NIL NIL)))
58	(<-AS WINDOW-WITH-PC-PPR-CLASS ':BORN)
59	(SETQ TYPEOUT-STREAM
60	(SI:MAKE-WINDOW-TYPEOUT-STREAM SELF NIL))
61	(<- SELF ':WINDOW-UPDATE)
62	(<- SELF ':ERASE-ALL))
63
64	(DEFUN FED-TOP-LEVEL (WINDOW)
65	(DO () (()) (<- WINDOW ':COMMAND (KBD-TYI))))
66
67	(DEFMETHOD (FED-WINDOW-CLASS :ERASE-ALL) ()
68	(FED-ERASE-ALL SELF T))
69
70	;; Recompute the size of the window in boxes based on everything.
71	;; If necessary, allocate a new window array and clean the window.
72	(DEFMETHOD (FED-WINDOW-CLASS :WINDOW-UPDATE) ()
73	(<- SELF ':EDGES<- SI:LEFT SI:TOP SI:RIGHT SI:BOTTOM)
74	(AND SI:FRAME (LEXPR-FUNCALL '<- SI:FRAME ':EDGES<- (<- SI:FRAME ':EDGES))))
75
76	(DEFMETHOD (FED-WINDOW-CLASS :EDGES<-) (NEW-LEFT NEW-TOP NEW-RIGHT NEW-BOTTOM)
77	(<-AS WINDOW-WITH-PC-PPR-CLASS ':EDGES<- NEW-LEFT NEW-TOP NEW-RIGHT NEW-BOTTOM)
78	(SETQ LEFT-MARGIN NEW-LEFT TOP-MARGIN NEW-TOP)
79	;; Round size in both directions down to multiple of box.
80	;; If size has changed, make a new window array.
81	;; Both SETQs must be done even if the value of the AND is determined by the first!
82	(SETQ WINDOW-X-SIZE (// (- NEW-RIGHT NEW-LEFT) BOX-X-SIZE))
83	(SETQ WINDOW-Y-SIZE (// (- NEW-BOTTOM NEW-TOP) BOX-Y-SIZE))
84	(SETQ RIGHT-MARGIN (+ LEFT-MARGIN (* BOX-X-SIZE WINDOW-X-SIZE))
85	BOTTOM-MARGIN (+ TOP-MARGIN (* BOX-Y-SIZE WINDOW-Y-SIZE)))
86	;; Update the list MARGINS.
87	(SETF (FIRST MARGINS) LEFT-MARGIN)
88	(SETF (SECOND MARGINS) TOP-MARGIN)
89	(SETF (THIRD MARGINS) RIGHT-MARGIN)
90	(SETF (FOURTH MARGINS) BOTTOM-MARGIN))
91
92	(DEFMETHOD (FED-WINDOW-CLASS :CLOBBER-SCREEN) ()
93	(SETQ CLOBBERED-P T))
94
95	;; When we expose, make a new WINDOW-ARRAY if our size has changed since last use.
96	;; In that case, clean the window.
97	(DEFMETHOD (FED-WINDOW-CLASS :EXPOSE) ()
98	(OR (AND WINDOW-ARRAY
99	(= WINDOW-X-SIZE (ARRAY-DIMENSION-N 1 WINDOW-ARRAY))
100	(= WINDOW-Y-SIZE (ARRAY-DIMENSION-N 2 WINDOW-ARRAY)))
101	(SETQ WINDOW-ARRAY (MAKE-ARRAY NIL ART-4B (LIST WINDOW-X-SIZE WINDOW-Y-SIZE))))
102	(LET ((INHIBIT-SCREEN-RESTORATION-FLAG
103	(OR INHIBIT-SCREEN-RESTORATION-FLAG CLOBBERED-P)))
104	(<-AS WINDOW-WITH-PC-PPR-CLASS ':EXPOSE)))
105
106	;Methods concerned with redisplaying a fed window.
107
108	(DEFMETHOD (FED-WINDOW-CLASS :LABEL-HEIGHT) ()
109	(MAX (<-AS WINDOW-CLASS ':LABEL-HEIGHT)
110	(COND (FONT (FD-LINE-SPACING (FED-GET-FD FONT))) (T 0))))
111
112	(DEFMETHOD (FED-WINDOW-CLASS :PRINT-LABEL) (LABEL-PC-PPR)
113	(BIND (LOCF (PC-PPR-LINE-HEIGHT LABEL-PC-PPR)) (FUNCALL SELF ':LABEL-HEIGHT))
114	(COND (FONT
115	(BIND (LOCF (PC-PPR-BASELINE LABEL-PC-PPR))
116	(MAX (PC-PPR-BASELINE LABEL-PC-PPR)
117	(FD-BASELINE (FED-GET-FD FONT))))))
118	;; Now display which font and which character we are editing.
119	(TV-SET-FONT LABEL-PC-PPR (SCREEN-DEFAULT-FONT SI:SCREEN))
120	(TV-STRING-OUT LABEL-PC-PPR "Font: ")
121	(TV-STRING-OUT LABEL-PC-PPR (GET-PNAME FONT))
122	(COND (CHARACTER
123	(TV-STRING-OUT LABEL-PC-PPR " Char: ")
124	(TV-TYO LABEL-PC-PPR (+ #/0 (LDB 0603 CHARACTER)))
125	(TV-TYO LABEL-PC-PPR (+ #/0 (LDB 0303 CHARACTER)))
126	(TV-TYO LABEL-PC-PPR (+ #/0 (LDB 0003 CHARACTER)))
127	(TV-TYO LABEL-PC-PPR #/ )
128	(COND ((= CHARACTER #/ )
129	(TV-STRING-OUT LABEL-PC-PPR "Space"))
130	(T (TV-TYO LABEL-PC-PPR CHARACTER)))
131	(TV-TYO LABEL-PC-PPR #/ )
132	(COND ((AND (BOUNDP FONT) (SYMEVAL FONT))
133	(TV-SET-FONT LABEL-PC-PPR (SYMEVAL FONT))
134	(FED-TYO LABEL-PC-PPR CHARACTER)))))
135	(SI:TV-MOVE-BITPOS LABEL-PC-PPR 10 0)
136	(COND ((AND SAMPLE-STRING (BOUNDP FONT) (SYMEVAL FONT))
137	(TV-SET-FONT LABEL-PC-PPR (SYMEVAL FONT))
138	(DOTIMES (I (STRING-LENGTH SAMPLE-STRING))
139	(FED-TYO LABEL-PC-PPR (AR-1 SAMPLE-STRING I))))))
140
141	(DEFMETHOD (FED-WINDOW-CLASS :UPDATE) (&AUX TEM (INHIBIT-SCHEDULING-FLAG T))
142	(AND (FUNCALL TYPEOUT-STREAM ':DEACTIVATE)
143	(SETQ CLOBBERED-P T))
144	(TV-OPEN-SCREEN)
145	(TV-SELECT-SCREEN SI:SCREEN)
146	;; If dots or character box have changed, must reprint the label.
147	(AND (OR (> MAX-CHANGED-X -1)
148	CLOBBERED-P
149	(NOT (AND (= DISPLAYED-CHAR-BOX-X1 CHAR-BOX-X1)
150	(= DISPLAYED-CHAR-BOX-X2 CHAR-BOX-X2)
151	(= DISPLAYED-CHAR-BOX-Y1 CHAR-BOX-Y1)
152	(= DISPLAYED-CHAR-BOX-Y2 CHAR-BOX-Y2)
153	(= DISPLAYED-CHAR-BOX-Y3 CHAR-BOX-Y3))))
154	(<- SELF ':UPDATE-LABEL))
155	(COND (CLOBBERED-P
156	(SETQ CLOBBERED-P NIL)
157	(TV-CLEAR-PC-PPR SI:PC-PPR)
158	;; Now add in the lines representing the edges of the character frame,
159	;; except in scale 1.
160	(COND ((OR (= BOX-X-SIZE 1) (= BOX-Y-SIZE 1)))
161	(T
162	(SETQ DISPLAYED-CHAR-BOX-X1 CHAR-BOX-X1)
163	(SETQ DISPLAYED-CHAR-BOX-X2 CHAR-BOX-X2)
164	(SETQ DISPLAYED-CHAR-BOX-Y1 CHAR-BOX-Y1)
165	(SETQ DISPLAYED-CHAR-BOX-Y2 CHAR-BOX-Y2)
166	(SETQ DISPLAYED-CHAR-BOX-Y3 CHAR-BOX-Y3)
167	(FUNCALL SELF ':DISPLAY-CHAR-BOX)))
168	;; Now add in the grid points, unless the grid is too small.
169	(OR (< BOX-X-SIZE 6) (< BOX-Y-SIZE 6)
170	(DO ((I 0 (1+ I))) ((> I WINDOW-X-SIZE))
171	(DO ((J 0 (1+ J))) ((> J WINDOW-Y-SIZE))
172	(TV-ERASE-TRUNCATED MARGINS 2 2
173	(+ (CAR MARGINS) (* BOX-X-SIZE I) -1)
174	(+ (CADR MARGINS) (* BOX-Y-SIZE J) -1)
175	TV-ALU-XOR))))
176	;; Every box is now clear on the screen
177	(DO ((I 0 (1+ I))) ((= I WINDOW-X-SIZE))
178	(DO ((J 0 (1+ J))) ((= J WINDOW-Y-SIZE))
179	(AS-2 0 WINDOW-ARRAY I J)))
180	;; but every box must be checked for redisplay.
181	(SETQ MIN-CHANGED-X 0 MIN-CHANGED-Y 0
182	MAX-CHANGED-X (1- WINDOW-X-SIZE)
183	MAX-CHANGED-Y (1- WINDOW-Y-SIZE))))
184	;; Take advantage of knowing that there can't be any points in nonexistent part of plane.
185	(SETQ MIN-CHANGED-X (MAX MIN-CHANGED-X (- (FIRST (PLANE-ORIGIN CHARACTER-ARRAY))
186	WINDOW-X-POS)))
187	(SETQ MIN-CHANGED-Y (MAX MIN-CHANGED-Y (- (SECOND (PLANE-ORIGIN CHARACTER-ARRAY))
188	WINDOW-Y-POS)))
189	(SETQ MAX-CHANGED-X (MIN MAX-CHANGED-X (+ (FIRST (PLANE-ORIGIN CHARACTER-ARRAY))
190	(- WINDOW-X-POS)
191	(FIRST (ARRAY-DIMENSIONS CHARACTER-ARRAY)))))
192	(SETQ MAX-CHANGED-Y (MIN MAX-CHANGED-Y (+ (SECOND (PLANE-ORIGIN CHARACTER-ARRAY))
193	(- WINDOW-Y-POS)
194	(SECOND (ARRAY-DIMENSIONS CHARACTER-ARRAY)))))
195	;; Now, for each box which isn't already displayed in the right state,
196	;; update it.
197	(DO ((I MIN-CHANGED-X (1+ I))) ((> I MAX-CHANGED-X))
198	(DO ((J MIN-CHANGED-Y (1+ J))) ((> J MAX-CHANGED-Y))
199	(COND ((= (AR-2 WINDOW-ARRAY I J)
200	(SETQ TEM (PLANE-AR-N CHARACTER-ARRAY
201	(+ I WINDOW-X-POS)
202	(+ J WINDOW-Y-POS)))))
203	(T
204	(TV-ERASE BOX-X-SIZE BOX-Y-SIZE
205	(+ (* I BOX-X-SIZE) (CAR MARGINS))
206	(+ (* J BOX-Y-SIZE) (CADR MARGINS))
207	TV-ALU-XOR)
208	(AS-2 TEM WINDOW-ARRAY I J)))))
209	;; If character frame lines aren't in the right place,
210	;; clear them out and redraw them in the right place.
211	(COND ((OR (= BOX-X-SIZE 1) (= BOX-Y-SIZE 1)))
212	((AND (= DISPLAYED-CHAR-BOX-X1 CHAR-BOX-X1)
213	(= DISPLAYED-CHAR-BOX-X2 CHAR-BOX-X2)
214	(= DISPLAYED-CHAR-BOX-Y1 CHAR-BOX-Y1)
215	(= DISPLAYED-CHAR-BOX-Y2 CHAR-BOX-Y2)
216	(= DISPLAYED-CHAR-BOX-Y3 CHAR-BOX-Y3)))
217	(T
218	(FUNCALL SELF ':DISPLAY-CHAR-BOX)
219	(SETQ DISPLAYED-CHAR-BOX-X1 CHAR-BOX-X1)
220	(SETQ DISPLAYED-CHAR-BOX-X2 CHAR-BOX-X2)
221	(SETQ DISPLAYED-CHAR-BOX-Y1 CHAR-BOX-Y1)
222	(SETQ DISPLAYED-CHAR-BOX-Y2 CHAR-BOX-Y2)
223	(SETQ DISPLAYED-CHAR-BOX-Y3 CHAR-BOX-Y3)
224	(FUNCALL SELF ':DISPLAY-CHAR-BOX)))
225	;; Say that the range of boxes needing consideration for redisplay is now empty.
226	(SETQ MIN-CHANGED-X WINDOW-X-SIZE
227	MIN-CHANGED-Y WINDOW-Y-SIZE
228	MAX-CHANGED-X -1 MAX-CHANGED-Y -1)
229	;; If we are supposed to display the cursor, do so.
230	(COND (FED-CURSOR-ON
231	(TV-SET-BLINKER-CURSORPOS MOUSE-BLINKER
232	(+ (CAR MARGINS)
233	(* BOX-X-SIZE FED-CURSOR-X))
234	(+ (CADR MARGINS)
235	(* BOX-Y-SIZE FED-CURSOR-Y)))
236	(TV-SET-BLINKER-VISIBILITY MOUSE-BLINKER 'BLINK))))
237
238	;Subroutines of redisplaying a fed window.
239
240	;Either write or remove (xor) the five lines displaying the character box and baseline
241	;at lattice (not dot) positions specified by DISPLAYED-CHAR-BOX-X1, etc.
242	;This is a method so that the class variables will be locally special within,
243	;when that gets implemented.
244	(DEFMETHOD (FED-WINDOW-CLASS :DISPLAY-CHAR-BOX) (&AUX X1 Y1 X2 Y2 Y3)
245	(SETQ X1 (+ LEFT-MARGIN (* BOX-X-SIZE (- DISPLAYED-CHAR-BOX-X1 WINDOW-X-POS)) -1))
246	(SETQ Y1 (+ TOP-MARGIN (* BOX-Y-SIZE (- DISPLAYED-CHAR-BOX-Y1 WINDOW-Y-POS)) -1))
247	(SETQ X2 (+ LEFT-MARGIN (* BOX-X-SIZE (- DISPLAYED-CHAR-BOX-X2 WINDOW-X-POS)) -1))
248	(SETQ Y2 (+ TOP-MARGIN (* BOX-Y-SIZE (- DISPLAYED-CHAR-BOX-Y2 WINDOW-Y-POS)) -1))
249	(SETQ Y3 (+ TOP-MARGIN (* BOX-Y-SIZE (- DISPLAYED-CHAR-BOX-Y3 WINDOW-Y-POS)) -1))
250	(TV-ERASE-TRUNCATED MARGINS
251	2 (- Y2 Y1) X1 Y1
252	TV-ALU-XOR)
253	(COND ((= X1 X2))
254	(T
255	(TV-ERASE-TRUNCATED MARGINS
256	(- X2 X1) 2 (+ 2 X1) Y1
257	TV-ALU-XOR)
258	(TV-ERASE-TRUNCATED MARGINS
259	2 (- Y2 Y1) X2 (+ 2 Y1)
260	TV-ALU-XOR)
261	(TV-ERASE-TRUNCATED MARGINS
262	(- X2 X1) 2 X1 Y2
263	TV-ALU-XOR)
264	(OR (= Y2 Y3)
265	(TV-ERASE-TRUNCATED MARGINS
266	(- X2 -2 X1) 2 X1 Y3
267	TV-ALU-XOR)))))
268
269	;; Print a character on pc-ppr, assuming that pc-ppr is set up to the
270	;; font being edited. If the character is the one being edited,
271	;; the picture being edited is displayed.
272	(DEFUN FED-TYO (PC-PPR CH)
273	(LOCAL-DECLARE ((SPECIAL CHARACTER CHARACTER-ARRAY CHAR-BOX-X1 CHAR-BOX-X2 CHAR-BOX-Y1))
274	(COND ((AND CHARACTER (= CH CHARACTER))
275	(LET (;; Offset from horiz idx in plane to hpos of dot on screen.
276	(LEFT (+ (- (PC-PPR-CURRENT-X PC-PPR) CHAR-BOX-X1)
277	(FIRST (PLANE-ORIGIN CHARACTER-ARRAY))))
278	;; Offset from vert idx in plane to vpos of dot on screen.
279	(TOP (+ (- (PC-PPR-CURRENT-Y PC-PPR) CHAR-BOX-Y2)
280	(PC-PPR-BASELINE PC-PPR)
281	(SECOND (PLANE-ORIGIN CHARACTER-ARRAY))))
282	(PLANE-WIDTH (FIRST (ARRAY-DIMENSIONS CHARACTER-ARRAY)))
283	;; First vertical idx to print from in plane.
284	(PLANE-TOP (MAX 0 (- CHAR-BOX-Y1
285	(SECOND (PLANE-ORIGIN CHARACTER-ARRAY)))))
286	;; Last+1 vertical idx to print from in plane.
287	(PLANE-BOTTOM (MIN (SECOND (ARRAY-DIMENSIONS CHARACTER-ARRAY))
288	(- CHAR-BOX-Y3
289	(SECOND (PLANE-ORIGIN CHARACTER-ARRAY))))))
290	(DOTIMES (HPOS PLANE-WIDTH)
291	(DO ((VPOS PLANE-TOP (1+ VPOS)))
292	((>= VPOS PLANE-BOTTOM))
293	(OR (ZEROP (AR-2 CHARACTER-ARRAY HPOS VPOS))
294	(TV-ERASE 1 1 (+ HPOS LEFT) (+ VPOS TOP) TV-ALU-IOR))))
295	(SI:TV-MOVE-BITPOS PC-PPR (- CHAR-BOX-X2 CHAR-BOX-X1) 0)))
296	(T (TV-TYO PC-PPR CH)))))
297
298	;This function processes one command for a FED WINDOW.
299	;The "trivial" process associated with the FED window loops reading a
300	;character and handing it with a COMMAND command to the window,
301	;and that calls this function.
302	;Digits are accumulated as an argument for the next command.
303	;Not all commands use such an arg, but all non-digits flush any arg.
304	(DEFMETHOD (FED-WINDOW-CLASS :COMMAND) (COMMAND &AUX
305	(STANDARD-OUTPUT TYPEOUT-STREAM)
306	(STANDARD-INPUT TYPEOUT-STREAM))
307	(PROG ((ARG 1) ARG-P)
308	LOOP
309	(COND ((AND (>= COMMAND #/0) (<= COMMAND #/9))
310	(SETQ ARG (+ COMMAND -60 (* 10. (COND (ARG-P ARG) (T 0)))))
311	(SETQ ARG-P T)
312	(SETQ COMMAND (KBD-TYI))
313	(GO LOOP)))
314	(COND ((NOT (ZEROP (LDB %%KBD-MOUSE COMMAND)))
315	(SETQ FED-CURSOR-ON NIL)
316	(SELECTQ (LOGAND 77 COMMAND)
317	(0 (FED-MOUSE-MARK-SQUARES T))
318	(1 (FED-MOUSE-MOVE-CHAR-BOX))
319	(2 (FED-MOUSE-MARK-SQUARES NIL))
320	(OTHERWISE (TV-BEEP))))
321	(T (SELECTQ (CHAR-UPCASE (LDB %%KBD-CHAR COMMAND))
322	((#/ #/ #/ 13)
323	(FED-SHIFT-WINDOW COMMAND ARG-P ARG))
324	((#/[ #/] #/\ #// )
325	(FED-SHIFT-CURSOR COMMAND ARG-P ARG))
326	((0 #/ ) NIL) ;0 is used to cause a redisplay!
327	(#/H (FED-HOME))
328	(#/@ (FED-SCALE ARG-P ARG))
329	(#/F (FED-SPECIFY-FONT))
330	(#/C (FED-SPECIFY-CHARACTER COMMAND))
331	(#/M (FED-MERGE-CHARACTER COMMAND))
332	(#/S (FED-SAVE-CHARACTER))
333	(#/Z (FED-ERASE-REGION))
334	(#/E (FED-ERASE-ALL SELF))
335	(#/P (FED-SET-FONT-PARAMETERS))
336	(#/B (BREAK FED T))
337	(#/X (FED-SET-X ARG))
338	(#/Y (FED-SET-Y ARG))
339	(#/D (FED-DISPLAY-FONT))
340	(#/V (FED-SET-SAMPLE))
341	(#/ (FED-REFLECT-COMMAND ARG))
342	(15 ;Circle-plus
343	(FED-ROTATE-CHARACTER-RIGHT))
344	(#/R (FED-READ-KST-FILE FONT))
345	(#/W (FED-WRITE-KST-FILE FONT))
346	(#/. (COND (FED-CURSOR-ON
347	(FED-ALTER-SQUARE T FED-CURSOR-X FED-CURSOR-Y))
348	(T (TV-BEEP))))
349	(#/, (COND (FED-CURSOR-ON
350	(FED-ALTER-SQUARE NIL FED-CURSOR-X FED-CURSOR-Y))
351	(T (TV-BEEP))))
352	((#/? 206) (FED-HELP))
353	(214 (<- SELECTED-WINDOW ':CLEAN) ;Not self, but our frame instead.
354	(<- SELF ':CLOBBER-SCREEN))
355	(OTHERWISE (TV-BEEP)))))
356	(COND ((FUNCALL TYPEOUT-STREAM ':INCOMPLETE-P)
357	;; If dots or character box have changed, must reprint the label.
358	(AND (OR (> MAX-CHANGED-X -1)
359	CLOBBERED-P
360	(NOT (AND (= DISPLAYED-CHAR-BOX-X1 CHAR-BOX-X1)
361	(= DISPLAYED-CHAR-BOX-X2 CHAR-BOX-X2)
362	(= DISPLAYED-CHAR-BOX-Y1 CHAR-BOX-Y1)
363	(= DISPLAYED-CHAR-BOX-Y2 CHAR-BOX-Y2)
364	(= DISPLAYED-CHAR-BOX-Y3 CHAR-BOX-Y3))))
365	(<- SELF ':UPDATE-LABEL))
366	(LET ((NEXTCH (FUNCALL TYPEOUT-STREAM ':TYI)))
367	(FUNCALL TYPEOUT-STREAM ':MAKE-COMPLETE)
368	(COND ((NOT (= NEXTCH #/ ))
369	(FUNCALL SELF ':COMMAND NEXTCH))))))
370	(OR (KBD-CHAR-AVAILABLE) (<- SELF ':UPDATE))))
371
372	(DEFUN FED-SET-SAMPLE ()
373	(LOCAL-DECLARE ((SPECIAL FONT SAMPLE-STRING))
374	(FORMAT T "~%String to display in ~A: " FONT)
375	(SETQ SAMPLE-STRING (READLINE))
376	(FUNCALL STANDARD-OUTPUT ':MAKE-COMPLETE)
377	(AND (ZEROP (STRING-LENGTH SAMPLE-STRING)) (SETQ SAMPLE-STRING NIL))))
378
379	(DEFUN FED-HELP ()
380	(PRINC "Mouse-Left - set square Mouse-Right - clear square
381	Mouse-Middle - move edge of character box
382	F - select Font C - select Character
383	S - Store back edited character E - Erase all dots
384	Z - erase (Zap) connected region where the cursor is
385	R - Read KST file W - Write KST file
386	P - set font Parameters M - Merge in character
387	X - set X position of non-mouse cursor Y - set Y
388	- reflect character 015 - rotate character
389	[, ], \, // - move non-mouse cursor
390	. - set dot under non-mouse cursor , - clear it
391	, , 013, - move window H - move window to Home
392	@ - set scale (size of box) to numeric arg
393	D - Display entire font V - set sample string
394	[, ], \, //, , , 013, take numeric arg or meta bits
395	"))
396
397	;Alter the square which the mouse is on.
398	(DEFUN FED-ALTER-SQUARE (SETP &OPTIONAL X Y)
399	(LOCAL-DECLARE ((SPECIAL LEFT-MARGIN TOP-MARGIN CHARACTER-ARRAY
400	BOX-X-SIZE BOX-Y-SIZE WINDOW-X-POS WINDOW-Y-POS
401	MIN-CHANGED-X MIN-CHANGED-Y MAX-CHANGED-X MAX-CHANGED-Y))
402	(OR X (SETQ X (// (- MOUSE-X LEFT-MARGIN) BOX-X-SIZE)
403	Y (// (- MOUSE-Y TOP-MARGIN) BOX-Y-SIZE)))
404	(SETQ X (+ WINDOW-X-POS X) Y (+ WINDOW-Y-POS Y))
405	(PLANE-AS-N (COND (SETP 1) (T 0)) CHARACTER-ARRAY X Y)
406	(SETQ MIN-CHANGED-X (MIN MIN-CHANGED-X (- X WINDOW-X-POS)))
407	(SETQ MIN-CHANGED-Y (MIN MIN-CHANGED-Y (- Y WINDOW-Y-POS)))
408	(SETQ MAX-CHANGED-X (MAX MAX-CHANGED-X (- X WINDOW-X-POS)))
409	(SETQ MAX-CHANGED-Y (MAX MAX-CHANGED-Y (- Y WINDOW-Y-POS)))))
410
411	;Erase a region connected by vertical or horizontal (but not diagonal) adjacency.
412
413	(DEFUN FED-ERASE-REGION (&OPTIONAL X Y)
414	(LOCAL-DECLARE ((SPECIAL CHARACTER-ARRAY LEFT-MARGIN TOP-MARGIN BOX-X-SIZE BOX-Y-SIZE))
415	(OR X (SETQ X (// (- MOUSE-X LEFT-MARGIN) BOX-X-SIZE)
416	Y (// (- MOUSE-Y TOP-MARGIN) BOX-Y-SIZE)))
417	(SETQ X (+ WINDOW-X-POS X) Y (+ WINDOW-Y-POS Y))
418	(FED-ERASE-REGION-1 X Y)))
419
420	(DEFUN FED-ERASE-REGION-1 (X Y)
421	(LOCAL-DECLARE ((SPECIAL CHARACTER-ARRAY MIN-CHANGED-X MIN-CHANGED-Y
422	MAX-CHANGED-X MAX-CHANGED-Y))
423	(COND ((NOT (ZEROP (PLANE-AR-N CHARACTER-ARRAY X Y)))
424	(PLANE-AS-N 0 CHARACTER-ARRAY X Y)
425	(SETQ MIN-CHANGED-X (MIN MIN-CHANGED-X (- X WINDOW-X-POS)))
426	(SETQ MIN-CHANGED-Y (MIN MIN-CHANGED-Y (- Y WINDOW-Y-POS)))
427	(SETQ MAX-CHANGED-X (MAX MAX-CHANGED-X (- X WINDOW-X-POS)))
428	(SETQ MAX-CHANGED-Y (MAX MAX-CHANGED-Y (- Y WINDOW-Y-POS)))
429	(FED-ERASE-REGION-1 (1- X) Y)
430	(FED-ERASE-REGION-1 (1+ X) Y)
431	(FED-ERASE-REGION-1 X (1- Y))
432	(FED-ERASE-REGION-1 X (1+ Y))))))
433
434
435	(DEFUN FED-ERASE-ALL (IGNORE &OPTIONAL DONT-ASK-FLAG &AUX FD)
436	(LOCAL-DECLARE ((SPECIAL FONT CHARACTER-ARRAY TYPEOUT-STREAM
437	CHAR-BOX-X1 CHAR-BOX-X2 CHAR-BOX-X3
438	CHAR-BOX-Y1 CHAR-BOX-Y2))
439	(COND ((OR DONT-ASK-FLAG
440	(PROG1 (Y-OR-N-P "Erase all these dots? " TYPEOUT-STREAM)
441	(FUNCALL TYPEOUT-STREAM ':MAKE-COMPLETE)))
442	(SETQ CHARACTER-ARRAY (MAKE-PLANE ART-4B 2 0 10))
443	(SETQ CHAR-BOX-X1 0 CHAR-BOX-Y1 0
444	CHAR-BOX-X2 7 CHAR-BOX-Y2 11 CHAR-BOX-Y3 14)
445	(COND (FONT
446	(SETQ FD (FED-GET-FD FONT))
447	(SETQ CHAR-BOX-Y2 (FD-BASELINE FD)
448	CHAR-BOX-X2 (FD-SPACE-WIDTH FD)
449	CHAR-BOX-Y3 (FD-LINE-SPACING FD))))
450	(FED-HOME)))))
451
452	;; Display all of the characters of the font being edited, to show what they look like.
453	;; Above each one is the corresponding character of CPTFONT, so you
454	;; can see which character is which in non-alphabetic fonts.
455	(DEFUN FED-DISPLAY-FONT ()
456	(LOCAL-DECLARE ((SPECIAL FONT TYPEOUT-STREAM SI:SCREEN CHARACTER))
457	(COND ((AND (BOUNDP FONT) (SYMEVAL FONT))
458	(LET ((PP (FUNCALL TYPEOUT-STREAM ':PC-PPR))
459	(DF (SCREEN-DEFAULT-FONT SI:SCREEN)))
460	(FUNCALL TYPEOUT-STREAM ':CLEAR-SCREEN)
461	(FORMAT TYPEOUT-STREAM "Font ~A:~%" FONT)
462	(DO ((CH 0) (OCH)) ((= CH 128.))
463	(TV-CRLF PP)
464	(SETQ OCH CH)
465	;; Output one line of chars in the default font,
466	;; spaced so that they lie above the corresponding chars in the next line.
467	;; Stop at margin, or when we reach a char code that's a multiple of 32.
468	(DO ()
469	((> (+ (PC-PPR-CURRENT-X PP) (FED-CHAR-WIDTH (SYMEVAL FONT) CH))
470	(PC-PPR-RIGHT-MARGIN PP)))
471	(COND ((OR (AND (AR-1 (FED-GET-FD FONT) CH)
472	(NOT (ZEROP (FED-CHAR-WIDTH (SYMEVAL FONT) CH))))
473	(AND CHARACTER (= CH CHARACTER)))
474	(TV-TYO PP CH)
475	(SI:TV-MOVE-BITPOS PP
476	(- (MAX (FED-CHAR-WIDTH (SYMEVAL FONT) CH)
477	(FED-CHAR-WIDTH DF CH))
478	(FED-CHAR-WIDTH DF CH))
479	0)))
480	(SETQ CH (1+ CH))
481	(AND (ZEROP (\ CH 32.)) (RETURN)))
482	(TV-CRLF PP)
483	;; Clear out what we will move down over with TV-MOVE-BITPOS.
484	(TV-ERASE (- (PC-PPR-RIGHT-MARGIN PP) (PC-PPR-LEFT-MARGIN PP))
485	(FONT-CHAR-HEIGHT (SYMEVAL FONT))
486	(PC-PPR-LEFT-MARGIN PP)
487	(+ (PC-PPR-CURRENT-Y PP) (PC-PPR-LINE-HEIGHT PP))
488	TV-ALU-ANDCA)
489	;; Now output the corresponding chars in the font being edited.
490	;; First leave space so it won't overlap if font is taller.
491	(SI:TV-MOVE-BITPOS PP 0 (- (FONT-BASELINE (SYMEVAL FONT))
492	(PC-PPR-BASELINE PP)))
493	(TV-SET-FONT PP (SYMEVAL FONT))
494	(DO ()
495	((> (+ (PC-PPR-CURRENT-X PP) (FED-CHAR-WIDTH (SYMEVAL FONT) OCH))
496	(PC-PPR-RIGHT-MARGIN PP)))
497	(COND ((OR (AND (AR-1 (FED-GET-FD FONT) OCH)
498	(NOT (ZEROP (FED-CHAR-WIDTH (SYMEVAL FONT) OCH))))
499	(EQ CH CHARACTER))
500	(FED-TYO PP OCH)
501	(SI:TV-MOVE-BITPOS PP
502	(- (MAX (FED-CHAR-WIDTH (SYMEVAL FONT) OCH)
503	(FED-CHAR-WIDTH DF OCH))
504	(FED-CHAR-WIDTH (SYMEVAL FONT) OCH))
505	0)))
506	(SETQ OCH (1+ OCH))
507	(AND (ZEROP (\ OCH 32.)) (RETURN)))
508	(TV-SET-FONT PP DF)
509	;; Move down, leaving space for font's descenders.
510	(SI:TV-MOVE-BITPOS PP 0 (- (FONT-CHAR-HEIGHT (SYMEVAL FONT))
511	(- (FONT-BASELINE (SYMEVAL FONT))
512	(PC-PPR-BASELINE PP)))))
513	(SETF (PC-PPR-CURRENT-X PP) (PC-PPR-LEFT-MARGIN PP))))
514	(T (TV-BEEP)))))
515
516	;; Return the width of a given char in a given font.
517	(DEFUN FED-CHAR-WIDTH (FONT CHAR)
518	(LET ((CWT (FONT-CHAR-WIDTH-TABLE FONT)))
519	(COND (CWT (AR-1 CWT CHAR))
520	(T (FONT-CHAR-WIDTH FONT)))))
521
522	;Set the position of the cursor, which is used as an alternate to the mouse
523	;for complementing squares. Also say that the cursor ought to be displayed.
524	(DEFUN FED-SET-X (XPOS)
525	(COND ((OR (< XPOS 0) (>= XPOS WINDOW-X-SIZE))
526	(TV-BEEP)))
527	(SETQ FED-CURSOR-X (MAX 0 (MIN (1- WINDOW-X-SIZE) XPOS))))
528
529	(DEFUN FED-SET-Y (YPOS)
530	(COND ((OR (< YPOS 0) (>= YPOS WINDOW-Y-SIZE))
531	(TV-BEEP)))
532	(SETQ FED-CURSOR-Y (MAX 0 (MIN (1- WINDOW-Y-SIZE) YPOS))))
533
534	(DEFUN FED-SHIFT-CURSOR (COMMAND ARG-P DISTANCE &AUX DX DY ARROW)
535	(OR ARG-P (SETQ DISTANCE (LSH 1 (LDB %%KBD-CONTROL-META COMMAND))))
536	(SETQ ARROW (LDB %%KBD-CHAR COMMAND))
537	(SETQ DX (* DISTANCE (OR (CADR (ASSQ ARROW '((#/[ -1) (#/] 1)))) 0)))
538	(SETQ DY (* DISTANCE (OR (CADR (ASSQ ARROW '((#/\ -1) (#// 1)))) 0)))
539	(FED-SET-X (+ FED-CURSOR-X DX))
540	(FED-SET-Y (+ FED-CURSOR-Y DY))
541	(SETQ FED-CURSOR-ON T))
542
543	(DEFUN FED-SHIFT-WINDOW (COMMAND ARG-P DISTANCE &AUX DX DY ARROW)
544	(OR ARG-P (SETQ DISTANCE (LSH 1 (LDB %%KBD-CONTROL-META COMMAND))))
545	(SETQ ARROW (LDB %%KBD-CHAR COMMAND))
546	(SETQ DX (* DISTANCE (OR (CADR (ASSQ ARROW '((#/ 1) (#/ -1)))) 0)))
547	(SETQ DY (* DISTANCE (OR (CADR (ASSQ ARROW '((13 1) (#/ -1)))) 0)))
548	(FED-SET-WINDOW-POS (+ WINDOW-X-POS DX)
549	(+ WINDOW-Y-POS DY)))
550
551	;Set the box-size (in both X and Y) of the fed-window to SCALE.
552	;We try to keep the center of the window in the center.
553	(DEFUN FED-SCALE (ARG-P SCALE)
554	(LOCAL-DECLARE ((SPECIAL LEFT-MARGIN TOP-MARGIN RIGHT-MARGIN BOTTOM-MARGIN
555	BOX-X-SIZE BOX-Y-SIZE))
556	(PROG ()
557	(OR ARG-P (SETQ SCALE 14))
558	(OR (AND (> SCALE 0)
559	(< SCALE (// (- RIGHT-MARGIN LEFT-MARGIN) 2))
560	(< SCALE (// (- BOTTOM-MARGIN TOP-MARGIN) 2)))
561	(RETURN (TV-BEEP)))
562	(SETQ BOX-X-SIZE SCALE BOX-Y-SIZE SCALE)
563	(<- SELF ':WINDOW-UPDATE))))
564
565	;Return the window of the fed window to home position.
566	(DEFUN FED-HOME ()
567	(FED-SET-WINDOW-POS CHAR-BOX-X1 CHAR-BOX-Y1)
568	(SETQ FED-CURSOR-X 0 FED-CURSOR-Y 0))
569
570	;Set the window position of the fed window.
571	(DEFUN FED-SET-WINDOW-POS (X Y)
572	(SETQ FED-CURSOR-X (MAX 0 (MIN WINDOW-X-SIZE (- FED-CURSOR-X (- X WINDOW-X-POS)))))
573	(SETQ FED-CURSOR-Y (MAX 0 (MIN WINDOW-Y-SIZE (- FED-CURSOR-Y (- Y WINDOW-Y-POS)))))
574	(SETQ WINDOW-X-POS X WINDOW-Y-POS Y)
575	(<- SELF ':CLOBBER-SCREEN))
576
577	;Read the name of a font and select it.
578	(DEFUN FED-SPECIFY-FONT (&AUX NEW-FONT TEM)
579	(LOCAL-DECLARE ((SPECIAL FONT TYPEOUT-STREAM CHARACTER))
580	(FUNCALL TYPEOUT-STREAM ':FRESH-LINE)
581	(PRINC "Font: ")
582	(SETQ TEM (READLINE))
583	(COND ((ZEROP (STRING-LENGTH TEM))
584	(TV-BEEP))
585	(T
586	(SETQ NEW-FONT (INTERN (STRING-TRIM '(#\SP) TEM) "FONTS"))
587	(COND ((OR (BOUNDP NEW-FONT)
588	(Y-OR-N-P "This font does not exist. Create it? "
589	TYPEOUT-STREAM))
590	;; Creating a font: make sure we have an FD for it before FED-SET-FONT-PARAMETERS is called.
591	(FED-GET-FD (SETQ FONT NEW-FONT))
592	(SETQ CHARACTER NIL)))))
593	(FUNCALL TYPEOUT-STREAM ':HOME-CURSOR)
594	(COND ((AND NEW-FONT (BOUNDP NEW-FONT))
595	(FED-DISPLAY-FONT)
596	(<- SELF ':WINDOW-UPDATE)))))
597
598	;Get the font descriptor corresponding to the specified font.
599	;If we haven't made one yet, make one, and remember it on FED-FD-ALIST.
600	;If the font is a nonexistent one (being created), make a default empty FD.
601	(DEFUN FED-GET-FD (FONT &AUX FD)
602	(COND ((BOUNDP FONT)
603	(FONT-NAME-FONT-DESCRIPTOR FONT))
604	(T (SETQ FD (MAKE-FONT-DESCRIPTOR FD-LINE-SPACING 14
605	FD-BASELINE 11
606	FD-BLINKER-HEIGHT 14
607	FD-BLINKER-WIDTH 7
608	FD-SPACE-WIDTH 7))
609	(AS-1 (MAKE-CHAR-DESCRIPTOR
610	MAKE-ARRAY (NIL ART-4B '(11 7))
611	CD-CHAR-WIDTH 7
612	CD-CHAR-LEFT-KERN 0)
613	FD #/ )
614	(PUTPROP FONT FD 'FONT-DESCRIPTOR)
615	(SET FONT NIL)
616	(PUTPROP FONT NIL 'FONT-DESCRIBED)
617	FD)))
618
619	;Set various per-font (as opposed to per-character) parameters of the current font.
620	;This command is necessary because editing one character is not allowed to
621	;change anything pertaining to the whole font.
622	(DEFUN FED-SET-FONT-PARAMETERS (&AUX FD (IBASE 10.) TEM FNT)
623	(LOCAL-DECLARE ((SPECIAL FONT))
624	;; If we have no FD format array for this font, make one.
625	(SETQ FD (FED-GET-FD FONT))
626	(SETQ FNT (AND (BOUNDP FONT) (SYMEVAL FONT)))
627	(FORMAT T "~%Font line spacing (now ~D) = " (FD-LINE-SPACING FD))
628	(SETQ TEM (READLINE))
629	(OR (ZEROP (STRING-LENGTH TEM))
630	(NOT (NUMBERP (SETQ TEM (READ-FROM-STRING TEM))))
631	(PROGN (AND FNT (SETF (FONT-CHAR-HEIGHT FNT) TEM))
632	(SETF (FD-LINE-SPACING FD) TEM)))
633	(FORMAT T "Font baseline (now ~D) = " (FD-BASELINE FD))
634	(SETQ TEM (READLINE))
635	(OR (ZEROP (STRING-LENGTH TEM))
636	(NOT (NUMBERP (SETQ TEM (READ-FROM-STRING TEM))))
637	(PROGN (AND FNT (SETF (FONT-BASELINE FNT) TEM))
638	(SETF (FD-BASELINE FD) TEM)))
639	(FORMAT T "Font blinker height (now ~D) = " (FD-BLINKER-HEIGHT FD))
640	(SETQ TEM (READLINE))
641	(OR (ZEROP (STRING-LENGTH TEM))
642	(NOT (NUMBERP (SETQ TEM (READ-FROM-STRING TEM))))
643	(PROGN (AND FNT (SETF (FONT-BLINKER-HEIGHT FNT) TEM))
644	(SETF (FD-BLINKER-HEIGHT FD) TEM)))
645	(FORMAT T "Font blinker width (now ~D) = " (FD-BLINKER-WIDTH FD))
646	(SETQ TEM (READLINE))
647	(OR (ZEROP (STRING-LENGTH TEM))
648	(NOT (NUMBERP (SETQ TEM (READ-FROM-STRING TEM))))
649	(PROGN (AND FNT (SETF (FONT-BLINKER-WIDTH FNT) TEM))
650	(SETF (FD-BLINKER-WIDTH FD) TEM)))
651	(SETQ CHAR-BOX-Y1 (- CHAR-BOX-Y2 (FD-BASELINE FD))
652	CHAR-BOX-Y3 (+ CHAR-BOX-Y1 (FD-LINE-SPACING FD)))
653	(FUNCALL STANDARD-OUTPUT ':MAKE-COMPLETE)
654	(<- SELF ':WINDOW-UPDATE)))
655
656	(DEFUN FED-READ-KST-FILE (FONT &AUX FD FILENAME)
657	(SETQ FD (READ-KST-INTO-FONT-DESCRIPTOR
658	(SETQ FILENAME (FED-READ-KST-FILENAME FONT)) FONT))
659	(PUTPROP FONT FILENAME 'KST-FILE)
660	(FONT-NAME-SET-FONT-AND-DESCRIPTOR FONT FD))
661
662	(DEFUN FED-WRITE-KST-FILE (FONT &AUX FILENAME)
663	(WRITE-FONT-INTO-KST FONT (SETQ FILENAME (FED-READ-KST-FILENAME FONT)))
664	(PUTPROP FONT FILENAME 'KST-FILE))
665
666	(DEFUN FED-READ-KST-FILENAME (FONT &AUX TEM TEM1 SPEC)
667	(SETQ TEM (STRING-APPEND "LMFONT;"
668	(COND ((< (STRING-LENGTH FONT) 7) (STRING FONT))
669	(T (SUBSTRING FONT 0 6)))
670	" KST"))
671	(AND (SETQ TEM1 (GET FONT 'KST-FILE))
672	(SETQ TEM (SI:FILE-MERGE-PATHNAMES TEM1 TEM)))
673	(PRINC "KST file name: ")
674	(SETQ SPEC (READLINE))
675	(FUNCALL STANDARD-OUTPUT ':MAKE-COMPLETE)
676	(SI:FILE-MERGE-PATHNAMES SPEC TEM))
677
678	;C => Read the name of a character and select it in the current font.
679	;C-C => Read name of character and select it, keeping data in fed-buffer
680	;instead of gobbling the current definition of the new character.
681	;Typing a control or mouse character as the arg to the C command aborts it.
682	(DEFUN FED-SPECIFY-CHARACTER (COMMAND-CHAR &AUX CH)
683	(LOCAL-DECLARE ((SPECIAL FONT CHARACTER))
684	(PRINC "Character: ")
685	(SETQ CH (FUNCALL STANDARD-INPUT ':TYI))
686	(COND ((= CH (LOGAND 177 CH))
687	(SETQ CHARACTER CH)
688	(FORMAT T "~:C~%" CHARACTER)
689	(FUNCALL STANDARD-OUTPUT ':MAKE-COMPLETE)
690	(AND (ZEROP (LDB %%KBD-CONTROL COMMAND-CHAR))
691	(FED-GOBBLE-CHARACTER FONT CHARACTER)))
692	(T (TV-BEEP)))))
693
694	;Copy the data from character CHAR in font FONT
695	;into the fed window to be edited.
696	(DEFUN FED-GOBBLE-CHARACTER (FONT CHAR &AUX FD CD)
697	(PROG ()
698	;; If we have no FD format array for this font, make one.
699	(SETQ FD (FED-GET-FD FONT))
700	;; Get the character descriptor for the desired character out of the FD.
701	(OR (AND (SETQ CD (AR-1 FD CHAR))
702	(NOT (ZEROP (ARRAY-DIMENSION-N 2 CD))))
703	(RETURN (FED-ERASE-ALL SELF T)))
704	(SETQ CHARACTER-ARRAY (MAKE-PLANE ART-4B 2 0 10))
705	;; Put sides of character frame at right place, according to char width and left kern.
706	(SETQ CHAR-BOX-X1 (CD-CHAR-LEFT-KERN CD)
707	CHAR-BOX-X2 (+ (CD-CHAR-WIDTH CD) (CD-CHAR-LEFT-KERN CD)))
708	;; Put top of character at top of font line, and bottom at baseline
709	;; so that descenders go below the "bottom".
710	(SETQ CHAR-BOX-Y1 0
711	CHAR-BOX-Y2 (FD-BASELINE FD)
712	CHAR-BOX-Y3 (FD-LINE-SPACING FD))
713	;; Now XWIDTH and YWIDTH get the size of the character's raster,
714	;; and copy the data into the plane in CHARACTER-ARRAY.
715	(LET ((XWIDTH (SECOND (ARRAY-DIMENSIONS CD)))
716	(YWIDTH (FIRST (ARRAY-DIMENSIONS CD))))
717	(DO I 0 (1+ I) (= I XWIDTH)
718	(DO J 0 (1+ J) (= J YWIDTH)
719	(PLANE-AS-N (AR-2 CD J I) CHARACTER-ARRAY I J))))
720	;; Now put the window at home position, causing a full redisplay.
721	(FED-HOME)))
722
723	;M => Read the name of a character and merge it into the data already there.
724	;Typing a control or mouse character as the arg to the C command aborts it.
725	(DEFUN FED-MERGE-CHARACTER (IGNORE &AUX CH)
726	(LOCAL-DECLARE ((SPECIAL FONT))
727	(PRINC "Character to merge: ")
728	(SETQ CH (FUNCALL STANDARD-INPUT ':TYI))
729	(COND ((= CH (LOGAND 177 CH))
730	(FORMAT T "~:C~%" CH)
731	(FUNCALL STANDARD-OUTPUT ':MAKE-COMPLETE)
732	(FED-MERGE-CHARACTER-1 FONT CH)))))
733
734	(DEFUN FED-MERGE-CHARACTER-1 (FONT CHAR &AUX FD CD)
735	(PROG ((XOFFS (+ FED-CURSOR-X WINDOW-X-POS)) (YOFFS (+ FED-CURSOR-Y WINDOW-Y-POS)))
736	;; If we have no FD format array for this font, make one.
737	(SETQ FD (FED-GET-FD FONT))
738	;; Get the character descriptor for the desired character out of the FD.
739	(OR (AND (SETQ CD (AR-1 FD CHAR))
740	(NOT (ZEROP (ARRAY-DIMENSION-N 2 CD))))
741	(RETURN NIL))
742	(SETQ XOFFS (+ (- XOFFS (CD-CHAR-LEFT-KERN CD)) CHAR-BOX-X1))
743	;; Now XWIDTH and YWIDTH get the size of the character's raster,
744	;; and copy the data into the plane in CHARACTER-ARRAY.
745	(LET ((XEND (+ XOFFS (SECOND (ARRAY-DIMENSIONS CD))))
746	(YEND (+ YOFFS (FIRST (ARRAY-DIMENSIONS CD)))))
747	(DO I XOFFS (1+ I) (= I XEND)
748	(DO J YOFFS (1+ J) (= J YEND)
749	(PLANE-AS-N (LOGIOR (PLANE-AR-N CHARACTER-ARRAY I J)
750	(AR-2 CD (- J YOFFS) (- I XOFFS)))
751	CHARACTER-ARRAY I J)))
752	(SETQ MIN-CHANGED-X (MIN MIN-CHANGED-X XOFFS))
753	(SETQ MAX-CHANGED-X (MAX MAX-CHANGED-X XEND))
754	(SETQ MIN-CHANGED-Y (MIN MIN-CHANGED-Y YOFFS))
755	(SETQ MAX-CHANGED-Y (MAX MAX-CHANGED-Y YEND)))))
756
757	(DEFUN FED-REFLECT-COMMAND (IGNORE)
758	(PROG (AXIS)
759	(PRINC "Line to reflect in (X, Y, XY or X-Y): ")
760	(SETQ AXIS (STRING-UPCASE (READLINE)))
761	(OR (MEMBER AXIS '("X" "Y" "XY" "X-Y"))
762	(RETURN (TV-BEEP)))
763	(FUNCALL STANDARD-OUTPUT ':MAKE-COMPLETE)
764	(FED-REFLECT-CHARACTER AXIS)))
765
766	(DEFUN FED-REFLECT-CHARACTER (AXIS &AUX NEW-CHAR ORIGINS EXTENTS)
767	(SETQ NEW-CHAR (MAKE-PLANE ART-4B 2 0 10))
768	(SETQ ORIGINS (PLANE-ORIGIN CHARACTER-ARRAY))
769	(SETQ EXTENTS (ARRAY-DIMENSIONS CHARACTER-ARRAY))
770	(DO ((HPOS (FIRST ORIGINS) (1+ HPOS))
771	(HEND (+ (FIRST ORIGINS) (FIRST EXTENTS))))
772	(( HPOS HEND))
773	(DO ((VPOS (SECOND ORIGINS) (1+ VPOS))
774	(VEND (+ (SECOND ORIGINS) (SECOND EXTENTS))))
775	(( VPOS VEND))
776	(LET ((NEWVPOS VPOS) (NEWHPOS HPOS))
777	(COND ((EQUAL AXIS "X")
778	(SETQ NEWVPOS
779	(- (+ CHAR-BOX-Y1 CHAR-BOX-Y3 -1) VPOS)))
780	((EQUAL AXIS "Y")
781	(SETQ NEWHPOS
782	(- (+ CHAR-BOX-X1 CHAR-BOX-X2 -1) HPOS)))
783	((EQUAL AXIS "X-Y")
784	(SETQ NEWHPOS (+ CHAR-BOX-X1 (- VPOS CHAR-BOX-Y1))
785	NEWVPOS (+ CHAR-BOX-Y1 (- HPOS CHAR-BOX-X1))))
786	((EQUAL AXIS "XY")
787	;; Invert in the origin, then reflect in X-Y.
788	(SETQ NEWVPOS
789	(- (+ CHAR-BOX-Y1 CHAR-BOX-Y3 -1) VPOS))
790	(SETQ NEWHPOS
791	(- (+ CHAR-BOX-X1 CHAR-BOX-X2 -1) HPOS))
792	(PSETQ NEWHPOS (+ CHAR-BOX-X1 (- NEWVPOS CHAR-BOX-Y1))
793	NEWVPOS (+ CHAR-BOX-Y1 (- NEWHPOS CHAR-BOX-X1)))))
794	(PLANE-AS-N (PLANE-AR-N CHARACTER-ARRAY HPOS VPOS)
795	NEW-CHAR NEWHPOS NEWVPOS))))
796	(SETQ CHARACTER-ARRAY NEW-CHAR)
797	(<- SELF ':CLOBBER-SCREEN))
798
799	(DEFUN FED-ROTATE-CHARACTER-RIGHT (&AUX NEW-CHAR ORIGINS EXTENTS)
800	(SETQ NEW-CHAR (MAKE-PLANE ART-4B 2 0 10))
801	(SETQ ORIGINS (PLANE-ORIGIN CHARACTER-ARRAY))
802	(SETQ EXTENTS (ARRAY-DIMENSIONS CHARACTER-ARRAY))
803	(DO ((HPOS (FIRST ORIGINS) (1+ HPOS))
804	(HEND (+ (FIRST ORIGINS) (FIRST EXTENTS))))
805	(( HPOS HEND))
806	(DO ((VPOS (SECOND ORIGINS) (1+ VPOS))
807	(VEND (+ (SECOND ORIGINS) (SECOND EXTENTS))))
808	(( VPOS VEND))
809	(LET ((NEWVPOS (+ CHAR-BOX-Y1 (- HPOS CHAR-BOX-X1)))
810	(NEWHPOS (- CHAR-BOX-X2 1 (- VPOS CHAR-BOX-Y1))))
811	(PLANE-AS-N (PLANE-AR-N CHARACTER-ARRAY HPOS VPOS)
812	NEW-CHAR NEWHPOS NEWVPOS))))
813	(SETQ CHARACTER-ARRAY NEW-CHAR)
814	(<- SELF ':CLOBBER-SCREEN))
815
816	(DEFUN FED-REGENERATE-FONT ()
817	(LOCAL-DECLARE ((SPECIAL FONT CHARACTER))
818	(AND CHARACTER (FED-STORE-CD FONT CHARACTER NIL))
819	(FONT-NAME-SET-FONT-AND-DESCRIPTOR FONT (FED-GET-FD FONT))))
820
821	;Save the editing that has been done on the current character.
822	(DEFUN FED-SAVE-CHARACTER ()
823	(LOCAL-DECLARE ((SPECIAL FONT CHARACTER))
824	(COND (CHARACTER
825	(FED-STORE-CD FONT CHARACTER)
826	(<- SELF ':UPDATE-LABEL))
827	(T (TV-BEEP)))))
828
829	;Store the current FED data buffer into character CHAR of the font descriptor
830	;array for font FONT.
831	(DEFUN FED-STORE-CD (FONT CHAR &OPTIONAL (UPDATE-FONT-FLAG T)
832	&AUX FD CD YSTART XSTART YWIDTH XWIDTH KERN
833	PLANE-X1 PLANE-Y1 PLANE-WIDTH PLANE-HEIGHT)
834	(PROG FED-STORE-CD ()
835	;; Find the FD format array for this font.
836	(SETQ FD (FED-GET-FD FONT))
837	;; Warn if char box now displayed is incompatible with the font.
838	(COND ((OR ( (- CHAR-BOX-Y2 CHAR-BOX-Y1) (FD-BASELINE FD))
839	( (- CHAR-BOX-Y3 CHAR-BOX-Y1) (FD-LINE-SPACING FD)))
840	(OR (Y-OR-N-P "/
841	Character height and baseline are incompatible with font.
842	If actually stored, the character will be aligned by the top of its box.
843	Proceed to store anyway?"
844	TYPEOUT-STREAM)
845	(RETURN-FROM FED-STORE-CD NIL))))
846	;; What are the regions of the fed data plane which actually are stored?
847	(SETQ PLANE-X1 (FIRST (PLANE-ORIGIN CHARACTER-ARRAY)))
848	(SETQ PLANE-Y1 (SECOND (PLANE-ORIGIN CHARACTER-ARRAY)))
849	(SETQ PLANE-WIDTH (FIRST (ARRAY-DIMENSIONS CHARACTER-ARRAY)))
850	(SETQ PLANE-HEIGHT (SECOND (ARRAY-DIMENSIONS CHARACTER-ARRAY)))
851	;; Figure out what portion of the plane holding the fed data is really nonzero.
852	;; XSTART and YSTART get the indices in CHARACTER-ARRAY (as an array, not as a plane!)
853	;; of what is going to go into the upper left corner of the CD.
854	;; XWIDTH and YWIDTH get the dimensions which the CD will need to hold all nonzero data.
855	;; XSTART is determined by the leftmost nonzero data, and its distance from
856	;; CHAR-BOX-X1 determines the left kern. YSTART has to correspond to CHAR-BOX-Y1
857	;; because that is not a per-character parameter.
858	(SETQ YSTART (MAX 0 (- CHAR-BOX-Y1 PLANE-Y1)) YWIDTH 0)
859	(DO J YSTART (1+ J) (= J PLANE-HEIGHT)
860	(DO I 0 (1+ I) (= I PLANE-WIDTH)
861	(OR (ZEROP (AR-2 CHARACTER-ARRAY I J))
862	(SETQ YWIDTH (1+ (- J YSTART))))))
863	(SETQ XSTART NIL XWIDTH 0)
864	(DO I 0 (1+ I) (= I PLANE-WIDTH)
865	(DO J YSTART (1+ J) (= J PLANE-HEIGHT)
866	(COND ((NOT (ZEROP (AR-2 CHARACTER-ARRAY I J)))
867	(OR XSTART (SETQ XSTART I))
868	(SETQ XWIDTH (1+ (- I XSTART)))))))
869	;; Make sure XSTART isn't NIL, and neither width is zero.
870	(COND ((NULL XSTART)
871	(SETQ XSTART 0 XWIDTH 1)))
872	(AND (ZEROP YWIDTH) (SETQ YWIDTH 1))
873	;; Warn about dots to be lost above YSTART.
874	(PROG FOO ()
875	(DO I 0 (1+ I) (= I PLANE-WIDTH)
876	(DO J 0 (1+ J) (= J YSTART)
877	(OR (ZEROP (AR-2 CHARACTER-ARRAY I J))
878	(COND ((Y-OR-N-P "/
879	Dots above character top will be lost. Store anyway? "
880	TYPEOUT-STREAM)
881	(RETURN-FROM FOO NIL))
882	(T (RETURN-FROM FED-STORE-CD NIL)))))))
883	(SETQ KERN (- CHAR-BOX-X1 (+ XSTART PLANE-X1)))
884	;; Copy the data in the FED buffer into a CD
885	(SETQ CD (MAKE-CHAR-DESCRIPTOR
886	MAKE-ARRAY (NIL ART-4B (LIST YWIDTH XWIDTH))
887	CD-CHAR-WIDTH (- CHAR-BOX-X2 CHAR-BOX-X1)
888	CD-CHAR-LEFT-KERN KERN))
889	(DO I 0 (1+ I) (= I XWIDTH)
890	(DO J 0 (1+ J) (= J YWIDTH)
891	(AS-2 (AR-2 CHARACTER-ARRAY (+ I XSTART) (+ J YSTART))
892	CD J I)))
893	(COND (UPDATE-FONT-FLAG
894	;; Use the CD just made to update the font itself,or make a new font.
895	(FONT-NAME-STORE-CD FONT CD CHAR))
896	(T
897	;; Store the CD in the FD.
898	(AS-1 CD FD CHAR)
899	(AND (= CHAR #/ )
900	(SETF (FD-SPACE-WIDTH FD) (CD-CHAR-WIDTH CD)))))))
901
902	(DEFMETHOD (FED-WINDOW-CLASS :MOUSE-BUTTONS) (BD X Y)
903	;; First, see if the mouse is where we have typed stuff out.
904	;; If so, it has no effect (since we use no typeout items)
905	;; unless it is getting the system menu.
906	(OR (FUNCALL TYPEOUT-STREAM ':MOUSE-BUTTONS BD X Y)
907	;; Not in typeout => decode double clicks
908	;; and pass along as an input character to the fed process
909	;; unless it's getting the system menu.
910	(LET ((BUTTONS (MOUSE-BUTTON-ENCODE BD)))
911	(COND ((= BUTTONS 2012)
912	(<- (<- SELF ':POP-UP-MENU) ':CHOOSE))
913	(T (<- SI:PROCESS ':FORCE-KBD-INPUT (DPB 1 %%KBD-MOUSE BUTTONS)))))))
914
915	;Set or clear the square under the mouse, and then as long as you hold the button down
916	;whenever the mouse is moved to a new square that square is set or clear also.
917	(DEFUN FED-MOUSE-MARK-SQUARES (SETP &AUX X Y OLD-M-X OLD-M-Y)
918	(LOCAL-DECLARE ((SPECIAL LEFT-MARGIN TOP-MARGIN BOX-X-SIZE BOX-Y-SIZE
919	WINDOW-X-SIZE WINDOW-Y-SIZE FED-CURSOR-X FED-CURSOR-Y))
920	(DO ((FIRST T NIL))
921	((AND (NOT FIRST) (ZEROP (SI:MOUSE-BUTTONS))))
922	(OR FIRST (MOUSE-WAIT OLD-M-X OLD-M-Y))
923	(SETQ OLD-M-X MOUSE-X OLD-M-Y MOUSE-Y)
924	(SETQ X (// (- MOUSE-X LEFT-MARGIN) BOX-X-SIZE))
925	(SETQ Y (// (- MOUSE-Y TOP-MARGIN) BOX-Y-SIZE))
926	(OR (AND (LESSP -1 X WINDOW-X-SIZE) (LESSP -1 Y WINDOW-Y-SIZE))
927	(RETURN NIL))
928	(OR (AND (NOT FIRST)
929	(= X FED-CURSOR-X) (= Y FED-CURSOR-Y))
930	(PROGN (FED-ALTER-SQUARE SETP X Y)
931	(<- SELF ':UPDATE)))
932	(SETQ FED-CURSOR-X X FED-CURSOR-Y Y))))
933
934	;Push this button when the mouse is near an edge or corner of the character box,
935	;and then as long as you hold the button down you are moving that corner.
936	(DEFUN FED-MOUSE-MOVE-CHAR-BOX (&AUX X-POS-NAME Y-POS-NAME)
937	(LOCAL-DECLARE ((SPECIAL LEFT-MARGIN TOP-MARGIN
938	WINDOW-X-POS WINDOW-Y-POS
939	BOX-X-SIZE BOX-Y-SIZE
940	CHAR-BOX-X1 CHAR-BOX-X2
941	CHAR-BOX-Y1 CHAR-BOX-Y2 CHAR-BOX-Y3
942	WINDOW-X-SIZE WINDOW-Y-SIZE))
943	(PROG ()
944	;; Decide which corner or edge of the character box we will move
945	;; (or maybe we aren't in range of any of them).
946	(COND ((< (ABS (- MOUSE-X (* (- CHAR-BOX-X1 WINDOW-X-POS)
947	BOX-X-SIZE) LEFT-MARGIN))
948	(// BOX-X-SIZE 2))
949	(SETQ X-POS-NAME 'CHAR-BOX-X1))
950	((< (ABS (- MOUSE-X (* (- CHAR-BOX-X2 WINDOW-X-POS)
951	BOX-X-SIZE) LEFT-MARGIN))
952	(// BOX-X-SIZE 2))
953	(SETQ X-POS-NAME 'CHAR-BOX-X2)))
954	(COND ((< (ABS (- MOUSE-Y (* (- CHAR-BOX-Y1 WINDOW-Y-POS)
955	BOX-Y-SIZE) TOP-MARGIN))
956	(// BOX-Y-SIZE 2))
957	(SETQ Y-POS-NAME 'CHAR-BOX-Y1))
958	((< (ABS (- MOUSE-Y (* (- CHAR-BOX-Y2 WINDOW-Y-POS)
959	BOX-Y-SIZE) TOP-MARGIN))
960	(// BOX-Y-SIZE 2))
961	(SETQ Y-POS-NAME 'CHAR-BOX-Y2))
962	((< (ABS (- MOUSE-Y (* (- CHAR-BOX-Y3 WINDOW-Y-POS)
963	BOX-Y-SIZE) TOP-MARGIN))
964	(// BOX-Y-SIZE 2))
965	(SETQ Y-POS-NAME 'CHAR-BOX-Y3)))
966	;; If not in range to move any edge, beep.
967	(OR X-POS-NAME Y-POS-NAME (RETURN (TV-BEEP)))
968	(DO ((NOT-FIRST NIL T) (X) (Y) (OX) (OY) (OLD-M-X) (OLD-M-Y))
969	((AND NOT-FIRST (ZEROP MOUSE-LAST-BUTTONS)))
970	(AND NOT-FIRST (MOUSE-WAIT OLD-M-X OLD-M-Y))
971	(OR (SI:WINDOW-OWNS-MOUSE-P SELF)
972	(RETURN NIL))
973	(SETQ OLD-M-X MOUSE-X OLD-M-Y MOUSE-Y)
974	(SETQ X (// (+ (// BOX-X-SIZE 2) (- MOUSE-X LEFT-MARGIN)) BOX-X-SIZE))
975	(SETQ Y (// (+ (// BOX-Y-SIZE 2) (- MOUSE-Y TOP-MARGIN)) BOX-Y-SIZE))
976	;; Exit if mouse is outside of FED grid area.
977	(OR (AND (LESSP -1 X (1+ WINDOW-X-SIZE)) (LESSP -1 Y (1+ WINDOW-Y-SIZE)))
978	(RETURN NIL))
979	(SETQ X (+ X WINDOW-X-POS) Y (+ Y WINDOW-Y-POS))
980	;; Try moving the edges, remember where they used to be.
981	(SETQ OX (SYMEVAL X-POS-NAME) OY (SYMEVAL Y-POS-NAME))
982	(AND Y-POS-NAME (SET Y-POS-NAME Y))
983	(AND X-POS-NAME (SET X-POS-NAME X))
984	;; Don't move an edge past or up to its opposite edge.
985	(OR (AND ( CHAR-BOX-X1 CHAR-BOX-X2)
986	(< CHAR-BOX-Y1 CHAR-BOX-Y2)
987	( CHAR-BOX-Y2 CHAR-BOX-Y3))
988	(PROGN (SET X-POS-NAME OX)
989	(SET Y-POS-NAME OY)
990	(TV-BEEP)))
991	;; If we are really moving an edge to a new place, redisplay.
992	(OR (AND (OR (NOT X-POS-NAME)
993	(= (SYMEVAL X-POS-NAME) OX))
994	(OR (NOT Y-POS-NAME)
995	(= (SYMEVAL Y-POS-NAME) OY)))
996	(<- SELF ':UPDATE))))))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format