scm/framework-ps.scm

   1 ;;;; framework-ps.scm --
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c)  2004 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"
  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   (apply string-append
  87          (map (lambda (x) (font-load-command x))
  88               (filter (lambda (x) (not (ly:pango-font? x)))
  89                       font-list))))
  90
  91 ;; FIXME: duplicated in other output backends
  92 ;; FIXME: silly interface name
  93 (define (output-variables layout)
  94   ;; FIXME: duplicates output-layout's scope-entry->string, mostly
  95   (define (value->string  val)
  96     (cond
  97      ((string? val) (string-append "(" val ")"))
  98      ((symbol? val) (symbol->string val))
  99      ((number? val) (number->string val))
 100      (else "")))
 101
 102   (define (output-entry ps-key ly-key)
 103     (string-append
 104      "/" ps-key " "
 105      (value->string (ly:output-def-lookup layout ly-key)) " def\n"))
 106
 107   (string-append
 108    "/lily-output-units "
 109      (number->string mm-to-bigpoint)
 110      " def %% millimeter\n"
 111    (output-entry "staff-line-thickness" 'linethickness)
 112    (output-entry "line-width" 'linewidth)
 113    (output-entry "paper-size" 'papersizename)
 114    (output-entry "staff-height" 'staffheight)   ;junkme.
 115    "/output-scale "
 116      (number->string (ly:output-def-lookup layout 'outputscale))
 117      " def\n"
 118    (output-entry "page-height" 'vsize)
 119    (output-entry "page-width" 'hsize)))
 120
 121 (define (dump-page outputter page page-number page-count landscape?)
 122   (ly:outputter-dump-string 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 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   (let* ((fonts (ly:paper-fonts paper)))
 141     (apply string-append
 142            (map (lambda (f)
 143                   (format
 144                    (if load-fonts?
 145                     "%%DocumentSuppliedResources: font ~a\n"
 146                     "%%DocumentNeededResources: font ~a\n")
 147                    (ly:font-name f)))
 148                 fonts))))
 149
 150 (define (eps-header paper bbox load-fonts?)
 151     (string-append "%!PS-Adobe-2.0 EPSF-2.0\n"
 152                  "%%Creator: creator time-stamp\n"
 153                  "%%BoundingBox: "
 154                  (string-join (map ly:number->string bbox) " ") "\n"
 155                  "%%Orientation: "
 156                  (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 157                      "Landscape\n"
 158                      "Portrait\n")
 159                  (supplies-or-needs paper load-fonts?)
 160                  "%%EndComments\n"))
 161
 162 (define (page-header paper page-count load-fonts?)
 163   (string-append "%!PS-Adobe-3.0\n"
 164                  "%%Creator: creator time-stamp\n"
 165                  "%%Pages: " (number->string page-count) "\n"
 166                  "%%PageOrder: Ascend\n"
 167                  "%%Orientation: "
 168                  (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 169                      "Landscape\n"
 170                      "Portrait\n")
 171                  "%%DocumentPaperSizes: "
 172                  (ly:output-def-lookup paper 'papersizename) "\n"
 173                  (supplies-or-needs paper load-fonts?)
 174                  "%%EndComments\n"))
 175
 176 (define (procset file-name)
 177   (string-append
 178    (format
 179     "%%BeginResource: procset (~a) 1 0
 180 ~a
 181 %%EndResource
 182 "
 183     file-name (cached-file-contents file-name))))
 184
 185 (define (setup paper)
 186   (string-append
 187    "\n"
 188    "%%BeginSetup\n"
 189    (define-fonts paper)
 190    (output-variables paper)
 191    "init-lilypond-parameters\n"
 192    "%%EndSetup\n"))
 193
 194 (define (write-preamble paper load-fonts? port)
 195   (define (load-fonts paper)
 196     (let* ((fonts (ly:paper-fonts paper))
 197            (all-font-names
 198             (map
 199              (lambda (font)
 200                (if (string? (ly:font-file-name font))
 201                    (list (ly:font-file-name font))
 202                    (ly:font-sub-fonts font)))
 203
 204              fonts))
 205            (font-names
 206             (uniq-list
 207              (sort (apply append all-font-names) string<?)))
 208            (pfas (map
 209                   (lambda (x)
 210                     (let* ((bare-file-name (ly:find-file x))
 211                            (cffname (string-append x ".cff.ps"))
 212                            (aname (string-append x ".pfa"))
 213                            (bname (string-append x ".pfb"))
 214                            (cff-file-name (ly:find-file cffname))
 215                            (a-file-name (ly:kpathsea-find-file aname))
 216                            (b-file-name (ly:kpathsea-find-file bname)))
 217                       (cond
 218                        (bare-file-name (if (string-match "\\.pfb" bare-file-name)
 219                                            (ly:pfb->pfa bare-file-name)
 220                                            (cached-file-contents bare-file-name)))
 221                        (cff-file-name  (cached-file-contents cff-file-name))
 222                        (a-file-name (ps-embed-pfa (cached-file-contents a-file-name) x 0))
 223                        (b-file-name (ps-embed-pfa (ly:pfb->pfa b-file-name) x 0))
 224                        (else
 225                         (ly:warn "cannot find CFF/PFA/PFB font ~S" x)
 226                         ""))))
 227                   (filter string? font-names))))
 228            pfas))
 229
 230
 231   (display (procset "music-drawing-routines.ps") port)
 232   (display (procset "lilyponddefs.ps") port)
 233   (if load-fonts?
 234       (for-each (lambda (f) (display f port)) (load-fonts paper)))
 235   (display (setup paper) port))
 236
 237 (define-public (output-framework basename book scopes fields)
 238   (let* ((filename (format "~a.ps" basename))
 239          (outputter  (ly:make-paper-outputter filename "ps"))
 240          (paper (ly:paper-book-paper book))
 241          (pages (ly:paper-book-pages book))
 242          (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
 243          (page-number (1- (ly:output-def-lookup paper 'firstpagenumber)))
 244          (page-count (length pages))
 245          (port (ly:outputter-port outputter)))
 246
 247
 248     (display (page-header paper page-count #t) port)
 249     (write-preamble paper #t  port)
 250
 251     (for-each
 252      (lambda (page)
 253        (set! page-number (1+ page-number))
 254        (dump-page outputter page page-number page-count landscape?))
 255      pages)
 256
 257     (display "%%Trailer\n%%EOF\n" port)
 258     (ly:outputter-close outputter)
 259     (postprocess-output book framework-ps-module filename (ly:output-formats))
 260 ))
 261
 262 (if (not (defined? 'nan?))
 263     (define (nan? x) #f))
 264 (if (not (defined? 'inf?))
 265     (define (inf? x) #f))
 266
 267
 268 (define-public (dump-stencil-as-EPS paper dump-me filename load-fonts?)
 269   (define (mm-to-bp-box mmbox)
 270     (let*
 271         ((scale  (ly:output-def-lookup paper 'outputscale))
 272          (box (map
 273                (lambda (x)
 274                  (inexact->exact
 275                   (round (* x scale mm-to-bigpoint)))) mmbox)))
 276
 277     (list (car box) (cadr box)
 278           (max (1+ (car box)) (caddr box))
 279           (max (1+ (cadr box)) (cadddr box)))))
 280
 281   (let*
 282       ((outputter (ly:make-paper-outputter (format "~a.eps" filename)
 283                                            "ps"))
 284
 285        (port (ly:outputter-port outputter))
 286        (xext (ly:stencil-extent dump-me X))
 287        (yext (ly:stencil-extent dump-me Y))
 288
 289        (bbox
 290         (map
 291          (lambda (x)
 292            (if (or (nan? x) (inf? x))
 293                0.0 x))
 294          (list (car xext) (car yext)
 295                (cdr xext) (cdr yext))))
 296        (rounded-bbox (mm-to-bp-box bbox))
 297        (port (ly:outputter-port outputter))
 298        (header (eps-header paper rounded-bbox load-fonts?)))
 299
 300     (display header port)
 301     (write-preamble paper load-fonts? port)
 302     (display "start-system { set-ps-scale-to-lily-scale \n" port)
 303     (ly:outputter-dump-stencil outputter dump-me)
 304     (display "} stop-system\n%%Trailer\n%%EOF\n" port)
 305     (ly:outputter-close outputter)
 306     ))
 307
 308
 309 (define-public (output-preview-framework basename book scopes fields )
 310   (let* ((outputter  (ly:make-paper-outputter filename
 311                                               "ps"))
 312          (paper (ly:paper-book-paper book))
 313          (systems (ly:paper-book-systems book))
 314          (scale  (ly:output-def-lookup paper 'outputscale ))
 315          (titles (take-while ly:paper-system-title? systems))
 316          (non-title (find (lambda (x)
 317                             (not (ly:paper-system-title? x))) systems))
 318          (dump-me
 319           (stack-stencils Y DOWN 0.0
 320                           (map ly:paper-system-stencil
 321                                (append titles (list non-title))))))
 322     (dump-stencil-as-EPS paper dump-me basename #t)))
 323
 324
 325
 326 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 327
 328 (define-public (convert-to-pdf book name)
 329   (let* ((defs (ly:paper-book-paper book))
 330          (papersizename (ly:output-def-lookup defs 'papersizename)))
 331
 332     (if (equal? name "-")
 333         (ly:warn "Can't convert <stdout> to PDF")
 334         (postscript->pdf (if (string? papersizename) papersizename "a4")
 335                          name))))
 336
 337 (define-public (convert-to-png book name)
 338   (let* ((defs (ly:paper-book-paper book))
 339          (resolution (ly:output-def-lookup defs 'pngresolution)))
 340
 341     (postscript->png (if (number? resolution) resolution
 342
 343                          (ly:get-option 'resolution))
 344                      name)))
 345
 346 (define-public (convert-to-dvi book name)
 347   (ly:warn "Can not generate DVI via the postscript back-end"))
 348
 349 (define-public (convert-to-tex book name)
 350   (ly:warn "Can not generate TeX via the postscript back-end"))
 351
 352 (define-public (convert-to-ps book name)
 353   #t)