aboutsummaryrefslogtreecommitdiff
path: root/src/common/index.scm
diff options
context:
space:
mode:
authorLudovic Court`es2006-10-11 07:43:47 +0000
committerLudovic Court`es2006-10-11 07:43:47 +0000
commitd4360259d60722eaa175a483f792fce7b8c66d97 (patch)
tree622cc21b820e3dd4616890bc9ccba74de6637d8a /src/common/index.scm
parentfc42fe56a57eace2dbdb31574c2e161f0eacf839 (diff)
downloadskribilo-d4360259d60722eaa175a483f792fce7b8c66d97.tar.gz
skribilo-d4360259d60722eaa175a483f792fce7b8c66d97.tar.lz
skribilo-d4360259d60722eaa175a483f792fce7b8c66d97.zip
slide: Propagate the `outline?' parameter in `slide-(sub)?topic'.
* src/guile/skribilo/package/slide.scm (slide-topic): Propagate the `outline?' parameter as an option. (slide-subtopic): Likewise. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-1
Diffstat (limited to 'src/common/index.scm')
-rw-r--r--src/common/index.scm126
1 files changed, 0 insertions, 126 deletions
diff --git a/src/common/index.scm b/src/common/index.scm
deleted file mode 100644
index 65c271f..0000000
--- a/src/common/index.scm
+++ /dev/null
@@ -1,126 +0,0 @@
-;*=====================================================================*/
-;* 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)))))))))))
-