4 (define (sk-numbers->string l)
6 (number->string (car l))
9 (string-append "," (sk-numbers->string (cdr l)))
15 (define (sketch-scm action-name)
18 (define output-scale 1.0)
19 (define (mul-scale x) (* output-scale x))
21 ;; alist containing fontname -> fontcommand assoc (both strings)
22 (define font-alist '())
24 (define current-font "")
27 (define (cached-fontname i)
30 (make-string 1 (integer->char (+ 65 i)))))
33 (define (select-font name-mag-pair)
36 (c (assoc name-mag-pair font-name-alist))
42 (display (object-type (car name-mag-pair)))
43 (display (object-type (caaar font-name-alist)))
45 (ly-warn (string-append
46 "Programming error: No such font known "
47 (car name-mag-pair) " "
48 (ly-number->string (cdr name-mag-pair))
51 "") ; issue no command
53 ; (string-append " " (cddr c) " "))
56 (define (font-load-command name-mag command)
61 (define (beam width slope thick)
63 (sk-numbers->string (list slope width thick)) " draw_beam" ))
66 (string-append "% " s))
68 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
70 (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
73 (invoke-char " show" i))
76 (define (hairpin thick width starth endh )
78 (numbers->string (list width starth endh thick))
81 ;; what the heck is this interface ?
82 (define (dashed-slur thick dash l)
84 (apply string-append (map control->string l))
85 (ly-number->string thick)
87 (ly-number->string dash)
89 (ly-number->string (* 10 thick)) ;UGH. 10 ?
90 " ] 0 draw_dashed_slur"))
92 (define (dashed-line thick on off dx dy)
94 (ly-number->string dx)
96 (ly-number->string dy)
98 (ly-number->string thick)
100 (ly-number->string on)
102 (ly-number->string off)
103 " ] 0 draw_dashed_line"))
105 (define (repeat-slash wid slope thick)
106 (string-append (numbers->string (list wid slope thick))
107 " draw_repeat_slash"))
110 "guidelayer('Guide Lines',1,0,0,1,(0,0,1))
111 grid((0,0,20,20),0,(0,0,1),'Grid')\n")
113 (define (experimental-on) "")
116 (define (font-def i s)
119 (substring s 0 (- (string-length s) 4))
120 " findfont 12 scalefont setfont} bind def \n"))
122 (define (font-switch i)
124 ; (string-append (font i) " "))
131 (define (lily-def key val)
132 (if (equal? key "lilypondpaperoutputscale")
133 (set! output-scale (string->number val))
138 (define (header creator generate)
143 layer('Layer 1',1,1,0,0,(0,0,0))
146 (define (invoke-char s i)
149 (define (invoke-dim1 s d)
151 (ly-number->string (* d (/ 72.27 72))) " " s ))
153 (define (placebox x y s)
154 (set! global-x (+ x 0))
155 (set! global-y (+ y 100))
159 (define (bezier-sandwich l thick)
161 (apply string-append (map control->string l))
162 (ly-number->string thick)
163 " draw_bezier_sandwich"))
165 ; TODO: use HEIGHT argument
166 (define (start-line height)
170 (define (filledbox breapth width depth height)
173 (sk-numbers->string (quote ,(map mul-scale (list (+ breapth width)
175 (- (+ breapth depth))
177 (+ global-y height)))))
181 (define (stem x y z w) (filledbox x y z w))
189 ; (string-append "(" s ") show "))
192 (define (volta h w thick vert_start vert_end)
194 (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
197 (define (tuplet ht gap dx dy thick dir)
199 (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
206 (define (ez-ball ch letter-col ball-col)
209 (numbers->string (list letter-col ball-col))
210 " /Helvetica-Bold " ;; ugh
213 (define (define-origin a b c ) "")
214 (define (no-origin) "")
217 (cond ((eq? action-name 'all-definitions)
220 (define tuplet ,tuplet)
221 (define bracket ,bracket)
223 (define hairpin ,hairpin)
224 (define volta ,volta)
225 (define bezier-sandwich ,bezier-sandwich)
226 (define dashed-line ,dashed-line)
227 (define dashed-slur ,dashed-slur)
228 (define end-output ,end-output)
229 (define experimental-on ,experimental-on)
230 (define filledbox ,filledbox)
232 (define font-def ,font-def)
233 (define font-switch ,font-switch)
234 (define header-end ,header-end)
235 (define lily-def ,lily-def)
236 (define font-load-command ,font-load-command)
237 (define header ,header)
238 (define invoke-char ,invoke-char)
239 (define invoke-dim1 ,invoke-dim1)
240 (define placebox ,placebox)
241 (define select-font ,select-font)
242 (define start-line ,start-line)
244 (define stop-line ,stop-line)
245 (define stop-last-line ,stop-line)
246 (define repeat-slash ,repeat-slash)
248 (define no-origin ,no-origin)
249 (define define-origin ,define-origin)
250 (define ez-ball ,ez-ball)
252 ((eq? action-name 'repeat-slash) repeat-slash)
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 'dashed-line) dashed-line)
259 ((eq? action-name 'dashed-slur) dashed-slur)
260 ((eq? action-name 'hairpin) hairpin)
261 ((eq? action-name 'experimental-on) experimental-on)
262 ((eq? action-name 'filledbox) filledbox)
263 ((eq? action-name 'ez-ball) ez-ball)
264 ((eq? action-name 'select-font) select-font)
265 ((eq? action-name 'volta) volta)
266 (else (error "unknown tag -- SKETCH-SCM " action-name))