Added biblio helpers (abbrev, author, BibTeX) taken from my `biblib.skr'.

git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-83

6 files changed, 306 insertions, 1 deletions

diff --git a/configure.ac b/configure.ac
index ff903ff..7a6d1a9 100644
--- a/configure.ac
+++ b/configure.ac
@@ -39,6 +39,7 @@ AC_OUTPUT([Makefile
 	   src/guile/skribilo/package/eq/Makefile
 	   src/guile/skribilo/skribe/Makefile
 	   src/guile/skribilo/coloring/Makefile
+	   src/guile/skribilo/biblio/Makefile
 	   doc/Makefile
 	   doc/user/Makefile
 	   doc/user/src/Makefile
diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am
index 6689d15..8c17711 100644
--- a/src/guile/skribilo/Makefile.am
+++ b/src/guile/skribilo/Makefile.am
@@ -7,4 +7,4 @@ dist_guilemodule_DATA = biblio.scm color.scm config.scm		\
 			writer.scm ast.scm location.scm		\
 			condition.scm
 
-SUBDIRS = utils reader engine package skribe coloring
+SUBDIRS = utils reader engine package skribe coloring biblio
diff --git a/src/guile/skribilo/biblio/Makefile.am b/src/guile/skribilo/biblio/Makefile.am
new file mode 100644
index 0000000..9442562
--- /dev/null
+++ b/src/guile/skribilo/biblio/Makefile.am
@@ -0,0 +1,4 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/biblio
+dist_guilemodule_DATA = bibtex.scm author.scm abbrev.scm
+
+## arch-tag: aeffaead-c3f0-47f3-a0b3-bb3e22da2657
diff --git a/src/guile/skribilo/biblio/abbrev.scm b/src/guile/skribilo/biblio/abbrev.scm
new file mode 100644
index 0000000..7b477d1
--- /dev/null
+++ b/src/guile/skribilo/biblio/abbrev.scm
@@ -0,0 +1,83 @@
+;;; abbrev.scm  --  Determining abbreviations.
+;;;
+;;; Copyright 2006  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
+;;; 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;; USA.
+
+(define-module (skribilo biblio abbrev)
+  :use-module (srfi srfi-13)
+  :autoload   (ice-9 regex) (regexp-substitute/global)
+  :export (is-abbreviation? is-acronym? abbreviate-word))
+
+;;; Author:  Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Heuristics to identify or generate abbreviations.
+;;;
+;;; Code:
+
+(define (is-abbreviation? str)
+  ;; Return #t if STR denotes an abbreviation or name initial.
+  (and (>= (string-length str) 2)
+       (char=? (string-ref str 1) #\.)))
+
+(define (is-acronym? str)
+  (string=? str (string-upcase str)))
+
+(define (abbreviate-word word)
+   (if (or (string=? "" word)
+	   (and (>= (string-length word) 3)
+		(string=? "and" (substring word 0 3)))
+	   (is-acronym? word))
+       word
+       (let ((dash (string-index word #\-))
+	     (abbr (string (string-ref word 0) #\.)))
+	  (if (not dash)
+	      abbr
+	      (string-append (string (string-ref word 0)) "-"
+			     (abbreviate-word
+			      (substring word (+ 1 dash)
+					 (string-length word))))))))
+
+(define (abbreviate-string subst title)
+  ;; Abbreviate common conference names within TITLE based on the SUBST list
+  ;; of regexp-substitution pairs.  This function also removes the
+  ;; abbreviation if it appears in parentheses right after the substitution
+  ;; regexp.  Example:
+  ;;
+  ;;   "Symposium on Operating Systems Principles (SOSP 2004)"
+  ;;
+  ;; yields
+  ;;
+  ;;   "SOSP"
+  ;;
+  (let loop ((title title)
+	     (subst subst))
+    (if (null? subst)
+	title
+	(let* ((abbr (cdar subst))
+	       (abbr-rexp (string-append "( \\(" abbr "[^\\)]*\\))?"))
+	       (to-replace (string-append (caar subst) abbr-rexp)))
+	  (loop (regexp-substitute/global #f to-replace title
+					  'pre abbr 'post)
+		(cdr subst))))))
+
+
+;;; arch-tag: 34e0c5bb-592f-467b-b59a-d6f7d130ae4e
+
+;;; abbrev.scm ends here
diff --git a/src/guile/skribilo/biblio/author.scm b/src/guile/skribilo/biblio/author.scm
new file mode 100644
index 0000000..c2b3e6d
--- /dev/null
+++ b/src/guile/skribilo/biblio/author.scm
@@ -0,0 +1,134 @@
+;;; author.scm  --  Handling author names.
+;;;
+;;; Copyright 2006  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
+;;; 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;; USA.
+
+(define-module (skribilo biblio author)
+  :use-module (srfi srfi-13)
+  :use-module (srfi srfi-14)
+  :use-module (skribilo biblio abbrev)
+  :autoload   (skribilo utils compat) (skribe-error)
+  :export (comma-separated->author-list
+	   comma-separated->and-separated-authors
+
+	   extract-first-author-name
+	   abbreviate-author-first-names
+	   abbreviate-first-names
+	   first-author-last-name
+
+	   bib-sort/first-author-last-name))
+
+;;; Author:  Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Heuristics to manipulate author names as strings.
+;;;
+;;; Code:
+
+(define (comma-separated->author-list authors)
+  ;; Return a list of strings where each individual string is an author
+  ;; name.  AUTHORS is a string representing a list of author names separated
+  ;; by a comma.
+
+  ;; XXX: I should use SRFI-13 instead.
+  (string-split authors #\,))
+
+(define (comma-separated->and-separated-authors authors)
+  ;; Take AUTHORS, a string containing comma-separated author names, and
+  ;; return a string where author names are separated by " and " (suitable
+  ;; for BibTeX).
+  (string-join (comma-separated->author-list authors)
+	       " and " 'infix))
+
+
+(define (extract-first-author-name names)
+   ;; Extract the name of the first author from string
+   ;; NAMES that is a comma-separated list of authors.
+   (let ((author-name-end (or (string-index names #\,)
+			      (string-length names))))
+      (substring names 0 author-name-end)))
+
+(define (abbreviate-author-first-names name)
+   ;; Abbreviate author first names
+   (let* ((components (string-split name #\space))
+	  (component-number (length components)))
+      (apply string-append
+	     (append
+	      (map (lambda (c)
+		      (string-append (abbreviate-word c) " "))
+		   (list-head components
+			      (- component-number 1)))
+	      (list-tail components (- component-number 1))))))
+
+(define (abbreviate-first-names names)
+   ;; Abbreviate first names in NAMES.  NAMES is supposed to be
+   ;; something like "Ludovic Courtès, Marc-Olivier Killijian".
+   (let loop ((names ((make-string-replace '((#\newline " ")
+					     (#\tab     " ")))
+		      names))
+	      (result ""))
+      (if (string=? names "")
+	  result
+	  (let* ((len (string-length names))
+		 (first-author-names-end (or (string-index names #\,)
+					     len))
+		 (first-author-names (substring names 0
+						first-author-names-end))
+		 (next (substring names
+				  (min (+ 1 first-author-names-end) len)
+				  len)))
+	     (loop next
+		   (string-append result
+				  (if (string=? "" result) "" ", ")
+				  (abbreviate-author-first-names
+				   first-author-names)))))))
+
+
+(define (first-author-last-name authors)
+  ;; Return a string containing exactly the last name of the first author.
+  ;; Author names in AUTHORS are assumed to be comma separated.
+  (let loop ((first-author (extract-first-author-name authors)))
+    (let ((space (string-index first-author #\space)))
+      (if (not space)
+	  first-author
+	  (loop (substring first-author (+ space 1)
+			   (string-length first-author)))))))
+
+(define (bib-sort/first-author-last-name entries)
+   ;; May be passed as the `:sort' argument of `the-bibliography'.
+   (let ((check-author (lambda (e)
+			  (if (not (markup-option e 'author))
+			      (skribe-error 'web
+					    "No author for this bib entry"
+					    (markup-ident e))
+			      #t))))
+      (sort entries
+	    (lambda (e1 e2)
+	    (let* ((x1 (check-author e1))
+		   (x2 (check-author e2))
+		   (a1 (first-author-last-name
+			(markup-body (markup-option e1 'author))))
+		   (a2 (first-author-last-name
+			(markup-body (markup-option e2 'author)))))
+	       (string-ci<=? a1 a2))))))
+
+
+;;; arch-tag: c9a1ef10-a2cd-4a06-bd35-fbdee1abf09a
+
+;;; author.scm ends here
diff --git a/src/guile/skribilo/biblio/bibtex.scm b/src/guile/skribilo/biblio/bibtex.scm
new file mode 100644
index 0000000..be5ed36
--- /dev/null
+++ b/src/guile/skribilo/biblio/bibtex.scm
@@ -0,0 +1,83 @@
+;;; bibtex.scm  --  Handling BibTeX references.
+;;;
+;;; Copyright 2006  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
+;;; 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;; USA.
+
+
+(define-module (skribilo biblio bibtex)
+  :autoload   (skribilo runtime)     (make-string-replace)
+  :autoload   (skribilo ast)         (markup-option ast->string)
+  :autoload   (skribilo engine)      (engine-filter find-engine)
+  :use-module (skribilo biblio author)
+  :use-module (srfi srfi-39)
+  :export     (print-as-bibtex-entry))
+
+;;; Author:  Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; A set of BibTeX tools, e.g., issuing a BibTeX entry from a `&bib-entry'
+;;; markup object.
+;;;
+;;; Code:
+
+(define *bibtex-author-filter*
+  ;; Defines how the `author' field is to be filtered.
+  (make-parameter comma-separated->and-separated-authors))
+
+(define (print-as-bibtex-entry entry)
+  "Display @code{&bib-entry} object @var{entry} as a BibTeX entry."
+  (let ((show-option (lambda (opt)
+		       (let* ((o (markup-option entry opt))
+			      (f (make-string-replace '((#\newline " "))))
+			      (g (if (eq? opt 'author)
+				     (lambda (a)
+				       ((*bibtex-author-filter*) (f a)))
+				     f)))
+			 (if (not o)
+			     #f
+			     `(,(symbol->string opt)
+			       " = \""
+			       ,(g (ast->string (markup-body o)))
+			       "\","))))))
+    (format #t "@~a{~a,~%"
+	    (markup-option entry 'kind)
+	    (markup-ident entry))
+    (for-each (lambda (opt)
+		(let* ((o (show-option opt))
+		       (tex-filter (engine-filter
+				    (find-engine 'latex)))
+		       (filter (lambda (n)
+				 (tex-filter (ast->string n))))
+		       (id (lambda (a) a)))
+		  (if o
+		      (display
+		       (apply string-append
+			      `(,@(map (if (eq? 'url opt)
+					   id filter)
+				       (cons "  " o))
+				"\n"))))))
+	      '(author institution title
+                booktitle journal number
+		year month url pages address publisher))
+    (display "}\n")))
+
+
+;;; arch-tag: 8b5913cc-9077-4e92-839e-c4c633b7bd46
+
+;;; bibtex.scm ends here