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

(defun measure-an-interval-of-two-notes-upward (s1 s2)
　　(let ((n1 (translate-sound-to-number s1))
　　　　　(n2 (translate-sound-to-number s2)))
　　　(if (<= n1 n2)
　　　　　(- n2 n1)
　　　　(- (+ n2 6.0) n1))))

(defun measure-an-interval-of-two-notes-downward (s1 s2)
　　(measure-an-interval-of-two-notes-upward s2 s1))

(defun relation-of-two-notes (n1 n2)
　　(let ((u (measure-an-interval-of-two-notes-upward n1 n2))
　　　　　(d (measure-an-interval-of-two-notes-downward n1 n2)))
　　　　(cond ((< u d) (list 'upward u))
　　　　　　　　((> u d) (list 'downward d))
　　　　　　　　((or (= u 3.0) (= d 3.0))
　　　　　　　　　(case (random 2)
　　　　　　　　　　　(0 (list 'upward u))
　　　　　　　　　　　(1 (list 'downward d))))
　　　　　　　　((and (= 0.0 u) (= 0.0 d)) '(same-note)))))

;;;
;;; (get-passing-note '("CM7" ion) "ミ" "ソ")) ===> ファ
;;;
(defun get-passing-note (pair n1 n2)
　　(let* ((scale (get-chordscale (involve-character-p (first pair))
　　　　　　　　　　　　　　　　　　　　　(second pair)))
　　　　　　(relation (relation-of-two-notes n1 n2))
　　　　　　(direction (first relation))
　　　　　　(distance (second relation))
　　　　　　(num1 (translate-sound-to-number n1))
　　　　　　(num2 (translate-sound-to-number n2)))
　　　　(case direction
　　　　　　(upward
　　　　　　　(cond ((> distance 2.0) (values))
　　　　　　　　　　　((= 0.5 distance) (values))
　　　　　　　　　　　((= 1.0 distance)
　　　　　　　　　　　　(translate-number-to-sound num1 0.5 (involve-character-p (first pair))))
　　　　　　　　　　　(t
　　　　　　　　　　　　(second (rotate-a-scale-from-a-note n1 pair 'left)))))
　　　　　　(downward
　　　　　　　(cond ((> distance 2.0) (values))
　　　　　　　　　　　((= 0.5 distance) (values))
　　　　　　　　　　　((= 1.0 distance)
　　　　　　　　　　　　(translate-number-to-sound num1 5.5 (involve-character-p (first pair))))
　　　　　　　　　　　(t
　　　　　　　　　　　　(second (rotate-a-scale-from-a-note n1 pair 'right))))))))

;;;
;;;
;;;
(defun get-auxiliary-note (pair n1 n2)
　　(let* ((scale (get-chordscale (involve-character-p (first pair)) (second pair)))
　　　　　　(num1 (translate-sound-to-number n1))
　　　　　　(num2 (translate-sound-to-number n2))
　　　　　　(base (involve-character-p (first pair)))
　　　　　　(l1 (translate-number-to-sound num1 5.0 base))
　　　　　　(l2 (translate-number-to-sound num1 5.5 base))
　　　　　　(u1 (translate-number-to-sound num1 0.5 base))
　　　　　　(u2 (translate-number-to-sound num1 1.0 base)))
　　　　(cond ((not (= num1 num2)) (values))
　　　　　　　　(t
　　　　　　　　　(cond ((and (member l2 scale :test #'equal) (member u1 scale :test #'equal))
　　　　　　　　　　　　　　(list (list 'downward l2) (list 'upward u1)))
　　　　　　　　　　　　　((and (member l2 scale :test #'equal) (not (member u1 scale :test #'equal)))
　　　　　　　　　　　　　　(list (list 'downward l2) (list 'upward u1 u2)))
　　　　　　　　　　　　　((and (not (member l2 scale :test #'equal)) (member u1 scale :test #'equal))
　　　　　　　　　　　　　　(list (list 'downward l1 l2) (list 'upward u1)))
　　　　　　　　　　　　　((and (not (member l2 scale :test #'equal)) (not (member u1 scale :test #'equal)))
　　　　　　　　　　　　　　(list (list 'downward l1 l2) (list 'upward u1 u2))))))))

(defun select-an-auxiliary-note (pair n1 n2)
　　(let* ((lst (get-auxiliary-note pair n1 n2))
　　　　　　(a-n (append (rest (first lst)) (rest (second lst)))))
　　　　(if (not a-n)
　　　　　　(values)
　　　　　(nth (random (length a-n)) a-n))))

;;;
;;; (connect-notes-in-a-chord '(("CM7" ion) ("ミ" "ソ" "シ" "ド")))
;;;
(defun connect-notes-in-a-chord (l)
　　(let ((scale (first l))
　　　　　(phrase (second l)))
　　　(do ((lst phrase (rest lst))
　　　　　　(w)
　　　　　　(sp)
　　　　　　(sa))
　　　　　　((null (rest lst))
　　　　　　　(push (car lst) w)
　　　　　　　(list scale (reverse w)))
　　　　　(push (first lst) w)
　　　　　(setf sp (get-passing-note scale (first lst) (second lst)))
　　　　　(setf sa (select-an-auxiliary-note scale (first lst) (second lst)))
　　　　　(if (not (null sp)) (push sp w))
　　　　　(if (not (null sa)) (push sa w)))))

(defun connect-notes-in-a-chord-partially (l)
　　(let ((scale (first l))
　　　　　(phrase (second l)))
　　　(do ((lst phrase (rest lst))
　　　　　　(w)
　　　　　　(sp)
　　　　　　(sa))
　　　　　　((null (rest lst))
　　　　　　　(push (car lst) w)
　　　　　　　(list scale (reverse w)))
　　　　　(push (first lst) w)
　　　　　(case (random 2)
　　　　　　　(0
　　　　　　　　(setf sp (get-passing-note scale (first lst) (second lst)))
　　　　　　　　(setf sa (select-an-auxiliary-note scale (first lst) (second lst))))
　　　　　　　(1
　　　　　　　　(setf sp nil)
　　　　　　　　(setf sa nil)))
　　　　　(if (not (null sp)) (push sp w))
　　　　　(if (not (null sa)) (push sa w)))))