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