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