;;;
;;; c:\\program files\\acl62\\music43.cl
;;;
(defun make-O ()
　　(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 (doremi)
　　(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)))

(defun confine-a-number-2 (n)
　　(cond ((>= n 7.0) (- n 6.0))
　　　　　((<= n 0.5) (+ n 6.0))
　　　　　(t n)))

(defun translate-number-to-doremi (n)
　　(let ((num (confine-a-number-2 
                 (confine-a-number-2 n))))
　　　(case num
　　　　　(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 'si))))

(defun up-a-note (doremi n)
　　(let* ((num (translate-doremi-to-number
                      doremi))
　　　　　 (nn (+ num n)))
　　　 (translate-number-to-doremi nn)))

(defun down-a-note (doremi n)
　　(let* ((num (translate-doremi-to-number
                       doremi))
　　　　　 (nn (- num n)))
　　　(translate-number-to-doremi nn)))

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

;;;
;;; c:\\program files\\acl62\\music48.cl
;;;
(defun get-4-kinds-of-note-series ()
　　(let* ((l1 (make-O))
　　　　 　(l2 (make-R l1))
　　　　 　(l3 (make-I l1))
　　　　 　(l4 (make-IR l1)))
　　　　(list `(O ,l1) `(R ,l2) `(I ,l3) `(IR ,l4))))

(defun get-note-series (n)
　　(let* ((l (get-4-kinds-of-note-series))
　　　　　 (l1 (list (first l))))
　　　(do ((nn (1- n) (1- nn))
　　　　　 (w))
　　　　　((<= nn 0) (append l1 (reverse w)))
　　　　(let ((kind (nth (random 4) '(O R I IR))))
　　　　　 (push (assoc kind l) w)))))

(defun get-and-squash-note-series (n)
　　(let ((l (get-note-series n)))
　　　(list (mapcar #'first l) 
            (mapcar #'second l))))

(defun get-and-squash-note-series-2 (n)
　　(let ((l (get-note-series n)))
　　　(list (mapcar #'first l)
            (squash (mapcar #'second l)))))

(defun get-2-part-from-list (lst)
　　(do ((l lst (cddr l))
　　　　 (w))
　　　　((null l) (reverse w))
　　　(push (list (first l) (second l)) w)))

(defun get-3-part-from-list (lst)
　　(do ((l lst (cdddr l))
　　　　 (w))
　　　　((null l) (reverse w))
　　　(push (list (first l) (second l) 
                  (third l))
             w)))

(defun get-4-part-from-list (lst)
　　(do ((l lst (cddddr l))
　　　 　(w))
　　　　((null l) (reverse w))
　　　　(push (list (first l) (second l) 
                    (third l) (fourth l))
               w)))

(defun get-6-part-from-list (lst)
　　(do ((l lst (cddr (cddddr l)))
　　　 　(w))
　　　　((null l) (reverse w))
　　　(push (list (first l) (second l)
                  (third l) (fourth l)
                  (fifth l) (sixth l))
             w)))

(defun get-part-from-list-at-random (lst)
　　(let ((n (random 4)))
　　　(case n
　　　　(0 (get-2-part-from-list lst))
　　　　(1 (get-3-part-from-list lst))
　　　　(2 (get-4-part-from-list lst))
　　　　(3 lst))))

(defun auto-comp-twelve (n)
　　(let* ((l1 (get-note-series n))
　　　　　 (l2 (mapcar #'first l1))
　　　　　 (l3 (mapcar #'second l1)))
　　　(do ((ll1 l2 (cdr ll1))
　　　 　　(ll2 l3 (cdr ll2))
　　　 　　(w))
　　　　　((null ll1) (reverse w))
　　　　(let ((l4 (car ll1))
　　　　　　　(l5 (get-part-from-list-at-random
                          (car ll2))))
　　　　　　　(format t "~% ~a : ~a." l4 l5)
　　　　　　　(push (list l4 l5) w)))))