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 (define-fonts bookpaper)
  17
  18   (define font-list (ly:bookpaper-fonts bookpaper))
  19   (define (define-font command fontname scaling)
  20     (string-append
  21      "/" command " { /" fontname " findfont "
  22      (ly:number->string scaling) " output-scale div scalefont } bind def\n"))
  23
  24   (define (reencode-font plain encoding command)
  25     (let ((coding-vector (get-coding-command encoding)))
  26       (string-append
  27        plain " " coding-vector " /" command " reencode-font\n"
  28        "/" command "{ /" command " findfont 1 scalefont } bind def\n")))
  29
  30   (define (guess-ps-fontname basename)
  31     "We do not have the FontName, try to guess is from basename."
  32     (cond
  33      ((tex-font? basename)
  34       ;; FIXME: we need proper Fontmap for the bluesky CM*, EC* fonts.
  35       ;; Only the fonts that we trace in mf/ are in our own FontMap.
  36       (string-append basename ".pfb"))
  37      (else (string-append basename ".pfa"))
  38      ))
  39
  40   (define (font-load-command font)
  41     (let* ((specced-font-name (ly:font-name font))
  42            (fontname (if specced-font-name
  43                          specced-font-name
  44                          (guess-ps-fontname (ly:font-filename font))))
  45
  46            (coding-alist (ly:font-encoding-alist font))
  47            (input-encoding (assoc-get 'input-name coding-alist))
  48            (font-encoding (assoc-get 'output-name coding-alist))
  49            (command (ps-font-command font))
  50            ;; FIXME -- see (ps-font-command )
  51            (plain (ps-font-command font #f))
  52            (designsize (ly:font-design-size font))
  53            (magnification (* (ly:font-magnification font)))
  54            (ops (ly:output-def-lookup bookpaper 'outputscale))
  55            (scaling (* ops magnification designsize)))
  56
  57       (string-append
  58        (define-font plain fontname scaling)
  59        (if (or (equal? input-encoding font-encoding)
  60                ;; guh
  61                (equal? font-encoding "fetaBraces")
  62                (equal? font-encoding "fetaNumber")
  63                (equal? font-encoding "fetaMusic")
  64                (equal? font-encoding "parmesanMusic"))
  65                ""
  66            (reencode-font plain input-encoding command)))))
  67
  68   (define (font-load-encoding encoding)
  69     (let ((filename (get-coding-filename encoding)))
  70       (ly:kpathsea-gulp-file filename)))
  71
  72   (let* ((encoding-list (map (lambda (x)
  73                                (assoc-get 'input-name
  74                                           (ly:font-encoding-alist x)))
  75                              font-list))
  76          (encodings (uniq-list (sort-list (filter string? encoding-list)
  77                                           string<?))))
  78
  79     (string-append
  80      (apply string-append (map font-load-encoding encodings))
  81      (apply string-append
  82             (map (lambda (x) (font-load-command x)) font-list)))))
  83
  84 ;; FIXME: duplicated in other output backends
  85 ;; FIXME: silly interface name
  86 (define (output-variables paper)
  87   ;; FIXME: duplicates output-paper's scope-entry->string, mostly
  88   (define (value->string  val)
  89     (cond
  90      ((string? val) (string-append "(" val ")"))
  91      ((symbol? val) (symbol->string val))
  92      ((number? val) (number->string val))
  93      (else "")))
  94
  95   (define (output-entry ps-key ly-key)
  96     (string-append
  97      "/" ps-key " " (value->string (ly:output-def-lookup paper ly-key)) " def \n"))
  98
  99   (string-append
 100    "/lily-output-units 2.83464  def  %% milimeter \n"
 101    "% /lily-output-units 0.996264  def  %% true points.\n"
 102    (output-entry "staff-line-thickness" 'linethickness)
 103    (output-entry "line-width" 'linewidth)
 104    (output-entry "paper-size" 'papersize)
 105    (output-entry "staff-height" 'staffheight)   ;junkme.
 106    "/output-scale "
 107    (number->string (ly:output-def-lookup paper 'outputscale))
 108    " lily-output-units mul def \n"
 109     ))
 110
 111 (define (header paper page-count classic?)
 112   (string-append
 113    "%!PS-Adobe-3.0\n"
 114    "%%Creator: creator time-stamp \n"
 115    "%%Pages: " (number->string page-count) "\n"
 116    "%%PageOrder: Ascend\n"
 117    "%%DocumentPaperSizes: " (ly:output-def-lookup paper 'papersize) "\n"
 118    ;;(string-append "GNU LilyPond (" (lilypond-version) "), ")
 119    ;;      (strftime "%c" (localtime (current-time))))
 120    ;; FIXME: duplicated in every backend
 121    (ps-string-def
 122     "lilypond" 'tagline
 123     (string-append "Engraved by LilyPond (version " (lilypond-version) ")"))
 124    ))
 125
 126 (define (dump-page outputter page page-number page-count)
 127   (ly:outputter-dump-string outputter
 128    (string-append
 129     "%%Page: " (number->string page-number) " " (number->string page-count) "\n"
 130     "0 0 start-system { "
 131     "set-ps-scale-to-lily-scale "
 132     "\n"))
 133   (ly:outputter-dump-stencil outputter (ly:page-stencil page))
 134   (ly:outputter-dump-string outputter
 135                             "} stop-system \nshowpage\n") )
 136
 137
 138 (define-public (output-framework-ps outputter book scopes fields basename)
 139   (let*
 140       ((bookpaper  (ly:paper-book-book-paper book))
 141        (pages (ly:paper-book-pages book))
 142        (pageno 0)
 143        (page-count (length pages))
 144        )
 145   (for-each
 146    (lambda (x)
 147      (ly:outputter-dump-string outputter x))
 148    (list
 149     (header bookpaper
 150             (length pages)
 151             #f)
 152
 153     (output-variables bookpaper)
 154     (ly:gulp-file "music-drawing-routines.ps")
 155     (ly:gulp-file "lilyponddefs.ps")
 156     (define-fonts bookpaper)
 157     ))
 158
 159   (for-each
 160    (lambda (page)
 161      (set! pageno (1+ pageno))
 162      (dump-page outputter page pageno page-count))
 163    pages)
 164   (ly:outputter-dump-string outputter "%%Trailer\n%%EOF\n")
 165   ))
 166
 167
 168 (define (dump-line outputter system)
 169   (ly:outputter-dump-string
 170    outputter
 171     " start-system {\n set-ps-scale-to-lily-scale\n")
 172   (ly:outputter-dump-stencil outputter (ly:page-line-stencil system))
 173   (ly:outputter-dump-string
 174    outputter
 175   "} stop-system\n"))
 176
 177
 178 (define-public (output-classic-framework-ps outputter book scopes fields basename)
 179   (let*
 180       ((bookpaper  (ly:paper-book-book-paper book))
 181        (lines (ly:paper-book-lines book))
 182        (pageno 0)
 183        (page-count (length lines))
 184        )
 185   (for-each
 186    (lambda (x)
 187      (ly:outputter-dump-string outputter x))
 188    (list
 189     (header bookpaper
 190             (length pages)
 191             #f)
 192
 193     (output-variables bookpaper)
 194     (ly:gulp-file "music-drawing-routines.ps")
 195     (ly:gulp-file "lilyponddefs.ps")
 196     (define-fonts bookpaper)
 197     ))
 198
 199   (for-each
 200    (lambda (line)
 201      (set! pageno (1+ pageno))
 202      (dump-line outputter line)) ;   pageno page-count))
 203    lines)
 204   (ly:outputter-dump-string outputter "\n")
 205   ))
 206