scm/framework-ps.scm

   1 ;;;; framework-ps.scm --
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2004--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
   6
   7 (define-module (scm framework-ps))
   8
   9 ;;; this is still too big a mess.
  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 framework-ps-module (current-module))
  20
  21 ;;(define pdebug stderr)
  22 (define (pdebug . rest) #f)
  23
  24 (define mm-to-bigpoint
  25   (/ 72 25.4))
  26
  27
  28 (define-public (ps-font-command font)
  29   (let* ((name (munge-lily-font-name (ly:font-file-name font)))
  30          (magnify (ly:font-magnification font)))
  31
  32     (string-append
  33      "magfont"
  34      (string-regexp-substitute "[ /%]" "_" name)
  35      "m" (string-encode-integer (inexact->exact (round (* 1000 magnify)))))))
  36
  37 (define (tex-font? fontname)
  38   (or
  39    (equal? (substring fontname 0 2) "cm")
  40    (equal? (substring fontname 0 2) "ec")))
  41
  42 (define (ps-embed-pfa body font-name version)
  43   (string-append
  44    (format
  45     "%%BeginResource: font ~a
  46 ~a
  47 %%EndResource\n"
  48     font-name body)))
  49
  50
  51 (define (define-fonts paper)
  52   (define font-list (ly:paper-fonts paper))
  53   (define (define-font command fontname scaling)
  54     (string-append
  55      "/" command " { /" fontname " findfont "
  56      (ly:number->string scaling) " output-scale div scalefont } bind def\n"))
  57
  58   (define (standard-tex-font? x)
  59     (or (equal? (substring x 0 2) "ms")
  60         (equal? (substring x 0 2) "cm")))
  61
  62   (define (font-load-command font)
  63     (let* ((specced-font-name (ly:font-name font))
  64            (fontname (if specced-font-name
  65                          (munge-lily-font-name specced-font-name)
  66                          (ly:font-file-name font)))
  67            (command (ps-font-command font))
  68
  69            ;; FIXME -- see (ps-font-command )
  70            (plain (ps-font-command font))
  71            (designsize (ly:font-design-size font))
  72            (magnification (* (ly:font-magnification font)))
  73            (ops (ly:output-def-lookup paper 'outputscale))
  74            (scaling (* ops magnification designsize)))
  75
  76       ;; Bluesky pfbs have UPCASE names (sigh.)
  77       ;; FIXME - don't support Bluesky?
  78       (if (standard-tex-font? fontname)
  79           (set! fontname (string-upcase fontname)))
  80       (if (equal? fontname "unknown")
  81           (display (list font fontname)))
  82       (define-font plain fontname scaling)))
  83
  84
  85   (apply string-append
  86          (map (lambda (x) (font-load-command x))
  87               (filter (lambda (x) (not (ly:pango-font? x)))
  88                       font-list))))
  89
  90 ;; FIXME: duplicated in other output backends
  91 ;; FIXME: silly interface name
  92 (define (output-variables layout)
  93   ;; FIXME: duplicates output-layout's scope-entry->string, mostly
  94   (define (value->string  val)
  95     (cond
  96      ((string? val) (string-append "(" val ")"))
  97      ((symbol? val) (symbol->string val))
  98      ((number? val) (number->string val))
  99      (else "")))
 100
 101   (define (output-entry ps-key ly-key)
 102     (string-append
 103      "/" ps-key " "
 104      (value->string (ly:output-def-lookup layout ly-key)) " def\n"))
 105
 106   (string-append
 107    "/lily-output-units "
 108      (number->string mm-to-bigpoint)
 109      " def %% millimeter\n"
 110    (output-entry "staff-line-thickness" 'linethickness)
 111    (output-entry "line-width" 'linewidth)
 112    (output-entry "paper-size" 'papersizename)
 113    (output-entry "staff-height" 'staffheight)   ;junkme.
 114    "/output-scale "
 115      (number->string (ly:output-def-lookup layout 'outputscale))
 116      " def\n"
 117    (output-entry "page-height" 'vsize)
 118    (output-entry "page-width" 'hsize)))
 119
 120 (define (dump-page outputter page page-number page-count landscape?)
 121   (ly:outputter-dump-string
 122    outputter
 123    (string-append
 124     "%%Page: "
 125     (number->string page-number) " " (number->string page-count) "\n"
 126
 127     "%%BeginPageSetup\n"
 128     (if landscape?
 129         "page-width output-scale lily-output-units mul mul 0 translate 90 rotate\n"
 130         "")
 131     "%%EndPageSetup\n"
 132
 133     "start-page { "
 134     "set-ps-scale-to-lily-scale "
 135     "\n"))
 136   (ly:outputter-dump-stencil outputter page)
 137   (ly:outputter-dump-string outputter "} stop-system \nshowpage\n"))
 138
 139 (define (supplies-or-needs paper load-fonts?)
 140   (define (extract-names font)
 141     (if (ly:pango-font? font)
 142         (map car (ly:pango-font-physical-fonts font))
 143         (list (munge-lily-font-name (ly:font-name font)))))
 144
 145   (let* ((fonts (ly:paper-fonts paper))
 146          (names (apply append (map extract-names fonts))))
 147
 148     (apply string-append
 149            (map (lambda (f)
 150                   (format
 151                    (if load-fonts?
 152                     "%%DocumentSuppliedResources: font ~a\n"
 153                     "%%DocumentNeededResources: font ~a\n")
 154                    f))
 155                 (uniq-list (sort names string<?))))))
 156
 157 (define (eps-header paper bbox load-fonts?)
 158   (string-append "%!PS-Adobe-2.0 EPSF-2.0\n"
 159                  "%%Creator: LilyPond\n"
 160                  "%%BoundingBox: "
 161                  (string-join (map ly:number->string bbox) " ") "\n"
 162                  "%%Orientation: "
 163                  (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 164                      "Landscape\n"
 165                      "Portrait\n")
 166                  (supplies-or-needs paper load-fonts?)
 167                  "%%EndComments\n"))
 168
 169 (define (page-header paper page-count load-fonts?)
 170   (string-append "%!PS-Adobe-3.0\n"
 171                  "%%Creator: LilyPond\n"
 172                  "%%Pages: " (number->string page-count) "\n"
 173                  "%%PageOrder: Ascend\n"
 174                  "%%Orientation: "
 175                  (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 176                      "Landscape\n"
 177                      "Portrait\n")
 178                  "%%DocumentPaperSizes: "
 179                  (ly:output-def-lookup paper 'papersizename) "\n"
 180                  (supplies-or-needs paper load-fonts?)
 181                  "%%EndComments\n"))
 182
 183 (define (procset file-name)
 184   (string-append
 185    (format
 186     "%%BeginResource: procset (~a) 1 0
 187 ~a
 188 %%EndResource
 189 "
 190     file-name (cached-file-contents file-name))))
 191
 192 (define (setup paper)
 193   (string-append
 194    "\n"
 195    "%%BeginSetup\n"
 196    (define-fonts paper)
 197    (output-variables paper)
 198    "init-lilypond-parameters\n"
 199    "%%EndSetup\n"))
 200
 201 (define-public (munge-lily-font-name name)
 202   (regexp-substitute/global #f "([eE]mmentaler|[aA]ybabtu)"
 203                             name 'pre "PFA" 1 'post))
 204
 205 (define (write-preamble paper load-fonts? port)
 206   (define (load-fonts paper)
 207     (let* ((fonts (ly:paper-fonts paper))
 208            (all-font-names
 209             (map
 210              (lambda (font)
 211                (cond
 212                 ((string? (ly:font-file-name font)) (list (ly:font-file-name font)))
 213                 ((ly:pango-font? font)
 214                  (map cdr  (ly:pango-font-physical-fonts font)))
 215                 (else (ly:font-sub-fonts font))))
 216
 217              fonts))
 218
 219            (font-names
 220             (uniq-list
 221              (sort (apply append all-font-names) string<?)))
 222            (pfas (map
 223                   (lambda (x)
 224                     (let* ((bare-file-name (ly:find-file x))
 225                            (cffname (string-append x ".cff.ps"))
 226                            (cff-file-name (ly:find-file cffname)))
 227
 228
 229                       (cond
 230                        ((and bare-file-name (string-match "\\.pfa" bare-file-name))
 231                         (cached-file-contents bare-file-name))
 232                        ((and bare-file-name (string-match "\\.pfb" bare-file-name))
 233                         (ly:pfb->pfa bare-file-name))
 234
 235                        ((string-match "([eE]mmentaler|[Aa]ybabtu)" x)
 236                         (cached-file-contents
 237                          (format "~a.pfa" (munge-lily-font-name x))))
 238
 239                        ((and bare-file-name
 240                             (string-match "\\.(otf|cff)" bare-file-name))
 241
 242                         ; replace with the CFF.ps, which lives in a
 243                         ; separate subdir.
 244                         (for-each (lambda (tup)
 245                                     (set! bare-file-name
 246                                           (string-regexp-substitute
 247                                            (car tup) (cdr tup) bare-file-name)))
 248                                   '(("/fonts/otf/" . "/ps/")
 249                                     ("/fonts/cff/" . "/ps/")
 250                                     ("\\.(otf|cff)" . ".cff.ps")))
 251
 252                         (cached-file-contents bare-file-name))
 253                        ((and bare-file-name (string-match "\\.ttf" bare-file-name))
 254                         (ly:ttf->pfa bare-file-name))
 255                        (bare-file-name (cached-file-contents bare-file-name))
 256                        (cff-file-name  (cached-file-contents cff-file-name))
 257                        (else
 258                         (ly:warning (_ "can't find CFF/PFA/PFB font ~S" x))
 259                         ""))))
 260                   (filter string? font-names))))
 261            pfas))
 262
 263   (display (procset "music-drawing-routines.ps") port)
 264   (display (procset "lilyponddefs.ps") port)
 265   (if load-fonts?
 266       (for-each (lambda (f) (display f port)) (load-fonts paper)))
 267   (display (setup paper) port))
 268
 269 (define-public (output-framework basename book scopes fields)
 270   (let* ((filename (format "~a.ps" basename))
 271          (outputter  (ly:make-paper-outputter filename "ps"))
 272          (paper (ly:paper-book-paper book))
 273          (pages (ly:paper-book-pages book))
 274          (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
 275          (page-number (1- (ly:output-def-lookup paper 'firstpagenumber)))
 276          (page-count (length pages))
 277          (port (ly:outputter-port outputter)))
 278
 279     (output-scopes scopes fields basename)
 280     (display (page-header paper page-count #t) port)
 281     (write-preamble paper #t  port)
 282
 283     (for-each
 284      (lambda (page)
 285        (set! page-number (1+ page-number))
 286        (dump-page outputter page page-number page-count landscape?))
 287      pages)
 288
 289     (display "%%Trailer\n%%EOF\n" port)
 290     (ly:outputter-close outputter)
 291     (postprocess-output book framework-ps-module filename
 292                          (completize-formats (ly:output-formats)))))
 293
 294 (if (not (defined? 'nan?))
 295     (define (nan? x) #f))
 296
 297 (if (not (defined? 'inf?))
 298     (define (inf? x) #f))
 299
 300 (define-public (dump-stencil-as-EPS paper dump-me filename load-fonts?)
 301   (define (mm-to-bp-box mmbox)
 302     (let* ((scale  (ly:output-def-lookup paper 'outputscale))
 303            (box (map
 304                  (lambda (x)
 305                    (inexact->exact
 306                     (round (* x scale mm-to-bigpoint)))) mmbox)))
 307
 308     (list (car box) (cadr box)
 309           (max (1+ (car box)) (caddr box))
 310           (max (1+ (cadr box)) (cadddr box)))))
 311
 312   (let* ((outputter (ly:make-paper-outputter (format "~a.eps" filename) "ps"))
 313          (port (ly:outputter-port outputter))
 314          (xext (ly:stencil-extent dump-me X))
 315          (yext (ly:stencil-extent dump-me Y))
 316          (bbox
 317           (map
 318            (lambda (x)
 319              (if (or (nan? x) (inf? x))
 320                  0.0 x))
 321            (list (car xext) (car yext)
 322                (cdr xext) (cdr yext))))
 323          (rounded-bbox (mm-to-bp-box bbox))
 324          (port (ly:outputter-port outputter))
 325          (header (eps-header paper rounded-bbox load-fonts?)))
 326
 327     (display header port)
 328     (write-preamble paper load-fonts? port)
 329     (display "start-system { set-ps-scale-to-lily-scale \n" port)
 330     (ly:outputter-dump-stencil outputter dump-me)
 331     (display "} stop-system\n%%Trailer\n%%EOF\n" port)
 332     (ly:outputter-close outputter)))
 333
 334 (define-public (output-preview-framework basename book scopes fields)
 335   (let* ((paper (ly:paper-book-paper book))
 336          (systems (ly:paper-book-systems book))
 337          (scale (ly:output-def-lookup paper 'outputscale))
 338          (titles (take-while ly:paper-system-title? systems))
 339          (non-title (find (lambda (x)
 340                             (not (ly:paper-system-title? x))) systems))
 341          (dump-me
 342           (stack-stencils Y DOWN 0.0
 343                           (map ly:paper-system-stencil
 344                                (append titles (list non-title))))))
 345     (output-scopes scopes fields basename)
 346     (dump-stencil-as-EPS paper dump-me
 347                          (format "~a.preview" basename)
 348                          #t)))
 349
 350 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 351
 352 (define-public (convert-to-pdf book name)
 353   (let* ((defs (ly:paper-book-paper book))
 354          (papersizename (ly:output-def-lookup defs 'papersizename)))
 355
 356     (if (equal? (basename name ".ps") "-")
 357         (ly:warning (_ "can't convert <stdout> to ~S" "PDF"))
 358         (postscript->pdf (if (string? papersizename) papersizename "a4")
 359                          name))))
 360
 361 (define-public (convert-to-png book name)
 362   (let* ((defs (ly:paper-book-paper book))
 363          (resolution (ly:output-def-lookup defs 'pngresolution))
 364          (papersizename (ly:output-def-lookup defs 'papersizename)))
 365
 366     (postscript->png (if (number? resolution) resolution
 367                          (ly:get-option 'resolution))
 368                      (if (string? papersizename) papersizename "a4")
 369                      name)))
 370
 371 (define-public (convert-to-dvi book name)
 372   (ly:warning (_ "can't generate ~S using the postscript back-end") "DVI"))
 373
 374 (define-public (convert-to-tex book name)
 375   (ly:warning (_ "can't generate ~S using the postscript back-end") "TeX"))
 376
 377 (define-public (convert-to-ps book name)
 378   #t)