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