130 lines
3.8 KiB
Plaintext
130 lines
3.8 KiB
Plaintext
(define main 0)
|
|
(define aux 1)
|
|
|
|
(define pretty-print (lambda (expr) (format #t "Pretty: ~S\n" expr) expr))
|
|
|
|
(define every?
|
|
(lambda (test . lists)
|
|
(let scan ((tails lists))
|
|
(if (member #t (map null? tails)) ;(any null? lists)
|
|
#t
|
|
(and (apply test (map car tails))
|
|
(scan (map cdr tails)))))))
|
|
|
|
(define (make-entry key font main/aux page)
|
|
(list key font main/aux page))
|
|
(define (entry-key x) (car x))
|
|
(define (entry-font x) (cadr x))
|
|
(define (entry-main/aux x) (caddr x))
|
|
(define (entry-page x) (cadddr x))
|
|
|
|
(define *database* '())
|
|
|
|
(define (index-entry key font main/aux page)
|
|
(set! *database*
|
|
(cons (make-entry (string-lower key)
|
|
font
|
|
main/aux
|
|
page)
|
|
*database*))
|
|
#t)
|
|
|
|
(define (create-index p)
|
|
(define (loop)
|
|
(if (null? *database*)
|
|
'done
|
|
(begin (process-key (collect-entries) p)
|
|
(loop))))
|
|
(set! *database*
|
|
(sort *database*
|
|
(lambda (x y)
|
|
(string<? (entry-key x)
|
|
(entry-key y)))))
|
|
(loop))
|
|
|
|
(define (collect-entries)
|
|
(define (loop key entries)
|
|
(cond ((null? *database*) entries)
|
|
((string=? key (entry-key (car *database*)))
|
|
(let ((x (car *database*)))
|
|
(set! *database* (cdr *database*))
|
|
(loop key (cons x entries))))
|
|
(else entries)))
|
|
(loop (caar *database*) '()))
|
|
|
|
(define (process-key entries p)
|
|
(let ((entries (sort entries entry<?)))
|
|
(if (not (consistent? entries))
|
|
(begin (display "Inconsistent entries:")
|
|
(newline)
|
|
(pretty-print entries)
|
|
(newline)
|
|
(newline)))
|
|
(let ((key (entry-key (car entries)))
|
|
(font (entry-font (car entries)))
|
|
(main? (entry-main/aux (car entries)))
|
|
(pages (remove-duplicates (map entry-page entries))))
|
|
(if main?
|
|
(write-entries key font (car pages) (cdr pages) p)
|
|
(write-entries key font #f pages p)))))
|
|
|
|
(define (entry<? x y)
|
|
(let ((x1 (entry-main/aux x))
|
|
(y1 (entry-main/aux y)))
|
|
(or (< x1 y1)
|
|
(and (eq? x1 y1)
|
|
(< (entry-page x) (entry-page y))))))
|
|
|
|
(define (consistent? entries)
|
|
(let ((x (car entries)))
|
|
(let ((key (entry-key x))
|
|
(font (entry-font x)))
|
|
(every? (lambda (x)
|
|
(and (string=? key (entry-key x))
|
|
(string=? font (entry-font x))
|
|
;(eq? aux (entry-main/aux x))
|
|
))
|
|
(cdr entries)))))
|
|
|
|
(define (remove-duplicates x)
|
|
(define (loop x y)
|
|
(cond ((null? x) (reverse y))
|
|
((memq (car x) y) (loop (cdr x) y))
|
|
(else (loop (cdr x) (cons (car x) y)))))
|
|
(loop (cdr x) (list (car x))))
|
|
|
|
(define *last-key* "%")
|
|
(define *s1* (string-append "\\item{" (list->string '(#\\))))
|
|
(define *s2* "{")
|
|
(define *s3* "}}\\dotfill\\ ")
|
|
(define *semi* "\; ")
|
|
(define *comma* ", ")
|
|
|
|
(define (write-entries key font main pages p)
|
|
(if (and (char-alphabetic? (string-ref key 0))
|
|
(not (char=? (string-ref *last-key* 0)
|
|
(string-ref key 0))))
|
|
(begin (display "\\indexspace" p)
|
|
(newline p)
|
|
(display "{\\vskip3mm\\LARGE " p)
|
|
(display (string-upper (substring key 0 1)) p)
|
|
(display "\\nopagebreak}\\" p)
|
|
(newline p)))
|
|
(set! *last-key* key)
|
|
(display (string-append *s1* font *s2* key *s3*) p)
|
|
(if main
|
|
(begin (write main p)
|
|
(if (not (null? pages))
|
|
(display *semi* p))))
|
|
(if (not (null? pages))
|
|
(begin (write (car pages) p)
|
|
(for-each (lambda (page)
|
|
(display *comma* p)
|
|
(write page p))
|
|
(cdr pages))))
|
|
(newline p))
|
|
|
|
(load "manual.idx")
|
|
(define p (open-output-file "index.tex"))
|
|
(create-index p)
|