blob: 65c271ff2fff5dafb8b06b3ddbfce899115b5477 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
;*=====================================================================*/
;* serrano/prgm/project/skribe/src/common/index.scm */
;* ------------------------------------------------------------- */
;* Author : Manuel Serrano */
;* Creation : Sun Aug 24 08:01:45 2003 */
;* Last change : Wed Feb 4 14:58:05 2004 (serrano) */
;* Copyright : 2003-04 Manuel Serrano */
;* ------------------------------------------------------------- */
;* Skribe indexes */
;* ------------------------------------------------------------- */
;* Implementation: @label index@ */
;* bigloo: @path ../bigloo/index.bgl@ */
;*=====================================================================*/
;*---------------------------------------------------------------------*/
;* index? ... */
;*---------------------------------------------------------------------*/
(define (index? obj)
(hashtable? obj))
;*---------------------------------------------------------------------*/
;* *index-table* ... */
;*---------------------------------------------------------------------*/
(define *index-table* #f)
;*---------------------------------------------------------------------*/
;* make-index-table ... */
;*---------------------------------------------------------------------*/
(define (make-index-table ident)
(make-hashtable))
;*---------------------------------------------------------------------*/
;* default-index ... */
;*---------------------------------------------------------------------*/
(define (default-index)
(if (not *index-table*)
(set! *index-table* (make-index-table "default-index")))
*index-table*)
;*---------------------------------------------------------------------*/
;* resolve-the-index ... */
;*---------------------------------------------------------------------*/
(define (resolve-the-index loc i c indexes split char-offset header-limit col)
;; fetch the descriminating index name letter
(define (index-ref n)
(let ((name (markup-option n 'name)))
(if (>= char-offset (string-length name))
(skribe-error 'the-index "char-offset out of bound" char-offset)
(string-ref name char-offset))))
;; sort a bucket of entries (the entries in a bucket share there name)
(define (sort-entries-bucket ie)
(sort ie
(lambda (i1 i2)
(or (not (markup-option i1 :note))
(markup-option i2 :note)))))
;; accumulate all the entries starting with the same letter
(define (letter-references refs)
(let ((letter (index-ref (car (car refs)))))
(let loop ((refs refs)
(acc '()))
(if (or (null? refs)
(not (char-ci=? letter (index-ref (car (car refs))))))
(values (char-upcase letter) acc refs)
(loop (cdr refs) (cons (car refs) acc))))))
;; merge the buckets that comes from different index tables
(define (merge-buckets buckets)
(if (null? buckets)
'()
(let loop ((buckets buckets)
(res '()))
(cond
((null? (cdr buckets))
(reverse! (cons (car buckets) res)))
((string=? (markup-option (car (car buckets)) 'name)
(markup-option (car (cadr buckets)) 'name))
;; we merge
(loop (cons (append (car buckets) (cadr buckets))
(cddr buckets))
res))
(else
(loop (cdr buckets)
(cons (car buckets) res)))))))
(let* ((entries (apply append (map hashtable->list indexes)))
(sorted (map sort-entries-bucket
(merge-buckets
(sort entries
(lambda (e1 e2)
(string-ci<?
(markup-option (car e1) 'name)
(markup-option (car e2) 'name))))))))
(if (and (not split) (< (apply + (map length sorted)) header-limit))
(new markup
(markup '&the-index)
(loc loc)
(ident i)
(class c)
(options `((:column ,col)))
(body sorted))
(let loop ((refs sorted)
(lrefs '())
(body '()))
(if (null? refs)
(new markup
(markup '&the-index)
(loc loc)
(ident i)
(class c)
(options `((:column ,col)
(header ,(new markup
(markup '&the-index-header)
(loc loc)
(body (reverse! lrefs))))))
(body (reverse! body)))
(call-with-values
(lambda () (letter-references refs))
(lambda (l lr next-refs)
(let* ((s (string l))
(m (mark (symbol->string (gensym s)) :text s))
(h (new handle (loc loc) (ast m)))
(r (ref :handle h :text s)))
(ast-loc-set! m loc)
(ast-loc-set! r loc)
(loop next-refs
(cons r lrefs)
(append lr (cons m body)))))))))))
|
