diff options
Diffstat (limited to 'skr/base.skr')
| -rw-r--r-- | skr/base.skr | 464 |
1 files changed, 464 insertions, 0 deletions
diff --git a/skr/base.skr b/skr/base.skr new file mode 100644 index 0000000..ec987ec --- /dev/null +++ b/skr/base.skr @@ -0,0 +1,464 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/base.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jul 26 12:39:30 2003 */ +;* Last change : Wed Oct 27 11:24:20 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* BASE Skribe engine */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* base-engine ... */ +;*---------------------------------------------------------------------*/ +(define base-engine + (default-engine-set! + (make-engine 'base + :version 'plain + :symbol-table '(("iexcl" "!") + ("cent" "c") + ("lguillemet" "\"") + ("not" "!") + ("registered" "(r)") + ("degree" "o") + ("plusminus" "+/-") + ("micro" "o") + ("paragraph" "p") + ("middot" ".") + ("rguillemet" "\"") + ("iquestion" "?") + ("Agrave" "À") + ("Aacute" "A") + ("Acircumflex" "Â") + ("Atilde" "A") + ("Amul" "A") + ("Aring" "A") + ("AEligature" "AE") + ("Oeligature" "OE") + ("Ccedilla" "Ç") + ("Egrave" "È") + ("Eacute" "É") + ("Ecircumflex" "Ê") + ("Euml" "E") + ("Igrave" "I") + ("Iacute" "I") + ("Icircumflex" "Î") + ("Iuml" "I") + ("ETH" "D") + ("Ntilde" "N") + ("Ograve" "O") + ("Oacute" "O") + ("Ocurcumflex" "O") + ("Otilde" "O") + ("Ouml" "O") + ("times" "x") + ("Oslash" "O") + ("Ugrave" "Ù") + ("Uacute" "U") + ("Ucircumflex" "Û") + ("Uuml" "Ü") + ("Yacute" "Y") + ("agrave" "à") + ("aacute" "a") + ("acircumflex" "â") + ("atilde" "a") + ("amul" "a") + ("aring" "a") + ("aeligature" "æ") + ("oeligature" "oe") + ("ccedilla" "ç") + ("egrave" "è") + ("eacute" "é") + ("ecircumflex" "ê") + ("euml" "e") + ("igrave" "i") + ("iacute" "i") + ("icircumflex" "î") + ("iuml" "i") + ("ntilde" "n") + ("ograve" "o") + ("oacute" "o") + ("ocurcumflex" "o") + ("otilde" "o") + ("ouml" "o") + ("divide" "/") + ("oslash" "o") + ("ugrave" "ù") + ("uacute" "u") + ("ucircumflex" "û") + ("uuml" "ü") + ("yacute" "y") + ("ymul" "y") + ;; punctuation + ("bullet" ".") + ("ellipsis" "...") + ("<-" "<-") + ("<--" "<--") + ("uparrow" "^;") + ("->" "->") + ("-->" "-->") + ("downarrow" "v") + ("<->" "<->") + ("<-->" "<-->") + ("<+" "<+") + ("<=" "<=;") + ("<==" "<==") + ("Uparrow" "^") + ("=>" "=>") + ("==>" "==>") + ("Downarrow" "v") + ("<=>" "<=>") + ("<==>" "<==>") + ;; Mathematical operators + ("asterisk" "*") + ("angle" "<") + ("and" "^;") + ("or" "v") + ("models" "|=") + ("vdash" "|-") + ("dashv" "-|") + ("sim" "~") + ("mid" "|") + ("langle" "<") + ("rangle" ">") + ;; LaTeX + ("circ" "o") + ("top" "T") + ("lhd" "<") + ("rhd" ">") + ("parallel" "||"))))) + +;*---------------------------------------------------------------------*/ +;* mark ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'symbol + :action (lambda (n e) + (let* ((s (markup-body n)) + (c (assoc s (engine-symbol-table e)))) + (if (pair? c) + (display (cadr c)) + (output s e))))) + +;*---------------------------------------------------------------------*/ +;* unref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'unref + :options 'all + :action (lambda (n e) + (let* ((s (markup-option n :skribe)) + (k (markup-option n 'kind)) + (f (cond + (s + (format "?~a@~a " k s)) + (else + (format "?~a " k)))) + (msg (list f (markup-body n))) + (n (list "[" (color :fg "red" (bold msg)) "]"))) + (skribe-eval n e)))) + +;*---------------------------------------------------------------------*/ +;* &the-bibliography ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-bibliography + :before (lambda (n e) + (let ((w (markup-writer-get 'table e))) + (and (writer? w) (invoke (writer-before w) n e)))) + :action (lambda (n e) + (when (pair? (markup-body n)) + (for-each (lambda (i) (output i e)) (markup-body n)))) + :after (lambda (n e) + (let ((w (markup-writer-get 'table e))) + (and (writer? w) (invoke (writer-after w) n e))))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry + :options '(:title) + :before (lambda (n e) + (invoke (writer-before (markup-writer-get 'tr e)) n e)) + :action (lambda (n e) + (let ((wtc (markup-writer-get 'tc e))) + ;; the label + (markup-option-add! n :valign 'top) + (markup-option-add! n :align 'right) + (invoke (writer-before wtc) n e) + (output n e (markup-writer-get '&bib-entry-label e)) + (invoke (writer-after wtc) n e) + ;; the body + (markup-option-add! n :valign 'top) + (markup-option-add! n :align 'left) + (invoke (writer-before wtc) n e) + (output n e (markup-writer-get '&bib-entry-body)) + (invoke (writer-after wtc) n e))) + :after (lambda (n e) + (invoke (writer-after (markup-writer-get 'tr e)) n e))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-label ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-label + :options '(:title) + :before "[" + :action (lambda (n e) (output (markup-option n :title) e)) + :after "]") + +;*---------------------------------------------------------------------*/ +;* &bib-entry-body ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-body + :action (lambda (n e) + (define (output-fields descr) + (let loop ((descr descr) + (pending #f) + (armed #f)) + (cond + ((null? descr) + 'done) + ((pair? (car descr)) + (if (eq? (caar descr) 'or) + (let ((o1 (cadr (car descr)))) + (if (markup-option n o1) + (loop (cons o1 (cdr descr)) + pending + #t) + (let ((o2 (caddr (car descr)))) + (loop (cons o2 (cdr descr)) + pending + armed)))) + (let ((o (markup-option n (cadr (car descr))))) + (if o + (begin + (if (and pending armed) + (output pending e)) + (output (caar descr) e) + (output o e) + (if (pair? (cddr (car descr))) + (output (caddr (car descr)) e)) + (loop (cdr descr) #f #t)) + (loop (cdr descr) pending armed))))) + ((symbol? (car descr)) + (let ((o (markup-option n (car descr)))) + (if o + (begin + (if (and armed pending) + (output pending e)) + (output o e) + (loop (cdr descr) #f #t)) + (loop (cdr descr) pending armed)))) + ((null? (cdr descr)) + (output (car descr) e)) + ((string? (car descr)) + (loop (cdr descr) + (if pending pending (car descr)) + armed)) + (else + (skribe-error 'output-bib-fields + "Illegal description" + (car descr)))))) + (output-fields + (case (markup-option n 'kind) + ((techreport) + `(author " -- " (or title url documenturl) " -- " + number ", " institution ", " + address ", " month ", " year ", " + ("pp. " pages) ".")) + ((article) + `(author " -- " (or title url documenturl) " -- " + journal ", " volume "" ("(" number ")") ", " + address ", " month ", " year ", " + ("pp. " pages) ".")) + ((inproceedings) + `(author " -- " (or title url documenturl) " -- " + booktitle ", " series ", " ("(" number ")") ", " + address ", " month ", " year ", " + ("pp. " pages) ".")) + ((book) + '(author " -- " (or title url documenturl) " -- " + publisher ", " address + ", " month ", " year ", " ("pp. " pages) ".")) + ((phdthesis) + '(author " -- " (or title url documenturl) " -- " type ", " + school ", " address + ", " month ", " year".")) + ((misc) + '(author " -- " (or title url documenturl) " -- " + publisher ", " address + ", " month ", " year".")) + (else + '(author " -- " (or title url documenturl) " -- " + publisher ", " address + ", " month ", " year ", " ("pp. " pages) ".")))))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-ident ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-ident + :action (lambda (n e) + (output (markup-option n 'number) e))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-title + :action (lambda (n e) + (skribe-eval (bold (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-publisher ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-publisher + :action (lambda (n e) + (skribe-eval (it (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &the-index ... @label the-index@ */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-index + :options '(:column) + :before (lambda (n e) + (output (markup-option n 'header) e)) + :action (lambda (n e) + (define (make-mark-entry n fst) + (let ((l (tr :class 'index-mark-entry + (td :colspan 2 :align 'left + (bold (it (sf n))))))) + (if fst + (list l) + (list (tr (td :colspan 2)) l)))) + (define (make-primary-entry n p) + (let* ((note (markup-option n :note)) + (b (markup-body n)) + (c (if note + (list b + (it (list " (" note ")"))) + b))) + (when p + (markup-option-add! b :text + (list (markup-option b :text) + ", p.")) + (markup-option-add! b :page #t)) + (tr :class 'index-primary-entry + (td :colspan 2 :valign 'top :align 'left c)))) + (define (make-secondary-entry n p) + (let* ((note (markup-option n :note)) + (b (markup-body n)) + (bb (markup-body b))) + (cond + ((not (or bb (is-markup? b 'url-ref))) + (skribe-error 'the-index + "Illegal entry" + b)) + (note + (let ((r (if bb + (it (ref :class "the-index-secondary" + :handle bb + :page p + :text (if p + (list note ", p.") + note))) + (it (ref :class "the-index-secondary" + :url (markup-option b :url) + :page p + :text (if p + (list note ", p.") + note)))))) + (tr :class 'index-secondary-entry + (td :valign 'top :align 'right :width 1. " ...") + (td :valign 'top :align 'left r)))) + (else + (let ((r (if bb + (ref :class "the-index-secondary" + :handle bb + :page p + :text (if p " ..., p." " ...")) + (ref :class "the-index-secondary" + :url (markup-option b :url) + :page p + :text (if p " ..., p." " ..."))))) + (tr :class 'index-secondary-entry + (td :valign 'top :align 'right :width 1.) + (td :valign 'top :align 'left r))))))) + (define (make-column ie p) + (let loop ((ie ie) + (f #t)) + (cond + ((null? ie) + '()) + ((not (pair? (car ie))) + (append (make-mark-entry (car ie) f) + (loop (cdr ie) #f))) + (else + (cons (make-primary-entry (caar ie) p) + (append (map (lambda (x) + (make-secondary-entry x p)) + (cdar ie)) + (loop (cdr ie) #f))))))) + (define (make-sub-tables ie nc p) + (let* ((l (length ie)) + (w (/ 100. nc)) + (iepc (let ((d (/ l nc))) + (if (integer? d) + (inexact->exact d) + (+ 1 (inexact->exact (truncate d)))))) + (split (list-split ie iepc))) + (tr (map (lambda (ies) + (td :valign 'top :width w + (if (pair? ies) + (table :width 100. (make-column ies p)) + ""))) + split)))) + (let* ((ie (markup-body n)) + (nc (markup-option n :column)) + (loc (ast-loc n)) + (pref (eq? (engine-custom e 'index-page-ref) #t)) + (t (cond + ((null? ie) + "") + ((or (not (integer? nc)) (= nc 1)) + (table :width 100. + :&skribe-eval-location loc + :class "index-table" + (make-column ie pref))) + (else + (table :width 100. + :&skribe-eval-location loc + :class "index-table" + (make-sub-tables ie nc pref)))))) + (output (skribe-eval t e) e)))) + +;*---------------------------------------------------------------------*/ +;* &the-index-header ... */ +;* ------------------------------------------------------------- */ +;* The index header is only useful for targets that support */ +;* hyperlinks such as HTML. */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-index-header + :action (lambda (n e) #f)) + +;*---------------------------------------------------------------------*/ +;* &prog-line ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&prog-line + :before (lambda (n e) + (let ((n (markup-ident n))) + (if n (skribe-eval (it (list n) ": ") e)))) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* line-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'line-ref + :options '(:offset) + :action (lambda (n e) + (let ((o (markup-option n :offset)) + (n (markup-ident (handle-body (markup-body n))))) + (skribe-eval (it (if (integer? o) (+ o n) n)) e)))) + + + +;;;; A VIRER (mais handle-body n'est pas défini) +(markup-writer 'line-ref + :options '(:offset) + :action #f) |