;;;
;;; c:\\program files\\acl62\\music3.cl
;;;
(load "c:\\program files\\acl62\\rythm.cl")

(defun distance-of-two-chars (c1 c2)
　　(let* ((n1 (translate-alphabet-to-number c1))
　　　　　　(n2 (translate-alphabet-to-number c2))
　　　　　　(num (- n2 n1)))
　　　(cond ((>= num 7.0) (- num 6.0))
　　　　　　　((<= num 0.0) (+ num 6.0))
　　　　　　　(t num))))

(defun translate-number-to-lower-char (n key)
　　(case n
　　　　(1.0 'c)
　　　　(1.5 (if (+key-p key) '+c '-d))
　　　　(2.0 'd)
　　　　(2.5 (if (+key-p key) '+d '-e))
　　　　(3.0 'e) (3.5 'f)
　　　　(4.0 (if (+key-p key) '+f '-g))
　　　　(4.5 'g)
　　　　(5.0 (if (+key-p key) '+g '-a))
　　　　(5.5 'a)
　　　　(6.0 (if (+key-p key) '+a '-b))
　　　　(6.5 'b)))

(defun translate-number-to-upper-char (n key)
　　(case n
　　　　(1.0 'C)
　　　　(1.5 (if (+key-p key) '+C '-D))
　　　　(2.0 'D)
　　　　(2.5 (if (+key-p key) '+D '-E))
　　　　(3.0 'E) (3.5 'F)
　　　　(4.0 (if (+key-p key) '+F '-G))
　　　　(4.5 'G)
　　　　(5.0 (if (+key-p key) '+G '-A))
　　　　(5.5 'A)
　　　　(6.0 (if (+key-p key) '+A '-B))
　　　　(6.5 'B)))

(defun translate-lower-char-key1-to-key2 (char key1 key2)
　　(let ((num (confine-a-number (+ (translate-alphabet-to-number char)
　　　　　　　　　　　　　　　　　　　　　 (distance-of-two-chars key1 key2)))))
　　　 (translate-number-to-lower-char num key2)))

(defun translate-upper-char-key1-to-key2 (char key1 key2)
　　(let ((num (confine-a-number (+ (translate-alphabet-to-number char)
　　　　　　　　　　　　　　　　　　　　　　　 (distance-of-two-chars key1 key2)))))
　　　 (translate-number-to-upper-char num key2)))

(defun upper-char-p (c)
　　(cond ((member c '(C +C -D D +D -E E F +F -G G +G -A A +A -B B)) t)
　　　　　　(t nil)))

(defun lower-char-p (c)
　　(cond ((member c '(c +c -d d +d -e e f +f -g g +g -a a +a -b b)) t)
　　　　　　(t nil)))

(defun translate-char-key1-to-key2 (char key1 key2)
　　(cond ((upper-char-p char)
　　　　　　　(translate-upper-char-key1-to-key2 char key1 key2))
　　　　　　((lower-char-p char)
　　　　　　　(translate-lower-char-key1-to-key2 char key1 key2))
　　　　　　(t char)))

(defun involve-atom-p (c)
　　(intern (involve-char-p (string c))))

(defun replace-key1-to-key2 (l key1 key2)
　　(cond ((null l) nil)
　　　　　　((and (not (listp l))
　　　　　　　　　　(or (upper-char-p l)
　　　　　　　　　　(lower-char-p l)))
　　　　　　　(translate-char-key1-to-key2 l key1 key2))
　　　　　　((atom l) l)
　　　　　　(t (cons (replace-key1-to-key2 (car l) key1 key2)
　　　　　　　　　　　　(replace-key1-to-key2 (cdr l) key1 key2)))))

(defun get-function-of-C () (cdr (fget-frame 'C)))
(defun get-function-of-Am () (cdr (fget-frame 'Am)))
(defun get-function-of-CM7 () (cdr (fget-frame 'CM7)))
(defun get-function-of-Am7 () (cdr (fget-frame 'Am7)))
(defun get-function-of-C7 () (cdr (fget-frame 'C7)))
(defun get-function-of-C6 () (cdr (fget-frame 'C6)))
(defun get-function-of-Am6 () (cdr (fget-frame 'Am6)))
(defun get-function-of-Am7-5 () (cdr (fget-frame 'Am7-5)))
(defun get-function-of-AmM7 () (cdr (fget-frame 'AmM7)))
(defun get-function-of-A+M7 () (cdr (fget-frame 'A+M7)))

(defun get-function-of- (chord)
　　(replace-key1-to-key2 (get-function-of-C) 'C (involve-atom-p chord)))

(defun get-function-of-m (chord)
　　(replace-key1-to-key2 (get-function-of-Am) 'a (involve-atom-p chord)))

(defun get-function-of-M7 (chord)
　　(replace-key1-to-key2 (get-function-of-CM7) 'C (involve-atom-p chord)))

(defun get-function-of-m7 (chord)
　　(replace-key1-to-key2 (get-function-of-Am7) 'a (involve-atom-p chord)))

(defun get-function-of-7 (chord)
　　(replace-key1-to-key2 (get-function-of-C7) 'C (involve-atom-p chord)))

(defun get-function-of-6 (chord)
　　(replace-key1-to-key2 (get-function-of-C6) 'C (involve-atom-p chord)))

(defun get-function-of-m6 (chord)
　　(replace-key1-to-key2 (get-function-of-Am6) 'a (involve-atom-p chord)))

(defun get-function-of-m7-5 (chord)
　　(replace-key1-to-key2 (get-function-of-Am7-5) 'a (involve-atom-p chord)))

(defun get-function-of-mM7 (chord)
　　(replace-key1-to-key2 (get-function-of-AmM7) 'a (involve-atom-p chord)))

(defun get-function-of-+M7 (chord)
　　(replace-key1-to-key2 (get-function-of-A+M7) 'a (involve-atom-p chord)))

;;;
;;; (get-function-of-chord 'CM7)
;;;
(defun get-function-of-chord (chord)
　　(cond ((search-s1-in-s2 "m7-5" (string chord)) (get-function-of-m7-5 chord))
　　　　　　((search-s1-in-s2 "mM7" (string chord)) (get-function-of-mM7 chord))
　　　　　　((search-s1-in-s2 "+M7" (string chord)) (get-function-of-+M7 chord))
　　　　　　((search-s1-in-s2 "M7" (string chord)) (get-function-of-M7 chord))
　　　　　　((search-s1-in-s2 "m7" (string chord)) (get-function-of-m7 chord))
　　　　　　((search-s1-in-s2 "m6" (string chord)) (get-function-of-m6 chord))
　　　　　　((search-s1-in-s2 "m" (string chord)) (get-function-of-m chord))
　　　　　　((search-s1-in-s2 "7" (string chord)) (get-function-of-7 chord))
　　　　　　((search-s1-in-s2 "6" (string chord)) (get-function-of-6 chord))
　　　　　　(t (get-function-of- chord))))