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