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