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