diff options
Diffstat (limited to 'src/guile/skribilo/index.scm')
| -rw-r--r-- | src/guile/skribilo/index.scm | 170 |
1 files changed, 170 insertions, 0 deletions
diff --git a/src/guile/skribilo/index.scm b/src/guile/skribilo/index.scm new file mode 100644 index 0000000..33f8d15 --- /dev/null +++ b/src/guile/skribilo/index.scm @@ -0,0 +1,170 @@ +;;; index.scm +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo index) + :use-syntax (skribilo utils syntax) + :use-syntax (skribilo lib) + + :use-module (skribilo lib) + :use-module (skribilo ast) + :use-module (srfi srfi-39) + + ;; XXX: The use of `mark' here introduces a cross-dependency between + ;; `index' and `package base'. Thus, we require that each of these two + ;; modules autoloads the other one. + :autoload (skribilo package base) (mark) + + :export (index? make-index-table *index-table* + default-index resolve-the-index)) + + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; A library of functions dealing with the creation of indices in +;;; documents. +;;; +;;; Code: + + +;;; The contents of the file below are (almost) unchanged compared to Skribe +;;; 1.2d's `index.scm' file found in the `common' directory. + + +;*---------------------------------------------------------------------*/ +;* index? ... */ +;*---------------------------------------------------------------------*/ +(define (index? obj) + (hash-table? obj)) + +;*---------------------------------------------------------------------*/ +;* *index-table* ... */ +;*---------------------------------------------------------------------*/ +(define *index-table* (make-parameter #f)) + +;*---------------------------------------------------------------------*/ +;* make-index-table ... */ +;*---------------------------------------------------------------------*/ +(define (make-index-table ident) + (make-hash-table)) + +;*---------------------------------------------------------------------*/ +;* default-index ... */ +;*---------------------------------------------------------------------*/ +(define (default-index) + (if (not (*index-table*)) + (*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 (lambda (t) + (hash-map->list + (lambda (key val) val) t)) + 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))))))))))) + + +;;; index.scm ends here |