← Back to branch summary

~registry/texmacs/trunk

« back to all changes in this revision

Viewing changes to src/TeXmacs/progs/dynamic/fold-edit.scm

  • Committer: mgubi
  • Date: 2009-06-04 15:13:41 UTC
  • Revision ID: svn-v4:64cb5145-927a-446d-8aed-2fb7b4773692:trunk:2717
Support for X11 TeXmacs.app on Mac

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/TeXmacs/progs/dynamic/fold-edit.scm
 
1
 
 
2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
3
;;
 
4
;; MODULE      : fold-edit.scm
 
5
;; DESCRIPTION : routines for switching, folding and layers
 
6
;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
 
7
;;
 
8
;; This software falls under the GNU general public license version 3 or later.
 
9
;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
 
10
;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
 
11
;;
 
12
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
13
 
 
14
(texmacs-module (dynamic fold-edit)
 
15
  (:use (utils library tree)
 
16
        (utils library cursor)
 
17
        (dynamic dynamic-drd)))
 
18
 
 
19
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
20
;; Abstract stuff for fold tags and switches
 
21
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
22
 
 
23
(tm-define (dynamic-context? t)
 
24
  (or (toggle-tag? (tree-label t))
 
25
      (switch-tag? (tree-label t))))
 
26
 
 
27
(tm-define (dynamic-first) (noop))
 
28
(tm-define (dynamic-previous) (noop))
 
29
(tm-define (dynamic-next) (noop))
 
30
(tm-define (dynamic-last) (noop))
 
31
 
 
32
(tm-define (structured-left)
 
33
  (:context dynamic-context?)
 
34
  (dynamic-previous))
 
35
 
 
36
(tm-define (structured-right)
 
37
  (:context dynamic-context?)
 
38
  (dynamic-next))
 
39
 
 
40
(tm-define (structured-up)
 
41
  (:context dynamic-context?)
 
42
  (dynamic-previous))
 
43
 
 
44
(tm-define (structured-down)
 
45
  (:context dynamic-context?)
 
46
  (dynamic-next))
 
47
 
 
48
(tm-define (structured-first)
 
49
  (:context dynamic-context?)
 
50
  (dynamic-first))
 
51
 
 
52
(tm-define (structured-last)
 
53
  (:context dynamic-context?)
 
54
  (dynamic-last))
 
55
 
 
56
(tm-define (structured-top)
 
57
  (:context dynamic-context?)
 
58
  (dynamic-first))
 
59
 
 
60
(tm-define (structured-bottom)
 
61
  (:context dynamic-context?)
 
62
  (dynamic-last))
 
63
 
 
64
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
65
;; Operations on toggle trees
 
66
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
67
 
 
68
(tm-define (toggle-toggle t)
 
69
  (:synopsis "Toggle a fold/unfold")
 
70
  (tree-assign-node! t (ahash-ref toggle-table (tree-label t))))
 
71
 
 
72
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
73
;; Folding
 
74
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
75
 
 
76
(tm-define (toggle-context? t)
 
77
  (toggle-tag? (tree-label t)))
 
78
 
 
79
(tm-define (toggle-first-context? t)
 
80
  (toggle-first-tag? (tree-label t)))
 
81
 
 
82
(tm-define (toggle-second-context? t)
 
83
  (toggle-second-tag? (tree-label t)))
 
