scm/drums.scm

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