(load "c:\\program files\\acl62\\music41.cl")

(make-frame-from-list
　'(chords-on-scale
　　(CM7-ion-2 (value "CM7" "Dm7" "Em7"
                      "FM7" "G7" "Am7"
                      "Bm7-5"))
　　(Cm7-dor-2 (value "Cm7" "Dm7" "-EM7"
                      "F7" "Gm7" "Am7-5"
                      "-BM7"))
　　(Cm7-phr-2 (value "Cm7" "-DM7" "-E7"
                      "Fm7" "Gm7-5" "-AM7"
                      "-Bm7"))
　　(CM7-lyd-2 (value "CM7" "D7" "Em7"
                      "+Fm7-5" "GM7"
                      "Am7" "Bm7"))
　　(C7-mix-2 (value "C7" "Dm7" "Em7-5"
                     "FM7" "Gm7" "Am7"
                     "-BM7"))
　　(Cm7-aeo-2 (value "Cm7" "Dm7-5"
                      "-EM7" "Fm7" "Gm7"
                      "-AM7" "-B7"))
　　(Cm7-5-loc-2 (value "Cm7-5" "-DM7"
                        "-Em7" "Fm7"
                        "-GM7" "-AM7"
                        "-Bm7"))
　　(Cm7-n-2 (value "Cm7" "Dm7-5" "-EM7"
                    "Fm7" "Gm7" "-AM7"
                    "-B7"))
　　(Cm7-h-2 (value "CmM7" "Dm7-5"
                    "-EaugM7" "Fm7"
                    "G7" "-AM7"
                    "Bdim"))
　　(Cm7-m-2 (value "CmM7" "Dm7"
                    "-EaugM7" "F7"
                    "G7" "Am7-5" "Bm7-5"
                    "Cm7" "-B7" "-AM7"
                    "Gm7" "Fm7" "-EM7"
                    "Dm7-5"))
　　(Cm7-dor-2-2 (value "Cm7-5" "-DaugM7"
                        "-E7" "F7"
                        "Gm7-5" "Am7-5"
                        "-BmM7"))
　　(Cm7-5-loc+2-2 (value "Cm7-5"
                          "Dm7-5" "-EmM7"
                          "Fm7" "-GaugM7"
                          "-A7" "-B7"))
　　(C7-lyd-7-2 (value "C7" "D7" "Em7-5"
                       "+Fm7-5" "GmM7"
                       "Am7" "-BaugM7"))
　　(C7-hmp5-2 (value "Fm7" "-Ddim7"
                      "Edim7" "Gdim7"
                      "-Bdim7"))
　　(C7-mmp5-2 (value "C7" "Dm7-5"
                      "Em7-5" "FmM7"
                      "Gm7" "-AaugM7"
                      "-B7"))
　　(C7-alt-2 (value "Cm7-5" "-DmM7"
                     "-Em7" "EaugM7"
                     "-G7" "-A7"
                     "-Bm7-5"))
　　(C7-comd-2 (value "Cdim7" "-Ddim7"
                      "-Edim7" "Edim7"
                      "-Gdim7" "Gdim7"
                      "Adim7" "-Bdim7"))
　　(Cdim7-dim-2 (value "Cdim7" "Ddim7"
                        "-Edim7" "Fdim7"
                        "-Gdim7" "-Adim7"
                        "Adim7" "Bdim7"))
　　(C7-wt-2 (value "Caug" "Daug" "Eaug"
                    "-Gaug" "-Aaug"
                    "-Baug"))
　　(C7-mixsus4-2 (value "C7"
                         "Dm7" "Em7-5"
                         "FM7" "Gm7"
                         "Am7" "-BM7"))
　　(C7-mix-6-2 (value "C7" "Dm7-5"
                       "Em7-5" "FmM7"
                       "Gm7" "-AaugM7"
                       "-B7"))))

