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