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-system { "
 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 (ly:gulp-file 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"))
 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                                            (ly:gulp-file bare-file-name)))
 221                        (cff-file-name (ps-embed-cff (ly:gulp-file cff-file-name) x 0))
 222                        (a-file-name (ps-embed-pfa (ly:gulp-file 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
 240                                               (ly:output-backend)))
 241          (paper (ly:paper-book-paper book))
 242          (pages (ly:paper-book-pages book))
 243          (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
 244          (page-number (1- (ly:output-def-lookup paper 'firstpagenumber)))
 245          (page-count (length pages))
 246          (port (ly:outputter-port outputter)))
 247
 248
 249     (display (page-header paper page-count #t) port)
 250     (write-preamble paper #t  port)
 251
 252     (for-each
 253      (lambda (page)
 254        (set! page-number (1+ page-number))
 255        (dump-page outputter page page-number page-count landscape?))
 256      pages)
 257
 258     (display "%%Trailer\n%%EOF\n" port)
 259     (ly:outputter-close outputter)
 260     (postprocess-output book framework-ps-module filename (ly:output-formats))
 261 ))
 262
 263 (if (not (defined? 'nan?))
 264     (define (nan? x) #f))
 265 (if (not (defined? 'inf?))
 266     (define (inf? x) #f))
 267
 268 (define-public (output-preview-framework basename book scopes fields )
 269   (let* ((filename (format "~a.ps" basename))
 270          (outputter  (ly:make-paper-outputter filename
 271                                               (ly:output-backend)))
 272          (paper (ly:paper-book-paper book))
 273          (systems (ly:paper-book-systems book))
 274          (scale  (ly:output-def-lookup paper 'outputscale ))
 275          (titles (take-while ly:paper-system-title? systems))
 276          (non-title (find (lambda (x)
 277                             (not (ly:paper-system-title? x))) systems))
 278          (dump-me
 279           (stack-stencils Y DOWN 0.0
 280                           (map ly:paper-system-stencil
 281                                (append titles (list non-title)))))
 282          (xext (ly:stencil-extent dump-me X))
 283          (yext (ly:stencil-extent dump-me Y))
 284          (bbox
 285           (map
 286            (lambda (x)
 287              (if (or (nan? x) (inf? x))
 288                  0.0 x))
 289            (list (car xext) (car yext)
 290                  (cdr xext) (cdr yext))))
 291          (rounded-bbox
 292           (map
 293            (lambda (x)
 294              (inexact->exact
 295               (round (* x scale mm-to-bigpoint))))))
 296          (port (ly:outputter-port outputter))
 297           )
 298
 299
 300     (display (eps-header paper rounded-bbox #t) port)
 301     (write-preamble paper #t port)
 302     (display "start-system { set-ps-scale-to-lily-scale \n" port)
 303     (ly:outputter-dump-stencil outputter dump-me)
 304     (display outputter "} stop-system\n%%Trailer\n%%EOF\n" port)
 305     (ly:outputter-close outputter)
 306     (postprocess-output book framework-ps-module filename
 307                         (ly:output-formats))
 308 ))
 309
 310
 311 (define-public (output-classic-framework
 312                 basename book scopes fields)
 313   (define paper (ly:paper-book-paper book))
 314   (define (dump-line outputter line)
 315     (let*
 316         ((dump-me (ly:paper-system-stencil line))
 317          (xext (ly:stencil-extent dump-me X))
 318          (yext (ly:stencil-extent dump-me Y))
 319          (scale  (ly:output-def-lookup paper 'outputscale))
 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
 328           (map
 329            (lambda (x)
 330              (inexact->exact
 331               (round (* x scale mm-to-bigpoint)))) bbox))
 332          (port (ly:outputter-port outputter))
 333          (header (eps-header paper rounded-bbox #f)))
 334
 335     (display header port)
 336     (write-preamble paper #f port)
 337     (display "start-system { set-ps-scale-to-lily-scale \n" port)
 338     (ly:outputter-dump-stencil outputter dump-me)
 339     (display "} stop-system\n%%Trailer\n%%EOF\n" port)
 340     (ly:outputter-close outputter)))
 341
 342
 343   (define (dump-infinite-page lines)
 344     (let*
 345         ((outputter  (ly:make-paper-outputter (format "~a.eps" basename)
 346                                               (ly:output-backend)))
 347          (stencils (map ly:paper-system-stencil lines))
 348          (dump-me (stack-stencils Y DOWN 2.0 stencils))
 349          (xext (ly:stencil-extent dump-me X))
 350          (yext (ly:stencil-extent dump-me Y))
 351          (scale  (ly:output-def-lookup paper 'outputscale))
 352          (bbox
 353           (map
 354            (lambda (x)
 355              (if (or (nan? x) (inf? x))
 356                  0.0 x))
 357            (list (car xext) (car yext)
 358                  (cdr xext) (cdr yext))))
 359          (ps-bbox (map (lambda (x)
 360                          (inexact->exact
 361                           (round (* x scale mm-to-bigpoint))))
 362                        bbox))
 363
 364          (port (ly:outputter-port outputter))
 365          (header (eps-header paper ps-bbox #t)))
 366
 367       (display header port)
 368       (write-preamble paper #t port)
 369       (display "start-system { set-ps-scale-to-lily-scale \n" port)
 370       (ly:outputter-dump-stencil outputter dump-me)
 371       (display "} stop-system\n%%Trailer\n%%EOF\n" port)
 372       (ly:outputter-close outputter)))
 373
 374   (define (dump-lines lines count)
 375     (if (pair? lines)
 376         (let*
 377             ((outputter  (ly:make-paper-outputter (format "~a-~a.eps" basename count)
 378                                                   (ly:output-backend)))
 379              (line (car lines))
 380              (rest (cdr lines)))
 381           (dump-line outputter line)
 382           (dump-lines rest (1+ count))
 383           )))
 384
 385   (let* ((lines (ly:paper-book-systems book))
 386          (tex-system-port (open-output-file (format "~a-systems.tex" basename)))
 387          (texi-system-port (open-output-file (format "~a-systems.texi" basename)))
 388          (last-line (car (last-pair lines)))
 389          (pages (ly:paper-book-pages book))
 390          )
 391
 392     (dump-lines lines 1)
 393     (for-each (lambda (c)
 394                 (display (format "\\includegraphics{~a-~a.eps}%\n"
 395                                  basename (1+ c)) tex-system-port)
 396                 (display (format "@image{~a-~a}%\n"
 397                                  basename (1+ c)) texi-system-port)
 398
 399                 )
 400               (iota (length lines)))
 401
 402     (display "@c eof" texi-system-port)
 403     (display "% eof" tex-system-port)
 404     (dump-infinite-page lines))
 405     (postprocess-output book framework-ps-module (format "~a.eps" basename) (ly:output-formats)))
 406
 407 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 408
 409 (define-public (convert-to-pdf book name)
 410   (let* ((defs (ly:paper-book-paper book))
 411          (papersizename (ly:output-def-lookup defs 'papersizename)))
 412
 413     (if (equal? name "-")
 414         (ly:warn "Can't convert <stdout> to PDF")
 415         (postscript->pdf (if (string? papersizename) papersizename "a4")
 416                          name))))
 417
 418 (define-public (convert-to-png book name)
 419   (let* ((defs (ly:paper-book-paper book))
 420          (resolution (ly:output-def-lookup defs 'pngresolution)))
 421
 422     (postscript->png (if (number? resolution) resolution
 423
 424                          (ly:get-option 'resolution))
 425                      name)))
 426
 427 (define-public (convert-to-dvi book name)
 428   (ly:warn "Can not generate DVI via the postscript back-end"))
 429
 430 (define-public (convert-to-tex book name)
 431   (ly:warn "Can not generate TeX via the postscript back-end"))
 432
 433 (define-public (convert-to-ps book name)
 434   #t)