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