;;;
;;; (get-chords-on-scale '("CM7" ion))
;;;
(defun get-chords-on-scale (pair)
　(case (second pair)
　　(ion (modulate-key1-to-key2
             (fget-i 'chords-on-scale
                     'CM7-ion-2)
             'C
             (involve-atom-p
                     (first pair))))
　　(dor (modulate-key1-to-key2
             (fget-i 'chords-on-scale
                     'Cm7-dor-2)
             'C
             (involve-atom-p
                     (first pair))))
　　(phr (modulate-key1-to-key2
             (fget-i 'chords-on-scale
                     'Cm7-phr-2)
             'C
             (involve-atom-p
                     (first pair))))
　　(lyd (modulate-key1-to-key2
             (fget-i 'chords-on-scale
                     'CM7-lyd-2)
             'C
             (involve-atom-p
                     (first pair))))
　　(mix (modulate-key1-to-key2 
             (fget-i 'chords-on-scale
                     'C7-mix-2)
             'C
             (involve-atom-p
                     (first pair))))
　　(aeo (modulate-key1-to-key2
             (fget-i 'chords-on-scale
                     'Cm7-aeo-2)
             'C
             (involve-atom-p
                     (first pair))))
　　(loc (modulate-key1-to-key2
             (fget-i 'chords-on-scale
                     'Cm7-5-loc-2)
             'C
             (involve-atom-p
                     (first pair))))
　　(n (modulate-key1-to-key2
           (fget-i 'chords-on-scale
                   'Cm7-n-2)
           'C
           (involve-atom-p
                   (first pair))))
　　(h (modulate-key1-to-key2
           (fget-i 'chords-on-scale
                   'Cm7-h-2)
           'C
           (involve-atom-p
                   (first pair))))
　　(m (modulate-key1-to-key2
           (fget-i 'chords-on-scale
                   'Cm7-m-2)
           'C
           (involve-atom-p
                   (first pair))))
　　(dor-2 (modulate-key1-to-key2
               (fget-i 'chords-on-scale
                       'Cm7-dor-2-2)
               'C
               (involve-atom-p
                       (first pair))))
　　(loc+2 (modulate-key1-to-key2
               (fget-i 'chords-on-scale
                       'Cm7-5-loc+2-2)
               'C
               (involve-atom-p
                       (first pair))))
　　(lyd-7 (modulate-key1-to-key2
               (fget-i 'chords-on-scale
                       'C7-lyd-7-2)
               'C
               (involve-atom-p
                       (first pair))))
　　(hmp5 (modulate-key1-to-key2
              (fget-i 'chords-on-scale
                      'C7-hmp5-2)
              'C
              (involve-atom-p
                      (first pair))))
　　(mmp5 (modulate-key1-to-key2
              (fget-i 'chords-on-scale
                      'C7-mmp5-2)
              'C
              (involve-atom-p
                      (first pair))))
　　(alt (modulate-key1-to-key2
             (fget-i 'chords-on-scale
                     'C7-alt-2)
             'C
             (involve-atom-p
                     (first pair))))
　　(comd (modulate-key1-to-key2
              (fget-i 'chords-on-scale
                      'C7-comd-2)
              'C
              (involve-atom-p
                      (first pair))))
　　(dim (modulate-key1-to-key2
             (fget-i 'chords-on-scale
                     'Cdim7-dim-2)
             'C
             (involve-atom-p
                     (first pair))))
　　(wt (modulate-key1-to-key2
            (fget-i 'chords-on-scale
                    'C7-wt-2)
            'C
            (involve-atom-p
                    (first pair))))
　　(mixsus4 (modulate-key1-to-key2
                 (fget-i 'chords-on-scale
                         'C7-mixsus4-2)
                 'C
                 (involve-atom-p
                         (first pair))))
　　(mix-6 (modulate-key1-to-key2
               (fget-i 'chords-on-scale
                       'C7-mix-6-2)
               'C
               (involve-atom-p
                       (first pair))))))

;;;
;;; (tell-chords-on-scale *w1*)
;;;
(defun tell-chords-on-scale-aux (lst)
　　(let ((l (collect-pairs lst)))
　　　　(do ((ll l (cdr ll)))
　　　　　　((null ll))
　　　　　(format t "~% ~a : ~a."
                     (car ll)
                     (get-chords-on-scale 
                            (car ll))))))

(defun tell-chords-on-scale (wn)
　　(tagbody
　　　　(format t "~%*** ~a ***"
                   (second (first wn)))
　　　　(format t "~%The original key is ~a."
                   (first (first wn)))
　　　　(format t "~%Enter a key.")
　　　　loop1
　　　　(setf l1 (read-sentence))
　　　　(if (not (key-p (car l1)))
　　　　　　(go loop1))
　　　　(if (equal (car l1) (first (first wn)))
　　　　　　(setf l2 (cdr wn))
　　　　　(setf l2 (modulate-key1-to-key2
                       (cdr wn)
                       (first (first wn))
                       (car l1))))
　　　　(format t "~%*** The key is ~a."
                  (car l1))
　　　　(tell-chords-on-scale-aux l2)))

(defun collect-chords-on-scales-of-CM7 ()
　　(remove-duplicate
　　　　(append (fget-i 'chords-on-scale
                        'CM7-ion-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'CM7-lyd-2))))

(defun collect-chords-on-scales-of-Cm7 ()
　　(remove-duplicate
　　　　(append (fget-i 'chords-on-scale
                        'Cm7-dor-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'Cm7-phr-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'Cm7-aeo-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'Cm7-n-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'Cm7-h-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'Cm7-m-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'Cm7-dor-2-2))))

(defun collect-chords-on-scales-of-Cm7-5 ()
　　(remove-duplicate
　　　　(append (fget-i 'chords-on-scale
                        'Cm7-5-loc-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'Cm7-5-loc+2-2))))

(defun collect-chords-on-scales-of-C7 ()
　　(remove-duplicate
　　　　(append (fget-i 'chords-on-scale
                        'C7-mix-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'C7-lyd-7-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'C7-hmp5-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'C7-mmp5-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'C7-alt-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'C7-comd-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'C7-wt-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'C7-mixsus4-2)
　　　　　　　　(fget-i 'chords-on-scale
                        'C7-mix-6-2))))

(defun collect-chords-on-scales-of-Cdim7 ()
　　(fget-i 'chords-on-scale 'Cdim7-dim))

;;;
;;; (collect-chords-on-scales "CM7")
;;;
(defun collect-chords-on-scales (chord)
　　(cond ((search-s1-in-s2 "m7-5" chord)
　　　　　 (modulate-key1-to-key2
             (collect-chords-on-scales-of-Cm7-5)
               'C
               (involve-atom-p chord)))
　　　　　((search-s1-in-s2 "dim" chord)
　　　　　 (modulate-key1-to-key2
             (collect-chords-on-scales-of-Cdim7)
               'C
               (involve-atom-p chord)))
　　　　　((search-s1-in-s2 "m7" chord)
　　　　　 (modulate-key1-to-key2
               (collect-chords-on-scales-of-Cm7)
               'C
               (involve-atom-p chord)))
　　　　　((search-s1-in-s2 "M7" chord)
　　　　　 (modulate-key1-to-key2
               (collect-chords-on-scales-of-CM7)
               'C
               (involve-atom-p chord)))
　　　　　((search-s1-in-s2 "7" chord)
　　　　　 (modulate-key1-to-key2
               (collect-chords-on-scales-of-C7)
               'C
               (involve-atom-p chord)))))

;;;
;;; (tell-chords-on-scales *w1*)
;;;
(defun tell-chords-on-scales-aux (l)
　　(let ((lst (collect-chords l)))
　　　(do ((ll lst (cdr ll)))
　　　　　((null ll))
　　　　(format t "~% ~a : ~a."
                   (car ll)
                   (collect-chords-on-scales 
                            (car ll))))))

(defun tell-chords-on-scales (wn)
　　(tagbody
　　　　(format t "~%*** ~a ***"
                   (second (first wn)))
　　　　(format t "~%The original key is ~a."
                   (first (first wn)))
　　　　(format t "~%Enter a key.")
　　　　loop1
　　　　(setf l1 (read-sentence))
　　　　(if (not (key-p (car l1)))
　　　　　　(go loop1))
　　　　(if (equal (car l1) (first (first wn)))
　　　　　　(setf l2 (cdr wn))
　　　　　(setf l2 (modulate-key1-to-key2
                       (cdr wn)
                       (first (first wn))
                       (car l1))))
　　　　(format t "~%*** The key is ~a."
                   (car l1))
　　　　(tell-chords-on-scales-aux l2)))