biblio: Implemented the `name+year' label style.

* src/guile/skribilo/biblio.scm: Use `biblio author'.
  (assign-entries-numbers!): New (formerly `count!' in `resolve-the-bib').
  (assign-entries-name+years!): New.
  (resolve-the-bib): New optional `assign-entries-identifiers!' argument.
  Use it.

* src/guile/skribilo/biblio/author.scm (short-author-names): New.

* src/guile/skribilo/engine/lout.scm (lout-bib-refs-sort/number): Accept
  non-number identifiers.
  (&the-bibliography): Use simply `@TaggedList' when a style other than
  `number' is used.
  (&bib-entry): Use `@DropTagItem' when the bibliography style is not
  `number'.

* src/guile/skribilo/package/base.scm (the-bibliography): New `:labels'
  option.  Pass the right label assignment function to `resolve-the-bib'.

--This line, and those below, will be ignored--
Files to commit:
   src/guile/skribilo/package/base.scm
   src/guile/skribilo/engine/lout.scm
   src/guile/skribilo/biblio.scm
   doc/user/bib.skb
   src/guile/skribilo/biblio/author.scm

This list might be incomplete or outdated if editing the log
message was not invoked from an up-to-date changes buffer!

git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-92

5 files changed, 245 insertions, 75 deletions

diff --git a/ChangeLog b/ChangeLog
index 5b9e57c..483198b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,52 @@
 # arch-tag: automatic-ChangeLog--skribilo@sv.gnu.org--2006/skribilo--devo--1.2
 #
 
+2007-05-04 13:47:41 GMT	Ludovic Court`es <ludovic.courtes@laas.fr>	patch-92
+
+    Summary:
+      biblio: Implemented the `name+year' label style.
+    Revision:
+      skribilo--devo--1.2--patch-92
+
+    * src/guile/skribilo/biblio.scm: Use `biblio author'.
+      (assign-entries-numbers!): New (formerly `count!' in `resolve-the-bib').
+      (assign-entries-name+years!): New.
+      (resolve-the-bib): New optional `assign-entries-identifiers!' argument.
+      Use it.
+    
+    * src/guile/skribilo/biblio/author.scm (short-author-names): New.
+    
+    * src/guile/skribilo/engine/lout.scm (lout-bib-refs-sort/number): Accept
+      non-number identifiers.
+      (&the-bibliography): Use simply `@TaggedList' when a style other than
+      `number' is used.
+      (&bib-entry): Use `@DropTagItem' when the bibliography style is not
+      `number'.
+    
+    * src/guile/skribilo/package/base.scm (the-bibliography): New `:labels'
+      option.  Pass the right label assignment function to `resolve-the-bib'.
+    
+    --This line, and those below, will be ignored--
+    Files to commit:
+       src/guile/skribilo/package/base.scm
+       src/guile/skribilo/engine/lout.scm
+       src/guile/skribilo/biblio.scm
+       doc/user/bib.skb
+       src/guile/skribilo/biblio/author.scm
+    
+    This list might be incomplete or outdated if editing the log
+    message was not invoked from an up-to-date changes buffer!
+
+    modified files:
+     ChangeLog src/guile/skribilo/biblio.scm
+     src/guile/skribilo/biblio/author.scm
+     src/guile/skribilo/engine/lout.scm
+     src/guile/skribilo/package/base.scm
+
+    new patches:
+     lcourtes@laas.fr--2006-libre/skribilo--devo--1.2--patch-51
+
+
 2007-05-04 13:46:55 GMT	Ludovic Court`es <ludovic.courtes@laas.fr>	patch-91
 
     Summary:
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 ...                                                   */