suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

minor code improvements

Browse Source 
svn: r8417

original commit: 7126fdce72db0dc7a11b8db91cc37e678fd1ca8c
This commit is contained in:
Eli Barzilay 2008-01-25 16:32:33 +00:00
parent c63cd9a943
commit a65ca82cc5
1 changed files with 87 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

108
collects/scribble/basic.ss
View File

@ -89,12 +89,9 @@
(define (itemize . items) (define (itemize . items)
(let ([items (filter (lambda (v) (not (whitespace? v))) items)]) (let ([items (filter (lambda (v) (not (whitespace? v))) items)])
(for-each (lambda (v) (for ([v items])
(unless (an-item? v) (unless (an-item? v)
(error 'itemize (error 'itemize "expected an item, found something else: ~e" v)))
"expected an item, found something else: ~e"
v)))
items)
(make-itemization (map an-item-flow items)))) (make-itemization (map an-item-flow items))))
(define-struct an-item (flow)) (define-struct an-item (flow))
@ -203,41 +200,31 @@
null)) null))
(define (index-flow-elements) (define (index-flow-elements)
(list (make-delayed-flow-element (define (commas l)
(if (or (null? l) (null? (cdr l)))
l
(cdr (apply append (map (lambda (i) (list ", " i)) l)))))
(define (cadr-string-lists<? a b)
(let loop ([a (cadr a)] [b (cadr b)])
(cond [(null? a) #t]
[(null? b) #f]
[(string-ci=? (car a) (car b)) (loop (cdr a) (cdr b))]
[else (string-ci<? (car a) (car b))])))
(define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
(define contents
(make-delayed-flow-element
(lambda (renderer sec ri) (lambda (renderer sec ri)
(let ([l null]) (define l null)
(define alpha-starts (make-hash-table))
(hash-table-for-each (hash-table-for-each
(let ([parent (collected-info-parent (let ([parent (collected-info-parent (part-collected-info sec ri))])
(part-collected-info sec ri))])
(if parent (if parent
(collected-info-info (collected-info-info (part-collected-info parent ri))
(part-collected-info
parent
ri))
(collect-info-ext-ht (resolve-info-ci ri)))) (collect-info-ext-ht (resolve-info-ci ri))))
(lambda (k v) (lambda (k v)
(when (and (pair? k) (when (and (pair? k) (eq? 'index-entry (car k)))
(eq? 'index-entry (car k)))
(set! l (cons (cons (cadr k) v) l))))) (set! l (cons (cons (cadr k) v) l)))))
(let ([l (sort (set! l (sort l cadr-string-lists<?))
l
(lambda (a b)
(let loop ([a (cadr a)][b (cadr b)])
(cond
[(null? a) #t]
[(null? b) #f]
[(string-ci=? (car a) (car b))
(loop (cdr a) (cdr b))]
[else
(string-ci<? (car a) (car b))]))))]
[commas (lambda (l)
(if (or (null? l)
(null? (cdr l)))
l
(cdr (apply append (map (lambda (i)
(list ", " i))
l)))))]
[alpha-starts (make-hash-table)])
(make-table (make-table
'index 'index
(list* (list*
@ -245,19 +232,14 @@
(make-flow (make-flow
(list (list
(make-paragraph (make-paragraph
(let ([add-letter (let loop ([i l] [alpha alpha])
(lambda (letter l) (define (add-letter letter l)
(list* (make-element "nonavigation" (list* (make-element "nonavigation" (list (string letter)))
(list (string letter))) " " l))
" " (cond [(null? alpha) null]
l))]) [(null? i) (add-letter (car alpha) (loop i (cdr alpha)))]
(let loop ([i l] [else
[alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ")]) (let* ([strs (cadr (car i))]
(cond
[(null? alpha) null]
[(null? i) (add-letter (car alpha)
(loop i (cdr alpha)))]
[else (let* ([strs (cadr (car i))]
[letter (if (or (null? strs) [letter (if (or (null? strs)
(string=? "" (car strs))) (string=? "" (car strs)))
#f #f
@ -265,33 +247,33 @@
(cond (cond
[(not letter) (loop (cdr i) alpha)] [(not letter) (loop (cdr i) alpha)]
[(char-ci>? letter (car alpha)) [(char-ci>? letter (car alpha))
(add-letter (car alpha) (add-letter (car alpha) (loop i (cdr alpha)))]
(loop i (cdr alpha)))]
[(char-ci=? letter (car alpha)) [(char-ci=? letter (car alpha))
(hash-table-put! alpha-starts (car i) letter) (hash-table-put! alpha-starts (car i) letter)
(list* (make-element (make-target-url (list*
(format "#alpha:~a" letter) (make-element
(make-target-url
(format "#alpha:~a" (char-upcase letter))
#f) #f)
(list (string (car alpha)))) (list (string (car alpha))))
" " " "
(loop (cdr i) (cdr alpha)))] (loop (cdr i) (cdr alpha)))]
[else (loop (cdr i) alpha)]))]))))))) [else (loop (cdr i) alpha)]))]))))))
(list (make-flow (list (make-paragraph (list 'nbsp))))) (list (make-flow (list (make-paragraph (list 'nbsp)))))
(map (lambda (i) (map (lambda (i)
(list (make-flow (let* ([e (make-link-element
(list
(make-paragraph
(list
(let ([e (make-link-element
"indexlink" "indexlink"
(commas (caddr i)) (commas (caddr i))
(car i))]) (car i))]
(let ([letter (hash-table-get alpha-starts i #f)]) [letter (hash-table-get alpha-starts i #f)]
(if letter [e (if letter
(make-element (make-url-anchor (format "alpha:~a" letter)) (make-element
(make-url-anchor (format "alpha:~a" letter))
(list e)) (list e))
e))))))))) e)])
l))))))))) (list (make-flow (list (make-paragraph (list e)))))))
l))))))
(list contents))
;; ---------------------------------------- ;; ----------------------------------------