;;;
;;; c:\\program files\\acl62\\music43.cl
;;;
(load "c:\\program files\\acl62\\music42.cl")

(defun make-O ()
　　(my-randomize)
　　(let ((lst '(do +do re +re mi fa +fa so +so la +la si)))
　　　(do ((l lst)
　　　　　　(w))
　　　　　　((null l) (reverse w))
　　　　　(let ((note (nth (random (length l)) l)))
　　　　　　(push note w)
　　　　　　(setf l (remove note l))))))

(defun translate-doremi-to-number-from-start (start doremi)
　(case start
　　　(do (case doremi
　　　　　　　(do 1.0)(+do 1.5)(re 2.0)(+re 2.5)(mi 3.0)(fa 3.5)(+fa 4.0)(so 4.5)(+so 5.0)(la 5.5)(+la 6.0)(si 6.5)))
　　　(+do (case doremi
　　　　　　　(+do 1.0)(re 1.5)(+re 2.0)(mi 2.5)(fa 3.0)(+fa 3.5)(so 4.0)(+so 4.5)(la 5.0)(+la 5.5)(si 6.0)(do 6.5)))
　　　(re (case doremi
　　　　　　　(re 1.0)(+re 1.5)(mi 2.0)(fa 2.5)(+fa 3.0)(so 3.5)(+so 4.0)(la 4.5)(+la 5.0)(si 5.5)(do 6.0)(+do 6.5)))
　　　(+re (case doremi
　　　　　　　(+re 1.0)(mi 1.5)(fa 2.0)(+fa 2.5)(so 3.0)(+so 3.5)(la 4.0)(+la 4.5)(si 5.0)(do 5.5)(+do 6.0)(re 6.5)))
　　　(mi (case doremi
　　　　　　　(mi 1.0)(fa 1.5)(+fa 2.0)(so 2.5)(+so 3.0)(la 3.5)(+la 4.0)(si 4.5)(do 5.0)(+do 5.5)(re 6.0)(+re 6.5)))
　　　(fa (case doremi
　　　　　　　(fa 1.0)(+fa 1.5)(so 2.0)(+so 2.5)(la 3.0)(+la 3.5)(si 4.0)(do 4.5)(+do 5.0)(re 5.5)(+re 6.0)(mi 6.5)))
　　　(+fa (case doremi
　　　　　　　(+fa 1.0)(so 1.5)(+so 2.0)(la 2.5)(+la 3.0)(si 3.5)(do 4.0)(+do 4.5)(re 5.0)(+re 5.5)(mi 6.0)(fa 6.5)))
　　　(so (case doremi
　　　　　　　(so 1.0)(+so 1.5)(la 2.0)(+la 2.5)(si 3.0)(do 3.5)(+do 4.0)(re 4.5)(+re 5.0)(mi 5.5)(fa 6.0)(+fa 6.5)))
　　　(+so (case doremi
　　　　　　　(+so 1.0)(la 1.5)(+la 2.0)(si 2.5)(do 3.0)(+do 3.5)(re 4.0)(+re 4.5)(mi 5.0)(fa 5.5)(+fa 6.0)(so 6.5)))
　　　(la (case doremi
　　　　　　　(la 1.0)(+la 1.5)(si 2.0)(do 2.5)(+do 3.0)(re 3.5)(+re 4.0)(mi 4.5)(fa 5.0)(+fa 5.5)(so 6.0)(+so 6.5)))
　　　(+la (case doremi
　　　　　　　(+la 1.0)(si 1.5)(do 2.0)(+do 2.5)(re 3.0)(+re 3.5)(mi 4.0)(fa 4.5)(+fa 5.0)(so 5.5)(+so 6.0)(la 6.5)))
　　　(si (case doremi
　　　　　　　(si 1.0)(do 1.5)(+do 2.0)(re 2.5)(+re 3.0)(mi 3.5)(fa 4.0)(+fa 4.5)(so 5.0)(+so 5.5)(la 6.0)(+la 6.5)))))

(defun translate-flat-to-sharp-on-a-note (note)
　　(case note
　　　　(do 'do)
　　　　(+do '+do)
　　　　(-re '+do)
　　　　(re 're)
　　　　(+re '+re)
　　　　(-mi '+re)
　　　　(mi 'mi)
　　　　(fa 'fa)
　　　　(+fa '+fa)
　　　　(so 'so)
　　　　(+so '+so)
　　　　(-la '+so)
　　　　(la 'la)
　　　　(+la '+la)
　　　　(-si '+la)
　　　　(si 'si)))

(defun distance-from-n1-to-n2 (n1 n2)
　　(let ((nn1 (translate-flat-to-sharp-on-a-note n1))
　　　　　(nn2 (translate-flat-to-sharp-on-a-note n2)))
　　　　(let ((num (- (translate-doremi-to-number-from-start nn1 nn2) 1.0)))
　　　　　　(list (list nn1 nn2) (list 'down (- 6.0 num)) (list 'up num)))))

(defun make-distance-from-list (lst)
　　(do ((ll lst (cdr ll))
　　　　　(w))
　　　　　((null (cdr ll)) (reverse w))
　　　　(push (distance-from-n1-to-n2 (first ll) (second ll)) w)))

(defun get-up-degrees (lst)
　　(mapcar #'second (mapcar #'second lst)))

(defun make-I-aux-2 (lst)
　　(do ((ll (second lst) (cdr ll))
　　　　　(w1 (car lst))
　　　　　(w2))
　　　　　((null ll) (reverse w2))
　　　　(setf w1 (up-a-note (translate-flat-to-sharp-on-a-note w1) (car ll)))
　　　　(push w1 w2)))

(defun make-I-aux-3 (lst)
　　(cons (car lst) (make-I-aux-2 lst)))

(defun make-I (lst)
　　(let* ((l1 (make-distance-from-list lst))
　　　　　　(l2 (get-up-degrees l1))
　　　　　　(l3 (make-I-aux-2 (list (car lst) l2))))
　　　　(cons (car lst) l3)))

(defun make-R (lst) (reverse lst))

(defun make-IR (lst) (reverse (make-I lst)))

;;;
;;; ４種類の音列の生成（十二音技法の基礎）
;;;
(defun make-4-kinds-of-notes-series ()
　　(let* ((l1 (make-O))
　　　　　　(l2 (make-R l1))
　　　　　　(l3 (make-I l1))
　　　　　　(l4 (make-IR l1)))
　　　　(format t "~%基本形 O (Original) :~a." l1)
　　　　(format t "~%逆行形 R (Retrograde) :~a." l2)
　　　　(format t "~%反行形 I (Inversion) :~a." l3)
　　　　(format t "~%反行逆行形 IR (Inversion+Retrogade):~a." l4)))