scm/framework-tex.scm

   1 ;;;; framework-tex.scm --
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c)  2004 Han-Wen Nienhuys <hanwen@cs.uu.nl>
   6
   7 (define-module (scm framework-tex)
   8   #:export (output-framework-tex
   9             output-classic-framework-tex))
  10
  11 (use-modules (ice-9 regex)
  12              (ice-9 string-fun)
  13              (ice-9 format)
  14              (guile)
  15              (srfi srfi-13)
  16              (lily))
  17
  18 ;; FIXME: rename
  19 ;; what is bla supposed to do?  It breaks the default output terribly:
  20
  21 ;; \def\lilypondpaperbla$\backslash${$\backslash$}{bla$\backslash${$\backslash$}}%
  22 ;; \lyitem{089.5557}{-15.3109}{\hbox{\magfontUGQLomTVo{}bla$\backslash${$\backslash$}}}%
  23 ;; --jcn
  24 (define-public (sanitize-tex-string s)
  25   (if (ly:get-option 'safe)
  26       (regexp-substitute/global
  27        #f "\\\\"
  28        (regexp-substitute/global #f "([{}])" s 'pre  "\\" 1 'post )
  29        'pre "$\\backslash$" 'post)
  30       s))
  31
  32 (define (symbol->tex-key sym)
  33   (regexp-substitute/global
  34    #f "_" (sanitize-tex-string (symbol->string sym)) 'pre "X" 'post) )
  35
  36 (define (tex-number-def prefix key number)
  37   (string-append
  38    "\\def\\" prefix (symbol->tex-key key) "{" number "}%\n"))
  39
  40 (define-public (tex-font-command font)
  41   (string-append
  42    "magfont"
  43    (string-encode-integer
  44     (hashq (ly:font-filename font) 1000000))
  45    "m"
  46    (string-encode-integer
  47     (inexact->exact (round (* 1000 (ly:font-magnification font)))))))
  48
  49 (define (font-load-command paper font)
  50   (let* ((coding-alist (ly:font-encoding-alist font))
  51          (font-encoding (assoc-get 'output-name coding-alist)))
  52     (string-append
  53      "\\font\\lilypond" (tex-font-command font) "="
  54      (ly:font-filename font)
  55      " scaled "
  56      (ly:number->string (inexact->exact
  57                          (round (* 1000
  58                                    (ly:font-magnification font)
  59                                    (ly:paper-outputscale paper)))))
  60      "\n"
  61      "\\def\\" (tex-font-command font) "{%\n"
  62      ;; UGH.  Should be handled via alist.
  63      (if (or (equal? "Extended-TeX-Font-Encoding---Latin" font-encoding)
  64              (not font-encoding))
  65          "  \\lilypondfontencoding{T1}"
  66          "  ")
  67      "\\lilypond" (tex-font-command font)
  68      "}%\n")))
  69
  70 (define (define-fonts paper)
  71   (string-append
  72    ;; UGH. FIXME.
  73    "\\def\\lilypondpaperunit{mm}%\n"
  74    (tex-number-def "lilypondpaper" 'outputscale
  75                    (number->string (exact->inexact
  76                                     (ly:paper-outputscale paper))))
  77    (tex-string-def "lilypondpaper" 'papersize
  78                    (eval 'papersizename (ly:output-def-scope paper)))
  79    ;; paper/layout?
  80    (tex-string-def "lilypondpaper" 'inputencoding
  81                    (eval 'inputencoding (ly:output-def-scope paper)))
  82
  83    (apply string-append
  84           (map (lambda (x) (font-load-command paper x))
  85                (ly:paper-fonts paper)))))
  86
  87 (define (header-to-file fn key val)
  88   (set! key (symbol->string key))
  89   (if (not (equal? "-" fn))
  90       (set! fn (string-append fn "." key)))
  91   (display
  92    (format (_ "Writing header field `~a' to `~a'...")
  93            key
  94            (if (equal? "-" fn) "<stdout>" fn))
  95    (current-error-port))
  96   (if (equal? fn "-")
  97       (display val)
  98       (display val (open-file fn "w")))
  99   (newline (current-error-port))
 100   "")
 101
 102 (define (output-scopes scopes fields basename)
 103   (define (output-scope scope)
 104     (apply
 105      string-append
 106      (module-map
 107       (lambda (sym var)
 108         (let ((val (if (variable-bound? var) (variable-ref var) "")))
 109           (if (and (memq sym fields) (string? val))
 110               (header-to-file basename sym val))
 111           ""))
 112       scope)))
 113   (apply string-append (map output-scope scopes)))
 114
 115 (define (tex-string-def prefix key str)
 116   (if (equal? "" (sans-surrounding-whitespace (sanitize-tex-string str)))
 117       (string-append "\\let\\" prefix (symbol->tex-key key) "\\undefined%\n")
 118       (string-append "\\def\\" prefix (symbol->tex-key key)
 119                      "{" (sanitize-tex-string str) "}%\n")))
 120
 121 (define (header paper page-count classic?)
 122   (let ((scale (ly:output-def-lookup paper 'outputscale))
 123         (texpaper (string-append
 124                    (ly:output-def-lookup paper 'papersizename)
 125                    "paper"))
 126         (landscape? (eq? #t (ly:output-def-lookup paper 'landscape))))
 127     (string-append
 128      "% Generated by LilyPond "
 129      (lilypond-version) "\n"
 130      "% at " "time-stamp,FIXME" "\n"
 131      (if classic?
 132          (tex-string-def "lilypond" 'classic "1")
 133          "")
 134
 135      (if (ly:get-option 'safe)
 136          "\\nofiles\n"
 137          "")
 138
 139      (tex-string-def
 140       "lilypondpaper" 'linewidth
 141       (ly:number->string (* scale (ly:output-def-lookup paper 'linewidth))))
 142      "\\def\\lilyponddocumentclassoptions{"
 143      (sanitize-tex-string texpaper)
 144      (if landscape? ",landscape" "")
 145      "}%\n"
 146      (tex-string-def
 147       "lilypondpaper" 'interscoreline
 148       (ly:number->string
 149        (* scale (ly:output-def-lookup paper 'interscoreline)))))))
 150
 151 (define (header-end)
 152   (string-append
 153    "\\def\\scaletounit{ "
 154    (number->string (cond
 155                     ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 156                     ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 157                     (else (error "unknown unit" (ly:unit)))))
 158    " mul }%\n"
 159    "\\ifx\\lilypondstart\\undefined\n"
 160    "  \\input lilyponddefs\n"
 161    "\\fi\n"
 162    "\\lilypondstart\n"
 163    "\\lilypondspecial\n"
 164    "\\lilypondpostscript\n"))
 165
 166 (define (dump-page putter page last? with-extents?)
 167   (ly:outputter-dump-string
 168    putter
 169    (format "\\lybox{~a}{~a}{%\n"
 170            (if with-extents?
 171                (interval-start (ly:stencil-extent page X))
 172                0.0)
 173            (if with-extents?
 174                (- (interval-start (ly:stencil-extent page Y)))
 175                0.0)))
 176   (ly:outputter-dump-stencil putter page)
 177   (ly:outputter-dump-string
 178    putter
 179    (if last?
 180        "}%\n\\vfill\n"
 181        "}%\n\\vfill\n\\lilypondpagebreak\n")))
 182
 183 (define-public (output-framework outputter book scopes fields basename )
 184   (let* ((paper (ly:paper-book-paper book))
 185          (pages (ly:paper-book-pages book))
 186          (last-page (car (last-pair pages)))
 187          (with-extents
 188           (eq? #t (ly:output-def-lookup paper 'dump-extents))))
 189     (for-each
 190      (lambda (x)
 191        (ly:outputter-dump-string outputter x))
 192      (list
 193       (header paper (length pages) #f)
 194       (define-fonts paper)
 195       (header-end)))
 196     (ly:outputter-dump-string outputter "\\lilypondnopagebreak\n")
 197     (for-each
 198      (lambda (page)
 199        (dump-page outputter page (eq? last-page page) with-extents))
 200      pages)
 201     (ly:outputter-dump-string outputter "\\lilypondend\n")))
 202
 203 (define (dump-line putter line last?)
 204   (ly:outputter-dump-string
 205    putter
 206    (format "\\lybox{~a}{~a}{%\n"
 207            (ly:number->string
 208             (max 0 (interval-end (ly:paper-system-extent line X))))
 209            (ly:number->string
 210             (interval-length (ly:paper-system-extent line Y)))))
 211
 212   (ly:outputter-dump-stencil putter (ly:paper-system-stencil line))
 213   (ly:outputter-dump-string
 214    putter
 215    (if last?
 216        "}%\n"
 217        "}\\interscoreline\n")))
 218
 219 (define-public (output-classic-framework
 220                 outputter book scopes fields basename)
 221   (let* ((paper (ly:paper-book-paper book))
 222          (lines (ly:paper-book-systems book))
 223          (last-line (car (last-pair lines))))
 224     (for-each
 225      (lambda (x)
 226        (ly:outputter-dump-string outputter x))
 227      (list
 228       ;;FIXME
 229       (header paper (length lines) #f)
 230       "\\def\\lilypondclassic{1}%\n"
 231       (output-scopes scopes fields basename)
 232       (define-fonts paper)
 233       (header-end)))
 234
 235     (for-each
 236      (lambda (line) (dump-line outputter line (eq? line last-line))) lines)
 237     (ly:outputter-dump-string outputter "\\lilypondend\n")))
 238
 239 (define-public (output-preview-framework
 240                 outputter book scopes fields basename )
 241   (let* ((paper (ly:paper-book-paper book))
 242          (lines (ly:paper-book-systems book)))
 243     (for-each
 244      (lambda (x)
 245        (ly:outputter-dump-string outputter x))
 246      (list
 247       ;;FIXME
 248       (header paper (length lines) #f)
 249       "\\def\\lilypondclassic{1}%\n"
 250       (output-scopes scopes fields basename)
 251       (define-fonts paper)
 252       (header-end)))
 253
 254     (dump-line outputter (car lines) #t)
 255     (ly:outputter-dump-string outputter "\\lilypondend\n")))
 256
 257 (define-public (convert-to-pdf book name)
 258   (let* ((defs (ly:paper-book-paper book))
 259          (papersizename (ly:output-def-lookup defs 'papersizename)))
 260     (postscript->pdf (if (string? papersizename) papersizename "a4")
 261                      (string-append
 262                       (basename name ".tex")
 263                       ".ps"))))
 264
 265 (define-public (convert-to-png book name)
 266   (let* ((defs (ly:paper-book-paper book))
 267          (resolution (ly:output-def-lookup defs 'pngresolution)))
 268     (postscript->png
 269      (if (number? resolution)
 270          resolution
 271          (ly:get-option 'resolution))
 272      (string-append (basename name ".tex") ".ps"))))
 273
 274
 275 ;;
 276 ;; ugh  -   double check this. We are leaking
 277 ;; untrusted (user-settable) info to a command-line
 278 ;;
 279
 280
 281 (define-public (convert-to-ps book name)
 282   (let* ((paper (ly:paper-book-paper book))
 283          (preview? (string-contains name ".preview"))
 284          (papersizename (ly:output-def-lookup paper 'papersizename))
 285          (landscape? (eq? #t (ly:output-def-lookup paper 'landscape)))
 286          (base (basename name ".tex"))
 287          (cmd (string-append "dvips "
 288                              (if preview?
 289                                  " -E "
 290                                  (string-append
 291                                   " -t "
 292                                   (sanitize-command-option papersizename)))
 293
 294                              (if landscape?
 295                                  " -t landscape "
 296                                  " ")
 297                              "  -u+ec-mftrace.map -u+lilypond.map -Ppdf "
 298                              base)))
 299
 300     (let ((ps-name (string-append base ".ps")))
 301       (if (access? ps-name W_OK)
 302           (delete-file ps-name)))
 303     (if (not (ly:get-option 'verbose))
 304         (begin
 305           (format (current-error-port) (_ "Converting to `~a.ps'...") base)
 306           (newline (current-error-port))))
 307     (ly:system cmd)))
 308
 309 (define-public (convert-to-dvi book name)
 310   (let* ((curr-extra-mem
 311           (string->number
 312            (regexp-substitute/global
 313             #f " *%.*\n?"
 314             (ly:kpathsea-expand-variable "$extra_mem_top")
 315             'pre "" 'post)))
 316          (base (basename name ".tex"))
 317          (cmd (string-append
 318                "latex \\\\nonstopmode \\\\input " name)))
 319     (setenv "extra_mem_top" (number->string (max curr-extra-mem 1024000)))
 320     (let ((dvi-name (string-append base ".dvi")))
 321       (if (access? dvi-name W_OK)
 322           (delete-file dvi-name)))
 323     (if (not (ly:get-option 'verbose))
 324         (begin
 325           (format (current-error-port) (_ "Converting to `~a.dvi'...") base)
 326           (newline (current-error-port))))
 327
 328     ;; fixme: set in environment?
 329     (if (ly:get-option 'safe)
 330         (set! cmd (string-append "openout_any=p " cmd)))
 331
 332     (ly:system cmd)))
 333
 334 (define-public (convert-to-tex book name)
 335   #t)