home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmrprt / r4rs.lha / index.sch < prev    next >
Encoding:
Text File  |  1991-11-08  |  3.4 KB  |  114 lines
  1. ; Program to process r4rs.idx entries.
  2.  
  3. (define main 0)
  4. (define aux 1)
  5.  
  6. (define (make-entry key font main/aux page)
  7.   (list key font main/aux page))
  8. (define (entry-key x) (car x))
  9. (define (entry-font x) (cadr x))
  10. (define (entry-main/aux x) (caddr x))
  11. (define (entry-page x) (cadddr x))
  12.  
  13. (define *database* '())
  14.  
  15. (define (index-entry key font main/aux page)
  16.   (set! *database*
  17.         (cons (make-entry (string-downcase key)
  18.                           font
  19.                           main/aux
  20.                           page)
  21.               *database*))
  22.   #t)
  23.  
  24. (define (create-index p)
  25.   (define (loop)
  26.     (if (null? *database*)
  27.         'done
  28.         (begin (process-key (collect-entries) p)
  29.                (loop))))
  30.   (set! *database*
  31.         (sort *database*
  32.               (lambda (x y)
  33.                 (string<? (entry-key x)
  34.                           (entry-key y)))))
  35.   (loop))
  36.  
  37. (define (collect-entries)
  38.   (define (loop key entries)
  39.     (cond ((null? *database*) entries)
  40.           ((string=? key (entry-key (car *database*)))
  41.            (let ((x (car *database*)))
  42.              (set! *database* (cdr *database*))
  43.              (loop key (cons x entries))))
  44.           (else entries)))
  45.   (loop (caar *database*) '()))
  46.  
  47. (define (process-key entries p)
  48.   (let ((entries (sort entries entry<?)))
  49.     (if (not (consistent? entries))
  50.         (begin (display "Inconsistent entries:")
  51.                (newline)
  52.                (pretty-print entries)
  53.                (newline)
  54.                (newline)))
  55.     (let ((key (entry-key (car entries)))
  56.           (font (entry-font (car entries)))
  57.           (main? (entry-main/aux (car entries)))
  58.           (pages (remove-duplicates (map entry-page entries))))
  59.       (if main?
  60.           (write-entries key font (car pages) (cdr pages) p)
  61.           (write-entries key font #f pages p)))))
  62.  
  63. (define (entry<? x y)
  64.   (let ((x1 (entry-main/aux x))
  65.         (y1 (entry-main/aux y)))
  66.     (or (< x1 y1)
  67.         (and (eq? x1 y1)
  68.              (< (entry-page x) (entry-page y))))))
  69.  
  70. (define (consistent? entries)
  71.   (let ((x (car entries)))
  72.     (let ((key (entry-key x))
  73.           (font (entry-font x)))
  74.       (every? (lambda (x)
  75.                 (and (string=? key (entry-key x))
  76.                      (string=? font (entry-font x))
  77.                      ;(eq? aux (entry-main/aux x))
  78.                      ))
  79.               (cdr entries)))))
  80.  
  81. (define (remove-duplicates x)
  82.   (define (loop x y)
  83.     (cond ((null? x) (reverse y))
  84.           ((memq (car x) y) (loop (cdr x) y))
  85.           (else (loop (cdr x) (cons (car x) y)))))
  86.   (loop (cdr x) (list (car x))))
  87.  
  88. (define *last-key* "%")
  89. (define *s1* (string-append "\\item{" (list->string '(#\\))))
  90. (define *s2* "{")
  91. (define *s3* "}}{\\hskip .75em}")
  92. (define *semi* "\; ")
  93. (define *comma* ", ")
  94.  
  95. (define (write-entries key font main pages p)
  96.   (if (and (char-alphabetic? (string-ref key 0))
  97.            (not (char=? (string-ref *last-key* 0)
  98.                         (string-ref key 0))))
  99.       (begin (display "\\indexspace" p)
  100.              (newline p)))
  101.   (set! *last-key* key)
  102.   (display (string-append *s1* font *s2* key *s3*) p)
  103.   (if main
  104.       (begin (write main p)
  105.              (if (not (null? pages))
  106.                  (display *semi* p))))
  107.   (if (not (null? pages))
  108.       (begin (write (car pages) p)
  109.              (for-each (lambda (page)
  110.                          (display *comma* p)
  111.                          (write page p))
  112.                        (cdr pages))))
  113.   (newline p))
  114.