1 ;;;; drum-"hack". See input/tricks/drums.ly and ly/drumpitch.ly
2 ;;;; 2001/03/25 Rune Zedeler <rune@zedeler.dk>
4 ;;;; changed eval to primitive-eval for guile 1.4/1.4.1 compatibility --jcn
7 (define drum-pitch-names `(
8 (acousticbassdrum bda ,(make-pitch -3 6 0 ))
9 (bassdrum bd ,(make-pitch -2 0 0 ))
10 (hisidestick ssh ,(make-pitch -3 6 2))
11 (sidestick ss ,(make-pitch -2 0 1))
12 (losidestick ssl ,(make-pitch -2 1 -1))
13 (acousticsnare sna ,(make-pitch -2 1 0))
14 (snare sn ,(make-pitch -2 2 -2))
15 (handclap hc ,(make-pitch -2 1 1))
16 (electricsnare sne ,(make-pitch -2 2 0))
17 (lowfloortom tomfl ,(make-pitch -2 3 0))
18 (closedhihat hhc ,(make-pitch -2 3 1))
19 (hihat hh ,(make-pitch -2 4 -1))
20 (highfloortom tomfh ,(make-pitch -2 4 0))
21 (pedalhihat hhp ,(make-pitch -2 4 1))
22 (lowtom toml ,(make-pitch -2 5 0))
23 (openhihat hho ,(make-pitch -2 5 1))
24 (halfopenhihat hhho ,(make-pitch -2 5 1))
25 (lowmidtom tomml ,(make-pitch -2 6 0))
26 (himidtom tommh ,(make-pitch -1 0 0))
27 (crashcymbala cymca ,(make-pitch -1 0 1))
28 (crashcymbal cymc ,(make-pitch -1 1 -1))
29 (hightom tomh ,(make-pitch -1 1 0))
30 (ridecymbala cymra ,(make-pitch -1 1 1))
31 (ridecymbal cymr ,(make-pitch -1 2 -1))
32 (chinesecymbal cymch ,(make-pitch -1 2 0))
33 (ridebell rb ,(make-pitch -1 3 0))
34 (tambourine tamb ,(make-pitch -1 3 1))
35 (splashcymbal cyms ,(make-pitch -1 4 0))
36 (cowbell cb ,(make-pitch -1 4 1))
37 (crashcymbalb cymcb ,(make-pitch -1 5 0))
38 (vibraslap vibs ,(make-pitch -1 5 1))
39 (ridecymbalb cymrb ,(make-pitch -1 6 0))
40 (mutehibongo bohm ,(make-pitch -1 6 1))
41 (hibongo boh ,(make-pitch 0 0 0))
42 (openhibongo boho ,(make-pitch 0 1 -2))
43 (mutelobongo bolm ,(make-pitch -1 6 2))
44 (lobongo bol ,(make-pitch 0 0 1))
45 (openlobongo bolo ,(make-pitch 0 1 -1))
46 (mutehiconga cghm ,(make-pitch 0 1 0))
47 (muteloconga cglm ,(make-pitch 0 2 -2))
48 (openhiconga cgho ,(make-pitch 0 1 1))
49 (hiconga cgh ,(make-pitch 0 2 -1))
50 (openloconga cglo ,(make-pitch 0 1 2))
51 (loconga cgl ,(make-pitch 0 2 0))
52 (hitimbale timh ,(make-pitch 0 3 0))
53 (lotimbale timl ,(make-pitch 0 3 1))
54 (hiagogo agh ,(make-pitch 0 4 0))
55 (loagogo agl ,(make-pitch 0 4 1))
56 (cabasa cab ,(make-pitch 0 5 0))
57 (maracas mar ,(make-pitch 0 5 1))
58 (shortwhistle whs ,(make-pitch 0 6 0))
59 (longwhistle whl ,(make-pitch 1 0 0))
60 (shortguiro guis ,(make-pitch 1 0 1))
61 (longguiro guil ,(make-pitch 1 1 0))
62 (guiro gui ,(make-pitch 1 0 2))
63 (claves cl ,(make-pitch 1 1 1))
64 (hiwoodblock wbh ,(make-pitch 1 2 0))
65 (lowoodblock wbl ,(make-pitch 1 3 0))
66 (mutecuica cuim ,(make-pitch 1 3 1))
67 (opencuica cuio ,(make-pitch 1 4 0))
68 (mutetriangle trim ,(make-pitch 1 4 1))
69 (triangle tri ,(make-pitch 1 4 2))
70 (opentriangle trio ,(make-pitch 1 5 0))
71 ;; "transposing" pitches:
72 (oneup ua ,(make-pitch 0 1 0))
73 (twoup ub ,(make-pitch 0 2 0))
74 (threeup uc ,(make-pitch 0 3 0))
75 (fourup ud ,(make-pitch 0 4 0))
76 (fiveup ue ,(make-pitch 0 5 0))
77 (onedown da ,(make-pitch -1 6 0))
78 (twodown db ,(make-pitch -1 5 0))
79 (threedown dc ,(make-pitch -1 4 0))
80 (fourdown dd ,(make-pitch -1 3 0))
81 (fivedown de ,(make-pitch -1 2 0))
85 (acousticbassdrum default #f ,(make-pitch -1 4 0))
86 (bassdrum default #f ,(make-pitch -1 4 0))
87 (sidestick cross #f ,(make-pitch 0 1 0))
88 (acousticsnare default #f ,(make-pitch 0 1 0))
89 (snare default #f ,(make-pitch 0 1 0))
90 (handclap triangle #f ,(make-pitch 0 1 0))
91 (electricsnare default #f ,(make-pitch 0 1 0))
92 (lowfloortom default #f ,(make-pitch -1 3 0))
93 (closedhihat cross "stopped" ,(make-pitch 0 3 0))
94 (hihat cross #f ,(make-pitch 0 3 0))
95 (highfloortom default #f ,(make-pitch -1 5 0))
96 (pedalhihat cross #f ,(make-pitch -1 2 0))
97 (lowtom default #f ,(make-pitch -1 6 0))
98 (openhihat cross "open" ,(make-pitch 0 3 0))
99 (halfopenhihat xcircle #f ,(make-pitch 0 3 0))
100 (lowmidtom default #f ,(make-pitch 0 0 0))
101 (himidtom default #f ,(make-pitch 0 2 0))
102 (crashcymbala xcircle #f ,(make-pitch 0 5 0))
103 (crashcymbal xcircle #f ,(make-pitch 0 5 0))
104 (hightom default #f ,(make-pitch 0 4 0))
105 (ridecymbala cross #f ,(make-pitch 0 5 0))
106 (ridecymbal cross #f ,(make-pitch 0 5 0))
107 (chinesecymbal mensural #f ,(make-pitch 0 5 0))
108 (ridebell default #f ,(make-pitch 0 5 0))
109 (splashcymbal diamond #f ,(make-pitch 0 5 0))
110 (cowbell triangle #f ,(make-pitch 0 5 0))
111 (crashcymbalb cross #f ,(make-pitch 0 5 0))
112 (vibraslap diamond #f ,(make-pitch 0 4 0))
113 (ridecymbalb cross #f ,(make-pitch 0 5 0))
117 (losidestick cross #f ,(make-pitch -1 6 0))
118 (lotimbale default #f ,(make-pitch -1 6 0))
119 (cowbell triangle #f ,(make-pitch 0 2 0))
120 (hisidestick cross #f ,(make-pitch 0 1 0))
121 (hitimbale default #f ,(make-pitch 0 1 0))
125 (losidestick cross #f ,(make-pitch -1 6 0))
126 (loconga default #f ,(make-pitch -1 6 0))
127 (openloconga default "open" ,(make-pitch -1 6 0))
128 (muteloconga default "stopped" ,(make-pitch -1 6 0))
129 (hisidestick cross #f ,(make-pitch 0 1 0))
130 (hiconga default #f ,(make-pitch 0 1 0))
131 (openhiconga default "open" ,(make-pitch 0 1 0))
132 (mutehiconga default "stopped" ,(make-pitch 0 1 0))
137 (losidestick cross #f ,(make-pitch -1 6 0))
138 (lobongo default #f ,(make-pitch -1 6 0))
139 (openlobongo default "open" ,(make-pitch -1 6 0))
140 (mutelobongo default "stopped" ,(make-pitch -1 6 0))
141 (hisidestick cross #f ,(make-pitch 0 1 0))
142 (hibongo default #f ,(make-pitch 0 1 0))
143 (openhibongo default "open" ,(make-pitch 0 1 0))
144 (mutehibongo default "stopped" ,(make-pitch 0 1 0))
148 (define percussion `(
149 (opentriangle cross "open" ,(make-pitch 0 0 0))
150 (mutetriangle cross "stopped" ,(make-pitch 0 0 0))
151 (triangle cross #f ,(make-pitch 0 0 0))
152 (shortguiro default "staccato",(make-pitch 0 0 0))
153 (longguiro default "tenuto" ,(make-pitch 0 0 0))
154 (guiro default #f ,(make-pitch 0 0 0))
155 (cowbell triangle #f ,(make-pitch 0 0 0))
156 (claves default #f ,(make-pitch 0 0 0))
157 (tambourine default #f ,(make-pitch 0 0 0))
158 (cabasa cross #f ,(make-pitch 0 0 0))
159 (maracas default #f ,(make-pitch 0 0 0))
160 (handclap default #f ,(make-pitch 0 0 0))
163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
166 (define (make-articulation-script x)
167 (let* ( (m (ly-make-music "Articulation_req"))
169 (ly-set-mus-property m 'articulation-type x)
174 ;; adds the articulation script x to m if x is not #f.
175 (define (add-articulation-script m x)
177 (if (and x (equal? (ly-music-name m) "Request_chord"))
178 (ly-set-mus-property m 'elements
179 (cons (make-articulation-script x) (ly-get-mus-property m 'elements))
181 (let* ( (es (ly-get-mus-property m 'elements))
182 (e (ly-get-mus-property m 'element)) )
183 (map (lambda (y) (add-articulation-script y x)) es)
185 (add-articulation-script e x))
192 (define (make-head-type-elem t)
193 (let* ( (m (ly-make-music "Music"))
195 (ly-set-mus-property m 'iterator-ctor Push_property_iterator::constructor)
196 (ly-set-mus-property m 'symbol 'NoteHead)
197 (ly-set-mus-property m 'grob-property 'style)
198 (ly-set-mus-property m 'grob-value t)
203 (define (make-head-type t)
204 (let* ( (m (ly-make-music "Context_specced_music"))
205 (e (make-head-type-elem t))
207 (ly-set-mus-property m 'element e)
208 (ly-set-mus-property m 'context-type "Thread")
213 (define (make-thread-context thread-name element)
214 (let* ( (m (ly-make-music "Context_specced_music")))
215 (ly-set-mus-property m 'element element)
216 (ly-set-mus-property m 'context-type "Thread")
217 (ly-set-mus-property m 'context-id (symbol->string thread-name))
222 ;; makes a sequential-music of thread-context, head-change and note
223 (define (make-drum-head kit req-ch )
224 (let ((es (ly-get-mus-property req-ch 'elements)))
228 (oldp (ly-get-mus-property fe 'pitch))
230 (if (not (pitch? oldp))
232 (let* ((pap ((pitch->paper kit) oldp ))
236 (ht (make-head-type style))
237 (seq (make-sequential-music (list ht req-ch)))
239 (add-articulation-script req-ch script)
240 (ly-set-mus-property fe 'pitch pitch)
241 (set! req-ch (make-thread-context style seq))
250 ;; whoa, hadn't head of "assoc" when I made this :)
251 (define ((pitch->paper kit) p)
252 (let p2p ((pitches drum-pitch-names))
253 (cond ((eq? pitches '())
255 (display p) ;; UGH. FIXME. pitch->string ???
256 (ly-warn " unknown drumpitch.")
257 (cdar (primitive-eval kit))
259 ((eq? p (caddr (car pitches))) ((name->paper kit) (caar pitches)) )
260 (else (p2p (cdr pitches) ) )
264 (define ((name->paper kit) n)
265 (let n2p ((pitches (primitive-eval kit)))
266 (cond ((eq? pitches '())
268 (ly-warn (string-append "Kit `" (symbol->string kit) "' doesn't contain drum `" n
269 "'\nSee lily/drumpitch.ly for supported drums."))
270 (cdar (primitive-eval kit))
272 ((eq? n (caar pitches)) (cdar pitches) )
273 (else (n2p (cdr pitches) ) )
279 ;; converts a midi-pitched (ly/drumpitch.ly) file to paper output.
280 (define ((drums->paper kit) music)
282 (if (equal? (ly-music-name music) "Request_chord")
283 (set! music (make-drum-head kit music))
284 (let* ((es (ly-get-mus-property music 'elements))
285 (e (ly-get-mus-property music 'element))
286 (p (ly-get-mus-property music 'pitch))
287 (body (ly-get-mus-property music 'body))
288 (alts (ly-get-mus-property music 'alternatives)))
291 (ly-set-mus-property music 'elements (map (drums->paper kit) es) )
297 ((drums->paper kit) alts)))
302 ((drums->paper kit) body)))
308 ((drums->paper kit) e))