scm/framework-ps.scm

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