84
 
 
85
(tm-define (make-toggle tag)
 
86
  (:type (-> void))
 
87
  (:synopsis "Insert a 'fold' environment")
 
88
  (insert-go-to `(,tag (document "") (document "")) (list 0 0)))
 
89
 
 
90
(tm-define (fold)
 
91
  (:type (-> void))
 
92
  (:synopsis "Fold at the current cursor position")
 
93
  (with-innermost t toggle-second-context?
 
94
    (toggle-toggle t)
 
95
    (tree-go-to t 0 :start)))
 
96
 
 
97
(tm-define (unfold)
 
98
  (:type (-> void))
 
99
  (:synopsis "Unfold at the current cursor position")
 
100
  (with-innermost t toggle-first-context?
 
101
    (toggle-toggle t)
 
102
    (tree-go-to t 1 :start)))
 
103
 
 
104
(tm-define (mouse-fold)
 
105
  (:type (-> void))
 
106
  (:synopsis "Fold using the mouse")
 
107
  (:secure #t)
 
108
  (with-action t
 
109
    (tree-go-to t :start)
 
110
    (fold)))
 
111
 
 
112
(tm-define (mouse-unfold)
 
113
  (:type (-> void))
 
114
  (:synopsis "Unfold using the mouse")
 
115
  (:secure #t)
 
116
  (with-action t
 
117
    (tree-go-to t :start)
 
118
    (unfold)))
 
119
 
 
120
(tm-define (hidden-variant)
 
121
  (:context toggle-first-context?)
 
122
  (unfold))
 
123
 
 
124
(tm-define (hidden-variant)
 
125
  (:context toggle-second-context?)
 
126
  (fold))
 
127
 
 
128
(tm-define (dynamic-first)
 
129
  (:context toggle-context?)
 
130
  (fold))
 
131
 
 
132
(tm-define (dynamic-previous)
 
133
  (:context toggle-context?)
 
134
  (fold))
 
135
 
 
136
(tm-define (dynamic-next)
 
137
  (:context toggle-context?)
 
138
  (unfold))
 
139
 
 
140
(tm-define (dynamic-last)
 
141
  (:context toggle-context?)
 
142
  (unfold))
 
143
 
 
144
(tm-define (tree-show-hidden t)
 
145
  (:require (toggle-context? t))
 
146
  (toggle-toggle t))
 
147
 
 
148
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
149
;; Operations on switch trees
 
150
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
151
 
 
152
(define (switch-ref t i)
 
153
  (and t (>= i 0) (< i (tree-arity t)) (not (tree-is? t i 'hidden))))
 
154
 
 
155
(define (switch-set t i on?)
 
156
  (if (== i :last) (set! i (- (tree-arity t) 1)))
 
157
  (when (and (>= i 0) (< i (tree-arity t)))
 
158
    (cond ((and on? (tree-is? t i 'hidden))
 
159
           (tree-assign-node (tree-ref t i) 'shown))
 
160
          ((and (not on?) (tree-is? t i 'shown))
 
161
           (tree-assign-node (tree-ref t i) 'hidden))
 
162
          ((and on? (not (tree-is? t i 'shown)))
 
163
           (tree-insert-node (tree-ref t i) 0 '(shown)))
 
164
          ((and (not on?) (not (tree-is? t i 'hidden)))
 
165
           (tree-insert-node (tree-ref t i) 0 '(hidden))))))
 
166
 
 
167
(define (switch-set-range t first last on?)
 
168
  (if (== last :last) (set! last (tree-arity t)))
 
169
  (for (i first last) (switch-set t i on?)))
 
170
 
 
171
(define (switch-last-visible t)
 
172
  (with v (- (tree-arity t) 1)
 
173
    (while (and (>= v 0) (not (switch-ref t v)))
 
174
      (set! v (- v 1)))
 
175
    v))
 
176
 
 
177
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
178
;; Routines on innermost switch
 
179
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
180
 
 
181
(tm-define (switch-context? t)
 
182
  (switch-tag? (tree-label t)))
 
183
 
 
184
(tm-define (switch-arity)
 
185
  (with t (tree-innermost switch-context?)
 
186
    (and t (tree-arity t))))
 
187
 
 
188
(tm-define (switch-valid-child? i)
 
189
  (with t (tree-innermost switch-context?)
 
190
    (and t i (>= i 0) (< i (tree-arity t)))))
 
191
 
 
192
(tm-define (switch-index . args)
 
193
  (:context switch-context?)
 
194
  (and-let* ((i (if (null? args) :current (car args)))
 
195
             (t (tree-innermost switch-context?))
 
196
             (c (tree-down-index t))
 
197
             (l (- (tree-arity t) 1))
 
198
             (v (switch-last-visible t)))
 
199
    (cond ((< v 0) #f)
 
200
          ((== i :visible) v)
 
201
          ((== i :current) c)
 
202
          ((== i :previous) (max 0 (- c 1)))
 
203
          ((== i :next) (min l (+ c 1)))
 
204
          ((== i :var-previous) (- c 1))
 
205
          ((== i :var-next) (+ c 1))
 
206
          ((== i :rotate-backward) (if (= c 0) l (- c 1)))
 
207
          ((== i :rotate-forward) (if (= c l) 0 (+ c 1)))
 
208
          ((== i :first) 0)
 
209
          ((== i :last) l)
 
210
          (else i))))
 
211
 
 
212
(tm-define (switch-to i . args)
 
213
  (set! i (switch-index i))
 
214
  (if (null? args) (set! args '(:start)))
 
215
  (when (switch-valid-child? i)
 
216
    (switch-select i)
 
217
    (with-innermost t switch-context?
 
218
      (apply tree-go-to (cons* t i 0 args)))))
 
219
 
 
220
(tm-define (switch-insert-at i)
 
221
  (set! i (if (== i :end) (switch-arity) (switch-index i)))
 
222
  (with-innermost t switch-context?
 
223
    (when (and (>= i 0) (<= i (tree-arity t)))
 
224
      (let* ((empty (if (tree-in? t (big-switch-tag-list)) '(document "") ""))
 
225
             (v (switch-index :visible)))
 
226
        (tree-insert! t i `((shown ,empty)))
 
227
        (if (tree-in? t (alternative-tag-list))
 
228
            (switch-select i)
 
229
            (switch-select (+ v 1)))
 
230
        (tree-go-to t i :start)))))
 
