;;;
;;; 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 'do)
       (1.5 (if (+key-p key)
            '+do
            '-re))
       (2.0 're)
       (2.5 (if (+key-p key)
            '+re
            '-mi))
       (3.0 'mi)
       (3.5 'fa)
       (4.0 (if (+key-p key)
            '+fa
            '-so))
       (4.5 'so)
       (5.0 (if (+key-p key)
            '+so
            '-la))
       (5.5 'la)
       (6.0 (if (+key-p key)
            '+la
            '-si))
       (6.5 'si))))

(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) =====> (do re mi fa so la si do)
;;;
(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") =====> (do mi so si)
;;;
(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)))