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