scm/framework-ps.scm

   1
   2 (define-module (scm framework-ps))
   3
   4 (use-modules (ice-9 regex)
   5              (ice-9 string-fun)
   6              (ice-9 format)
   7              (guile)
   8              (srfi srfi-13)
   9              (scm output-ps)
  10              (lily))
  11
  12 (define (tex-font? fontname)
  13   (equal? (substring fontname 0 2) "cm"))
  14
  15
  16 (define (load-fonts bookpaper)
  17
  18   (let*
  19       ((fonts (ly:bookpaper-fonts bookpaper))
  20        (font-names (uniq-list (sort (map ly:font-filename fonts) string<?)))
  21        (pfas (map
  22               (lambda (x)
  23                 (ly:kpathsea-gulp-file (string-append x ".pfa")))
  24
  25               (filter string? font-names))) )
  26
  27     (string-join pfas "\n")))
  28
  29
  30 (define (define-fonts bookpaper)
  31
  32   (define font-list (ly:bookpaper-fonts bookpaper))
  33   (define (define-font command fontname scaling)
  34     (string-append
  35      "/" command " { /" fontname " findfont "
  36      (ly:number->string scaling) " output-scale div scalefont } bind def\n"))
  37
  38   (define (reencode-font plain encoding command)
  39     (let ((coding-vector (get-coding-command encoding)))
  40       (string-append
  41        plain " " coding-vector " /" command " reencode-font\n"
  42        "/" command "{ /" command " findfont 1 scalefont } bind def\n")))
  43
  44   (define (guess-ps-fontname basename)
  45
  46     "We do not have the FontName, try to guess is from basename."
  47     (cond
  48      (#t basename)
  49      ((tex-font? basename)
  50       ;; FIXME: we need proper Fontmap for the bluesky CM*, EC* fonts.
  51       ;; Only the fonts that we trace in mf/ are in our own FontMap.
  52       (string-append basename ".pfb"))
  53      (else (string-append basename ".pfa"))
  54      ))
  55
  56   (define (font-load-command font)
  57     (let* ((specced-font-name (ly:font-name font))
  58            (fontname (if specced-font-name
  59                          specced-font-name
  60                          (guess-ps-fontname (ly:font-filename font))))
  61
  62            (coding-alist (ly:font-encoding-alist font))
  63            (input-encoding (assoc-get 'input-name coding-alist))
  64            (font-encoding (assoc-get 'output-name coding-alist))
  65            (command (ps-font-command font))
  66            ;; FIXME -- see (ps-font-command )
  67            (plain (ps-font-command font #f))
  68            (designsize (ly:font-design-size font))
  69            (magnification (* (ly:font-magnification font)))
  70            (ops (ly:output-def-lookup bookpaper 'outputscale))
  71            (scaling (* ops magnification designsize)))
  72
  73       (string-append
  74        (define-font plain fontname scaling)
  75        (if (or (equal? input-encoding font-encoding)
  76                ;; guh
  77                (equal? font-encoding "fetaBraces")
  78                (equal? font-encoding "fetaNumber")
  79                (equal? font-encoding "fetaMusic")
  80                (equal? font-encoding "parmesanMusic"))
  81                ""
  82            (reencode-font plain input-encoding command)))))
  83
  84   (define (font-load-encoding encoding)
  85     (let ((filename (get-coding-filename encoding)))
  86       (ly:kpathsea-gulp-file filename)))
  87
  88   (let* ((encoding-list (map (lambda (x)
  89                                (assoc-get 'input-name
  90                                           (ly:font-encoding-alist x)))
  91                              font-list))
  92          (encodings (uniq-list (sort-list (filter string? encoding-list)
  93                                           string<?))))
  94
  95     (string-append
  96      (apply string-append (map font-load-encoding encodings))
  97      (apply string-append
  98             (map (lambda (x) (font-load-command x)) font-list)))))
  99
 100 ;; FIXME: duplicated in other output backends
 101 ;; FIXME: silly interface name
 102 (define (output-variables paper)
 103   ;; FIXME: duplicates output-paper's scope-entry->string, mostly
 104   (define (value->string  val)
 105     (cond
 106      ((string? val) (string-append "(" val ")"))
 107      ((symbol? val) (symbol->string val))
 108      ((number? val) (number->string val))
 109      (else "")))
 110
 111   (define (output-entry ps-key ly-key)
 112     (string-append
 113      "/" ps-key " " (value->string (ly:output-def-lookup paper ly-key)) " def \n"))
 114
 115   (string-append
 116    "/lily-output-units 2.83464  def  %% milimeter \n"
 117    "% /lily-output-units 0.996264  def  %% true points.\n"
 118    (output-entry "staff-line-thickness" 'linethickness)
 119    (output-entry "line-width" 'linewidth)
 120    (output-entry "paper-size" 'papersize)
 121    (output-entry "staff-height" 'staffheight)   ;junkme.
 122    "/output-scale "
 123    (number->string (ly:output-def-lookup paper 'outputscale))
 124    " lily-output-units mul def \n"
 125     ))
 126
 127 (define (header paper page-count classic?)
 128   (string-append
 129    "%!PS-Adobe-3.0\n"
 130    "%%Creator: creator time-stamp \n"
 131    ))
 132
 133 (define (dump-page outputter page page-number page-count)
 134   (ly:outputter-dump-string outputter
 135    (string-append
 136     "%%Page: " (number->string page-number) " " (number->string page-count) "\n"
 137     "0 0 start-system { "
 138     "set-ps-scale-to-lily-scale "
 139     "\n"))
 140   (ly:outputter-dump-stencil outputter (ly:page-stencil page))
 141   (ly:outputter-dump-string outputter
 142                             "} stop-system \nshowpage\n") )
 143
 144
 145 (define-public (output-framework-ps outputter book scopes fields basename)
 146   (let*
 147       ((bookpaper  (ly:paper-book-book-paper book))
 148        (pages (ly:paper-book-pages book))
 149        (pageno 0)
 150        (page-count (length pages))
 151        )
 152   (for-each
 153    (lambda (x)
 154      (ly:outputter-dump-string outputter x))
 155    (list
 156     (header bookpaper
 157             (length pages)
 158             #f)
 159
 160    "%%Pages: " (number->string page-count) "\n"
 161    "%%PageOrder: Ascend\n"
 162    "%%DocumentPaperSizes: " (ly:output-def-lookup bookpaper 'papersize) "\n"
 163
 164     (output-variables bookpaper)
 165     (ly:gulp-file "music-drawing-routines.ps")
 166     (ly:gulp-file "lilyponddefs.ps")
 167     (load-fonts bookpaper)
 168     (define-fonts bookpaper)
 169     ))
 170
 171   (for-each
 172    (lambda (page)
 173      (set! pageno (1+ pageno))
 174      (dump-page outputter page pageno page-count))
 175    pages)
 176   (ly:outputter-dump-string outputter "%%Trailer\n%%EOF\n")
 177   ))
 178
 179
 180
 181
 182 (define-public (output-classic-framework-ps outputter book scopes fields basename)
 183   (let*
 184       ((bookpaper  (ly:paper-book-book-paper book))
 185        (lines (ly:paper-book-lines book))
 186        (y 0.0)
 187        (scale (* 2.83464 (ly:output-def-lookup bookpaper 'outputscale)))
 188        (total-y (apply + (map (lambda (z) (ly:paper-line-extent z Y))  lines)))
 189        (x-ext '(-8 . 0))
 190        (lineno 0)
 191        )
 192
 193     (define (dump-line outputter system)
 194       (let*
 195           ((stil  (ly:paper-line-stencil  system)))
 196
 197       (ly:outputter-dump-string
 198        outputter
 199        (string-append
 200         " 0.0 "
 201         (ly:number->string y)
 202         " start-system {\n set-ps-scale-to-lily-scale\n"))
 203       (set! y (+ y (ly:paper-line-extent system Y)))
 204       (ly:outputter-dump-stencil outputter stil)
 205       (ly:outputter-dump-string
 206        outputter
 207        "} stop-system\n")))
 208
 209     (define (to-pt x)
 210       (inexact->exact (round (* scale x))))
 211
 212     (define (bbox llx lly urx ury)
 213       (string-append
 214        "%%BoundingBox: "
 215        (ly:number->string (to-pt llx)) " "
 216        (ly:number->string (to-pt lly)) " "
 217        (ly:number->string (to-pt urx)) " "
 218        (ly:number->string (to-pt ury)) "\n"))
 219
 220     (for-each (lambda (l)
 221                 (set! x-ext (interval-union x-ext (cons 0.0 (ly:paper-line-extent l X))))
 222                 )
 223                 lines)
 224
 225   (for-each
 226    (lambda (x)
 227      (ly:outputter-dump-string outputter x))
 228    (list
 229     "%!PS-Adobe-2.0 EPSF-2.0\n"
 230     "%%Creator: LilyPond \n"
 231
 232 ;;    (bbox (car x-ext) 0 (cdr x-ext) total-y)    ; doesn't work well
 233
 234     "%%EndComments\n"
 235     (output-variables bookpaper)
 236     (ly:gulp-file "music-drawing-routines.ps")
 237     (ly:gulp-file "lilyponddefs.ps")
 238     (load-fonts bookpaper)
 239     (define-fonts bookpaper)
 240     ))
 241
 242   (for-each
 243    (lambda (line)
 244      (set! lineno (1+ lineno))
 245      (dump-line outputter line)) ;   pageno page-count))
 246    lines)
 247   (ly:outputter-dump-string outputter "\n")
 248   ))
 249