;;;
;;; c:\\program files\\acl62\\music11.cl
;;;
(load "c:\\program files\\acl62\\music10.cl")

(defun translate-flat-to-sharp (c)
(cond ((equal c '-do) 'si)
((equal c '-re) '+do)
((equal c '-mi) '+re)
((equal c '-fa) 'mi)
((equal c '-so) '+fa)
((equal c '-la) '+so)
((equal c '-si) '+la)
((equal c '+do) '+do)
((equal c '+re) '+re)
((equal c '+mi) 'fa)
((equal c '+fa) '+fa)
((equal c '+so) '+so)
((equal c '+la) '+la)
((equal c '+si) 'do)
((equal c 'do) 'do)
((equal c 're) 're)
((equal c 'mi) 'mi)
((equal c 'fa) 'fa)
((equal c 'so) 'so)
((equal c 'la) 'la)
((equal c 'si) 'si)
((equal c '--do) '+la)
((equal c '++do) 're)
((equal c '--re) 'do)
((equal c '++re) 'mi)
((equal c '--mi) 're)
((equal c '++mi) '+fa)
((equal c '--fa) '+re)
((equal c '++fa) 'so)
((equal c '--so) 'fa)
((equal c '++so) 'la)
((equal c '--la) 'so)
((equal c '++la) 'si)
((equal c '--si) 'la)
((equal c '++si) '+do)))

(defun translate-flat-to-sharp-in-a-list (lst)
(mapcar #'translate-flat-to-sharp lst))

;;;
;;; (the-list-is-involved-in-a-chord '(do re mi) "CM7")
;;;
(defun the-list-is-involved-in-a-chord (lst s-cn)
(sub-set-p (translate-flat-to-sharp-in-a-list lst)
(translate-flat-to-sharp-in-a-list (get-chord-tone s-cn))))

(setf *chord-type*
'("7" "M7" "mM7" "m7" "dimM7" "augM7" "7sus4" "sus4"
"dim7" "m7-5" "aug7" "aug" "dim" "-5" "m6" "69" "m69" "6" ""))

(defun C-chord (type) (concatenate 'string "C" type))
(defun get-C-chords () (mapcar #'C-chord *chord-type*))

(defun +C-chord (type) (concatenate 'string "+C" type))
(defun get-+C-chords () (mapcar #'+C-chord *chord-type*))

(defun -D-chord (type) (concatenate 'string "-D" type))
(defun get--D-chords () (mapcar #'-D-chord *chord-type*))

(defun D-chord (type) (concatenate 'string "D" type))
(defun get-D-chords () (mapcar #'D-chord *chord-type*))

(defun +D-chord (type) (concatenate 'string "+D" type))
(defun get-+D-chords () (mapcar #'+D-chord *chord-type*))

(defun -E-chord (type) (concatenate 'string "-E" type))
(defun get--E-chords () (mapcar #'-E-chord *chord-type*))

(defun E-chord (type) (concatenate 'string "E" type))
(defun get-E-chords () (mapcar #'E-chord *chord-type*))

(defun F-chord (type) (concatenate 'string "F" type))
(defun get-F-chords () (mapcar #'F-chord *chord-type*))

(defun +F-chord (type) (concatenate 'string "+F" type))
(defun get-+F-chords () (mapcar #'+F-chord *chord-type*))

(defun -G-chord (type) (concatenate 'string "-G" type))
(defun get--G-chords () (mapcar #'-G-chord *chord-type*))

(defun G-chord (type) (concatenate 'string "G" type))
(defun get-G-chords () (mapcar #'G-chord *chord-type*))

(defun +G-chord (type) (concatenate 'string "+G" type))
(defun get-+G-chords () (mapcar #'+G-chord *chord-type*))

(defun -A-chord (type) (concatenate 'string "-A" type))
(defun get--A-chords () (mapcar #'-A-chord *chord-type*))

(defun A-chord (type) (concatenate 'string "A" type))
(defun get-A-chords () (mapcar #'A-chord *chord-type*))

(defun +A-chord (type) (concatenate 'string "+A" type))
(defun get-+A-chords () (mapcar #'+A-chord *chord-type*))

(defun -B-chord (type) (concatenate 'string "-B" type))
(defun get--B-chords () (mapcar #'-B-chord *chord-type*))

(defun B-chord (type) (concatenate 'string "B" type))
(defun get-B-chords () (mapcar #'B-chord *chord-type*))

;;;
;;;
;;;
(defun get-C-chords-which-involve-the-list (lst)
(do ((l (get-C-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-+C-chords-which-involve-the-list (lst)
(do ((l (get-+C-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get--D-chords-which-involve-the-list (lst)
(do ((l (get--D-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-D-chords-which-involve-the-list (lst)
(do ((l (get-D-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-+D-chords-which-involve-the-list (lst)
(do ((l (get-+D-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get--E-chords-which-involve-the-list (lst)
(do ((l (get--E-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-E-chords-which-involve-the-list (lst)
(do ((l (get-E-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-F-chords-which-involve-the-list (lst)
(do ((l (get-F-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-+F-chords-which-involve-the-list (lst)
(do ((l (get-+F-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get--G-chords-which-involve-the-list (lst)
(do ((l (get--G-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-G-chords-which-involve-the-list (lst)
(do ((l (get-G-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-+G-chords-which-involve-the-list (lst)
(do ((l (get-+G-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get--A-chords-which-involve-the-list (lst)
(do ((l (get--A-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-A-chords-which-involve-the-list (lst)
(do ((l (get-A-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-+A-chords-which-involve-the-list (lst)
(do ((l (get-+A-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get--B-chords-which-involve-the-list (lst)
(do ((l (get--B-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

(defun get-B-chords-which-involve-the-list (lst)
(do ((l (get-B-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))

;;;
;;; (get-chords-which-involve-the-notes '(+fa +la +do fa)) ===> ("+FM7" "-GM7")
;;;
(defun get-chords-which-involve-the-notes (lst)
(append (get-C-chords-which-involve-the-list lst)
(get-+C-chords-which-involve-the-list lst)
(get--D-chords-which-involve-the-list lst)
(get-D-chords-which-involve-the-list lst)
(get-+D-chords-which-involve-the-list lst)
(get--E-chords-which-involve-the-list lst)
(get-E-chords-which-involve-the-list lst)
(get-F-chords-which-involve-the-list lst)
(get-+F-chords-which-involve-the-list lst)
(get--G-chords-which-involve-the-list lst)
(get-G-chords-which-involve-the-list lst)
(get-+G-chords-which-involve-the-list lst)
(get--A-chords-which-involve-the-list lst)
(get-A-chords-which-involve-the-list lst)
(get-+A-chords-which-involve-the-list lst)
(get--B-chords-which-involve-the-list lst)
(get-B-chords-which-involve-the-list lst)))