自動作曲その他音楽情報処理１
(defun fget (frame slot facet)
(cdr (assoc facet (cdr (assoc slot (cdr (get frame 'frame)))))))
(putprop 'Henry
'(Henry (a-kind-of (value man))
(height (value 1.78))
(weight (value 75))
(hobies (value jogging skiing))
(licence (if-needed ask answer))
(occupation (value teaching research)))
'frame)
(defun extend (key a-list)
(cond ((assoc key (cdr a-list)))
(t
(cadr (rplacd (last a-list) (list (list key)))))))
(defun follow-path (path a-list)
(cond ((null path) a-list)
(t
(follow-path (cdr path) (extend (car path) a-list)))))
(defun fget-frame (frame)
(cond ((get frame 'frame))
(t
(setf (get frame 'frame) (list frame)))))
(defun fput (frame slot facet value)
(let ((value-list (follow-path (list slot facet) (fget-frame frame))))
(cond ((member value value-list :test #'equal) nil)
(t
(rplacd (last value-list) (list value)) value))))
(defun fremove (frame slot facet value)
(let ((value-list (follow-path (list slot facet) (fget-frame frame))))
(cond ((member value value-list :test #'equal)
(delete value value-list :test #'equal)
t)
(t nil))))
(defun fcheck (frame slot facet value)
(cond ((member value (fget frame slot facet) :test #'equal) t)
(t nil)))
(defun fclamp (frame1 frame2 slot)
(rplacd (fget-frame frame1)
(list (follow-path (list slot) (fget-frame frame2))))
slot)
(defun fget-v-d (frame slot)
(cond ((fget frame slot 'value))
((fget frame slot 'default))))
(defun fget-v-d-p (frame slot)
(cond ((fget frame slot 'value))
((fget frame slot 'default))
(t
(mapcan
#'(lambda (demon) (fucall demon frame slot))
(fget frame slot 'if-needed)))))
(defun ask (frame slot)
(print `(Please supply a value for the
,slot slot in the
,frame frame))
(terpri)
(let ((response (read)))
(cond (response (list response))
(t nil))))
(defun answer (&rest l)
(print '(It has been abswered)))
(setf *print-length* 200)
(setf *print-level* 6)
(defun caluculate-weight (frame slot)
(let ((heigh (fget-v-d frame 'height)))
(cond (height (list (fput frame
'weight
'value
(* 33 (car height))))))))
(putprop 'man
'(man (a-kind-of (value human))
(hobbies (if-removed report report) (value music reading))
(height (if-added caluculate-weight)))
'frame)
(putprop 'human
'(human (a-kind-of (value being))
(place (value earth)))
'frame)
(defun report (&rest l)
(print '(The data has been removed)))
;;;
;;; (fget-classes 'Henry)===>(Henry man human being)
;;;
(defun fget-classes (start)
(reverse (fget-classes1 (list start) nil)))
(defun fget-classes1 (queue classes)
(cond ((null queue) classes)
(t
(fget-classes1
;;;
(append (fget (car queue) 'a-kind-of 'value)
(cdr queue))
;;;
(cond ((member (car queue) classes)
classes)
(t
(cons (car queue) classes)))))))
;;;
;;; I-inheritannce
;;;
(defun fget-i (frame slot)
(fget-i1 (fget-classes frame) slot))
(defun fget-i1 (frames slot)
(cond ((null frames) nil)
((fget (car frames) slot 'value))
(t
(fget-i1 (cdr frames) slot))))
;;;
;;; Z-inheritannce
;;;
(defun fget-z (frame slot)
(fget-z1 slot (fget-calasses frame)))
(defun fget-z1 (slot classes)
(cond ((null classes) nil)
((fget-v-d-p (car classes) slot))
(t
(fget-z1 slot (cdr classes)))))
;;;
;;; N-inheritance
;;;
(defun fget-n (frame slot)
(let ((classes (fget-classes frame)))
(cond ((fget-n1 slot classes 'value))
((fget-n1 slot classes 'default))
((fget-n2 slot classes 'if-needed))
(t nil))))
(defun fget-n1 (slot classes key)
(cond ((null classes) nil)
((fget (car classes) slot key))
(t
(fget-n1 slot (cdr classes) key))))
(defun fget-n2 (slot classes key)
(cond ((null classes) nil)
((mapcan #'(lambda (demon) (funcall demon (car classase) slot))
(fget (car classes) slot ley)))
(t
(fget-n2 slot (cdr classes) key))))
;;;
;;;
;;;
(defun fput-p (frame slot facet value)
(cond ((fput frame slot facet value)
(mapcar #'(lambda (e)
(mapcar #'(lambda (demon) (funcall demon frame slot))
(fget e slot 'if-added)))
(fget-classes frame))
value)))
;;;
;;;
;;;
(defun remove-p (frame slot facet value)
(cond ((fremove frame slot facet value)
(mapcar #'(lambda (e)
(mapcar #'(lambda (demon) (funcall demon frame slot))
(fget e slot 'if-removed)))
(fget-classes frame))
value)))
;;;
;;;
;;;
(defun copy-frame (name1 name2)
(let ((lst (list name2 (second (fget-frame name1)))))
(putprop name2 lst 'frame)))
;;;
;;; c:\program files\acl62\utility.cl
;;;
(load "c:\\program files\\acl62\\my-test.cl")
(defun search-s1-in-s2 (s1 s2)
(let* ((n1 (length s1))
(n2 (length s2))
(lst (do ((i 0 (1+ i))
(j n1 (1+ j))
(w nil))
((= i n2)
(cond ((null w) nil)
(t (push n2 w)
(cond ((not (member 0 w))
(append w '(0)))
(t w)))))
(cond ((and (equal s1 (subseq s2 i j))
(cond ((null w) t)
(t (>= i (car w)))))
(push i w)
(push (+ i n1) w))))))
;;;
(do ((l lst (cdr l))
(w))
((null (cdr l)) w)
(cond ((not (= (car l) (cadr l)))
(push (list (cadr l) (car l)) w))))))
(defun divide-s1-with-s2 (s1 s2)
(let ((lst (search-s1-in-s2 s2 s1)))
(do ((l lst (cdr l))
(w))
((null l) (reverse w))
(push (subseq s1 (caar l) (cadar l)) w))))
(defun implode-aux (l)
(cond ((null l) "")
(t (concatenate 'string (car l) (implode-aux (cdr l))))))
(defun implode (l) (intern (implode-aux l)))
;;;
;;; (replace-s1-with-s2-in-s "a" "x" "abcabc") ===> "xbcxbc"
;;;
(defun replace-s1-with-s2-in-s (s1 s2 s)
(let ((lst (divide-s1-with-s2 s s1)))
(do ((l lst (cdr l))
(w))
((null l) (implode-aux (reverse w)))
(if (equal (car l) s1)
(push s2 w)
(push (car l) w)))))
(defun display-a-list (l)
(do ((lst l (cdr lst))
(i 1 (1+ i)))
((null lst))
(format t "~% ~a. ~a" i (car lst))))
(defun read-sentence ()
(let ((input (make-string-input-stream (read-line))))
(unwind-protect
(progn
(do ((word (read input nil) (read input nil))
(sentence nil))
((not word) (return (reverse sentence)))
(push word sentence)))
(close input))))
(defun diskout-a-list (file-name lst)
(let ((stream (open file-name :direction :output)))
(print lst stream)
(close stream)))
(defun diskin-a-list (file-name)
(with-open-file (stream file-name :direction :input)
(do ((data (read stream nil 'eof) (read stream nil 'eof))
(w nil))
((eq data 'eof) (reverse w))
(push data w))))
(defun cut-head-of-list (l n)
(cond ((<= (length l) n) l)
((= (length l) (1+ n))
(rest l))
(t (cut-head-of-list (rest l) n))))
(defun generate-a-number-n1-n2 (n1 n2)
(prog (num)
loop
(setf num (random (* 6 n2)))
(if (and (>= num n1) (<= num n2))
(return num)
(go loop))))
(defun remove-first-list-from-second-list (f s)
(cond ((null f) s)
((member (first f) s :test #'equal)
(remove (first f)
(remove-first-list-from-second-list (rest f) s)
:test #'equal))
(t
(remove-first-list-from-second-list (rest f) s))))
(defun same-set-p (a b)
(and (null (remove-first-list-from-second-list a b))
(null (remove-first-list-from-second-list b a))))
(defun sub-set-p (a b)
(null (remove-first-list-from-second-list b a)))
(defun rotate-list (l &key direction (distance 2))
(if (eq direction 'left)
(rotate-list-left l distance)
(rotate-list-right l distance)))
(defun rotate-list-right (l n)
(if (zerop n)
l
(rotate-list-right (append (last l) (butlast l)) (1- n))))
(defun rotate-list-left (l n)
(if (zerop n)
l
(rotate-list-left (append (rest l) (list (first l))) (1- n))))
(defun get-position-of-an-element (e l)
(do ((lst l (cdr lst))
(i 1 (1+ i)))
((null lst) nil)
(cond ((equal e (car lst))
(return i)))))
(defun my-nth (n l) (nth (1- n) l))
(defun cut-list-at-length (n l)
(if (<= (length l) n)
l
(do ((lst l (cdr lst))
(i 0 (1+ i))
(w))
((= i n) (reverse w))
(push (car lst) w))))
(setf *seed* 0)
;(defun my-rand ()
; (prog ()
; (setf *seed* (mod (+ (* 25173 *seed*) 13849) 65536))
; (return *seed*)))
(defun my-rand ()
(prog ()
(setf *seed* (mod (+ (* 7 *seed*) 4079) 268435456))
(return *seed*)))
(defun my-random (n) (mod (my-rand) n))
(defun squash (s)
(cond ((null s) nil)
((atom s) (list s))
(t (append (squash (car s)) (squash (cdr s))))))
(defun get-numbers-from-a-list (l)
(do ((lst l (cdr lst))
(w))
((null lst) (reserve w))
(if (numberp (car lst)) (push (car lst) w))))
(defun remove-duplicate (l)
(cond ((null l) nil)
((member (car l) (cdr l) :test #'equal)
(cons (car l) (remove (car l)
(remove-duplicate (cdr l)) :test #'equal)))
(t
(cons (car l) (remove-duplicate (cdr l))))))
(defun my-load (filename)
(let ((stream (open filename :direction :input)))
(do ((form nil (read stream nil stream)))
((eq form stream) (close stream))
(print (eval form)))))
(defun make-frame-from-list (l) (putprop (car l) l 'frame))
(defun display-frame (frame)
(let ((lst (fget-frame frame)))
(format t "~%On the frame ~a~%" (car lst))
(mapcan #'(lambda (e)
(format t "~% ***** ~a *****~% ~a" (car e) (cdadr e)))
(rest lst))))
;;;
;;; c:\\program files\\acl62\\rythm.cl
;;;
(load "c:\\program files\\acl62\\music2.cl")
(make-frame-from-list
'(4n (add0 (value 4 (8pause 8) "3(8pause 8pause 8)"))
(add1 (value (8 8) (8.5 16) "3(8pause 8 8)"))
(add2 (value (16pause 16 16 16) (8 16 16) "3(8 8 8)"))
(add3 (value (16 16 16 16)))))
(defun fget-addn-of-4n (n)
(case n
(0 (fget-i '4n 'add0))
(1 (fget-i '4n 'add1))
(2 (fget-i '4n 'add2))
(3 (fget-i '4n 'add3))))
(defun select-addn-of-4n (n)
(let ((lst (fget-addn-of-4n n)))
(nth (random (length lst)) lst)))
(defun generate-a-list-of-disorder-n (n)
(prog (w num)
loop
(setf num (1+ (random n)))
(if (and (not (member num w))
(<= num n))
(push num w))
(if (>= (length w) n)
(go exit)
(go loop))
exit
(return w)))
(defun replace-nth-element-in-a-list (l n e)
(do ((lst l (cdr lst))
(num 1 (1+ num))
(w))
((null lst) (reverse w))
(if (= num n)
(push e w)
(push (car lst) w))))
(defun replace-n-place-with-addn-of-4n (n1 l)
(do ((lst (generate-a-list-of-disorder-n 4) (cdr lst))
(lst2 l (cdr lst2))
(num1 0 (1+ num1))
(w '(4 4 4 4)))
((= num1 n1) (squash w))
(setf w (replace-nth-element-in-a-list w
(car lst)
(select-addn-of-4n (car lst2))))))
;;;
;;;
;;;
(defun add1-4n ()
(case (random 3)
(0 (replace-n-place-with-addn-of-4n 1 '(1)))
(1 (replace-n-place-with-addn-of-4n 2 '(0 1)))
(2 (replace-n-place-with-addn-of-4n 4 '(0 0 0 1)))))
(defun add2-4n ()
(case (random 7)
(0 (replace-n-place-with-addn-of-4n 3 '(0 1 1)))
(1 (replace-n-place-with-addn-of-4n 4 '(0 0 1 1)))
(2 (replace-n-place-with-addn-of-4n 2 '(0 2)))
(3 (replace-n-place-with-addn-of-4n 3 '(0 0 2)))
(4 (replace-n-place-with-addn-of-4n 4 '(0 0 0 2)))
(5 (replace-n-place-with-addn-of-4n 2 '(1 1)))
(6 (replace-n-place-with-addn-of-4n 1 '(2)))))
(defun add3-4n ()
(case (random 8)
(0 (replace-n-place-with-addn-of-4n 3 '(0 1 2)))
(1 (replace-n-place-with-addn-of-4n 4 '(0 0 1 2)))
(2 (replace-n-place-with-addn-of-4n 4 '(0 1 1 1)))
(3 (replace-n-place-with-addn-of-4n 2 '(0 3)))
(4 (replace-n-place-with-addn-of-4n 4 '(0 0 0 3)))
(5 (replace-n-place-with-addn-of-4n 2 '(1 2)))
(6 (replace-n-place-with-addn-of-4n 3 '(1 1 1)))
(7 (replace-n-place-with-addn-of-4n 1 '(3)))))
(defun add4-4n ()
(case (random 8)
(0 (replace-n-place-with-addn-of-4n 4 '(0 1 1 2)))
(1 (replace-n-place-with-addn-of-4n 3 '(0 1 3)))
(2 (replace-n-place-with-addn-of-4n 4 '(0 0 1 3)))
(3 (replace-n-place-with-addn-of-4n 3 '(0 2 2)))
(4 (replace-n-place-with-addn-of-4n 4 '(0 0 2 2)))
(5 (replace-n-place-with-addn-of-4n 3 '(1 1 2)))
(6 (replace-n-place-with-addn-of-4n 2 '(1 3)))
(7 (replace-n-place-with-addn-of-4n 2 '(2 2)))))
(defun add5-4n ()
(case (random 7)
(0 (replace-n-place-with-addn-of-4n 4 '(0 1 2 2)))
(1 (replace-n-place-with-addn-of-4n 4 '(0 1 1 3)))
(2 (replace-n-place-with-addn-of-4n 3 '(0 2 3)))
(3 (replace-n-place-with-addn-of-4n 4 '(0 0 2 3)))
(4 (replace-n-place-with-addn-of-4n 3 '(1 2 2)))
(5 (replace-n-place-with-addn-of-4n 2 '(2 3)))
(6 (replace-n-place-with-addn-of-4n 3 '(1 1 3)))))
(defun add6-4n ()
(case (random 9)
(0 (replace-n-place-with-addn-of-4n 4 '(0 1 2 3)))
(1 (replace-n-place-with-addn-of-4n 3 '(1 2 3)))
(2 (replace-n-place-with-addn-of-4n 4 '(0 2 2 2)))
(3 (replace-n-place-with-addn-of-4n 3 '(0 3 3)))
(4 (replace-n-place-with-addn-of-4n 4 '(0 0 3 3)))
(5 (replace-n-place-with-addn-of-4n 4 '(1 1 2 2)))
(6 (replace-n-place-with-addn-of-4n 4 '(1 1 1 3)))
(7 (replace-n-place-with-addn-of-4n 3 '(2 2 2)))
(8 (replace-n-place-with-addn-of-4n 2 '(3 3)))))
(defun add7-4n ()
(case (random 6)
(0 (replace-n-place-with-addn-of-4n 4 '(0 1 3 3)))
(1 (replace-n-place-with-addn-of-4n 4 '(0 2 2 3)))
(2 (replace-n-place-with-addn-of-4n 4 '(1 1 2 3)))
(3 (replace-n-place-with-addn-of-4n 3 '(1 3 3)))
(4 (replace-n-place-with-addn-of-4n 4 '(1 2 2 2)))
(5 (replace-n-place-with-addn-of-4n 3 '(2 2 3)))))
(defun add8-4n ()
(case (random 5)
(0 (replace-n-place-with-addn-of-4n 4 '(1 2 2 3)))
(1 (replace-n-place-with-addn-of-4n 3 '(2 3 3)))
(2 (replace-n-place-with-addn-of-4n 4 '(1 1 3 3)))
(3 (replace-n-place-with-addn-of-4n 4 '(2 2 2 2)))
(4 (replace-n-place-with-addn-of-4n 4 '(0 2 3 3)))))
(defun add9-4n ()
(case (random 4)
(0 (replace-n-place-with-addn-of-4n 4 '(1 2 3 3)))
(1 (replace-n-place-with-addn-of-4n 4 '(2 2 2 3)))
(2 (replace-n-place-with-addn-of-4n 3 '(3 3 3)))
(3 (replace-n-place-with-addn-of-4n 4 '(0 3 3 3)))))
(defun add10-4n ()
(case (random 2)
(0 (replace-n-place-with-addn-of-4n 4 '(2 2 3 3)))
(1 (replace-n-place-with-addn-of-4n 4 '(3 3 3 1)))))
(defun add11-4n ()
(replace-n-place-with-addn-of-4n 4 '(2 3 3 3)))
(defun add12-4n ()
(replace-n-place-with-addn-of-4n 4 '(3 3 3 3)))
(defun add0-4n ()
(nth (random 10) '((4 4 4 4) (4.5 8 4 4) (4 4 4.5 8) (4 4.5 4 8) (4 2 8 8)
(2 4 8 8) (4 8 8 2) (2 8 8 4) (8 8 2 4) (4 8 8 2))))
(defun add-1-4n ()
(nth (random 7) '((2 4 4) (4 4 2) (4 2 4) (4.5 8 2) (2 4.5 8) (2.5 8 8) (8 8 2.5))))
(defun add-2-4n ()
(nth (random 6) '((2.5 4) (4 2.5) (2.5 4) (4 2.5) (2 2) (2 2))))
(defun add-3-4n () (nth (random 2) '((1) (1))))
;;;
;;;
;;;
(defun get-rythm-of-4beat (n)
(case n
(1 (add-3-4n))
(2 (add-2-4n))
(3 (add-1-4n))
(4 (add0-4n))
(5 (add1-4n))
(6 (add2-4n))
(7 (add3-4n))
(8 (add4-4n))
(9 (add5-4n))
(10 (add6-4n))
(11 (add7-4n))
(12 (add8-4n))
(13 (add9-4n))
(14 (add10-4n))
(15 (add11-4n))
(16 (add12-4n))))
(defun get-4beat-below-n (n)
(get-rythm-of-4beat (1+ (random n))))
(defun get-4beat ()
(get-rythm-of-4beat (1+ (random 16))))
;;;
;;;*************************************************************
;;;
(make-frame-from-list
'(3n (add0 (value 4 (8pause 8) "3(8pause 8pause 8)"))
(add1 (value (8 8) (8.5 16) "3(8pause 8 8)"))
(add2 (value (16 16 8) (8 16 16) "3(8 8 8)"))
(add3 (value (16 16 16 16)))))
(defun fget-addn-of-3n (n)
(case n
(0 (fget-i '3n 'add0))
(1 (fget-i '3n 'add1))
(2 (fget-i '3n 'add2))
(3 (fget-i '3n 'add3))))
(defun select-addn-of-3n (n)
(let ((lst (fget-addn-of-3n n)))
(nth (random (length lst)) lst)))
(defun replace-n-place-with-addn-of-3n (n1 l)
(do ((lst (generate-a-list-of-disorder-n 3) (cdr lst))
(lst2 l (cdr lst2))
(num1 0 (1+ num1))
(w '(4 4 4)))
((= n1 num1) (squash w))
(setf w (replace-nth-element-in-a-list w
(car lst)
(select-addn-of-3n (car lst2))))))
(defun add1-3n ()
(case (random 3)
(0 (replace-n-place-with-addn-of-3n 2 '(0 1)))
(1 (replace-n-place-with-addn-of-3n 3 '(0 0 1)))
(2 (replace-n-place-with-addn-of-3n 1 '(1)))))
(defun add2-3n ()
(case (random 5)
(0 (replace-n-place-with-addn-of-3n 3 '(0 1 1)))
(1 (replace-n-place-with-addn-of-3n 2 '(0 2)))
(2 (replace-n-place-with-addn-of-3n 3 '(0 0 2)))
(3 (replace-n-place-with-addn-of-3n 2 '(1 1)))
(4 (replace-n-place-with-addn-of-3n 1 '(2)))))
(defun add3-3n ()
(case (random 4)
(0 (replace-n-place-with-addn-of-3n 3 '(0 1 2)))
(1 (replace-n-place-with-addn-of-3n 2 '(0 3)))
(2 (replace-n-place-with-addn-of-3n 3 '(0 0 3)))
(3 (replace-n-place-with-addn-of-3n 2 '(1 2)))))
(defun add4-3n ()
(case (random 5)
(0 (replace-n-place-with-addn-of-3n 2 '(1 3)))
(1 (replace-n-place-with-addn-of-3n 3 '(0 2 2)))
(2 (replace-n-place-with-addn-of-3n 3 '(1 1 2)))
(3 (replace-n-place-with-addn-of-3n 2 '(1 3)))
(4 (replace-n-place-with-addn-of-3n 2 '(2 2)))))
(defun add5-3n ()
(case (random 4)
(0 (replace-n-place-with-addn-of-3n 3 '(0 2 3)))
(1 (replace-n-place-with-addn-of-3n 3 '(1 2 2)))
(2 (replace-n-place-with-addn-of-3n 2 '(2 3)))
(3 (replace-n-place-with-addn-of-3n 3 '(1 1 3)))))
(defun add6-3n ()
(case (random 4)
(0 (replace-n-place-with-addn-of-3n 3 '(1 2 3)))
(1 (replace-n-place-with-addn-of-3n 3 '(0 3 3)))
(2 (replace-n-place-with-addn-of-3n 3 '(2 2 2)))
(3 (replace-n-place-with-addn-of-3n 2 '(3 3)))))
(defun add7-3n ()
(case (random 2)
(0 (replace-n-place-with-addn-of-3n 3 '(1 3 3)))
(1 (replace-n-place-with-addn-of-3n 3 '(2 2 3)))))
(defun add8-3n ()
(replace-n-place-with-addn-of-3n 3 '(2 3 3)))
(defun add9-3n ()
(replace-n-place-with-addn-of-3n 3 '(3 3 3)))
(defun add0-3n ()
(nth (random 5) '((4 4 4) (4 4.5 8) (4.5 8 4) (2 8 8) (8 8 2))))
(defun add-1-3n ()
(nth (random 2) '((2 4) (4 2))))
(defun add-2-3n () '(2.5))
;;;
;;;
;;;
(defun get-rythm-of-3beat (n)
(case n
(1 (add-2-3n))
(2 (add-1-3n))
(3 (add0-3n))
(4 (add1-3n))
(5 (add2-3n))
(6 (add3-3n))
(7 (add4-3n))
(8 (add5-3n))
(9 (add6-3n))
(10 (add7-3n))
(11 (add8-3n))
(12 (add9-3n))))
(defun get-3beat-below-n (n)
(get-rythm-of-3beat (1+ (random n))))
(defun get-3beat ()
(get-rythm-of-3beat (1+ (random 12))))
;;;
;;; c:\\program files\\acl62\\music1.cl
;;;
(load "c:\\program files\\acl62\\utility.cl")
(make-frame-from-list
'(key (type (value major-key minor-key))))
(make-frame-from-list
'(function (major-key (value tonic subdominant subdominant-minor dominant))
(minor-key (value tonic-minor subdominant subdominant-minor dominant
dominant-minor))))
(make-frame-from-list
'(major-key (tonic
(value ("I" ion) ("I6" ion) ("IM7" ion)
("IIIm7" phr)
("VIm7" aeo)
("+IVm7-5" loc)))
(subdominant
(value ("IV" lyd) ("IV6" lyd) ("IVM7" lyd)
("IIm7" dor)
("IV7" lyd-7 bn)
("-VIIM7" lyd)
("VII7" alt)
("+IVm7-5" loc)))
(subdominant-minor
(value ("IVm7" dor)
("IIm7-5" loc+2)
("-VI6" lyd)
("-VIM7" lyd)
("-VII7" lyd-7)
("-IIM7" lyd)
("-VI7" lyd-7)))
(dominant
(value ("V7" mix lyd-7 hmp5 alt comd wt)
("VIIm7-5" loc)
("-II7" lyd-7)
("VIIdim7" dim)))))
(make-frame-from-list
'(minor-key (tonic-minor
(value ("Im" all)
("Im6" m)
("Im7" dor)
("ImM7" h m)
("-IIIM7" lyd ion)
("-III+M7" lyd)
("-VIM7" lyd)
("VIm7-5" loc)))
(subdominant
(value ("IV" lyd)
("IV6" lyd7)
("IV7" lyd-7)
("IIm7" dor-2)
("VII7" alt)
("IVM7" lyd)))
(subdominant-minor
(value ("IVm" dor)
("IVm6" dor)
("IVm7" dor)
("IIm7-5" loc)
("-VI6" lyd)
("-VIM7" lyd)
("-VII7" mix)
("-IIM7" lyd)
("-VI7" lyd-7)
("VImM7" dor)))
(dominant
(value ("V7" mix lyd-7 hmp5 alt comd wt)
("VIIdim7" dim)
("VIIm7-5" loc)
("-II7" lyd-7)))
(dominant-minor
(value ("Vm" phr) ("Vm7" phr)))))
(make-frame-from-list
'(scale (ion (value 1.0 2.0 3.0 3.5 4.5 5.5 6.5 7.0))
(dor (value 1.0 2.0 2.5 3.5 4.5 5.5 6.0 7.0))
(phr (value 1.0 1.5 2.5 3.5 4.5 5.0 6.0 7.0))
(lyd (value 1.0 2.0 3.0 4.0 4.5 5.5 6.5 7.0))
(mix (value 1.0 2.0 3.0 3.5 4.5 5.5 6.0 7.0))
(aeo (value 1.0 2.0 2.5 3.5 4.5 5.0 6.0 7.0))
(loc (value 1.0 1.5 2.5 3.5 4.0 5.0 6.0 7.0))
(n (value 1.0 2.0 2.5 3.5 4.5 5.0 6.0 7.0))
(h (value 1.0 2.0 2.5 3.5 4.5 5.0 6.5 7.0))
(m (value １.0 2.0 2.5 3.5 4.5 5.5 6.5 7.0 7.0 6.0 5.0 4.5 3.5 2.5 2.0 1.0))
(all (value 1.0 2.0 2.5 3.5 4.5 5.0 5.5 6.0 6.5 7.0))
(dor-2 (value 1.0 1.5 2.5 3.5 4.5 5.5 6.0 7.0))
(loc+2 (value 1.0 2.0 2.5 3.5 4.0 5.0 6.0 7.0))
(lyd-7 (value 1.0 2.0 3.0 4.0 4.5 5.5 6.0 7.0))
(mmp5 (value 1.0 2.0 3.0 3.5 4.5 5.0 6.0 7.0))
(hmp5 (value 1.0 1.5 2.5 3.0 3.5 4.5 5.0 6.0 7.0))
(alt (value 1.0 1.5 2.5 3.0 4.0 5.0 6.0 7.0))
(comd (value 1.0 1.5 2.5 3.0 4.0 4.5 5.5 6.0 7.0))
(dim (value 1.0 2.0 2.5 3.5 4.0 5.0 5.5 6.5 7.0))
(wt (value 1.0 2.0 3.0 4.0 5.0 6.0 7.0))
(pt (value 1.0 2.0 3.0 4.5 5.5 7.0))
(bpt (value 1.0 2.5 3.5 4.0 4.5 6.0 7.0))
(bn (value 1.0 2.0 2.5 3.5 4.0 4.5 5.5 6.0 7.0))
(mixsus4 (value 1.0 2.0 3.0 3.5 4.5 5.5 6.0 7.0))
(mix-6 (value 1.0 2.0 3.0 3.5 4.5 5.0 6.0 7.0))
(spanish (value 1.0 1.5 2.5 3.0 3.5 4.5 5.0 6.0 7.0))
(gypsy (value 1.0 2.0 2.5 4.0 4.5 5.0 6.5 7.0))
(hms (value 1.0 2.0 3.0 3.5 4.5 5.0 6.5 7.0))
(ryukyu (value 1.0 3.0 3.5 4.5 6.5 7.0))
(tyuto (value 1.0 2.0 2.5 3.5 4.0 5.0 5.5 6.5 7.0))
(in (value 1.0 1.5 3.5 4.5 6.0 7.0 5.0 4.5 3.5 1.5 1.0))
(yo (value 1.0 2.0 3.5 4.5 6.0 7.0 5.5 4.5 3.5 2.0 1.0))
(ro (value 1.0 2.0 3.0 4.5 5.5 7.0))
(ritu (value 1.0 2.0 3.5 4.5 5.5 7.0))))
(make-frame-from-list
'(code (Mt (value 1.0 3.0 4.5))
(mt (value 1.0 2.5 4.5))
(sus4 (value 1.0 3.5 4.5))
(aug (value 1.0 3.0 5.0))
(dim (value 1.0 2.5 4.0))
(M-5 (value 1.0 3.0 4.0))
(d7 (value 1.0 3.0 4.5 6.0))
(m7 (value 1.0 2.5 4.5 6.0))
(M7 (value 1.0 3.0 4.5 6.5))
(mM7 (value 1.0 2.5 4.5 6.5))
(dim7 (value 1.0 2.5 4.0 5.5))
(dimM7 (value 1.0 2.5 4.0 6.5))
(m7-5 (value 1.0 2.5 4.0 6.0))
(aug7 (value 1.0 3.0 5.0 6.0))
(augM7 (value 1.0 3.0 5.0 6.5))
(M6 (value 1.0 3.0 4.5 5.5))
(m6 (value 1.0 2.5 4.5 5.5))
(d7sus4 (value 1.0 3.5 4.5 6.0))
(Madd9 (value 1.0 2.0 3.0 4.5))
(madd9 (value 1.0 2.0 2.5 4.5))
(M69 (value 1.0 2.0 3.0 4.5 5.5))
(m69 (value 1.0 2.0 2.5 4.5 5.5))
(d7-5 (value 1.0 3.0 4.0 6.0))
(M+11 (value 1.0 3.0 4.0 4.5))
(m11 (value 1.0 2.5 3.5 4.5))
(d7-9 (value 1.0 1.5 3.0 4.5 6.0))
(d79 (value 1.0 2.0 3.0 4.5 6.0))
(d7+9 (value 1.0 2.5 3.0 4.5 6.0))
(d7+11 (value 1.0 3.0 4.0 4.5 6.0))
(d713 (value 1.0 3.0 4.5 5.5 6.0))
(d7-9+11 (value 1.0 1.5 3.0 4.0 4.5 6.0))
(d79+11 (value 1.0 2.0 3.0 4.0 4.5 6.0))
(d7+9+11 (value 1.0 2.5 3.0 4.0 4.5 6.0))
(d7+1113 (value 1.0 3.0 4.0 4.5 5.5 6.0))
(m79 (value 1.0 2.0 2.5 4.5 6.0))
(m711 (value 1.0 2.5 3.5 4.5 6.0))
(m713 (value 1.0 2.5 4.5 5.5 6.0))
(M79 (value 1.0 2.0 3.0 4.5 6.5))
(M7+11 (value 1.0 3.0 4.0 4.5 6.5))
(M713 (value 1.0 3.0 4.5 5.5 6.5))
(mM79 (value 1.0 2.0 2.5 4.5 6.5))
(mM711 (value 1.0 2.5 3.5 4.5 6.5))
(mM713 (value 1.0 2.5 4.5 5.5 6.5))))
(make-frame-from-list
'(guide-tone
(Mt (value 3.0 6.5))
(mt (value 2.5 6.0))
(sus4 (value 3.5 6.0))
(aug (value 3.0 6.5))
(dim (value 2.5 5.5))
(M-5 (value 3.0 6.5))
(d7 (value 3.0 6.0))
(m7 (value 2.5 6.0))
(M7 (value 3.0 6.5))
(mM7 (value 2.5 6.5))
(dim7 (value 2.5 5.5))
(dimM7 (value 2.5 6.5))
(m7-5 (value 2.5 6.0))
(aug7 (value 3.0 6.0))
(augM7 (value 3.0 6.5))
(M6 (value 3.0 6.5))
(m6 (value 2.5 6.0))
(d7sus4 (value 3.5 6.0))
(Madd9 (value 3.0 6.5))
(madd9 (value 2.5 6.0))
(M69 (value 3.0 6.5))
(m69 (value 2.5 6.0))
(d7-5 (value 3.0 6.0))
(M+11 (value 3.0 6.5))
(m11 (value 2.5 6.0))
(d7-9 (value 3.0 6.0))
(d79 (value 3.0 6.0))
(d7+9 (value 3.0 6.0))
(d7+11 (value 3.0 6.0))
(d713 (value 3.0 6.0))
(d7-9+11 (value 3.0 6.0))
(d79+11 (value 3.0 6.0))
(d7+9+11 (value 3.0 6.0))
(d7+1113 (value 3.0 6.0))
(m79 (value 2.5 6.0))
(m711 (value 2.5 6.0))
(m713 (value 2.5 6.0))
(M79 (value 3.0 6.5))
(M7+11 (value 3.0 6.5))
(M713 (value 3.0 6.5))
(mM79 (value 2.5 6.5))
(mM711 (value 2.5 6.5))
(mM713 (value 2.5 6.5))))
(make-frame-from-list
'(tension-note (ion (value 2.0 5.5))
(dor (value 2.0 3.5))
(phr (value 3.5 5.0))
(lyd (value 2.0 4.0 5.5))
(mix (value 2.0 5.5))
(aeo (value 2.0 3.5))
(loc (value 3.5 5.0))
(n (value 2.0 3.5))
(h (value 2.0 3.5))
(m (value 2.0 3.5 5.5 3.5 2.0))
(all (value 2.0 3.5))
(dor-2 (value 3.5 5.5))
(loc+2 (value 2.0 3.5 5.0))
(lyd-7 (value 2.0 4.0 5.5))
(mmp5 (value 2.0 5.0))
(hmp5 (value 1.5 2.5 5.0))
(alt (value 1.5 2.5 4.0 5.0))
(dim (value 2.0 3.5 5.0 6.5))
(comd (value 1.5 2.5 4.0 5.5))
(wt (value 2.0 4.0))
(mixsus4 (value 2.0 5.5))
(mix-6 (value 2.0 5.0))
(spanish (value 1.5 2.5 3.5 5.0))
(gypsy (value 2.0 4.0 5.0))
(hms (value 2.0 3.5 5.0))
(ryukyu (value 3.5))
(tyuto (value 2.0 3.5 5.0 5.5))
(in (value 1.5 4.5))
(yo (value 2.0 4.5))
(ro (value 2.0 5.5))
(ritu (value 2.0 5.5))
(pt (value 2.0 5.5))
(bpt (value 3.5 4.0))
(bn (value 2.0 3.5 4.0 5.5))))
;;;
;;;
;;;
(make-frame-from-list
'(UST-CM7 (ion (value "G" "Am" "Em" "D" "Bm"))
(lyd (value "G" "Am" "Em" "D" "Bm"))))
;;;
;;;
;;;
(make-frame-from-list
'(UST-Cm7 (dor (value "Gm" "-B" "-E" "Dm"))
(phr (value "-E" "-A" "Fm"))
(aeo (value "-B" "-E" "Gm"))
(n (value "Gm" "-B"))
(h (value "G"))
(all (value "Gm" "G" "-A" "-B" "-E" "Dm"))))
;;;
;;;
;;;
(make-frame-from-list
'(UST-Cm (dor (value "Gm" "-B" "-E" "Dm"))
(phr (value "-E" "-A" "Fm"))
(aeo (value "-B" "-E" "Gm"))
(n (value "Gm" "-B"))
(h (value "G"))
(all (value "Gm" "G" "-A" "-B" "-E" "Dm"))))
;;;
;;;
;;;
(make-frame-from-list
'(UST-C7 (mix (value "Gm" "Am"))
(lyd-7 (value "D" "Gm" "Am"))
(alt (value "-Dm" "-Em" "-G" "-A"))
(hmp5 (value "-Dm" "-E" "-A"))
(comd (value "-Em" "-E" "-Gm" "-G" "Am" "A"))
(all (value "-E" "D" "-G" "-A" "A" "-Bm" "-Dm"
"-B" "Am" "-Gm" "Gm" "-Em"))))
;;;
;;;
;;;
(make-frame-from-list
'(UST-Cdim7 (dim (value "Dm" "D" "Fm" "F" "-Am" "-A" "Bm" "B"))))
;;;
;;;
;;;
(make-frame-from-list
'(UST-C7sus4 (mixsus4 (value "Dm" "F" "Gm" "-B"))))
;;;
;;;
;;;
(make-frame-from-list
'(UST-Cm7-5 (loc (value "-A" "-B" "-Em" "Fm" "-A" "-G" "-Bm"))
(loc+2 (value "Fm" "-A" "-B"))))
;;;
;;;
;;;
(make-frame-from-list
'(UST-CmM7 (m (value "Dm" "F" "G"))))
;;;
;;;
;;;
(make-frame-from-list
'(UST-Cm6 (m (value "Dm" "F" "G"))))
;;;
;;;
;;;
(make-frame-from-list
'(C (ion (value (tonic (C))))
(lyd (value (subdominant (g D G))))))
;;;
;;;
;;;
(make-frame-from-list
'(Am (all (value (tonic-minor (a))))
(aeo (value (tonc (C))))
(phr (value (dominant-minor (d)) (tonic (F))))
(dor (value (subdominant-minor (E e))))
(dor-2 (value (subdominant (g))))))
;;;
;;;
;;;
(make-frame-from-list
'(CM7 (ion (value (tonic (C))))
(lyd (value (tonic-minor (a e)) (subdominant (g D G)) (subdominant-minor (B E b e))))))
;;;
;;;
;;;
(make-frame-from-list
'(Am7 (aeo (value (tonic (C))))
(phr (value (tonic (F)) (dominant-minor (d))))
(dor (value (tonic-minor (a)) (subdominant (G)) (subdominant-minor (E e))))
(dor-2 (value (subdominant (g))))))
;;;
;;;
;;;
(make-frame-from-list
'(C7 (all (value (tonic (C)) (dominant (f F))))
(lyd-7 (value (dominant (B b)) (subdominant (G g)) (subdominant-minor (D E e))))
(alt (value (subdominant (-D +c))))
(comd (value (subdominant (-D +c))))
(hmp5 (value (dominant (f))))
(mix (value (subdominant-minor (d))))))
;;;
;;;
;;;
(make-frame-from-list
'(C6 (ion (value (tonic (C))))
(lyd (value (subdominant (G g)) (subdominant-minor (E e))))))
;;;
;;;
;;;
(make-frame-from-list
'(Am6 (m (value (tonic-minor (a))))
(dor (value (subdominant-minor (E e))))))
;;;
;;;
;;;
(make-frame-from-list
'(Am7-5 (loc (value (tonic (-E)) (tonic-minor (c)) (subdominant (-E)) (subdominant-minor (g))
(dominant (-B -b))))
(loc+2 (value (subdominant-minor (G))))))
;;;
;;;
;;;
(make-frame-from-list
'(AmM7 (h (value (tonic-minor (a))))
(m (value (tonic-minor (a))))
(dor (value (subdominant-minor (c))))))
;;;
;;;
;;;
(make-frame-from-list
'(A+M7 (lyd (value (tonic-minor (+f))))))
;;;
;;; c:\\program files\\acl62\\music2.cl
;;;
(load "c:\\program files\\acl62\\music1.cl")
(setf *print-length* 1000)
(defun +key-p (key)
(if (member key '(G +F B E A D +d +g +c +f b e))
t
nil))
(defun confine-a-number (n)
(prog (num)
(setf num (eval (cons '+ (multiple-value-list (floor n 7.0)))))
(cond ((and (>= num 0.8) (<= num 1.2)) (return 1.0))
((and (>= num 1.3) (<= num 1.7)) (return 1.5))
((and (>= num 1.8) (<= num 2.2)) (return 2.0))
((and (>= num 2.3) (<= num 2.7)) (return 2.5))
((and (>= num 2.8) (<= num 3.2)) (return 3.0))
((and (>= num 3.3) (<= num 3.7)) (return 3.5))
((and (>= num 3.8) (<= num 4.2)) (return 4.0))
((and (>= num 4.3) (<= num 4.7)) (return 4.5))
((and (>= num 4.8) (<= num 5.2)) (return 5.0))
((and (>= num 5.3) (<= num 5.7)) (return 5.5))
((and (>= num 5.8) (<= num 6.2)) (return 6.0))
((and (>= num 6.3) (<= num 6.7)) (return 6.5)))))
(defun translate-number-to-sound (n offset key)
(let ((num (confine-a-number (+ n offset))))
(case num
(1.0 "ド")
(1.5 (if (+key-p key)
"#ド"
"♭レ"))
(2.0 "レ")
(2.5 (if (+key-p key)
"#レ"
"♭ミ"))
(3.0 "ミ")
(3.5 "ファ")
(4.0 (if (+key-p key)
"#ファ"
"♭ソ"))
(4.5 "ソ")
(5.0 (if (+key-p key)
"#ソ"
"♭ラ"))
(5.5 "ラ")
(6.0 (if (+key-p key)
"#ラ"
"♭シ"))
(6.5 "シ"))))
(defun translate-list-of-number-to-sound (l offset key)
(mapcar #'(lambda (e) (translate-number-to-sound e offset key)) l))
(defun translate-alphabet-to-number (c)
(case c
(c 1.0)(C 1.0)
(+c 1.5)(+C 1.5)(-d 1.5)(-D 1.5)
(d 2.0)(D 2.0)
(+d 2.5)(+D 2.5)(-e 2.5)(-E 2.5)
(e 3.0)(E 3.0)
(f 3.5)(F 3.5)
(+f 4.0)(+F 4.0)(-g 4.0)(-G 4.0)
(g 4.5)(G 4.5)
(+g 5.0)(+G 5.0)(-a 5.0)(-A 5.0)
(a 5.5)(A 5.5)
(+a 6.0)(+A 6.0)(-b 6.0)(-B 6.0)
(b 6.5)(B 6.5)))
;;;
;;; (get-chordscale 'c 'ion) =====> ("ド" "レ" "ミ" "ファ" "ソ" "ラ" "シ" "ド")
;;;
(defun get-chordscale (c csn)
(translate-list-of-number-to-sound (fget-i 'scale csn)
(1- (translate-alphabet-to-number c))
c))
;;;
;;; (get-tension-note 'C 'ion)
;;;
(defun get-tension-note (c csn)
(translate-list-of-number-to-sound (fget-i 'tension-note csn)
(1- (translate-alphabet-to-number c))
c))
;;;
;;;
;;;
(defun get-chord-type (scn)
(cond ((search-s1-in-s2 "7(+11 13)" scn) 'd7+1113)
((search-s1-in-s2 "7(+9+11)" scn) 'd7+9+11)
((search-s1-in-s2 "7(-9+11)" scn) 'd7-9+11)
((search-s1-in-s2 "7(9+11)" scn) 'd79+11)
((search-s1-in-s2 "M7(+11)" scn) 'M7+11)
((search-s1-in-s2 "mM7(11)" scn) 'mM711)
((search-s1-in-s2 "mM7(13)" scn) 'mM713)
((search-s1-in-s2 "7(+11)" scn) 'd7+11)
((search-s1-in-s2 "m7(11)" scn) 'm711)
((search-s1-in-s2 "m7(13)" scn) 'm713)
((search-s1-in-s2 "M7(13)" scn) 'M713)
((search-s1-in-s2 "mM7(9)" scn) 'mM79)
((search-s1-in-s2 "dimM7" scn) 'dimM7)
((search-s1-in-s2 "augM7" scn) 'augM7)
((search-s1-in-s2 "7sus4" scn) 'd7sus4)
((search-s1-in-s2 "(+11)" scn) 'M+11)
((search-s1-in-s2 "m(11)" scn) 'm11)
((search-s1-in-s2 "7(-9)" scn) 'd7-9)
((search-s1-in-s2 "madd9" scn) 'madd9)
((search-s1-in-s2 "7(+9)" scn) 'd7+9)
((search-s1-in-s2 "7(13)" scn) 'd713)
((search-s1-in-s2 "m7(9)" scn) 'm79)
((search-s1-in-s2 "M7(9)" scn) 'M79)
((search-s1-in-s2 "sus4" scn) 'sus4)
((search-s1-in-s2 "dim7" scn) 'dim7)
((search-s1-in-s2 "m7-5" scn) 'm7-5)
((search-s1-in-s2 "aug7" scn) 'aug7)
((search-s1-in-s2 "add9" scn) 'Madd9)
((search-s1-in-s2 "7(9)" scn) 'd79)
((search-s1-in-s2 "aug" scn) 'aug)
((search-s1-in-s2 "dim" scn) 'dim)
((search-s1-in-s2 "mM7" scn) 'mM7)
((search-s1-in-s2 "m69" scn) 'm69)
((search-s1-in-s2 "7-5" scn) 'd7-5)
((search-s1-in-s2 "-5" scn) 'M-5)
((search-s1-in-s2 "m7" scn) 'm7)
((search-s1-in-s2 "M7" scn) 'M7)
((search-s1-in-s2 "m6" scn) 'm6)
((search-s1-in-s2 "69" scn) 'M69)
((search-s1-in-s2 "m" scn) 'mt)
((search-s1-in-s2 "7" scn) 'd7)
((search-s1-in-s2 "6" scn) 'M6)
(t 'Mt)))
(defun involve-character-p (s)
(let ((lst '("+C" "-D" "+D" "-E" "+F" "-G" "+G" "-A" "+A" "-B"
"C" "D" "E" "F" "G" "A" "B")))
(do ((l lst (cdr l)))
((null l))
(cond ((search-s1-in-s2 (car l) s)
(return (intern (car l))))))))
;;;
;;; (get-chord-tone "CM7") =====> ("ド" "ミ" "ソ" "シ")
;;;
(defun get-chord-tone (scn)
(let ((num (1- (translate-alphabet-to-number (involve-character-p scn))))
(lst (fget-i 'code (get-chord-type scn))))
(translate-list-of-number-to-sound lst num (involve-character-p scn))))
;;;
;;; (get-guide-tone "CM7")
;;;
(defun get-guide-tone (scn)
(let ((num (1- (translate-alphabet-to-number (involve-character-p scn))))
(lst (fget-i 'guide-tone (get-chord-type scn))))
(translate-list-of-number-to-sound lst num (involve-character-p scn))))
;;;
;;;
;;;
(defun translate-roman-to-number (s)
(cond ((equal s "I") 1.0)
((or (equal s "+I") (equal s "-II")) 1.5)
((equal s "II") 2.0)
((or (equal s "+II") (equal s "-III")) 2.5)
((equal s "III") 3.0)
((equal s "IV") 3.5)
((or (equal s "+IV") (equal s "-V")) 4.0)
((equal s "V") 4.5)
((or (equal s "+V") (equal s "-VI")) 5.0)
((equal s "VI") 5.5)
((or (equal s "+VI") (equal s "-VII")) 6.0)
((equal s "VII") 6.5)))
(defun translate-number-to-roman (n offset key)
(let ((num (confine-a-number (+ n offset))))
(case num
(1.0 "I")
(1.5 (if (+key-p key) "+I" "-II"))
(2.0 "II")
(2.5 (if (+key-p key) "+II" "-III"))
(3.0 "III")
(3.5 "IV")
(4.0 (if (+key-p key) "+IV" "-V"))
(4.5 "V")
(5.0 (if (+key-p key) "+V" "-VI"))
(5.5 "VI")
(6.0 (if (+key-p key) "+VI" "-VII"))
(6.5 "VII"))))
(defun translate-number-to-alphabet (n offset key)
(let ((num (confine-a-number (+ n offset))))
(case num
(1.0 "C")
(1.5 (if (+key-p key) "+C" "-D"))
(2.0 "D")
(2.5 (if (+key-p key) "+D" "-E"))
(3.0 "E")
(3.5 "F")
(4.0 (if (+key-p key) "+F" "-G"))
(4.5 "G")
(5.0 (if (+key-p key) "+G" "-A"))
(5.5 "A")
(6.0 (if (+key-p key) "+A" "-B"))
(6.5 "B"))))
;;;
;;; (translate-roman-to-alphabet "II" 'C) =====> "D"
;;;
(defun translate-roman-to-alphabet (s key)
(let ((num (translate-roman-to-number s)))
(translate-number-to-alphabet num (1- (translate-alphabet-to-number key)) key)))
;;;
;;; (translate-alphabet-to-roman 'D 'C) =====> "II"
;;;
(defun translate-alphabet-to-roman (c key)
(let ((num (translate-alphabet-to-number c)))
(translate-number-to-roman num (- 6.0 (1- (translate-alphabet-to-number key))) key)))
(defun involve-roman-p (s)
(let ((lst '("-VII" "-III" "VII" "+VI" "-VI" "+IV" "III" "+II" "-II"
"+I" "II" "IV" "-V" "+V" "VI" "V" "I")))
(do ((l lst (cdr l)))
((null l))
(cond ((search-s1-in-s2 (car l) s) (return (car l)))))))
;;;
;;; (get-chord-name-from-roman "IIm7" 'D) =====> "Em7"
;;;
(defun get-chord-name-from-roman (s key)
(let* ((roman (involve-roman-p s))
(char (translate-roman-to-alphabet roman key)))
(replace-s1-with-s2-in-s roman char s)))
(defun replace-roman (l key)
(cond ((null l) nil)
((and (not (listp l)) (involve-roman-p (string l)))
(get-chord-name-from-roman (string l) key))
((atom l) l)
(t (cons (replace-roman (car l) key)
(replace-roman (cdr l) key)))))
(defun get-key-type (Mm)
(if (equal Mm 'major) 'major-key 'minor-key))
;;;
;;; (instantiate-a-key 'C 'major)
;;;
(defun instantiate-a-key (key type)
(let ((lst (fget-frame (get-key-type type))))
(replace-roman lst key)))
(defun involve-char-p (s)
(let ((lst '("+C" "-D" "+D" "-E" "+F" "-G" "+G" "-A" "+A" "-B"
"C" "D" "E" "F" "G" "A" "B")))
(do ((l lst (cdr l)))
((null l))
(cond ((search-s1-in-s2 (car l) s)
(return (car l)))))))
(defun get-roman-from-chord-name (s key)
(let* ((chord (involve-char-p s))
(roman (translate-alphabet-to-roman (intern chord) key)))
(replace-s1-with-s2-in-s chord roman s)))
;;;
;;;
;;;
(defun back-to-roman (l key)
(cond ((null l) nil)
((and (not (listp l)) (involve-char-p (string l)))
(get-roman-from-chord-name (string l) key))
((atom l) l)
(t (cons (back-to-roman (car l) key)
(back-to-roman (cdr l) key)))))
(defun get-UST-of-C (s)
(cond ((equal s "CM7") (cdr (fget-frame 'UST-CM7)))
((equal s "Cm7") (cdr (fget-frame 'UST-Cm7)))
((equal s "Cm") (cdr (fget-frame 'UST-Cm)))
((equal s "C7") (cdr (fget-frame 'UST-C7)))
((equal s "Cdim7") (cdr (fget-frame 'UST-Cdim7)))
((equal s "C7sus4") (cdr (fget-frame 'UST-C7sus4)))
((equal s "Cm7-5") (cdr (fget-frame 'UST-Cm7-5)))
((equal s "CmM7") (cdr (fget-frame 'UST-CmM7)))))
(defun get-chord-type2 (s)
(let ((lst '("7sus4" "dim7" "m7-5" "mM7" "M7" "m7" "m" "7")))
(do ((l lst (cdr l)))
((null l))
(cond ((search-s1-in-s2 (car l) s)
(return (car l)))))))
(defun get-C-chord-name (s) (concatenate 'string "C" (get-chord-type2 s)))
;;;
;;; (get-UST "CM7")
;;;
(defun get-UST (s)
(let* ((lst (get-UST-of-C (get-C-chord-name s)))
(roman (back-to-roman lst 'C)))
(replace-roman roman (intern (involve-char-p s)))))
;;;
;;;
;;;
(defun modulate-key1-to-key2 (l key1 key2)
(let ((lst (back-to-roman l key1)))
(replace-roman lst key2)))
;;;
;;; c:\\program files\\acl62\\music3.cl
;;;
(load "c:\\program files\\acl62\\rythm.cl")
(defun distance-of-two-chars (c1 c2)
(let* ((n1 (translate-alphabet-to-number c1))
(n2 (translate-alphabet-to-number c2))
(num (- n2 n1)))
(cond ((>= num 7.0) (- num 6.0))
((<= num 0.0) (+ num 6.0))
(t num))))
(defun translate-number-to-lower-char (n key)
(case n
(1.0 'c)
(1.5 (if (+key-p key) '+c '-d))
(2.0 'd)
(2.5 (if (+key-p key) '+d '-e))
(3.0 'e) (3.5 'f)
(4.0 (if (+key-p key) '+f '-g))
(4.5 'g)
(5.0 (if (+key-p key) '+g '-a))
(5.5 'a)
(6.0 (if (+key-p key) '+a '-b))
(6.5 'b)))
(defun translate-number-to-upper-char (n key)
(case n
(1.0 'C)
(1.5 (if (+key-p key) '+C '-D))
(2.0 'D)
(2.5 (if (+key-p key) '+D '-E))
(3.0 'E) (3.5 'F)
(4.0 (if (+key-p key) '+F '-G))
(4.5 'G)
(5.0 (if (+key-p key) '+G '-A))
(5.5 'A)
(6.0 (if (+key-p key) '+A '-B))
(6.5 'B)))
(defun translate-lower-char-key1-to-key2 (char key1 key2)
(let ((num (confine-a-number (+ (translate-alphabet-to-number char)
(distance-of-two-chars key1 key2)))))
(translate-number-to-lower-char num key2)))
(defun translate-upper-char-key1-to-key2 (char key1 key2)
(let ((num (confine-a-number (+ (translate-alphabet-to-number char)
(distance-of-two-chars key1 key2)))))
(translate-number-to-upper-char num key2)))
(defun upper-char-p (c)
(cond ((member c '(C +C -D D +D -E E F +F -G G +G -A A +A -B B)) t)
(t nil)))
(defun lower-char-p (c)
(cond ((member c '(c +c -d d +d -e e f +f -g g +g -a a +a -b b)) t)
(t nil)))
(defun translate-char-key1-to-key2 (char key1 key2)
(cond ((upper-char-p char)
(translate-upper-char-key1-to-key2 char key1 key2))
((lower-char-p char)
(translate-lower-char-key1-to-key2 char key1 key2))
(t char)))
(defun involve-atom-p (c)
(intern (involve-char-p (string c))))
(defun replace-key1-to-key2 (l key1 key2)
(cond ((null l) nil)
((and (not (listp l))
(or (upper-char-p l)
(lower-char-p l)))
(translate-char-key1-to-key2 l key1 key2))
((atom l) l)
(t (cons (replace-key1-to-key2 (car l) key1 key2)
(replace-key1-to-key2 (cdr l) key1 key2)))))
(defun get-function-of-C () (cdr (fget-frame 'C)))
(defun get-function-of-Am () (cdr (fget-frame 'Am)))
(defun get-function-of-CM7 () (cdr (fget-frame 'CM7)))
(defun get-function-of-Am7 () (cdr (fget-frame 'Am7)))
(defun get-function-of-C7 () (cdr (fget-frame 'C7)))
(defun get-function-of-C6 () (cdr (fget-frame 'C6)))
(defun get-function-of-Am6 () (cdr (fget-frame 'Am6)))
(defun get-function-of-Am7-5 () (cdr (fget-frame 'Am7-5)))
(defun get-function-of-AmM7 () (cdr (fget-frame 'AmM7)))
(defun get-function-of-A+M7 () (cdr (fget-frame 'A+M7)))
(defun get-function-of- (chord)
(replace-key1-to-key2 (get-function-of-C) 'C (involve-atom-p chord)))
(defun get-function-of-m (chord)
(replace-key1-to-key2 (get-function-of-Am) 'a (involve-atom-p chord)))
(defun get-function-of-M7 (chord)
(replace-key1-to-key2 (get-function-of-CM7) 'C (involve-atom-p chord)))
(defun get-function-of-m7 (chord)
(replace-key1-to-key2 (get-function-of-Am7) 'a (involve-atom-p chord)))
(defun get-function-of-7 (chord)
(replace-key1-to-key2 (get-function-of-C7) 'C (involve-atom-p chord)))
(defun get-function-of-6 (chord)
(replace-key1-to-key2 (get-function-of-C6) 'C (involve-atom-p chord)))
(defun get-function-of-m6 (chord)
(replace-key1-to-key2 (get-function-of-Am6) 'a (involve-atom-p chord)))
(defun get-function-of-m7-5 (chord)
(replace-key1-to-key2 (get-function-of-Am7-5) 'a (involve-atom-p chord)))
(defun get-function-of-mM7 (chord)
(replace-key1-to-key2 (get-function-of-AmM7) 'a (involve-atom-p chord)))
(defun get-function-of-+M7 (chord)
(replace-key1-to-key2 (get-function-of-A+M7) 'a (involve-atom-p chord)))
;;;
;;; (get-function-of-chord 'CM7)
;;;
(defun get-function-of-chord (chord)
(cond ((search-s1-in-s2 "m7-5" (string chord)) (get-function-of-m7-5 chord))
((search-s1-in-s2 "mM7" (string chord)) (get-function-of-mM7 chord))
((search-s1-in-s2 "+M7" (string chord)) (get-function-of-+M7 chord))
((search-s1-in-s2 "M7" (string chord)) (get-function-of-M7 chord))
((search-s1-in-s2 "m7" (string chord)) (get-function-of-m7 chord))
((search-s1-in-s2 "m6" (string chord)) (get-function-of-m6 chord))
((search-s1-in-s2 "m" (string chord)) (get-function-of-m chord))
((search-s1-in-s2 "7" (string chord)) (get-function-of-7 chord))
((search-s1-in-s2 "6" (string chord)) (get-function-of-6 chord))
(t (get-function-of- chord))))
;;;
;;; c:\\progra files\\acl62\\music4.cl
;;;
(load "c:\\program files\\acl62\\music3.cl")
(make-frame-from-list
'(c-major (T-key (value C))
(p-m-key-of-SD-key (value d))
(p-m-key-of-D-key (value e))
(SD-key (value F))
(D-key (value G))
(p-m (value a))))
(make-frame-from-list
'(c-minor (T-key (value c))
(p-M-key-of-SD-key (value -E))
(SD-key (value f))
(D-key (value g))
(p-M-key-of-SD-key (value -A))
(p-M-key-of-D-key (value -B))))
(defun get-related-key-of-major-key (c)
(replace-key1-to-key2 (cdr (fget-frame 'c-major)) 'C c))
(defun get-related-key-of-minor-key (c)
(replace-key1-to-key2 (cdr (fget-frame 'c-minor)) 'c c))
;;;
;;; (get-related-key 'C)
;;;
(defun get-related-key (c)
(cond ((upper-char-p c) (get-related-key-of-major-key c))
((lower-char-p c) (get-related-key-of-minor-key c))))
;;; ;;;***************************************************************************************** ;;;
(make-frame-from-list
'(DC1 (G7 (value ("Em7" phr) ("Am7" aeo) ("Em7-5" loc) ("Am7-5" loc)
("+Fm7-5" loc) ("-EM7" lyd) ("-AM7" lyd) ("-DM7" lyd)))))
(make-frame-from-list
'(DC2 (G7 (value ("-BM7" lyd) (("-EM7" lyd) ("-AM7" lyd) ("-DM7" lyd) ("CM7" ion))))))
(make-frame-from-list
'(DC3 (G7 (value ("-B7" lyd-7) (("A7" lyd-7) ("-A7" lyd-7)
("G7" mix lyd-7 hmp5 alt comd wt) ("CM7" ion))))))
(make-frame-from-list
'(DC4 (G7 (value ("-Em7" dor) (("-A7" lyd-7) ("Dm7" dor)
("G7" mix lyd-7 hmp5 alt comd wt) ("CM7" ion))))))
;;;
;;;
;;;
(defun get-DC1-of-G7 () (fget-i 'DC1 'G7))
(defun get-DC2-of-G7 () (fget-i 'DC2 'G7))
(defun get-DC3-of-G7 () (fget-i 'DC3 'G7))
(defun get-DC4-of-G7 () (fget-i 'DC4 'G7))
(defun translate-dominant-atom (c)
(case c
(G 'C)
(+G '+C)(-A '-D)
(A 'D)
(+A '+D)(-B '-E)
(B 'E)
(C 'F)
(+C '+F)(-D '-G)
(D 'G)
(+D '+G)(-E '-A)
(E 'A)
(F '-B)
(+F 'B)(-G 'B)))
(defun get-DC1 (dominant-chord)
(modulate-key1-to-key2 (get-DC1-of-G7)
'C
(translate-dominant-atom (involve-atom-p dominant-chord))))
(defun get-DC2 (dominant-chord)
(modulate-key1-to-key2 (get-DC2-of-G7)
'C
(translate-dominant-atom (involve-atom-p dominant-chord))))
(defun get-DC3 (dominant-chord)
(modulate-key1-to-key2 (get-DC3-of-G7)
'C
(translate-dominant-atom (involve-atom-p dominant-chord))))
(defun get-DC4 (dominant-chord)
(modulate-key1-to-key2 (get-DC4-of-G7)
'C
(translate-dominant-atom (involve-atom-p dominant-chord))))
;;;
;;; (get-DC "G7" 1)
;;;
(defun get-DC (dominant-chord &optional (n 1))
(case n (1 (get-DC1 dominant-chord))
(2 (get-DC2 dominant-chord))
(3 (get-DC3 dominant-chord))
(4 (get-DC4 dominant-chord))))
;;;
;;; 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)))))
;;;
;;; c:\\program files\\acl62\\music7.cl
;;;
(load "c:\\program files\\acl62\\music6.cl")
(make-frame-from-list
'(CP-of-CM (pat1 (value ("CM7" ion) ("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat2 (value ("CM7" ion) ("FM7" lyd) ("CM7" ion)))
(pat3 (value ("CM7" ion) ("FM7" lyd)
("G7" mix lyd-7 alt comd wt) ("CM" ion)))
(pat4 (value ("CM7" ion) ("Am7" aeo) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat5 (value ("CM7" ion) ("Cdim7" dim) ("G7" mix lyd-7 alt comd wt)))
(pat6 (value ("CM7" ion) ("Gdim7" dim)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat7 (value ("CM7" ion) ("+Cdim7" dim) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat8 (value ("CM7" ion) ("Am7" aeo) ("D7" mix lyd-7 alt comd wt)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat9 (value ("CM7" ion) ("Cdim7" dim) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat10 (value ("CM7" ion) ("BM7" ion) ("CM7" ion)))
(pat11 (value ("CM7" ion) ("Gaug7" mix) ("CM7" ion)))
(pat12 (value ("CM7" ion) ("Cdim7" dim) ("CM7" ion)
("D7" mix lyd-7 alt comd wt) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat13 (value ("CM7" ion) ("A7" mix lyd-7 alt comd wt)
("D7" mix lyd-7 alt comd wt)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat14 (value ("CM7" ion) ("D7" mix lyd-7 alt comd wt)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat15 (value ("CM7" ion) ("FM7" lyd) ("CM7" ion)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat16 (value ("CM7" ion) ("C7" mix lyd-7 alt comd wt)
("FM7" lyd) ("Fm7" dor) ("CM7" ion)))
(pat17 (value ("CM7" ion) ("Fm7" dor) ("G7" mix lyd-7 alt comd wt)
("CM7" ion)))
(pat18 (value ("CM7" ion) ("F7" lyd-7) ("CM7" ion)))
(pat19 (value ("CM7" ion) ("-B7" lyd-7) ("CM7" ion)))
(pat20 (value ("CM7" ion) ("Gm7" dor) ("A7" mix lyd-7 alt comd wt)
("D7" mix lyd-7 alt comd wt) ("G7" mix lyd-7 alt comd wt)
("CM7" ion)))
(pat21 (value ("CM7" ion) ("B7" alt) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat22 (value ("CM7" ion) ("A7" lyd-7 hmp5 alt comd wt)
("Dm7" dor) ("B7" alt) ("Em7" phr)
("C7" mix lyd-7 alt comd wt) ("FM7" lyd)))
(pat23 (value ("CM7" ion) ("C7" mix lyd-7 hmp5 alt comd wt)
("Am7" aeo) ("+Cdim7" dim)
("G7" mix lyd-7 alt comd wt)))
(pat24 (value ("CM7" ion) ("E7" mix lyd-7 alt comd wt)
("A7" mix lyd-7 alt comd wt) ("Dm7" dor)))
(pat25 (value ("CM7" ion) ("-E7" lyd-7) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat26 (value ("CM7" ion) ("B7" alt) ("E7" mix lyd-7 alt comd wt)
("A7" lyd-7 hmp5 alt comd wt) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat27 (value ("CM7" ion) ("Em7" phr) ("Am7" aeo)
("C7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)))
(pat28 (value ("CM7" ion) ("Caug7" ion) ("Am7" aeo)
("C7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)))
(pat29 (value ("CM7" ion) ("Am7" aeo) ("-A7" lyd-7)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat30 (value ("CM7" ion) ("Dm7" dor) ("Em7" phr)
("Dm7" dor) ("CM7" ion)))
(pat31 (value ("CM7" ion) ("C7" mix lyd-7 alt comd wt) ("F7" lyd-7)
("CM7" ion) ("-AM7" lyd)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat32 (value ("CM7" ion) ("Dm7" dor) ("E7" mix lyd-7 alt comd wt)
("A7" mix lyd-7 alt comd wt) ("Cm" all)
("D7" mix lyd-7 alt comd wt) ("G7" mix lyd-7 alt comd wt)))
(pat33 (value ("CM7" ion) ("C7" lyd-7) ("B7" lyd-7) ("-B7" lyd-7)
("A7" mix lyd-7 alt comd wt) ("D7" mix lyd-7 alt comd wt)
("G7" mix lyd-7 alt comd wt)))
(pat34 (value ("CM7" ion) ("-Em7" dor) ("Dm7" dor)
("-D7" lyd-7) ("CM7" ion)))
(pat35 (value ("CM7" ion) ("-E7" lyd-7) ("D7" lyd-7) ("-D7" lyd-7)
("CM7" ion)))
(pat36 (value ("CM7" ion) ("-A7" lyd-7) ("G7" mix lyd-7 alt comd wt)
("CM7" ion)))
(pat37 (value ("CM7" ion) ("Em7" phr) ("Am7" aeo) ("+Cdim7" dim)
("Dm7" dor) ("G7" mix lyd-7 alt comd wt)))
(pat38 (value ("CM7" ion) ("-A7" lyd-7) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat39 (value ("CM7" ion) ("-A7" lyd-7) ("CM7" ion) ("Cdim7" dim)
("Dm7" dor) ("G7" mix lyd-7 alt comd wt)))
(pat40 (value ("CM7" ion) ("Cm" all) ("Gm7" phr)
("A7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat41 (value ("C7" mix lyd-7 alt comd wt) ("FM7" lyd)
("D7" mix lyd-7 alt comd wt) ("G7" mix lyd-7 alt comd wt)))
(pat42 (value ("C7" lyd-7 hmp5 alt comd wt) ("Cdim7" dim)
("C7" lyd-7 hmp5 alt comd wt) ("D7" mix lyd-7 alt comd wt)
("Fm7" dor) ("G7" mix lyd-7 alt comd wt)))
(pat43 (value ("C7" mix lyd-7 alt comd wt) ("FM7" lyd) ("Fm7" dor)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat44 (value ("D7" mix lyd-7 alt comd wt) ("Fm7" dor)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat45 (value ("Dm7" dor) ("G7" mix lyd-7 alt comd wt) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat46 (value ("Dm7" dor) ("-D7" lyd-7) ("CM7" ion)))
(pat47 (value ("D7" mix lyd-7 alt comd wt) ("Fm7" dor)
("Em7" phr) ("A7" lyd-7 hmp5 alt comd wt)
("Dm7" dor) ("G7" mix lyd-7 alt comd wt)))
(pat48 (value ("Dm7" dor) ("A7" lyd-7 hmp5 alt comd wt)
("-B7" lyd-7) ("A7" lyd-7 hmp5 alt comd wt) ("Dm7" dor)
("Fm7" dor) ("G7" mix lyd-7 alt comd wt)))
(pat49 (value ("Em7" phr) ("B7" alt) ("Em7" phr)
("G7" mix lyd-7 alt comd wt)))
(pat50 (value ("Em7" phr) ("B7" alt) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat51 (value ("Em7" phr) ("A7" mix lyd-7 alt comd wt)
("D7" mix lyd-7 alt comd wt) ("G7" mix lyd-7 alt comd wt)
("CM7" ion)))
(pat52 (value ("Em7" phr) ("Am7" aeo) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat53 (value ("Em7" phr) ("-Em7" dor) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat54 (value ("E7" mix lyd-7 alt comd wt) ("A7" mix lyd-7 alt comd wt)
("D7" mix lyd-7 alt comd wt) ("G7" mix lyd-7 alt comd wt)
("CM7" ion)))
(pat55 (value ("E7" lyd-7 hmp5 alt comd wt) ("Am7" aeo)
("D7" mix lyd-7 alt comd wt) ("G7" mix lyd-7 alt comd wt)))
(pat56 (value ("E7" lyd-7) ("-E7" lyd-7) ("D7" mix lyd-7 alt comd wt)
("G7" mix lyd-7 alt comd wt)))
(pat57 (value ("EM7" ion) ("+Fm7" dor) ("B7" alt) ("EM7" ion)))
(pat58 (value ("FM7" lyd) ("E7" lyd-7 hmp5 alt comd wt) ("Am7" aeo)))
(pat59 (value ("FM7" lyd) ("B7" alt) ("CM7" ion)
("A7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat60 (value ("FM7" lyd) ("Fm7" dor) ("CM7" ion) ("Am7" aeo)
("D7" mix lyd-7 alt comd wt) ("G7" mix lyd-7 alt comd wt)))
(pat61 (value ("FM7" lyd) ("Fm7" dor) ("CM7" ion)
("A7" lyd-7 hmp5 alt comd wt) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat62 (value ("Fm7" dor) ("G7" mix lyd-7 alt comd wt) ("Em7" phr)
("Am7" aeo)))
(pat63 (value ("FM7" lyd) ("E7" lyd-7 hmp5 alt comd wt) ("Am7" aeo)
("Cdim7" dim) ("G7" mix lyd-7 alt comd wt)
("+Cdim7" dim) ("Dm7" dor)))
(pat64 (value ("Fm7" dor) ("G7" mix lyd-7 alt comd wt)
("Gdim7" dim) ("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat65 (value ("F7" lyd-7) ("CM7" ion) ("-A7" lyd-7)
("G7" mix lyd-7 alt comd wt)))
(pat66 (value ("Fm7" dor) ("CM7" ion) ("Em7" phr) ("Am7" aeo)))
(pat67 (value ("GM7" ion) ("Am7" aeo) ("D7" mix lyd-7 alt comd wt)
("G7" mix lyd-7 alt comd wt)))
(pat68 (value ("Gm7" phr) ("A7" lyd-7 alt comd wt) ("Fm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat69 (value ("G7" mix lyd-7 alt comd wt) ("-Edim7" dim)
("G7" mix lyd-7 alt comd wt) ("GM7" ion) ("CM7" ion)))
(pat70 (value ("Gm7" dor) ("C7" mix lyd-7 hmp5 alt comd wt)
("Gm7" dor) ("C7" mix lyd-7 hmp7 alt comd wt)))
(pat71 (value ("Am7" aeo) ("B7" alt) ("EM7" ion)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat72 (value ("Am7" aeo) ("Em7" phr) ("Dm7" dor) ("CM7" ion)))
(pat73 (value ("Am7" aeo) ("B7" alt) ("Em7" phr)
("A7" lyd-7 hmp5 alt comd wt) ("Dm7" dor)))
(pat74 (value ("Am7" aeo) ("E7" mix lyd-7 alt comd wt) ("Gm7" phr)
("A7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat75 (value ("Am7" aeo) ("Caug" ion) ("CM7" ion)))
(pat76 (value ("-AM7" lyd) ("G7" mix lyd-7 hmp5 alt comd wt) ("Em7" phr)
("Am7" aeo)))
(pat77 (value ("-AM7" lyd) ("-Bm7" dor) ("-E7" mix lyd-7 alt comd wt)
("-AM7" lyd) ("G7" mix lyd-7 alt comd wt) ("CM7" ion)))
(pat78 (value ("B7" alt) ("Em7" phr) ("D7" mix lyd-7 alt comd wt)
("G7" mix lyd-7 alt comd wt)))
(pat79 (value ("CM7" ion) ("A7" lyd-7 hmp5 alt comd wt) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat80 (value ("CM7" ion) ("C7" mix lyd-7 alt comd wt) ("FM7" lyd)
("Fm7" dor)))
(pat81 (value ("CM7" ion) ("C7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("-B7" lyd-7) ("CM7" ion)))
(pat82 (value ("CM7" ion) ("C7" lyd-7 alt comd wt) ("FM7" lyd) ("+Fdim7" dim)
("CM7" ion)))
(pat83 (value ("CM7" ion) ("FM7" lyd) ("Fm7" dor) ("-B7" lyd-7) ("CM7" ion)))
(pat84 (value ("CM7" ion) ("FM7" lyd) ("Em7" phr)
("A7" lyd-7 hmp5 alt comd wt) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat85 (value ("CM7" ion) ("F7" lyd-7) ("Em7" phr)
("A7" lyd-7 hmp5 alt comd wt) ("Dm7" dor)
("G7" mix lyd-7 alt comd wt)))
(pat86 (value ("CM7" ion) ("FM7" lyd) ("Em7" phr) ("-E7" lyd-7)
("Dm7" dor) ("G7" mix lyd-7 alt comd wt)))
(pat87 (value ("CM7" ion) ("F7" lyd-7) ("Em7" phr) ("-E7" lyd-7)
("Dm7" dor) ("G7" mix lyd-7 alt comd wt)))
(pat88 (value ("CM7" ion) ("Dm7" dor) ("Em7" phr) ("Dm7" dor) ("CM7" ion)))
(pat89 (value ("CM7" ion) ("FM7" lyd) ("Em7" phr) ("Dm7" dor) ("CM7" ion)))
(pat90 (value ("CM7" ion) ("Dm7" dor) ("Em7" phr) ("FM7" lyd) ("Em7" phr)
("Dm7" dor) ("CM7" ion)))
(pat91 (value ("CM7" ion) ("-E7" mix lyd-7 alt comd wt) ("-AM7" lyd)
("-DM7" lyd) ("CM7" ion)))
(pat92 (value ("CM7" ion) ("GM7" mix) ("FM7" lyd) ("GM7" mix)
("CM7" ion)))))
(defun select-patn-of-CP-CM-at-random ()
(nth (random 92)
'(pat1 pat2 pat3 pat4 pat5 pat6 pat7 pat8 pat9 pat10
pat11 pat12 pat13 pat14 pat15 pat16 pat17 pat18 pat19 pat20
pat21 pat22 pat23 pat24 pat25 pat26 pat27 pat28 pat29 pat30
pat31 pat32 pat33 pat34 pat35 pat36 pat37 pat38 pat39 pat40
pat41 pat42 pat43 pat44 pat45 pat46 pat47 pat48 pat49 pat50
pat51 pat52 pat53 pat54 pat55 pat56 pat57 pat58 pat59 pat60
pat61 pat62 pat63 pat64 pat65 pat66 pat67 pat68 pat69 pat70
pat71 pat72 pat73 pat74 pat75 pat76 pat77 pat78 pat79 pat80
pat81 pat82 pat83 pat84 pat85 pat86 pat87 pat88 pat89 pat90
pat91 pat92)))
(defun get-CP-CM-at-random ()
(fget-i 'CP-of-CM (select-patn-of-CP-CM-at-random)))
(defun get-CPM-with-key-at-random (key)
(modulate-key1-to-key2 (get-CP-CM-at-random) 'C key))
(defun get-CPM-at-random ()
(get-CPM-with-key-at-random (select-key-at-random)))
;;;
;;;
;;;
(defun my-randomize ()
(tagbody
loop
(format t "~% Enter an integer! ~%")
(setf *seed* (read))
(if (numberp *seed*)
(go exit)
(go loop))
exit
(setf *seed* (floor (abs *seed*) 1.0))
(do ((i *seed* (1- i)))
((<= i 0))
(random 10))))
;;;
;;; c:\\progra files\\acl62\\music8.cl
;;;
(load "c:\\program files\\acl62\\music7.cl")
(make-frame-from-list
'(CP-of-Cm (pat1 (value ("Cm" all) ("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat2 (value ("Cm" all) ("Fm7" dor) ("Cm" all)))
(pat3 (value ("Cm" all) ("Fm7" dor) ("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat4 (value ("Cm" all) ("-AM7" lyd) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat5 (value ("Cm" all) ("Cdim7" dim)
("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat6 (value ("Cm" all) ("Gdim7" dim) ("G7" lyd-7 hmp5 alt comd wt)
("Cm" all)))
(pat7 (value ("Cm" all) ("+Cdim7" dim) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat8 (value ("Cm" all) ("-AM7" lyd) ("D7" mix lyd-7 alt comd wt)
("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat9 (value ("Cm" all) ("Cdim7" dim) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat10 (value ("Cm" all) ("Gaug" ion) ("Cm" all)))
(pat11 (value ("Cm" all) ("Cdim7" dim) ("Cm" all)
("D7" mix lyd-7 hmp5 alt comd wt) ("Fm7" dor) ("Cm" all)))
(pat12 (value ("Cm" all) ("D7" mix lyd-7 hmp5 alt comd wt)
("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat13 (value ("Cm" all) ("Fm7" dor) ("Cm" all) ("G7" lyd-7 hmp5 alt comd wt)
("Cm" all)))
(pat14 (value ("Cm" all) ("C7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("Cm" all)))
(pat15 (value ("Cm" all) ("F7" lyd-7) ("Cm" all)))
(pat16 (value ("Cm" all) ("-B7" mix) ("Cm" all)))
(pat17 (value ("Cm" all) ("Gm7" phr) ("-A7" lyd-7)
("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat18 (value ("Cm" all) ("-B7" mix) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat19 (value ("Cm" all) ("-A7" lyd-7) ("Fm7" dor) ("-B7" mix)
("-EM7" lyd ion) ("Caug" ion) ("Fm7" dor)))
(pat20 (value ("Cm" all) ("-AM7" lyd) ("+Cdim7" dim)
("G7" lyd-7 hmp5 alt comd wt)))
(pat21 (value ("Cm" all) ("-E7" mix lyd-7 alt comd wt) ("-AM7" lyd)
("Fm7" dor)))
(pat22 (value ("Cm" all) ("-E7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat23 (value ("Cm" all) ("-B7" mix) ("-E7" mix lyd-7 alt comd wt)
("-A7" lyd-7) ("Fm7" dor) ("Cm" all)))
(pat24 (value ("Cm" all) ("-EM7" lyd ion) ("-AM7" lyd)
("C7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)))
(pat25 (value ("Cm" all) ("-AM7" lyd) ("C7" lyd-7 hmp5 alt comd wt)
("Fm7" dor)))
(pat26 (value ("Cm" all) ("-A7" lyd-7) ("G7" lyd-7 hmp5 alt comd wt)
("Cm" all)))
(pat27 (value ("Cm" all) ("Fm7" dor) ("-EM7" lyd ion) ("Fm7" dor) ("Cm" all)))
(pat28 (value ("Cm" all) ("C7" mix lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("Cm" all)))
(pat29 (value ("Cm" all) ("Fm7" dor) ("-E7" mix lyd-7 alt comd wt)
("-A7" lyd-7) ("Cm" all) ("D7" mix lyd-7 hmp5 alt comd wt)
("G7" lyd-7 hmo5 alt comd wt) ("Cm" all)))
(pat30 (value ("Cm" all) ("C7" lyd-7) ("B7" lyd-7) ("-B7" lyd-7)
("A7" mix lyd-7 hmp5 alt comd wt)
("D7" mix lyd-7 hmp5 alt comd wt)
("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat31 (value ("Cm" all) ("-Em7" dor) ("Dm7" dor) ("-D7" lyd-7) ("Cm" all)))
(pat32 (value ("Cm" all) ("-E7" lyd-7) ("D7" lyd-7) ("-D7" lyd-7) ("Cm" all)))
(pat33 (value ("Cm" all) ("-A7" lyd-7) ("Cm" all) ("Cdim7" dim) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat34 (value ("Cm" all) ("Gm7" phr) ("-A7" lyd-7) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat35 (value ("C7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("D7" mix lyd-7 hmp5 alt comd wt)
("G7" lyd-7 hmp5 alt comd wt)))
(pat36 (value ("C7" mix lyd-7 hmp5 alt comd wt) ("Cdim7" dim)
("C7" mix lyd-7 hmp5 alt comd wt)
("D7" mix lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat37 (value ("C7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat38 (value ("D7" mix lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat39 (value ("Fm7" dor) ("G7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat40 (value ("Fm7" dor) ("-D7" lyd-) ("Cm" all)))
(pat41 (value ("D7" lyd-7 hmp5 alt comd wt) ("Fm7" dor) ("-EM7" lyd ion)
("-A7" lyd-7) ("Fm7" dor) ("Cm" all)))
(pat42 (value ("Fm7" dor) ("-AM7" lyd) ("-B7" mix)
("A7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat43 (value ("-EM7" lyd ion) ("-B7" mix) ("-EM7" lyd ion)))
(pat44 (value ("-EM7" lyd ion) ("-B7" mix) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat45 (value ("-EM7" lyd ion) ("-A7" lyd-7)
("D7" mix lyd-7 hmp5 alt comd wt)
("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat46 (value ("-EM7" lyd ion) ("-AM7" lyd) ("Fm7" dor) ("Gaug" ion)
("Cm" all)))
(pat47 (value ("C7" lyd-7 hmp5 alt comd wt) ("-Em7" dor) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat48 (value ("-E7" mix lyd-7 hmp5 alt comd wt) ("-AM7" lyd)
("D7" lyd-7 hmp5 alt comd wt)))
(pat49 (value ("-EM7" lyd ion) ("Fm7" dor) ("-B7" mix) ("-EM7" lyd ion)))
(pat50 (value ("-EM7" lyd ion) ("Cm" all) ("Fm7" dor) ("-B7" mix)))
(pat51 (value ("-EM7" lyd ion) ("-AM7" lyd) ("-B7" mix) ("-EM7" lyd ion)
("C7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd) ("Cm" all)))
(pat52 (value ("Fm7" dor) ("-B7" mix) ("-AM7" lyd)))
(pat53 (value ("Fm7" dor) ("Cm" all) ("-A7" lyd-7) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat54 (value ("Fm7" dor) ("G7" lyd-7 hmp5 alt comd wt) ("-EM7" lyd ion)
("Fm7" dor)))
(pat55 (value ("Fm7" dor) ("-E7" mix lyd-7 hmp5 alt comd wt) ("-AM7" lyd)
("Cdim7" dim) ("G7" lyd-7 hmp5 alt comd wt)
("+Cdim7" dim) ("Fm7" dor)))
(pat56 (value ("Fm7" dor) ("G7" lyd-7 hmp5 alt comd wt) ("Gdim7" dim)
("G7" lyd-7 hmp5 alt comd wt) ("Cm" ion)))
(pat57 (value ("F7" lyd-7) ("Cm" all) ("-A7" lyd-7)
("G7" lyd-7 hmp5 alt comd wt)))
(pat58 (value ("Fm7" dor) ("Cm" all) ("-Em7" dor) ("-AM7" lyd)))
(pat59 (value ("Gm7" phr) ("-AM7" lyd) ("D7" mix lyd-7 hmp5 alt comd wt)
("G7" lyd-7 hmp5 alt comd wt)))
(pat60 (value ("Gm7" phr) ("-A7" lyd-7) ("Fm7" dor)))
(pat61 (value ("G7" lyd-7 hmp5 alt comd wt) ("-Edim7" dim)
("G7" lyd-7 hmp5 alt comd wt) ("Gaug" ion) ("Cm" all)))
(pat62 (value ("Gm7" phr) ("C7" lyd-7 hmp5 alt comd wt) ("Gm7" phr)
("C7" lyd-7 hmp5 alt comd wt)))
(pat63 (value ("-AM7" lyd) ("-B7" mix) ("-EM7" lyd ion)
("G7" lyd-7 hmp5 alt comd wt) ("Cm" all)))
(pat64 (value ("-AM7" lyd) ("-EM7" lyd ion) ("Fm7" dor) ("CM7" ion)))
(pat65 (value ("-AM7" lyd) ("-BM7" lyd) ("-Em7" dor) ("-AM7" lyd)
("Cm" all)))
(pat66 (value ("-AM7" lyd) ("-E7" mix lyd-7 hmp5 alt comd wt) ("Gm7" phr)
("-A7" lyd-7) ("G7" lyd-7 hmp5 alt comd wt)))
(pat67 (value ("-AM7" lyd) ("Gaug" ion) ("Cm" all)))
(pat68 (value ("-AM7" lyd) ("G7" lyd-7 hmp5 alt comd wt) ("-EM7" lyd ion)
("-AM7" lyd)))
(pat69 (value ("-AM7" lyd) ("-Bm7" dor) ("-E7" mix lyd-7 hmp5 alt comd wt)
("-AM7" lyd)))
(pat70 (value ("-B7" mix) ("-EM7" lyd ion) ("D7" mix lyd-7 hmp5 alt comd wt)
("G7" lyd-7 hmp5 alt comd wt)))
(pat71 (value ("Cm" all) ("Am7-5" loc) ("Dm7-5" loc)
("G7" lyd-7 hmp5 alt comd wt)))
(pat72 (value ("Cm" all) ("-EM7" lyd ion) ("Dm7-5" loc)
("G7" lyd-7 hmp5 alt comd wt)))
(pat73 (value ("Cm" all) ("A7" mix lyd-7 hmp5 alt comd wt)
("D7" mix lyd-7 hmp5 alt comd wt)
("G7" lyd-7 hmp5 alt comd wt)))
(pat74 (value ("Cm" all) ("C7" lyd-7 hmp5 alt comd wt) ("Fm7" dor)
("G7" lyd-7 hmp5 alt comd wt)))
(pat75 (value ("Cm" all) ("-B7" mix) ("-A7" lyd-7)
("G7" lyd-7 hmp5 alt comd wt)))
(pat76 (value ("Cm" all) ("Dm7-5" loc) ("-EM7" lyd ion) ("Dm7-5" loc)))
(pat77 (value ("Cm" all) ("-E7" mix lyd-7 hmp5 alt comd wt) ("-AM7" lyd)
("G7" lyd-7 hmp5 alt comd wt)))
(pat78 (value ("Cm" all) ("Fm7" dor) ("Dm7-5" loc)
("G7" lyd-7 hmp5 alt comd wt)))))
(defun select-patn-of-CP-Cm-at-random ()
(nth (random 78)
'(pat1 pat2 pat3 pat4 pat5 pat6 pat7 pat8 pat9 pat10
pat11 pat12 pat13 pat14 pat15 pat16 pat17 pat18 pat19 pat20
pat21 pat22 pat23 pat24 pat25 pat26 pat27 pat28 pat29 pat30
pat31 pat32 pat33 pat34 pat35 pat36 pat37 pat38 pat39 pat40
pat41 pat42 pat43 pat44 pat45 pat46 pat47 pat48 pat49 pat50
pat51 pat52 pat53 pat54 pat55 pat56 pat57 pat58 pat59 pat60
pat61 pat62 pat63 pat64 pat65 pat66 pat67 pat68 pat69 pat70
pat71 pat72 pat73 pat74 pat75 pat76 pat77 pat78)))
(defun get-CP-Cm-at-random ()
(fget-i 'CP-of-Cm (select-patn-of-CP-Cm-at-random)))
(defun get-CPm-with-key-at-random (key)
(modulate-key1-to-key2 (get-CP-Cm-at-random) 'C key))
(defun get-CPm-at-random ()
(get-CPm-with-key-at-random (select-key-at-random)))
(setf *w1* '((-E "When I Fall In Love")
("-EM7" ion "C7" hmp5) ("Fm7" dor "-B7" mix) ("-EM7" ion "C7" hmp5)
("Fm7" dor "-B7" mix)
("-EM7" ion) ("C7" alt) ("F7" lyd-7) ("-B7" mix)
("-EM7" ion) ("Fm7" dor "-B7" mix) ("-EM7" ion "C7" hmp5) ("Fm7" dor "C7" hmp5)
("Fm7" dor) ("C7" hmp5) ("Fm7" dor) ("-B7" mix)
("-EM7" ion "C7" hmp5) ("Fm7" dor "-B7" mix) ("-EM7" ion "C7" hmp5)
("Fm7" dor "-B7" mix)
("-EM7" ion) ("C7" alt) ("F7" lyd-7) ("-B7" mix)
("-EM7" ion) ("Am7-5" loc "D7" hmp5) ("Gm7" phr "C7" hmp5)
("Fm7" dor "-D7" lyd-7)
("Gm7" phr "C7" hmp5) ("Fm7" dor "-B7" mix)
("-EM7" ion "Edim7" dim) ("Fm7" dor "-B7" mix)
("-EM7" ion)))
;;;
;;; c:\\program files\\acl62\\music12.cl
;;;
(load "c:\\program files\\acl62\\music11")
;;;
;;; (tell-a-chord "CM7(13)") etc.
;;;
(defun tell-a-chord (scn)
(let ((cd (get-representative-chord scn)))
(format t "~%*********** ~a ************" scn)
(format t "~%Chord Tone ~a" (get-chord-tone scn))
(format t "~%Guide Tone ~a" (get-guide-tone scn))
(format t "~%UST ~a" (get-UST cd))
(format t "~%Function of Chord ~a" (if (search-s1-in-s2 "dim7" cd)
"nothing"
(get-function-of-chord cd)))
(format t "~%Tension Notes")
(show-tension-notes cd)
(format t "~%Chord Scales")
(show-scales cd)))
(defun get-scale-name-aux (scn)
(cond ((search-s1-in-s2 "dim7" scn)
(remove 'all (mapcar #'car (get-UST scn))))
(t (remove 'all (mapcar #'car (get-function-of-chord scn))))))
(defun get-scale-name (scn)
(mapcar #'(lambda (x) (list scn x)) (get-scale-name-aux scn)))
(defun show-scales (scn)
(let ((l (get-scale-name scn)))
(do ((lst l (cdr lst)))
((null lst))
(format t "~%~a ~a" (second (car lst)) (chord-scale (car lst))))))
(defun show-tension-notes (scn)
(let ((l (get-scale-name scn)))
(do ((lst l (cdr lst)))
((null lst))
(format t "~%~a ~a" (second (car lst)) (tension-note (car lst))))))
(defun representative-of-chord (scn)
(cond ((search-s1-in-s2 "7(+11 13)" scn) "7")
((search-s1-in-s2 "7(+9+11)" scn) "7")
((search-s1-in-s2 "7(-9+11)" scn) "7")
((search-s1-in-s2 "7(9+11)" scn) "7")
((search-s1-in-s2 "M7(+11)" scn) "M7")
((search-s1-in-s2 "mM7(11)" scn) "mM7")
((search-s1-in-s2 "mM7(13)" scn) "mM7")
((search-s1-in-s2 "7(+11)" scn) "7")
((search-s1-in-s2 "m7(11)" scn) "m7")
((search-s1-in-s2 "m7(13)" scn) "m7")
((search-s1-in-s2 "M7(13)" scn) "M7")
((search-s1-in-s2 "mM7(9)" scn) "mM7")
((search-s1-in-s2 "dimM7" scn) "dim7")
((search-s1-in-s2 "augM7" scn) "M7")
((search-s1-in-s2 "7sus4" scn) "7sus4")
((search-s1-in-s2 "(+11)" scn) "M7")
((search-s1-in-s2 "m(11)" scn) "m")
((search-s1-in-s2 "7(-9)" scn) "7")
((search-s1-in-s2 "madd9" scn) "m")
((search-s1-in-s2 "7(+9)" scn) "7")
((search-s1-in-s2 "7(13)" scn) "7")
((search-s1-in-s2 "m7(9)" scn) "m7")
((search-s1-in-s2 "M7(9)" scn) "M7")
((search-s1-in-s2 "sus4" scn) "7sus4")
((search-s1-in-s2 "dim7" scn) "dim7")
((search-s1-in-s2 "m7-5" scn) "m7-5")
((search-s1-in-s2 "aug7" scn) "7")
((search-s1-in-s2 "add9" scn) "M7")
((search-s1-in-s2 "7(9)" scn) "7")
((search-s1-in-s2 "aug" scn) "M7")
((search-s1-in-s2 "dim" scn) "dim7")
((search-s1-in-s2 "mM7" scn) "mM7")
((search-s1-in-s2 "m69" scn) "m7")
((search-s1-in-s2 "7-5" scn) "7")
((search-s1-in-s2 "-5" scn) "M7")
((search-s1-in-s2 "m7" scn) "m7")
((search-s1-in-s2 "M7" scn) "M7")
((search-s1-in-s2 "m6" scn) "m7")
((search-s1-in-s2 "69" scn) "M7")
((search-s1-in-s2 "m" scn) "m")
((search-s1-in-s2 "7" scn) "7")
((search-s1-in-s2 "6" scn) "M7")
(t "M7")))
(defun get-representative-chord (scn)
(concatenate 'string (string (involve-character-p scn)) (representative-of-chord scn))
;;;
;;; c:\\program files\\acl62\\music11.cl
;;;
(load "c:\\program files\\acl62\\music10.cl")
(defun translate-j-note-to-doremi (s-note)
(cond ((equal s-note "ド") 'do)
((equal s-note "#ド") '+do)
((equal s-note "♭レ") '+do)
((equal s-note "#レ") '+re)
((equal s-note "♭ミ") '+re)
((equal s-note "#ミ") 'fa)
((equal s-note "#ファ") '+fa)
((equal s-note "♭ソ") '+fa)
((equal s-note "#ソ") '+so)
((equal s-note "♭ラ") '+so)
((equal s-note "#ラ") '+la)
((equal s-note "♭シ") '+la)
((equal s-note "#シ") 'do)
((equal s-note "レ") 're)
((equal s-note "ミ") 'mi)
((equal s-note "ファ") 'fa)
((equal s-note "ソ") 'so)
((equal s-note "ラ") 'la)
((equal s-note "シ") 'si)))
(defun replace-j-note-with-doremi (lst)
(mapcar #'translate-j-note-to-doremi lst))
(defun replace-j-note-with-doremi-in-a-chord (s-cn)
(replace-j-note-with-doremi (get-chord-tone s-cn)))
(defun translate-flat-to-sharp (c)
(cond ((equal c '-do) 'si)
((equal c '-re) '+do)
((equal c '-mi) '+re)
((equal c '-fa) 'mi)
((equal c '-so) '+fa)
((equal c '-la) '+so)
((equal c '-si) '+la)
((equal c '+do) '+do)
((equal c '+re) '+re)
((equal c '+mi) 'fa)
((equal c '+fa) '+fa)
((equal c '+so) '+so)
((equal c '+la) '+la)
((equal c '+si) 'do)
((equal c 'do) 'do)
((equal c 're) 're)
((equal c 'mi) 'mi)
((equal c 'fa) 'fa)
((equal c 'so) 'so)
((equal c 'la) 'la)
((equal c 'si) 'si)
((equal c '--do) '+la)
((equal c '++do) 're)
((equal c '--re) 'do)
((equal c '++re) 'mi)
((equal c '--mi) 're)
((equal c '++mi) '+fa)
((equal c '--fa) '+re)
((equal c '++fa) 'so)
((equal c '--so) 'fa)
((equal c '++so) 'la)
((equal c '--la) 'so)
((equal c '++la) 'si)
((equal c '--si) 'la)
((equal c '++si) '+do)))
(defun translate-flat-to-sharp-in-a-list (lst)
(mapcar #'translate-flat-to-sharp lst))
;;;
;;; (the-list-is-involved-in-a-chord '(do re mi) "CM7")
;;;
(defun the-list-is-involved-in-a-chord (lst s-cn)
(sub-set-p (translate-flat-to-sharp-in-a-list lst)
(replace-j-note-with-doremi-in-a-chord s-cn)))
(setf *chord-type* '("7" "M7" "mM7" "m7" "dimM7" "augM7" "7sus4" "sus4"
"dim7" "m7-5" "aug7" "aug" "dim" "-5" "m6" "69" "m69" "6" ""))
(defun C-chord (type) (concatenate 'string "C" type))
(defun get-C-chords () (mapcar #'C-chord *chord-type*))
(defun +C-chord (type) (concatenate 'string "+C" type))
(defun get-+C-chords () (mapcar #'+C-chord *chord-type*))
(defun -D-chord (type) (concatenate 'string "-D" type))
(defun get--D-chords () (mapcar #'-D-chord *chord-type*))
(defun D-chord (type) (concatenate 'string "D" type))
(defun get-D-chords () (mapcar #'D-chord *chord-type*))
(defun +D-chord (type) (concatenate 'string "+D" type))
(defun get-+D-chords () (mapcar #'+D-chord *chord-type*))
(defun -E-chord (type) (concatenate 'string "-E" type))
(defun get--E-chords () (mapcar #'-E-chord *chord-type*))
(defun E-chord (type) (concatenate 'string "E" type))
(defun get-E-chords () (mapcar #'E-chord *chord-type*))
(defun F-chord (type) (concatenate 'string "F" type))
(defun get-F-chords () (mapcar #'F-chord *chord-type*))
(defun +F-chord (type) (concatenate 'string "+F" type))
(defun get-+F-chords () (mapcar #'+F-chord *chord-type*))
(defun -G-chord (type) (concatenate 'string "-G" type))
(defun get--G-chords () (mapcar #'-G-chord *chord-type*))
(defun G-chord (type) (concatenate 'string "G" type))
(defun get-G-chords () (mapcar #'G-chord *chord-type*))
(defun +G-chord (type) (concatenate 'string "+G" type))
(defun get-+G-chords () (mapcar #'+G-chord *chord-type*))
(defun -A-chord (type) (concatenate 'string "-A" type))
(defun get--A-chords () (mapcar #'-A-chord *chord-type*))
(defun A-chord (type) (concatenate 'string "A" type))
(defun get-A-chords () (mapcar #'A-chord *chord-type*))
(defun +A-chord (type) (concatenate 'string "+A" type))
(defun get-+A-chords () (mapcar #'+A-chord *chord-type*))
(defun -B-chord (type) (concatenate 'string "-B" type))
(defun get--B-chords () (mapcar #'-B-chord *chord-type*))
(defun B-chord (type) (concatenate 'string "B" type))
(defun get-B-chords () (mapcar #'B-chord *chord-type*))
;;;
;;;
;;;
(defun get-C-chords-which-involve-the-list (lst)
(do ((l (get-C-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-+C-chords-which-involve-the-list (lst)
(do ((l (get-+C-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get--D-chords-which-involve-the-list (lst)
(do ((l (get--D-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-D-chords-which-involve-the-list (lst)
(do ((l (get-D-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-+D-chords-which-involve-the-list (lst)
(do ((l (get-+D-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get--E-chords-which-involve-the-list (lst)
(do ((l (get--E-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-E-chords-which-involve-the-list (lst)
(do ((l (get-E-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-F-chords-which-involve-the-list (lst)
(do ((l (get-F-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-+F-chords-which-involve-the-list (lst)
(do ((l (get-+F-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get--G-chords-which-involve-the-list (lst)
(do ((l (get--G-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-G-chords-which-involve-the-list (lst)
(do ((l (get-G-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-+G-chords-which-involve-the-list (lst)
(do ((l (get-+G-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get--A-chords-which-involve-the-list (lst)
(do ((l (get--A-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-A-chords-which-involve-the-list (lst)
(do ((l (get-A-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-+A-chords-which-involve-the-list (lst)
(do ((l (get-+A-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get--B-chords-which-involve-the-list (lst)
(do ((l (get--B-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
(defun get-B-chords-which-involve-the-list (lst)
(do ((l (get-B-chords) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-chord lst (car l))
(push (car l) w)))))
;;;
;;; (get-chords-which-involve-the-notes '(+fa +la +do fa)) ===> ("+FM7" "-GM7")
;;;
(defun get-chords-which-involve-the-notes (lst)
(append (get-C-chords-which-involve-the-list lst)
(get-+C-chords-which-involve-the-list lst)
(get--D-chords-which-involve-the-list lst)
(get-D-chords-which-involve-the-list lst)
(get-+D-chords-which-involve-the-list lst)
(get--E-chords-which-involve-the-list lst)
(get-E-chords-which-involve-the-list lst)
(get-F-chords-which-involve-the-list lst)
(get-+F-chords-which-involve-the-list lst)
(get--G-chords-which-involve-the-list lst)
(get-G-chords-which-involve-the-list lst)
(get-+G-chords-which-involve-the-list lst)
(get--A-chords-which-involve-the-list lst)
(get-A-chords-which-involve-the-list lst)
(get-+A-chords-which-involve-the-list lst)
(get--B-chords-which-involve-the-list lst)
(get-B-chords-which-involve-the-list lst)))
;;;
;;; c:\\program files\\acl62\\music13.cl
;;;
(load "c:\\program files\\acl62\\music12.cl")
;;;
;;; (the-list-is-involved-in-a-scale '(do re mi fa so la si do) '(C ion))
;;;
(defun the-list-is-involved-in-a-scale (lst pair)
(sub-set-p (translate-flat-to-sharp-in-a-list lst)
(replace-j-note-with-doremi (get-chordscale (first pair) (second pair)))))
(setf *scales* '(ion dor phr lyd mix aeo loc n h m all dor-2 loc+2
lyd-7 hmp5 mmp5 alt comd dim wt mixsus4 mix-6))
(defun C-scale (type) (list 'C type))
(defun get-C-scales () (mapcar #'C-scale *scales*))
(defun +C-scale (type) (list '+C type))
(defun get-+C-scales () (mapcar #'+C-scale *scales*))
(defun -D-scale (type) (list '-D type))
(defun get--D-scales () (mapcar #'-D-scale *scales*))
(defun D-scale (type) (list 'D type))
(defun get-D-scales () (mapcar #'D-scale *scales*))
(defun +D-scale (type) (list '+D type))
(defun get-+D-scales () (mapcar #'+D-scale *scales*))
(defun -E-scale (type) (list '-E type))
(defun get--E-scales () (mapcar #'-E-scale *scales*))
(defun E-sacle (type) (list 'E type))
(defun get-E-scales () (mapcar #'E-sacle *scales*))
(defun F-scale (type) (list 'F type))
(defun get-F-scales () (mapcar #'F-scale *scales*))
(defun +F-scale (type) (list '+F type))
(defun get-+F-scales () (mapcar #'+F-scale *scales*))
(defun -G-scale (type) (list '-G type))
(defun get--G-scales () (mapcar #'-G-scale *scales*))
(defun G-scale (type) (list 'G type))
(defun get-G-scales () (mapcar #'G-scale *scales*))
(defun +G-scale (type) (list '+G type))
(defun get-+G-scales () (mapcar #'+G-scale *scales*))
(defun -A-scale (type) (list '-A type))
(defun get--A-scales () (mapcar #'-A-scale *scales*))
(defun A-scale (type) (list 'A type))
(defun get-A-scales () (mapcar #'A-scale *scales*))
(defun +A-scale (type) (list '+A type))
(defun get-+A-scales () (mapcar #'+A-scale *scales*))
(defun -B-scale (type) (list '-B type))
(defun get--B-scales () (mapcar #'-B-scale *scales*))
(defun B-scale (type) (list 'B type)) (defun get-B-scales () (mapcar #'B-scale *scales*))
;;;
;;;
;;;
(defun get-C-scales-whitch-involve-the-list (lst)
(do ((l (get-C-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-+C-scales-whitch-involve-the-list (lst)
(do ((l (get-+C-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get--D-scales-whitch-involve-the-list (lst)
(do ((l (get--D-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-D-scales-whitch-involve-the-list (lst)
(do ((l (get-D-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-+D-scales-whitch-involve-the-list (lst)
(do ((l (get-+D-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get--E-scales-whitch-involve-the-list (lst)
(do ((l (get--E-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-E-scales-whitch-involve-the-list (lst)
(do ((l (get-E-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-F-scales-whitch-involve-the-list (lst)
(do ((l (get-F-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-+F-scales-whitch-involve-the-list (lst)
(do ((l (get-+F-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get--G-scales-whitch-involve-the-list (lst)
(do ((l (get--G-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-G-scales-whitch-involve-the-list (lst)
(do ((l (get-G-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-+G-scales-whitch-involve-the-list (lst)
(do ((l (get-+G-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get--A-scales-whitch-involve-the-list (lst)
(do ((l (get--A-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-A-scales-whitch-involve-the-list (lst)
(do ((l (get-A-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-+A-scales-whitch-involve-the-list (lst)
(do ((l (get-+A-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get--B-scales-whitch-involve-the-list (lst)
(do ((l (get--B-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
(defun get-B-scales-whitch-involve-the-list (lst)
(do ((l (get-B-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale lst (car l))
(push (car l) w)))))
;;;
;;; (get-scales-whitch-involve-the-notes '(do re mi fa so la si do))
;;;
(defun get-scales-whitch-involve-the-notes (lst)
(append (get-C-scales-whitch-involve-the-list lst)
(get-+C-scales-whitch-involve-the-list lst)
(get--D-scales-whitch-involve-the-list lst)
(get-D-scales-whitch-involve-the-list lst)
(get-+D-scales-whitch-involve-the-list lst)
(get--E-scales-whitch-involve-the-list lst)
(get-E-scales-whitch-involve-the-list lst)
(get-F-scales-whitch-involve-the-list lst)
(get-+F-scales-whitch-involve-the-list lst)
(get--G-scales-whitch-involve-the-list lst)
(get-G-scales-whitch-involve-the-list lst)
(get-+G-scales-whitch-involve-the-list lst)
(get--A-scales-whitch-involve-the-list lst)
(get-A-scales-whitch-involve-the-list lst)
(get-+A-scales-whitch-involve-the-list lst)
(get--B-scales-whitch-involve-the-list lst)
(get-B-scales-whitch-involve-the-list lst)))
;;;
;;; c:\\program files\\acl62\\music14.cl
;;;
(load "c:\\program files\\acl62\\music13.cl")
;;;
;;; (the-list-is-involved-in-a-scale-2 '(re la) '(C ion))
;;;
(defun the-list-is-involved-in-a-scale-2 (lst pair)
(sub-set-p (translate-flat-to-sharp-in-a-list lst)
(replace-j-note-with-doremi (get-tension-note (first pair) (second pair)))))
(setf *scales* '(ion dor phr lyd mix aeo loc n h m all dor-2
loc+2 lyd-7 hmp5 mmp5 alt comd dim wt mixsus4 mix-6))
;;;
;;;
;;;
(defun get-C-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-C-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-+C-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-+C-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get--D-scales-whitch-involve-the-list-2 (lst)
(do ((l (get--D-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-D-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-D-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-+D-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-+D-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get--E-scales-whitch-involve-the-list-2 (lst)
(do ((l (get--E-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-E-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-E-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-F-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-F-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-+F-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-+F-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get--G-scales-whitch-involve-the-list-2 (lst)
(do ((l (get--G-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-G-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-G-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-+G-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-+G-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get--A-scales-whitch-involve-the-list-2 (lst)
(do ((l (get--A-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-A-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-A-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-+A-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-+A-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get--B-scales-whitch-involve-the-list-2 (lst)
(do ((l (get--B-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
(defun get-B-scales-whitch-involve-the-list-2 (lst)
(do ((l (get-B-scales) (cdr l))
(w))
((null l) w)
(cond ((the-list-is-involved-in-a-scale-2 lst (car l))
(push (car l) w)))))
;;;
;;; (get-scales-whitch-involve-the-tension-notes '(re la))
;;;
(defun get-scales-whitch-involve-the-tension-notes (lst)
(append (get-C-scales-whitch-involve-the-list-2 lst)
(get-+C-scales-whitch-involve-the-list-2 lst)
(get--D-scales-whitch-involve-the-list-2 lst)
(get-D-scales-whitch-involve-the-list-2 lst)
(get-+D-scales-whitch-involve-the-list-2 lst)
(get--E-scales-whitch-involve-the-list-2 lst)
(get-E-scales-whitch-involve-the-list-2 lst)
(get-F-scales-whitch-involve-the-list-2 lst)
(get-+F-scales-whitch-involve-the-list-2 lst)
(get--G-scales-whitch-involve-the-list-2 lst)
(get-G-scales-whitch-involve-the-list-2 lst)
(get-+G-scales-whitch-involve-the-list-2 lst)
(get--A-scales-whitch-involve-the-list-2 lst)
(get-A-scales-whitch-involve-the-list-2 lst)
(get-+A-scales-whitch-involve-the-list-2 lst)
(get--B-scales-whitch-involve-the-list-2 lst)
(get-B-scales-whitch-involve-the-list-2 lst)))
;;;
;;; c:\\program files\\acl62\\work1.cl
;;;
;;;
;;; (auto-comp *w1*) etc.
;;;
(setf *w1* '((-E "When I Fall In Love")
("-EM7" ion "C7" alt) ("Fm7" dor "-B7" mix) ("-EM7" ion "C7" alt) ("Fm7" dor "-B7" mix)
("-EM7" ion) ("C7" alt) ("F7" lyd-7) ("-B7" mix) ("-EM7" ion) ("Fm7" dor "-B7" mix)
("-EM7" ion "-D7" lyd-7) ("Gm7" phr "C7" alt) ("Fm7" dor) ("C7" alt) ("Fm7" dor)
("-B7" mix) ("-EM7" ion "C7" alt) ("Fm7" dor "-B7" mix) ("-EM7" ion "C7" alt)
("Fm7" dor "-B7" mix) ("-EM7" ion) ("C7" alt) ("F7" lyd-7) ("-B7" mix) ("-EM7" ion)
("Am7-5" loc "D7" alt) ("Gm7" phr "C7" alt) ("Fm7" dor "-D7" lyd-7) ("Gm7" phr "C7" alt)
("Fm7" dor "-B7" mix) ("-EM7" ion "Edim7" dim) ("Fm7" dor "-B7" mix)))
(setf *w2* '((C "Laura")
("Am7" dor) ("D7" alt) ("GM7" ion) ("GM7" ion) ("Gm7" dor) ("C7" alt) ("FM7" ion)
("FM7" ion) ("Fm7" dor) ("-B7" alt) ("-EM7" ion) ("-EM7" ion) ("Am7-5" loc)
("D7" alt) ("GM7" ion) ("Bm7" phr "E7" alt) ("Am7" dor) ("D7" alt) ("GM7" ion)
("GM7" ion) ("Gm7" dor) ("C7" alt) ("FM7" ion) ("FM7" ion) ("Fm7" dor)
("Dm7-5" loc "G7" alt) ("CM7" ion) ("Am7" aeo) ("D7" lyd-7) ("Dm7-5" loc "G7" alt)
("-DM7" ion) ("CM7" ion)))
(setf *w3* '((F "Dindi")
("FM7" ion) ("-EM7" lyd) ("FM7" ion) ("Cm7" dor "F7" alt) ("-BM7" lyd)
("-E7" lyd-7) ("FM7" ion) ("-EM7" lyd) ("FM7" ion) ("-EM7" lyd) ("FM7" ion)
("Cm7" dor "F7" alt) ("-BM7" lyd) ("-E7" lyd-7) ("FM7" ion) ("Bm7-5" loc "E7" hmp5)
("Am7" all) ("E7" hmp5) ("Am7" all "E7" hmp5) ("Am7" all "D7" alt) ("Gm7" all)
("D7" hmp5) ("Gm7" all "D7" hmp5) ("Gm7" all "C7" alt) ("FM7" ion) ("-EM7" lyd)
("FM7" ion) ("Cm7" dor "F7" alt) ("-BM7" lyd) ("-E7" lyd-7) ("FM7" ion) ("-EM7" lyd)
("FM7" ion) ("-EM7" lyd) ("FM7" ion) ("-EM7" lyd)
("FM7" ion) ("FM7" ion) ("-EM7" lyd) ("-EM7" lyd)
("DM7" ion) ("DM7" ion) ("DM7" ion) ("DM7" ion)))
(setf *w4* '((G "Love")
("GM7" ion) ("GM7" ion) ("Am7" dor) ("D7" mix) ("D7" mix) ("D7" mix)
("GM7" ion) ("GM7" ion) ("GM7" ion) ("G7" mix) ("CM7" lyd) ("CM7" lyd)
("A7" lyd-7) ("A7" lyd-7) ("Am7" dor) ("D7" mix) ("GM7" ion) ("GM7" ion)
("Am7" dor) ("D7" mix) ("D7" mix) ("D7" mix) ("GM7" ion) ("GM7" ion)
("GM7" ion) ("G7" mix) ("CM7" lyd) ("+Cdim7" dim) ("GM7" ion) ("D7" mix)
("GM7" ion "+Gdim7" dim) ("Am7" dor "D7" mix) ("GM7" ion)
("GM7" ion) ("GM7" ion) ("GM7" ion)))
(setf *w5* '((c "Yesterdays")
("Cm" all) ("Dm7-5" loc "G7" alt) ("Cm" all) ("Dm7-5" loc "G7" alt) ("Cm" all)
("Cm7" all) ("Am7-5" loc) ("D7" alt) ("G7" alt) ("C7" alt) ("F7" alt) ("-B7" lyd-7)
("-E7" alt) ("-AM7" ion "G7" alt) ("Cm" all) ("Dm7-5" loc "G7" alt) ("Cm" all)
("Dm7-5" loc "G7" alt) ("Cm" all) ("Dm7-5" loc "G7" alt) ("Cm" all) ("Cm7" all)
("Am7-5" loc) ("D7" alt) ("G7" alt) ("C7" alt) ("F7" alt) ("-B7" lyd-7) ("-E7" alt)
("-AM7" ion "G7" alt) ("Cm" all) ("Dm7-5" loc "G7" alt) ("Cm" all "Am7-5" loc)
("Dm7-5" loc "G7" alt) ("Cm" all "Am7-5" loc) ("Dm7-5" loc "G7" alt)
("Cm" all "Am7-5" loc) ("Dm7-5" loc "G7" alt)
("Cm" all) ("Cm" all) ("Cm" all) ("Cm" all)))
(setf *w6* '((F "I'm Getting Sentimental Over You")
("FM7" ion) ("E7" alt) ("Am7-5" loc) ("D7" alt) ("G7" lyd-7) ("C7" mix)
("Am7" phr "D7" alt) ("Gm7" dor "C7" mix) ("FM7" ion) ("E7" alt) ("Am7-5" loc)
("D7" alt) ("G7" lyd-7) ("C7" mix) ("FM7" ion) ("Bm7-5" loc "E7" alt)
("Am" aeo) ("Am7" aeo) ("B7" alt) ("Dm7" dor) ("E7" alt) ("E7" alt)
("Am7" aeo "D7" alt) ("Gm7" dor "C7" mix) ("FM7" ion) ("E7" alt)
("Am7-5" loc) ("D7" alt) ("G7" lyd-7) ("C7" mix) ("Am7" aeo) ("D7" alt)
("G7" lyd-7) ("C7" mix) ("FM7" ion "+Fdim7" dim) ("Gm7" dor "C7" mix)
("FM7" ion) ("FM7" ion) ("FM7" ion) ("FM7" ion)))
;;;
;;; c:\\program files\\acl62\\music15.cl
;;;
(load "c:\\program files\\acl62\\music14.cl")
(defun make-lists-of-elements-except-one (lst)
(do ((l lst (cdr l)) (w))
((null l)
(remove-duplicate (reverse w)))
(push (list (car l) (remove (car l) lst)) w)))
(defun test (lst)
(format t "~%Tnesion~%~a" (get-scales-whitch-involve-the-tension-notes lst))
(format t "~%Scales~%~a" (get-scales-whitch-involve-the-notes lst))
(format t "~%Chords~%~a" (get-chords-which-involve-the-notes lst)))
(defun check-a-tension (note)
(get-scales-whitch-involve-the-tension-notes (list note)))
(defun get-chord-type-from-scale (scale)
(cond ((equal scale 'ion) "M7")
((equal scale 'dor) "m7")
((equal scale 'phr) "m7")
((equal scale 'lyd) "M7")
((equal scale 'mix) "7")
((equal scale 'aeo) "m7")
((equal scale 'loc) "m7-5")
((equal scale 'n) "m7")
((equal scale 'h) "m7")
((equal scale 'm) "m7")
((equal scale 'all) "m7")
((equal scale 'dor-2) "m7")
((equal scale 'loc+2) "m7-5")
((equal scale 'lyd-7) "7")
((equal scale 'hmp5) "7")
((equal scale 'mmp5) "7")
((equal scale 'alt) "7")
((equal scale 'comd) "7")
((equal scale 'dim) "dim7")
((equal scale 'wt) "7")
((equal scale 'mixsus4) "7sus4")
((equal scale 'mix-6) "7")))
;;;
;;; (get-chord-name-from-a-pair '(C ion))
;;;
(defun get-chord-name-from-a-pair (pair)
(concatenate 'string (string (first pair)) (get-chord-type-from-scale (second pair))))
(defun get-chord-names-from-pairs (lst)
(mapcar #'get-chord-name-from-a-pair lst))
(defun get-chord-names-with-a-tension (ten)
(remove-duplicate (get-chord-names-from-pairs (check-a-tension ten))))
(defun get-chord-names-with-a-chord-note (note)
(get-chords-which-involve-the-notes (list note)))
(defun get-chord-names-with-a-note (note)
(append (get-chord-names-with-a-tension note) (get-chord-names-with-a-chord-note note)))
(defun get-chord-names-with-notes (lst-of-notes)
(mapcar #'get-chord-names-with-a-note lst-of-notes))
(defun intersect-of-two-sets (l1 l2)
(do ((l l1 (cdr l)) (w))
((null l) w)
(if (member (car l) l2 :test #'equal)
(push (car l) w))))
(defun intersect-of-sets (lst)
(do* ((l lst (cdr l))
(w (first l)))
((null (rest l)) w)
(setf w (append (intersect-of-two-sets w (second l))))))
;;;
;;; ある音列に利用可能なコードの候補を列挙します
;;; ;;; (get-chords '(do re mi fa))
;;;
(defun get-chords (lst)
(format t "~%~a" (intersect-of-sets (get-chord-names-with-notes lst))))
(defun check-chords (lst)
(format t "~%~a" (get-chords-which-involve-the-notes lst)))
(defun check-tensions (lst)
(format t "~%~a"
(remove-duplicate (get-chord-names-from-pairs (get-scales-whitch-involve-the-tension-notes lst)))))
(defun check-scales (lst)
(format t "~%~a"
(remove-duplicate (get-chord-names-from-pairs (get-scales-whitch-involve-the-notes lst)))))
;;;
;;;
;;;
(defun identify-scales (lst)
(format t "~%~a" (get-scales-whitch-involve-the-notes lst)))
;;;
;;; c:\\program files\\acl62\\music16.cl
;;;
(load "c:\\program files\\acl62\\music15.cl")
;;;(get-chord-tone "CM7")
;;;(rotate-list-right '(a b c d) 2)
;;;(rotate-list-left '(a b c d) 3)
(defun get-figures-of-a-chord (chord-name)
(let ((lst (get-chord-tone chord-name)))
(list (rotate-list-right lst 0)
(rotate-list-right lst 1)
(rotate-list-right lst 2)
(rotate-list-right lst 3))))
(defun drop2-aux (lst)
(list (third lst) (list (first lst) (second lst) (fourth lst))))
(defun drop2 (chord-name)
(mapcar #'drop2-aux (get-figures-of-a-chord chord-name)))
(defun drop3-aux (lst)
(list (second lst) (list (first lst) (third lst) (fourth lst))))
(defun drop3 (chord-name)
(mapcar #'drop3-aux (get-figures-of-a-chord chord-name)))
(defun drop2&4-aux (lst)
(list (list (first lst) (third lst)) (list (second lst) (fourth lst))))
(defun drop2&4 (chord-name)
(mapcar #'drop2&4-aux (get-figures-of-a-chord chord-name)))
(defun drop1&4-aux (lst)
(list (list (list (first lst) (fourth lst)) (list (second lst) (third lst)))))
(defun drop1&4 (chord-name)
(drop1&4-aux (first (get-figures-of-a-chord chord-name))))
;;;
;;; (drops "CM7")
;;;
(defun drops (chord-name)
(format t "~%drop2 ~a" (drop2 chord-name))
(format t "~%drop3 ~a" (drop3 chord-name))
(format t "~%drop2&4 ~a" (drop2&4 chord-name))
(format t "~%drop1&4 ~a" (drop1&4 chord-name))
(format t "~%Tensions")
(show-tension-notes chord-name))
(defun set-of-drops (chord-name)
(append (drop2 chord-name)
(drop3 chord-name)
(drop2&4 chord-name)
(drop1&4 chord-name)))
(defun get-a-drop (chord-name)
(let ((lst (set-of-drops chord-name)))
(nth (random (length lst)) lst)))
(defun a-drop (chord-name)
(format t "~%~a " (get-a-drop chord-name))
(format t "~%Tensions")
(show-tension-notes chord-name))
;;;
;;; c:\\program files\\acl62\\work1.cl
;;;
;;; (auto-comp *w1*)
;;; (tell-pairs *w2*) etc.
(setf *w1* '((-E "When I Fall In Love")
("-EM7" ion "C7" alt) ("Fm7" dor "-B7" mix) ("-EM7" ion "C7" alt)
("Fm7" dor "-B7" mix) ("-EM7" ion) ("C7" alt) ("F7" lyd-7) ("-B7" mix)
("-EM7" ion) ("Fm7" dor "-B7" mix) ("-EM7" ion "-D7" lyd-7) ("Gm7" phr "C7" alt)
("Fm7" dor) ("C7" alt) ("Fm7" dor) ("-B7" mix) ("-EM7" ion "C7" alt)
("Fm7" dor "-B7" mix) ("-EM7" ion "C7" alt) ("Fm7" dor "-B7" mix)
("-EM7" ion) ("C7" alt) ("F7" lyd-7) ("-B7" mix) ("-EM7" ion) ("Am7-5" loc "D7" alt)
("Gm7" phr "C7" alt) ("Fm7" dor "-D7" lyd-7) ("Gm7" phr "C7" alt)
("Fm7" dor "-B7" mix) ("-EM7" ion "Edim7" dim) ("Fm7" dor "-B7" mix)))
(setf *w2* '((C "Laura")
("Am7" dor) ("D7" alt) ("GM7" ion) ("GM7" ion) ("Gm7" dor) ("C7" alt)
("FM7" ion) ("FM7" ion) ("Fm7" dor) ("-B7" alt) ("-EM7" ion) ("-EM7" ion)
("Am7-5" loc) ("D7" alt) ("GM7" ion) ("Bm7" phr "E7" alt) ("Am7" dor) ("D7" alt)
("GM7" ion) ("GM7" ion) ("Gm7" dor) ("C7" alt) ("FM7" ion) ("FM7" ion)
("Fm7" dor) ("Dm7-5" loc "G7" alt) ("CM7" ion) ("Am7" aeo) ("D7" lyd-7)
("Dm7-5" loc "G7" alt) ("-DM7" ion) ("CM7" ion)))
(setf *w3* '((F "Dindi")
("FM7" ion) ("-EM7" lyd) ("FM7" ion) ("Cm7" dor "F7" alt) ("-BM7" lyd)
("-E7" lyd-7) ("FM7" ion) ("-EM7" lyd) ("FM7" ion) ("-EM7" lyd) ("FM7" ion)
("Cm7" dor "F7" alt) ("-BM7" lyd) ("-E7" lyd-7) ("FM7" ion) ("Bm7-5" loc "E7" hmp5)
("Am7" all) ("E7" hmp5) ("Am7" all "E7" hmp5) ("Am7" all "D7" alt)
("Gm7" all) ("D7" hmp5) ("Gm7" all "D7" hmp5) ("Gm7" all "C7" alt)
("FM7" ion) ("-EM7" lyd) ("FM7" ion) ("Cm7" dor "F7" alt) ("-BM7" lyd) ("-E7" lyd-7)
（"FM7" ion) ("-EM7" lyd) ("FM7" ion) ("-EM7" lyd) ("FM7" ion) ("-EM7" lyd)
("FM7" ion) ("FM7" ion) ("-EM7" lyd) ("-EM7" lyd) ("DM7" ion)
("DM7" ion) ("DM7" ion) ("DM7" ion)))
(setf *w4* '((G "Love")
("GM7" ion) ("GM7" ion) ("Am7" dor) ("D7" mix) ("D7" mix) ("D7" mix)
("GM7" ion) ("GM7" ion) ("GM7" ion) ("G7" mix) ("CM7" lyd) ("CM7" lyd)
("A7" lyd-7) ("A7" lyd-7) ("Am7" dor) ("D7" mix) ("GM7" ion) ("GM7" ion)
("Am7" dor) ("D7" mix) ("D7" mix) ("D7" mix) ("GM7" ion) ("GM7" ion) ("GM7" ion)
("G7" mix) ("CM7" lyd) ("+Cdim7" dim) ("GM7" ion) ("D7" mix) ("GM7" ion "+Gdim7" dim)
("Am7" dor "D7" mix) ("GM7" ion) ("GM7" ion) ("GM7" ion) ("GM7" ion)))
(setf *w5* '((c "Yesterdays")
("Cm" all) ("Dm7-5" loc "G7" alt) ("Cm" all) ("Dm7-5" loc "G7" alt) ("Cm" all)
("Cm7" all) ("Am7-5" loc) ("D7" alt) ("G7" alt) ("C7" alt) ("F7" alt) ("-B7" lyd-7)
("-E7" alt) ("-AM7" ion "G7" alt) ("Cm" all) ("Dm7-5" loc "G7" alt) ("Cm" all)
("Dm7-5" loc "G7" alt) ("Cm" all) ("Dm7-5" loc "G7" alt) ("Cm" all) ("Cm7" all)
("Am7-5" loc) ("D7" alt) ("G7" alt) ("C7" alt) ("F7" alt) ("-B7" lyd-7)
("-E7" alt) ("-AM7" ion "G7" alt) ("Cm" all) ("Dm7-5" loc "G7" alt)
("Cm" all "Am7-5" loc) ("Dm7-5" loc "G7" alt) ("Cm" all "Am7-5" loc)
("Dm7-5" loc "G7" alt) ("Cm" all "Am7-5" loc) ("Dm7-5" loc "G7" alt)
("Cm" all) ("Cm" all) ("Cm" all) ("Cm" all)))
(setf *w6* '((F "I'm Getting Sentimental Over You")
("FM7" ion) ("E7" alt) ("Am7-5" loc) ("D7" alt) ("G7" lyd-7) ("C7" mix)
("Am7" phr "D7" alt) ("Gm7" dor "C7" mix) ("FM7" ion) ("E7" alt) ("Am7-5" loc)
("D7" alt) ("G7" lyd-7) ("C7" mix) ("FM7" ion) ("Bm7-5" loc "E7" alt) ("Am" aeo)
("Am7" aeo) ("B7" alt) ("Dm7" dor) ("E7" alt) ("E7" alt) ("Am7" aeo "D7" alt)
("Gm7" dor "C7" mix) ("FM7" ion) ("E7" alt) ("Am7-5" loc) ("D7" alt) ("G7" lyd-7)
("C7" mix) ("Am7" aeo) ("D7" alt) ("G7" lyd-7) ("C7" mix) ("FM7" ion "+Fdim7" dim)
("Gm7" dor "C7" mix) ("FM7" ion) ("FM7" ion) ("FM7" ion) ("FM7" ion)))
(setf *w7* '((G "Speak Low")
("Am7" dor) ("D7" mix) ("Am7" dor) ("D7" mix) ("Am7" dor) ("D7" mix)
("Bm7-5" loc) ("E7" alt) ("Cm7" dor) ("F7" mix) ("Cm7" dor) ("F7" mix)
("Bm7" phr "E7" hmp5) ("Am7" dor "D7" mix) ("GM7" ion)
("Bm7-5" loc "E7" hmp5) ("Am7" dor) ("D7" mix) ("Am7" dor) ("D7" mix)
("Am7" dor) ("D7" alt) ("Bm7-5" loc) ("E7" alt) ("Cm7" dor) ("F7" mix)
("Cm7" dor) ("F7" mix) ("Bm7" phr "E7" hmp5) ("Am7" dor "D7" alt)
("GM7" ion) ("GM7" ion) ("Gm7" dor) ("Gm7" dor) ("-E7" lyd-7) ("-E7" lyd-7)
("FM7" ion) ("FM7" ion) ("-E7" lyd-7) ("D7" mix) ("Am7" dor) ("D7" mix)
("Am7" dor) ("D7" mix) ("Am7" dor) ("D7" mix) ("Bm7-5" loc) ("E7" alt)
("Cm7" dor) ("F7" mix) ("Cm7" dor) ("F7" mix) ("Bm7-5" loc) ("E7" alt)
("Em7" aeo "A7" lyd-7) ("Am7" dor "D7" mix) ("GM7" ion) ("Bm7-5" loc "E7" hmp5)
("-EM7" lyd) ("-AM7" lyd) ("GM7" ion)))
(setf *w8* '((F "Day By Day")
("Gm7" dor) ("C7" mix) ("Gm7" dor) ("C7" alt) ("FM7" ion) ("-B7" lyd-7)
("Am7" phr) ("D7" alt) ("Gm7" dor) ("A7" alt) ("Dm7" aeo) ("Dm7" aeo)
("G7" lyd-7) ("G7" lyd-7) ("Am7-5" loc) ("D7" alt) ("Gm7" dor) ("C7" mix)
("Gm7" dor) ("C7" alt) ("FM7" ion) ("-B7" lyd-7) ("Am7-5" loc) ("D7" alt)
("Gm7" dor) ("C7" alt) ("Am7" phr) ("D7" alt) ("Gm7" dor) ("C7" alt) ("FM7" ion)
("Am7-5" loc "D7" alt) ("Gm7" dor) ("C7" mix) ("Gm7" dor) ("C7" alt) ("FM7" ion)
("-B7" lyd-7) ("Am7" phr) ("D7" alt) ("Gm7" dor) ("A7" alt) ("Dm7" aeo) ("Dm7" aeo)
("G7" lyd-7) ("G7" lyd-7) ("Am7-5" loc) ("D7" alt) ("Gm7" dor) ("C7" mix)
("Gm7" dor) ("C7" alt) ("FM7" ion) ("-B7" lyd-7) ("Am7-5" loc) ("D7" alt)
("Gm7" dor) ("C7" alt) ("Am7" phr) ("D7" alt) ("Gm7" dor) ("C7" alt) ("FM7" ion)
("Am7-5" loc "D7" alt) ("Gm7" dor) ("C7" alt) ("FM7" ion) ("FM7" ion))
コメント
コメントを投稿