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

(make-frame-from-list
　'(triads-on-scale
　　(CM7-ion (value "C" "Dm" "Em" "F"
                    "G" "Am" "Bm-5" "Bdim"))
　　(Cm7-dor (value "Cm" "Dm" "-E" "F"
                    "Gm" "Am-5" "Adim"
                    "-B"))
　　(Cm7-phr (value "Cm" "-D" "-E" "Fm"
                    "Gm-5" "Gdim" "-A"
                    "-Bm"))
　　(CM7-lyd (value "C" "D" "Em" "-Gm-5"
                    "-Gdim" "G" "Am" "Bm"))
　　(C7-mix (value "C" "Dm" "Em-5" "Edim"
                   "F" "Gm" "Am" "-B"))
　　(Cm7-aeo (value "Cm" "Dm-5" "Ddim" "-E"
                    "Fm" "Gm" "-A" "-B"))
　　(Cm7-5-loc (value "Cm-5" "Cdim" "-D"
                      "-Em" "Fm" "-G" "-A"
                      "-Bm"))
　　(Cm7-n (value "Cm" "Dm-5" "Ddim" "-E"
                  "Fm" "Gm" "-A" "-B"))
　　(Cm7-h (value "Cm" "Dm-5" "Ddim"
                  "-Eaug" "Fm" "G"
                  "-A" "Bm-5" "Bdim"))
　　(Cm7-m (value "Cm" "Dm" "-Eaug" "F"
                  "G" "Am-5" "Adim"
                  "Bm-5" "Bdim"
　　　　　　　　　"-B" "-A" "Gm" "Fm"
                  "-E" "Dm-5" "Ddim"
                  "Cm"))
　　(Cm7-dor-2 (value "Cm" "-Daug" "-E"
                       "F" "Gm-5" "Gdim"
                      "Am-5" "Adim" "-Bm"))
　　(Cm7-5-loc+2 (value "Cm-5" "Cdim" "Dm-5"
                        "Ddim" "-Em" "Fm"
                        "-Gaug" "-A" "-B"))
　　(C7-lyd-7 (value "C" "D" "Em-5" "Edim"
                     "-Gm-5" "-Gdim" "Gm"
                     "Am" "-Baug"))
　　(C7-hmp5 (value "-A6" "-Dm-5" "-Ddim"
                    "-Am6" "Em-5" "Edim"
                    "Fm" "Gm-5" "Gdim" 
                    "-A" "-Bm-5" "-Bdim"))
　　(C7-mmp5 (value "C" "Dm-5" "Ddim"
                    "Em-5" "Edim" "Fm"
                    "Gm" "-Aaug" "-B"))
　　(C7-alt (value "Cm-5" "Cdim" "-Dm"
                   "-Em" "Eaug" "-G" "-A"
                   "-Bm-5" "-Bdim"))
　　(C7-comd (value "Cm-5" "Cdim" "-Dm-5"
                    "-Ddim" "-Em-5"
                    "-Edim" "Em-5" "Edim"
                    "-Gm-5" "-Gdim" "Gm-5"
                    "Gdim" "Am-5" "Adim"
                    "-Bm-5" "-Bdim"))
　　(Cdim7-dim (value "Cm-5" "Cdim" "Dm-5"
                      "Ddim" "-Em-5"
                      "-Edim" "Fm-5"
                      "Fdim" "-Gm-5"
                      "-Gdim""-Am-5"
                      "-Adim" "Am-5"
                      "Adim" "Bm-5"
                      "Bdim"))
　　(C7-wt (value "Caug" "Daug" "Eaug"
                  "-Gaug" "-Aaug" "-Baug"))
　　(C7-mixsus4 (value "C" "Dm" "Em-5"
                       "Edim" "F" "Gm"
                       "Am" "-B"))
　　(C7-mix-6 (value "C" "Dm-5" "Ddim"
                     "Em-5" "Edim" "Fm"
                     "Gm" "-Aaug" "-B"))))

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

;;;
;;; (tell-triads-on-scale *w1*)
;;;
(defun collect-pairs-aux (lst)
　　(do ((l lst (cddr l))
　　　　　(w))
　　　　　((null l) (reverse w))
　　　　(push (list (first l) (second l)) w)))

(defun collect-pairs (lst)
　　(remove-duplicate
         (collect-pairs-aux (squash lst))))

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

(defun tell-triads-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-triads-on-scale-aux l2)))