Changed license to CC0
[fifth.git] / tools / editor.bas
1 ' Disk file editor for FIFTH
2 ' Svjatoslav Agejenko: n0@hot.ee
3
4 DECLARE SUB fdisp ()
5 DECLARE SUB fopen (a$)
6 DECLARE SUB ask (a$, b$)
7 DECLARE SUB addk (a$)
8 DECLARE SUB llen (a%, l%)
9 DECLARE SUB save (a%)
10 DECLARE SUB disp ()
11 DEFINT A-Z
12
13 DECLARE SUB load (a)
14 DECLARE SUB start ()
15 DECLARE SUB edit ()
16 DIM SHARED buf(0 TO 31, 0 TO 31)
17 DIM SHARED obuf(0 TO 31, 0 TO 31)
18 DIM SHARED byte AS STRING * 1
19 DIM SHARED font(0 TO 20, 0 TO 255)
20 DIM SHARED eb
21 DIM SHARED keys(0 TO 10000)
22 DIM SHARED keyl, keyc
23 DIM SHARED curx, cury
24 DIM SHARED fil$(0 TO 1000)
25 DIM SHARED fline, froll
26 DIM SHARED filename$
27
28 start
29
30 OPEN "..\..\disk.raw" FOR BINARY AS #1
31
32 edit
33
34 CLOSE #1
35 SYSTEM
36
37 SUB addk (a$)
38 keys(keyl) = ASC(a$)
39 keyl = keyl + 1
40 IF keyl > 10000 THEN keyl = 0
41 END SUB
42
43 SUB ask (a$, b$)
44 LOCATE 16, 34
45 PRINT SPACE$(46)
46 LOCATE 16, 34
47 COLOR 15
48 PRINT a$
49 COLOR 10
50 LOCATE 16, 34 + LEN(a$)
51 INPUT "", b$
52 LOCATE 16, 34
53 PRINT SPACE$(46)
54 COLOR 15
55 END SUB
56
57 SUB disp
58
59 FOR y = 0 TO 31
60 FOR x = 0 TO 31
61 c = buf(x, y)
62 IF c <> obuf(x, y) THEN
63   PUT (x * 8, y * 8), font(0, c), PSET
64   obuf(x, y) = c
65 END IF
66 NEXT x
67 NEXT y
68
69 x1 = curx * 8
70 y1 = cury * 8
71 FOR y = y1 TO y1 + 7
72 FOR x = x1 TO x1 + 7
73 c = POINT(x, y)
74 IF c = 15 THEN c = 0 ELSE c = 10
75 PSET (x, y), c
76 NEXT x
77 NEXT y
78 obuf(curx, cury) = -1
79
80 LOCATE 1, 77
81 PRINT "   "
82 LOCATE 1, 76
83 PRINT buf(curx, cury)
84 END SUB
85
86 SUB edit
87 fdisp
88 leb = -1
89 m = 0
90 1
91 IF eb <> leb THEN
92   IF m = 1 THEN
93     save leb
94     m = 0
95   END IF
96   load eb
97   leb = eb
98   LOCATE 1, 60
99   PRINT "page:"; eb; " "
100 END IF
101 disp
102 2
103 a$ = INKEY$
104 bk = 0
105 IF a$ = "" THEN
106   IF keyl = keyc THEN GOTO 2
107   a$ = CHR$(keys(keyc))
108   keyc = keyc + 1
109   IF keyc > 10000 THEN keyc = 0
110   bk = 1
111 END IF
112
113 IF a$ = CHR$(0) + CHR$(73) THEN eb = eb - 1
114 IF a$ = CHR$(0) + CHR$(81) THEN eb = eb + 1
115 IF a$ = CHR$(27) THEN GOTO 4
116 IF a$ = CHR$(0) + "M" THEN curx = curx + 1
117 IF a$ = CHR$(0) + "K" THEN curx = curx - 1
118 IF a$ = CHR$(0) + "P" THEN cury = cury + 1
119 IF a$ = CHR$(0) + "H" THEN cury = cury - 1
120 IF a$ = CHR$(0) + "=" THEN ask "page: ", b$: eb = VAL(b$)
121 IF a$ = CHR$(0) + "?" THEN ask "file: ", b$: fopen b$
122 IF a$ = CHR$(0) + CHR$(132) THEN fline = fline - 1: fdisp
123 IF a$ = CHR$(0) + CHR$(118) THEN fline = fline + 1: fdisp
124 IF a$ = CHR$(0) + CHR$(64) THEN         ' F6
125   d = 0
126   FOR b = 1 TO LEN(fil$(fline))
127     c$ = RIGHT$(LEFT$(fil$(fline), b), 1)
128     IF c$ = CHR$(9) THEN c$ = " "
129     IF c$ = " " OR c$ = CHR$(255) THEN d = d + 1 ELSE d = 0
130     IF d < 2 THEN addk c$
131   NEXT b
132 END IF
133
134 IF a$ = CHR$(0) + ";" THEN
135   FOR y = 0 TO 31
136     FOR x = 0 TO 31
137       buf(x, y) = 255
138     NEXT x
139   NEXT y
140   m = 1
141 END IF
142
143 IF a$ = CHR$(0) + CHR$(83) THEN
144   FOR b = curx TO 30
145     buf(b, cury) = buf(b + 1, cury)
146   NEXT b
147   buf(31, cury) = 255
148   m = 1
149 END IF
150
151 IF (a$ = CHR$(13)) AND (bk = 0) THEN
152 a$ = ""
153 IF cury < 31 THEN
154   FOR a = 31 TO cury + 2 STEP -1
155     FOR b = 0 TO 31
156       buf(b, a) = buf(b, a - 1)
157     NEXT b
158   NEXT a
159   FOR a = 0 TO 31
160     buf(a, cury + 1) = 255
161   NEXT a
162   FOR a = curx TO 31
163     SWAP buf(a, cury), buf(a - curx, cury + 1)
164   NEXT a
165   m = 1
166   cury = cury + 1
167   curx = 0
168 END IF
169 END IF
170
171 IF LEN(a$) = 1 THEN
172   IF ASC(a$) = 32 THEN a$ = CHR$(255)
173   IF (a$ = CHR$(8)) AND (bk = 0) THEN
174     a$ = ""
175     IF curx > 0 THEN
176       FOR b = curx - 1 TO 30
177         buf(b, cury) = buf(b + 1, cury)
178       NEXT b
179       buf(31, cury) = 255
180       curx = curx - 1
181       m = 1
182     ELSE
183       IF cury > 0 THEN
184         llen cury - 1, a
185         curx = a
186         FOR b = a TO 31
187           buf(b, cury - 1) = buf(b - a, cury)
188         NEXT b
189         FOR a = cury TO 30
190           FOR b = 0 TO 31
191             buf(b, a) = buf(b, a + 1)
192           NEXT b
193         NEXT a
194         FOR b = 0 TO 31
195           buf(b, 31) = 255
196         NEXT b
197         m = 1
198         cury = cury - 1
199       END IF
200     END IF
201   END IF
202 END IF
203
204 IF a$ = CHR$(0) + "<" THEN
205 ask "decimal number:", b$
206 b$ = HEX$(VAL(b$))
207 FOR a = 1 TO LEN(b$)
208   c = ASC(RIGHT$(LEFT$(b$, a), 1))
209   IF (c <= 57) AND (c >= 48) THEN d$ = CHR$(c - 48): addk d$
210   IF (c <= 70) AND (c >= 65) THEN d$ = CHR$(c - 55): addk d$
211 NEXT a
212 END IF
213
214 IF a$ = CHR$(0) + CHR$(65) THEN
215 FOR a = 999 TO fline STEP -1
216   fil$(a + 1) = fil$(a)
217 NEXT a
218 fil$(fline) = ""
219 FOR a = curx TO 31
220   fil$(fline) = fil$(fline) + CHR$(buf(a, cury))
221 NEXT a
222 fdisp
223 END IF
224
225 IF a$ = CHR$(0) + ">" THEN
226 ask "ascii code:", b$
227 a$ = CHR$(VAL(b$))
228 END IF
229
230 IF LEN(a$) = 1 THEN
231     FOR b = 31 TO curx + 1 STEP -1
232       buf(b, cury) = buf(b - 1, cury)
233     NEXT b
234     buf(curx, cury) = ASC(a$)
235     curx = curx + 1
236     m = 1
237 END IF
238
239 IF eb < 0 THEN eb = 0
240 IF curx < 0 THEN curx = 0
241 IF cury < 0 THEN cury = 0
242 IF curx > 31 THEN curx = 31
243 IF cury > 31 THEN cury = 31
244 GOTO 1
245 4
246
247 END SUB
248
249 SUB fdisp
250 IF fline < 0 THEN fline = 0
251 IF fline > 1000 THEN fline = 1000
252 IF fline - froll > 10 THEN froll = fline - 10
253 IF fline - froll < 0 THEN froll = fline
254 IF froll < 0 THEN froll = 0
255
256 LOCATE 17, 1
257 PRINT SPACE$(80)
258 LOCATE 17, 1
259 PRINT "file: " + filename$
260
261 LOCATE 17, 20
262 PRINT "line:"; fline
263
264 FOR a = 0 TO 10
265   LOCATE a + 18, 1
266   IF a + froll = fline THEN
267     COLOR 10
268     IF fil$(a + froll) = SPACE$(LEN(fil$(a + froll))) THEN
269       FOR b = 1 TO 80
270         PRINT CHR$(219);
271       NEXT b
272       GOTO 7
273     END IF
274   ELSE
275     COLOR 12
276   END IF
277   PRINT fil$(a + froll) + SPACE$(80 - LEN(fil$(a + froll)));
278 7
279 NEXT a
280
281 COLOR 15
282 END SUB
283
284 SUB fopen (a$)
285 filename$ = a$
286 FOR b = 0 TO 1000
287   fil$(b) = ""
288 NEXT b
289
290 b = 0
291 OPEN filename$ FOR INPUT AS #2
292 5
293 IF EOF(2) <> 0 THEN GOTO 6
294 LINE INPUT #2, c$
295 fil$(b) = c$
296 b = b + 1
297 IF b > 1000 THEN GOTO 6
298 GOTO 5
299 6
300 CLOSE #2
301
302 fline = 0
303 froll = 0
304 fdisp
305 END SUB
306
307 SUB llen (a, l)
308 FOR b = 31 TO 0 STEP -1
309 IF buf(b, a) <> 255 THEN l = b + 1: GOTO 3
310 NEXT b
311 l = 0
312 3
313 END SUB
314
315 SUB load (a)
316 DIM c AS LONG
317 DIM a1 AS LONG
318 a1 = a
319 c = a1 * 1024
320 SEEK #1, c + 1
321 FOR y = 0 TO 31
322   FOR x = 0 TO 31
323     GET #1, , byte
324     buf(x, y) = ASC(byte)
325   NEXT x
326 NEXT y
327 END SUB
328
329 SUB save (a)
330 DIM c AS LONG
331 DIM a1 AS LONG
332 a1 = a
333 c = a1 * 1024
334 SEEK #1, c + 1
335 FOR y = 0 TO 31
336   FOR x = 0 TO 31
337     byte = CHR$(buf(x, y))
338     PUT #1, , byte
339   NEXT x
340 NEXT y
341 SOUND 5000, .1
342 END SUB
343
344 SUB start
345 SCREEN 12
346 COLOR 15
347 eb = 7
348
349 filename$ = "<noname>"
350 fline = 0
351 froll = 0
352 keyl = 0
353 keyc = 0
354
355 OPEN "font.dat" FOR BINARY AS #1
356 FOR f = 0 TO 255
357 FOR y = 0 TO 7
358 GET #1, , byte
359 n = ASC(byte)
360 b = 128
361 FOR a = 0 TO 7
362 IF n >= b THEN n = n - b: c = 15 ELSE c = 0
363 b = b / 2
364 PSET (a, y), c
365 NEXT a
366 NEXT y
367 GET (0, 0)-(7, 7), font(0, f)
368 NEXT f
369 CLOSE #1
370
371 FOR y = 0 TO 31
372 FOR x = 0 TO 31
373 obuf(x, y) = -1
374 NEXT x
375 NEXT y
376
377 LOCATE 1, 34
378 PRINT "F1 - clear page"
379 LOCATE 2, 34
380 PRINT "F2 - enter decimal number"
381 LOCATE 3, 34
382 PRINT "F3 - goto page"
383 LOCATE 4, 34
384 PRINT "F4 - enter character code"
385 LOCATE 5, 34
386 PRINT "F5 - load source file"
387 LOCATE 6, 34
388 PRINT "F6 - insert line from source file"
389 LOCATE 7, 34
390 PRINT "F7 - copy line to source file"
391
392 LOCATE 1, 71
393 PRINT "code:"
394 END SUB
395