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