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 . override-coding)
  32   (let* ((name (ly:font-file-name font))
  33          (magnify (ly:font-magnification font)))
  34
  35     (string-append
  36      "magfont" (string-encode-integer (hashq  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                          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 #f))
  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 mul 0 translate 90 rotate\n"
 131                                  "")
 132                              "%%EndPageSetup\n"
 133
 134                              "start-page { "
 135                              "set-ps-scale-to-lily-scale "
 136                              "\n"))
 137   (ly:outputter-dump-stencil outputter page)
 138   (ly:outputter-dump-string outputter "} stop-system \nshowpage\n"))
 139
 140
 141 (define (supplies-or-needs paper load-fonts?)
 142   (define (extract-names font)
 143     (if (ly:pango-font? font)
 144         (map car (ly:pango-font-physical-fonts font))
 145         (list (ly:font-name font))))
 146
 147   (let* ((fonts (ly:paper-fonts paper))
 148          (names (apply append (map extract-names fonts)))
 149          )
 150
 151     (apply string-append
 152            (map (lambda (f)
 153                   (format
 154                    (if load-fonts?
 155                     "%%DocumentSuppliedResources: font ~a\n"
 156                     "%%DocumentNeededResources: font ~a\n")
 157                    f))
 158                 (uniq-list (sort names string<?))))))
 159
 160 (define (eps-header paper bbox load-fonts?)
 161     (string-append "%!PS-Adobe-2.0 EPSF-2.0\n"
 162                  "%%Creator: LilyPond\n"
 163                  "%%BoundingBox: "
 164                  (string-join (map ly:number->string bbox) " ") "\n"
 165                  "%%Orientation: "
 166                  (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 167                      "Landscape\n"
 168                      "Portrait\n")
 169                  (supplies-or-needs paper load-fonts?)
 170                  "%%EndComments\n"))
 171
 172 (define (page-header paper page-count load-fonts?)
 173   (string-append "%!PS-Adobe-3.0\n"
 174                  "%%Creator: LilyPond\n"
 175                  "%%Pages: " (number->string page-count) "\n"
 176                  "%%PageOrder: Ascend\n"
 177                  "%%Orientation: "
 178                  (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 179                      "Landscape\n"
 180                      "Portrait\n")
 181                  "%%DocumentPaperSizes: "
 182                  (ly:output-def-lookup paper 'papersizename) "\n"
 183                  (supplies-or-needs paper load-fonts?)
 184                  "%%EndComments\n"))
 185
 186 (define (procset file-name)
 187   (string-append
 188    (format
 189     "%%BeginResource: procset (~a) 1 0
 190 ~a
 191 %%EndResource
 192 "
 193     file-name (cached-file-contents file-name))))
 194
 195 (define (setup paper)
 196   (string-append
 197    "\n"
 198    "%%BeginSetup\n"
 199    (define-fonts paper)
 200    (output-variables paper)
 201    "init-lilypond-parameters\n"
 202    "%%EndSetup\n"))
 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                            (aname (string-append x ".pfa"))
 226                            (bname (string-append x ".pfb"))
 227                            (cff-file-name (ly:find-file cffname))
 228                            (a-file-name (ly:kpathsea-find-file aname))
 229                            (b-file-name (ly:kpathsea-find-file bname)))
 230                       (cond
 231                        ((and bare-file-name (string-match "\\.pfb" bare-file-name))
 232                         (ly:pfb->pfa bare-file-name))
 233                        ((and bare-file-name (string-match "\\.ttf" bare-file-name))
 234                         (ly:ttf->pfa bare-file-name))
 235                        (bare-file-name (cached-file-contents bare-file-name))
 236                        (cff-file-name  (cached-file-contents cff-file-name))
 237                        (a-file-name (ps-embed-pfa (cached-file-contents a-file-name) x 0))
 238                        (b-file-name (ps-embed-pfa (ly:pfb->pfa b-file-name) x 0))
 239                        (else
 240                         (ly:warn "cannot find CFF/PFA/PFB font ~S" x)
 241                         ""))))
 242                   (filter string? font-names))))
 243            pfas))
 244
 245   (display (procset "music-drawing-routines.ps") port)
 246   (display (procset "lilyponddefs.ps") port)
 247   (if load-fonts?
 248       (for-each (lambda (f) (display f port)) (load-fonts paper)))
 249   (display (setup paper) port))
 250
 251 (define-public (output-framework basename book scopes fields)
 252   (let* ((filename (format "~a.ps" basename))
 253          (outputter  (ly:make-paper-outputter filename "ps"))
 254          (paper (ly:paper-book-paper book))
 255          (pages (ly:paper-book-pages book))
 256          (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
 257          (page-number (1- (ly:output-def-lookup paper 'firstpagenumber)))
 258          (page-count (length pages))
 259          (port (ly:outputter-port outputter)))
 260
 261
 262     (display (page-header paper page-count #t) port)
 263     (write-preamble paper #t  port)
 264
 265     (for-each
 266      (lambda (page)
 267        (set! page-number (1+ page-number))
 268        (dump-page outputter page page-number page-count landscape?))
 269      pages)
 270
 271     (display "%%Trailer\n%%EOF\n" port)
 272     (ly:outputter-close outputter)
 273     (postprocess-output book framework-ps-module filename (ly:output-formats))
 274 ))
 275
 276 (if (not (defined? 'nan?))
 277     (define (nan? x) #f))
 278 (if (not (defined? 'inf?))
 279     (define (inf? x) #f))
 280
 281
 282 (define-public (dump-stencil-as-EPS paper dump-me filename load-fonts?)
 283   (define (mm-to-bp-box mmbox)
 284     (let*
 285         ((scale  (ly:output-def-lookup paper 'outputscale))
 286          (box (map
 287                (lambda (x)
 288                  (inexact->exact
 289                   (round (* x scale mm-to-bigpoint)))) mmbox)))
 290
 291     (list (car box) (cadr box)
 292           (max (1+ (car box)) (caddr box))
 293           (max (1+ (cadr box)) (cadddr box)))))
 294
 295   (let*
 296       ((outputter (ly:make-paper-outputter (format "~a.eps" filename)
 297                                            "ps"))
 298
 299        (port (ly:outputter-port outputter))
 300        (xext (ly:stencil-extent dump-me X))
 301        (yext (ly:stencil-extent dump-me Y))
 302
 303        (bbox
 304         (map
 305          (lambda (x)
 306            (if (or (nan? x) (inf? x))
 307                0.0 x))
 308          (list (car xext) (car yext)
 309                (cdr xext) (cdr yext))))
 310        (rounded-bbox (mm-to-bp-box bbox))
 311        (port (ly:outputter-port outputter))
 312        (header (eps-header paper rounded-bbox load-fonts?)))
 313
 314     (display header port)
 315     (write-preamble paper load-fonts? port)
 316     (display "start-system { set-ps-scale-to-lily-scale \n" port)
 317     (ly:outputter-dump-stencil outputter dump-me)
 318     (display "} stop-system\n%%Trailer\n%%EOF\n" port)
 319     (ly:outputter-close outputter)
 320     ))
 321
 322
 323 (define-public (output-preview-framework basename book scopes fields )
 324   (let* ((paper (ly:paper-book-paper book))
 325          (systems (ly:paper-book-systems book))
 326          (scale  (ly:output-def-lookup paper 'outputscale))
 327          (titles (take-while ly:paper-system-title? systems))
 328          (non-title (find (lambda (x)
 329                             (not (ly:paper-system-title? x))) systems))
 330          (dump-me
 331           (stack-stencils Y DOWN 0.0
 332                           (map ly:paper-system-stencil
 333                                (append titles (list non-title))))))
 334     (dump-stencil-as-EPS paper dump-me
 335                          (format "~a.preview" basename)
 336                          #t)))
 337
 338
 339
 340 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 341
 342 (define-public (convert-to-pdf book name)
 343   (let* ((defs (ly:paper-book-paper book))
 344          (papersizename (ly:output-def-lookup defs 'papersizename)))
 345
 346     (if (equal? name "-")
 347         (ly:warn "Can't convert <stdout> to PDF")
 348         (postscript->pdf (if (string? papersizename) papersizename "a4")
 349                          name))))
 350
 351 (define-public (convert-to-png book name)
 352   (let* ((defs (ly:paper-book-paper book))
 353          (resolution (ly:output-def-lookup defs 'pngresolution)))
 354
 355     (postscript->png (if (number? resolution) resolution
 356
 357                          (ly:get-option 'resolution))
 358                      name)))
 359
 360 (define-public (convert-to-dvi book name)
 361   (ly:warn "Can not generate DVI via the postscript back-end"))
 362
 363 (define-public (convert-to-tex book name)
 364   (ly:warn "Can not generate TeX via the postscript back-end"))
 365
 366 (define-public (convert-to-ps book name)
 367   #t)