3 (use-modules (ice-9 format))
5 (define (ascii->string i) (make-string 1 (integer->char i)))
7 (define (control->list c)
8 (list (+ global-x (car c)) (+ global-y (cdr c))))
10 (define (control-flip-y c)
11 (cons (car c) (* -1 (cdr c))))
14 (define (sk-numbers->string l)
16 (number->string (car l))
19 (string-append "," (sk-numbers->string (cdr l))))))
23 (define global-list '())
24 (define global-font "")
26 (define global-scale 1.0)
27 (define (global-mul-scale x) (* global-scale x))
29 ;; hmm, global is global
30 (define (global-filledbox width dy dx height x y)
36 (map global-mul-scale (list width dy dx height x y)))
39 (define (global-bezier l)
40 (let* ((c0 (car (list-tail l 3)))
41 (c123 (list-head l 3))
42 (start (control->list c0))
43 (control (apply append (map control->list c123))))
45 "bs(" (sk-numbers->string (map global-mul-scale start)) ",0)\n"
46 "bc(" (sk-numbers->string (map global-mul-scale control)) ",2)\n")))
49 (define (global-beziers l thick)
50 (let* (;;(burp (set! global-y (+ global-y (* 2 (cdar l)))))
61 (global-bezier second)
66 (define (sketch-scm action-name)
68 ;; alist containing fontname -> fontcommand assoc (both strings)
69 (define font-alist '())
71 (define current-font "")
76 (define (cached-fontname i)
79 (define (select-font name-mag-pair)
80 (set! global-font (car name-mag-pair))
83 (define (font-load-command name-mag command)
86 (define (beam width slope thick)
99 (string-append "% " s))
101 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
103 (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
107 ;; `(string-append "txt(" ,(number->string i) ",("
108 ;; (sk-numbers->string (list global-x global-y))
113 ;; "Fn('" global-font "')\n"
114 ;; "Fn('Times-Roman')\n"
117 ;; chars > 128 don't work yet
118 "txt('" ,(ascii->string (modulo i 128)) "',("
119 ;; "char(" ,(number->string i) ",("
120 (sk-numbers->string (list (* global-scale global-x)
121 (* global-scale global-y)))
124 (define (hairpin thick width starth endh )
126 (numbers->string (list width starth endh thick))
129 ;; what the heck is this interface ?
130 (define (dashed-slur thick dash l)
132 (apply string-append (map control->string l))
133 (ly-number->string thick)
135 (ly-number->string dash)
137 (ly-number->string (* 10 thick)) ;UGH. 10 ?
138 " ] 0 draw_dashed_slur"))
140 (define (dashed-line thick on off dx dy)
142 (ly-number->string dx)
144 (ly-number->string dy)
146 (ly-number->string thick)
148 (ly-number->string on)
150 (ly-number->string off)
151 " ] 0 draw_dashed_line"))
153 (define (repeat-slash wid slope thick)
154 (string-append (numbers->string (list wid slope thick))
155 " draw_repeat_slash"))
158 "guidelayer('Guide Lines',1,0,0,1,(0,0,1))
159 grid((0,0,20,20),0,(0,0,1),'Grid')\n")
161 (define (experimental-on) "")
163 (define (font-switch i)
169 (define (lily-def key val)
170 (if (equal? key "lilypondpaperoutputscale")
171 (set! global-scale (string->number val)))
175 (define (header creator generate)
180 layer('Layer 1',1,1,0,0,(0,0,0))
183 (define (invoke-char s i)
186 (define (invoke-dim1 s d)
188 (ly-number->string (* d (/ 72.27 72))) " " s ))
191 (define (placebox x y s)
192 ;; (format (current-error-port) "placebox: ~S, ~S, ~S\n" x y s)
193 (set! global-x (+ x 0))
194 (set! global-y (+ y 100))
195 (let ((s (primitive-eval global-s)))
199 (define (bezier-sandwich l thick)
205 (set! global-list l))
208 ; TODO: use HEIGHT argument
209 (define (start-line height)
213 ;; r((520.305,0,0,98.0075,51.8863,10.089))
214 ;; width, 0, 0, height, x, y
215 (define (filledbox breapth width depth height)
221 `(- global-x ,breapth)
222 `(- global-y ,depth))))
223 ;; (format (current-error-port) "filledbox: ~S\n" s)
227 (define (stem x y z w) (filledbox x y z w))
235 `(string-append "txt('" ,s "',("
236 (sk-numbers->string (list global-x global-y))
240 (define (volta h w thick vert_start vert_end)
242 (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
245 (define (tuplet ht gap dx dy thick dir)
247 (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
254 (define (ez-ball ch letter-col ball-col)
257 (numbers->string (list letter-col ball-col))
258 " /Helvetica-Bold " ;; ugh
261 (define (define-origin a b c ) "")
262 (define (no-origin) "")
265 (cond ((eq? action-name 'all-definitions)
268 (define tuplet ,tuplet)
269 (define bracket ,bracket)
271 (define hairpin ,hairpin)
272 (define volta ,volta)
273 (define bezier-sandwich ,bezier-sandwich)
274 (define dashed-line ,dashed-line)
275 (define dashed-slur ,dashed-slur)
276 (define end-output ,end-output)
277 (define experimental-on ,experimental-on)
278 (define filledbox ,filledbox)
280 (define font-def ,font-def)
281 (define font-switch ,font-switch)
282 (define header-end ,header-end)
283 (define lily-def ,lily-def)
284 (define font-load-command ,font-load-command)
285 (define header ,header)
286 (define invoke-char ,invoke-char)
287 (define invoke-dim1 ,invoke-dim1)
288 (define placebox ,placebox)
289 (define select-font ,select-font)
290 (define start-line ,start-line)
292 (define stop-line ,stop-line)
293 (define stop-last-line ,stop-line)
294 (define repeat-slash ,repeat-slash)
296 (define no-origin ,no-origin)
297 (define define-origin ,define-origin)
298 (define ez-ball ,ez-ball)
300 ((eq? action-name 'repeat-slash) repeat-slash)
301 ((eq? action-name 'tuplet) tuplet)
302 ((eq? action-name 'beam) beam)
303 ((eq? action-name 'bezier-sandwich) bezier-sandwich)
304 ((eq? action-name 'bracket) bracket)
305 ((eq? action-name 'char) char)
306 ((eq? action-name 'dashed-line) dashed-line)
307 ((eq? action-name 'dashed-slur) dashed-slur)
308 ((eq? action-name 'hairpin) hairpin)
309 ((eq? action-name 'experimental-on) experimental-on)
310 ((eq? action-name 'filledbox) filledbox)
311 ((eq? action-name 'ez-ball) ez-ball)
312 ((eq? action-name 'select-font) select-font)
313 ((eq? action-name 'volta) volta)
314 (else (error "unknown tag -- SKETCH-SCM " action-name))