summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/guile/skribilo/biblio.scm120
-rw-r--r--src/guile/skribilo/biblio/author.scm19
-rw-r--r--src/guile/skribilo/engine/lout.scm104
-rw-r--r--src/guile/skribilo/package/base.scm31
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 ... */
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-01 08:18:37 +0000