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