101 |
|
|
102 |
(define (read-text-outline-silently port) |
(define (read-text-outline-silently port) |
103 |
(let* ((all '(start)) |
(let* ((all '(start)) |
104 |
(pchain (list)) ; parents chain |
(pchain (list))) ; parents chain |
105 |
(tp all)) ; tail pointer |
(let loop ((line (read-line port)) |
106 |
(let loop ((line (read-line port)) (prev-level -1)) |
(prev-level -1) ; how this relates to the first input |
107 |
|
; level determines whether or not we |
108 |
|
; start in "sibling" or "child" mode. |
109 |
|
; in the end, `start' is ignored and |
110 |
|
; it's much easier to ignore parents |
111 |
|
; than siblings (sometimes). this is |
112 |
|
; not to encourage ignorance, however. |
113 |
|
(tp all)) ; tail pointer |
114 |
(or (eof-object? line) |
(or (eof-object? line) |
115 |
(cond ((regexp-exec *depth-cue-rx* line) |
(cond ((regexp-exec *depth-cue-rx* line) |
116 |
=> (lambda (m) |
=> (lambda (m) |
119 |
(or (match:substring m *subm-number*) |
(or (match:substring m *subm-number*) |
120 |
"")) |
"")) |
121 |
*level-divisor*)) |
*level-divisor*)) |
122 |
(diff (- level prev-level)) |
(diff (- level prev-level))) |
|
(saved-tp tp)) |
|
123 |
(cond |
(cond |
124 |
|
|
125 |
;; sibling |
;; sibling |
126 |
((zero? diff) |
((zero? diff) |
127 |
(set-cdr! tp words) |
;; just extend the chain |
128 |
(set! tp words)) |
(set-cdr! tp words)) |
129 |
|
|
130 |
;; child |
;; child |
131 |
((positive? diff) |
((positive? diff) |
132 |
(or (= 1 diff) |
(or (= 1 diff) |
133 |
(error "unhandled diff not 1:" diff line)) |
(error "unhandled diff not 1:" diff line)) |
134 |
|
;; parent may be contacted by uncle later (kids |
135 |
|
;; these days!) so save its level |
136 |
(set-object-property! tp 'level prev-level) |
(set-object-property! tp 'level prev-level) |
137 |
(set! pchain (cons tp pchain)) |
(set! pchain (cons tp pchain)) |
138 |
(set-car! tp (cons (car tp) words)) |
;; "push down" car into hierarchy |
139 |
(set! tp words)) |
(set-car! tp (cons (car tp) words))) |
140 |
|
|
141 |
;; uncle |
;; uncle |
142 |
((negative? diff) |
((negative? diff) |
143 |
|
;; prune back to where levels match |
144 |
(do ((p pchain (cdr p))) |
(do ((p pchain (cdr p))) |
145 |
((= level (object-property (car p) 'level)) |
((= level (object-property (car p) 'level)) |
146 |
(set! pchain p))) |
(set! pchain p))) |
147 |
|
;; resume at this level |
148 |
(set-cdr! (car pchain) words) |
(set-cdr! (car pchain) words) |
149 |
(set! pchain (cdr pchain)) |
(set! pchain (cdr pchain)))) |
|
(set! tp words))) |
|
150 |
|
|
151 |
(loop (read-line port) level)))) |
(loop (read-line port) level words)))) |
152 |
(else (loop (read-line port) prev-level))))) |
(else (loop (read-line port) prev-level tp))))) |
153 |
(set! all (car all)) |
(set! all (car all)) |
154 |
(if (eq? 'start all) |
(if (eq? 'start all) |
155 |
'() |
'() ; wasteland |
156 |
(cdr all)))) |
(cdr all)))) |
157 |
|
|
158 |
(define (read-text-outline . args) |
(define (read-text-outline . args) |