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   (define (beam width slope thick)
  56     (string-append
  57      (numbers->string (list slope width thick)) " draw_beam" ))
  58
  59   (define (comment s)
  60     (string-append "% " s))
  61
  62   (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
  63     (string-append
  64      (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
  65
  66   (define (char i)
  67     (invoke-char " show" i))
  68
  69
  70   (define (hairpin thick width starth endh )
  71     (string-append
  72      (numbers->string (list width starth endh thick))
  73      " draw_hairpin"))
  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 (repeat-slash wid slope thick)
 100    (string-append (numbers->string (list wid slope thick))
 101     " draw_repeat_slash"))
 102
 103   (define (end-output)
 104     "\nend-lilypond-output\n")
 105
 106   (define (experimental-on) "")
 107
 108   (define (filledbox breapth width depth height)
 109     (string-append (numbers->string (list breapth width depth height))
 110                    " draw_box" ))
 111
 112   ;; obsolete?
 113   (define (font-def i s)
 114     (string-append
 115      "\n/" (font i) " {/"
 116      (substring s 0 (- (string-length s) 4))
 117      " findfont 12 scalefont setfont} bind def \n"))
 118
 119   (define (font-switch i)
 120     (string-append (font i) " "))
 121
 122   (define (header-end)
 123     (string-append
 124      ;; URG: now we can't use scm output without Lily
 125      (ly-gulp-file "lilyponddefs.ps")
 126      " {exch pop //systemdict /run get exec} "
 127      (ly-gulp-file "music-drawing-routines.ps")
 128      "{ exch pop //systemdict /run get exec } "
 129      (if (defined? 'ps-testing) "\n /testing true def" "")
 130     ))
 131
 132   (define (lily-def key val)
 133
 134      (if (string=? (substring key 0 (min (string-length "lilypondpaper") (string-length key))) "lilypondpaper")
 135          (string-append "/" key " {" val "} bind def\n")
 136          (string-append "/" key " (" val ") def\n")
 137          )
 138      )
 139
 140   (define (header creator generate)
 141     (string-append
 142      "%!PS-Adobe-3.0\n"
 143      "%%Creator: " creator generate "\n"))
 144
 145   (define (invoke-char s i)
 146     (string-append
 147      "(\\" (inexact->string i 8) ") " s " " ))
 148
 149   (define (invoke-dim1 s d)
 150     (string-append
 151      (ly-number->string (* d  (/ 72.27 72))) " " s ))
 152
 153   (define (placebox x y s)
 154     (string-append
 155      (ly-number->string x) " " (ly-number->string y) " {" s "} place-box\n"))
 156
 157   (define (bezier-sandwich l thick)
 158     (string-append
 159      (apply string-append (map control->string l))
 160      (ly-number->string  thick)
 161      " draw_bezier_sandwich"))
 162
 163 ; TODO: use HEIGHT argument
 164   (define (start-line height)
 165     (string-append
 166      "\n"
 167      (ly-number->string height)
 168      " start-line {
 169 lilypondpaperoutputscale lilypondpaperoutputscale scale
 170 "))
 171
 172   (define (stem breapth width depth height)
 173     (string-append (numbers->string (list breapth width depth height))
 174                    " draw_box" ))
 175
 176   (define (stop-line)
 177       "}\nstop-line\n")
 178
 179   (define (text s)
 180     (string-append "(" s ") show  "))
 181
 182
 183   (define (volta h w thick vert_start vert_end)
 184     (string-append
 185      (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
 186      " draw_volta"))
 187
 188   (define (tuplet ht gap dx dy thick dir)
 189     (string-append
 190      (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
 191      " draw_tuplet"))
 192
 193
 194   (define (unknown)
 195     "\n unknown\n")
 196
 197   (define (ez-ball ch letter-col ball-col)
 198     (string-append
 199      " (" ch ") "
 200      (numbers->string (list letter-col ball-col))
 201      " /Helvetica-Bold " ;; ugh
 202      " draw_ez_ball"))
 203
 204   (define (define-origin a b c ) "")
 205   (define (no-origin) "")
 206
 207   ;; PS
 208   (cond ((eq? action-name 'all-definitions)
 209          `(begin
 210             (define beam ,beam)
 211             (define tuplet ,tuplet)
 212             (define bracket ,bracket)
 213             (define char ,char)
 214             (define hairpin ,hairpin)
 215             (define volta ,volta)
 216             (define bezier-sandwich ,bezier-sandwich)
 217             (define dashed-line ,dashed-line)
 218             (define dashed-slur ,dashed-slur)
 219             (define end-output ,end-output)
 220             (define experimental-on ,experimental-on)
 221             (define filledbox ,filledbox)
 222             (define font-def ,font-def)
 223             (define font-switch ,font-switch)
 224             (define header-end ,header-end)
 225             (define lily-def ,lily-def)
 226             (define font-load-command ,font-load-command)
 227             (define header ,header)
 228             (define invoke-char ,invoke-char)
 229             (define invoke-dim1 ,invoke-dim1)
 230             (define placebox ,placebox)
 231             (define select-font ,select-font)
 232             (define start-line ,start-line)
 233             (define stem ,stem)
 234             (define stop-line ,stop-line)
 235             (define stop-last-line ,stop-line)
 236             (define repeat-slash ,repeat-slash)
 237             (define text ,text)
 238             (define no-origin ,no-origin)
 239             (define define-origin ,define-origin)
 240             (define ez-ball ,ez-ball)
 241             ))
 242         ((eq? action-name 'repeat-slash) repeat-slash)
 243         ((eq? action-name 'tuplet) tuplet)
 244         ((eq? action-name 'beam) beam)
 245         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 246         ((eq? action-name 'bracket) bracket)
 247         ((eq? action-name 'char) char)
 248         ((eq? action-name 'dashed-line) dashed-line)
 249         ((eq? action-name 'dashed-slur) dashed-slur)
 250         ((eq? action-name 'hairpin) hairpin)
 251         ((eq? action-name 'experimental-on) experimental-on)
 252         ((eq? action-name 'filledbox) filledbox)
 253         ((eq? action-name 'ez-ball) ez-ball)
 254         ((eq? action-name 'select-font) select-font)
 255         ((eq? action-name 'volta) volta)
 256         (else (error "unknown tag -- PS-SCM " action-name))
 257         )
 258   )
 259
 260 (define (scm-ps-output)
 261   (primitive-eval (ps-scm 'all-definitions)))