;;;
;;; c:\\program files\\acl62\\music18.cl
;;;
(load "c:\\program files\\acl62\\music17.cl")

(defun floor-n-at-m (n m)
　　(do ((nn 0 (1+ nn))
　　　　　(w))
　　　　　((>= nn n) (mapcar #'(lambda (e) (floor e m)) (reverse w)))
　　　　(push nn w)))

(defun floor-list-at-m (lst m)
　　(floor-n-at-m (length lst) m))

(defun append-floor (lst n)
　　(do ((l1 (floor-list-at-m lst n) (cdr l1))
　　　　　(l2 lst (cdr l2))
　　　　　(w))
　　　　　((null l1) (reverse w))
　　　　(push (list (car l1) (car l2)) w)))

(defun last-of-floor (lst n)
　　(car (last (floor-list-at-m lst n))))

(defun fetch-n-part-of-lst (lst n)
　　(do ((l lst (cdr l))
　　　　　(w))
　　　　　((null l) (reverse w))
　　　　(if (= (first (car l)) n)
　　　　　　(push (second (car l)) w))))

(defun divide-into-n-parts (lst n)
　　(do ((max (last-of-floor lst n))
　　　　　(l (append-floor lst n) (cdr l))
　　　　　(n 0 (1+ n))
　　　　　(w))
　　　　　((= n (1+ max)) (reverse w))
　　　　(push (fetch-n-part-of-lst l n) w)))

;;;
;;;
;;;
(defun fold-list-at-n (lst n)
　　(divide-into-n-parts lst n))

(defun show-list-at-n-fold (lst n)
　　(do ((l (fold-list-at-n lst n) (cdr l)))
　　　　　((null l))
　　　　(format t "~%~a" (car l))))

;;;
;;;
;;;
(defun tell-a-pair-1 (pair)
　　(format t "~% トライアッド")
　　(show-list-at-n-fold (get-triads pair) 4)
　　(format t "~% 7thコード")
　　(show-list-at-n-fold (get-chords-from-scale pair) 4)
　　(format t "~% ４度重ね３和音")
　　(show-list-at-n-fold (4th-interval-triads pair) 4)
　　(format t "~% ４度重ね４和音")
　　(show-list-at-n-fold (4th-interval-chords pair) 4))

(defun tell-a-pair-2 (pair)
　　(format t "~%Scale ~a" (chord-scale pair))
　　(format t "~%3rd-interval ~a" (3rd-interval pair))
　　(format t "~%4th-interval ~a" (4th-interval pair))
　　(format t "~%5th-interval ~a" (5th-interval pair))
　　(format t "~%6th-interval ~a" (6th-interval pair))
　　(format t "~%7th-interval ~a" (7th-interval pair)))

(defun tell-a-pair-3 (pair)
　　(tell-a-chord (car pair)))

(defun tell-a-pair-4 (pair)
　　(format t "~%drop2 ~a" (drop2 (car pair)))
　　(format t "~%drop3 ~a" (drop3 (car pair)))
　　(format t "~%drop2&4 ~a" (drop2&4 (car pair)))
　　(format t "~%drop1&4 ~a" (drop1&4 (car pair))))

(defun tell-a-pair-5 (pair)
　　(format t "~%Recommended drop ~a" (get-a-drop (car pair))))

;;;
;;; (tell-a-pair-aux '("G7" alt)
;;;
(defun tell-a-pair-aux (pair)
　　(tell-a-pair-1 pair)
　　(tell-a-pair-2 pair)
　　(tell-a-pair-3 pair)
　　(tell-a-pair-4 pair)
　　(tell-a-pair-5 pair))

(defun tell-a-pair (l)
　　(do ((lst l (cddr lst)))
　　　　　((null lst))
　　　　(read-sentence)
　　　　(format t "~%********** On ~a **********" (list (first lst) (second lst)))
　　　　(tell-a-pair-aux (list (first lst) (second lst)))))

(defun tell-pairs-aux (l)
　　(do ((lst l (cdr lst)))
　　　　　((null lst))
　　　　　(tell-a-pair (car lst))))

(defun tell-pairs (wn)
　　(tagbody
　　　(my-randomize)
　　　(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-pairs-aux l2))