;;; -*- Mode : Lisp; indent-tabs-mode: nil -*-
;;; Copyright © 2006 Jeremy English <jhe@jeremyenglish.org>
;;; 
;;; Permission to use, copy, modify, distribute, and sell this software and its
;;; documentation for any purpose is hereby granted without fee, provided that
;;; the above copyright notice appear in all copies and that both that
;;; copyright notice and this permission notice appear in supporting
;;; documentation.  No representations are made about the suitability of this
;;; software for any purpose.  It is provided "as is" without express or 
;;; implied warranty.
;;; 
;;; Created: 22-February-2006
;;;
;;; Music theory. I Want to be able to ask the computer certain music
;;; questions. For instance:
;;;
;;; (major-scale A#)
;;; (major-chord A#)
;;; (chord-progression (I III V) A#)
;;;
;;; So the computer will need to know how to construct scales and
;;; chords.  It should be easy to teach the computer a new scale.  For
;;; instance I would like to say :
;;;
;;;   (define-scale major '(W W H W W W H))
;;;
;;; To do this the computer will need to know how to move from one note
;;; to the next by a whole step, half step and a whole half step.
;;;
;;; TODO:
;;;   A GUI of some sort would be nice.
;;;
;;;   This will probably be in a different file but use the information
;;;   here to describe scale and chords on the guitar.

(defpackage "MUSIC-THEORY"
    (:documentation "Answers questions about chords, scale and chord progressions.")
  (:use "COMMON-LISP")
  (:export "MUSIC-MAN"))

(in-package music-theory)
  
(defparameter *notes* '((A) (A# Bb) (B) (C) (C# Db) (D) (D# Eb) (E) (F) (F# Gb) (G) (G# Ab)))

;; find note suggested by - Frode Vatvedt Fjeld
;; My version was eleven lines. I had to check for a cons.
(defun find-note (note &optional (notes *notes*))
  (position-if (lambda (set) (member (if (consp note) (car note) note) set)) notes))
      
(defun get-note (idx)
  "Handels wrap around when asking for a note. Anything over 11 gets
wrapped"
  (nth (mod idx 12) *notes*))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun make-help-system (help-db)
    (list
     ;;Add item
     #'(lambda (name type)
         (setf help-db (cons (cons name type) help-db)))
     ;;Return list for all items of type
     #'(lambda (type)
         (remove nil (mapcar 
                      #'(lambda (x) 
                          (if (eq type (cdr x)) x nil)) 
                      help-db)))
     ;;Dump the database
     #'(lambda () help-db)))

  (defvar *help-database* (make-help-system nil))
  
  (defun add-help-item (name type help-db)
    (if (null (position (cons name type) 
                        (dump-help-items *help-database*) 
                        :test #'(lambda (a b)
                                  (and 
                                   (equal (car a) (car b))
                                   (equal (cdr a) (cdr b))))))
        (funcall (first help-db) name type)))
  
  (defun list-help-items (type help-db)
    (funcall (second help-db) type))

  (defun dump-help-items (help-db)
    (funcall (third help-db))))

(defmacro define-stepper (name amount)
  `(defun ,name (note) 
      (get-note 
       (+ (find-note 
	   (if (consp note) (first note) note))
	  ,amount))))

(defmacro define-scale (name steps)
  (add-help-item name 'scale *help-database*)
  `(defun ,name (note)
     (labels ((build-scale (scale step note)
                           (cond ((null (car step)) (nreverse scale))
                                 (t 
                                  (build-scale (cons (funcall (car step) note) scale) 
                                               (cdr step) 
                                               (funcall (car step) note))))))
       (build-scale (list (list note)) ,steps note))))

(defmacro define-chord (name formula)
  (add-help-item name 'chord *help-database*)
  `(defun ,name (key)
    (labels ((build-chord (f chord)
	       (cond ((null (car f)) (nreverse chord))
		     (t
		      (build-chord (cdr f) (cons (funcall (car f) key) chord))))))
      (build-chord ,formula '()))))
   	       
(defun item-from-cons (list idx)
  "Scroll through a list if you find a cons return the item specified"
  (labels ((fix-list (old-list new-list)
	     (cond
	       ((null old-list) (nreverse new-list))
	       ((consp (car old-list))
		(fix-list (cdr old-list) (cons (funcall idx (car old-list)) new-list)))
	       (t
		(fix-list (cdr old-list) (cons (car old-list) new-list))))))
    (fix-list list '())))
	       
(defun show-sharps (list)
  (item-from-cons list 'first))

(defun show-flats (list)
  (item-from-cons list 'second))

(defun define-scale-helper (adjustment)
  (cond
    ((eq adjustment 'sharp) (lambda (x) (get-note (+ (find-note x) 1))))
    ((eq adjustment 'flat)  (lambda (x) (get-note (- (find-note x) 1))))
    ((eq adjustment 'double-flat)(lambda (x) (get-note (- (find-note x) 2))))
    ((eq adjustment 'none) (lambda (x) x))))


(defmacro define-scale-pos (name pos adjustment scale)
  `(defun ,name (key)
    (let ((note (nth (mod (1- ,pos) 7) (,scale key))))
      (funcall (define-scale-helper ,adjustment) note))))

(defun get-input ()
  "Read from stdin and create a list of items"
  (labels ((parse-input (s n)
	     (multiple-value-bind
		   (word pos)
		 (read-from-string s nil nil :start n)
	       (cond
		 ((null word) '())
		 (t
		  (cons word (parse-input s pos)))))))
    (parse-input (read-line) 0)))

(defun interactive-interpreter (prompt transformer &optional (reader #'read))
  "Read an expression, transform it, and print the result."
  (loop
   (handler-case
       (progn
	 (if (stringp prompt)
	     (print prompt)
	     (funcall prompt))
	 (finish-output)
	 (print (funcall transformer (funcall reader))))
     ;; In case of error, do this:
     (error (condition)
       (format t "~&;; Error ~a ignored, back to the top level."
	       condition)))))

(defun prompt-generator (&optional (num 0) (ctl-string "~&[~d] "))
  "Return a function that prints prompts like [1], [2], etc."
  #'(lambda () (format t ctl-string (incf num))))

(defun quote-all (lst)
  (cond
    ((null lst) '())
    (t
     (cons `',(car lst) (quote-all (cdr lst))))))

(defun music-top-level (input)
  (eval (cons (car input) (quote-all (cdr input)))))

(defun music-man ()
  (in-package music-theory)
  (interactive-interpreter (prompt-generator) #'music-top-level #'get-input))

(define-stepper H  1)
(define-stepper W  2)
(define-stepper Wh 3)
		     		    	     
(define-scale major-scale                 '(W W H W W W H))
(define-scale major-pentationic           '(W W Wh W Wh))
(define-scale natural-minor-scale         '(W H W W H W W))
(define-scale minor-pentatonic            '(Wh W W Wh W))
(define-scale blues-scale                 '(Wh W H H Wh W))
(define-scale mixo-blues-scale            '(W H H H H H W H W))
(define-scale mixolydian-mode             '(W W H W W H W))
(define-scale dorian-mode                 '(W H W W W H W))
(define-scale melodic-minor-scale         '(W H W W W W H))
(define-scale harmonic-minor-scale        '(W H W W H Wh H))
(define-scale phrygian-mode               '(H W W W H W W))
(define-scale locrian-mode                '(H W W H W W W))
(define-scale lydian-mode                 '(W W W H W W H))
(define-scale diminished-half-whole       '(H W H W H W H W))
(define-scale diminished-scale-whole-half '(W H W H W H W H))
(define-scale chromatic-scale             '(H H H H H H H H H H H H))
(define-scale whole-tone                  '(W W W W W W))

(define-scale-pos 1st              1 'none  major-scale)
(define-scale-pos 2nd              2 'none  major-scale)
(define-scale-pos 3rd              3 'none  major-scale)
(define-scale-pos flat-3rd         3 'flat  major-scale)
(define-scale-pos 4th              4 'none  major-scale)
(define-scale-pos 5th              5 'none  major-scale)
(define-scale-pos flat-5th         5 'flat  major-scale)
(define-scale-pos sharp-5th        5 'sharp major-scale)
(define-scale-pos 6th              6 'none  major-scale)
(define-scale-pos 7th              7 'none  major-scale)
(define-scale-pos flat-7th         7 'flat  major-scale)
(define-scale-pos double-flat-7th  7 'double-flat major-scale)
(define-scale-pos 8th              8 'none  major-scale)
(define-scale-pos 9th              9 'none  major-scale)
(define-scale-pos flat-9th         9 'flat  major-scale)
(define-scale-pos sharp-9th        9 'sharp major-scale)
(define-scale-pos 10th            10 'none  major-scale)
(define-scale-pos 11th            11 'none  major-scale)
(define-scale-pos sharp-11th      11 'sharp major-scale)
(define-scale-pos 12th            12 'none  major-scale)
(define-scale-pos 13th            13 'none  major-scale)

(define-chord major-chord             '(1st 3rd 5th))
(define-chord minor-chord             '(1st flat-3rd 5th))
(define-chord power-chord             '(1st 5th))
(define-chord augmented-chord         '(1st 3rd sharp-5th))
(define-chord diminshed-chord         '(1st 4th 5th))
(define-chord suspended-4th-chord     '(1st 4th 5th))
(define-chord suspended-2nd-chord     '(1st 2nd 5th))
(define-chord major-add-9th-chord     '(1st 3rd 5th 9th))
(define-chord minor-add-9th-chord     '(1st flat-3rd 5th 9th))
(define-chord major-add-6th-chord     '(1st 3rd 5th 6th))
(define-chord minor-add-6th-chord     '(1st flat-3rd 5th 6th))
(define-chord major-add-6th-9th-chord '(1st 3rd 5th 6th 9th))
(define-chord minor-add-6th-9th-chord '(1st flat-3rd 5th 6th 9th))
(define-chord major-7th-chord         '(1st 3rd 5th 7th))
(define-chord minor-7th-chord         '(1st flat-3rd 5th flat-7th))
(define-chord dominant-7th-chord      '(1st 3rd 5th flat-7th))
(define-chord minor-7th-flat-5-chord  '(1st flat-3rd flat-5th flat-7th))
(define-chord diminished-7th-chord    '(1st flat-3rd flat-5th double-flat-7th))
(define-chord 7th-suspended-4th-chord '(1st 4th 5th flat-7th))
(define-chord minor-major-7th-chord   '(1st flat-3rd 5th 7th))
(define-chord major-9th-chord         '(1st 3rd 5th 7th 9th))
(define-chord minor-9th-chord         '(1st flat-3rd 5th flat-7th 9th))
(define-chord dominate-9th-chord      '(1st 3rd 5th flat-7th 9th))
(define-chord 9th-suspended-4th       '(1st 4th 5th flat-7th 9th))
(define-chord minor-11th-chord        '(1st flat-3rd 5th flat-7th 9th 11th))
(define-chord 11th-chord              '(1st 3rd 5th flat-7th 9th 11th))
(define-chord major-13th-chord        '(1st 3rd 5th 7th 9th 13th))
(define-chord minor-13th-chord        '(1st flat-3rd 5th flat-7th 9th 11th 13th))
(define-chord 13th-chord              '(1st 3rd 5th flat-7th 9th 13th))     

(defun unknown (&rest r)
  (list "Unknown"))

(defparameter *chord-progressions*
  '((I . 1st) (II . 2nd) (III . 3rd) (IV . 4th) (V . 5th) 
        (VI . 6th) (VII . 7th) (VIII . 8th) (IX . 9th) (X . 10th)
        (XI . 11th) (XII . 12th) (? . unknown)))

(defun chord-progression (progr key)
  (cond ((null progr) ())
        (t
         (cons (funcall (cdr (assoc (car progr) *chord-progressions*)) key)
               (chord-progression (cdr progr) key)))))

(defun print-chords (name chord) 
  (format t "~:{~2A ~A ~{~3A~}~%~}" 
	  (mapcar #'(lambda (x) 
		      (list x name 
                            (show-sharps (funcall chord x)))) 
		  (show-sharps *notes*))))

(defun progression (progression)
  (loop for i in progression collecting
        (let ((note 
               (find-note
                (if (consp i) (car i) i)
                (major-scale 
                 (if (consp (car progression))
                     (caar progression) 
                (car progression))))))
          (if (null note)
              '(? . ?)
         (nth note *chord-progressions*)))))

(defun transpose-chord-progression (p new-key)
  (chord-progression
   (mapcar #'car (progression p))
   new-key))