1 ;;;; drum-"hack". See input/regression/drums.ly and ly/drumpitch-init.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
6 ;; TODO: the design of this hack should be rethought.
9 ;; ugh. Should make separate module?
10 (define-public drum-pitch-names `(
11 (acousticbassdrum bda ,(ly:make-pitch -3 6 NATURAL))
12 (bassdrum bd ,(ly:make-pitch -2 0 NATURAL))
13 (hisidestick ssh ,(ly:make-pitch -3 6 DOUBLE-SHARP))
14 (sidestick ss ,(ly:make-pitch -2 0 SHARP))
15 (losidestick ssl ,(ly:make-pitch -2 1 FLAT))
16 (acousticsnare sna ,(ly:make-pitch -2 1 NATURAL))
17 (snare sn ,(ly:make-pitch -2 2 DOUBLE-FLAT))
18 (handclap hc ,(ly:make-pitch -2 1 SHARP))
19 (electricsnare sne ,(ly:make-pitch -2 2 NATURAL))
20 (lowfloortom tomfl ,(ly:make-pitch -2 3 NATURAL))
21 (closedhihat hhc ,(ly:make-pitch -2 3 SHARP))
22 (hihat hh ,(ly:make-pitch -2 4 FLAT))
23 (highfloortom tomfh ,(ly:make-pitch -2 4 NATURAL))
24 (pedalhihat hhp ,(ly:make-pitch -2 4 SHARP))
25 (lowtom toml ,(ly:make-pitch -2 5 NATURAL))
26 (openhihat hho ,(ly:make-pitch -2 5 SHARP))
27 (halfopenhihat hhho ,(ly:make-pitch -2 5 SHARP))
28 (lowmidtom tomml ,(ly:make-pitch -2 6 NATURAL))
29 (himidtom tommh ,(ly:make-pitch -1 0 NATURAL))
30 (crashcymbala cymca ,(ly:make-pitch -1 0 SHARP))
31 (crashcymbal cymc ,(ly:make-pitch -1 1 FLAT))
32 (hightom tomh ,(ly:make-pitch -1 1 NATURAL))
33 (ridecymbala cymra ,(ly:make-pitch -1 1 SHARP))
34 (ridecymbal cymr ,(ly:make-pitch -1 2 FLAT))
35 (chinesecymbal cymch ,(ly:make-pitch -1 2 NATURAL))
36 (ridebell rb ,(ly:make-pitch -1 3 NATURAL))
37 (tambourine tamb ,(ly:make-pitch -1 3 SHARP))
38 (splashcymbal cyms ,(ly:make-pitch -1 4 NATURAL))
39 (cowbell cb ,(ly:make-pitch -1 4 SHARP))
40 (crashcymbalb cymcb ,(ly:make-pitch -1 5 NATURAL))
41 (vibraslap vibs ,(ly:make-pitch -1 5 SHARP))
42 (ridecymbalb cymrb ,(ly:make-pitch -1 6 NATURAL))
43 (mutehibongo bohm ,(ly:make-pitch -1 6 SHARP))
44 (hibongo boh ,(ly:make-pitch 0 0 NATURAL))
45 (openhibongo boho ,(ly:make-pitch 0 1 DOUBLE-FLAT))
46 (mutelobongo bolm ,(ly:make-pitch -1 6 DOUBLE-SHARP))
47 (lobongo bol ,(ly:make-pitch 0 0 SHARP))
48 (openlobongo bolo ,(ly:make-pitch 0 1 FLAT))
49 (mutehiconga cghm ,(ly:make-pitch 0 1 NATURAL))
50 (muteloconga cglm ,(ly:make-pitch 0 2 DOUBLE-FLAT))
51 (openhiconga cgho ,(ly:make-pitch 0 1 SHARP))
52 (hiconga cgh ,(ly:make-pitch 0 2 FLAT))
53 (openloconga cglo ,(ly:make-pitch 0 1 DOUBLE-SHARP))
54 (loconga cgl ,(ly:make-pitch 0 2 NATURAL))
55 (hitimbale timh ,(ly:make-pitch 0 3 NATURAL))
56 (lotimbale timl ,(ly:make-pitch 0 3 SHARP))
57 (hiagogo agh ,(ly:make-pitch 0 4 NATURAL))
58 (loagogo agl ,(ly:make-pitch 0 4 SHARP))
59 (cabasa cab ,(ly:make-pitch 0 5 NATURAL))
60 (maracas mar ,(ly:make-pitch 0 5 SHARP))
61 (shortwhistle whs ,(ly:make-pitch 0 6 NATURAL))
62 (longwhistle whl ,(ly:make-pitch 1 0 NATURAL))
63 (shortguiro guis ,(ly:make-pitch 1 0 SHARP))
64 (longguiro guil ,(ly:make-pitch 1 1 NATURAL))
65 (guiro gui ,(ly:make-pitch 1 0 DOUBLE-SHARP))
66 (claves cl ,(ly:make-pitch 1 1 SHARP))
67 (hiwoodblock wbh ,(ly:make-pitch 1 2 NATURAL))
68 (lowoodblock wbl ,(ly:make-pitch 1 3 NATURAL))
69 (mutecuica cuim ,(ly:make-pitch 1 3 SHARP))
70 (opencuica cuio ,(ly:make-pitch 1 4 NATURAL))
71 (mutetriangle trim ,(ly:make-pitch 1 4 SHARP))
72 (triangle tri ,(ly:make-pitch 1 4 DOUBLE-SHARP))
73 (opentriangle trio ,(ly:make-pitch 1 5 NATURAL))
74 ;; "transposing" pitches:
75 (oneup ua ,(ly:make-pitch 0 1 NATURAL))
76 (twoup ub ,(ly:make-pitch 0 2 NATURAL))
77 (threeup uc ,(ly:make-pitch 0 3 NATURAL))
78 (fourup ud ,(ly:make-pitch 0 4 NATURAL))
79 (fiveup ue ,(ly:make-pitch 0 5 NATURAL))
80 (onedown da ,(ly:make-pitch -1 6 NATURAL))
81 (twodown db ,(ly:make-pitch -1 5 NATURAL))
82 (threedown dc ,(ly:make-pitch -1 4 NATURAL))
83 (fourdown dd ,(ly:make-pitch -1 3 NATURAL))
84 (fivedown de ,(ly:make-pitch -1 2 NATURAL))
88 ;; all settings for percussive instruments.
89 ;; public so people can add their own stuff.
93 percussive-instrument-init-settings
96 (acousticbassdrum default #f ,(ly:make-pitch -1 4 NATURAL))
97 (bassdrum default #f ,(ly:make-pitch -1 4 NATURAL))
98 (sidestick cross #f ,(ly:make-pitch 0 1 NATURAL))
99 (acousticsnare default #f ,(ly:make-pitch 0 1 NATURAL))
100 (snare default #f ,(ly:make-pitch 0 1 NATURAL))
101 (handclap triangle #f ,(ly:make-pitch 0 1 NATURAL))
102 (electricsnare default #f ,(ly:make-pitch 0 1 NATURAL))
103 (lowfloortom default #f ,(ly:make-pitch -1 3 NATURAL))
104 (closedhihat cross "stopped" ,(ly:make-pitch 0 3 NATURAL))
105 (hihat cross #f ,(ly:make-pitch 0 3 NATURAL))
106 (highfloortom default #f ,(ly:make-pitch -1 5 NATURAL))
107 (pedalhihat cross #f ,(ly:make-pitch -1 2 NATURAL))
108 (lowtom default #f ,(ly:make-pitch -1 6 NATURAL))
109 (openhihat cross "open" ,(ly:make-pitch 0 3 NATURAL))
110 (halfopenhihat xcircle #f ,(ly:make-pitch 0 3 NATURAL))
111 (lowmidtom default #f ,(ly:make-pitch 0 0 NATURAL))
112 (himidtom default #f ,(ly:make-pitch 0 2 NATURAL))
113 (crashcymbala xcircle #f ,(ly:make-pitch 0 5 NATURAL))
114 (crashcymbal xcircle #f ,(ly:make-pitch 0 5 NATURAL))
115 (hightom default #f ,(ly:make-pitch 0 4 NATURAL))
116 (ridecymbala cross #f ,(ly:make-pitch 0 5 NATURAL))
117 (ridecymbal cross #f ,(ly:make-pitch 0 5 NATURAL))
118 (chinesecymbal mensural #f ,(ly:make-pitch 0 5 NATURAL))
119 (ridebell default #f ,(ly:make-pitch 0 5 NATURAL))
120 (splashcymbal diamond #f ,(ly:make-pitch 0 5 NATURAL))
121 (cowbell triangle #f ,(ly:make-pitch 0 5 NATURAL))
122 (crashcymbalb cross #f ,(ly:make-pitch 0 5 NATURAL))
123 (vibraslap diamond #f ,(ly:make-pitch 0 4 NATURAL))
124 (ridecymbalb cross #f ,(ly:make-pitch 0 5 NATURAL))
129 (losidestick cross #f ,(ly:make-pitch -1 6 NATURAL))
130 (lotimbale default #f ,(ly:make-pitch -1 6 NATURAL))
131 (cowbell triangle #f ,(ly:make-pitch 0 2 NATURAL))
132 (hisidestick cross #f ,(ly:make-pitch 0 1 NATURAL))
133 (hitimbale default #f ,(ly:make-pitch 0 1 NATURAL))
138 (losidestick cross #f ,(ly:make-pitch -1 6 NATURAL))
139 (loconga default #f ,(ly:make-pitch -1 6 NATURAL))
140 (openloconga default "open" ,(ly:make-pitch -1 6 NATURAL))
141 (muteloconga default "stopped" ,(ly:make-pitch -1 6 NATURAL))
142 (hisidestick cross #f ,(ly:make-pitch 0 1 NATURAL))
143 (hiconga default #f ,(ly:make-pitch 0 1 NATURAL))
144 (openhiconga default "open" ,(ly:make-pitch 0 1 NATURAL))
145 (mutehiconga default "stopped" ,(ly:make-pitch 0 1 NATURAL))
150 (losidestick cross #f ,(ly:make-pitch -1 6 NATURAL))
151 (lobongo default #f ,(ly:make-pitch -1 6 NATURAL))
152 (openlobongo default "open" ,(ly:make-pitch -1 6 NATURAL))
153 (mutelobongo default "stopped" ,(ly:make-pitch -1 6 NATURAL))
154 (hisidestick cross #f ,(ly:make-pitch 0 1 NATURAL))
155 (hibongo default #f ,(ly:make-pitch 0 1 NATURAL))
156 (openhibongo default "open" ,(ly:make-pitch 0 1 NATURAL))
157 (mutehibongo default "stopped" ,(ly:make-pitch 0 1 NATURAL))
163 (opentriangle cross "open" ,(ly:make-pitch 0 0 NATURAL))
164 (mutetriangle cross "stopped" ,(ly:make-pitch 0 0 NATURAL))
165 (triangle cross #f ,(ly:make-pitch 0 0 NATURAL))
166 (shortguiro default "staccato",(ly:make-pitch 0 0 NATURAL))
167 (longguiro default "tenuto" ,(ly:make-pitch 0 0 NATURAL))
168 (guiro default #f ,(ly:make-pitch 0 0 NATURAL))
169 (cowbell triangle #f ,(ly:make-pitch 0 0 NATURAL))
170 (claves default #f ,(ly:make-pitch 0 0 NATURAL))
171 (tambourine default #f ,(ly:make-pitch 0 0 NATURAL))
172 (cabasa cross #f ,(ly:make-pitch 0 0 NATURAL))
173 (maracas default #f ,(ly:make-pitch 0 0 NATURAL))
174 (handclap default #f ,(ly:make-pitch 0 0 NATURAL))
179 (define percussive-instrument-settings percussive-instrument-init-settings)
181 ;; don't use assoc-set!, since this will overwrite Scheme defaults, and leak
183 (define-public (set-drum-kit kit value)
184 (set! percussive-instrument-settings
185 (acons kit value percussive-instrument-settings)))
187 (define-public (reset-drum-kit)
188 (set! percussive-instrument-settings percussive-instrument-init-settings))
190 (define-public (get-drum-kit kit)
191 (assoc-get-default kit percussive-instrument-settings '()))
194 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
197 (define (make-articulation-script x)
198 (let* ((m (make-music-by-name 'ArticulationEvent)))
199 (ly:set-mus-property! m 'articulation-type x)
202 ;; adds the articulation script x to m if x is not #f.
203 (define (add-articulation-script m x)
205 (if (and x (equal? (ly:get-mus-property m 'name) 'EventChord))
206 (ly:set-mus-property! m 'elements
207 (cons (make-articulation-script x) (ly:get-mus-property m 'elements))
209 (let* ( (es (ly:get-mus-property m 'elements))
210 (e (ly:get-mus-property m 'element)) )
211 (map (lambda (y) (add-articulation-script y x)) es)
213 (add-articulation-script e x))
220 (define (make-head-type-elem t)
221 (let* ( (m (make-music-by-name 'OverrideProperty)))
224 `((symbol . NoteHead)
225 (grob-property . style)
233 (define (make-head-type t)
234 (context-spec-music (make-head-type-elem t) 'Thread))
236 (define (make-thread-context thread-name element)
237 (context-spec-music element 'Thread thread-name))
239 ;; makes a sequential-music of thread-context, head-change and note
240 (define (make-drum-head kit req-ch )
241 (let ((es (ly:get-mus-property req-ch 'elements)))
245 (oldp (ly:get-mus-property fe 'pitch))
247 (if (not (ly:pitch? oldp))
249 (let* ((pap ((pitch->paper kit) oldp ))
253 (ht (make-head-type style))
254 (seq (make-sequential-music (list ht req-ch)))
256 (add-articulation-script req-ch script)
257 (ly:set-mus-property! fe 'pitch pitch)
258 (set! req-ch (make-thread-context (symbol->string style) seq))
267 ;; whoa, hadn't head of "assoc" when I made this :)
268 (define ((pitch->paper kit) p)
269 (let p2p ((pitches drum-pitch-names))
270 (cond ((eq? pitches '())
272 (display p) ;; UGH. FIXME. pitch->string ???
273 (ly:warn " unknown drumpitch.")
274 (cdar (get-drum-kit kit))
276 ((eq? p (caddr (car pitches))) ((name->paper kit) (caar pitches)) )
277 (else (p2p (cdr pitches) ) )
282 (define ((name->paper kit) n)
283 (let n2p ((pitches (get-drum-kit kit)))
284 (cond ((eq? pitches '())
286 (ly:warn (string-append "Kit `" (symbol->string kit) "' doesn't contain drum `" n
287 "'\nSee ly/drumpitch-init.ly for supported drums."))
288 (cdar (get-drum-kit kit))
290 ((eq? n (caar pitches)) (cdar pitches) )
291 (else (n2p (cdr pitches) ) )
297 ;; converts a midi-pitched (ly/drumpitch.ly) file to paper output.
299 (define-public ((drums->paper kit) music)
301 (if (equal? (ly:get-mus-property music 'name) 'EventChord)
302 (set! music (make-drum-head kit music))
303 (let* ((es (ly:get-mus-property music 'elements))
304 (e (ly:get-mus-property music 'element))
305 (p (ly:get-mus-property music 'pitch))
306 (body (ly:get-mus-property music 'body))
307 (alts (ly:get-mus-property music 'alternatives)))
310 (ly:set-mus-property! music 'elements (map (drums->paper kit) es) )
314 (ly:set-mus-property!
316 ((drums->paper kit) alts)))
319 (ly:set-mus-property!
321 ((drums->paper kit) body)))
325 (ly:set-mus-property!
327 ((drums->paper kit) e))