/[guile]/guile/guile-core/scripts/read-text-outline
ViewVC logotype

Diff of /guile/guile-core/scripts/read-text-outline

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by ttn, Tue Apr 2 11:13:48 2002 UTC revision 1.2 by ttn, Tue Apr 2 20:50:38 2002 UTC
# Line 101  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 101  exec ${GUILE-guile} -l $0 -c "(apply $ma
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)
# Line 112  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 119  exec ${GUILE-guile} -l $0 -c "(apply $ma
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)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26