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