Initial import of Skribe 1.2d.

Initial import of Skribe 1.2d.


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

1 files changed, 192 insertions, 0 deletions

diff --git a/skribe/src/common/bib.scm b/skribe/src/common/bib.scm
new file mode 100644
index 0000000..b73c5f0
--- /dev/null
+++ b/skribe/src/common/bib.scm
@@ -0,0 +1,192 @@
+;*=====================================================================*/
+;*    serrano/prgm/project/skribe/src/common/bib.scm                   */
+;*    -------------------------------------------------------------    */
+;*    Author      :  Manuel Serrano                                    */
+;*    Creation    :  Fri Dec  7 06:12:29 2001                          */
+;*    Last change :  Wed Jan 14 08:02:45 2004 (serrano)                */
+;*    Copyright   :  2001-04 Manuel Serrano                            */
+;*    -------------------------------------------------------------    */
+;*    Skribe Bibliography                                              */
+;*    -------------------------------------------------------------    */
+;*    Implementation: @label bib@                                      */
+;*    bigloo: @path ../bigloo/bib.bgl@                                 */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;*    bib-load! ...                                                    */
+;*---------------------------------------------------------------------*/
+(define (bib-load! table filename command)
+   (if (not (bib-table? table))
+       (skribe-error 'bib-load "Illegal bibliography table" table)
+       ;; read the file
+       (let ((p (skribe-open-bib-file filename command)))
+	  (if (not (input-port? p))
+	      (skribe-error 'bib-load "Can't open data base" filename)
+	      (unwind-protect
+		 (parse-bib table p)
+		 (close-input-port p))))))
+
+;*---------------------------------------------------------------------*/
+;*    resolve-bib ...                                                  */
+;*---------------------------------------------------------------------*/
+(define (resolve-bib table ident)
+   (if (not (bib-table? table))
+       (skribe-error 'resolve-bib "Illegal bibliography table" table)
+       (let* ((i (cond
+		    ((string? ident) ident)
+		    ((symbol? ident) (symbol->string ident))
+		    (else (skribe-error 'resolve-bib "Illegal ident" ident))))
+	      (en (hashtable-get table i)))
+	  (if (is-markup? en '&bib-entry)
+	      en
+	      #f))))
+
+;*---------------------------------------------------------------------*/
+;*    make-bib-entry ...                                               */
+;*---------------------------------------------------------------------*/
+(define (make-bib-entry kind ident fields from)
+   (let* ((m (new markup
+		(markup '&bib-entry)
+		(ident ident)
+		(options `((kind ,kind) (from ,from)))))
+	  (h (new handle
+		(ast m))))
+      (for-each (lambda (f)
+		   (if (and (pair? f)
+			    (pair? (cdr f))
+			    (null? (cddr f))
+			    (symbol? (car f)))
+		       (markup-option-add! m 
+					   (car f)
+					   (new markup
+					      (markup (symbol-append
+						       '&bib-entry-
+						       (car f)))
+					      (parent h)
+					      (body (cadr f))))
+		       (bib-parse-error f)))
+		fields)
+      m))
+
+;*---------------------------------------------------------------------*/
+;*    bib-sort/authors ...                                             */
+;*---------------------------------------------------------------------*/
+(define (bib-sort/authors l)
+   (define (cmp i1 i2 def)
+      (cond
+	 ((and (markup? i1) (markup? i2))
+	  (cmp (markup-body i1) (markup-body i2) def))
+	 ((markup? i1)
+	  (cmp (markup-body i1) i2 def))
+	 ((markup? i2)
+	  (cmp i1 (markup-body i2) def))
+	 ((and (string? i1) (string? i2))
+	  (if (string=? i1 i2)
+	      (def)
+	      (string<? i1 i2)))
+	 ((string? i1)
+	  #f)
+	 ((string? i2)
+	  #t)
+	 (else
+	  (def))))
+   (sort l (lambda (e1 e2)
+	      (cmp (markup-option e1 'author)
+		   (markup-option e2 'author)
+		   (lambda ()
+		      (cmp (markup-option e1 'year)
+			   (markup-option e2 'year)
+			   (lambda ()
+			      (cmp (markup-option e1 'title)
+				   (markup-option e2 'title)
+				   (lambda ()
+				      (cmp (markup-ident e1)
+					   (markup-ident e2)
+					   (lambda ()
+					      #t)))))))))))
+
+;*---------------------------------------------------------------------*/
+;*    bib-sort/idents ...                                              */
+;*---------------------------------------------------------------------*/
+(define (bib-sort/idents l)
+   (sort l (lambda (e f) (string<? (markup-ident e) (markup-ident f)))))
+
+;*---------------------------------------------------------------------*/
+;*    bib-sort/dates ...                                               */
+;*---------------------------------------------------------------------*/
+(define (bib-sort/dates l)
+   (sort l (lambda (p1 p2)
+	      (define (month-num m)
+		 (let ((body (markup-body m)))
+		    (if (not (string? body))
+			13
+			(let* ((s (if (> (string-length body) 3)
+				      (substring body 0 3)
+				      body))
+			       (sy (string->symbol (string-downcase body)))
+			       (c (assq sy '((jan . 1)
+					     (feb . 2)
+					     (mar . 3)
+					     (apr . 4)
+					     (may . 5)
+					     (jun . 6)
+					     (jul . 7)
+					     (aug . 8)
+					     (sep . 9)
+					     (oct . 10)
+					     (nov . 11)
+					     (dec . 12)))))
+			   (if (pair? c) (cdr c) 13)))))
+	      (let ((d1 (markup-option p1 'year))
+		    (d2 (markup-option p2 'year)))
+		 (cond
+		    ((not (markup? d1)) #f)
+		    ((not (markup? d2)) #t)
+		    (else
+		     (let ((y1 (markup-body d1))
+			   (y2 (markup-body d2)))
+			(cond
+			   ((string>? y1 y2) #t)
+			   ((string<? y1 y2) #f)
+			   (else
+			    (let ((d1 (markup-option p1 'month))
+				  (d2 (markup-option p2 'month)))
+			       (cond
+				  ((not (markup? d1)) #f)
+				  ((not (markup? d2)) #t)
+				  (else
+				   (let ((m1 (month-num d1))
+					 (m2 (month-num d2)))
+				      (> m1 m2))))))))))))))
+
+;*---------------------------------------------------------------------*/
+;*    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
+				    (new markup
+				       (markup '&bib-entry-ident)
+				       (parent (car es))
+				       (options `((number ,i)))
+				       (body (new handle
+						(ast (car es))))))
+		(loop (cdr es) (+ i 1))))))
+   (if (not (bib-table? table))
+       (skribe-error 'resolve-the-bib "Illegal bibliography table" table)
+       (let* ((es (sort (hashtable->list table)))
+	      (fes (filter (if (procedure? pred)
+			       (lambda (m) (pred m n))
+			       (lambda (m) (pair? (markup-option m 'used))))
+			   es)))
+	  (count! (if (eq? count 'full) es fes))
+	  (new markup
+	     (markup '&the-bibliography)
+	     (options opts)
+	     (body fes)))))
+