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