src/TeXmacs/progs/bibtex/alpha.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : alpha.scm
   5 ;; DESCRIPTION : alpha style for BibTeX files
   6 ;; COPYRIGHT   : (C) 2010  David MICHEL
   7 ;;
   8 ;; This software falls under the GNU general public license version 3 or later.
   9 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
  10 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  11 ;;
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13
  14 (texmacs-module (bibtex alpha)
  15   (:use (bibtex bib-utils) (bibtex plain)))
  16
  17 (bib-define-style "alpha" "plain")
  18
  19 (define (format-label-year x)
  20   (let* ((y (bib-field x "year"))
  21          (l (string-length y)))
  22     (if (<= l 2) y (substring y (- l 2) l))))
  23
  24 (define (format-label-names a)
  25   (let* ((n (length a))
  26          (pre (cond
  27                 ((equal? n 2)
  28                  (with von (bib-purify (bib-abbreviate
  29                                         (list-ref (list-ref a 1) 2) "" ""))
  30                    (if (empty? von)
  31                        (bib-prefix (list-ref (list-ref a 1) 3) 3)
  32                        (string-append von (bib-prefix
  33                                            (list-ref (list-ref a 1) 3) 1)))))
  34                 (else
  35                   (with lab ""
  36                     (do
  37                         ((i 1 (+ 1 i)))
  38                         ((>= i (min n 5)))
  39                       (with von (bib-purify (bib-abbreviate
  40                                              (list-ref (list-ref a i) 2)
  41                                              "" ""))
  42                         (set! lab (string-append
  43                                    lab von (bib-prefix
  44                                             (list-ref (list-ref a i) 3) 1)))))
  45                     lab)))))
  46     (if (> n 5) (string-append pre "+") pre)))
  47
  48 (define (format-book-inbook-label n x)
  49   (with key (list-ref x 2)
  50     (if (bib-empty? x "author")
  51         (if (bib-empty? x "editor")
  52             (if (empty? key)
  53                 (number->string n)
  54                 (bib-prefix key 3))
  55             (format-label-names (bib-field x "editor")))
  56         (format-label-names (bib-field x "author")))))
  57
  58 (define (format-proceedings-misc-label ae n x)
  59   (with key (list-ref x 2)
  60     (if (bib-empty? x ae)
  61         (if (empty? key)
  62             (number->string n)
  63             (bib-prefix key 3))
  64         (format-label-names (bib-field x ae)))))
  65
  66 (define (format-label-prefix n x)
  67   (let* ((doctype (list-ref x 1))
  68          (pre (cond
  69                 ((or (equal? doctype "book") (equal? doctype "inbook"))
  70                  (format-book-inbook-label n x))
  71                 ((equal? doctype "proceedings")
  72                  (format-proceedings-misc-label "editor" n x))
  73                 (else (format-proceedings-misc-label "author" n x)))))
  74     (string-append pre (format-label-year x))))
  75
  76 (define bib-label-table `())
  77 (define bib-key-table `())
  78
  79 (tm-define (bib-preprocessing t)
  80   (:mode bib-alpha?)
  81   (set! bib-label-table (make-hash-table 100))
  82   (set! bib-key-table (make-hash-table 100))
  83   (do ((entry t (cdr entry)) (n 1 (+ n 1)))
  84       ((null? entry))
  85     (let* ((label (format-label-prefix 0 (car entry)))
  86            (num (hash-ref bib-label-table label)))
  87       (hash-set! bib-key-table (list-ref (car entry) 2) label)
  88       (if num
  89           (hash-set! bib-label-table label
  90                      (if (equal? num `()) `(1 2) `(,@num ,(+ 1 (length num)))))
  91           (hash-set! bib-label-table label `())))))
  92
  93 (define (format-label n x)
  94   (let* ((pre (hash-ref bib-key-table (list-ref x 2)))
  95          (num (hash-ref bib-label-table pre)))
  96     (if (null? num) pre
  97         (with n (car num)
  98           (hash-set! bib-label-table pre (cdr num))
  99           (string-append pre (string (integer->char (+ 96 n))))))))
 100
 101 (tm-define (format-bibitem n x)
 102   (:mode bib-alpha?)
 103   `(bibitem* ,(format-label n x)))
 104
 105 (define (invert-label l)
 106   (with invert (lambda (c)
 107                  (cond
 108                    ((char-upper-case? c) (char-downcase c))
 109                    ((char-lower-case? c) (char-upcase c))
 110                    (else c)))
 111     (string-map invert l)))
 112
 113 (tm-define (bib-sort-key x)
 114   (:mode bib-alpha?)
 115   (let ((label (hash-ref bib-key-table (list-ref x 2)))
 116         (lplain (bib-with-style "plain" bib-sort-key x)))
 117     (string-append (invert-label label) "    " lplain)))
 118