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