scm/drums.scm

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