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