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