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                       (ly-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 " (ly-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      (ly-number->string thick)
  80      " [ "
  81      (ly-number->string dash)
  82      " "
  83      (ly-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      (ly-number->string dx)
  89      " "
  90      (ly-number->string dy)
  91      " "
  92      (ly-number->string thick)
  93      " [ "
  94      (ly-number->string on)
  95      " "
  96      (ly-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      (ly-number->string (* d  (/ 72.27 72))) " " s ))
 153
 154   (define (placebox x y s)
 155     (string-append
 156      (ly-number->string x) " " (ly-number->string y) " {" s "} placebox\n"))
 157
 158   (define (bezier-sandwich l thick)
 159     (string-append
 160      (apply string-append (map control->string l))
 161      (ly-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   (define (ez-ball ch letter-col ball-col)
 195     (string-append
 196      " (" ch ") "
 197      (numbers->string (list letter-col ball-col))
 198      " /Helvetica-Bold " ;; ugh
 199      " draw_ez_ball"))
 200
 201   (define (define-origin a b c ) "")
 202   (define (no-origin) "")
 203
 204   ;; PS
 205   (cond ((eq? action-name 'all-definitions)
 206          `(begin
 207             (define beam ,beam)
 208             (define tuplet ,tuplet)
 209             (define bracket ,bracket)
 210             (define char ,char)
 211             (define crescendo ,crescendo)
 212             (define volta ,volta)
 213             (define bezier-sandwich ,bezier-sandwich)
 214             (define dashed-line ,dashed-line)
 215             (define dashed-slur ,dashed-slur)
 216             (define decrescendo ,decrescendo)
 217             (define end-output ,end-output)
 218             (define experimental-on ,experimental-on)
 219             (define filledbox ,filledbox)
 220             (define font-def ,font-def)
 221             (define font-switch ,font-switch)
 222             (define header-end ,header-end)
 223             (define lily-def ,lily-def)
 224             (define font-load-command ,font-load-command)
 225             (define header ,header)
 226             (define invoke-char ,invoke-char)
 227             (define invoke-dim1 ,invoke-dim1)
 228             (define placebox ,placebox)
 229             (define select-font ,select-font)
 230             (define start-line ,start-line)
 231             (define stem ,stem)
 232             (define stop-line ,stop-line)
 233             (define stop-last-line ,stop-line)
 234             (define text ,text)
 235             (define no-origin ,no-origin)
 236             (define define-origin ,define-origin)
 237             (define ez-ball ,ez-ball)
 238             ))
 239         ((eq? action-name 'tuplet) tuplet)
 240         ((eq? action-name 'beam) beam)
 241         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 242         ((eq? action-name 'bracket) bracket)
 243         ((eq? action-name 'char) char)
 244         ((eq? action-name 'crescendo) crescendo)
 245         ((eq? action-name 'dashed-line) dashed-line)
 246         ((eq? action-name 'dashed-slur) dashed-slur)
 247         ((eq? action-name 'decrescendo) decrescendo)
 248         ((eq? action-name 'experimental-on) experimental-on)
 249         ((eq? action-name 'filledbox) filledbox)
 250         ((eq? action-name 'ez-ball) ez-ball)
 251         ((eq? action-name 'select-font) select-font)
 252         ((eq? action-name 'volta) volta)
 253         (else (error "unknown tag -- PS-SCM " action-name))
 254         )
 255   )
 256
 257 (define (scm-ps-output)
 258   (ly-eval (ps-scm 'all-definitions)))