src/TeXmacs/progs/convert/latex/latex-tools.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : latex-tools.scm
   5 ;; DESCRIPTION : Routines for expansion of macros and preamble construction
   6 ;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
   7 ;;
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;;
  10 ;; This software falls under the GNU general public license version 3 or later.
  11 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
  12 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  13 ;;
  14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15
  16 (texmacs-module (convert latex latex-tools)
  17   (:use (convert latex latex-drd)
  18         (convert latex texout)))
  19
  20 (tm-define tmtex-use-catcodes? #t)
  21 (tm-define tmtex-use-macros? #f)
  22
  23 (define latex-language "english")
  24 (define latex-cyrillic-catcode? #f)
  25 (define latex-style "generic")
  26 (define latex-style-hyp 'generic-style%)
  27 (define latex-packages '())
  28 (define latex-amsthm-hyp 'no-amsthm-package%)
  29
  30 (define latex-uses-table (make-ahash-table))
  31 (define latex-catcode-table (make-ahash-table))
  32 (define latex-macro-table (make-ahash-table))
  33 (define latex-env-table (make-ahash-table))
  34 (define latex-preamble-table (make-ahash-table))
  35
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37 ;; Setting global parameters
  38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39
  40 (tm-define (latex-set-language lan)
  41   (set! latex-language lan)
  42   (set! latex-cyrillic-catcode?
  43         (in? lan '("bulgarian" "russian" "ukrainian"))))
  44
  45 (tm-define (latex-set-style sty)
  46   (set! latex-style sty)
  47   (set! latex-style-hyp (string->symbol (string-append sty "-style%"))))
  48
  49 (tm-define (latex-set-packages ps)
  50   (set! latex-packages ps)
  51   (when (in? "amsthm" ps)
  52     (set! latex-amsthm-hyp 'amsthm-package%)))
  53
  54 (tm-define (latex-book-style?)
  55   (in? latex-style '("book")))
  56
  57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58 ;; Catcode expansion
  59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60
  61 (define (latex-replace-catcode s)
  62   (or (if latex-cyrillic-catcode?
  63           (drd-ref cyrillic-catcodes% s)
  64           (drd-ref corkT1-to-latex-catcodes% s))
  65       s))
  66
  67 (tm-define (latex-expand-catcodes t)
  68   (:synopsis "Expand all catcodes in @t")
  69   (cond ((string? t)
  70          (with l (map string (string->list t))
  71            (apply string-append (map latex-replace-catcode l))))
  72         ((pair? t) (cons (car t) (map latex-expand-catcodes (cdr t))))
  73         (else t)))
  74
  75 (define (latex-expand-catcodes* t)
  76   (if tmtex-use-catcodes? t (latex-expand-catcodes t)))
  77
  78 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79 ;; Compute catcode definitions
  80 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81
  82 (define (latex-catcode-defs-char c)
  83   (let* ((s (list->string (list c)))
  84          (r (latex-replace-catcode s)))
  85     (if (!= r s) (ahash-set! latex-catcode-table s r))))
  86
  87 (define (latex-catcode-defs-sub doc)
  88   (cond ((string? doc) (for-each latex-catcode-defs-char (string->list doc)))
  89         ((list? doc) (for-each latex-catcode-defs-sub doc))))
  90
  91 (define (latex-catcode-def key im)
  92   (string-append "\\catcode`\\" key "=\\active \\def" key "{" im "}\n"))
  93
  94 (tm-define (latex-catcode-defs doc)
  95   (:synopsis "Return necessary catcode definitions for @doc")
  96   (set! latex-catcode-table (make-ahash-table))
  97   (latex-catcode-defs-sub doc)
  98   (let* ((l1 (ahash-table->list latex-catcode-table))
  99          (l2 (list-sort l1 (lambda (x y) (string<=? (car x) (car y)))))
 100          (l3 (map (lambda (x) (latex-catcode-def (car x) (cdr x))) l2)))
 101     (apply string-append l3)))
 102
 103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 104 ;; Macro and environment expansion
 105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 106
 107 (define (latex-substitute t args)
 108   (cond ((number? t) (list-ref args t))
 109         ((== t '---) (car args))
 110         ((func? t '!recurse 1)
 111          (latex-expand-macros (latex-substitute (cadr t) args)))
 112         ((func? t '!translate 1)
 113          (translate (cadr t) "english" latex-language))
 114         ((list? t) (map (cut latex-substitute <> args) t))
 115         (else t)))
 116
 117 (tm-define (latex-expand-macros t)
 118   (:synopsis "Expand all TeXmacs macros occurring in @t")
 119   (if (npair? t) t
 120       (let* ((head  (car t))
 121              (tail  (map latex-expand-macros (cdr t)))
 122              (body  (drd-ref latex-texmacs-macro% head
 123                              latex-style-hyp latex-amsthm-hyp))
 124              (arity (drd-ref latex-texmacs-arity% head
 125                              latex-style-hyp latex-amsthm-hyp))
 126              (env   (and (func? head '!begin)
 127                          (drd-ref latex-texmacs-environment% (cadr head)
 128                                   latex-style-hyp latex-amsthm-hyp)))
 129              (envar (and (func? head '!begin)
 130                          (drd-ref latex-texmacs-env-arity% (cadr head)
 131                                   latex-style-hyp latex-amsthm-hyp))))
 132         (cond ((and body (== (length tail) arity))
 133                (latex-substitute body t))
 134               ((and env (== (length tail) 1) (== (length (cddr head)) envar))
 135                (latex-substitute env (append (cdr t) (cddr head))))
 136               (else (cons head tail))))))
 137
 138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 139 ;; Compute macro and environment definitions
 140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 141
 142 (define (latex-expand-def t)
 143   (cond ((== t '---) "#-#-#")
 144         ((number? t) (string-append "#" (number->string t)))
 145         ((func? t '!recurse 1) (latex-expand-def (cadr t)))
 146         ((func? t '!translate 1) (translate (cadr t) "english" latex-language))
 147         ((list? t) (map latex-expand-def t))
 148         (else t)))
 149
 150 (define (latex-macro-defs-sub t)
 151   (when (pair? t)
 152     (for-each latex-macro-defs-sub (cdr t))
 153     (let* ((body  (drd-ref latex-texmacs-macro% (car t)
 154                            latex-style-hyp latex-amsthm-hyp))
 155            (arity (drd-ref latex-texmacs-arity% (car t)
 156                            latex-style-hyp latex-amsthm-hyp)))
 157       (when (and body (== (length t) (+ arity 1)))
 158         (ahash-set! latex-macro-table (car t)
 159                     (list arity (latex-expand-def body)))
 160         (latex-macro-defs-sub body)))
 161     (let* ((body  (and (func? (car t) '!begin)
 162                        (drd-ref latex-texmacs-environment% (cadar t))))
 163            (arity (and (func? (car t) '!begin)
 164                        (drd-ref latex-texmacs-env-arity% (cadar t)))))
 165       (when (and body (== (length (cddar t)) arity))
 166         (ahash-set! latex-env-table (cadar t)
 167                     (list arity (latex-expand-def body)))
 168         (latex-macro-defs-sub body)))
 169     (with body (or (drd-ref latex-texmacs-preamble% (car t)
 170                             latex-style-hyp latex-amsthm-hyp)
 171                    (and (func? (car t) '!begin)
 172                         (drd-ref latex-texmacs-env-preamble% (cadar t)
 173                                  latex-style-hyp latex-amsthm-hyp)))
 174       (when body
 175         (ahash-set! latex-preamble-table (car t) body)))))
 176
 177 (define (latex<=? x y)
 178   (if (symbol? x) (set! x (symbol->string x)))
 179   (if (symbol? y) (set! y (symbol->string y)))
 180   (if (func? x '!begin) (set! x (cadr x)))
 181   (if (func? y '!begin) (set! y (cadr y)))
 182   (string<=? x y))
 183
 184 (tm-define (latex-macro-defs t)
 185   (:synopsis "Return necessary macro and environment definitions for @doc")
 186   (set! latex-macro-table (make-ahash-table))
 187   (set! latex-env-table (make-ahash-table))
 188   (set! latex-preamble-table (make-ahash-table))
 189   (latex-macro-defs-sub t)
 190   (let* ((c1 (ahash-table->list latex-macro-table))
 191          (c2 (list-sort c1 (lambda (x y) (latex<=? (car x) (car y)))))
 192          (c3 (map (cut cons '!newcommand <>) c2))
 193          (e1 (ahash-table->list latex-env-table))
 194          (e2 (list-sort e1 (lambda (x y) (latex<=? (car x) (car y)))))
 195          (e3 (map (cut cons '!newenvironment <>) e2))
 196          (p1 (ahash-table->list latex-preamble-table))
 197          (p2 (list-sort p1 (lambda (x y) (latex<=? (car x) (car y)))))
 198          (p3 (map cdr (map latex-expand-def p2))))
 199     (cons '!append (append c3 e3 p3))))
 200
 201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 202 ;; Serialization of TeXmacs preambles
 203 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 204
 205 (define (latex-macro-def name arity body)
 206   (set! body (serialize-latex (latex-expand-def body)))
 207   (set! body (string-replace body "\n\n" "*/!!/*"))
 208   (set! body (string-replace body "\n" " "))
 209   (set! body (string-replace body "*/!!/*" "\n\n"))
 210   (string-append "\\newcommand{\\" (symbol->string name) "}"
 211                  (if (= arity 0) ""
 212                      (string-append "[" (number->string arity) "]"))
 213                  "{" body "}\n"))
 214
 215 (define (latex-env-def name arity body)
 216   (set! body (serialize-latex (latex-expand-def body)))
 217   (set! body (string-replace body "\n\n" "*/!!/*"))
 218   (set! body (string-replace body "\n  " " "))
 219   (set! body (string-replace body "\n" " "))
 220   (set! body (string-replace body "   #-#-# " "}{"))
 221   (set! body (string-replace body "#-#-# " "}{"))
 222   (set! body (string-replace body "#-#-#" "}{"))
 223   (set! body (string-replace body "*/!!/*" "\n\n"))
 224   (string-append "\\newenvironment{" name "}"
 225                  (if (= arity 0) ""
 226                      (string-append "[" (number->string arity) "]"))
 227                  "{" body "}\n"))
 228
 229 (tm-define (latex-serialize-preamble t)
 230   (:synopsis "Serialize a LaTeX preamble @t")
 231   (cond ((string? t) t)
 232         ((func? t '!append)
 233          (apply string-append (map latex-serialize-preamble (cdr t))))
 234         ((func? t '!newcommand 3) (apply latex-macro-def (cdr t)))
 235         ((func? t '!newenvironment 3) (apply latex-env-def (cdr t)))
 236         (else (serialize-latex t))))
 237
 238 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 239 ;; Compute usepackage command for a document
 240 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 241
 242 (define (latex-command-uses s)
 243   (with packlist (drd-ref-list latex-needs% s)
 244     (when packlist
 245       (for-each (cut ahash-set! latex-uses-table <> #t) packlist))))
 246
 247 (define (latex-use-which-package l)
 248   (when (and (list? l) (nnull? l))
 249     (let ((x (car l)))
 250       (if (symbol? x) (latex-command-uses x))
 251       (if (and (list? x) (>= (length l) 2) (== (car x) '!begin))
 252           (latex-command-uses (string->symbol (cadr x))))
 253       (if (match? x '(!begin "enumerate" (!option :%1)))
 254           (ahash-set! latex-uses-table "enumerate" #t))
 255       (for-each latex-use-which-package (cdr l)))))
 256
 257 (define (latex-use-package-compare l r)
 258   (let* ((tl (drd-ref latex-package-priority% l))
 259          (tr (drd-ref latex-package-priority% r))
 260          (vl (if tl tl 999999))
 261          (vr (if tr tr 999999)))
 262     (< vl vr)))
 263
 264 (define (latex-as-use-package l1)
 265   (let* ((l2 (sort l1 latex-use-package-compare))
 266          (l3 (map force-string l2))
 267          (l4 (list-intersperse l3 ","))
 268          (s  (apply string-append l4)))
 269     (if (== s "") "" (string-append "\\usepackage{" s "}\n"))))
 270
 271 (tm-define (latex-use-package-command doc)
 272   (:synopsis "Return the usepackage command for @doc")
 273   (set! latex-uses-table (make-ahash-table))
 274   (latex-use-which-package doc)
 275   (let* ((l1 latex-packages)
 276          (s1 (latex-as-use-package (list-difference l1 '("amsthm"))))
 277          (l2 (map car (ahash-table->list latex-uses-table)))
 278          (s2 (latex-as-use-package (list-difference l2 l1))))
 279     (string-append s1 s2)))
 280
 281 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 282 ;; Page size settings
 283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 284
 285 (define (latex-preamble-language lan)
 286   (if (drd-ref latex-preamble-language-def% lan)
 287       (string-append (drd-ref latex-preamble-language-def% lan) "\n")
 288       ""))
 289
 290 (define (latex-preamble-page-type init)
 291   (let* ((page-type (ahash-ref init "page-type"))
 292          (page-size (drd-ref latex-paper-type% page-type)))
 293     (if page-size `(!append (geometry ,page-size) "\n") "")))
 294
 295 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 296 ;; Building the preamble
 297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 298
 299 (tm-define (latex-preamble text style lan init)
 300   (:synopsis "Compute preamble for @text")
 301   (let* ((Expand       latex-expand-catcodes*)
 302          (Page         (Expand (latex-preamble-page-type init)))
 303          (Macro        (Expand (latex-macro-defs text)))
 304          (Text         (list '!tuple Page Macro text))
 305          (pre-language (latex-preamble-language lan))
 306          (pre-page     (latex-serialize-preamble Page))
 307          (pre-macro    (latex-serialize-preamble Macro))
 308          (pre-catcode  (latex-catcode-defs Text))
 309          (pre-uses     (latex-use-package-command Text)))
 310     (values
 311       (if (in? "amsthm" latex-packages) "[amsthm]" "")
 312       (string-append pre-uses)
 313       (string-append pre-page)
 314       (string-append pre-language pre-catcode pre-macro))))