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