;;;
;;; c:\\program files\\acl62\\music39.cl
;;;
(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)))