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
6 (define (make-articulation-script x)
7 (let* ( (m (ly-make-music "Articulation_req"))
9 (ly-set-mus-property m 'articulation-type x)
14 ;; adds the articulation script x to m if x is not #f.
15 (define (add-articulation-script m x)
17 (if (and x (equal? (ly-music-name m) "Request_chord"))
18 (ly-set-mus-property m 'elements
19 (cons (make-articulation-script x) (ly-get-mus-property m 'elements))
21 (let* ( (es (ly-get-mus-property m 'elements))
22 (e (ly-get-mus-property m 'element)) )
23 (map (lambda (y) (add-articulation-script y x)) es)
25 (add-articulation-script e x))
32 (define (make-head-type-elem t)
33 (let* ( (m (ly-make-music "Music"))
35 (ly-set-mus-property m 'iterator-ctor Push_property_iterator::constructor)
36 (ly-set-mus-property m 'symbols 'NoteHead)
37 (ly-set-mus-property m 'grob-property 'style)
38 (ly-set-mus-property m 'grob-value t)
43 (define (make-head-type t)
44 (let* ( (m (ly-make-music "Context_specced_music"))
45 (e (make-head-type-elem t))
47 (ly-set-mus-property m 'element e)
48 (ly-set-mus-property m 'context-type "Thread")
53 (define (make-thread-context thread-name element)
54 (let* ( (m (ly-make-music "Context_specced_music")))
55 (ly-set-mus-property m 'element element)
56 (ly-set-mus-property m 'context-type "Thread")
57 (ly-set-mus-property m 'context-id (symbol->string thread-name))
62 ;; makes a sequential-music of thread-context, head-change and note
63 (define (make-drum-head kit req-ch )
64 (let ((es (ly-get-mus-property req-ch 'elements)))
68 (oldp (ly-get-mus-property fe 'pitch))
70 (if (not (pitch? oldp))
72 (let* ((pap ((pitch->paper kit) oldp ))
76 (ht (make-head-type style))
77 (seq (make-sequential-music (list ht req-ch)))
79 (add-articulation-script req-ch script)
80 (ly-set-mus-property fe 'pitch pitch)
81 (set! req-ch (make-thread-context style seq))
90 ;; whoa, hadn't head of "assoc" when I made this :)
91 (define ((pitch->paper kit) p)
92 (let p2p ((pitches drum-pitch-names))
93 (cond ((eq? pitches '())
95 (display p) ;; UGH. FIXME. pitch->string ???
96 (ly-warn " unknown drumpitch.")
97 (cdar (primitive-eval kit))
99 ((eq? p (caddr (car pitches))) ((name->paper kit) (caar pitches)) )
100 (else (p2p (cdr pitches) ) )
104 (define ((name->paper kit) n)
105 (let n2p ((pitches (primitive-eval kit)))
106 (cond ((eq? pitches '())
108 (ly-warn (string-append "Kit `" (symbol->string kit) "' doesn't contain drum `" n
109 "'\nSee lily/drumpitch.ly for supported drums."))
110 (cdar (primitive-eval kit))
112 ((eq? n (caar pitches)) (cdar pitches) )
113 (else (n2p (cdr pitches) ) )
119 ;; converts a midi-pitched (ly/drumpitch.ly) file to paper output.
120 (define ((drums->paper kit) music)
122 (if (equal? (ly-music-name music) "Request_chord")
123 (set! music (make-drum-head kit music))
124 (let* ((es (ly-get-mus-property music 'elements))
125 (e (ly-get-mus-property music 'element))
126 (p (ly-get-mus-property music 'pitch))
127 (body (ly-get-mus-property music 'body))
128 (alts (ly-get-mus-property music 'alternatives)))
131 (ly-set-mus-property music 'elements (map (drums->paper kit) es) )
137 ((drums->paper kit) alts)))
142 ((drums->paper kit) body)))
148 ((drums->paper kit) e))