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 (define-public (set-drum-kit kit value)
  88   (set! percussive-instrument-settings
  89         (assoc-set! percussive-instrument-settings kit value)))
  90
  91 (define-public (get-drum-kit kit)
  92   (assoc-get-default kit percussive-instrument-settings '()))
  93
  94 ;;
  95 ;; all settings for percussive instruments.
  96 ;; public so people can add their own stuff.
  97 ;;
  98
  99 (define-public
 100   percussive-instrument-settings
 101   `((drums
 102     . (
 103            (acousticbassdrum default    #f        ,(ly:make-pitch -1 4 0))
 104            (bassdrum      default       #f        ,(ly:make-pitch -1 4 0))
 105            (sidestick     cross         #f        ,(ly:make-pitch 0 1 0))
 106            (acousticsnare         default       #f        ,(ly:make-pitch 0 1 0))
 107            (snare                 default       #f        ,(ly:make-pitch 0 1 0))
 108            (handclap      triangle      #f        ,(ly:make-pitch 0 1 0))
 109            (electricsnare         default       #f        ,(ly:make-pitch 0 1 0))
 110            (lowfloortom   default       #f        ,(ly:make-pitch -1 3 0))
 111            (closedhihat   cross         "stopped" ,(ly:make-pitch 0 3 0))
 112            (hihat                 cross         #f        ,(ly:make-pitch 0 3 0))
 113            (highfloortom          default       #f        ,(ly:make-pitch -1 5 0))
 114            (pedalhihat    cross         #f        ,(ly:make-pitch -1 2 0))
 115            (lowtom                default       #f        ,(ly:make-pitch -1 6 0))
 116            (openhihat     cross         "open"    ,(ly:make-pitch 0 3 0))
 117            (halfopenhihat         xcircle       #f        ,(ly:make-pitch 0 3 0))
 118            (lowmidtom     default       #f        ,(ly:make-pitch 0 0 0))
 119            (himidtom      default       #f        ,(ly:make-pitch 0 2 0))
 120            (crashcymbala          xcircle       #f        ,(ly:make-pitch 0 5 0))
 121            (crashcymbal   xcircle       #f        ,(ly:make-pitch 0 5 0))
 122            (hightom       default       #f        ,(ly:make-pitch 0 4 0))
 123            (ridecymbala   cross         #f        ,(ly:make-pitch 0 5 0))
 124            (ridecymbal    cross         #f        ,(ly:make-pitch 0 5 0))
 125            (chinesecymbal         mensural      #f        ,(ly:make-pitch 0 5 0))
 126            (ridebell      default       #f        ,(ly:make-pitch 0 5 0))
 127            (splashcymbal          diamond       #f        ,(ly:make-pitch 0 5 0))
 128            (cowbell       triangle      #f        ,(ly:make-pitch 0 5 0))
 129            (crashcymbalb          cross         #f        ,(ly:make-pitch 0 5 0))
 130            (vibraslap     diamond       #f        ,(ly:make-pitch 0 4 0))
 131            (ridecymbalb   cross         #f        ,(ly:make-pitch 0 5 0))
 132            ))
 133
 134   (timbales
 135    . (
 136       (losidestick        cross         #f        ,(ly:make-pitch -1 6 0))
 137       (lotimbale          default       #f        ,(ly:make-pitch -1 6 0))
 138       (cowbell    triangle      #f        ,(ly:make-pitch 0 2 0))
 139       (hisidestick        cross         #f        ,(ly:make-pitch 0 1 0))
 140       (hitimbale          default       #f        ,(ly:make-pitch 0 1 0))
 141       ))
 142
 143   (congas
 144    . (
 145       (losidestick        cross         #f        ,(ly:make-pitch -1 6 0))
 146       (loconga    default       #f        ,(ly:make-pitch -1 6 0))
 147       (openloconga      default       "open"    ,(ly:make-pitch -1 6 0))
 148       (muteloconga      default       "stopped" ,(ly:make-pitch -1 6 0))
 149       (hisidestick        cross         #f        ,(ly:make-pitch 0 1 0))
 150       (hiconga    default       #f        ,(ly:make-pitch 0 1 0))
 151       (openhiconga      default       "open"    ,(ly:make-pitch 0 1 0))
 152       (mutehiconga      default       "stopped" ,(ly:make-pitch 0 1 0))
 153       ))
 154
 155   (bongos
 156     . (
 157        (losidestick       cross         #f        ,(ly:make-pitch -1 6 0))
 158        (lobongo   default       #f        ,(ly:make-pitch -1 6 0))
 159        (openlobongo      default       "open"    ,(ly:make-pitch -1 6 0))
 160        (mutelobongo      default       "stopped" ,(ly:make-pitch -1 6 0))
 161        (hisidestick       cross         #f        ,(ly:make-pitch 0 1 0))
 162        (hibongo   default       #f        ,(ly:make-pitch 0 1 0))
 163        (openhibongo      default       "open"    ,(ly:make-pitch 0 1 0))
 164        (mutehibongo      default       "stopped" ,(ly:make-pitch 0 1 0))
 165        ))
 166
 167
 168   (percussion
 169    . (
 170       (opentriangle       cross         "open"    ,(ly:make-pitch 0 0 0))
 171       (mutetriangle       cross         "stopped" ,(ly:make-pitch 0 0 0))
 172       (triangle   cross         #f        ,(ly:make-pitch 0 0 0))
 173       (shortguiro         default       "staccato",(ly:make-pitch 0 0 0))
 174       (longguiro          default       "tenuto"  ,(ly:make-pitch 0 0 0))
 175       (guiro              default       #f        ,(ly:make-pitch 0 0 0))
 176       (cowbell    triangle      #f        ,(ly:make-pitch 0 0 0))
 177       (claves             default       #f        ,(ly:make-pitch 0 0 0))
 178       (tambourine         default       #f        ,(ly:make-pitch 0 0 0))
 179       (cabasa             cross         #f        ,(ly:make-pitch 0 0 0))
 180       (maracas    default       #f        ,(ly:make-pitch 0 0 0))
 181       (handclap   default       #f        ,(ly:make-pitch 0 0 0))
 182       ))
 183   ))
 184
 185
 186
 187 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 188 ;;
 189
 190 (define (make-articulation-script x)
 191      (let* ((m (make-music-by-name 'ArticulationEvent)))
 192      (ly:set-mus-property! m 'articulation-type x)
 193      m))
 194
 195 ;; adds the articulation script x to m if x is not #f.
 196 (define (add-articulation-script m x)
 197   (if x
 198    (if (and x (equal? (ly:get-mus-property m 'name) 'EventChord))
 199      (ly:set-mus-property! m 'elements
 200        (cons (make-articulation-script x) (ly:get-mus-property m 'elements))
 201      )
 202      (let* ( (es (ly:get-mus-property m 'elements))
 203             (e (ly:get-mus-property m 'element)) )
 204        (map (lambda (y) (add-articulation-script y x)) es)
 205        (if (ly:music? e)
 206          (add-articulation-script e x))
 207      )
 208    )
 209   )
 210   m
 211  )
 212
 213 (define (make-head-type-elem t)
 214    (let* ( (m (make-music-by-name 'OverrideProperty)))
 215      (set-mus-properties!
 216       m
 217       `((symbol . NoteHead)
 218         (grob-property . style)
 219         (grob-value . ,t)
 220         (pop-first  . #t)))
 221       m
 222
 223    )
 224  )
 225
 226 (define (make-head-type t)
 227   (context-spec-music (make-head-type-elem t) "Thread"))
 228
 229 (define (make-thread-context thread-name element)
 230   (context-spec-music element "Thread" thread-name))
 231
 232 ;; makes a sequential-music of thread-context, head-change and note
 233 (define (make-drum-head kit req-ch )
 234   (let ((es (ly:get-mus-property req-ch 'elements)))
 235    (if (equal? es '())
 236     req-ch
 237     (let* ((fe (car es))
 238            (oldp (ly:get-mus-property fe 'pitch))
 239           )
 240       (if (not (ly:pitch? oldp))
 241        req-ch
 242        (let* ((pap ((pitch->paper kit) oldp ))
 243               (style (car pap))
 244               (script (cadr pap))
 245               (pitch (caddr pap))
 246               (ht (make-head-type style))
 247               (seq (make-sequential-music (list ht req-ch)))
 248              )
 249          (add-articulation-script req-ch script)
 250          (ly:set-mus-property! fe 'pitch pitch)
 251          (set! req-ch (make-thread-context style seq))
 252          req-ch
 253        )
 254       )
 255     )
 256    )
 257   )
 258  )
 259
 260 ;; whoa, hadn't head of "assoc" when I made this :)
 261 (define ((pitch->paper kit) p)
 262    (let p2p ((pitches drum-pitch-names))
 263      (cond ((eq? pitches '())
 264               (begin
 265                (display p) ;; UGH. FIXME. pitch->string ???
 266                (ly:warn " unknown drumpitch.")
 267                (cdar (get-drum-kit kit))
 268            ))
 269          ((eq? p (caddr (car pitches))) ((name->paper kit) (caar pitches)) )
 270          (else                          (p2p (cdr pitches) ) )
 271      )
 272    )
 273  )
 274
 275 (define ((name->paper kit) n)
 276    (let n2p ((pitches (get-drum-kit kit)))
 277      (cond ((eq? pitches '())
 278               (begin
 279                (ly:warn (string-append "Kit `" (symbol->string kit) "' doesn't contain drum `" n
 280                                        "'\nSee ly/drumpitch-init.ly for supported drums."))
 281                (cdar (get-drum-kit kit))
 282              ))
 283            ((eq? n (caar pitches))  (cdar pitches) )
 284            (else                    (n2p (cdr pitches) ) )
 285      )
 286    )
 287  )
 288
 289 ;;
 290 ;; converts a midi-pitched (ly/drumpitch.ly) file to paper output.
 291 ;;
 292 (define-public ((drums->paper kit) music)
 293   (begin
 294    (if (equal? (ly:get-mus-property music 'name) 'EventChord)
 295     (set! music (make-drum-head kit music))
 296     (let* ((es (ly:get-mus-property music 'elements))
 297            (e (ly:get-mus-property music 'element))
 298            (p (ly:get-mus-property music 'pitch))
 299            (body (ly:get-mus-property music 'body))
 300            (alts (ly:get-mus-property music 'alternatives)))
 301
 302       (if (pair? es)
 303         (ly:set-mus-property! music 'elements (map (drums->paper kit) es) )
 304       )
 305
 306       (if (ly:music? alts)
 307         (ly:set-mus-property!
 308          music 'alternatives
 309          ((drums->paper kit) alts)))
 310
 311       (if (ly:music? body)
 312         (ly:set-mus-property!
 313          music 'body
 314          ((drums->paper kit) body)))
 315
 316       (if (ly:music? e)
 317         (begin
 318           (ly:set-mus-property!
 319            music 'element
 320            ((drums->paper kit) e))
 321         ))))
 322    music
 323   ))