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    "%%EndSetup\n"))
 199
 200 (define-public (munge-lily-font-name name)
 201   (regexp-substitute/global #f "([eE]mmentaler|[aA]ybabtu)"
 202                             name 'pre "PFA" 1 'post))
 203
 204 (define (write-preamble paper load-fonts? port)
 205   (define (load-fonts paper)
 206     (let* ((fonts (ly:paper-fonts paper))
 207            (all-font-names
 208             (map
 209              (lambda (font)
 210                (cond
 211                 ((string? (ly:font-file-name font)) (list (ly:font-file-name font)))
 212                 ((ly:pango-font? font)
 213                  (map cdr  (ly:pango-font-physical-fonts font)))
 214                 (else (ly:font-sub-fonts font))))
 215
 216              fonts))
 217
 218            (font-names
 219             (uniq-list
 220              (sort (apply append all-font-names) string<?)))
 221            (pfas (map
 222                   (lambda (x)
 223                     (let* ((bare-file-name (ly:find-file x))
 224                            (cffname (string-append x ".cff.ps"))
 225                            (cff-file-name (ly:find-file cffname)))
 226
 227
 228                       (cond
 229                        ((and bare-file-name (string-match "\\.pfa" bare-file-name))
 230                         (cached-file-contents bare-file-name))
 231                        ((and bare-file-name (string-match "\\.pfb" bare-file-name))
 232                         (ly:pfb->pfa bare-file-name))
 233
 234                        ((string-match "([eE]mmentaler|[Aa]ybabtu)" x)
 235                         (cached-file-contents
 236                          (format "~a.pfa" (munge-lily-font-name x))))
 237
 238                        ((and bare-file-name
 239                             (string-match "\\.(otf|cff)" bare-file-name))
 240
 241                         ; replace with the CFF.ps, which lives in a
 242                         ; separate subdir.
 243                         (for-each (lambda (tup)
 244                                     (set! bare-file-name
 245                                           (string-regexp-substitute
 246                                            (car tup) (cdr tup) bare-file-name)))
 247                                   '(("/fonts/otf/" . "/ps/")
 248                                     ("/fonts/cff/" . "/ps/")
 249                                     ("\\.(otf|cff)" . ".cff.ps")))
 250
 251                         (cached-file-contents bare-file-name))
 252                        ((and bare-file-name (string-match "\\.ttf" bare-file-name))
 253                         (ly:ttf->pfa bare-file-name))
 254                        (bare-file-name (cached-file-contents bare-file-name))
 255                        (cff-file-name  (cached-file-contents cff-file-name))
 256                        (else
 257                         (ly:warning (_ "can't find CFF/PFA/PFB font ~S" x))
 258                         ""))))
 259                   (filter string? font-names))))
 260            pfas))
 261
 262   (if load-fonts?
 263       (for-each (lambda (f) (display f port)) (load-fonts paper)))
 264   (display (setup paper) port)
 265
 266   ; adobe note 5002: should initialize variables before loading routines.
 267   (display (procset "music-drawing-routines.ps") port)
 268   (display (procset "lilyponddefs.ps") port)
 269   (display "init-lilypond-parameters\n" port)
 270
 271   )
 272
 273 (define-public (output-framework basename book scopes fields)
 274   (let* ((filename (format "~a.ps" basename))
 275          (outputter  (ly:make-paper-outputter filename "ps"))
 276          (paper (ly:paper-book-paper book))
 277          (pages (ly:paper-book-pages book))
 278          (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
 279          (page-number (1- (ly:output-def-lookup paper 'firstpagenumber)))
 280          (page-count (length pages))
 281          (port (ly:outputter-port outputter)))
 282
 283     (output-scopes scopes fields basename)
 284     (display (page-header paper page-count #t) port)
 285     (write-preamble paper #t  port)
 286
 287     (for-each
 288      (lambda (page)
 289        (set! page-number (1+ page-number))
 290        (dump-page outputter page page-number page-count landscape?))
 291      pages)
 292
 293     (display "%%Trailer\n%%EOF\n" port)
 294     (ly:outputter-close outputter)
 295     (postprocess-output book framework-ps-module filename
 296                          (completize-formats (ly:output-formats)))))
 297
 298 (if (not (defined? 'nan?))
 299     (define (nan? x) #f))
 300
 301 (if (not (defined? 'inf?))
 302     (define (inf? x) #f))
 303
 304 (define-public (dump-stencil-as-EPS paper dump-me filename load-fonts?)
 305   (define (mm-to-bp-box mmbox)
 306     (let* ((scale  (ly:output-def-lookup paper 'outputscale))
 307            (box (map
 308                  (lambda (x)
 309                    (inexact->exact
 310                     (round (* x scale mm-to-bigpoint)))) mmbox)))
 311
 312     (list (car box) (cadr box)
 313           (max (1+ (car box)) (caddr box))
 314           (max (1+ (cadr box)) (cadddr box)))))
 315
 316   (let* ((outputter (ly:make-paper-outputter (format "~a.eps" filename) "ps"))
 317          (port (ly:outputter-port outputter))
 318          (xext (ly:stencil-extent dump-me X))
 319          (yext (ly:stencil-extent dump-me Y))
 320          (bbox
 321           (map
 322            (lambda (x)
 323              (if (or (nan? x) (inf? x))
 324                  0.0 x))
 325            (list (car xext) (car yext)
 326                (cdr xext) (cdr yext))))
 327          (rounded-bbox (mm-to-bp-box bbox))
 328          (port (ly:outputter-port outputter))
 329          (header (eps-header paper rounded-bbox load-fonts?)))
 330
 331     (display header port)
 332     (write-preamble paper load-fonts? port)
 333     (display "start-system { set-ps-scale-to-lily-scale \n" port)
 334     (ly:outputter-dump-stencil outputter dump-me)
 335     (display "} stop-system\n%%Trailer\n%%EOF\n" port)
 336     (ly:outputter-close outputter)))
 337
 338 (define-public (output-preview-framework basename book scopes fields)
 339   (let* ((paper (ly:paper-book-paper book))
 340          (systems (ly:paper-book-systems book))
 341          (scale (ly:output-def-lookup paper 'outputscale))
 342          (titles (take-while ly:paper-system-title? systems))
 343          (non-title (find (lambda (x)
 344                             (not (ly:paper-system-title? x))) systems))
 345          (dump-me
 346           (stack-stencils Y DOWN 0.0
 347                           (map ly:paper-system-stencil
 348                                (append titles (list non-title))))))
 349     (output-scopes scopes fields basename)
 350     (dump-stencil-as-EPS paper dump-me
 351                          (format "~a.preview" basename)
 352                          #t)))
 353
 354 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 355
 356 (define-public (convert-to-pdf book name)
 357   (let* ((defs (ly:paper-book-paper book))
 358          (papersizename (ly:output-def-lookup defs 'papersizename)))
 359
 360     (if (equal? (basename name ".ps") "-")
 361         (ly:warning (_ "can't convert <stdout> to ~S" "PDF"))
 362         (postscript->pdf (if (string? papersizename) papersizename "a4")
 363                          name))))
 364
 365 (define-public (convert-to-png book name)
 366   (let* ((defs (ly:paper-book-paper book))
 367          (resolution (ly:output-def-lookup defs 'pngresolution))
 368          (papersizename (ly:output-def-lookup defs 'papersizename)))
 369
 370     (postscript->png (if (number? resolution) resolution
 371                          (ly:get-option 'resolution))
 372                      (if (string? papersizename) papersizename "a4")
 373                      name)))
 374
 375 (define-public (convert-to-dvi book name)
 376   (ly:warning (_ "can't generate ~S using the postscript back-end") "DVI"))
 377
 378 (define-public (convert-to-tex book name)
 379   (ly:warning (_ "can't generate ~S using the postscript back-end") "TeX"))
 380
 381 (define-public (convert-to-ps book name)
 382   #t)