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

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

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

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

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

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

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

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

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