source: project/release/4/scbib/trunk/scbib.scm @ 15281

Last change on this file since 15281 was 15281, checked in by Ivan Raikov, 11 years ago

Initial import of scbib, a library for managing bibliographic data.

File size: 5.7 KB
Line 
1;;;
2;;; scbib - a bibliography management system
3;;;
4;;; Copyright (C) 2004 Satoru Takabayashi <satoru@namazu.org>
5;;;     All rights reserved.
6;;;     This is free software with ABSOLUTELY NO WARRANTY.
7;;;
8;;; You can redistribute it and/or modify it under the terms of
9;;; the Gauche's licence.
10;;;
11;;; Ported to Chicken Scheme and modified by Ivan Raikov.
12
13(module scbib
14
15  (scbib-db-person
16   scbib-db-publisher
17   scbib-db-journal
18   scbib-db-bib
19   scbib-find
20   scbib-values
21   scbib-value
22   scbib-load-db
23   scbib-load-db-from-port
24   scbib-load-db-all
25   scbib-load-path
26   scbib-match
27   scbib-get-authors
28   scbib-get-abbrev
29   scbib-print-abbrev-list
30   scbib-add-to-db!
31   )
32
33  (import scheme chicken srfi-1 regex extras files posix data-structures)
34
35;; DBs
36(define scbib-db-person    (make-parameter '()))
37(define scbib-db-publisher (make-parameter '()))
38(define scbib-db-journal   (make-parameter '()))
39(define scbib-db-bib       (make-parameter '()))
40
41(define scbib-load-path (make-parameter "."))
42
43(define (scbib-find query db)
44  (cond ((null? db)
45         #f)
46        ((query (car db))
47         (car db))
48        (else
49         (scbib-find query (cdr db)))))
50
51(define (scbib-values item name)
52  (let ((name (->string name)))
53    (cond ((null? item)
54           #f)
55          ((equal? (caar item) name)
56           (cdar item))
57          (else
58           (scbib-values (cdr item) name)))))
59
60(define (scbib-value item name)
61  (let ((val (scbib-values item name)))
62    (if val
63        (car val)
64        #f)))
65
66(define (scbib-add-to-db! item)
67  (let* ((db-type (car item))
68         (contents (cdr item)))
69    (case db-type
70      ((person) 
71       (scbib-db-person
72        (cons contents (scbib-db-person))))
73      ((publisher)
74       (scbib-db-publisher
75        (cons contents (scbib-db-publisher))))
76      ((journal)
77       (scbib-db-journal
78        (cons contents (scbib-db-journal))))
79      ((bib)
80       (scbib-db-bib
81          (cons contents (scbib-db-bib)))))))
82
83(define (scbib-load-db-from-port iport)
84  (let loop ()
85    (let ((item (read iport)))
86      (unless (eof-object? item)
87              (scbib-add-to-db! item)
88              (loop)))))
89
90(define (scbib-load-db file)
91  (let ((file (if (file-exists? file)
92                  file
93                  (make-pathname (scbib-load-path) file))))
94        (call-with-input-file file
95          (lambda (iport)
96            (scbib-load-db-from-port iport)))))
97
98(define (scbib-load-db-all)
99  (for-each (lambda (file) (scbib-load-db file))
100            (find-files (scbib-load-path) ".+.db$")))
101
102
103(define r1 (regexp "^([^a-z ]+) [^a-z ]+$"))
104(define r2 (regexp "^([^ ]+), [^ ]+$"))
105(define r3 (regexp "([^ ]+)( Jr\\.)$"))
106(define r4 (regexp "([^ ]+)$"))
107
108(define scbib-get-abbrev
109  (let ((abbrev-alist '()))
110    (lambda (bibitem . rest)
111      (let-optionals rest ((key-style #f))
112
113      (define (family-name name)
114        (cond ((string-search r1 name) => (lambda (m) (list-ref m 1)))
115              ((string-search r2 name) => (lambda (m) (list-ref m 1)))
116              ((string-search r3 name) => (lambda (m) (list-ref m 1)))
117              ((string-search r4 name) => (lambda (m) (list-ref m 1)))))
118
119      (define (generate-abbrev)
120        (let* ((authors (scbib-get-authors bibitem))
121               (author (if authors (car authors) #f))
122               (editor (scbib-value bibitem 'editor)))
123          (let ((author (family-name (or author
124                                         editor
125                                         "Anonymous")))
126                (year (or (scbib-value bibitem 'year) "XXXX")))
127            (or (and key-style (key-style author year))
128                (format #f "~a:~a" author year)))))
129
130      (let* ((abbrev-candidate
131              (or (scbib-value bibitem 'abbrev) (generate-abbrev)))
132             (abbrev-item (assoc abbrev-candidate abbrev-alist)))
133        (if abbrev-item 
134            (let ((count (cdr abbrev-item)))
135              (set-cdr! abbrev-item (+ count 1))
136              (string-append abbrev-candidate "-" 
137                             (number->string (+ count 1))))
138            (begin
139              (set! abbrev-alist 
140                    (cons (cons abbrev-candidate 1) abbrev-alist))
141              abbrev-candidate))))))
142  )
143
144(define (scbib-get-authors bibitem)
145  (let ((title (scbib-value bibitem 'title))
146        (original-title (scbib-value bibitem 'original-title)))
147    (if original-title 
148        ;; if the original title exists
149        (let ((original-bibitem
150               (scbib-find (lambda (x) 
151                             (equal? (car (scbib-values x 'title)) 
152                                     original-title)) 
153                           (scbib-db-bib))))
154          (append (scbib-values original-bibitem 'author)
155                  (let ((r (reverse (scbib-values bibitem 'author))))
156                    (reverse (cons (string-append (car r) " Ìõ")
157                                   (cdr r))))))
158        (scbib-values bibitem 'author))))
159
160(define (scbib-print-abbrev-list)
161  (for-each (lambda (bib) 
162              (format #t "~a\n" (scbib-value bib 'abbrev)))
163            (reverse (scbib-db-bib))))
164
165
166
167;; (scbib-match item bibtype: "book")
168;; (scbib-match item bibtype: "book" category: '(not "programming"))
169;; (scbib-match item bibtype: '(or "book" "article"))
170(define (scbib-match  #!key bibtype category subcategory)
171  (lambda (item)
172    (every (lambda (key value)
173             (or (eq? value #f)
174                 (let ((v (scbib-value item key)))
175                   (cond ((and (pair? value) (eq? (first value) 'not))
176                          (not (equal? v (second value))))
177                       ((and (pair? value) (eq? (first value) 'or))
178                        (any (lambda (vv) (equal? v vv))
179                             (cdr value)))
180                       (else
181                        (equal? v value))))
182                 ))
183           '(bibtype category subcategory)
184           (list bibtype category subcategory))))
185
186(define-datatype bibstyle bibstyle?
187  (BibNil)
188  (BibCons    (car bibstyle?) (cdr bibstyle?))
189  (BibText    (text string?))
190  (BibField   (extract procedure?))
191  (BibCond    (test procedure?) (consequent bibstyle?) (alternate bibstyle?)))
192
193)
Note: See TracBrowser for help on using the repository browser.