Building musical chords

2018/06/06

(setq chord-intervals
      '((1 . (0))
	(5 . (0 7))
	(major . (0 4 7))
	(m . (0 3 7))
	(7 . (0 4 7 10))
	(dim . (0 3 6))))

(setq scales
      '((major . (0 2 2 1 2 2 2))
	(minor . (0 2 1 2 2 1 2))))

(setq scale-chords
      '((major . (major m m major major m dim))
	(minor . (m dim major m m major major))))

(setq chromatic-scale '(c c\# d d\# e f f\# g g\# a a\# b))
(defun rotate-scale (scale rotation)
  (if (= rotation 0)
      scale
    (rotate-scale
     (append (cdr scale) (list (car scale)))
     (- rotation 1))))

(rotate-scale chromatic-scale 0) ;; => (C |C#| D |D#| E F |F#| G |G#| A |A#| B)
(rotate-scale chromatic-scale 5) ;; => (F |F#| G |G#| A |A#| B C |C#| D |D#| E)

(defun get-note-at-interval (scale interval)
  (nth (mod interval (length scale)) scale))

(get-note-at-interval chromatic-scale 5) ;;=> F

(defun get-notes (scale interval-list)
  (mapcar
   (lambda (n)
     (get-note-at-interval scale n))
   interval-list))

(get-notes chromatic-scale '(0 4 7)) ;;=> (C E G)

(defun make-scale (key)
  (rotate-scale chromatic-scale (position key chromatic-scale)))

(make-scale 'c) ;;=> (C |C#| D |D#| E F |F#| G |G#| A |A#| B)
(make-scale 'f\#) ;;=> (|F#| G |G#| A |A#| B C |C#| D |D#| E F)
(make-scale 'a) ;;=> (A |A#| B C |C#| D |D#| E F |F#| G |G#|)

(defun make-scale-chords (scale scale-intervals scale-chords)
  (let ((chords))
    (dotimes (index (length scale-intervals))
      (let ((interval (nth index scale-intervals)))
	(setq scale (rotate-scale scale interval))
	(setq chords (append chords
			     (list (get-notes
				     scale
				     (cdr (assoc (nth index scale-chords) chord-intervals))))))))
    chords))

(defun chords (key scale-mode)
  (make-scale-chords
   (make-scale key)
   (cdr (assoc scale-mode scales))
   (cdr (assoc scale-mode scale-chords))))

(chords 'c 'major)

;;=> ((C E G) (D F A) (E G B) (F A C) (G B D) (A C E) (B D F))

(chords 'c 'minor)
;;=> ((C |D#| G) (D F |G#|) (|D#| G |A#|) (F |G#| C) (G |A#| D) (|G#| C |D#|) (|A#| D F))

Older Posts