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

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

scbib documentation and bug fixes

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