diff options
| -rw-r--r-- | src/guile/skribilo/biblio.scm | 120 | ||||
| -rw-r--r-- | src/guile/skribilo/biblio/author.scm | 19 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/lout.scm | 104 | ||||
| -rw-r--r-- | src/guile/skribilo/package/base.scm | 31 |
4 files changed, 199 insertions, 75 deletions
diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm index 2a0c070..0c2cfa7 100644 --- a/src/guile/skribilo/biblio.scm +++ b/src/guile/skribilo/biblio.scm @@ -2,7 +2,7 @@ ;;; ;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano ;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2005, 2006, 2007 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 @@ -31,10 +31,11 @@ :use-module (srfi srfi-39) :use-module (skribilo condition) - :autoload (skribilo reader) (%default-reader) - :autoload (skribilo parameters) (*bib-path*) - :autoload (skribilo ast) (<markup> <handle> is-markup?) - :autoload (skribilo lib) (skribe-warning) + :autoload (skribilo reader) (%default-reader) + :autoload (skribilo parameters) (*bib-path*) + :autoload (skribilo ast) (<markup> <handle> is-markup?) + :autoload (skribilo lib) (skribe-warning) + :autoload (skribilo biblio author)(short-author-names) :use-module (ice-9 optargs) :use-module (oop goops) @@ -45,6 +46,9 @@ bib-load! resolve-bib resolve-the-bib make-bib-entry + ;; entry labels + assign-entries-numbers! assign-entries-name+years! + ;; sorting entries bib-sort/authors bib-sort/idents bib-sort/dates @@ -290,6 +294,11 @@ fields) m)) + +;;; +;;; Sorting. +;;; + ;*---------------------------------------------------------------------*/ ;* bib-sort/authors ... */ ;*---------------------------------------------------------------------*/ @@ -381,23 +390,88 @@ (m2 (month-num d2))) (> m1 m2)))))))))))))) + +;;; +;;; Bibliography creation and entry name assignment. +;;; + +(define (assign-entries-numbers! entries) + ;; Traverse `&bib-entry' markups in ENTRIES and add them a `:title' option + ;; whose content is a `&bib-entry-ident' markup suitable numbered. + (let loop ((es entries) + (i 1)) + (if (pair? es) + (begin + (markup-option-add! (car es) + :title + (make <markup> + :markup '&bib-entry-ident + :parent (car es) + :options `((number ,i)) + :body (make <handle> :ast (car es)))) + (loop (cdr es) (+ i 1)))))) + +(define (assign-entries-name+years! entries) + ;; Assign name+year-style labels to bibliography entries in ENTRIES (a list + ;; of `&bib-entry' markups. Such labels will look like this: "[Smith + ;; 1984]", "[Smith & Johnson 1979]", "[Smith et al. 1980]". + + (define %letters + '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r +#\s #\t #\u #\v #\w #\x #\y #\z #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K +#\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) + + (define (assign-label! entry label) + (markup-option-add! entry :title + (make <markup> + :markup '&bib-entry-ident + :parent entry + :options `((number ,label)) + :body (make <handle> :ast entry)))) + + (let ((name+year-table (make-hash-table))) + ;; Construct NAME+YEAR-TABLE such that keys are name+year labels and + ;; values are a list of matching entries. + (let loop ((entries entries)) + (if (pair? entries) + (let* ((e (car entries)) + (author (markup-body (markup-option e 'author))) + (name (if (string? author) + (short-author-names author) + author)) + (year (let ((m (markup-option e 'year))) + (and (markup? m) (markup-body m)))) + (name+year (list name " " year))) + (let ((same-named (hash-create-handle! name+year-table + name+year '()))) + (set-cdr! same-named (cons e (cdr same-named))) + (loop (cdr entries)))))) + + ;; Actually assign labels to entries. When there are several entries per + ;; author-year tuple (e.g., several "[Smith et al. 1984]"), they are + ;; assigned distinguishing labels by adding a letter at the end of the + ;; label (e.g., "[Smith et al. 1984a]"). + (hash-for-each (lambda (name+year entries) + (if (null? (cdr entries)) + (assign-label! (car entries) name+year) + (let loop ((entries (reverse! entries)) + (letters %letters)) + (if (not (null? entries)) + (let ((letter (string (car letters)))) + ;; Disambiguate same-named entries. + (assign-label! (car entries) + (append name+year + (list letter))) + (loop (cdr entries) + (cdr letters))))))) + name+year-table))) + ;*---------------------------------------------------------------------*/ ;* resolve-the-bib ... */ ;*---------------------------------------------------------------------*/ -(define (resolve-the-bib table n sort pred count opts) - (define (count! entries) - (let loop ((es entries) - (i 1)) - (if (pair? es) - (begin - (markup-option-add! (car es) - :title - (make <markup> - :markup '&bib-entry-ident - :parent (car es) - :options `((number ,i)) - :body (make <handle> :ast (car es)))) - (loop (cdr es) (+ i 1)))))) +(define* (resolve-the-bib table n sort pred count opts + :optional (assign-entries-identifiers! + assign-entries-numbers!)) (if (not (bib-table? table)) (raise (condition (&invalid-argument-error (proc-name "resolve-the-bib") @@ -407,7 +481,13 @@ (lambda (m) (pred m n)) (lambda (m) (pair? (markup-option m 'used)))) es))) - (count! (if (eq? count 'full) es fes)) + + ;; XXX: Assigning identifiers through side-effects is somewhat + ;; broken since it precludes the production of more several + ;; bibliographies with different styles in a single document (e.g., + ;; the user manual cannot illustrate more than one style). + (assign-entries-identifiers! (if (eq? count 'full) es fes)) + (make <markup> :markup '&the-bibliography :options opts diff --git a/src/guile/skribilo/biblio/author.scm b/src/guile/skribilo/biblio/author.scm index ea15f4c..c1883ee 100644 --- a/src/guile/skribilo/biblio/author.scm +++ b/src/guile/skribilo/biblio/author.scm @@ -1,6 +1,6 @@ ;;; author.scm -- Handling author names. ;;; -;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2006, 2007 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -25,6 +25,7 @@ :autoload (skribilo ast) (markup-option markup-body markup-ident) :autoload (skribilo lib) (skribe-error) :autoload (skribilo utils strings) (make-string-replace) + :autoload (skribilo package base) (it) :export (comma-separated->author-list comma-separated->and-separated-authors @@ -32,6 +33,7 @@ abbreviate-author-first-names abbreviate-first-names first-author-last-name + short-author-names bib-sort/first-author-last-name)) @@ -112,6 +114,21 @@ (loop (substring first-author (+ space 1) (string-length first-author))))))) +(define (short-author-names authors) + ;; Given AUTHORS (a string containing a comma-separated author list), + ;; return author markup suitable for use as a bibliography identifier. For + ;; instance, "Smith", "Smith & Johnson", "Smith et al.". + (let ((authors (comma-separated->author-list authors))) + (if (null? (cdr authors)) + (first-author-last-name (car authors)) + (if (null? (cddr authors)) + (string-append (first-author-last-name (car authors)) + " & " + (first-author-last-name (cadr authors))) + (list (first-author-last-name (car authors)) " " + (it " et al.")))))) + + (define (bib-sort/first-author-last-name entries) ;; May be passed as the `:sort' argument of `the-bibliography'. (let ((check-author (lambda (e) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 4648217..e00d213 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -1,6 +1,7 @@ ;;; lout.scm -- A Lout engine. ;;; -;;; Copyright 2004, 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2004, 2005, 2006, 2007 +;;; Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -21,6 +22,8 @@ ;;; Taken from `lcourtes@laas.fr--2004-libre', ;;; `skribe-lout--main--0.2--patch-15'. ;;; Based on `latex.skr', copyright 2003, 2004 Manuel Serrano. +;;; +;;; For more information on Lout, see http://lout.sf.net/ . (define-skribe-module (skribilo engine lout) @@ -518,8 +521,10 @@ (let ((ident1 (markup-option entry1 :title)) (ident2 (markup-option entry2 :title))) (if (and (markup? ident1) (markup? ident2)) - (< (markup-option ident1 'number) - (markup-option ident2 'number)) + (let ((n1 (markup-option ident1 'number)) + (n2 (markup-option ident2 'number))) + (and (number? n1) (number? n2) + (< n1 n2))) (begin (fprint (current-error-port) "i1: " ident1 ", " entry1) (fprint (current-error-port) "i2: " ident2 ", " entry2))))) @@ -2532,7 +2537,7 @@ (output (car rs) e)) (if (pair? (cdr rs)) (begin - (display ",") + (display ", ") (loop (cdr rs))))))))) :after "]") @@ -2591,44 +2596,45 @@ ;*---------------------------------------------------------------------*/ (markup-writer '&the-bibliography :before (lambda (n e) - ;; Compute the length (in characters) of the longest entry label - ;; so that the label width of the list is adjusted. - (let loop ((entries (markup-body n)) - (label-width 0)) - (if (null? entries) - (begin - (display "\n# the-bibliography\n@LP\n") - ;; usually, the tag with be something like "[7]", hence - ;; the `+ 1' below (`[]' is narrower than 2f) - (printf "@TaggedList labelwidth { ~af }\n" - (+ 1 label-width))) - (loop (cdr entries) - (let ((entry-length - (let liip ((e (car entries))) - (cond - ((markup? e) - (cond ((is-markup? e '&bib-entry) - (liip (markup-option e :title))) - ((is-markup? e '&bib-entry-ident) - (liip (markup-option e 'number))) - (else - (liip (markup-body e))))) - ((string? e) - (string-length e)) - ((number? e) - (liip (number->string e))) - ((list? e) - (apply + (map liip e))) - (else 0))))) -; (fprint (current-error-port) -; "node=" (car entries) -; " body=" (markup-body (car entries)) -; " title=" (markup-option (car entries) -; :title) -; " len=" entry-length) - (if (> label-width entry-length) - label-width - entry-length)))))) + (display "\n# the-bibliography\n@LP\n") + + (case (markup-option n 'labels) + ((number) + ;; Compute the length (in characters) of the longest entry + ;; label so that the label width of the list is adjusted. + (let loop ((entries (markup-body n)) + (label-width 0)) + (if (null? entries) + ;; usually, the tag with be something like "[7]", hence + ;; the `+ 1' below (`[]' is narrower than 2f) + (printf "@TaggedList labelwidth { ~af }\n" + (+ 1 label-width)) + (loop (cdr entries) + (let ((entry-length + (let liip ((e (car entries))) + (cond + ((markup? e) + (cond ((is-markup? e '&bib-entry) + (liip (markup-option e :title))) + ((is-markup? e '&bib-entry-ident) + (liip (markup-option e 'number))) + (else + (liip (markup-body e))))) + ((string? e) + (string-length e)) + ((number? e) + (liip (number->string e))) + ((list? e) + (apply + (map liip e))) + (else 0))))) + + (if (> label-width entry-length) + label-width + entry-length)))))) + + (else ;; `name+year' and others. + (display "@TaggedList\n")))) + :after (lambda (n e) (display "\n@EndList # the-bibliography (end)\n"))) @@ -2637,13 +2643,25 @@ ;*---------------------------------------------------------------------*/ (markup-writer '&bib-entry :options '(:title) - :before "@TagItem " + + :before (lambda (n e) + (let ((ident (markup-option n :title))) + (if (is-markup? ident '&bib-entry-ident) + (let ((number (markup-option ident 'number))) + (cond ((number? number) + (display "@TagItem ")) + (else + ;; probably `name+year'-style. + (display "@DropTagItem ")))) + (display "@TagItem ")))) + :action (lambda (n e) (display " { ") (output n e (markup-writer-get '&bib-entry-label e)) (display " } { ") (output n e (markup-writer-get '&bib-entry-body e)) (display " }")) + :after "\n") ;*---------------------------------------------------------------------*/ diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm index 4725c06..3aae9bf 100644 --- a/src/guile/skribilo/package/base.scm +++ b/src/guile/skribilo/package/base.scm @@ -1326,20 +1326,29 @@ pred (bib-table (*bib-table*)) (sort bib-sort/authors) - (count 'partial)) + (count 'partial) + (labels 'number)) (if (not (memq count '(partial full))) (skribe-error 'the-bibliography - "Cound must be either `partial' or `full'" + "count must be either `partial' or `full'" count) - (new unresolved - (loc &invocation-location) - (proc (lambda (n e env) - (resolve-the-bib bib-table - (new handle (ast n)) - sort - pred - count - (the-options opts))))))) + (let ((label-proc (case labels + ((number) assign-entries-numbers!) + ((name+year) assign-entries-name+years!) + (else + (skribe-error + 'the-bibliography + "invalid label type" lables))))) + (new unresolved + (loc &invocation-location) + (proc (lambda (n e env) + (resolve-the-bib bib-table + (new handle (ast n)) + sort + pred + count + (the-options opts) + label-proc))))))) ;*---------------------------------------------------------------------*/ ;* make-index ... */ |