;;;
;;; c:\\program files\\acl62\\music33.cl
;;;
(load "c:\\program files\\acl62\\music32.cl")

;;;
;;; (get-UST-from-a-pair '("CM7" ion))
;;;
(defun get-UST-from-a-pair-2 (pair)
　　(list (first pair) (assoc (second pair) (get-UST (first pair)))))

;;;
;;; (get-UST-from-pairs-aux '("Dm7" dor "G7" alt "CM7" ion))
;;;
(defun get-UST-from-pairs-aux (pairs)
　　(do ((lst pairs (cddr lst)) (w))
　　　　　((null lst) (reverse w))
　　　　(push (get-UST-from-a-pair-2 (list (first lst) (second lst))) w)))

(defun get-UST-from-pairs-aux-2 (pairs)
　　(do ((lst pairs (cddr lst)) (w))
　　　　　((null lst) (reverse w))
　　　　(push (list (first lst) (get-UST (first lst))) w)))

;;;
;;; (get-UST-from-pairs '(("CM7" ion "A7" hmp5) ("Dm7" dor "G7" alt) ("CM7" ion)))
;;;
(defun get-UST-from-pairs (pairs)
　　(do ((lst pairs (cdr lst)))
　　　　　((null lst))
　　　　(print '***************************************************)
　　　　(print (car lst))
　　　　(print (get-UST-from-pairs-aux (car lst)))))

(defun get-UST-from-pairs-2 (pairs)
　　(do ((lst pairs (cdr lst)))
　　　　　((null lst))
　　　　(print '***************************************************)
　　　　(print (car lst))
　　　　(print (get-UST-from-pairs-aux-2 (car lst)))))

;;;
;;; (indicate-UST *w1*)
;;;
(defun indicate-UST (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))
　　(get-UST-from-pairs l2)))

(defun indicate-UST-2 (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))
　　(get-UST-from-pairs-2 l2)))