;;; -*- Mode : Lisp; indent-tabs-mode: nil -*- ;;; Copyright 2006 Jeremy English ;;; ;;; 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))