aboutsummaryrefslogtreecommitdiff
path: root/skribe/src/common/index.scm
diff options
context:
space:
mode:
Diffstat (limited to 'skribe/src/common/index.scm')
-rw-r--r--skribe/src/common/index.scm126
1 files changed, 126 insertions, 0 deletions
diff --git a/skribe/src/common/index.scm b/skribe/src/common/index.scm
new file mode 100644
index 0000000..65c271f
--- /dev/null
+++ b/skribe/src/common/index.scm
@@ -0,0 +1,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)))))))))))
+