guile/scripts/read-text-outline

#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts read-text-outline)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; read-text-outline --- Read a text outline and display it as a sexp

;; 	Copyright (C) 2002 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: read-text-outline OUTLINE
;;
;; Scan OUTLINE file and display a list of trees, the structure of
;; each reflecting the "levels" in OUTLINE.  The recognized outline
;; format (used to indicate outline headings) is zero or more pairs of
;; leading spaces followed by "-" or "+".  Something like:
;;
;;    - a                  0
;;      - b                1
;;        - c              2
;;      - d                1
;;    - e                  0
;;      - f                1
;;        - g              2
;;      -h                 1
;;
;; In this example the levels are shown to the right.  The output for
;; such a file would be the single line:
;;
;;   (("a" ("b" "c") "d") ("e" ("f" "g") "h"))
;;
;;
;; Usage from a Scheme program: These three procs are exported:
;;
;;   (read-text-outline . args)           ; only first arg is used
;;   (read-text-outline-silently port)
;;   (display-outline-tree tree)
;;
;; Don't forget to iterate (say, `display-outline-tree') over the list of
;; trees that `read-text-outline-silently' returns.
;;
;;
;; Bugs and caveats:
;;
;; (1) Only the first file specified on the command line is scanned.
;; (2) TAB characters at the beginnings of lines are not recognized.
;; (3) Outlines that "skip" levels signal an error.  In other words,
;;     this will fail:
;;
;;            - a               0
;;              - b             1
;;                  - c         3       <-- skipped 2 -- error!
;;              - d             1
;;
;;
;; TODO: Determine what's the right thing to do for skips.
;;       Handle TABs.
;;       Handle follow-on lines.
;;       Make line/display format customizable via longopts.

;;; Code:

(define-module (scripts read-text-outline)
  :export (read-text-outline read-text-outline-silently display-outline-tree)
  :use-module (ice-9 regex)
  :use-module (ice-9 rdelim))

;; todo: make customizable
(define *depth-cue-rx* (make-regexp "(([ ][ ])*)[-+] *"))
(define *subm-number* 1)
(define *level-divisor* 2)

(define (>> level line)
  (format #t "\t~A\t~A- ~A\n" level (make-string level #\space) line))

(define (display-outline-tree level tree)
  (cond ((list? tree)
         (>> level (car tree))
         (for-each (lambda (kid)
                     (display-outline-tree (+ *level-divisor* level) kid))
                   (cdr tree)))
        (else (>> level tree))))

(define (read-text-outline-silently port)
  (let* ((all '(start))
         (pchain (list)))               ; parents chain
    (let loop ((line (read-line port))
               (prev-level -1)          ; how this relates to the first input
                                        ; level determines whether or not we
                                        ; start in "sibling" or "child" mode.
                                        ; in the end, `start' is ignored and
                                        ; it's much easier to ignore parents
                                        ; than siblings (sometimes).  this is
                                        ; not to encourage ignorance, however.
               (tp all))                ; tail pointer
      (or (eof-object? line)
          (cond ((regexp-exec *depth-cue-rx* line)
                 => (lambda (m)
                      (let* ((words (list (match:suffix m)))
                             (level (/ (string-length
                                        (or (match:substring m *subm-number*)
                                            ""))
                                       *level-divisor*))
                             (diff (- level prev-level)))
                        (cond

                         ;; sibling
                         ((zero? diff)
                          ;; just extend the chain
                          (set-cdr! tp words))

                         ;; child
                         ((positive? diff)
                          (or (= 1 diff)
                              (error "unhandled diff not 1:" diff line))
                          ;; parent may be contacted by uncle later (kids
                          ;; these days!) so save its level
                          (set-object-property! tp 'level prev-level)
                          (set! pchain (cons tp pchain))
                          ;; "push down" car into hierarchy
                          (set-car! tp (cons (car tp) words)))

                         ;; uncle
                         ((negative? diff)
                          ;; prune back to where levels match
                          (do ((p pchain (cdr p)))
                              ((= level (object-property (car p) 'level))
                               (set! pchain p)))
                          ;; resume at this level
                          (set-cdr! (car pchain) words)
                          (set! pchain (cdr pchain))))

                        (loop (read-line port) level words))))
                (else (loop (read-line port) prev-level tp)))))
    (set! all (car all))
    (if (eq? 'start all)
        '()                             ; wasteland
        (cdr all))))

(define (read-text-outline . args)
  (let ((trees (read-text-outline-silently (open-file (car args) "r"))))
    ;; try this
    ;; (for-each (lambda (tree)
    ;;             (display-outline-tree 0 tree))
    ;;           trees))
    (write trees)
    (newline))
  #t)                                   ; exit val

(define main read-text-outline)

;;; read-text-outline ends here