scm/drums.scm

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