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
 297     (for-each
 298      (lambda (x)
 299        (ly:outputter-dump-string outputter x))
 300      (cons
 301       (eps-header paper
 302                   (map
 303                    (lambda (x)
 304                      (inexact->exact
 305                       (round (* x scale mm-to-bigpoint))))
 306                    bbox)
 307                   #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          (header (eps-header paper
 341                              (map
 342                               (lambda (x)
 343                                 (inexact->exact
 344                                  (round (* x scale mm-to-bigpoint))))
 345                               bbox) #f)))
 346
 347       (for-each
 348        (lambda (str) (ly:outputter-dump-string outputter str))
 349        (cons
 350         header
 351         (preamble paper #f)))
 352
 353       (ly:outputter-dump-string outputter
 354                                 (string-append "start-system { "
 355                                                "set-ps-scale-to-lily-scale "
 356                                                "\n"))
 357
 358       (ly:outputter-dump-stencil outputter dump-me)
 359       (ly:outputter-dump-string outputter "} stop-system\n%%Trailer\n%%EOF\n")
 360       (ly:outputter-close outputter)))
 361
 362   (define (dump-lines lines count)
 363     (if (pair? lines)
 364         (let*
 365             ((outputter  (ly:make-paper-outputter (format "~a-~a.eps" basename count)
 366                                                   (ly:output-backend)))
 367              (line (car lines))
 368              (rest (cdr lines)))
 369           (dump-line outputter line)
 370           (dump-lines rest (1+ count))
 371           )))
 372
 373   (let* ((lines (ly:paper-book-systems book))
 374          (tex-system-port (open-output-file (format "~a-systems.tex" basename)))
 375 g        (last-line (car (last-pair lines))))
 376
 377     (dump-lines lines 1)
 378     (for-each (lambda (c)
 379                 (display (format "\\lilypondEpsGraphics{~a-~a.eps}%\n"
 380                                  basename (1+ c)) tex-system-port))
 381               (iota (length lines))
 382               )))
 383
 384 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 385
 386 (define-public (convert-to-pdf book name)
 387   (let* ((defs (ly:paper-book-paper book))
 388          (papersizename (ly:output-def-lookup defs 'papersizename)))
 389
 390     (if (equal? name "-")
 391         (ly:warn "Can't convert <stdout> to PDF")
 392         (postscript->pdf (if (string? papersizename) papersizename "a4")
 393                          name))))
 394
 395 (define-public (convert-to-png book name)
 396   (let* ((defs (ly:paper-book-paper book))
 397          (resolution (ly:output-def-lookup defs 'pngresolution)))
 398
 399     (postscript->png (if (number? resolution) resolution
 400
 401                          (ly:get-option 'resolution))
 402                      name)))
 403
 404 (define-public (convert-to-dvi book name)
 405   (ly:warn "Can not generate DVI via the postscript back-end"))
 406
 407 (define-public (convert-to-tex book name)
 408   (ly:warn "Can not generate TeX via the postscript back-end"))
 409
 410 (define-public (convert-to-ps book name)
 411   #t)