root/trunk/lisp/lmio1/xfed.lisp @ 252

Revision 252, 45.7 KB (checked in by rjs, 3 years 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
381Mouse-Middle - move edge of character box
382F - select Font   C - select Character
383S - Store back edited character   E - Erase all dots
384Z - erase (Zap) connected region where the cursor is
385R - Read KST file   W - Write KST file
386P - set font Parameters   M - Merge in character
387X - 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
393D - 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 "/
841Character height and baseline are incompatible with font.
842If actually stored, the character will be aligned by the top of its box.
843Proceed 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 "/
879Dots 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.