(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))