scm/ps.scm

   1 ;;; ps.scm -- implement Scheme output routines for PostScript
   2 ;;;
   3 ;;;  source file of the GNU LilyPond music typesetter
   4 ;;;
   5 ;;; (c) 1998--2001 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8
   9 (define (ps-scm action-name)
  10
  11   ;; alist containing fontname -> fontcommand assoc (both strings)
  12   (define font-alist '())
  13   (define font-count 0)
  14   (define current-font "")
  15
  16
  17   (define (cached-fontname i)
  18     (string-append
  19      "lilyfont"
  20      (make-string 1 (integer->char (+ 65 i)))))
  21
  22
  23   (define (select-font name-mag-pair)
  24     (let*
  25         (
  26          (c (assoc name-mag-pair font-name-alist))
  27          )
  28
  29       (if (eq? c #f)
  30           (begin
  31             (display "FAILED\n")
  32             (display (object-type (car name-mag-pair)))
  33             (display (object-type (caaar font-name-alist)))
  34
  35             (ly-warn (string-append
  36                       "Programming error: No such font known "
  37                       (car name-mag-pair) " "
  38                       (number->string (cdr name-mag-pair))
  39                       ))
  40
  41             "") ; issue no command
  42           (string-append " " (cddr c) " "))
  43       ))
  44
  45     (define (font-load-command name-mag command)
  46       (string-append
  47        "/" command
  48        " { /"
  49        (car name-mag)
  50        " findfont "
  51        "12 " (number->string (cdr name-mag)) " mul "
  52        "lilypondpaperoutputscale div scalefont setfont } bind def "
  53        "\n"))
  54
  55
  56   (define (beam width slope thick)
  57     (string-append
  58      (numbers->string (list width slope thick)) " draw_beam" ))
  59
  60   (define (comment s)
  61     (string-append "% " s))
  62
  63   (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
  64     (string-append
  65      (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
  66
  67   (define (char i)
  68     (invoke-char " show" i))
  69
  70   (define (crescendo thick w h cont )
  71     (string-append
  72      (numbers->string (list w h (inexact->exact cont) thick))
  73      " draw_crescendo"))
  74
  75   ;; what the heck is this interface ?
  76   (define (dashed-slur thick dash l)
  77     (string-append
  78      (apply string-append (map control->string l))
  79      (number->string thick)
  80      " [ "
  81      (number->string dash)
  82      " "
  83      (number->string (* 10 thick))      ;UGH.  10 ?
  84      " ] 0 draw_dashed_slur"))
  85
  86   (define (dashed-line thick on off dx dy)
  87     (string-append
  88      (number->string dx)
  89      " "
  90      (number->string dy)
  91      " "
  92      (number->string thick)
  93      " [ "
  94      (number->string on)
  95      " "
  96      (number->string off)
  97      " ] 0 draw_dashed_line"))
  98
  99   (define (decrescendo thick w h cont)
 100     (string-append
 101      (numbers->string (list w h (inexact->exact cont) thick))
 102      " draw_decrescendo"))
 103
 104
 105   (define (end-output)
 106     "\nshowpage\n")
 107
 108   (define (experimental-on) "")
 109
 110   (define (filledbox breapth width depth height)
 111     (string-append (numbers->string (list breapth width depth height))
 112                    " draw_box" ))
 113
 114   ;; obsolete?
 115   (define (font-def i s)
 116     (string-append
 117      "\n/" (font i) " {/"
 118      (substring s 0 (- (string-length s) 4))
 119      " findfont 12 scalefont setfont} bind def \n"))
 120
 121   (define (font-switch i)
 122     (string-append (font i) " "))
 123
 124   (define (header-end)
 125     (string-append
 126      ;; URG: now we can't use scm output without Lily
 127      (ly-gulp-file "lilyponddefs.ps")
 128      " {exch pop //systemdict /run get exec} "
 129      (ly-gulp-file "lily.ps")
 130      "{ exch pop //systemdict /run get exec } "
 131     ))
 132
 133   (define (lily-def key val)
 134
 135      (if (string=? (substring key 0 (min (string-length "lilypondpaper") (string-length key))) "lilypondpaper")
 136          (string-append "/" key " {" val "} bind def\n")
 137          (string-append "/" key " (" val ") def\n")
 138          )
 139      )
 140
 141   (define (header creator generate)
 142     (string-append
 143      "%!PS-Adobe-3.0\n"
 144      "%%Creator: " creator generate "\n"))
 145
 146   (define (invoke-char s i)
 147     (string-append
 148      "(\\" (inexact->string i 8) ") " s " " ))
 149
 150   (define (invoke-dim1 s d)
 151     (string-append
 152      (number->string (* d  (/ 72.27 72))) " " s ))
 153
 154   (define (placebox x y s)
 155     (string-append
 156      (number->string x) " " (number->string y) " {" s "} placebox "))
 157
 158   (define (bezier-sandwich l thick)
 159     (string-append
 160      (apply string-append (map control->string l))
 161      (number->string  thick)
 162      " draw_bezier_sandwich"))
 163
 164   (define (start-line height)
 165           "\nstart_line {
 166 lilypondpaperoutputscale lilypondpaperoutputscale scale
 167 ")
 168
 169   (define (stem breapth width depth height)
 170     (string-append (numbers->string (list breapth width depth height))
 171                    " draw_box" ))
 172
 173   (define (stop-line)
 174       "}\nstop_line\n")
 175
 176   (define (text s)
 177     (string-append "(" s ") show  "))
 178
 179
 180   (define (volta h w thick vert_start vert_end)
 181     (string-append
 182      (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
 183      " draw_volta"))
 184
 185   (define (tuplet ht gap dx dy thick dir)
 186     (string-append
 187      (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
 188      " draw_tuplet"))
 189
 190
 191   (define (unknown)
 192     "\n unknown\n")
 193
 194 ;; note heads with letters.
 195   (define (ez-ball ch letter-col ball-col)
 196     (string-append "
 197 /Helvetica-Bold findfont
 198 0.7 scalefont
 199 setfont
 200 0.1 setlinewidth
 201  0 0 moveto
 202 0 setgray
 203 0.5 0 0.5 0 360  arc
 204 closepath "
 205                    (if (equal? ball-col 0) " fill " " stroke ")
 206                    (number->string letter-col)
 207                    "
 208 setgray
 209 % 0.25 is empiric centering. Change to taste
 210 0.25 -0.25 moveto
 211  (" ch ") show
 212 showpage ")
 213     )
 214
 215   (define (define-origin a b c ) "")
 216   (define (no-origin) "")
 217
 218   ;; PS
 219   (cond ((eq? action-name 'all-definitions)
 220          `(begin
 221             (define beam ,beam)
 222             (define tuplet ,tuplet)
 223             (define bracket ,bracket)
 224             (define char ,char)
 225             (define crescendo ,crescendo)
 226             (define volta ,volta)
 227             (define bezier-sandwich ,bezier-sandwich)
 228             (define dashed-line ,dashed-line)
 229             (define dashed-slur ,dashed-slur)
 230             (define decrescendo ,decrescendo)
 231             (define end-output ,end-output)
 232             (define experimental-on ,experimental-on)
 233             (define filledbox ,filledbox)
 234             (define font-def ,font-def)
 235             (define font-switch ,font-switch)
 236             (define header-end ,header-end)
 237             (define lily-def ,lily-def)
 238             (define font-load-command ,font-load-command)
 239             (define header ,header)
 240             (define invoke-char ,invoke-char)
 241             (define invoke-dim1 ,invoke-dim1)
 242             (define placebox ,placebox)
 243             (define select-font ,select-font)
 244             (define start-line ,start-line)
 245             (define stem ,stem)
 246             (define stop-line ,stop-line)
 247             (define stop-last-line ,stop-line)
 248             (define text ,text)
 249             (define no-origin ,no-origin)
 250             (define define-origin ,define-origin)
 251             (define ez-ball ,ez-ball)
 252             ))
 253         ((eq? action-name 'tuplet) tuplet)
 254         ((eq? action-name 'beam) beam)
 255         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 256         ((eq? action-name 'bracket) bracket)
 257         ((eq? action-name 'char) char)
 258         ((eq? action-name 'crescendo) crescendo)
 259         ((eq? action-name 'dashed-line) dashed-line)
 260         ((eq? action-name 'dashed-slur) dashed-slur)
 261         ((eq? action-name 'decrescendo) decrescendo)
 262         ((eq? action-name 'experimental-on) experimental-on)
 263         ((eq? action-name 'filledbox) filledbox)
 264         ((eq? action-name 'ez-ball) ez-ball)
 265         ((eq? action-name 'select-font) select-font)
 266         ((eq? action-name 'volta) volta)
 267         (else (error "unknown tag -- PS-SCM " action-name))
 268         )
 269   )
 270
 271 (define (scm-ps-output)
 272   (ly-eval (ps-scm 'all-definitions)))