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