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 lily-output-units lily-output-units scale
 161 "
 162    (output-entry "staff-line-thickness" 'linethickness)
 163    (output-entry "line-width" 'linewidth)
 164    (output-entry "paper-size" 'papersizename)
 165    (output-entry "staff-height" 'staffheight)   ;junkme.
 166    "/output-scale "
 167    (number->string (ly:output-def-lookup layout 'outputscale))
 168    " def \n"
 169    (output-entry "page-height" 'vsize)
 170    (output-entry "page-width" 'hsize)))
 171
 172 (define (dump-page outputter page page-number page-count landscape?)
 173   (ly:outputter-dump-string outputter
 174                             (string-append
 175                              "%%Page: "
 176                              (number->string page-number) " " (number->string page-count) "\n"
 177
 178                              "%%BeginPageSetup\n"
 179                              (if landscape?
 180                                  "page-width output-scale mul 0 translate 90 rotate\n"
 181                                  "")
 182                              "%%EndPageSetup\n"
 183
 184                              "start-system { "
 185                              "set-ps-scale-to-lily-scale "
 186                              "\n"))
 187   (ly:outputter-dump-stencil outputter page)
 188   (ly:outputter-dump-string outputter "} stop-system \nshowpage\n"))
 189
 190 (define (eps-header paper bbox)
 191   (string-append "%!PS-Adobe-2.0 EPSF-2.0\n"
 192                  "%%Creator: creator time-stamp\n"
 193                  "%%BoundingBox: "
 194                  (string-join (map ly:number->string bbox) " ") "\n"
 195                  "%%Orientation: "
 196                  (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 197                      "Landscape\n"
 198                      "Portrait\n")
 199                  "%%EndComments\n"))
 200
 201 (define (page-header paper page-count)
 202   (string-append "%!PS-Adobe-3.0\n"
 203                  "%%Creator: creator time-stamp\n"
 204                  "%%Pages: " (number->string page-count) "\n"
 205                  "%%PageOrder: Ascend\n"
 206                  "%%Orientation: "
 207                  (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 208                      "Landscape\n"
 209                      "Portrait\n")
 210                  "%%DocumentPaperSizes: "
 211                  (ly:output-def-lookup paper 'papersizename) "\n"))
 212
 213 (define (preamble paper)
 214   (list
 215    (output-variables paper)
 216    (ly:gulp-file "music-drawing-routines.ps")
 217    (ly:gulp-file "lilyponddefs.ps")
 218    (load-fonts paper)
 219    (define-fonts paper)))
 220
 221 (define-public (output-framework outputter book scopes fields basename)
 222   (let* ((paper (ly:paper-book-paper book))
 223          (pages (ly:paper-book-pages book))
 224          (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
 225          (page-number (1- (ly:output-def-lookup paper 'firstpagenumber)))
 226          (page-count (length pages)))
 227
 228     (for-each
 229      (lambda (x)
 230        (ly:outputter-dump-string outputter x))
 231      (cons
 232       (page-header paper page-count)
 233       (preamble paper)))
 234
 235     (for-each
 236      (lambda (page)
 237        (set! page-number (1+ page-number))
 238        (dump-page outputter page page-number page-count landscape?))
 239      pages)
 240
 241     (ly:outputter-dump-string outputter "%%Trailer\n%%EOF\n")))
 242
 243 (define-public (output-preview-framework outputter book scopes fields basename)
 244   (let* ((paper (ly:paper-book-paper book))
 245          (systems (ly:paper-book-systems book))
 246          (scale  (ly:output-def-lookup paper 'outputscale ))
 247          (titles (take-while ly:paper-system-title? systems))
 248          (non-title (find (lambda (x)
 249                             (not (ly:paper-system-title? x))) systems))
 250          (dump-me
 251           (stack-stencils Y DOWN 0.0
 252                           (map ly:paper-system-stencil
 253                                (append titles (list non-title)))))
 254          (xext (ly:stencil-extent dump-me X))
 255          (yext (ly:stencil-extent dump-me Y))
 256          (bbox
 257           (map
 258            (lambda (x)
 259              (if (or (nan? x) (inf? x))
 260                  0.0 x))
 261            (list (car xext) (car yext)
 262                  (cdr xext) (cdr yext)))               ))
 263
 264     (for-each
 265      (lambda (x)
 266        (ly:outputter-dump-string outputter x))
 267      (cons
 268       (eps-header paper
 269                   (map
 270                    (lambda (x)
 271                      (inexact->exact
 272                       (round (* x scale mm-to-bigpoint))))
 273                    bbox))
 274       (preamble paper)))
 275
 276
 277     (ly:outputter-dump-string outputter
 278                               (string-append "start-system { "
 279                                              "set-ps-scale-to-lily-scale "
 280                                              "\n"))
 281
 282     (ly:outputter-dump-stencil outputter dump-me)
 283     (ly:outputter-dump-string outputter "} stop-system\n%%Trailer\n%%EOF\n")))
 284
 285 (define-public (convert-to-pdf book name)
 286   (let* ((defs (ly:paper-book-paper book))
 287          (papersizename (ly:output-def-lookup defs 'papersizename)))
 288
 289     (if (equal? name "-")
 290         (ly:warn "Can't convert <stdout> to PDF")
 291         (postscript->pdf (if (string? papersizename) papersizename "a4")
 292                          name))))
 293
 294 (define-public (convert-to-png book name)
 295   (let* ((defs (ly:paper-book-paper book))
 296          (resolution (ly:output-def-lookup defs 'pngresolution)))
 297
 298     (postscript->png (if (number? resolution) resolution
 299
 300                          (ly:get-option 'resolution))
 301                      name)))
 302
 303 (define-public (convert-to-dvi book name)
 304   (ly:warn "Can not generate DVI via the postscript back-end"))
 305
 306 (define-public (convert-to-tex book name)
 307   (ly:warn "Can not generate TeX via the postscript back-end"))
 308
 309 (define-public (convert-to-ps book name)
 310   #t)