/[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.2 by ttn, Tue Apr 2 20:50:38 2002 UTC revision 1.3 by ttn, Sat Apr 6 01:55:20 2002 UTC
# Line 31  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 31  exec ${GUILE-guile} -l $0 -c "(apply $ma
31  ;; Scan OUTLINE file and display a list of trees, the structure of  ;; Scan OUTLINE file and display a list of trees, the structure of
32  ;; each reflecting the "levels" in OUTLINE.  The recognized outline  ;; each reflecting the "levels" in OUTLINE.  The recognized outline
33  ;; format (used to indicate outline headings) is zero or more pairs of  ;; format (used to indicate outline headings) is zero or more pairs of
34  ;; leading spaces followed by "-" or "+".  Something like:  ;; leading spaces followed by "-".  Something like:
35  ;;  ;;
36  ;;    - a                  0  ;;    - a                  0
37  ;;      - b                1  ;;      - b                1
# Line 40  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 40  exec ${GUILE-guile} -l $0 -c "(apply $ma
40  ;;    - e                  0  ;;    - e                  0
41  ;;      - f                1  ;;      - f                1
42  ;;        - g              2  ;;        - g              2
43  ;;      -h                 1  ;;      - h                1
44  ;;  ;;
45  ;; In this example the levels are shown to the right.  The output for  ;; In this example the levels are shown to the right.  The output for
46  ;; such a file would be the single line:  ;; such a file would be the single line:
47  ;;  ;;
48  ;;   (("a" ("b" "c") "d") ("e" ("f" "g") "h"))  ;;   (("a" ("b" "c") "d") ("e" ("f" "g") "h"))
49  ;;  ;;
50    ;; Basically, anything at the beginning of a list is a parent, and the
51    ;; remaining elements of that list are its children.
52  ;;  ;;
53  ;; Usage from a Scheme program: These three procs are exported:  ;;
54    ;; Usage from a Scheme program: These two procs are exported:
55  ;;  ;;
56  ;;   (read-text-outline . args)           ; only first arg is used  ;;   (read-text-outline . args)           ; only first arg is used
57  ;;   (read-text-outline-silently port)  ;;   (read-text-outline-silently port)
58  ;;   (display-outline-tree tree)  ;;   (make-text-outline-reader re specs)
59    ;;
60    ;; `make-text-outline-reader' returns a proc that reads from PORT and
61    ;; returns a list of trees (similar to `read-text-outline-silently').
62  ;;  ;;
63  ;; Don't forget to iterate (say, `display-outline-tree') over the list of  ;; RE is a regular expression (string) that is used to identify a header
64  ;; trees that `read-text-outline-silently' returns.  ;; line of the outline (as opposed to a whitespace line or intervening
65    ;; text).  RE must begin w/ a sub-expression to match the "level prefix"
66    ;; of the line.  You can use `level-submatch-number' in SPECS (explained
67    ;; below) to specify a number other than 1, the default.
68    ;;
69    ;; Normally, the level of the line is taken directly as the length of
70    ;; its level prefix.  This often results in adjacent levels not mapping
71    ;; to adjacent numbers, which confuses the tree-building portion of the
72    ;; program, which expects top-level to be 0, first sub-level to be 1,
73    ;; etc.  You can use `level-substring-divisor' or `compute-level' in
74    ;; SPECS to specify a constant scaling factor or specify a completely
75    ;; alternative procedure, respectively.
76    ;;
77    ;; SPECS is an alist which may contain the following key/value pairs:
78    ;;
79    ;; - level-submatch-number NUMBER
80    ;; - level-substring-divisor NUMBER
81    ;; - compute-level PROC
82    ;; - body-submatch-number NUMBER
83    ;; - extra-fields ((FIELD-1 . SUBMATCH-1) (FIELD-2 . SUBMATCH-2) ...)
84    ;;
85    ;; The PROC value associated with key `compute-level' should take a
86    ;; Scheme match structure (as returned by `regexp-exec') and return a
87    ;; number, the normalized level for that line.  If this is specified,
88    ;; it takes precedence over other level-computation methods.
89    ;;
90    ;; Use `body-submatch-number' if RE specifies the whole body, or if you
91    ;; want to make use of the extra fields parsing.  The `extra-fields'
92    ;; value is a sub-alist, whose keys name additional fields that are to
93    ;; be recognized.  These fields along with `level' are set as object
94    ;; properties of the final string ("body") that is consed into the tree.
95    ;; If a field name ends in "?" the field value is set to be #t if there
96    ;; is a match and the result is not an empty string, and #f otherwise.
97  ;;  ;;
98  ;;  ;;
99  ;; Bugs and caveats:  ;; Bugs and caveats:
# Line 73  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 111  exec ${GUILE-guile} -l $0 -c "(apply $ma
111  ;;  ;;
112  ;; TODO: Determine what's the right thing to do for skips.  ;; TODO: Determine what's the right thing to do for skips.
113  ;;       Handle TABs.  ;;       Handle TABs.
114  ;;       Handle follow-on lines.  ;;       Make line format customizable via longopts.
 ;;       Make line/display format customizable via longopts.  
115    
116  ;;; Code:  ;;; Code:
117    
118  (define-module (scripts read-text-outline)  (define-module (scripts read-text-outline)
119    :export (read-text-outline read-text-outline-silently display-outline-tree)    :export (read-text-outline
120               read-text-outline-silently
121               make-text-outline-reader)
122    :use-module (ice-9 regex)    :use-module (ice-9 regex)
123    :use-module (ice-9 rdelim))    :autoload (ice-9 rdelim) (read-line)
124      :autoload (ice-9 getopt-long) (getopt-long))
125    
126  ;; todo: make customizable  (define (?? symbol)
127  (define *depth-cue-rx* (make-regexp "(([ ][ ])*)[-+] *"))    (let ((name (symbol->string symbol)))
128  (define *subm-number* 1)      (string=? "?" (substring name (1- (string-length name))))))
129  (define *level-divisor* 2)  
130    (define (msub n)
131  (define (>> level line)    (lambda (m)
132    (format #t "\t~A\t~A- ~A\n" level (make-string level #\space) line))      (match:substring m n)))
133    
134  (define (display-outline-tree level tree)  (define (??-predicates pair)
135    (cond ((list? tree)    (cons (car pair)
136           (>> level (car tree))          (if (?? (car pair))
137           (for-each (lambda (kid)              (lambda (m)
138                       (display-outline-tree (+ *level-divisor* level) kid))                (not (string=? "" (match:substring m (cdr pair)))))
139                     (cdr tree)))              (msub (cdr pair)))))
140          (else (>> level tree))))  
141    (define (make-line-parser re specs)
142  (define (read-text-outline-silently port)    (let* ((rx (let ((fc (substring re 0 1)))
143    (let* ((all '(start))                 (make-regexp (if (string=? "^" fc)
144           (pchain (list)))               ; parents chain                                  re
145      (let loop ((line (read-line port))                                  (string-append "^" re)))))
146                 (prev-level -1)          ; how this relates to the first input           (check (lambda (key)
147                      (assq-ref specs key)))
148             (level-substring (msub (or (check 'level-submatch-number) 1)))
149             (extract-level (cond ((check 'compute-level)
150                                   => (lambda (proc)
151                                        (lambda (m)
152                                          (proc m))))
153                                  ((check 'level-substring-divisor)
154                                   => (lambda (n)
155                                        (lambda (m)
156                                          (/ (string-length (level-substring m))
157                                             n))))
158                                  (else
159                                   (lambda (m)
160                                     (string-length (level-substring m))))))
161             (extract-body (cond ((check 'body-submatch-number)
162                                  => msub)
163                                 (else
164                                  (lambda (m) (match:suffix m)))))
165             (misc-props! (cond ((check 'extra-fields)
166                                 => (lambda (alist)
167                                      (let ((new (map ??-predicates alist)))
168                                        (lambda (obj m)
169                                          (for-each
170                                           (lambda (pair)
171                                             (set-object-property!
172                                              obj (car pair)
173                                              ((cdr pair) m)))
174                                           new)))))
175                                (else
176                                 (lambda (obj m) #t)))))
177        ;; retval
178        (lambda (line)
179          (cond ((regexp-exec rx line)
180                 => (lambda (m)
181                      (let ((level (extract-level m))
182                            (body  (extract-body m)))
183                        (set-object-property! body 'level level)
184                        (misc-props! body m)
185                        body)))
186                (else #f)))))
187    
188    (define (make-text-outline-reader re specs)
189      (let ((parse-line (make-line-parser re specs)))
190        ;; retval
191        (lambda (port)
192          (let* ((all '(start))
193                 (pchain (list)))           ; parents chain
194            (let loop ((line (read-line port))
195                       (prev-level -1)      ; how this relates to the first input
196                                          ; level determines whether or not we                                          ; level determines whether or not we
197                                          ; start in "sibling" or "child" mode.                                          ; start in "sibling" or "child" mode.
198                                          ; in the end, `start' is ignored and                                          ; in the end, `start' is ignored and
199                                          ; it's much easier to ignore parents                                          ; it's much easier to ignore parents
200                                          ; than siblings (sometimes).  this is                                          ; than siblings (sometimes).  this is
201                                          ; not to encourage ignorance, however.                                          ; not to encourage ignorance, however.
202                 (tp all))                ; tail pointer                     (tp all))            ; tail pointer
203        (or (eof-object? line)            (or (eof-object? line)
204            (cond ((regexp-exec *depth-cue-rx* line)                (cond ((parse-line line)
205                   => (lambda (m)                       => (lambda (w)
206                        (let* ((words (list (match:suffix m)))                            (let* ((words (list w))
207                               (level (/ (string-length                                   (level (object-property w 'level))
208                                          (or (match:substring m *subm-number*)                                   (diff (- level prev-level)))
209                                              ""))                              (cond
210                                         *level-divisor*))  
211                               (diff (- level prev-level)))                               ;; sibling
212                          (cond                               ((zero? diff)
213                                  ;; just extend the chain
214                           ;; sibling                                (set-cdr! tp words))
215                           ((zero? diff)  
216                            ;; just extend the chain                               ;; child
217                            (set-cdr! tp words))                               ((positive? diff)
218                                  (or (= 1 diff)
219                           ;; child                                    (error "unhandled diff not 1:" diff line))
220                           ((positive? diff)                                ;; parent may be contacted by uncle later (kids
221                            (or (= 1 diff)                                ;; these days!) so save its level
222                                (error "unhandled diff not 1:" diff line))                                (set-object-property! tp 'level prev-level)
223                            ;; parent may be contacted by uncle later (kids                                (set! pchain (cons tp pchain))
224                            ;; these days!) so save its level                                ;; "push down" car into hierarchy
225                            (set-object-property! tp 'level prev-level)                                (set-car! tp (cons (car tp) words)))
226                            (set! pchain (cons tp pchain))  
227                            ;; "push down" car into hierarchy                               ;; uncle
228                            (set-car! tp (cons (car tp) words)))                               ((negative? diff)
229                                  ;; prune back to where levels match
230                           ;; uncle                                (do ((p pchain (cdr p)))
231                           ((negative? diff)                                    ((= level (object-property (car p) 'level))
232                            ;; prune back to where levels match                                     (set! pchain p)))
233                            (do ((p pchain (cdr p)))                                ;; resume at this level
234                                ((= level (object-property (car p) 'level))                                (set-cdr! (car pchain) words)
235                                 (set! pchain p)))                                (set! pchain (cdr pchain))))
236                            ;; resume at this level  
237                            (set-cdr! (car pchain) words)                              (loop (read-line port) level words))))
238                            (set! pchain (cdr pchain))))                      (else (loop (read-line port) prev-level tp)))))
239            (set! all (car all))
240                          (loop (read-line port) level words))))          (if (eq? 'start all)
241                  (else (loop (read-line port) prev-level tp)))))              '()                         ; wasteland
242      (set! all (car all))              (cdr all))))))
243      (if (eq? 'start all)  
244          '()                             ; wasteland  (define read-text-outline-silently
245          (cdr all))))    (make-text-outline-reader "(([ ][ ])*)- *"
246                                '((level-substring-divisor . 2))))
247    
248  (define (read-text-outline . args)  (define (read-text-outline . args)
249    (let ((trees (read-text-outline-silently (open-file (car args) "r"))))    (write (read-text-outline-silently (open-file (car args) "r")))
250      ;; try this    (newline)
     ;; (for-each (lambda (tree)  
     ;;             (display-outline-tree 0 tree))  
     ;;           trees))  
     (write trees)  
     (newline))  
251    #t)                                   ; exit val    #t)                                   ; exit val
252    
253  (define main read-text-outline)  (define main read-text-outline)

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

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