;;;
;;; 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" "Em" "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" "Em" "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" "Em" "FM7" "G7" "Am7" "Bm7-5")

        ;;;(get-DS-of-a-key 'D 'Major)

        ;;;("DM7" "Em7" "+Fm" "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)))) 

        

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

        

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