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 (define (seq-music-list elts)
   5    (let* ( (ml (ly-make-music "Sequential_music")) )
   6    (ly-set-mus-property ml 'elements elts)
   7    ml
   8 ))
   9
  10 (define (make-art-script x)
  11      (let* (  (m (ly-make-music "Articulation_req"))
  12            )
  13      (ly-set-mus-property m 'articulation-type x)
  14      m
  15      )
  16  )
  17
  18 ;; adds the articulation script x to m if x is not #f.
  19 (define (add-art-script m x)
  20   (if x
  21    (if (and x (equal? (ly-music-name m) "Request_chord"))
  22      (ly-set-mus-property m 'elements
  23        (cons (make-art-script x) (ly-get-mus-property m 'elements))
  24      )
  25      (let* ( (es (ly-get-mus-property m 'elements))
  26             (e (ly-get-mus-property m 'element)) )
  27        (map (lambda (y) (add-art-script y x)) es)
  28        (if (music? e)
  29          (add-art-script e x))
  30      )
  31    )
  32   )
  33   m
  34  )
  35
  36 (define (make-head-type-elem t)
  37    (let* ( (m (ly-make-music "Music"))
  38          )
  39      (ly-set-mus-property m 'iterator-ctor Push_property_iterator::constructor)
  40      (ly-set-mus-property m 'symbols 'NoteHead)
  41      (ly-set-mus-property m 'grob-property 'style)
  42      (ly-set-mus-property m 'grob-value t)
  43      m
  44    )
  45  )
  46
  47 (define (make-head-type t)
  48    (let* ( (m (ly-make-music "Context_specced_music"))
  49            (e (make-head-type-elem t))
  50          )
  51      (ly-set-mus-property m 'element e)
  52      (ly-set-mus-property m 'context-type "Thread")
  53      m
  54    )
  55  )
  56
  57 (define (make-thread-context thread-name element)
  58    (let* ( (m (ly-make-music "Context_specced_music")))
  59      (ly-set-mus-property m 'element element)
  60      (ly-set-mus-property m 'context-type "Thread")
  61      (ly-set-mus-property m 'context-id (symbol->string thread-name))
  62      m
  63    )
  64  )
  65
  66 ;; makes a sequential-music of thread-context, head-change and note
  67 (define (make-drum-head kit req-ch )
  68   (let ((es (ly-get-mus-property req-ch 'elements)))
  69    (if (equal? es '())
  70     req-ch
  71     (let* ((fe (car es))
  72            (oldp (ly-get-mus-property fe 'pitch))
  73           )
  74       (if (not (pitch? oldp))
  75        req-ch
  76        (let* ((pap ((pitch->paper kit) oldp ))
  77               (style (car pap))
  78               (script (cadr pap))
  79               (pitch (caddr pap))
  80               (ht (make-head-type style))
  81               (seq (seq-music-list (list ht req-ch)))
  82              )
  83          (add-art-script req-ch script)
  84          (ly-set-mus-property fe 'pitch pitch)
  85          (set! req-ch (make-thread-context style seq))
  86          req-ch
  87        )
  88       )
  89     )
  90    )
  91   )
  92  )
  93
  94 ;; whoa, hadn't head of "assoc" when I made this :)
  95 (define ((pitch->paper kit) p)
  96    (let p2p ((pitches drum-pitch-names))
  97      (cond ((eq? pitches '())
  98               (begin
  99                (display p) ;; UGH. FIXME. pitch->string ???
 100                (ly-warn " unknown drumpitch.")
 101                (cdar (eval kit))
 102            ))
 103          ((eq? p (caddr (car pitches))) ((name->paper kit) (caar pitches)) )
 104          (else                          (p2p (cdr pitches) ) )
 105      )
 106    )
 107  )
 108 (define ((name->paper kit) n)
 109    (let n2p ((pitches (eval kit)))
 110      (cond ((eq? pitches '())
 111               (begin
 112                (ly-warn (string-append "Kit `" (symbol->string kit) "' doesn't contain drum `" n
 113                                        "'\nSee lily/drumpitch.ly for supported drums."))
 114                (cdar (eval kit))
 115              ))
 116            ((eq? n (caar pitches))  (cdar pitches) )
 117            (else                    (n2p (cdr pitches) ) )
 118      )
 119    )
 120  )
 121
 122
 123 ;; converts a midi-pitched (ly/drumpitch.ly) file to paper output.
 124 (define ((drums->paper kit) music)
 125   (begin
 126    (if (equal? (ly-music-name music) "Request_chord")
 127     (set! music (make-drum-head kit music))
 128     (let* ((es (ly-get-mus-property music 'elements))
 129            (e (ly-get-mus-property music 'element))
 130            (p (ly-get-mus-property music 'pitch))
 131            (body (ly-get-mus-property music 'body))
 132            (alts (ly-get-mus-property music 'alternatives)))
 133
 134       (if (pair? es)
 135         (ly-set-mus-property music 'elements (map (drums->paper kit) es) )
 136       )
 137
 138       (if (music? alts)
 139         (ly-set-mus-property
 140          music 'alternatives
 141          ((drums->paper kit) alts)))
 142
 143       (if (music? body)
 144         (ly-set-mus-property
 145          music 'body
 146          ((drums->paper kit) body)))
 147
 148       (if (music? e)
 149         (begin
 150           (ly-set-mus-property
 151            music 'element
 152            ((drums->paper kit) e))
 153         )
 154       )
 155     )
 156    )
 157    music
 158   )
 159  )