231
 
 
232
(tm-define (switch-remove-at i)
 
233
  (set! i (switch-index i))
 
234
  (with-innermost t switch-context?
 
235
    (when (and (>= i 0) (< i (tree-arity t)) (> (tree-arity t) 1))
 
236
      (let* ((v (switch-index :visible))
 
237
             (l (- (tree-arity t) 2)))
 
238
        (switch-set-range t (max 0 (- i 1)) (min l (+ i 1)) #t)
 
239
        (tree-remove! t i 1)
 
240
        (tree-go-to t (min i l) :start)
 
241
        (if (tree-in? t (alternative-tag-list))
 
242
            (switch-select (min i l))
 
243
            (switch-select (max 0 (- v 1))))))))
 
244
 
 
245
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
246
;; Specific types of switches
 
247
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
248
 
 
249
(define (alternative-context? t)
 
250
  (alternative-tag? (tree-label t)))
 
251
 
 
252
(tm-define (tree/switch-select t i)
 
253
  (:require (alternative-context? t))
 
254
  (switch-set-range t 0 :last #f)
 
255
  (switch-set t i #t))
 
256
 
 
257
(define (unroll-context? t)
 
258
  (unroll-tag? (tree-label t)))
 
259
 
 
260
(tm-define (tree/switch-select t i)
 
261
  (:require (unroll-context? t))
 
262
  (switch-set-range t 0 (+ i 1) #t)
 
263
  (switch-set-range t (+ i 1) :last #f))
 
264
 
 
265
(define (expanded-context? t)
 
266
  (expanded-tag? (tree-label t)))
 
267
 
 
268
(tm-define (tree/switch-select t i)
 
269
  (:require (expanded-context? t))
 
270
  (switch-set-range t 0 :last #t))
 
271
 
 
272
(tm-define (switch-select i)
 
273
  (with-innermost t switch-context?
 
274
    (tree/switch-select t i)))
 
275
 
 
276
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
277
;; User interface to switches
 
278
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
279
 
 
280
(tm-define (make-switch tag)
 
281
  (if (in? tag (big-switch-tag-list))
 
282
      (insert-go-to `(,tag (shown (document ""))) '(0 0 0 0))
 
283
      (insert-go-to `(,tag (shown "")) '(0 0 0))))
 
284
 
 
285
(tm-define (dynamic-first)
 
286
  (:context switch-context?)
 
287
  (switch-to :first :start))
 
288
 
 
289
(tm-define (dynamic-previous)
 
290
  (:context switch-context?)
 
291
  (switch-to :previous :end))
 
292
 
 
293
(tm-define (dynamic-next)
 
294
  (:context switch-context?)
 
295
  (switch-to :next :start))
 
296
 
 
297
(tm-define (dynamic-last)
 
298
  (:context switch-context?)
 
299
  (switch-to :last :end))
 
300
 
 
301
(tm-define (structured-insert forwards?)
 
302
  (:context switch-context?)
 
303
  (switch-insert-at (if forwards? :var-next :current)))
 
304
 
 
305
(tm-define (structured-insert-up)
 
306
  (:context switch-context?)
 
307
  (switch-insert-at :current))
 
308
 
 
309
(tm-define (structured-insert-down)
 
310
  (:context switch-context?)
 
311
  (switch-insert-at :var-next))
 
312
 
 
313
(tm-define (structured-remove forwards?)
 
314
  (:context switch-context?)
 
315
  (with-innermost t switch-context?
 
316
    (with i (if forwards? :current :var-previous)
 
317
      (set! i (switch-index i))
 
318
      (cond ((< i 0) (tree-go-to t :start))
 
319
            ((and forwards? (= i (- (tree-arity t) 1))) (tree-go-to t :end))
 
320
            (else (switch-remove-at i))))))
 
321
 
 
322
(tm-define (hidden-variant)
 
323
  (:context switch-context?)
 
324
  (switch-to :rotate-forward))
 
325
 
 
326
(tm-define (variant-circulate forward?)
 
327
  (:context switch-context?)
 
328
  (with-innermost t switch-context?
 
329
    (let* ((old (tree-label t))
 
330
           (val (big-switch-tag-list))
 
331
           (rot (list-search-rotate val old))
 
332
           (new (if (and forward? (nnull? rot)) (cadr rot) (cAr rot)))
 
333
           (i (switch-index)))
 
334
      (variant-replace old new)
 
335
      (switch-select i))))
 
336
 
 
337
(tm-define (tree-show-hidden t)
 
338
  (:require (switch-context? t))
 
339
  (with i (tree-down-index t)
 
340
    (if (tree-is? (tree-ref t i) 'hidden)
 
341
        (tree/switch-select t i))))
 
342
 
 
343
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
344
;; Analyzing the environments occurring in folds
 
345
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
346
 
 
347
(define fold-environments (make-ahash-table))
 
348
(define fold-environments-first (make-ahash-table))
 
349
(define fold-environments-second (make-ahash-table))
 
350
 
 
351
(define (fold-add-environment t first?)
 
352
  (cond ((and (toggle-first-context? t)
 
353
              (not (tree-is? t 'summarized-algorithm)))
 
354
         (fold-add-environment (tree-ref t 1) #t))
 
355
        ((and (toggle-second-context? t)
 
356
              (not (tree-is? t 'detailed-algorithm)))
 
357
         (fold-add-environment (tree-ref t 1) #f))
 
358
        ((tm-func? t 'document 1)
 
359
         (fold-add-environment (tree-ref t 0) first?))
 
360
        (else
 
361
         (with tag 'text
 
362
           (if (tree-compound? t) (set! tag (tree-label t)))
 
363
           (if (== tag 'concat) (set! tag 'text))
 
364
           (if (== tag 'document) (set! tag 'text))
 
365
           (if (== tag 'render-proof) (set! tag 'proof))
 
366
           (if (in? tag '(summarized-algorithm detailed-algorithm))
 
367
               (set! tag 'algorithm))
 
368
           (ahash-set! fold-environments tag #t)
 
369
           (ahash-set! (if first?
 
370
                           fold-environments-first
 
371
                           fold-environments-second)
 
372
                       tag #t)))))
 
373
 
 
374
(define (fold-get-environments-sub t)
 
375
  (if (tree-compound? t)
 
376
      (for-each fold-get-environments-sub (tree-children t)))
 
377
  (if (toggle-context? t)
 
378
      (fold-add-environment t (toggle-first-context? t))))
 
379
 
 
380
(tm-define (fold-get-environments-in-buffer)
 
381
  (set! fold-environments (make-ahash-table))
 
382
  (set! fold-environments-first (make-ahash-table))
 
383
  (set! fold-environments-second (make-ahash-table))
 
384
  (fold-get-environments-sub (buffer-tree))
 
385
  (with envl (map car (ahash-table->list fold-environments))
 
386
    (values
 
387
      (list-sort (map symbol->string envl) string<=?)
 
388
      fold-environments-first
 
389
      fold-environments-second)))
 
390
 
 
391
(define (fold-matching-env? t tag)
 
392
  (cond ((tree-in? t '(summarized-algorithm detailed-algorithm))
 
393
         (== tag 'algorithm))
 
394
        ((toggle-first-context? t)
 
395
         (fold-matching-env? (tree-ref t 1) tag))
 
396
        ((toggle-second-context? t)
 
397
         (fold-matching-env? (tree-ref t 1) tag))
 
398
        ((tm-func? t 'document 1)
 
399
         (fold-matching-env? (tree-ref t 0) tag))
 
400
        ((or (tree-atomic? t) (tree-in? t '(document concat)))
 
401
         (== tag 'text))
 
402
        ((== tag 'proof)
 
403
         (tree-in? t '(proof render-proof)))
 
404
        (else (tree-is? t tag))))
 
405
 
 
406
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
407
;; Global routines for folding/unfolding/compressing/expanding
 
408
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
409
 
 
410
(define (dynamic-operate-sub t mode)
 
411
  (if (tree-compound? t)
 
412
      (for-each (lambda (x) (dynamic-operate x mode)) (tree-children t)))
 
413
  (cond ((toggle-first-context? t)
 
414
         (cond ((== mode :var-last)
 
415
                (tree-insert-node! t 0 '(traversed)))
 
416
               ((in? mode '(:unfold :expand :var-expand :last))
 
417
                (toggle-toggle t))
 
418
               ((and (pair? mode) (== (car mode) :unfold)
 
419
                     (fold-matching-env? t (cadr mode)))
 
420
                (toggle-toggle t))))
 
421
        ((toggle-second-context? t)
 
422
         (cond ((== mode :var-last)
 
423
                (toggle-toggle t)
 
424
                (tree-insert-node! t 0 '(traversed)))
 
425
               ((in? mode '(:fold :compress :var-compress :first))
 
426
                (toggle-toggle t))
 
427
               ((and (pair? mode) (== (car mode) :fold)
 
428
                     (fold-matching-env? t (cadr mode)))
 
429
                (toggle-toggle t))))
 
430
        ((and (== mode :expand) (switch-context? t))
 
431
         (switch-set-range t 0 :last #t))
 
432
        ((and (== mode :compress) (switch-context? t))
 
433
         (switch-set t 0 #t)
 
434
         (switch-set-range t 1 :last #f))
 
435
        ((alternative-context? t)
 
436
         (cond ((== mode :first)
 
437
                (switch-set-range t 1 :last #f)
 
438
                (switch-set t 0 #t))
 
439
               ((== mode :last)
 
440
                (switch-set-range t 0 :last #f)
 
441
                (switch-set t :last #t))
 
442
               ((== mode :var-expand)
 
443
                (tree-assign-node! t 'expanded)
 
444
                (switch-set-range t 0 :last #t))))
 
445
        ((unroll-context? t)
 
446
         (cond ((== mode :var-last)
 
447
                (switch-set-range t 1 :last #f)
 
448
                (switch-set t 0 #t)
 
449
                (tree-insert-unary t 0 '(traversed)))
 
450
               ((== mode :first)
 
451
                (switch-set-range t 1 :last #f)
 
452
                (switch-set t 0 #t))
 
453
               ((== mode :last)
 
454
                (switch-set-range t 0 :last #t))
 
455
               ((== mode :var-expand)
 
456
                (switch-set-range t 0 :last #t))
 
457
               ((== mode :var-compress)
 
458
                (switch-set t 0 #t)
 
459
                (switch-set-range t 1 :last #f))))
 
460
        ((expanded-context? t)
 
461
         (cond ((== mode :var-compress)
 
462
                (tree-assign-node! t 'switch)
 
463
                (switch-set t 0 #t)
 
464
                (switch-set-range t 1 :last #f))))))
 
465
 
 
466
(define (dynamic-operate t mode)
 
467
  (when (tree-compound? t)
 
468
    (cond ((tree-is? t 'traversed)
 
469
           (when (!= mode :var-last)
 
470
             (dynamic-operate (tree-ref t 0) mode)
 
471
             (if (in? mode '(:unfold :expand :var-expand :first))
 
472
                 (tree-remove-node! t 0))))
 
473
          ((tree-is? t 'fold-back)
 
474
           (if (== mode :last) (set! mode :var-last))
 
475
           (dynamic-operate (tree-ref t 0) mode))
 
476
          ((tree-is? t 'keep-folded)
 
477
           (if (== mode :var-last) (set! mode :last))
 
478
           (dynamic-operate (tree-ref t 0) mode))
 
479
          (else (dynamic-operate-sub t mode)))))
 
480
 
 
481
(tm-define (dynamic-operate-on-buffer mode)
 
482
  (dynamic-operate (buffer-tree) mode)
 
483
  (if (in? mode '(:first :var-first)) (tree-go-to (buffer-tree) :start))
 
484
  (if (in? mode '(:last :var-last)) (tree-go-to (buffer-tree) :end)))
 
485
 
 
486
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
487
;; Global navigation in recursive fold/switch structure
 
488
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
489
 
 
490
(define (dynamic-traverse-folded t mode)
 
491
  (cond ((in? mode '(:next :var-next))
 
492
         (toggle-toggle t)
 
493
         (dynamic-operate (tree-ref t 1) :first)
 
494
         (tree-go-to t 1 :end)
 
495
         #t)
 
496
        (else #f)))
 
497
 
 
498
(define (dynamic-traverse-unfolded t mode)
 
499
  (cond ((== mode :var-next)
 
500
         (toggle-toggle t)
 
501
         (tree-insert-node! t 0 '(traversed))
 
502
         #t)
 
503
        ((in? mode '(:previous :var-previous))
 
504
         (with last-mode (if (== mode :previous) :last :var-last)
 
505
           (toggle-toggle t)
 
506
           (dynamic-operate (tree-ref t 0) last-mode)
 
507
           (tree-go-to t 0 :end)
 
508
           #t))
 
509
        (else #f)))
 
510
 
 
511
(define (dynamic-traverse-switch t i l mode)
 
512
  (cond ((and (== mode :var-next) (= i l) (unroll-context? t))
 
513
         (dynamic-operate t :first)
 
514
         (tree-insert-node! t 0 '(traversed))
 
515
         #t)
 
516
        ((and (in? mode '(:next :var-next)) (< i l))
 
517
         (dynamic-operate (tree-ref t (1+ i)) :first)
 
518
         (tree-go-to t i :end)
 
519
         (switch-to :next)
 
520
         #t)
 
521
        ((and (in? mode '(:previous :var-previous)) (> i 0))
 
522
         (with last-mode (if (== mode :previous) :last :var-last)
 
523
           (dynamic-operate (tree-ref t (- i 1)) last-mode)
 
524
           (tree-go-to t i :start)
 
525
           (switch-to :previous)
 
526
           #t))
 
527
        (else #f)))
 
528
 
 
529
(define (dynamic-traverse-traversed t mode)
 
530
  (and (in? mode '(:previous :var-previous))
 
531
       (begin
 
532
         (tree-remove-node! t 0)
 
533
         (dynamic-operate t :last)
 
534
         (if (and (== mode :var-previous) (tree-compound? t))
 
535
             (for-each (lambda (x) (dynamic-operate x :var-last))
 
536
                       (tree-accessible-children t)))
 
537
         #t)))
 
538
 
 
539
(define (dynamic-traverse-list l mode)
 
540
  (and (nnull? l)
 
541
       (or (dynamic-traverse (car l) mode)
 
542
           (dynamic-traverse-list (cdr l) mode))))
 
543
 
 
544
(define (dynamic-traverse t mode)
 
545
  (cond ((tree-atomic? t) #f)
 
546
        ((tree-is? t 'traversed)
 
547
         (dynamic-traverse-traversed t mode))
 
548
        ((tree-is? t 'fold-back)
 
549
         (if (== mode :next) (set! mode :var-next))
 
550
         (if (== mode :previous) (set! mode :var-previous))
 
551
         (dynamic-traverse (tree-ref t 0) mode))
 
552
        ((tree-is? t 'keep-folded)
 
553
         (if (== mode :var-next) (set! mode :next))
 
554
         (if (== mode :var-previous) (set! mode :previous))
 
555
         (dynamic-traverse (tree-ref t 0) mode))
 
556
        ((toggle-first-context? t)
 
557
         (or (dynamic-traverse (tree-ref t 0) mode)
 
558
             (dynamic-traverse-folded t mode)))
 
559
        ((toggle-second-context? t)
 
560
         (or (dynamic-traverse (tree-ref t 1) mode)
 
561
             (dynamic-traverse-unfolded t mode)))
 
562
        ((or (alternative-context? t) (unroll-context? t))
 
563
         (let* ((i (switch-last-visible t))
 
564
                (l (- (tree-arity t) 1)))
 
565
           (or (dynamic-traverse (tree-ref t i) mode)
 
566
               (dynamic-traverse-switch t i l mode))))
 
567
        (else
 
568
         (let* ((c (tree-accessible-children t))
 
569
                (forward? (in? mode '(:next :var-next)))
 
570
                (l (if forward? c (reverse c))))
 
571
           (dynamic-traverse-list l mode)))))
 
572
 
 
573
(tm-define (dynamic-traverse-buffer mode)
 
574
  (dynamic-traverse (buffer-tree) mode))