diff options
Diffstat (limited to 'src/common/bib.scm')
| -rw-r--r-- | src/common/bib.scm | 192 |
1 files changed, 192 insertions, 0 deletions
diff --git a/src/common/bib.scm b/src/common/bib.scm new file mode 100644 index 0000000..b73c5f0 --- /dev/null +++ b/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))))) + |