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



(defun translate-j-note-to-doremi (s-note) 
　　(cond ((equal s-note "ド") 'do) 
　　　　　　((equal s-note "#ド") '+do) 
　　　　　　((equal s-note "♭レ") '+do) 
　　　　　　((equal s-note "#レ") '+re) 
　　　　　　((equal s-note "♭ミ") '+re) 
　　　　　　((equal s-note "#ミ") 'fa) 
　　　　　　((equal s-note "#ファ") '+fa) 
　　　　　　((equal s-note "♭ソ") '+fa) 
　　　　　　((equal s-note "#ソ") '+so) 
　　　　　　((equal s-note "♭ラ") '+so) 
　　　　　　((equal s-note "#ラ") '+la) 
　　　　　　((equal s-note "♭シ") '+la) 
　　　　　　((equal s-note "#シ") 'do) 
　　　　　　((equal s-note "レ") 're) 
　　　　　　((equal s-note "ミ") 'mi) 
　　　　　　((equal s-note "ファ") 'fa) 
　　　　　　((equal s-note "ソ") 'so) 
　　　　　　((equal s-note "ラ") 'la) 
　　　　　　((equal s-note "シ") 'si))) 


(defun replace-j-note-with-doremi (lst) 
　　(mapcar #'translate-j-note-to-doremi lst)) 


(defun replace-j-note-with-doremi-in-a-chord (s-cn) 
　　(replace-j-note-with-doremi 
         (get-chord-tone s-cn))) 


(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) 

　　(replace-j-note-with-doremi-in-a-chord 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)))