;;;
;;; c:\\program files\\acl62\\music2.cl
;;;
(load "c:\\program files\\acl62\\music1.cl")

(setf *print-length* 1000)

(defun +key-p (key)
　　(if (member key '(G +F B E A D +d +g +c +f b e))
　　　　t
　　　nil))

(defun confine-a-number (n)
　　(prog (num)
　　　　(setf num (eval (cons '+ (multiple-value-list (floor n 7.0)))))
　　　　(cond ((and (>= num 0.8) (<= num 1.2)) (return 1.0))
　　　　　　　　((and (>= num 1.3) (<= num 1.7)) (return 1.5))
　　　　　　　　((and (>= num 1.8) (<= num 2.2)) (return 2.0))
　　　　　　　　((and (>= num 2.3) (<= num 2.7)) (return 2.5))
　　　　　　　　((and (>= num 2.8) (<= num 3.2)) (return 3.0))
　　　　　　　　((and (>= num 3.3) (<= num 3.7)) (return 3.5))
　　　　　　　　((and (>= num 3.8) (<= num 4.2)) (return 4.0))
　　　　　　　　((and (>= num 4.3) (<= num 4.7)) (return 4.5))
　　　　　　　　((and (>= num 4.8) (<= num 5.2)) (return 5.0))
　　　　　　　　((and (>= num 5.3) (<= num 5.7)) (return 5.5))
　　　　　　　　((and (>= num 5.8) (<= num 6.2)) (return 6.0))
　　　　　　　　((and (>= num 6.3) (<= num 6.7)) (return 6.5)))))

(defun translate-number-to-sound (n offset key)
　　(let ((num (confine-a-number (+ n offset))))
　　　　(case num
　　　　　　(1.0 "ド")
　　　　　　(1.5 (if (+key-p key)
　　　　　　　　　　　"#ド"
　　　　　　　　　"♭レ"))
　　　　　　(2.0 "レ")
　　　　　　(2.5 (if (+key-p key)
　　　　　　　　　　　"#レ"
　　　　　　　　　"♭ミ"))
　　　　　　(3.0 "ミ")
　　　　　　(3.5 "ファ")
　　　　　　(4.0 (if (+key-p key)
　　　　　　　　　　　"#ファ"
　　　　　　　　　　"♭ソ"))
　　　　　　(4.5 "ソ")
　　　　　　(5.0 (if (+key-p key)
　　　　　　　　　　　"#ソ"
　　　　　　　　　　"♭ラ"))
　　　　　　(5.5 "ラ")
　　　　　　(6.0 (if (+key-p key)
　　　　　　　　　　　"#ラ"
　　　　　　　　　　"♭シ"))
　　　　　　(6.5 "シ"))))

(defun translate-list-of-number-to-sound (l offset key)
　　(mapcar #'(lambda (e) (translate-number-to-sound e offset key)) l))

(defun translate-alphabet-to-number (c)
　　(case c
　　　　(c 1.0)(C 1.0)
　　　　(+c 1.5)(+C 1.5)(-d 1.5)(-D 1.5)
　　　　(d 2.0)(D 2.0)
　　　　(+d 2.5)(+D 2.5)(-e 2.5)(-E 2.5)
　　　　(e 3.0)(E 3.0)
　　　　(f 3.5)(F 3.5)
　　　　(+f 4.0)(+F 4.0)(-g 4.0)(-G 4.0)
　　　　(g 4.5)(G 4.5)
　　　　(+g 5.0)(+G 5.0)(-a 5.0)(-A 5.0)
　　　　(a 5.5)(A 5.5)
　　　　(+a 6.0)(+A 6.0)(-b 6.0)(-B 6.0)
　　　　(b 6.5)(B 6.5)))
;;;
;;; (get-chordscale 'c 'ion) =====> ("ド" "レ" "ミ" "ファ" "ソ" "ラ" "シ" "ド")
;;;
(defun get-chordscale (c csn)
　　(translate-list-of-number-to-sound (fget-i 'scale csn)
　　　　　　　　　　　　　　　　　　　　　　　　　　(1- (translate-alphabet-to-number c))
　　　　　　　　　　　　　　　　　　　　　　　　　　c))
;;;
;;; (get-tension-note 'C 'ion)
;;;
(defun get-tension-note (c csn)
　　(translate-list-of-number-to-sound (fget-i 'tension-note csn)
　　　　　　　　　　　　　　　　　　　　　　　　　　(1- (translate-alphabet-to-number c))
　　　　　　　　　　　　　　　　　　　　　　　　　　c))
;;;
;;;
;;;
(defun get-chord-type (scn)
　　(cond ((search-s1-in-s2 "7(+11 13)" scn) 'd7+1113)
　　　　　　((search-s1-in-s2 "7(+9+11)" scn) 'd7+9+11)
　　　　　　((search-s1-in-s2 "7(-9+11)" scn) 'd7-9+11)
　　　　　　((search-s1-in-s2 "7(9+11)" scn) 'd79+11)
　　　　　　((search-s1-in-s2 "M7(+11)" scn) 'M7+11)
　　　　　　((search-s1-in-s2 "mM7(11)" scn) 'mM711)
　　　　　　((search-s1-in-s2 "mM7(13)" scn) 'mM713)
　　　　　　((search-s1-in-s2 "7(+11)" scn) 'd7+11)
　　　　　　((search-s1-in-s2 "m7(11)" scn) 'm711)
　　　　　　((search-s1-in-s2 "m7(13)" scn) 'm713)
　　　　　　((search-s1-in-s2 "M7(13)" scn) 'M713)
　　　　　　((search-s1-in-s2 "mM7(9)" scn) 'mM79)
　　　　　　((search-s1-in-s2 "dimM7" scn) 'dimM7)
　　　　　　((search-s1-in-s2 "augM7" scn) 'augM7)
　　　　　　((search-s1-in-s2 "7sus4" scn) 'd7sus4)
　　　　　　((search-s1-in-s2 "(+11)" scn) 'M+11)
　　　　　　((search-s1-in-s2 "m(11)" scn) 'm11)
　　　　　　((search-s1-in-s2 "7(-9)" scn) 'd7-9)
　　　　　　((search-s1-in-s2 "madd9" scn) 'madd9)
　　　　　　((search-s1-in-s2 "7(+9)" scn) 'd7+9)
　　　　　　((search-s1-in-s2 "7(13)" scn) 'd713)
　　　　　　((search-s1-in-s2 "m7(9)" scn) 'm79)
　　　　　　((search-s1-in-s2 "M7(9)" scn) 'M79)
　　　　　　((search-s1-in-s2 "sus4" scn) 'sus4)
　　　　　　((search-s1-in-s2 "dim7" scn) 'dim7)
　　　　　　((search-s1-in-s2 "m7-5" scn) 'm7-5)
　　　　　　((search-s1-in-s2 "aug7" scn) 'aug7)
　　　　　　((search-s1-in-s2 "add9" scn) 'Madd9)
　　　　　　((search-s1-in-s2 "7(9)" scn) 'd79)
　　　　　　((search-s1-in-s2 "aug" scn) 'aug)
　　　　　　((search-s1-in-s2 "dim" scn) 'dim)
　　　　　　((search-s1-in-s2 "mM7" scn) 'mM7)
　　　　　　((search-s1-in-s2 "m69" scn) 'm69)
　　　　　　((search-s1-in-s2 "7-5" scn) 'd7-5)
　　　　　　((search-s1-in-s2 "-5" scn) 'M-5)
　　　　　　((search-s1-in-s2 "m7" scn) 'm7)
　　　　　　((search-s1-in-s2 "M7" scn) 'M7)
　　　　　　((search-s1-in-s2 "m6" scn) 'm6)
　　　　　　((search-s1-in-s2 "69" scn) 'M69)
　　　　　　((search-s1-in-s2 "m" scn) 'mt)
　　　　　　((search-s1-in-s2 "7" scn) 'd7)
　　　　　　((search-s1-in-s2 "6" scn) 'M6)
　　　　　　(t 'Mt)))

(defun involve-character-p (s)
　　(let ((lst '("+C" "-D" "+D" "-E" "+F" "-G" "+G" "-A" "+A" "-B"
　　　　　　　　　"C" "D" "E" "F" "G" "A" "B")))
　　　　(do ((l lst (cdr l)))
　　　　　　　((null l))
　　　　　(cond ((search-s1-in-s2 (car l) s)
　　　　　　　　　　(return (intern (car l))))))))
;;;
;;; (get-chord-tone "CM7") =====> ("ド" "ミ" "ソ" "シ")
;;;
(defun get-chord-tone (scn)
　　(let ((num (1- (translate-alphabet-to-number (involve-character-p scn))))
　　　　　(lst (fget-i 'code (get-chord-type scn))))
　　　(translate-list-of-number-to-sound lst num (involve-character-p scn))))
;;;
;;; (get-guide-tone "CM7")
;;;
(defun get-guide-tone (scn)
　　(let ((num (1- (translate-alphabet-to-number (involve-character-p scn))))
　　　　　(lst (fget-i 'guide-tone (get-chord-type scn))))
　　　(translate-list-of-number-to-sound lst num (involve-character-p scn))))
;;;
;;;
;;;
(defun translate-roman-to-number (s)
　　(cond ((equal s "I") 1.0)
　　　　　　　((or (equal s "+I") (equal s "-II")) 1.5)
　　　　　　　((equal s "II") 2.0)
　　　　　　　((or (equal s "+II") (equal s "-III")) 2.5)
　　　　　　　((equal s "III") 3.0)
　　　　　　　((equal s "IV") 3.5)
　　　　　　　((or (equal s "+IV") (equal s "-V")) 4.0)
　　　　　　　((equal s "V") 4.5)
　　　　　　　((or (equal s "+V") (equal s "-VI")) 5.0)
　　　　　　　((equal s "VI") 5.5)
　　　　　　　((or (equal s "+VI") (equal s "-VII")) 6.0)
　　　　　　　((equal s "VII") 6.5)))

(defun translate-number-to-roman (n offset key)
　　(let ((num (confine-a-number (+ n offset))))
　　　　(case num
　　　　　　(1.0 "I")
　　　　　　(1.5 (if (+key-p key) "+I" "-II"))
　　　　　　(2.0 "II")
　　　　　　(2.5 (if (+key-p key) "+II" "-III"))
　　　　　　(3.0 "III")
　　　　　　(3.5 "IV")
　　　　　　(4.0 (if (+key-p key) "+IV" "-V"))
　　　　　　(4.5 "V")
　　　　　　(5.0 (if (+key-p key) "+V" "-VI"))
　　　　　　(5.5 "VI")
　　　　　　(6.0 (if (+key-p key) "+VI" "-VII"))
　　　　　　(6.5 "VII"))))

(defun translate-number-to-alphabet (n offset key)
　　(let ((num (confine-a-number (+ n offset))))
　　　　(case num
　　　　　　(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"))))
;;;
;;; (translate-roman-to-alphabet "II" 'C) =====> "D"
;;;
(defun translate-roman-to-alphabet (s key)
　　(let ((num (translate-roman-to-number s)))
　　　　(translate-number-to-alphabet num (1- (translate-alphabet-to-number key)) key)))
;;;
;;; (translate-alphabet-to-roman 'D 'C) =====> "II"
;;;
(defun translate-alphabet-to-roman (c key)
　　(let ((num (translate-alphabet-to-number c)))
　　　(translate-number-to-roman num (- 6.0 (1- (translate-alphabet-to-number key))) key)))

(defun involve-roman-p (s)
　　(let ((lst '("-VII" "-III" "VII" "+VI" "-VI" "+IV" "III" "+II" "-II"
　　　　　　　　　"+I" "II" "IV" "-V" "+V" "VI" "V" "I")))
　　　　(do ((l lst (cdr l)))
　　　　　　　((null l))
　　　　　(cond ((search-s1-in-s2 (car l) s) (return (car l)))))))
;;;
;;; (get-chord-name-from-roman "IIm7" 'D) =====> "Em7"
;;;
(defun get-chord-name-from-roman (s key)
　　(let* ((roman (involve-roman-p s))
　　　　　　(char (translate-roman-to-alphabet roman key)))
　　　　(replace-s1-with-s2-in-s roman char s)))

(defun replace-roman (l key)
　　(cond ((null l) nil)
　　　　　　((and (not (listp l)) (involve-roman-p (string l)))
　　　　　　　(get-chord-name-from-roman (string l) key))
　　　　　　((atom l) l)
　　　　　　(t (cons (replace-roman (car l) key)
　　　　　　　　　　　　(replace-roman (cdr l) key)))))

(defun get-key-type (Mm)
　　(if (equal Mm 'major) 'major-key 'minor-key))
;;;
;;; (instantiate-a-key 'C 'major)
;;;
(defun instantiate-a-key (key type)
　　(let ((lst (fget-frame (get-key-type type))))
　　　(replace-roman lst key)))

(defun involve-char-p (s)
　　(let ((lst '("+C" "-D" "+D" "-E" "+F" "-G" "+G" "-A" "+A" "-B"
　　　　　　　　"C" "D" "E" "F" "G" "A" "B")))
　　　(do ((l lst (cdr l)))
　　　　　　((null l))
　　　　(cond ((search-s1-in-s2 (car l) s)
　　　　　　　　　(return (car l)))))))

(defun get-roman-from-chord-name (s key)
　　(let* ((chord (involve-char-p s))
　　　　　　(roman (translate-alphabet-to-roman (intern chord) key)))
　　　　(replace-s1-with-s2-in-s chord roman s)))
;;;
;;;
;;;
(defun back-to-roman (l key)
　　(cond ((null l) nil)
　　　　　　((and (not (listp l)) (involve-char-p (string l)))
　　　　　　　(get-roman-from-chord-name (string l) key))
　　　　　　((atom l) l)
　　　　　　(t (cons (back-to-roman (car l) key)
　　　　　　　　 　　　(back-to-roman (cdr l) key)))))

(defun get-UST-of-C (s)
　　(cond ((equal s "CM7") (cdr (fget-frame 'UST-CM7)))
　　　　　　((equal s "Cm7") (cdr (fget-frame 'UST-Cm7)))
　　　　　　((equal s "Cm") (cdr (fget-frame 'UST-Cm)))
　　　　　　((equal s "C7") (cdr (fget-frame 'UST-C7)))
　　　　　　((equal s "Cdim7") (cdr (fget-frame 'UST-Cdim7)))
　　　　　　((equal s "C7sus4") (cdr (fget-frame 'UST-C7sus4)))
　　　　　　((equal s "Cm7-5") (cdr (fget-frame 'UST-Cm7-5)))
　　　　　　((equal s "CmM7") (cdr (fget-frame 'UST-CmM7)))))

(defun get-chord-type2 (s)
　　(let ((lst '("7sus4" "dim7" "m7-5" "mM7" "M7" "m7" "m" "7")))
　　　(do ((l lst (cdr l)))
　　　　　　((null l))
　　　　(cond ((search-s1-in-s2 (car l) s)
　　　　　　　　　(return (car l)))))))

(defun get-C-chord-name (s) (concatenate 'string "C" (get-chord-type2 s)))

;;;
;;; (get-UST "CM7")
;;;
(defun get-UST (s)
　　(let* ((lst (get-UST-of-C (get-C-chord-name s)))
　　　　　　(roman (back-to-roman lst 'C)))
　　　(replace-roman roman (intern (involve-char-p s)))))
;;;
;;;
;;;
(defun modulate-key1-to-key2 (l key1 key2)
　　(let ((lst (back-to-roman l key1)))
　　　　(replace-roman lst key2)))