main.lisp

(defvar *pitches* '(C C# D D# E F F# G G# A A# B))

(defvar *intervals* '(perfect-unison minor-second major-second minor-third major-third perfect-fourth _ perfect-fifth minor-sixth major-sixth minor-seventh major-seventh perfect-octave))

(defparameter *scales* '(major natural-minor major-pentatonic natural-minor-pentatonic blues harmonic-minor melodic-minor))

(defparameter *modes* '(ionian dorian phrygian lydian mixolydian aeolian locrian))

(defparameter *chords* '(major minor augmented diminished suspended-second suspended-fourth minor-suspended-fourth major-sixth minor-sixth major-sixth-add-ninth minor-sixth-add-ninth dominant-seventh major-seventh minor-seventh dominant-seventh-flat-fifth dominant-seventh-sharp-fifth dominant-seventh-suspended-fourth))

(defun split-by-space (string)
  (loop for i = 0 then (1+ j)
	 as j = (position #\Space string :start i)
	 collect (subseq string i j)
	 while j))

(defun string->symbol (string)
  (let ((upcase-string (mapcar #'string-upcase (split-by-space string))))
    (mapcar #'intern upcase-string)))

(defun pretty-print-note (note)
  (if (> (length (symbol-name note)) 1)
      (format t "~A~A" (elt (symbol-name note) 0) (if (string-equal (elt (symbol-name note) 1) "#") "♯" "♭"))
      (format t "~A" note)))

(defun pretty-print-chord (chord)
  (dotimes (i (length chord))
    (pretty-print-note (nth i chord))
    (when (< i (1- (length chord)))
      (format t " ")))
  (format t "~%"))

(defmacro wrap (number length) `(mod ,number ,length))

(defun pitch-wrap (n) (wrap n (length *pitches*)))

(defmacro tone-step-amount (function note duration)
  `(let ((pos (position ,note *pitches*)))
     (nth (pitch-wrap (funcall ,function pos ,duration)) *pitches*)))

(defun tone-step-increase (note duration) (tone-step-amount #'+ note duration))
(defun tone-step-decrease (note duration) (tone-step-amount #'- note duration))

(defun intervals (interval)
  (case interval
    (augmented-second 'major-third)
    (augmented-fourth '_)
    (diminished-fifth '_)
    (augmented-fifth 'minor-sixth)
    (augmented-sixth 'minor-seventh)
    (diminished-seventh 'major-sixth)
    (minor-ninth 'minor-second)
    (major-ninth 'major-second)
    (minor-eleventh 'minor-third)
    (major-eleventh 'major-third)
    (otherwise interval)))

(defun chord-intervals (name)
  (case name
    ((or maj major) '(major-third perfect-fifth))
    ((or min minor) '(minor-third perfect-fifth))
    ((or aug augmented) '(major-third augmented-fifth))
    ((or dim diminished) '(minor-third diminished-fifth))
    ((or sus2 suspended-second) '(major-second perfect-fifth))
    ((or sus4 suspended-fourth) '(perfect-fourth perfect-fifth))
    ((or msus4 minor-suspended-fourth) '(minor-third perfect-fourth perfect-fifth))
    ((or maj6 major-sixth) '(major-third perfect-fifth major-sixth))
    ((or min6 minor-sixth) '(minor-third perfect-fifth major-sixth))
    ((or maj6add9 major-sixth-add-ninth) '(major-third perfect-fifth major-sixth major-ninth))
    ((or min6add9 minor-sixth-add-ninth) '(minor-third perfect-fifth major-sixth major-ninth))
    ((or dom7 dominant-seventh) '(major-third perfect-fifth minor-seventh))
    ((or maj7 major-seventh) '(major-third perfect-fifth major-seventh))
    ((or min7 minor-seventh) '(minor-third perfect-fifth minor-seventh))
    ((or dom7flat5 dominant-seventh-flat-fifth) '(major-third diminished-fifth minor-seventh))
    ((or dom7sharp5 dominant-seventh-sharp-fifth) '(major-third augmented-fifth minor-seventh))
    ((or dom7sus4 dominant-seventh-suspended-fourth) '(major-third perfect-fourth perfect-fifth minor-seventh))))

(defun scale-intervals (name)
  (case name
    (major '(major-second major-third perfect-fourth perfect-fifth major-sixth major-seventh))
    (natural-minor '(major-second minor-third perfect-fourth perfect-fifth minor-sixth minor-seventh))
    (major-pentatonic '(major-second major-third perfect-fifrth major-sixth))
    (natural-minor-pentatonic '(minor-third perfect-fourth perfect-fifth minor-seventh))
    (major-blues '(major-third perfect-fourth diminished-fifth perfect-fifth major-seventh))
    (minor-blues '(minor-third perfect-fourth diminished-fifth perfect-fifth minor-seventh))
    (harmonic-minor '(major-second minor-third perfect-fourth perfect-fifth minor-sixth major-seventh))
    (melodic-minor '(major-second minor-third perfect-fourth perfect-fifth major-sixth major-seventh))
    (ionian '(major-second major-third perfect-fourth perfect-fifth major-sixth major-seventh))
    (dorian '(major-second minor-third perfect-fourth perfect-fifth major-sixth minor-seventh))
    (phrygian '(minor-second minor-third perfect-fourth perfect-fifth minor-sixth minor-seventh))
    (lydian '(major-second major-third augmented-fourth perfect-fifth major-sixth major-seventh))
    (mixolydian '(major-second major-third perfect-fourth perfect-fifth major-sixth minor-seventh))
    (aeolian '(major-second minor-third perfect-fourth perfect-fifth minor-sixth minor-seventh))
    (locrian '(minor-second minor-third perfect-fourth diminished-fifth minor-sixth minor-seventh))))

(defun sharpen (note) (tone-step-amount #'+ note 1))
(defun flatten (note) (tone-step-amount #'- note 1))

(defun interval-step (tone interval) (tone-step-increase tone (position (intervals interval) *intervals*)))

(defun create-chord (root intervals)
  (let ((chord (make-list 0)))
    (flet ((add-to-chord (tone) (push tone chord)))
      (add-to-chord root)
      (loop for interval in intervals
		 do (add-to-chord (interval-step root interval)))
      (reverse chord))))

(defun create-progression (root name length)
  (let ((scale (create-chord root (scale-intervals name)))
		(progression (make-list 0)))
    (flet ((add-to-progression (note) (push note progression)))
      (dotimes (i length)
		(add-to-progression (elt scale (random (length scale)))))
      progression)))

(defun create-chord-progression (root name)
  (let ((scale (create-chord root (scale-intervals name)))
		(progression (make-list 0)))
    (flet ((add-to-progression (note) (push note progression)))
      (dotimes (n (length scale))
		(add-to-progression `(,(nth (wrap n (length scale)) scale) ,(nth (wrap (+ 2 n) (length scale)) scale) ,(nth (wrap (+ 4 n) (length scale)) scale))))
      (reverse progression))))

(defmacro chord (root name) `(create-chord ',root (chord-intervals ',name)))
(defmacro scale (root name) `(create-chord ',root (scale-intervals ',name)))
(defmacro progression (root name &optional (length 7)) `(create-progression ',root ',name ,length))
(defmacro chord-progression (root name) `(create-chord-progression ',root ',name))

;; (defmacro tone-step (name duration) `(defun ,(intern (format nil "~A-STEP" name)) (note) (tone-step-increase note ,duration)))

;; (tone-step no 0)
;; (tone-step half 1)
;; (tone-step whole 2)
;; (tone-step double 3)

;; (defun steps (step)
;;   (case step
;;     (H 'HALF-STEP)
;;     (W 'WHOLE-STEP)
;;     (D 'DOUBLE-STEP)
;;     (otherwise 'NO-STEP)))

;; (defun create-scale (root steps)
;;   (let ((scale (make-list 0)))
;;     (flet ((add-to-scale (tone) (push tone scale)))
;;       (add-to-scale root)
;;       (loop for step in (mapcar #'steps steps)
;;     do (add-to-scale (funcall step (first scale))))
;;       ;; (format t "~{~A~^ ~}~%" (reverse scale))
;;       (reverse scale))))

;; (defun scale-steps (name)
;;   (case name
;;     (major            '(W W H W W W H))
;;     (natural-minor    '(W H W W H W W))
;;     (harmonic-minor   '(W H W W D H))
;;     (pentatonic-major '(W W D W D))
;;     (pentatonic-minor '(D W W D W))
;;     (melodic-minor-ascending '(W H W W W W H))
;;     (melodic-minor-descending '(W W H W W H W))
;;     (ionian-mode     '(W W H W W W H))
;;     (dorian-mode     '(W H W W W H W))
;;     (phrygian-mode   '(H W W W H W W))
;;     (lydian-mode     '(W W W H W W H))
;;     (mixolydian-mode '(W W H W W H W))
;;     (aeolian-mode    '(W H W W H W W))
;;     (locrian-mode    '(H W W H W W W))))

;; (defmacro scale (root name) `(create-scale ',root (scale-steps ',name)))