;;;
;;; c:\\program files\\acl62\\music15.cl
;;;
(load "c:\\program files\\acl62\\music14.cl")

(defun make-lists-of-elements-except-one (lst)
　　(do ((l lst (cdr l)) (w))
　　　　　((null l)
　　　　　(remove-duplicate (reverse w)))
　　　(push (list (car l) (remove (car l) lst)) w)))

(defun test (lst)
　　(format t "~%Tnesion~%~a" (get-scales-whitch-involve-the-tension-notes lst))
　　(format t "~%Scales~%~a" (get-scales-whitch-involve-the-notes lst))
　　(format t "~%Chords~%~a" (get-chords-which-involve-the-notes lst)))

(defun check-a-tension (note)
　　(get-scales-whitch-involve-the-tension-notes (list note)))

(defun get-chord-type-from-scale (scale)
　　(cond ((equal scale 'ion) "M7")
　　　　　　((equal scale 'dor) "m7")
　　　　　　((equal scale 'phr) "m7")
　　　　　　((equal scale 'lyd) "M7")
　　　　　　((equal scale 'mix) "7")
　　　　　　((equal scale 'aeo) "m7")
　　　　　　((equal scale 'loc) "m7-5")
　　　　　　((equal scale 'n) "m7")
　　　　　　((equal scale 'h) "m7")
　　　　　　((equal scale 'm) "m7")
　　　　　　((equal scale 'all) "m7")
　　　　　　((equal scale 'dor-2) "m7")
　　　　　　((equal scale 'loc+2) "m7-5")
　　　　　　((equal scale 'lyd-7) "7")
　　　　　　((equal scale 'hmp5) "7")
　　　　　　((equal scale 'mmp5) "7")
　　　　　　((equal scale 'alt) "7")
　　　　　　((equal scale 'comd) "7")
　　　　　　((equal scale 'dim) "dim7")
　　　　　　((equal scale 'wt) "7")
　　　　　　((equal scale 'mixsus4) "7sus4")
　　　　　　((equal scale 'mix-6) "7")))

;;;
;;; (get-chord-name-from-a-pair '(C ion))
;;;
(defun get-chord-name-from-a-pair (pair)
　　(concatenate 'string (string (first pair)) (get-chord-type-from-scale (second pair))))

(defun get-chord-names-from-pairs (lst)
　　(mapcar #'get-chord-name-from-a-pair lst))

(defun get-chord-names-with-a-tension (ten)
　　(remove-duplicate (get-chord-names-from-pairs (check-a-tension ten))))

(defun get-chord-names-with-a-chord-note (note)
　　(get-chords-which-involve-the-notes (list note)))

(defun get-chord-names-with-a-note (note)
　　(append (get-chord-names-with-a-tension note) (get-chord-names-with-a-chord-note note)))

(defun get-chord-names-with-notes (lst-of-notes)
　　(mapcar #'get-chord-names-with-a-note lst-of-notes))

(defun intersect-of-two-sets (l1 l2)
　　(do ((l l1 (cdr l)) (w))
　　　　　((null l) w)
　　　　(if (member (car l) l2 :test #'equal)
　　　　　　(push (car l) w))))

(defun intersect-of-sets (lst)
　　(do* ((l lst (cdr l))
　　　　　　(w (first l)))
　　　　　　((null (rest l)) w)
　　　　(setf w (append (intersect-of-two-sets w (second l))))))

;;;
;;; ある音列に利用可能なコードの候補を列挙します
;;; ;;; (get-chords '(do re mi fa))
;;;
(defun get-chords (lst)
　　(format t "~%~a" (intersect-of-sets (get-chord-names-with-notes lst))))

(defun check-chords (lst)
　　(format t "~%~a" (get-chords-which-involve-the-notes lst)))

(defun check-tensions (lst)
　　(format t "~%~a"
　　　(remove-duplicate (get-chord-names-from-pairs (get-scales-whitch-involve-the-tension-notes lst)))))

(defun check-scales (lst)
　　(format t "~%~a"
　　　(remove-duplicate (get-chord-names-from-pairs (get-scales-whitch-involve-the-notes lst)))))

;;;
;;;
;;;
(defun identify-scales (lst)
　　(format t "~%~a" (get-scales-whitch-involve-the-notes lst)))