scm/chord-entry.scm

   1
   2
   3 (define (make-chord pitches bass duration)
   4   "Make EventChord with notes corresponding to PITCHES, BASS and DURATION. "
   5   (define (make-note-ev pitch)
   6     (let*
   7         (
   8          (ev   (make-music-by-name 'NoteEvent))
   9          )
  10
  11       (ly:set-mus-property! ev 'duration duration)
  12       (ly:set-mus-property! ev 'pitch pitch)
  13       ev
  14       ))
  15
  16   (let*
  17       (
  18        (nots (map make-note-ev pitches))
  19        (bass-note (if bass (make-note-ev bass) #f))
  20        )
  21
  22     (if bass-note
  23         (begin
  24           (ly:set-mus-property! bass-note 'bass #t)
  25           (set! nots (cons bass-note nots))))
  26
  27     (make-event-chord nots)
  28   ))
  29
  30
  31 (define (aug-modifier root pitches)
  32   (set! pitches  (replace-step (ly:pitch-transpose (ly:make-pitch 0 4 1) root) pitches))
  33   (replace-step (ly:pitch-transpose (ly:make-pitch 0 2 0) root) pitches)
  34   )
  35
  36
  37 (define (minor-modifier root pitches)
  38   (replace-step (ly:pitch-transpose (ly:make-pitch 0 2 -1) root) pitches)
  39   )
  40
  41 (define (maj7-modifier root pitches)
  42   (set! pitches (remove-step 7 pitches))
  43   (cons  (ly:pitch-transpose (ly:make-pitch 0 6 0) root) pitches)
  44   )
  45
  46 (define (dim-modifier root pitches)
  47   (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 2 -1) root) pitches))
  48   (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 4 -1) root) pitches))
  49   (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 6 -2) root) pitches))
  50   pitches
  51   )
  52
  53
  54 (define (sus2-modifier root pitches)
  55   (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 2 0) root)) pitches))
  56   (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 3 0) root)) pitches))
  57   (cons (ly:pitch-transpose (ly:make-pitch 0 1 0) root) pitches)
  58   )
  59
  60 (define (sus4-modifier root pitches)
  61   (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 2 0) root)) pitches))
  62   (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 3 0) root)) pitches))
  63   (cons (ly:pitch-transpose (ly:make-pitch 0 3 0) root) pitches)
  64   )
  65
  66 (define-public default-chord-modifier-list
  67   `((m . ,minor-modifier)
  68     (min . ,minor-modifier)
  69     (aug . , aug-modifier)
  70     (dim . , dim-modifier)
  71     (maj . , maj7-modifier)
  72     (sus . , sus4-modifier)
  73     ))
  74
  75 (define (gobble-pitches lst)
  76   (if (null? lst)
  77       '()
  78       (if (ly:pitch? (car lst))
  79           (gobble-pitches (cdr lst))
  80           lst
  81           )))
  82
  83
  84 ;; ? should remove 3 if sus2 or sus4 found?
  85 (define (add-pitches root pitches to-add)
  86   (if
  87    (or (null? to-add) (not (ly:pitch? (car to-add))))
  88    pitches
  89    (let*
  90        (
  91         (p (ly:pitch-transpose  (car to-add) root))
  92         (step (pitch-step p))
  93         )
  94      (if (get-step step pitches)
  95          (set! pitches (remove-step step pitches)))
  96      (add-pitches root (cons p pitches) (cdr to-add)))))
  97
  98 (define (rm-pitches root pitches to-add)
  99   (if
 100    (or (null? to-add) (not (ly:pitch? (car to-add))))
 101    pitches
 102    (let*
 103        (
 104         (p (ly:pitch-transpose (car to-add) root))
 105         (step (pitch-step p))
 106         )
 107      (rm-pitches root (remove-step step pitches) (cdr to-add)))))
 108
 109
 110 (define-public (construct-chord root duration modifications)
 111   (let*
 112       (
 113        (flat-mods (flatten-list modifications))
 114        (base-chord (list root
 115                          (ly:pitch-transpose (ly:make-pitch 0 2 0) root)
 116                          (ly:pitch-transpose (ly:make-pitch 0 4 0) root)))
 117        (complete-chord '())
 118        (bass #f)
 119        (inversion #f)
 120        )
 121
 122     (define (process-inversion note-evs inversion)
 123
 124       ;; TODO
 125       ;; Transpose the inversion down, and remember its original octave.
 126       note-evs
 127       )
 128
 129     (define (interpret-chord root chord mods)
 130       "Walk MODS, and apply each mod to CHORD in turn.
 131
 132 Side-effect: set BASS and INVERSION in containing body
 133 "
 134       ;; the recursion makes this into a loop. Perhaps its better to
 135       ;; to do the different types of modifiers in order, so that
 136       ;; addition _always_ precedes removal.
 137       (if (null? mods)
 138           chord
 139           (let* (
 140                  (tag (car mods))
 141                  (tail (cdr mods))
 142                  )
 143             (cond
 144              ((procedure? tag)
 145               (interpret-chord root
 146                                (tag root chord)
 147                                tail))
 148              ((equal? tag 'chord-colon)
 149               (interpret-chord root
 150                                (add-pitches root chord tail)
 151                                (gobble-pitches tail)))
 152              ((equal? tag 'chord-caret)
 153               (interpret-chord root
 154                                (rm-pitches root chord tail)
 155                                (gobble-pitches tail)))
 156
 157              ((equal? tag 'chord-slash)
 158               (set! inversion (car tail))
 159               (interpret-chord root
 160                                chord
 161                                (gobble-pitches tail)))
 162              ((equal? tag 'chord-bass)
 163               (set! bass (car tail))
 164               (interpret-chord root
 165                                chord
 166                                (gobble-pitches tail)))
 167
 168              ;; ugh. Simply add isolated pitches. This will give
 169              ;; unexpected results.
 170              ((ly:pitch? tag)
 171               (interpret-chord root
 172                                (add-pitches root chord tail)
 173                                (gobble-pitches tail)))
 174              (else (scm-error 'chord-entry 'interpret-chord  "Unknown chord instructions ~S." (list mods) #f))
 175              )
 176             )
 177           ))
 178
 179     (write-me "*******\n" flat-mods)
 180     (set! complete-chord (interpret-chord root base-chord flat-mods))
 181     (write-me "pitches: " complete-chord)
 182     (write-me "bass: " bass)
 183     (process-inversion (make-chord complete-chord bass duration) inversion)
 184
 185   ))