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 (define drum-pitch-names `(
   8         (acousticbassdrum bda   ,(make-pitch -3 6 0 ))
   9         (bassdrum         bd    ,(make-pitch -2 0 0 ))
  10         (hisidestick      ssh   ,(make-pitch -3 6 2))
  11         (sidestick        ss    ,(make-pitch -2 0 1))
  12         (losidestick      ssl   ,(make-pitch -2 1 -1))
  13         (acousticsnare    sna   ,(make-pitch -2 1 0))
  14         (snare            sn    ,(make-pitch -2 2 -2))
  15         (handclap         hc    ,(make-pitch -2 1 1))
  16         (electricsnare    sne   ,(make-pitch -2 2 0))
  17         (lowfloortom      tomfl ,(make-pitch -2 3 0))
  18         (closedhihat      hhc   ,(make-pitch -2 3 1))
  19         (hihat            hh    ,(make-pitch -2 4 -1))
  20         (highfloortom     tomfh ,(make-pitch -2 4 0))
  21         (pedalhihat       hhp   ,(make-pitch -2 4 1))
  22         (lowtom           toml  ,(make-pitch -2 5 0))
  23         (openhihat        hho   ,(make-pitch -2 5 1))
  24         (halfopenhihat    hhho  ,(make-pitch -2 5 1))
  25         (lowmidtom        tomml ,(make-pitch -2 6 0))
  26         (himidtom         tommh ,(make-pitch -1 0 0))
  27         (crashcymbala     cymca ,(make-pitch -1 0 1))
  28         (crashcymbal      cymc  ,(make-pitch -1 1 -1))
  29         (hightom          tomh  ,(make-pitch -1 1 0))
  30         (ridecymbala      cymra ,(make-pitch -1 1 1))
  31         (ridecymbal       cymr  ,(make-pitch -1 2 -1))
  32         (chinesecymbal    cymch ,(make-pitch -1 2 0))
  33         (ridebell         rb    ,(make-pitch -1 3 0))
  34         (tambourine       tamb  ,(make-pitch -1 3 1))
  35         (splashcymbal     cyms  ,(make-pitch -1 4 0))
  36         (cowbell          cb    ,(make-pitch -1 4 1))
  37         (crashcymbalb     cymcb ,(make-pitch -1 5 0))
  38         (vibraslap        vibs  ,(make-pitch -1 5 1))
  39         (ridecymbalb      cymrb ,(make-pitch -1 6 0))
  40         (hibongo          boh   ,(make-pitch 0 0 0))
  41         (lobongo          bol   ,(make-pitch 0 0 1))
  42         (mutehiconga      cghm  ,(make-pitch 0 1 0))
  43         (openhiconga      cgho  ,(make-pitch 0 1 1))
  44         (hiconga          cgh   ,(make-pitch 0 2 -1))
  45         (openloconga      cglo  ,(make-pitch 0 1 2))
  46         (loconga          cgl   ,(make-pitch 0 2 0))
  47         (hitimbale        timh  ,(make-pitch 0 3 0))
  48         (lotimbale        timl  ,(make-pitch 0 3 1))
  49         (hiagogo          agh   ,(make-pitch 0 4 0))
  50         (loagogo          agl   ,(make-pitch 0 4 1))
  51         (cabasa           cab   ,(make-pitch 0 5 0))
  52         (maracas          mar   ,(make-pitch 0 5 1))
  53         (shortwhistle     whs   ,(make-pitch 0 6 0))
  54         (longwhistle      whl   ,(make-pitch 1 0 0))
  55         (shortguiro       guis  ,(make-pitch 1 0 1))
  56         (longguiro        guil  ,(make-pitch 1 1 0))
  57         (guiro            gui   ,(make-pitch 1 0 2))
  58         (claves           cl    ,(make-pitch 1 1 1))
  59         (hiwoodblock      wbh   ,(make-pitch 1 2 0))
  60         (lowoodblock      wbl   ,(make-pitch 1 3 0))
  61         (mutecuica        cuim  ,(make-pitch 1 3 1))
  62         (opencuica        cuio  ,(make-pitch 1 4 0))
  63         (mutetriangle     trim  ,(make-pitch 1 4 1))
  64         (triangle         tri   ,(make-pitch 1 4 2))
  65         (opentriangle     trio  ,(make-pitch 1 5 0))
  66         ;; "transposing" pitches:
  67         (oneup            ua    ,(make-pitch 0 1 0))
  68         (twoup            ub    ,(make-pitch 0 2 0))
  69         (threeup          uc    ,(make-pitch 0 3 0))
  70         (fourup           ud    ,(make-pitch 0 4 0))
  71         (fiveup           ue    ,(make-pitch 0 5 0))
  72         (onedown          da    ,(make-pitch -1 6 0))
  73         (twodown          db    ,(make-pitch -1 5 0))
  74         (threedown        dc    ,(make-pitch -1 4 0))
  75         (fourdown         dd    ,(make-pitch -1 3 0))
  76         (fivedown         de    ,(make-pitch -1 2 0))
  77 ))
  78
  79 (define drums `(
  80         (acousticbassdrum default       #f        ,(make-pitch -1 4 0))
  81         (bassdrum         default       #f        ,(make-pitch -1 4 0))
  82         (sidestick        cross         #f        ,(make-pitch 0 1 0))
  83         (acousticsnare    default       #f        ,(make-pitch 0 1 0))
  84         (snare            default       #f        ,(make-pitch 0 1 0))
  85         (handclap         triangle      #f        ,(make-pitch 0 1 0))
  86         (electricsnare    default       #f        ,(make-pitch 0 1 0))
  87         (lowfloortom      default       #f        ,(make-pitch -1 3 0))
  88         (closedhihat      cross         "stopped" ,(make-pitch 0 3 0))
  89         (hihat            cross         #f        ,(make-pitch 0 3 0))
  90         (highfloortom     default       #f        ,(make-pitch -1 5 0))
  91         (pedalhihat       cross         #f        ,(make-pitch -1 2 0))
  92         (lowtom           default       #f        ,(make-pitch 0 0 0))
  93         (openhihat        cross         "open"    ,(make-pitch 0 3 0))
  94         (halfopenhihat    xcircle       #f        ,(make-pitch 0 3 0))
  95         (lowmidtom        default       #f        ,(make-pitch 0 1 0))
  96         (himidtom         default       #f        ,(make-pitch 0 2 0))
  97         (crashcymbala     xcircle       #f        ,(make-pitch 0 5 0))
  98         (crashcymbal      xcircle       #f        ,(make-pitch 0 5 0))
  99         (hightom          default       #f        ,(make-pitch 0 4 0))
 100         (ridecymbala      cross         #f        ,(make-pitch 0 5 0))
 101         (ridecymbal       cross         #f        ,(make-pitch 0 5 0))
 102         (chinesecymbal    mensural      #f        ,(make-pitch 0 5 0))
 103         (ridebell         default       #f        ,(make-pitch 0 5 0))
 104         (splashcymbal     diamond       #f        ,(make-pitch 0 5 0))
 105         (cowbell          triangle      #f        ,(make-pitch 0 5 0))
 106         (crashcymbalb     cross         #f        ,(make-pitch 0 5 0))
 107         (vibraslap        diamond       #f        ,(make-pitch 0 4 0))
 108         (ridecymbalb      cross         #f        ,(make-pitch 0 5 0))
 109  ))
 110
 111 (define timbales `(
 112         (losidestick      cross         #f        ,(make-pitch -1 6 0))
 113         (lotimbale        default       #f        ,(make-pitch -1 6 0))
 114         (cowbell          triangle      #f        ,(make-pitch 0 2 0))
 115         (hisidestick      cross         #f        ,(make-pitch 0 1 0))
 116         (hitimbale        default       #f        ,(make-pitch 0 1 0))
 117  ))
 118
 119 (define congas `(
 120         (losidestick      cross         #f        ,(make-pitch -1 6 0))
 121         (loconga          default       #f        ,(make-pitch -1 6 0))
 122         (openloconga      default       ,"open"   ,(make-pitch -1 6 0))
 123         (hisidestick      cross         #f        ,(make-pitch 0 1 0))
 124         (hiconga          default       #f        ,(make-pitch 0 1 0))
 125         (openhiconga      default       "open"    ,(make-pitch 0 1 0))
 126         (mutehiconga      default       "stopped" ,(make-pitch 0 1 0))
 127
 128  ))
 129
 130 (define bongos `(
 131         (lobongo          default       #f        ,(make-pitch -1 6 0))
 132         (hibongo          default       #f        ,(make-pitch 0 1 0))
 133  ))
 134
 135
 136 (define percussion `(
 137         (opentriangle     cross         "open"    ,(make-pitch 0 0 0))
 138         (mutetriangle     cross         "stopped" ,(make-pitch 0 0 0))
 139         (triangle         cross         #f        ,(make-pitch 0 0 0))
 140         (shortguiro       default       "staccato",(make-pitch 0 0 0))
 141         (longguiro        default       "tenuto"  ,(make-pitch 0 0 0))
 142         (guiro            default       #f        ,(make-pitch 0 0 0))
 143         (cowbell          triangle      #f        ,(make-pitch 0 0 0))
 144         (claves           default       #f        ,(make-pitch 0 0 0))
 145         (tambourine       default       #f        ,(make-pitch 0 0 0))
 146         (cabasa           cross         #f        ,(make-pitch 0 0 0))
 147         (maracas          default       #f        ,(make-pitch 0 0 0))
 148         (handclap         default       #f        ,(make-pitch 0 0 0))
 149  ))
 150
 151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 152 ;;;;;;;;;;;;;;;;
 153
 154 (define (make-articulation-script x)
 155      (let* (  (m (ly-make-music "Articulation_req"))
 156            )
 157      (ly-set-mus-property m 'articulation-type x)
 158      m
 159      )
 160  )
 161
 162 ;; adds the articulation script x to m if x is not #f.
 163 (define (add-articulation-script m x)
 164   (if x
 165    (if (and x (equal? (ly-music-name m) "Request_chord"))
 166      (ly-set-mus-property m 'elements
 167        (cons (make-articulation-script x) (ly-get-mus-property m 'elements))
 168      )
 169      (let* ( (es (ly-get-mus-property m 'elements))
 170             (e (ly-get-mus-property m 'element)) )
 171        (map (lambda (y) (add-articulation-script y x)) es)
 172        (if (music? e)
 173          (add-articulation-script e x))
 174      )
 175    )
 176   )
 177   m
 178  )
 179
 180 (define (make-head-type-elem t)
 181    (let* ( (m (ly-make-music "Music"))
 182          )
 183      (ly-set-mus-property m 'iterator-ctor Push_property_iterator::constructor)
 184      (ly-set-mus-property m 'symbol 'NoteHead)
 185      (ly-set-mus-property m 'grob-property 'style)
 186      (ly-set-mus-property m 'grob-value t)
 187      m
 188    )
 189  )
 190
 191 (define (make-head-type t)
 192    (let* ( (m (ly-make-music "Context_specced_music"))
 193            (e (make-head-type-elem t))
 194          )
 195      (ly-set-mus-property m 'element e)
 196      (ly-set-mus-property m 'context-type "Thread")
 197      m
 198    )
 199  )
 200
 201 (define (make-thread-context thread-name element)
 202    (let* ( (m (ly-make-music "Context_specced_music")))
 203      (ly-set-mus-property m 'element element)
 204      (ly-set-mus-property m 'context-type "Thread")
 205      (ly-set-mus-property m 'context-id (symbol->string thread-name))
 206      m
 207    )
 208  )
 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 (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 lily/drumpitch.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 ((drums->paper kit) music)
 269   (begin
 270    (if (equal? (ly-music-name music) "Request_chord")
 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 (music? alts)
 283         (ly-set-mus-property
 284          music 'alternatives
 285          ((drums->paper kit) alts)))
 286
 287       (if (music? body)
 288         (ly-set-mus-property
 289          music 'body
 290          ((drums->paper kit) body)))
 291
 292       (if (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  )