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