1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
|
;;; edit.ss
;;; Copyright (C) 1987 R. Kent Dybvig
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;; This file contains an implementation of a simple interactive structure
;;; editor for Scheme. The editor is invoked with an expression as it's
;;; single argument. It prompts for, reads, and processes editor commands.
;;; The editor commands recognized are those documented in the Texas
;;; Instruments' PC Scheme manual. They are summarized below.
;;; Command syntax Action
;;;
;;; q or <eof> Quit the editor, returning edited expression.
;;;
;;; p Write the current expression.
;;;
;;; ? Write to level 2, length 10.
;;;
;;; pp Pretty print the current expression.
;;;
;;; ?? Pretty print to level 2, length 10.
;;;
;;; <pos> Move to subexpression of current expression
;;; <pos> = 0 is the current expression, <pos> > 0
;;; is the numbered subexpression (1 for first, 2
;;; for second, ...), <pos> < 0 is the numbered
;;; subexpression from the right (-1 for last, -2
;;; for second to last, ...), and <pos> = * is the
;;; "last cdr" of the current expression. If <pos>
;;; is not 0, the current expression must be a list.
;;;
;;; b Move back to parent expression.
;;;
;;; t Move to top-level expression.
;;;
;;; pr Move to expression on the left (previous).
;;;
;;; n Move to expression on the right (next).
;;;
;;; (f <obj>) Find <obj> within or to the right of the current
;;; expression using equal?.
;;;
;;; f or (f) Find <obj> of last (f <obj>) command.
;;;
;;; (d <pos>) Delete the expression at position <pos>.
;;;
;;; (r <pos> <obj>) Replace the expression at position <pos> with
;;; <obj>.
;;;
;;; (s <obj1> <obj2>) Replace all occurrences of <obj1> by <obj2>
;;; within the current expression.
;;;
;;; (dp <pos>) Remove parens from around expression at position
;;; <pos>.
;;;
;;; (ap <pos1> <pos2>) Insert parens around expressions from position
;;; <pos1> through <pos2> (inclusive). If <pos1> is
;;; 0 or *, <pos2> is ignored and may be omitted.
;;;
;;; (ib <pos> <obj>) Insert <obj> before expression at position <pos>.
;;;
;;; (ia <pos> <obj>) Insert <obj> after expression at position <pos>.
;;;
;;; (sb <pos> <obj>) Splice <obj> before expression at position <pos>.
;;;
;;; (sa <pos> <obj>) Splice <obj> after expression at position <pos>.
;;; Possible exercises/enhancements:
;;;
;;; 1) Implement an infinite undo ("u") command in the editor. This
;;; can be done by creating an "inverse" function for each operation
;;; that causes a side-effect, i.e, a closure that "remembers" the
;;; list cells involved and knows how to put them back the way they
;;; were. An undo (u) variable could then be added to the editor's
;;; main loop; it would be bound to a list containing the set of
;;; registers at the point of the last side-effect (similarly to the
;;; "back" (b) variable) and the undo function for the side-effect.
;;;
;;; 2) Implement an infinite redo ("r") command in the editor. This
;;; can be done by remembering the undo functions and registers for
;;; the undo's since the last non-undo command.
;;;
;;; 3) Handle circular structures better in the editor. Specifically,
;;; modify the find ("f") command so that it always terminates, and
;;; devise a method for printing circular structures with the "p"
;;; and "pp" commands. Cure the bug mentioned in the overview of
;;; the code given later in the file.
;;;
;;; 4) Add a help ("h") command to the editor. This could be as simple
;;; as listing the available commands.
;;;
;;; 5) Make the editor "extensible" via user-defined macros or editor
;;; commands written in Scheme.
;;;
;;; 6) Modify the editor to provide more descriptive error messages that
;;; diagnose the problem and attempt to give some help. For example,
;;; if the editor receives "(r 1)" it might respond with:
;;; "Two few arguments:
;;; Type (r pos exp) to replace the expression at position pos
;;; with the expression exp."
;;; This should be implemented in conjunction with the help command.
;;; Should it be possible to disable such verbose error messages?
;;; Implementation:
;;;
;;; The main editor loop and many of the help functions operate on a
;;; set of "registers". These registers are described below:
;;;
;;; s The current find object. s is initially #f, and is bound to a
;;; pair containing the find object when the first (f <obj>) command
;;; is seen. The identical f and (f) commands use the saved object.
;;;
;;; p The parent of the current expression. This is initially a list
;;; of one element, the argument to edit. It is updated by various
;;; movement commands.
;;;
;;; i The index of the current expression in the parent (p). This is
;;; initially 0. It is updated by various movement commands.
;;;
;;; b The "back" chain; actually a list containing the registers p, i
;;; and b for the parent of the current expression. It is initially
;;; (). It is updated by various movement commands.
;;;
;;; Bugs:
;;;
;;; When editing a circular structure, it is possible for the editor to
;;; get lost. That is, when the parent node of the current expression
;;; is changed by a command operating on a subexpression of the current
;;; expression, the index for the current expression may become incorrect.
;;; This can result in abnormal termination of the editor. It would be
;;; fairly simple to check for this (in list-ref) and reset the editor,
;;; and it may be possible to use a different set of registers to avoid
;;; the problem altogether.
(define edit #f) ; assigned within the let expression below
(let ()
(define cmdeq?
;; used to check command syntax
(lambda (cmd pat)
(and (pair? cmd)
(eq? (car cmd) (car pat))
(let okargs? ([cmd (cdr cmd)] [pat (cdr pat)])
(if (null? pat)
(null? cmd)
(and (not (null? cmd))
(okargs? (cdr cmd) (cdr pat))))))))
(define find
;; find expression within or to right of current expression
(lambda (s0 p0 i0 b0)
(define check
(lambda (p i b)
(if (equal? (list-ref p i) (car s0))
(wrlev s0 p i b)
(continue p i b))))
(define continue
(lambda (p i b)
(let ([e (list-ref p i)])
(if (atom? e)
(let next ([p p] [i i] [b b])
(let ([n (maxref p)])
(if (or (not n) (< i n))
(check p (+ i 1) b)
(if (null? b)
(search-failed s0 p0 i0 b0)
(apply next b)))))
(check e 0 (list p i b))))))
(continue p0 i0 b0)))
(define maxref
;; use "hare and tortoise" algorithm to check for circular lists.
;; return maximum reference index (zero-based) for a list x. return
;; -1 for atoms and #f for circular lists.
(lambda (x)
(let f ([hare x] [tortoise x] [n -1])
(cond
[(atom? hare) n]
[(atom? (cdr hare)) (+ n 1)]
[(eq? (cdr hare) tortoise) #f]
[else (f (cddr hare) (cdr tortoise) (+ n 2))]))))
(define move
;; move to subexpression specified by x and pass current state to k.
(lambda (x s p i b k)
(cond
[(eqv? x 0) (k s p i b)]
[(eq? x '*)
(let ([m (maxref (list-ref p i))])
(if m
(k s (list-ref p i) '* (list p i b))
(invalid-movement s p i b)))]
[(> x 0)
(let ([m (maxref (list-ref p i))] [x (- x 1)])
(if (or (not m) (>= m x))
(k s (list-ref p i) x (list p i b))
(invalid-movement s p i b)))]
[else
(let ([m (maxref (list-ref p i))] [x (- -1 x)])
(if (and m (>= m x))
(let ([x (- m x)])
(k s (list-ref p i) x (list p i b)))
(invalid-movement s p i b)))])))
(define proper-list?
;; return #t if x is a proper list.
(lambda (x)
(and (maxref x)
(or (null? x) (null? (cdr (last-pair x)))))))
(define list-ref
;; reference list ls element i. i may be *, in which case return
;; the last pair of ls.
(lambda (ls i)
(if (eq? i '*)
(cdr (last-pair ls))
(car (list-tail ls i)))))
(define list-set!
;; change element i of ls to x.
(lambda (ls i x)
(if (eq? i '*)
(set-cdr! (last-pair ls) x)
(set-car! (list-tail ls i) x))))
(define list-cut!
;; remove element i from ls.
(lambda (ls i)
(let ([a (cons '() ls)])
(set-cdr! (list-tail a i) (list-tail a (+ i 2)))
(cdr a))))
(define list-splice!
;; insert ls2 into ls1 in place of element i.
(lambda (ls1 i ls2)
(let ([a (list-tail ls1 i)])
(unless (null? (cdr a))
(set-cdr! (last-pair ls2) (cdr a)))
(set-car! a (car ls2))
(set-cdr! a (cdr ls2)))
ls1))
(define list-ap*!
;; place parens from element i through last pair of ls.
(lambda (ls i)
(let ([a (list-tail ls i)])
(let ([c (cons (car a) (cdr a))])
(set-car! a c)
(set-cdr! a '())))
ls))
(define list-ap!
;; place parens from element i0 through element i1.
(lambda (ls i0 i1)
(let ([a (list-tail ls i0)] [b (list-tail ls i1)])
(let ([c (cons (car a) (cdr a))])
(set-car! a c)
(if (eq? a b)
(set-cdr! c '())
(begin (set-cdr! a (cdr b))
(set-cdr! b '())))))
ls))
(define wrlev
;; write current expression to level 2, length 10 and continue.
(lambda (s p i b)
(parameterize ([print-level 2] [print-length 10])
(printf "~s~%" (list-ref p i)))
(edit-loop s p i b)))
(define wr
;; write current expression and continue.
(lambda (s p i b)
(printf "~s~%" (list-ref p i))
(edit-loop s p i b)))
(define pplev
;; pretty print current expression to level 2, length 10 and continue.
(lambda (s p i b)
(parameterize ([print-level 2] [print-length 10])
(pretty-print (list-ref p i)))
(edit-loop s p i b)))
(define pp
;; pretty print current expression and continue.
(lambda (s p i b)
(pretty-print (list-ref p i))
(edit-loop s p i b)))
(define not-a-proper-list
;; complain and continue.
(lambda (s p i b)
(printf "structure is not a proper list~%")
(edit-loop s p i b)))
(define cannot-dp-zero
;; complain and continue.
(lambda (s p i b)
(printf "cannot remove parens from current expression~%")
(edit-loop s p i b)))
(define pos2-before-pos1
;; complain and continue.
(lambda (s p i b)
(printf "second position before first~%")
(edit-loop s p i b)))
(define invalid-movement
;; complain and continue.
(lambda (s p i b)
(printf "no such position~%")
(edit-loop s p i b)))
(define unrecognized-command-syntax
;; complain and continue.
(lambda (s p i b)
(printf "unrecognized command syntax~%")
(edit-loop s p i b)))
(define search-failed
;; complain and continue.
(lambda (s p i b)
(printf "search failed~%")
(edit-loop s p i b)))
(define no-previous-find
;; complain and continue.
(lambda (s p i b)
(printf "no previous find command~%")
(edit-loop s p i b)))
(define edit-loop
;; read command and process.
(lambda (s p i b)
(let ([x (begin (printf "edit> ") (read))])
(cond
[(eof-object? x) (newline)] ; need newline after eof
[(eq? x 'q)] ; do not need newline after q
[(eq? x 'p) (wr s p i b)]
[(eq? x '?) (wrlev s p i b)]
[(eq? x 'pp) (pp s p i b)]
[(eq? x '??) (pplev s p i b)]
[(or (integer? x) (eqv? x '*)) (move x s p i b wrlev)]
[(eq? x 't)
(let f ([p p] [i i] [b b])
(if (null? b)
(wrlev s p i b)
(apply f b)))]
[(eq? x 'b)
(if (pair? b)
(apply wrlev s b)
(invalid-movement s p i b))]
[(eq? x 'n)
(let ([n (maxref p)])
(if (and (not (eq? i '*)) (or (not n) (< i n)))
(wrlev s p (+ i 1) b)
(invalid-movement s p i b)))]
[(eq? x 'pr)
(if (and (not (eq? i '*)) (> i 0))
(wrlev s p (- i 1) b)
(invalid-movement s p i b))]
[(or (eq? x 'f) (cmdeq? x '(f)))
(if s
(find s p i b)
(no-previous-find s p i b))]
[(cmdeq? x '(f x))
(find (cons (cadr x) '()) p i b)]
[(and (cmdeq? x '(r x x))
(or (integer? (cadr x)) (eq? (cadr x) '*)))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-set! p0 i0 (caddr x))))
(wrlev s p i b)]
[(cmdeq? x '(s x x))
(list-set! p i (subst! (caddr x) (cadr x) (list-ref p i)))
(wrlev s p i b)]
[(and (cmdeq? x '(d x)) (eqv? (cadr x) 0))
(list-set! p i '())
(wrlev s p i b)]
[(and (cmdeq? x '(d x)) (eq? (cadr x) '*))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(set-cdr! (last-pair p0) '())
(wrlev s p i b)))]
[(and (cmdeq? x '(d x)) (integer? (cadr x)))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-set! p i (list-cut! p0 i0))
(wrlev s p i b)))]
[(and (cmdeq? x '(dp x)) (eqv? (cadr x) 0))
(let ([e (list-ref p i)])
(if (and (pair? e) (null? (cdr e)))
(begin (list-set! p i (car e))
(wrlev s p i b))
(cannot-dp-zero s p i b)))]
[(and (cmdeq? x '(dp x))
(and (integer? (cadr x)) (not (= (cadr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(let ([e0 (list-ref p0 i0)])
(if (or (proper-list? e0)
(and (pair? e0) (eqv? i0 (maxref p0))))
(begin (if (null? e0)
(list-set! p i (list-cut! p0 i0))
(list-splice! p0 i0 e0))
(wrlev s p i b))
(not-a-proper-list s p i b)))))]
[(and (or (cmdeq? x '(ap x)) (cmdeq? x '(ap x x)))
(memv (cadr x) '(0 *)))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-set! p0 i0 (list (list-ref p0 i0)))
(wrlev s p i b)))]
[(and (cmdeq? x '(ap x x))
(and (integer? (cadr x)) (not (= (cadr x) 0)))
(eq? (caddr x) '*))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-ap*! p0 i0)
(wrlev s p i b)))]
[(and (cmdeq? x '(ap x x))
(and (integer? (cadr x)) (not (= (cadr x) 0)))
(and (integer? (caddr x)) (not (= (caddr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(move (caddr x) s p i b
(lambda (s1 p1 i1 b1)
(if (>= i1 i0)
(begin (list-ap! p0 i0 i1)
(wrlev s p i b))
(pos2-before-pos1 s p i b))))))]
[(and (cmdeq? x '(ib x x))
(and (integer? (cadr x)) (not (= (cadr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-splice! p0 i0 (list (caddr x) (list-ref p0 i0)))
(wrlev s p i b)))]
[(and (cmdeq? x '(ia x x))
(and (integer? (cadr x)) (not (= (cadr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-splice! p0 i0 (list (list-ref p0 i0) (caddr x)))
(wrlev s p i b)))]
[(and (cmdeq? x '(sb x x))
(and (integer? (cadr x)) (not (= (cadr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-splice! p0 i0
(append (caddr x) (list (list-ref p0 i0))))
(wrlev s p i b)))]
[(and (cmdeq? x '(sa x x))
(and (integer? (cadr x)) (not (= (cadr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-splice! p0 i0 (cons (list-ref p0 i0) (caddr x)))
(wrlev s p i b)))]
[else
(unrecognized-command-syntax s p i b)]))))
(set! edit
;; set up keyboard interrupt handler and go.
(lambda (e)
(let ([p (cons e '())])
(let ([k (call/cc (lambda (k) k))]) ; return here on interrupt
(parameterize ([keyboard-interrupt-handler
(lambda ()
(printf "reset~%")
(k k))])
(wrlev #f p 0 '())
(car p)))))))
|
