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