;;;
;;; c:\\program files\\acl62\\music6.cl
;;;
(load "c:\\program files\\acl62\\music5.cl")

;;;
;;; (get-elements-of-melody '("CM7" ion))
;;;
(defun get-elements-of-melody (l)
　　(append (get-guide-tone (car l)) (get-tension-note (involve-atom-p (car l)) (cadr l))))

(defun chord-scale (l)
　　(get-chordscale (involve-atom-p (car l)) (cadr l)))

(defun chord-tone (l)
　　(get-chord-tone (car l)))

(defun guide-tone (l)
　　(get-guide-tone (car l)))

(defun tension-note (l)
　　(get-tension-note (involve-atom-p (car l)) (cadr l)))

(defun UST (l)
　　(get-UST (car l)))

(defun function-of-chord (l)
　　(get-function-of-chord (intern (car l))))

;;;
;;; (interpret-a-pair-aux '("CM7" ion))
;;;
(defun interpret-a-pair-aux (l)
　　(format t "~% ***** ~a ***** について" l)
　　(format t "~% コードスケール ~a" (chord-scale l))
　　(format t "~% コード構成音 ~a" (chord-tone l))
　　(format t "~% テンションノート ~a" (tension-note l))
　　(format t "~% ガイドトーン ~a" (guide-tone l))
　　(format t "~% 旋律の要素 ~a" (get-elements-of-melody l))
　　(format t "~% 旋律例１ ~%~a ~a ~a ~a ~a"
　　　　(get-elements-of-melody-at-random l)
　　　　(get-elements-of-melody-at-random l)
　　　　(get-elements-of-melody-at-random l)
　　　　(get-elements-of-melody-at-random l)
　　　　(get-elements-of-melody-at-random l))
　　(format t "~% UST ~a" (UST l))
　　(format t "~% USTによる旋律例２ ~%~a ~%~a ~%~a ~%~a ~%~a"
　　　　(replace-UST-with-melody (assoc (second l) (UST l)))
　　　　(replace-UST-with-melody (assoc (second l) (UST l)))
　　　　(replace-UST-with-melody (assoc (second l) (UST l)))
　　　　(replace-UST-with-melody (assoc (second l) (UST l)))
　　　　(replace-UST-with-melody (assoc (second l) (UST l))))
　　(format t "~% スケールによる旋律例３ ~%~a ~%~a ~%~a ~%~a ~%~a ~%~a"
　　　　(make-a-phrase-with-scale-from-tension l)
　　　　(make-a-phrase-with-scale-from-tension l)
　　　　(make-a-phrase-with-scale-from-tension l)
　　　　(make-a-phrase-with-scale-from-elm l)
　　　　(make-a-phrase-with-scale-from-elm l)
　　　　(make-a-phrase-with-scale-from-elm l))
　　(values))

(defun interpret-a-pair (l)
　　(format t
　　　 "~%******************************************************************")
　　(format t "~%************* ~a **************" l)
　　(do ((lst l (cddr lst)))
　　　　　((null lst)) (interpret-a-pair-aux (list (first lst) (second lst)))
　　　　 (read-sentence)))

(defun interpret-pairs (l)
　　(do ((lst l (cdr lst)))
　　　　　((null lst))
　　　　(interpret-a-pair (car lst))))

(defun get-an-element-of-melody-at-random (l)
　　(let ((lst (get-elements-of-melody l)))
　　　　(nth (random (length lst)) lst)))

(defun get-UST-from-a-pair (l)
　　(cdr (second (assoc (second l) (get-UST (first l))))))

(defun get-a-note-from-UST-at-random (chord)
　　(let ((lst (get-chord-tone chord)))
　　　　(nth (random (length lst)) lst)))

(defun get-a-number-between-1-and-8 ()
　　(nth (random 8) '(1 2 3 4 5 6 7 8)))

(defun get-n-elements-of-melody (l n)
　　(do ((num n (1- num))
　　　　　(w))
　　　　((= num 0) w)
　　　(push (get-an-element-of-melody-at-random l) w)))

(defun get-elements-of-melody-at-random (l)
　　(get-n-elements-of-melody l (get-a-number-between-1-and-8)))

(defun get-n-notes-from-UST (chord n)
　　(do ((num n (1- num))
　　　　　(w))
　　　　((= num 0) w)
　　　(push (get-a-note-from-UST-at-random chord) w)))

(defun get-notes-from-UST-at-random (chord)
　　(get-n-notes-from-UST chord (get-a-number-between-1-and-8)))

(defun replace-UST-with-melody (l)
　　(cond ((null l) nil)
　　　　　　((stringp l) (get-notes-from-UST-at-random l))
　　　　　　((atom l) l)
　　　　　　(t
　　　　　　　(cons (replace-UST-with-melody (car l))
　　　　　　　　　　　(replace-UST-with-melody (cdr l))))))

(defun display-melody-of-UST (l)
　　(let ((lst (replace-UST-with-melody l)))
　　　(do ((l1 lst (cdr l1)))
　　　　　　((null l1))
　　　　(format t "~%~a" (car l1)))))

;;;
;;;
;;;
(defun translate-sound-to-number (s)
　　(cond ((equal s "ド") 1.0)
　　　　　　((or (equal s "#ド") (equal s "♭レ")) 1.5)
　　　　　　((equal s "レ") 2.0)
　　　　　　((or (equal s "#レ") (equal s "♭ミ")) 2.5)
　　　　　　((equal s "ミ") 3.0)
　　　　　　((equal s "ファ") 3.5)
　　　　　　((or (equal s "#ファ") (equal s "♭ソ")) 4.0)
　　　　　　((equal s "ソ") 4.5)
　　　　　　((or (equal s "#ソ") (equal s "♭ラ")) 5.0)
　　　　　　((equal s "ラ") 5.5)
　　　　　　((or (equal s "#ラ") (equal s "♭シ")) 6.0)
　　　　　　((equal s "シ") 6.5)))

;;;
;;; (get-position-of-a-note-in-a-scale-aux "ソ" '("CM7" ion))
;;;
(defun get-position-of-a-note-in-a-scale-aux (note pair)
　　(let* ((key (involve-atom-p (first pair)))
　　　　　　(scale (butlast (get-chordscale key (second pair))))
　　　　　　(num1 (translate-sound-to-number note))
　　　　　　(num (if (null num1) 1 num1))
　　　　　　(position (get-position-of-an-element note scale)))
　　　(if (not (null position))
　　　　　(1- position)
　　　　(do ((i (+ 0.5 num) (+ i 0.5)))
　　　　　　　((= i 15.0))
　　　　　(let ((j (get-position-of-an-element
　　　　　　　　　　(translate-number-to-sound i 0.0 (involve-atom-p (first pair)))
　　　　　　　　　　scale)))
　　　　　　(cond ((not (null j))
　　　　　　　　　　　(return (- j 2)))))))))

;;;
;;; (get-position-of-a-note-in-a-scale "ソ" '("CM7" ion))
;;;
(defun get-position-of-a-note-in-a-scale (note pair)
　　(let ((num (get-position-of-a-note-in-a-scale-aux note pair)))
　　　　(if (>= num 0)
　　　　　　num
　　　　　(+ num (length (get-chordscale
　　　　　　　　　　　　　　　　(involve-atom-p (first pair))
　　　　　　　　　　　　　　　　(second pair)))))))

;;;
;;; (rotate-a-scale-left-from-a-note "ソ" '("CM7" ion))
;;;
(defun rotate-a-scale-left-from-a-note (note pair)
　　(let* ((key (involve-atom-p (first pair)))
　　　　　　(scale (butlast (get-chordscale key (second pair))))
　　　　　　(position (get-position-of-a-note-in-a-scale note pair))
　　　　　　(lst (rotate-list-left scale position)))
　　　　(append lst (list (car lst)))))

(defun rotate-a-scale-right-from-a-note (note pair)
　　(reverse (rotate-a-scale-left-from-a-note note pair)))

;;;
;;; (rotate-a-scale-from-a-note "ソ" '("CM7" ion) 'left)
;;;
(defun rotate-a-scale-from-a-note (note pair direction)
　　(if (equal direction 'left)
　　　　(rotate-a-scale-left-from-a-note note pair)
　　　(rotate-a-scale-right-from-a-note note pair)))

;;;
;;; (get-a-tension-note-at-random '("CM7" ion))
;;;
(defun get-a-tension-note-at-random (pair)
　　(let ((lst (get-tension-note (involve-atom-p (first pair)) (second pair))))
　　　　(nth (random (length lst)) lst)))

;;; (get-an-element-of-melody-at-random '("CM7" ion))

(defun rotate-a-scale-from-tension-left-or-right (pair)
　　(case (random 2)
　　　　(0 (rotate-a-scale-left-from-a-note (get-a-tension-note-at-random pair) pair))
　　　　(1 (rotate-a-scale-right-from-a-note (get-a-tension-note-at-random pair) pair))))

(defun rotate-a-scale-from-elm-left-or-right (pair)
　　(case (random 2)
　　　　(0 (rotate-a-scale-left-from-a-note (get-an-element-of-melody-at-random pair) pair))
　　　　(1 (rotate-a-scale-right-from-a-note (get-an-element-of-melody-at-random pair)　pair))))

;;;
;;; (get-notes-around-a-note-in-a-scale "ソ" '("CM7" ion))
;;;
(defun get-notes-around-a-note-in-a-scale (note pair)
　　(let ((lst-r (rotate-a-scale-right-from-a-note note pair))
　　　　　(lst-l (rotate-a-scale-left-from-a-note note pair))
　　　　　(pos (get-position-of-a-note-in-a-scale-aux note pair)))
　　　　(append (list (cond ((member note lst-r :test #'equal)
　　　　　　　　　　　　　　　　　(second lst-r))
　　　　　　　　　　　　　　　　　((< pos 0) (second lst-r))
　　　　　　　　　　　　　　　　　(t
　　　　　　　　　　　　　　　　　　(first lst-r))))
　　　　　　　　　　(if (member note lst-r :test #'equal)
　　　　　　　　　　　　(list note)
　　　　　　　　　　　nil)
　　　　　　　　　　(list (cond ((member note lst-l :test #'equal)
　　　　　　　　　　　　　　　　　　(second lst-l))
　　　　　　　　　　　　　　　　　((< pos 0)
　　　　　　　　　　　　　　　　　　(first lst-l))
　　　　　　　　　　　　　　　　　(t
　　　　　　　　　　　　　　　　　　(second lst-l)))))))

(defun get-a-note-around-a-note-in-a-scale (note pair)
　　(let ((lst (get-notes-around-a-note-in-a-scale note pair)))
　　　　(case (random 3)
　　　　　　(0 (first lst))
　　　　　　(1 (second lst))
　　　　　　(2 (third lst)))))

;;;
;;;
;;;
(defun rotate-a-scale-from-a-note-left-or-right (note pair)
　　(case (random 2)
　　　　(0 (rotate-a-scale-left-from-a-note note pair))
　　　　(1 (rotate-a-scale-right-from-a-note note pair))))

(defun rotate-a-scale-from-a-note-and-cut (note pair)
　　(let ((lst (rotate-a-scale-from-a-note-left-or-right note pair)))
　　　　(cut-list-at-length (nth (random 8) '(1 2 3 4 5 6 7 8)) lst)))

(defun rotate-a-scale-from-tension-and-cut (pair)
　　(let ((lst (rotate-a-scale-from-tension-left-or-right pair)))
　　　　(cut-list-at-length (nth (random 8) '(1 2 3 4 5 6 7 8)) lst)))

(defun rotate-a-scale-from-elm-and-cut (pair)
　　(let ((lst (rotate-a-scale-from-elm-left-or-right pair)))
　　　　(cut-list-at-length (nth (random 8) '(1 2 3 4 5 6 7 8)) lst)))

;;;
;;;
;;;
(defun make-a-phrase-with-scale-from-tension (pair)
　　(do ((i 8 (1- i))
　　　　　(w (rotate-a-scale-from-tension-and-cut pair)))
　　　　((or (= i 0) (> (length w) 8))
　　　(cut-list-at-length (nth (random 8) '(1 2 3 4 5 6 7 8)) w))
　　(setf w (append w
　　　　　　　　　　　　(rotate-a-scale-from-a-note-and-cut
　　　　　　　　　　　　(get-a-note-around-a-note-in-a-scale (car (last w)) pair)
　　　　　　　　　　　　pair)))))

(defun make-a-phrase-with-scale-from-elm (pair)
　　(do ((i 8 (1- i))
　　　　　(w (rotate-a-scale-from-elm-and-cut pair)))
　　　　((or (= i 0) (> (length w) 8))
　　　(cut-list-at-length (nth (random 8) '(1 2 3 4 5 6 7 8)) w))
　　(setf w (append w
　　　　　　　　　　　　(rotate-a-scale-from-a-note-and-cut
　　　　　　　　　　　　(get-a-note-around-a-note-in-a-scale (car (last w)) pair)
　　　　　　　　　　　　pair)))))