From f9d6b7ca101444e7d278ea821a93e4b6172ff4bb Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 28 Jul 2006 15:06:14 +0000 Subject: Moved `(skribilo skribe index)' to `(skribilo index)'. * src/guile/skribilo/index.scm: No longer use `define-skribe-module'. Use the native hash-table functions instead of the one from `compat'. (*index-table*): Made an SRFI-39 parameter. * src/guile/skribilo/module.scm (%skribilo-user-autoloads): Added `(skribilo index)'. (%skribe-core-modules): Removed `index'. * src/guile/skribilo/package/base.scm: Use `(skribilo index)' instead of `(skribilo skribe index)'. * src/guile/skribilo/skribe/Makefile.am (dist_guilemodule_DATA): Removed `index.scm'. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-33 --- src/guile/skribilo/index.scm | 170 ++++++++++++++++++++++++++++++++++ src/guile/skribilo/module.scm | 4 +- src/guile/skribilo/package/base.scm | 4 +- src/guile/skribilo/skribe/Makefile.am | 2 +- src/guile/skribilo/skribe/index.scm | 149 ----------------------------- 5 files changed, 175 insertions(+), 154 deletions(-) create mode 100644 src/guile/skribilo/index.scm delete mode 100644 src/guile/skribilo/skribe/index.scm (limited to 'src') 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 +;;; +;;; +;;; 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-cistring (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 diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm index f68d4aa..54989fb 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -75,6 +75,8 @@ ((skribilo engine html) . (html-markup-class html-class html-width)) ((skribilo utils images) . (convert-image)) + ((skribilo index) . (index? make-index-table default-index + resolve-the-index)) ((skribilo source) . (source-read-lines source-fontify language? language-extractor language-fontifier source-fontify)) @@ -88,7 +90,7 @@ ((ice-9 receive) . (receive)))) (define %skribe-core-modules - '("index" "param" "sui")) + '("param" "sui")) diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm index 69818da..7b97c5d 100644 --- a/src/guile/skribilo/package/base.scm +++ b/src/guile/skribilo/package/base.scm @@ -37,9 +37,7 @@ :autoload (skribilo color) (skribe-use-color!) :autoload (skribilo source) (language? source-read-lines source-fontify) :autoload (skribilo prog) (make-prog-body resolve-line) - - :use-module (skribilo module) ;; needed before loading the following one - :autoload (skribilo skribe index) (make-index-table) + :autoload (skribilo index) (make-index-table) :replace (symbol)) diff --git a/src/guile/skribilo/skribe/Makefile.am b/src/guile/skribilo/skribe/Makefile.am index 91e3944..4b5797f 100644 --- a/src/guile/skribilo/skribe/Makefile.am +++ b/src/guile/skribilo/skribe/Makefile.am @@ -1,2 +1,2 @@ guilemoduledir = $(GUILE_SITE)/skribilo/skribe -dist_guilemodule_DATA = index.scm param.scm sui.scm +dist_guilemodule_DATA = param.scm sui.scm diff --git a/src/guile/skribilo/skribe/index.scm b/src/guile/skribilo/skribe/index.scm deleted file mode 100644 index 12ef31e..0000000 --- a/src/guile/skribilo/skribe/index.scm +++ /dev/null @@ -1,149 +0,0 @@ -;;; index.scm -;;; -;;; Copyright 2003, 2004 Manuel Serrano -;;; Copyright 2005 Ludovic Courtès -;;; -;;; -;;; 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-skribe-module (skribilo skribe index)) - -;;; Author: Manuel Serrano -;;; Commentary: -;;; -;;; A library of index-related functions. -;;; -;;; Code: - - -;;; The contents of the file below are unchanged compared to Skribe 1.2d's -;;; `index.scm' file found in the `common' directory. - - -;*---------------------------------------------------------------------*/ -;* index? ... */ -;*---------------------------------------------------------------------*/ -(define-public (index? obj) - (hashtable? obj)) - -;*---------------------------------------------------------------------*/ -;* *index-table* ... */ -;*---------------------------------------------------------------------*/ -(define-public *index-table* #f) - -;*---------------------------------------------------------------------*/ -;* make-index-table ... */ -;*---------------------------------------------------------------------*/ -(define-public (make-index-table ident) - (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* default-index ... */ -;*---------------------------------------------------------------------*/ -(define-public (default-index) - (if (not *index-table*) - (set! *index-table* (make-index-table "default-index"))) - *index-table*) - -;*---------------------------------------------------------------------*/ -;* resolve-the-index ... */ -;*---------------------------------------------------------------------*/ -(define-public (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-cistring (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 -- cgit v1.2.3