;;;
;;; c:\\program files\\acl62\\music53.cl
;;;
(load "c:\\program files\\acl62\\music52.cl")

(make-frame-from-list
　'(Diatonic-Scale-of-C (C-Major (value "CM7" "Dm7" "Em7" "FM7" "G7" "Am7" "Bm7-5"))
　　　　　　　　　　　　　　　　(C-Natural-Minor (value "Cm7" "Dm7-5" "-EM7" "Fm7" "Gm7" "-AM7" "-B7"))
　　　　　　　　　　　　　　　　(C-Harmonic-Minor (value "CmM7" "Dm7-5" "-EM7+5" "Fm7" "G7" "-AM7" "Bdim7"))
　　　　　　　　　　　　　　　　(C-Melodic-Minor (value "CmM7" "Dm7" "-EM7+5" "F7" "G7" "Am7-5" "Bm7-5"))))

;;;
;;;(get-DS-of-C 'C-Major)
;;;("CM7" "Dm7" "Em7" "FM7" "G7" "Am7" "Bm7-5")
;;;(get-DS-of-C 'C-Natural-Minor)
;;;("Cm7" "Dm7-5" "-EM7" "Fm7" "Gm7" "-AM7" "-B7")
;;;(get-DS-of-C 'C-Harmonic-Minor)
;;;("CmM7" "Dm7-5" "-EM7+5" "Fm7" "G7" "-AM7" "Bdim7")
;;;(get-DS-of-C 'C-Melodic-Minor)
;;;("CmM7" "Dm7" "-EM7+5" "F7" "G7" "Am7-5" "Bm7-5")
;;;
(defun get-DS-of-C (Scale-type)
　　(cond ((equal Scale-type 'Major) (fget 'Diatonic-Scale-of-C 'C-Major 'value))
　　　　　　((equal Scale-type 'Natural-Minor) (fget 'Diatonic-Scale-of-C 'C-Natural-Minor 'value))
　　　　　　((equal Scale-type 'Harmonic-Minor) (fget 'Diatonic-Scale-of-C 'C-Harmonic-Minor 'value))
　　　　　　((equal Scale-type 'Melodic-Minor) (fget 'Diatonic-Scale-of-C 'C-Melodic-Minor 'value))))

;;;
;;;(get-DS-of-a-key 'C 'Major)
;;;("CM7" "Dm7" "Em7" "FM7" "G7" "Am7" "Bm7-5")
;;;(get-DS-of-a-key 'D 'Major)
;;;("DM7" "Em7" "+Fm7" "GM7" "A7" "Bm7" "+Cm7-5")
;;;(get-DS-of-a-key 'a 'Natural-Minor)
;;;("Am7" "Bm7-5" "CM7" "Dm7" "Em7" "FM7" "G7")
;;;(get-DS-of-a-key 'e 'Natural-Minor)
;;;("Em7" "+Fm7-5" "GM7" "Am7" "Bm7" "CM7" "D7")
;;;(get-DS-of-a-key 'a 'Harmonic-Minor)
;;;("AmM7" "Bm7-5" "CM7+5" "Dm7" "E7" "FM7" "-Adim7")
;;;(get-DS-of-a-key 'c 'Harmonic-Minor)
;;;("CmM7" "Dm7-5" "-EM7+5" "Fm7" "G7" "-AM7" "Bdim7")
;;;(get-DS-of-a-key 'a 'Melodic-Minor)
;;;("AmM7" "Bm7" "CM7+5" "D7" "E7" "-Gm7-5" "-Am7-5")
;;;(get-DS-of-a-key 'c 'Melodic-Minor)
;;;("CmM7" "Dm7" "-EM7+5" "F7" "G7" "Am7-5" "Bm7-5")
;;;
(defun get-DS-of-a-key (key Scale-type)
　　(let* ((lst (get-DS-of-C Scale-type))
　　　　　　(roman (back-to-roman lst 'C)))
　　　　(replace-roman roman key)))

;;;
;;;Minor 3rd Progression
;;;
;;; p1-1 :C7 -E7 -G7 A7 C7 ( s ` j
;;; p1-2 :C7 A7 -G7 -E7 C7 ( s ` j
;;;
;;; p2-1 :CM7 AM7 -GM7 -EM7 CM7
;;; p2-2 :CM7 -EM7 -GM7 AM7 CM7
;;;
;;; p3 :CM7 F7 -A7 B7 D7 CM7
;;;
;;; p4 :-B7 G7 E7 -D7 CM7
;;;
;;; p5-1 :Dm7 Fm7 -Am7 Bm7 Dm7 G7 (CM7)
;;; p5-2 :Dm7 Bm7 -Am7 Fm7 Dm7 G7 (CM7)
;;;
;;; p6-1 :Dm7 Fm7 -Am7 -D7 CM7
;;; p6-2 :Dm7 Bm7 -Am7 -D7 CM7
;;;
;;; p7 :Dm7 Bm7 -Am7 Fm7 Em7 ( U I ~ j
;;;
;;; p8-1 :Bm7-5 -Am7-5 Fm7-5 Dm7-5 Bm7-5 E7 (Am7)
;;; p8-2 :Bm7-5 Dm7-5 Fm7-5 -Am7-5 Bm7-5 E7 (Am7)
;;;
(make-frame-from-list
　　'(P3-pat (p1-1 (value "C7" "-E7" "-G7" "A7" "C7"))
　　　　　　　　(p1-2 (value "C7" "A7" "-G7" "-E7" "C7"))
　　　　　　　　(p2-1 (value "CM7" "AM7" "-GM7" "-EM7" "CM7"))
　　　　　　　　(p2-2 (value "CM7" "-EM7" "-GM7" "AM7" "CM7"))
　　　　　　　　(p3 (value "CM7" "F7" "-A7" "B7" "D7" "CM7"))
　　　　　　　　(p4 (value "-B7" "G7" "E7" "-D7" "CM7"))
　　　　　　　　(p5-1 (value "Dm7" "Fm7" "-Am7" "Bm7" "Dm7" "G7" "CM7"))
　　　　　　　　(p5-2 (value "Dm7" "Bm7" "-Am7" "Fm7" "Dm7" "G7" "CM7"))
　　　　　　　　(p6-1 (value "Dm7" "Fm7" "-Am7" "-D7" "CM7"))
　　　　　　　　(p6-2 (value "Dm7" "Bm7" "-Am7" "-D7" "CM7"))
　　　　　　　　(p7 (value "Dm7" "Bm7" "-Am7" "Fm7" "Em7"))))

(make-frame-from-list
　　'(P3-pat-minor (p8-1 (value "Bm7-5" "-Am7-5" "Fm7-5" "Dm7-5" "Bm7-5" "E7" "Am7"))
　　　　　　　　　　　　(p8-2 (value "Bm7-5" "Dm7-5" "Fm7-5" "-Am7-5" "Bm7-5" "E7" "Am7"))))

(defun get-P3-of-C (pat)
　　(cond ((equal pat 'p1) (fget 'P3-pat 'p1-1 'value))
　　　　　　((equal pat 'p2) (fget 'P3-pat 'p1-2 'value))
　　　　　　((equal pat 'p3) (fget 'P3-pat 'p2-1 'value))
　　　　　　((equal pat 'p4) (fget 'P3-pat 'p2-2 'value))
　　　　　　((equal pat 'p5) (fget 'P3-pat 'p3 'value))
　　　　　　((equal pat 'p6) (fget 'P3-pat 'p4 'value))
　　　　　　((equal pat 'p7) (fget 'P3-pat 'p5-1 'value))
　　　　　　((equal pat 'p8) (fget 'P3-pat 'p5-2 'value))
　　　　　　((equal pat 'p9) (fget 'P3-pat 'p6-1 'value))
　　　　　　((equal pat 'p10) (fget 'P3-pat 'p6-2 'value))
　　　　　　((equal pat 'p11) (fget 'P3-pat 'p7 'value))))

(defun get-P3-of-a (pat)
　　(cond ((equal pat 'p1) (fget 'P3-pat-minor 'p8-1 'value))
　　　　　　((equal pat 'p2) (fget 'P3-pat-minor 'p8-2 'value))))

;;;
;;;(get-P3-of-major-key 'C 'p1)--->("C7" "-E7" "-G7" "A7" "C7")
;;;(get-P3-of-major-key 'C 'p2)--->("C7" "A7" "-G7" "-E7" "C7")
;;;(get-P3-of-major-key 'C 'p3)--->("CM7" "AM7" "-GM7" "-EM7" "CM7")
;;;(get-P3-of-major-key 'C 'p4)--->("CM7" "-EM7" "-GM7" "AM7" "CM7")
;;;(get-P3-of-major-key 'C 'p5)--->("CM7" "F7" "-A7" "B7" "D7" "CM7")
;;;(get-P3-of-major-key 'C 'p6)--->("-B7" "G7" "E7" "-D7" "CM7")
;;;(get-P3-of-major-key 'C 'p7)--->("Dm7" "Fm7" "-Am7" "Bm7" "Dm7" "G7" "CM7")
;;;(get-P3-of-major-key 'C 'p8)--->("Dm7" "Bm7" "-Am7" "Fm7" "Dm7" "G7" "CM7")
;;;(get-P3-of-major-key 'C 'p9)--->("Dm7" "Fm7" "-Am7" "-D7" "CM7")
;;;(get-P3-of-major-key 'C 'p10)--->("Dm7" "Bm7" "-Am7" "-D7" "CM7")
;;;(get-P3-of-major-key 'C 'p11)--->("Dm7" "Bm7" "-Am7" "Fm7" "Em7")
;;;(get-P3-of-major-key 'D 'p1)--->("D7" "F7" "+G7" "B7" "D7")
;;;(get-P3-of-major-key 'E 'p2)--->("E7" "+C7" "+A7" "G7" "E7")
;;;(get-P3-of-major-key 'F 'p3)--->("FM7" "DM7" "BM7" "-AM7" "FM7")
;;;(get-P3-of-major-key '+F 'p4)--->("+FM7" "AM7" "CM7" "+DM7" "+FM7")
;;;(get-P3-of-major-key '-G 'p5)--->("-GM7" "B7" "D7" "F7" "-A7" "-GM7")
;;;(get-P3-of-major-key 'G 'p6)--->("F7" "D7" "B7" "+G7" "GM7")
;;;(get-P3-of-major-key '+G 'p7)--->("-Bm7" "-Dm7" "Em7" "Gm7" "-Bm7" "-E7" "-AM7")
;;;(get-P3-of-major-key '-A 'p8)--->("-Bm7" "Gm7" "Em7" "-Dm7" "-Bm7" "-E7" "-AM7")
;;;(get-P3-of-major-key 'A 'p9)--->("Bm7" "Dm7" "Fm7" "+A7" "AM7")
;;;(get-P3-of-major-key '-B 'p10)--->("Cm7" "Am7" "-Gm7" "B7" "-BM7")
;;;(get-P3-of-major-key '+A 'p11)--->("Cm7" "Am7" "-Gm7" "-Em7" "Dm7")
;;;(get-P3-of-major-key 'B 'p1)--->("B7" "D7" "F7" "+G7" "B7")
;;;
(defun get-P3-of-major-key (key pat)
　　(let* ((lst (get-P3-of-C pat))
　　　　　　(roman (back-to-roman lst 'C)))
　　　　(replace-roman roman key)))

;;;
;;;(get-P3-of-minor-key 'a 'p1)--->("Bm7-5" "-Am7-5" "Fm7-5" "Dm7-5" "Bm7-5" "E7" "Am7")
;;;(get-P3-of-minor-key 'a 'p2)--->("Bm7-5" "Dm7-5" "Fm7-5" "-Am7-5" "Bm7-5" "E7" "Am7")
;;;(get-P3-of-minor-key 'd 'p1)--->("Em7-5" "-Dm7-5" "-Bm7-5" "Gm7-5" "Em7-5" "A7" "Dm7")
;;;(get-P3-of-minor-key 'd 'p2)--->("Em7-5" "Gm7-5" "-Bm7-5" "-Dm7-5" "Em7-5" "A7" "Dm7")
;;;(get-P3-of-minor-key '-e 'p1)--->("Fm7-5" "Dm7-5" "Bm7-5" "-Am7-5" "Fm7-5" "-B7" "-Em7")
;;;(get-P3-of-minor-key '+d 'p1)--->("Fm7-5" "Dm7-5" "Bm7-5" "+Gm7-5" "Fm7-5" "+A7" "+Dm7")
;;;(get-P3-of-minor-key '-e 'p2)--->("Fm7-5" "-Am7-5" "Bm7-5" "Dm7-5" "Fm7-5" "-B7" "-Em7")
;;;(get-P3-of-minor-key '+d 'p2)--->("Fm7-5" "+Gm7-5" "Bm7-5" "Dm7-5" "Fm7-5" "+A7" "+Dm7")
;;;
(defun get-P3-of-minor-key (key pat)
　　(let* ((lst (get-P3-of-a pat))
　　　　　　(roman (back-to-roman lst 'a)))
　　　　(replace-roman roman key)))