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