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