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 (use-modules (ice-9 regex)
  10              (ice-9 string-fun)
  11              (ice-9 format)
  12              (guile)
  13              (srfi srfi-1)
  14              (srfi srfi-13)
  15              (lily))
  16
  17 (define (stderr string . rest)
  18   (apply format (cons (current-error-port) (cons string rest)))
  19   (force-output (current-error-port)))
  20
  21 ;;(define pdebug stderr)
  22 (define (pdebug . rest) #f)
  23
  24 (define mm-to-bigpoint
  25   (/ 72 25.4))
  26
  27 (define-public (ps-font-command font . override-coding)
  28   (let* ((name (ly:font-file-name font))
  29          (magnify (ly:font-magnification font)))
  30
  31     (string-append
  32      "magfont" (string-encode-integer (hashq  name 1000000))
  33      "m" (string-encode-integer (inexact->exact (round (* 1000 magnify)))))))
  34
  35 (define (tex-font? fontname)
  36   (or
  37    (equal? (substring fontname 0 2) "cm")
  38    (equal? (substring fontname 0 2) "ec")))
  39
  40 (define (ps-embed-cff body font-set-name version)
  41   (let* ((binary-data
  42           (string-append
  43            (format "/~a ~s StartData " font-set-name (string-length body))
  44            body)))
  45
  46     (string-append
  47      (format
  48       "%!PS-Adobe-3.0 Resource-FontSet
  49 %%DocumentNeededResources: ProcSet (FontSetInit)
  50 %%EndComments
  51 %%IncludeResource: ProcSet (FontSetInit)
  52 %%BeginResource: FontSet (~a)
  53 %%Title: (FontSet/~a)
  54 %%Version: ~s
  55 /FontSetInit /ProcSet findresource begin
  56 %%BeginData: ~s Binary Bytes
  57 "
  58       font-set-name font-set-name version (string-length binary-data))
  59      binary-data
  60      "\n%%EndData
  61 %%EndResource
  62 %%EOF
  63 ")))
  64
  65
  66 (define (load-fonts paper)
  67   (let* ((fonts (ly:paper-fonts paper))
  68          (all-font-names
  69           (map
  70            (lambda (font)
  71              (if (string? (ly:font-file-name font))
  72                  (list (ly:font-file-name font))
  73                  (ly:font-sub-fonts font)))
  74
  75            fonts))
  76          (font-names
  77           (uniq-list
  78            (sort (apply append all-font-names) string<?)))
  79          (pfas (map
  80                 (lambda (x)
  81                   (let* ((bare-file-name (ly:find-file x))
  82                          (cffname (string-append x ".cff"))
  83                          (aname (string-append x ".pfa"))
  84                          (bname (string-append x ".pfb"))
  85                          (cff-file-name (ly:find-file cffname))
  86                          (a-file-name (ly:kpathsea-find-file aname))
  87                          (b-file-name (ly:kpathsea-find-file bname)))
  88                     (cond
  89                      (bare-file-name (if (string-match "\\.pfb" bare-file-name)
  90                                          (ly:pfb->pfa bare-file-name)
  91                                          (ly:gulp-file bare-file-name)))
  92                      (cff-file-name (ps-embed-cff (ly:gulp-file cff-file-name) x 0))
  93                      (a-file-name (ly:gulp-file a-file-name))
  94                      (b-file-name (ly:pfb->pfa b-file-name))
  95                      (else
  96                       (ly:warn "cannot find CFF/PFA/PFB font ~S" x)
  97                       ""))))
  98                 (filter string? font-names))))
  99
 100     (string-join pfas "\n")))
 101
 102 (define (define-fonts paper)
 103
 104   (define font-list (ly:paper-fonts paper))
 105   (define (define-font command fontname scaling)
 106     (string-append
 107      "/" command " { /" fontname " findfont "
 108      (ly:number->string scaling) " output-scale div scalefont } bind def\n"))
 109
 110   (define (standard-tex-font? x)
 111     (or (equal? (substring x 0 2) "ms")
 112         (equal? (substring x 0 2) "cm")))
 113
 114   (define (font-load-command font)
 115     (let* ((specced-font-name (ly:font-name font))
 116            (fontname (if specced-font-name
 117                          specced-font-name
 118                          (ly:font-file-name font)))
 119            (command (ps-font-command font))
 120
 121            ;; FIXME -- see (ps-font-command )
 122            (plain (ps-font-command font #f))
 123            (designsize (ly:font-design-size font))
 124            (magnification (* (ly:font-magnification font)))
 125            (ops (ly:output-def-lookup paper 'outputscale))
 126            (scaling (* ops magnification designsize)))
 127
 128
 129       ;; Bluesky pfbs have UPCASE names (sigh.)
 130       ;;
 131       (if (standard-tex-font? fontname)
 132           (set! fontname (string-upcase fontname)))
 133
 134
 135       (define-font plain fontname scaling)))
 136
 137   (apply string-append
 138          (map (lambda (x) (font-load-command x))
 139               (filter (lambda (x) (not (ly:pango-font? x)))
 140                       font-list))))
 141
 142 ;; FIXME: duplicated in other output backends
 143 ;; FIXME: silly interface name
 144 (define (output-variables layout)
 145   ;; FIXME: duplicates output-layout's scope-entry->string, mostly
 146   (define (value->string  val)
 147     (cond
 148      ((string? val) (string-append "(" val ")"))
 149      ((symbol? val) (symbol->string val))
 150      ((number? val) (number->string val))
 151      (else "")))
 152
 153   (define (output-entry ps-key ly-key)
 154     (string-append
 155      "/" ps-key " "
 156      (value->string (ly:output-def-lookup layout ly-key)) " def \n"))
 157
 158   (string-append
 159    "/lily-output-units " (number->string mm-to-bigpoint) " def %% milimeter
 160 "
 161    (output-entry "staff-line-thickness" 'linethickness)
 162    (output-entry "line-width" 'linewidth)
 163    (output-entry "paper-size" 'papersizename)
 164    (output-entry "staff-height" 'staffheight)   ;junkme.
 165    "/output-scale "
 166    (number->string (ly:output-def-lookup layout 'outputscale))
 167    " def \n"
 168    (output-entry "page-height" 'vsize)
 169    (output-entry "page-width" 'hsize)))
 170
 171 (define (dump-page outputter page page-number page-count landscape?)
 172   (ly:outputter-dump-string outputter
 173                             (string-append
 174                              "%%Page: "
 175                              (number->string page-number) " " (number->string page-count) "\n"
 176
 177                              "%%BeginPageSetup\n"
 178                              (if landscape?
 179                                  "page-width output-scale mul 0 translate 90 rotate\n"
 180                                  "")
 181                              "%%EndPageSetup\n"
 182
 183                              "start-system { "
 184                              "set-ps-scale-to-lily-scale "
 185                              "\n"))
 186   (ly:outputter-dump-stencil outputter page)
 187   (ly:outputter-dump-string outputter "} stop-system \nshowpage\n"))
 188
 189 (define (eps-header paper bbox)
 190   (string-append "%!PS-Adobe-2.0 EPSF-2.0\n"
 191                  "%%Creator: creator time-stamp\n"
 192                  "%%BoundingBox: "
 193                  (string-join (map ly:number->string bbox) " ") "\n"
 194                  "%%Orientation: "
 195                  (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 196                      "Landscape\n"
 197                      "Portrait\n")
 198                  "%%EndComments\n"))
 199
 200 (define (page-header paper page-count)
 201   (string-append "%!PS-Adobe-3.0\n"
 202                  "%%Creator: creator time-stamp\n"
 203                  "%%Pages: " (number->string page-count) "\n"
 204                  "%%PageOrder: Ascend\n"
 205                  "%%Orientation: "
 206                  (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 207                      "Landscape\n"
 208                      "Portrait\n")
 209                  "%%DocumentPaperSizes: "
 210                  (ly:output-def-lookup paper 'papersizename) "\n"))
 211
 212 (define (preamble paper)
 213   (list
 214    (output-variables paper)
 215    (ly:gulp-file "music-drawing-routines.ps")
 216    (ly:gulp-file "lilyponddefs.ps")
 217    (load-fonts paper)
 218    (define-fonts paper)))
 219
 220 (define-public (output-framework outputter book scopes fields basename)
 221   (let* ((paper (ly:paper-book-paper book))
 222          (pages (ly:paper-book-pages book))
 223          (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
 224          (page-number (1- (ly:output-def-lookup paper 'firstpagenumber)))
 225          (page-count (length pages)))
 226
 227     (for-each
 228      (lambda (x)
 229        (ly:outputter-dump-string outputter x))
 230      (cons
 231       (page-header paper page-count)
 232       (preamble paper)))
 233
 234     (for-each
 235      (lambda (page)
 236        (set! page-number (1+ page-number))
 237        (dump-page outputter page page-number page-count landscape?))
 238      pages)
 239
 240     (ly:outputter-dump-string outputter "%%Trailer\n%%EOF\n")))
 241
 242 (define-public (output-preview-framework outputter book scopes fields basename)
 243   (let* ((paper (ly:paper-book-paper book))
 244          (systems (ly:paper-book-systems book))
 245          (scale  (ly:output-def-lookup paper 'outputscale ))
 246          (titles (take-while ly:paper-system-title? systems))
 247          (non-title (find (lambda (x)
 248                             (not (ly:paper-system-title? x))) systems))
 249          (dump-me
 250           (stack-stencils Y DOWN 0.0
 251                           (map ly:paper-system-stencil
 252                                (append titles (list non-title)))))
 253          (xext (ly:stencil-extent dump-me X))
 254          (yext (ly:stencil-extent dump-me Y))
 255          (bbox
 256           (map
 257            (lambda (x)
 258              (if (or (nan? x) (inf? x))
 259                  0.0 x))
 260            (list (car xext) (car yext)
 261                  (cdr xext) (cdr yext)))               ))
 262
 263     (for-each
 264      (lambda (x)
 265        (ly:outputter-dump-string outputter x))
 266      (cons
 267       (eps-header paper
 268                   (map
 269                    (lambda (x)
 270                      (inexact->exact
 271                       (round (* x scale mm-to-bigpoint))))
 272                    bbox))
 273       (preamble paper)))
 274
 275
 276     (ly:outputter-dump-string outputter
 277                               (string-append "start-system { "
 278                                              "set-ps-scale-to-lily-scale "
 279                                              "\n"))
 280
 281     (ly:outputter-dump-stencil outputter dump-me)
 282     (ly:outputter-dump-string outputter "} stop-system\n%%Trailer\n%%EOF\n")))
 283
 284 (define-public (convert-to-pdf book name)
 285   (let* ((defs (ly:paper-book-paper book))
 286          (papersizename (ly:output-def-lookup defs 'papersizename)))
 287
 288     (if (equal? name "-")
 289         (ly:warn "Can't convert <stdout> to PDF")
 290         (postscript->pdf (if (string? papersizename) papersizename "a4")
 291                          name))))
 292
 293 (define-public (convert-to-png book name)
 294   (let* ((defs (ly:paper-book-paper book))
 295          (resolution (ly:output-def-lookup defs 'pngresolution)))
 296
 297     (postscript->png (if (number? resolution) resolution
 298
 299                          (ly:get-option 'resolution))
 300                      name)))
 301
 302 (define-public (convert-to-dvi book name)
 303   (ly:warn "Can not generate DVI via the postscript back-end"))
 304
 305 (define-public (convert-to-tex book name)
 306   (ly:warn "Can not generate TeX via the postscript back-end"))
 307
 308 (define-public (convert-to-ps book name)
 309   #t)