suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 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

172
collects/scribble/basic.ss
View File

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