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 (preamble paper load-fonts?)
 197   (define (load-fonts paper)
 198     (let* ((fonts (ly:paper-fonts paper))
 199            (all-font-names
 200             (map
 201              (lambda (font)
 202                (if (string? (ly:font-file-name font))
 203                    (list (ly:font-file-name font))
 204                    (ly:font-sub-fonts font)))
 205
 206              fonts))
 207            (font-names
 208             (uniq-list
 209              (sort (apply append all-font-names) string<?)))
 210            (pfas (map
 211                   (lambda (x)
 212                     (let* ((bare-file-name (ly:find-file x))
 213                            (cffname (string-append x ".cff"))
 214                            (aname (string-append x ".pfa"))
 215                            (bname (string-append x ".pfb"))
 216                            (cff-file-name (ly:find-file cffname))
 217                            (a-file-name (ly:kpathsea-find-file aname))
 218                            (b-file-name (ly:kpathsea-find-file bname)))
 219                       (cond
 220                        (bare-file-name (if (string-match "\\.pfb" bare-file-name)
 221                                            (ly:pfb->pfa bare-file-name)
 222                                            (ly:gulp-file bare-file-name)))
 223                        (cff-file-name (ps-embed-cff (ly:gulp-file cff-file-name) x 0))
 224                        (a-file-name (ly:gulp-file a-file-name))
 225                        (b-file-name (ly:pfb->pfa b-file-name))
 226                        (else
 227                         (ly:warn "cannot find CFF/PFA/PFB font ~S" x)
 228                         ""))))
 229                   (filter string? font-names))))
 230
 231       (string-join pfas "\n")))
 232
 233   (list
 234    (output-variables paper)
 235    (ly:gulp-file "music-drawing-routines.ps")
 236    (ly:gulp-file "lilyponddefs.ps")
 237    (if load-fonts?
 238        (load-fonts paper)
 239        "")
 240    (define-fonts paper)))
 241
 242 (define-public (output-framework basename book scopes fields )
 243   (let* ((filename (format "~a.ps" basename))
 244          (outputter  (ly:make-paper-outputter filename
 245                                               (ly:output-backend)))
 246          (paper (ly:paper-book-paper book))
 247          (pages (ly:paper-book-pages book))
 248          (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
 249          (page-number (1- (ly:output-def-lookup paper 'firstpagenumber)))
 250          (page-count (length pages)))
 251
 252     (for-each
 253      (lambda (x)
 254        (ly:outputter-dump-string outputter x))
 255      (cons
 256       (page-header paper page-count #t)
 257       (preamble paper #t)))
 258
 259     (for-each
 260      (lambda (page)
 261        (set! page-number (1+ page-number))
 262        (dump-page outputter page page-number page-count landscape?))
 263      pages)
 264
 265     (ly:outputter-dump-string outputter "%%Trailer\n%%EOF\n")
 266         (ly:outputter-close outputter)
 267     (postprocess-output book framework-ps-module filename (ly:output-formats))
 268 ))
 269
 270 (if (not (defined? 'nan?))
 271     (define (nan? x) #f))
 272 (if (not (defined? 'inf?))
 273     (define (inf? x) #f))
 274
 275 (define-public (output-preview-framework basename book scopes fields )
 276   (let* ((filename (format "~a.ps" basename))
 277          (outputter  (ly:make-paper-outputter filename
 278                                               (ly:output-backend)))
 279          (paper (ly:paper-book-paper book))
 280          (systems (ly:paper-book-systems book))
 281          (scale  (ly:output-def-lookup paper 'outputscale ))
 282          (titles (take-while ly:paper-system-title? systems))
 283          (non-title (find (lambda (x)
 284                             (not (ly:paper-system-title? x))) systems))
 285          (dump-me
 286           (stack-stencils Y DOWN 0.0
 287                           (map ly:paper-system-stencil
 288                                (append titles (list non-title)))))
 289          (xext (ly:stencil-extent dump-me X))
 290          (yext (ly:stencil-extent dump-me Y))
 291          (bbox
 292           (map
 293            (lambda (x)
 294              (if (or (nan? x) (inf? x))
 295                  0.0 x))
 296            (list (car xext) (car yext)
 297                  (cdr xext) (cdr yext)))               ))
 298
 299     (for-each
 300      (lambda (x)
 301        (ly:outputter-dump-string outputter x))
 302      (cons
 303       (eps-header paper
 304                   (map
 305                    (lambda (x)
 306                      (inexact->exact
 307                       (round (* x scale mm-to-bigpoint))))
 308                    bbox)
 309                   #t)
 310       (preamble paper #t)))
 311
 312
 313     (ly:outputter-dump-string outputter
 314                               (string-append "start-system { "
 315                                              "set-ps-scale-to-lily-scale "
 316                                              "\n"))
 317
 318     (ly:outputter-dump-stencil outputter dump-me)
 319     (ly:outputter-dump-string outputter "} stop-system\n%%Trailer\n%%EOF\n")
 320         (ly:outputter-close outputter)
 321     (postprocess-output book framework-ps-module filename
 322                         (ly:output-formats))
 323 ))
 324
 325
 326 (define-public (output-classic-framework
 327                 basename book scopes fields)
 328   (define paper (ly:paper-book-paper book))
 329   (define (dump-line outputter line)
 330     (let*
 331         ((dump-me (ly:paper-system-stencil line))
 332          (xext (ly:stencil-extent dump-me X))
 333          (yext (ly:stencil-extent dump-me Y))
 334          (scale  (ly:output-def-lookup paper 'outputscale))
 335          (bbox
 336           (map
 337            (lambda (x)
 338              (if (or (nan? x) (inf? x))
 339                  0.0 x))
 340            (list (car xext) (car yext)
 341                  (cdr xext) (cdr yext))))
 342          (header (eps-header paper
 343                              (map
 344                               (lambda (x)
 345                                 (inexact->exact
 346                                  (round (* x scale mm-to-bigpoint))))
 347                               bbox) #f)))
 348
 349       (for-each
 350        (lambda (str) (ly:outputter-dump-string outputter str))
 351        (cons
 352         header
 353         (preamble paper #f)))
 354
 355       (ly:outputter-dump-string outputter
 356                                 (string-append "start-system { "
 357                                                "set-ps-scale-to-lily-scale "
 358                                                "\n"))
 359
 360       (ly:outputter-dump-stencil outputter dump-me)
 361       (ly:outputter-dump-string outputter "} stop-system\n%%Trailer\n%%EOF\n")
 362       (ly:outputter-close outputter)))
 363
 364   (define (dump-lines lines count)
 365     (if (pair? lines)
 366         (let*
 367             ((outputter  (ly:make-paper-outputter (format "~a-~a.eps" basename count)
 368                                                   (ly:output-backend)))
 369              (line (car lines))
 370              (rest (cdr lines)))
 371           (dump-line outputter line)
 372           (dump-lines rest (1+ count))
 373           )))
 374
 375   (let* ((lines (ly:paper-book-systems book))
 376          (tex-port (open-output-file (format "~a.tex" basename)))
 377          (last-line (car (last-pair lines))))
 378
 379     (dump-lines lines 1)
 380     (for-each (lambda (c)
 381                 (display (format "\\includegraphics{~a-~a.eps}%\n"
 382                                  basename (1+ c)) tex-port))
 383               (iota (length lines))
 384               )))
 385
 386 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 387
 388 (define-public (convert-to-pdf book name)
 389   (let* ((defs (ly:paper-book-paper book))
 390          (papersizename (ly:output-def-lookup defs 'papersizename)))
 391
 392     (if (equal? name "-")
 393         (ly:warn "Can't convert <stdout> to PDF")
 394         (postscript->pdf (if (string? papersizename) papersizename "a4")
 395                          name))))
 396
 397 (define-public (convert-to-png book name)
 398   (let* ((defs (ly:paper-book-paper book))
 399          (resolution (ly:output-def-lookup defs 'pngresolution)))
 400
 401     (postscript->png (if (number? resolution) resolution
 402
 403                          (ly:get-option 'resolution))
 404                      name)))
 405
 406 (define-public (convert-to-dvi book name)
 407   (ly:warn "Can not generate DVI via the postscript back-end"))
 408
 409 (define-public (convert-to-tex book name)
 410   (ly:warn "Can not generate TeX via the postscript back-end"))
 411
 412 (define-public (convert-to-ps book name)
 413   #t)