自動作曲その他音楽情報処理２
;;
;;; C:\\program files\\acl62\\music19.cl
;;;
(load "c:\\program files\\acl62\\music18.cl")
(defun get-chord-tone-2 (pair)
(translate-flat-to-sharp-in-a-list (replace-j-note-with-doremi (get-chord-tone (car pair)))))
(defun get-chord-scale-2 (pair)
(translate-flat-to-sharp-in-a-list (replace-j-note-with-doremi (chord-scale pair))))
(defun get-tension-note-2 (pair)
(translate-flat-to-sharp-in-a-list (replace-j-note-with-doremi (tension-note pair))))
(defun get-guide-tone-2 (pair)
(translate-flat-to-sharp-in-a-list (replace-j-note-with-doremi (guide-tone pair))))
(defun get-elements-of-melody-2 (pair)
(translate-flat-to-sharp-in-a-list (replace-j-note-with-doremi (get-elements-of-melody pair))))
(defun generate-a-note-at-random (pair)
(let* ((lst (get-elements-of-melody-2 pair))
(num (length lst)))
(nth (random num) lst)))
(defun translate-number-to-sound-2 (n offset)
(let ((num (confine-a-number (+ n offset))))
(case num
(1.0 'do) (1.5 '+do) (2.0 're) (2.5 '+re)
(3.0 'mi) (3.5 'fa) (4.0 '+fa) (4.5 'so)
(5.0 '+so) (5.5 'la) (6.0 '+la) (6.5 'si))))
(defun translate-sound-to-number-2 (c)
(case c
(do 1.0) (+do 1.5) (re 2.0) (+re 2.5)
(mi 3.0) (fa 3.5) (+fa 4.0) (so 4.5)
(+so 5.0) (la 5.5) (+la 6.0) (si 6.5)))
(defun distance-of-two-sound-2 (s1 s2)
(let* ((n1 (translate-sound-to-number-2 s1))
(n2 (translate-sound-to-number-2 s2))
(num (- n2 n1)))
(cond ((>= num 7.0) (- num 6.0))
((<= num 0.0) (+ num 6.0))
(t num))))
(defun sharp-a-note (note)
(let ((num (translate-sound-to-number-2 note)))
(translate-number-to-sound-2 (+ 0.5 num) 0.0)))
(defun flat-a-note (note)
(let* ((num (translate-sound-to-number-2 note))
(n1 (- num 0.5))
(n2 (cond ((>= n1 7.0) (- n1 6.0))
((<= n1 0.5) (+ n1 6.0))
(t n1)))) (translate-number-to-sound-2 n2 0.0)))
(defun member-of-chord-tone-2 (note pair)
(car (member note (get-chord-tone-2 pair))))
(defun member-of-tension-note-2 (note pair)
(car (member note (get-tension-note-2 pair))))
(defun member-of-scale-note-2 (note pair)
(car (member note (append (get-chord-tone-2 pair) (get-tension-note-2 pair)))))
(defun member-of-element-note-2 (note pair)
(car (member note (append (get-guide-tone-2 pair) (get-tension-note-2 pair)))))
(defun member-of-guide-tone-2 (note pair)
(car (member note (get-guide-tone-2 pair))))
(defun sharp-till-chord-tone (note pair)
(do ((nt note (sharp-a-note nt))
(w))
((member-of-chord-tone-2 nt pair) (push nt w) (reverse w))
(cond ((member-of-scale-note-2 nt pair)
(push nt w)))))
(defun flat-till-chord-tone (note pair)
(do ((nt note (flat-a-note nt))
(w))
((member-of-chord-tone-2 nt pair) (push nt w) (reverse w))
(cond ((member-of-scale-note-2 nt pair)
(push nt w)))))
(defun generate-a-phrase-aux (pair)
(do ((i 8 (1- i))
(w))
((<= i 0) (reverse w))
(let ((nt (generate-a-note-at-random pair)))
(cond ((member-of-guide-tone-2 nt pair)
(push nt w))
((member-of-tension-note-2 nt pair)
(push
(case (random 2)
(0 (flat-till-chord-tone nt pair))
(1 (sharp-till-chord-tone nt pair))) w))
(t
(push
(case (random 2)
(0 (flat-till-chord-tone nt pair))
(1 (sharp-till-chord-tone nt pair))) w))))))
(defun generate-a-phrase-of-n-notes (pair n)
(cut-list-at-length n (generate-a-phrase-aux pair)))
(defun generate-a-phrase-at-random (pair)
(generate-a-phrase-of-n-notes pair (1+ (random 6))))
(defun make-a-phrase (l)
(do ((lst l (cddr lst)))
((null lst))
(format t "~%*********** On ~a ************" l)
(format t "~%*********** On ~a ************" (list (first lst) (second lst)))
(format t "~%Chord Scale: ~a" (chord-scale (list (first lst) (second lst))))
(format t "~%~a" (generate-a-phrase-at-random (list (first lst) (second lst))))
(format t "~%~a" (generate-a-phrase-at-random (list (first lst) (second lst))))
(format t "~%~a" (generate-a-phrase-at-random (list (first lst) (second lst))))
(format t "~%~a" (generate-a-phrase-at-random (list (first lst) (second lst))))
(format t "~%~a" (generate-a-phrase-at-random (list (first lst) (second lst))))))
(defun make-phrases (l)
(do ((lst l (cdr lst)))
((null lst))
(make-a-phrase (car lst))))
;;;
;;; (auto-comp2 *w3*) etc.
;;;
(defun auto-comp2 (wn)
(tagbody
(my-randomize)
(format t "~%********** ~a ************" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%********* The key is ~a. **********" (car l1))
(make-phrases l2)))
;;;
;;; C:\\program files\\acl62\\music20.cl
;;;
(load "c:\\program files\\acl62\\music19.cl")
(defun sharp-till-chord-tone-2 (note pair)
(do ((nt note (sharp-a-note nt))
(w))
((member-of-chord-tone-2 nt pair) (push nt w) (reverse w))
(push nt w)))
(defun flat-till-chord-tone-2 (note pair)
(do ((nt note (flat-a-note nt))
(w))
((member-of-chord-tone-2 nt pair) (push nt w) (reverse w))
(push nt w)))
(defun generate-a-phrase-aux-2 (pair)
(do ((i 8 (1- i))
(w))
((<= i 0) (reverse w))
(let ((nt (generate-a-note-at-random pair)))
(cond ((member-of-guide-tone-2 nt pair)
(push nt w))
((member-of-tension-note-2 nt pair)
(push
(case (random 4)
(0 (flat-till-chord-tone nt pair))
(1 (sharp-till-chord-tone nt pair))
(2 (flat-till-chord-tone-2 nt pair))
(3 (sharp-till-chord-tone-2 nt pair))) w))
(t
(push
(case (random 4)
(0 (flat-till-chord-tone nt pair))
(1 (sharp-till-chord-tone nt pair))
(2 (flat-till-chord-tone-2 nt pair))
(3 (sharp-till-chord-tone-2 nt pair))) w))))))
(defun generate-a-phrase-of-n-notes-2 (pair n)
(cut-list-at-length n (generate-a-phrase-aux-2 pair)))
(defun generate-a-phrase-at-random-2 (pair)
(generate-a-phrase-of-n-notes-2 pair (1+ (random 6))))
(defun make-a-phrase-2 (l)
(do ((lst l (cddr lst)))
((null lst))
(format t "~%*********** On ~a ************" l)
(format t "~%*********** On ~a ************" (list (first lst) (second lst)))
(format t "~%Chord Scale: ~a" (chord-scale (list (first lst) (second lst))))
(format t "~%~a" (generate-a-phrase-at-random-2 (list (first lst) (second lst))))
(format t "~%~a" (generate-a-phrase-at-random-2 (list (first lst) (second lst))))
(format t "~%~a" (generate-a-phrase-at-random-2 (list (first lst) (second lst))))
(format t "~%~a" (generate-a-phrase-at-random-2 (list (first lst) (second lst))))
(format t "~%~a" (generate-a-phrase-at-random-2 (list (first lst) (second lst))))))
(defun make-phrases-2 (l)
(do ((lst l (cdr lst)))
((null lst))
(make-a-phrase-2 (car lst))))
;;;
;;; (auto-comp3 *w3*) etc.
;;;
(defun auto-comp3 (wn)
(tagbody
(my-randomize)
(format t "~%********** ~a ************" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%********* The key is ~a. **********" (car l1))
(make-phrases-2 l2)))
;;;
;;; c:\\program files\\acl62\\music21.cl
;;;
(load "c:\\program files\\acl62\\music20.cl")
(defun make-a-phrase-1-2 (l)
(let ((num (length l)))
(case num
(2 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (cut-list-at-length (1+ (random 6))
(squash (generate-a-phrase-at-random (list (first lst) (second lst))))))))
(4 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w
(cut-list-at-length
(1+ (random 3))
(squash (generate-a-phrase-at-random (list (first lst) (second lst)))))))))
(6 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w
(cut-list-at-length
(1+ (random 2))
(squash (generate-a-phrase-at-random (list (first lst) (second lst))))))))))))
(defun make-a-phrase-2-2 (l)
(let ((num (length l)))
(case num
(2 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (cut-list-at-length (1+ (random 6))
(squash (generate-a-phrase-at-random-2 (list (car lst) (cadr lst))))))))
(4 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w
(cut-list-at-length
(1+ (random 3))
(squash (generate-a-phrase-at-random-2 (list (car lst) (cadr lst)))))))))
(6 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w
(cut-list-at-length
(1+ (random 2))
(squash (generate-a-phrase-at-random-2 (list (car lst) (cadr lst))))))))))))
(defun make-a-phrase-for-waltz (l)
(let* ((l1 (make-a-phrase-1-2 l))
(l2 (make-a-phrase-2-2 l))
(n1 (length l1))
(n2 (length l2))
(r1 (get-rythm-of-3beat n1))
(r2 (get-rythm-of-3beat n2)))
(list (list l1 r1) (list l2 r2))))
(defun make-phrases-for-waltz (l)
(do ((lst l (cdr lst)))
((null lst))
(format t "~%*********** ~a *************" (car lst))
(format t "~%~a" (make-a-phrase-for-waltz (car lst)))))
;;;
;;; (make-waltz *w3*)
;;;
(defun make-waltz (wn)
(tagbody
(my-randomize)
(format t "~%************ ~a ************" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%*********** The key is ~a. ***********" (car l1))
(make-phrases-for-waltz l2)))
;;;
;;; c:\\program files\\acl62\\music22.cl
;;;
(load "c:\\program files\\acl62\\music21.cl")
(defun make-a-phrase-1-3 (l)
(let ((num (length l)))
(case num
(2 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (cut-list-at-length
(1+ (random 8))
(squash (generate-a-phrase-at-random (list (first lst) (second lst))))))))
(4 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w
(cut-list-at-length
(1+ (random 4))
(squash (generate-a-phrase-at-random (list (first lst) (second lst)))))))))
(6 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w
(cut-list-at-length
(1+ (random 3))
(squash (generate-a-phrase-at-random (list (first lst) (second lst))))))))))))
(defun make-a-phrase-2-3 (l)
(let ((num (length l)))
(case num
(2 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (cut-list-at-length
(1+ (random 8))
(squash (generate-a-phrase-at-random-2 (list (car lst) (cadr lst))))))))
(4 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w
(cut-list-at-length
(1+ (random 4))
(squash (generate-a-phrase-at-random-2 (list (car lst) (cadr lst)))))))))
(6 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w
(cut-list-at-length
(1+ (random 3))
(squash (generate-a-phrase-at-random-2 (list (car lst) (cadr lst))))))))))))
(defun make-a-phrase-for-ballad (l)
(let* ((l1 (make-a-phrase-1-3 l))
(l2 (make-a-phrase-2-3 l))
(n1 (length l1))
(n2 (length l2))
(r1 (get-rythm-of-4beat n1))
(r2 (get-rythm-of-4beat n2)))
(list (list l1 r1) (list l2 r2))))
(defun make-phrases-for-ballad (l)
(do ((lst l (cdr lst)))
((null lst))
(format t "~%*********** ~a *************" (car lst))
(format t "~%~a" (make-a-phrase-for-ballad (car lst)))))
;;;
;;; (make-ballad *w3*)
;;;
(defun make-ballad (wn)
(tagbody
(my-randomize)
(format t "~%************ ~a ************" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%*********** The key is ~a. ***********" (car l1))
(make-phrases-for-ballad l2)))
;;;
;;; c:\\program files\\acl62\\music23.cl
;;;
(load "c:\\program files\\acl62\\music22.cl")
(defun generate-8-elements-at-random (pair)
(do ((i 8 (1- i))
(w))
((<= i 0) (reverse w))
(push (generate-a-note-at-random pair) w)))
(defun make-a-phrase-for-waltz-2 (l)
(let ((num (length l)))
(case num
(2 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (cut-list-at-length (1+ (random 6))
(generate-8-elements-at-random (list (first lst) (second lst)))))))
(4 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w (cut-list-at-length (1+ (random 3))
(generate-8-elements-at-random (list (first lst) (second lst))))))))
(6 (do ((lst l (cddr lst))
(w)) ((null lst) w)
(setf w (append w (cut-list-at-length (1+ (random 2))
(generate-8-elements-at-random (list (first lst) (second lst)))))))))))
(defun make-a-phrase-for-ballad-2 (l)
(let ((num (length l)))
(case num
(2 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (cut-list-at-length (1+ (random 8))
(generate-8-elements-at-random (list (first lst) (second lst)))))))
(4 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w (cut-list-at-length (1+ (random 4))
(generate-8-elements-at-random (list (first lst) (second lst))))))))
(6 (do ((lst l (cddr lst))
(w))
((null lst) w)
(setf w (append w (cut-list-at-length (1+ (random 3))
(generate-8-elements-at-random (list (first lst) (second lst)))))))))))
(defun make-a-phrase-for-song (l)
(let* ((l1 (make-a-phrase-for-waltz-2 l))
(l2 (make-a-phrase-for-ballad-2 l))
(n1 (length l1))
(n2 (length l2))
(r1 (get-rythm-of-3beat n1))
(r2 (get-rythm-of-4beat n2)))
(list (list l1 r1) (list l2 r2))))
(defun make-phrases-for-song (l)
(do ((lst l (cdr lst)))
((null lst))
(format t "~%*********** ~a ***********" (car lst))
(format t "~%~a" (make-a-phrase-for-song (car lst)))))
;;;
;;; (make-song *w3*)
;;;
(defun make-song (wn)
(tagbody
(my-randomize)
(format t "~%************ ~a *************" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%*********** The key is ~a. *************" (car l1))
(make-phrases-for-song l2)))
;;;
;;; c:\\program files\\acl62\\music24.cl
;;;
(load "c:\\program files\\acl62\\music23.cl")
(defun get-CPM-or-CPm (key)
(cond ((upper-char-p key)
(list (list key 'Major)
(get-CPM-with-key-at-random key)
(get-related-key key)))
((lower-char-p key)
(list (list key 'Minor)
(get-CPm-with-key-at-random key)
(get-related-key key)))))
(defun build-CP ()
(prog (key w r)
(my-randomize)
(setf w nil)
loop
(format t "~%The chord progression is ~a." w)
(format t "~%The length of the chord progression is ~a." (length w))
;;;
loop2
(format t "~%So far is it OK ? (y or n)")
(setf r (car (read-sentence)))
(if (not (or (eq r 'y) (eq r 'n)))
(go loop2))
;;;
(cond ((eq r 'n)
(setf w (butlast w))
(go loop))
((eq r 'y)
(go next)))
next
(format t "~%Enter a key!~%")
(setf key (car (read-sentence)))
(if (or (eq key 'end) (eq key 'END))
(go exit))
(if (not (or (upper-char-p key)
(lower-char-p key)))
(go next))
exit
(cond ((or (eq key 'end)
(eq key 'END))
(return w))
(t
(setf w (append w (list (get-CPM-or-CPm key))))
(go loop)))))
(defun get-first-and-second-part (lst)
(list (first lst) (second lst)))
;;;
;;;
;;;
(defun make-chord-progression ()
(format t "~%~a" (mapcar #'get-first-and-second-part (build-CP))))
;;;
;;; c:\\program files\\acl62\\music28.cl
;;;
(load "c:\\program files\\acl62\\music27.cl")
(defun get-all-DC-chords-aux-1 (dominant-chord)
(append (get-DC0 dominant-chord) (get-DC01 dominant-chord)))
(defun get-all-DC-chords-aux-2 (dominant-chord)
(append (get-DC0 dominant-chord) (get-DC02 dominant-chord)))
(defun get-all-DC-chords-1-aux (dominant-chord)
(mapcar #'car (get-all-DC-chords-aux-2 dominant-chord)))
(defun get-all-DC-chords-2-aux (dominant-chord)
(mapcar #'car (get-all-DC-chords-aux-1 dominant-chord)))
(defun get-all-DC-chords-1 (dominant-chord)
(let ((lst (get-all-DC-chords-1-aux dominant-chord)))
(append lst (mapcar #'change-a-chord-name lst))))
(defun get-all-DC-chords-2 (dominant-chord)
(let ((lst (get-all-DC-chords-2-aux dominant-chord)))
(append lst (mapcar #'change-a-chord-name lst))))
(defun translate-and+ (sc)
(cond ((equal sc "-D") "+C")
((equal sc "-E") "+D")
((equal sc "-G") "+F")
((equal sc "-A") "+G")
((equal sc "-B") "+A")
((equal sc "+C") "-D")
((equal sc "+D") "-E")
((equal sc "+F") "-G")
((equal sc "+G") "-A")
((equal sc "+A") "-B")
(t sc)))
;;;
;;; (change-a-chord-name "+Cm7") ====> "-Dm7"
;;;
(defun change-a-chord-name (chord)
(let* ((lst (divide-a-chord chord))
(cha (translate-and+ (first lst)))
(type (second lst)))
(concatenate 'string cha type)))
(defun member-of-all-DC-chords-1 (dominant-chord chord)
(if (member chord (get-all-DC-chords-1 dominant-chord) :test #'equal)
dominant-chord
nil))
(defun member-of-all-DC-chords-2 (dominant-chord chord)
(if (member chord (get-all-DC-chords-2 dominant-chord) :test #'equal)
dominant-chord
nil))
(setf *dominant-chords*
'("C7" "+C7" "-D7" "D7" "+D7" "-E7" "E7" "F7" "+F7" "-G7" "G7"
"+G7" "-A7" "A7" "+A7" "-B7" "B7"))
;;;
;;; (back-to-dominant-chords-1 "Em7") ====> (("D7" "F7" "G7" "B7") "Em7")
;;;
(defun back-to-dominant-chords-1 (chord)
(do ((lst *dominant-chords* (cdr lst))
(w))
((null lst) (list (reverse w) chord))
(let ((e (member-of-all-DC-chords-1 (car lst) chord)))
(if (not (null e)) (push e w)))))
(defun back-to-dominant-chords-2 (chord)
(do ((lst *dominant-chords* (cdr lst))
(w))
((null lst) (list (reverse w) chord))
(let ((e (member-of-all-DC-chords-2 (car lst) chord)))
(if (not (null e)) (push e w)))))
(make-frame-from-list
'(DC0 (G7 (value ("CM7" ion) ("-GM7" ion) ("+FM7" ion)
("Cm7" all) ("-Gm7" all) ("+Fm7" all) ("Cm7-5" loc)
("-Gm7-5" loc) ("+Fm7-5" loc) ("C7" all)
("-G7" all) ("+F7" all)))))
(make-frame-from-list
'(DC01 (G7 (value ("Em7" phr) ("Am7" aeo) ("Em7-5" loc) ("Am7-5" loc)
("+Fm7-5" loc) ("-Gm7-5" loc) ("-EM7" lyd) ("+DM7" lyd)
("-AM7" lyd) ("+GM7" lyd) ("-DM7" lyd) ("+CM7" lyd)
("-BM7" lyd) ("+AM7" lyd) ("-B7" lyd-7) ("+A7" lyd-7)
("-Em7" dor)))))
(make-frame-from-list
'(DC02 (G7 (value ("Em7" phr) ("Am7" aeo) ("Em7-5" loc) ("Am7-5" loc)
("+Fm7-5" loc) ("-Gm7-5" loc) ("-EM7" lyd) ("+DM7" lyd)
("-AM7" lyd) ("+GM7" lyd) ("-DM7" lyd) ("+CM7" lyd)))))
(defun get-DC0-of-G7 () (fget-i 'DC0 'G7))
(defun get-DC01-of-G7 () (fget-i 'DC01 'G7))
(defun get-DC02-of-G7 () (fget-i 'DC02 'G7))
(defun get-DC0 (dominant-chord)
(modulate-key1-to-key2 (get-DC0-of-G7)
'C
(translate-dominant-atom (involve-atom-p dominant-chord))))
(defun get-DC01 (dominant-chord)
(modulate-key1-to-key2 (get-DC01-of-G7)
'C
(translate-dominant-atom (involve-atom-p dominant-chord))))
(defun get-DC02 (dominant-chord)
(modulate-key1-to-key2 (get-DC02-of-G7)
'C
(translate-dominant-atom (involve-atom-p dominant-chord))))
;;;
;;; c:\\program files\\alc62\\music29.cl
;;;
(load "c:\\program files\\acl62\\music28.cl")
(defun auto-comp1-1-aux (pair)
(let* ((l (make-a-phrase-with-scale-from-tension pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp1-2-aux (pair)
(let* ((l (make-a-phrase-with-scale-from-tension-2 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp2-1-aux (pair)
(let* ((l (make-a-phrase-with-scale-from-elm pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp2-2-aux (pair)
(let* ((l (make-a-phrase-with-scale-from-elm-2 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp3-1-aux (pair)
(let* ((l (get-elements-of-melody-at-random pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp3-2-aux (pair)
(let* ((l (get-elements-of-melody-at-random-2 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp4-1-aux (pair)
(let* ((l (make-a-phrase-with-UST-at-random pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp4-2-aux (pair)
(let* ((l (get-notes-from-UST-at-random-2 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
;;;
;;;
;;;
(defun auto-comp1-1-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp1-1-aux l)))))
(defun auto-comp1-2-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp1-2-aux l)))))
(defun auto-comp2-1-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp2-1-aux l)))))
(defun auto-comp2-2-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp2-2-aux l)))))
(defun auto-comp3-1-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp3-1-aux l)))))
(defun auto-comp3-2-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp3-2-aux l)))))
(defun auto-comp4-1-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp4-1-aux l)))))
(defun auto-comp4-2-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp4-2-aux l)))))
;;;
;;;
;;;
(defun auto-comp1-1 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp1-1-aux-2 l2)))
(defun auto-comp1-2 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp1-2-aux-2 l2)))
(defun auto-comp2-1 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp2-1-aux-2 l2)))
(defun auto-comp2-2 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp2-2-aux-2 l2)))
(defun auto-comp3-1 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp3-1-aux-2 l2)))
(defun auto-comp3-2 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp3-2-aux-2 l2)))
(defun auto-comp4-1 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp4-1-aux-2 l2)))
(defun auto-comp4-2 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp4-2-aux-2 l2)))
;;;
;;; c:\\program files\\acl62\\music30.cl
;;;
(load "c:\\program files\\acl62\\music29.cl")
(defun make-a-phrase-with-scale-from-tension-3 (pair)
(cut-list-at-length (nth (random 4) '(1 2 3 4)) (make-a-phrase-with-scale-from-tension pair)))
(defun make-a-phrase-with-scale-from-elm-3 (pair)
(cut-list-at-length (nth (random 4) '(1 2 3 4)) (make-a-phrase-with-scale-from-elm pair)))
(defun get-elements-of-melody-at-random-3 (pair)
(cut-list-at-length (nth (random 4) '(1 2 3 4)) (get-elements-of-melody-at-random pair)))
(defun make-a-phrase-with-UST-at-random-3 (pair)
(cut-list-at-length (nth (random 4) '(1 2 3 4)) (make-a-phrase-with-UST-at-random pair)))
;;;
;;;
;;;
(defun auto-comp1-3-aux (pair)
(let* ((l (make-a-phrase-with-scale-from-tension-3 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp2-3-aux (pair)
(let* ((l (make-a-phrase-with-scale-from-elm-3 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp3-3-aux (pair)
(let* ((l (get-elements-of-melody-at-random-3 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp4-3-aux (pair)
(let* ((l (make-a-phrase-with-UST-at-random-3 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
;;;
;;;
;;;
(defun auto-comp1-3-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp1-3-aux l)))))
(defun auto-comp2-3-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp2-3-aux l)))))
(defun auto-comp3-3-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp3-3-aux l)))))
(defun auto-comp4-3-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp4-3-aux l)))))
;;;
;;;
;;;
(defun auto-comp1-3 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp1-3-aux-2 l2)))
(defun auto-comp2-3 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp2-3-aux-2 l2)))
(defun auto-comp3-3 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp3-3-aux-2 l2)))
(defun auto-comp4-3 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp4-3-aux-2 l2))
;;;
;;; c:\\program files\\acl62\\music31.cl
;;;
(load "c:\\program files\\acl62\\music30.cl")
(defun make-a-phrase-with-scale-from-tension-4 (pair)
(cut-list-at-length (nth (random 4) '(1 2 3 4)) (make-a-phrase-with-scale-from-tension-2 pair)))
(defun make-a-phrase-with-scale-from-elm-4 (pair)
(cut-list-at-length (nth (random 4) '(1 2 3 4)) (make-a-phrase-with-scale-from-elm-2 pair)))
(defun get-elements-of-melody-at-random-4 (pair)
(cut-list-at-length (nth (random 4) '(1 2 3 4)) (get-elements-of-melody-at-random-2 pair)))
(defun make-a-phrase-with-UST-at-random-4 (pair)
(cut-list-at-length (nth (random 4) '(1 2 3 4)) (get-notes-from-UST-at-random-2 pair)))
;;;
;;;
;;;
(defun auto-comp1-4-aux (pair)
(let* ((l (make-a-phrase-with-scale-from-tension-4 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp2-4-aux (pair)
(let* ((l (make-a-phrase-with-scale-from-elm-4 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp3-4-aux (pair)
(let* ((l (get-elements-of-melody-at-random-4 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
(defun auto-comp4-4-aux (pair)
(let* ((l (make-a-phrase-with-UST-at-random-4 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))
(read-sentence)))
;;;
;;;
;;;
(defun auto-comp1-4-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp1-4-aux l)))))
(defun auto-comp2-4-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp2-4-aux l)))))
(defun auto-comp3-4-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp3-4-aux l)))))
(defun auto-comp4-4-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp4-4-aux l)))))
;;;
;;;
;;;
(defun auto-comp1-4 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp1-4-aux-2 l2)))
(defun auto-comp2-4 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp2-4-aux-2 l2)))
(defun auto-comp3-4 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp3-4-aux-2 l2)))
(defun auto-comp4-4 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp4-4-aux-2 l2)))
;;;
;;; c:\\program files\\acl62\\music32.cl
;;;
(load "c:\\program files\\acl62\\music31.cl")
(defun measure-an-interval-of-two-notes-upward (s1 s2)
(let ((n1 (translate-sound-to-number s1))
(n2 (translate-sound-to-number s2)))
(if (<= n1 n2)
(- n2 n1)
(- (+ n2 6.0) n1))))
(defun measure-an-interval-of-two-notes-downward (s1 s2)
(measure-an-interval-of-two-notes-upward s2 s1))
(defun relation-of-two-notes (n1 n2)
(let ((u (measure-an-interval-of-two-notes-upward n1 n2))
(d (measure-an-interval-of-two-notes-downward n1 n2)))
(cond ((< u d) (list 'upward u))
((> u d) (list 'downward d))
((or (= u 3.0) (= d 3.0))
(case (random 2)
(0 (list 'upward u))
(1 (list 'downward d))))
((and (= 0.0 u) (= 0.0 d)) '(same-note)))))
;;;
;;; (get-passing-note '("CM7" ion) "ミ" "ソ")) ===> ファ
;;;
(defun get-passing-note (pair n1 n2)
(let* ((scale (get-chordscale (involve-character-p (first pair))
(second pair)))
(relation (relation-of-two-notes n1 n2))
(direction (first relation))
(distance (second relation))
(num1 (translate-sound-to-number n1))
(num2 (translate-sound-to-number n2)))
(case direction
(upward
(cond ((> distance 2.0) (values))
((= 0.5 distance) (values))
((= 1.0 distance)
(translate-number-to-sound num1 0.5 (involve-character-p (first pair))))
(t
(second (rotate-a-scale-from-a-note n1 pair 'left)))))
(downward
(cond ((> distance 2.0) (values))
((= 0.5 distance) (values))
((= 1.0 distance)
(translate-number-to-sound num1 5.5 (involve-character-p (first pair))))
(t
(second (rotate-a-scale-from-a-note n1 pair 'right))))))))
;;;
;;;
;;;
(defun get-auxiliary-note (pair n1 n2)
(let* ((scale (get-chordscale (involve-character-p (first pair)) (second pair)))
(num1 (translate-sound-to-number n1))
(num2 (translate-sound-to-number n2))
(base (involve-character-p (first pair)))
(l1 (translate-number-to-sound num1 5.0 base))
(l2 (translate-number-to-sound num1 5.5 base))
(u1 (translate-number-to-sound num1 0.5 base))
(u2 (translate-number-to-sound num1 1.0 base)))
(cond ((not (= num1 num2)) (values))
(t
(cond ((and (member l2 scale :test #'equal) (member u1 scale :test #'equal))
(list (list 'downward l2) (list 'upward u1)))
((and (member l2 scale :test #'equal) (not (member u1 scale :test #'equal)))
(list (list 'downward l2) (list 'upward u1 u2)))
((and (not (member l2 scale :test #'equal)) (member u1 scale :test #'equal))
(list (list 'downward l1 l2) (list 'upward u1)))
((and (not (member l2 scale :test #'equal)) (not (member u1 scale :test #'equal)))
(list (list 'downward l1 l2) (list 'upward u1 u2))))))))
(defun select-an-auxiliary-note (pair n1 n2)
(let* ((lst (get-auxiliary-note pair n1 n2))
(a-n (append (rest (first lst)) (rest (second lst)))))
(if (not a-n)
(values)
(nth (random (length a-n)) a-n))))
;;;
;;; (connect-notes-in-a-chord '(("CM7" ion) ("ミ" "ソ" "シ" "ド")))
;;;
(defun connect-notes-in-a-chord (l)
(let ((scale (first l))
(phrase (second l)))
(do ((lst phrase (rest lst))
(w)
(sp)
(sa))
((null (rest lst))
(push (car lst) w)
(list scale (reverse w)))
(push (first lst) w)
(setf sp (get-passing-note scale (first lst) (second lst)))
(setf sa (select-an-auxiliary-note scale (first lst) (second lst)))
(if (not (null sp)) (push sp w))
(if (not (null sa)) (push sa w)))))
(defun connect-notes-in-a-chord-partially (l)
(let ((scale (first l))
(phrase (second l)))
(do ((lst phrase (rest lst))
(w)
(sp)
(sa))
((null (rest lst))
(push (car lst) w)
(list scale (reverse w)))
(push (first lst) w)
(case (random 2)
(0
(setf sp (get-passing-note scale (first lst) (second lst)))
(setf sa (select-an-auxiliary-note scale (first lst) (second lst))))
(1
(setf sp nil)
(setf sa nil)))
(if (not (null sp)) (push sp w))
(if (not (null sa)) (push sa w)))))
;;;
;;; c:\\program files\\acl62\\music33.cl
;;;
(load "c:\\program files\\acl62\\music32.cl")
;;;
;;; (get-UST-from-a-pair '("CM7" ion))
;;;
(defun get-UST-from-a-pair-2 (pair)
(list (first pair) (assoc (second pair) (get-UST (first pair)))))
;;;
;;; (get-UST-from-pairs-aux '("Dm7" dor "G7" alt "CM7" ion))
;;;
(defun get-UST-from-pairs-aux (pairs)
(do ((lst pairs (cddr lst)) (w))
((null lst) (reverse w))
(push (get-UST-from-a-pair-2 (list (first lst) (second lst))) w)))
(defun get-UST-from-pairs-aux-2 (pairs)
(do ((lst pairs (cddr lst)) (w))
((null lst) (reverse w))
(push (list (first lst) (get-UST (first lst))) w)))
;;;
;;; (get-UST-from-pairs '(("CM7" ion "A7" hmp5) ("Dm7" dor "G7" alt) ("CM7" ion)))
;;;
(defun get-UST-from-pairs (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print '***************************************************)
(print (car lst))
(print (get-UST-from-pairs-aux (car lst)))))
(defun get-UST-from-pairs-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print '***************************************************)
(print (car lst))
(print (get-UST-from-pairs-aux-2 (car lst)))))
;;;
;;; (indicate-UST *w1*)
;;;
(defun indicate-UST (wn)
(tagbody
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(get-UST-from-pairs l2)))
(defun indicate-UST-2 (wn)
(tagbody
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(get-UST-from-pairs-2 l2)))
;;;
;;; c:\\program files\\acl62\\music34.cl
;;;
(load "c:\\program files\\acl62\\music33.cl")
(defun get-a-UST-from-a-pair-at-random (pair)
(let* ((l1 (assoc (second pair) (get-UST (first pair))))
(l2 (rest (second l1)))
(len (length l2)))
(nth (random len) l2)))
(defun get-n-USTs-from-a-pair-at-random (pair n)
(do ((num n (1- num))
(w))
((< num 1) (reverse w))
(push (get-a-UST-from-a-pair-at-random pair) w)))
(defun get-8-USTs-from-pairs-at-random-aux (pairs)
(do ((lst pairs (cddr lst))
(w))
((null lst) (reverse w))
(push (list (first lst) (get-n-USTs-from-a-pair-at-random (list (first lst) (second lst)) 8)) w)))
(defun get-8-USTs-from-pairs-at-random (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print '**************************************************************)
(print (car lst))
(print (get-8-USTs-from-pairs-at-random-aux (car lst)))))
;;;
;;; (indicate-8-USTs-at-random *w1*)
;;;
(defun indicate-8-USTs-at-random (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(get-8-USTs-from-pairs-at-random l2)))
;;;
;;; c:\\program files\\acl62\\music35.cl
;;;
(load "c:\\program files\\acl62\\music34.cl")
(defun make-a-phrase-with-scale-from-tension-5 (pair)
(cut-list-at-length (nth (random 10) '(1 2 3 4 5 6 7 8 9 10)) (make-a-phrase-with-scale-from-tension-2 pair)))
(defun make-a-phrase-with-scale-from-elm-5 (pair)
(cut-list-at-length (nth (random 10) '(1 2 3 4 5 6 7 8 9 10)) (make-a-phrase-with-scale-from-elm-2 pair)))
(defun get-elements-of-melody-at-random-5 (pair)
(cut-list-at-length (nth (random 10) '(1 2 3 4 5 6 7 8 9 10)) (get-elements-of-melody-at-random-2 pair)))
(defun make-a-phrase-with-UST-at-random-5 (pair)
(cut-list-at-length (nth (random 10) '(1 2 3 4 5 6 7 8 9 10)) (get-notes-from-UST-at-random-2 pair)))
;;;
;;;
;;;
(defun auto-comp1-5-aux (pair)
(let* ((l (make-a-phrase-with-scale-from-tension-5 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))))
(defun auto-comp2-5-aux (pair)
(let* ((l (make-a-phrase-with-scale-from-elm-5 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))))
(defun auto-comp3-5-aux (pair)
(let* ((l (get-elements-of-melody-at-random-5 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))))
(defun auto-comp4-5-aux (pair)
(let* ((l (make-a-phrase-with-UST-at-random-5 pair))
(n (length l))
(r3 (get-rythm-of-3beat n))
(r4 (get-rythm-of-4beat n)))
(format t "~%~a" (list l (list 3 r3) (list 4 r4)))))
;;;
;;;
;;;
(defun auto-comp1-5-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp1-5-aux l)))))
(defun auto-comp2-5-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp2-5-aux l)))))
(defun auto-comp3-5-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp3-5-aux l)))))
(defun auto-comp4-5-aux-2 (pairs)
(do ((lst pairs (cdr lst)))
((null lst))
(print (car lst))
(do ((ll (car lst) (cddr ll)))
((null ll))
(let ((l (list (first ll) (second ll))))
(print l)
(auto-comp4-5-aux l)))))
;;;
;;;
;;;
(defun auto-comp1-5 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp1-5-aux-2 l2)))
(defun auto-comp2-5 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp2-5-aux-2 l2)))
(defun auto-comp3-5 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp3-5-aux-2 l2)))
(defun auto-comp4-5 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(auto-comp4-5-aux-2 l2)))
;;;
;;; c:\\program files\\acl62\\music36.cl
;;;
(load "c:\\program files\\acl62\\music35.cl")
(defun collect-chords (l)
(let ((lst (squash l)))
(do ((ll lst (cdr ll))
(w))
((null ll) (remove-duplicate (reverse w)))
(if (stringp (car ll)) (push (car ll) w)))))
(defun tell-chords-aux (l)
(let ((lst (collect-chords l)))
(do ((ll lst (cdr ll)))
((null ll))
(tell-a-chord (car ll)))))
;;;
;;; (tell-chords *w1*)
;;;
(defun tell-chords (wn)
(tagbody
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1))) (go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(tell-chords-aux l2)))
(defun tell-chords-2 (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a. *****" (car l1))
(tell-pairs-aux (remove-duplicate l2))))
;;;
;;; c:\\program files\\acl62\\music37.cl
;;;
(load "c:\\program files\\acl62\\music36.cl")
(load "c:\\program files\\acl62\\work1.cl")
(make-frame-from-list
'(M7 (CM7 (value "E7" "+F7" "-G7" "A7" "B7"))))
(make-frame-from-list
'(m7 (Cm7 (value "+D7" "-E7" "E7" "+A7" "-B7"))))
(make-frame-from-list
'(m7-5 (Cm7-5 (value "+C7" "-D7" "+D7" "-E7" "+A7" "-B7"))))
(make-frame-from-list
'(d7 (C7 (value "A7"))))
;;;
;;;
;;;
(defun get-M7-of-CM7 () (fget-i 'M7 'CM7))
(defun get-m7-of-Cm7 () (fget-i 'm7 'Cm7))
(defun get-m7-5-of-Cm7-5 () (fget-i 'm7-5 'Cm7-5))
(defun get-d7-of-C7 () (fget-i 'd7 'C7))
;;;
;;;
;;;
(defun collect-DC-dominant-M7 (chord)
(remove-duplicate (modulate-key1-to-key2 (get-M7-of-CM7) 'C (involve-atom-p chord))))
(defun collect-DC-dominant-m7 (chord)
(remove-duplicate (modulate-key1-to-key2 (get-m7-of-Cm7) 'C (involve-atom-p chord))))
(defun collect-DC-dominant-m7-5 (chord)
(remove-duplicate (modulate-key1-to-key2 (get-m7-5-of-Cm7-5) 'C (involve-atom-p chord))))
(defun collect-DC-dominant-d7 (chord)
(remove-duplicate (modulate-key1-to-key2 (get-d7-of-C7) 'C (involve-atom-p chord))))
;;;
;;;
;;;
(defun collect-DC-dominant (chord)
(cond ((search-s1-in-s2 "m7-5" chord) (collect-DC-dominant-m7-5 chord))
((search-s1-in-s2 "m7" chord) (collect-DC-dominant-m7 chord))
((search-s1-in-s2 "M7" chord) (collect-DC-dominant-M7 chord))
((search-s1-in-s2 "7" chord) (collect-DC-dominant-d7 chord))))
;;;
;;; c:\\program files\\acl62\\music38.cl
;;;
(load "c:\\program files\\acl62\\music37.cl")
(make-frame-from-list
'(modulation-patterns-C (heikou-tyou-1 (value "Bm7-5" "E7" ("Am7") "D7" "Dm7" "G7" ("CM7")))
(heikou-tyou-2 (value ("CM7") "Am7" "Dm7" "G7" ("Am7") "Bm7-5"))
(zoku-tyou-1 (value ("CM7") "Am7" "D7" ("GM7") "Bm7" "Em7"))
(zoku-tyou-2 (value ("CM7") "-Bdim7" "Am7" "-A7" ("GM7") "Bm7" "Am7"))
(kazoku-tyou-1 (value "Dm7" "G7" "Gm7" "C7" ("FM7") "-BM7" "Gm7"
"C7" ("FM7")))
(kazoku-tyou-2 (value ("CM7") "Em7" "Am7" "-BM7" "Am7" "Gm7"
"C7" ("FM7")))
(hanon-up-1 (value ("CM7") "Dm7" "Em7" "A7" "-Em7" "-A7"
("-DM7") "-GM7"))
(hanon-up-2 (value "Dm7" "G7" "-Em7" "-A7" ("-DM7") "-Bm7"))
(zenon-up-1 (value ("CM7") "B7" "E7" "A7" ("DM7") "+Fm7" "Bm7"))
(zenon-up-2 (value ("CM7") "FM7" "-BM7" "-EM7" ("DM7") "Bm7"))
(3do-kei-1 (value ("CM7") "Dm7" "G7" ("-EM7") "Fm7" "-B7" ("-EM7")))
(3do-kei-2 (value ("CM7") "FM7" "Fm7" ("EM7") "AM7" "+Fm7" "B7" ("EM7")))
(zou4do (value "Em7" "Am7" "Dm7" "G7" ("-GM7") "-Am7"))
(6do-kei-1 (value ("CM7") "Dm7" "Gm7" "C7" ("-AM7") "Cm7" "F7"))
(6do-kei-2 (value ("CM7") "-BM7" "CM7" "E7" ("AM7") "+Fm7"))
(7do-kei-1 (value "Dm7" "G7" "Cm7" "F7" "-BM7" "-EM7" "F7" ("-BM7")))
(7do-kei-2 (value "FM7" "Em7" "-Em7" "Dm7" "+Cm7" ("BM7") "+Gm7"))))
(defun get-modulate-patterns (key)
(if (eq key 'C)
(fget-frame 'modulation-patterns-C)
(modulate-key1-to-key2 (fget-frame 'modulation-patterns-C) 'C key)))
(defun list-modulate-patterns (key)
(print (get-modulate-patterns key)))
(defun get-modulation ()
(prog (key num)
(format t "~%Enter a key !")
(setf key (car (read-sentence)))
(format t "~%１．平行調")
(format t "~%２．属調")
(format t "~%３．下属調")
(format t "~%４．半音上の調")
(format t "~%５．全音上の調")
(format t "~%６．３度系の調")
(format t "~%７．増４度の調")
(format t "~%８．６度系の調")
(format t "~%９．７度系の調")
loop1
(format t "~%Enter a number !")
(setf num (car (read-sentence)))
(if (member num '(1 2 3 4 5 6 7 8 9))
(go loop2)
(go loop1))
loop2
(case num
(1 (return (list key
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'heikou-tyou-1) 'C key)
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'heikou-tyou-2) 'C key))))
(2 (return (list key
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'zoku-tyou-1) 'C key)
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'zoku-tyou-2) 'C key))))
(3 (return (list key
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'kazoku-tyou-1) 'C key)
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'kazoku-tyou-2) 'C key))))
(4 (return (list key
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'hanon-up-1) 'C key)
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'hanon-up-2) 'C key))))
(5 (return (list key
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'zenon-up-1) 'C key)
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'zenon-up-2) 'C key))))
(6 (return (list key
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C '3do-kei-1) 'C key)
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C '3do-kei-2) 'C key))))
(7 (return (list key
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C 'zou4do) 'C key))))
(8 (return (list key
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C '6do-kei-1) 'C key)
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C '6do-kei-2) 'C key))))
(9 (return (list key
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C '7do-kei-1) 'C key)
(modulate-key1-to-key2 (fget-i 'modulation-patterns-C '7do-kei-2) 'C key)))))))
;;;
;;; c:\\program files\\acl62\\music39.cl
;;;
(load "c:\\program files\\acl62\\music38.cl")
(make-frame-from-list
'(triads-on-scale
(CM7-ion (value "C" "Dm" "Em" "F" "G" "Am" "Bm-5" "Bdim"))
(Cm7-dor (value "Cm" "Dm" "-E" "F" "Gm" "Am-5" "Adim" "-B"))
(Cm7-phr (value "Cm" "-D" "-E" "Fm" "Gm-5" "Gdim" "-A" "-Bm"))
(CM7-lyd (value "C" "D" "Em" "-Gm-5" "-Gdim" "G" "Am" "Bm"))
(C7-mix (value "C" "Dm" "Em-5" "Edim" "F" "Gm" "Am" "-B"))
(Cm7-aeo (value "Cm" "Dm-5" "Ddim" "-E" "Fm" "Gm" "-A" "-B"))
(Cm7-5-loc (value "Cm-5" "Cdim" "-D" "-Em" "Fm" "-G" "-A" "-Bm"))
(Cm7-n (value "Cm" "Dm-5" "Ddim" "-E" "Fm" "Gm" "-A" "-B"))
(Cm7-h (value "Cm" "Dm-5" "Ddim" "-Eaug" "Fm" "G" "-A" "Bm-5" "Bdim"))
(Cm7-m (value "Cm" "Dm" "-Eaug" "F" "G" "Am-5" "Adim" "Bm-5" "Bdim"
"-B" "-A" "Gm" "Fm" "-E" "Dm-5" "Ddim" "Cm"))
(Cm7-dor-2 (value "Cm" "-Daug" "-E" "F" "Gm-5" "Gdim" "Am-5" "Adim" "-Bm"))
(Cm7-5-loc+2 (value "Cm-5" "Cdim" "Dm-5" "Ddim" "-Em" "Fm" "-Gaug" "-A" "-B"))
(C7-lyd-7 (value "C" "D" "Em-5" "Edim" "-Gm-5" "-Gdim" "Gm" "Am" "-Baug"))
(C7-hmp5 (value "-A6" "-Dm-5" "-Ddim" "-Am6" "Em-5" "Edim" "Fm" "Gm-5" "Gdim" "-A" "-Bm-5" "-Bdim"))
(C7-mmp5 (value "C" "Dm-5" "Ddim" "Em-5" "Edim" "Fm" "Gm" "-Aaug" "-B"))
(C7-alt (value "Cm-5" "Cdim" "-Dm" "-Em" "Eaug" "-G" "-A" "-Bm-5" "-Bdim"))
(C7-comd (value "Cm-5" "Cdim" "-Dm-5" "-Ddim" "-Em-5" "-Edim" "Em-5" "Edim" "-Gm-5" "-Gdim"
"Gm-5" "Gdim" "Am-5" "Adim" "-Bm-5" "-Bdim"))
(Cdim7-dim (value "Cm-5" "Cdim" "Dm-5" "Ddim" "-Em-5" "-Edim" "Fm-5" "Fdim" "-Gm-5" "-Gdim"
"-Am-5" "-Adim" "Am-5" "Adim" "Bm-5" "Bdim"))
(C7-wt (value "Caug" "Daug" "Eaug" "-Gaug" "-Aaug" "-Baug"))
(C7-mixsus4 (value "C" "Dm" "Em-5" "Edim" "F" "Gm" "Am" "-B"))
(C7-mix-6 (value "C" "Dm-5" "Ddim" "Em-5" "Edim" "Fm" "Gm" "-Aaug" "-B"))))
;;;
;;; (get-triads-on-scale '("CM7" ion))
;;;
(defun get-triads-on-scale (pair)
(case (second pair)
(ion (modulate-key1-to-key2 (fget-i 'triads-on-scale 'CM7-ion) 'C (involve-atom-p (first pair))))
(dor (modulate-key1-to-key2 (fget-i 'triads-on-scale 'Cm7-dor) 'C (involve-atom-p (first pair))))
(phr (modulate-key1-to-key2 (fget-i 'triads-on-scale 'Cm7-phr) 'C (involve-atom-p (first pair))))
(lyd (modulate-key1-to-key2 (fget-i 'triads-on-scale 'CM7-lyd) 'C (involve-atom-p (first pair))))
(mix (modulate-key1-to-key2 (fget-i 'triads-on-scale 'C7-mix) 'C (involve-atom-p (first pair))))
(aeo (modulate-key1-to-key2 (fget-i 'triads-on-scale 'Cm7-aeo) 'C (involve-atom-p (first pair))))
(loc (modulate-key1-to-key2 (fget-i 'triads-on-scale 'Cm7-5-loc) 'C (involve-atom-p (first pair))))
(n (modulate-key1-to-key2 (fget-i 'triads-on-scale 'Cm7-n) 'C (involve-atom-p (first pair))))
(h (modulate-key1-to-key2 (fget-i 'triads-on-scale 'Cm7-h) 'C (involve-atom-p (first pair))))
(m (modulate-key1-to-key2 (fget-i 'triads-on-scale 'Cm7-m) 'C (involve-atom-p (first pair))))
(dor-2 (modulate-key1-to-key2 (fget-i 'triads-on-scale 'Cm7-dor-2) 'C (involve-atom-p (first pair))))
(loc+2 (modulate-key1-to-key2 (fget-i 'triads-on-scale 'Cm7-5-loc+2) 'C (involve-atom-p (first pair))))
(lyd-7 (modulate-key1-to-key2 (fget-i 'triads-on-scale 'C7-lyd-7) 'C (involve-atom-p (first pair))))
(hmp5 (modulate-key1-to-key2 (fget-i 'triads-on-scale 'C7-hmp5) 'C (involve-atom-p (first pair))))
(mmp5 (modulate-key1-to-key2 (fget-i 'triads-on-scale 'C7-mmp5) 'C (involve-atom-p (first pair))))
(alt (modulate-key1-to-key2 (fget-i 'triads-on-scale 'C7-alt) 'C (involve-atom-p (first pair))))
(comd (modulate-key1-to-key2 (fget-i 'triads-on-scale 'C7-comd) 'C (involve-atom-p (first pair))))
(dim (modulate-key1-to-key2 (fget-i 'triads-on-scale 'Cdim7-dim) 'C (involve-atom-p (first pair))))
(wt (modulate-key1-to-key2 (fget-i 'triads-on-scale 'C7-wt) 'C (involve-atom-p (first pair))))
(mixsus4 (modulate-key1-to-key2 (fget-i 'triads-on-scale 'C7-mixsus4) 'C (involve-atom-p (first pair))))
(mix-6 (modulate-key1-to-key2 (fget-i 'triads-on-scale 'C7-mix-6) 'C (involve-atom-p (first pair))))))
;;;
;;; (tell-triads-on-scale *w1*)
;;;
(defun collect-pairs-aux (lst)
(do ((l lst (cddr l))
(w))
((null l) (reverse w))
(push (list (first l) (second l)) w)))
(defun collect-pairs (lst)
(remove-duplicate (collect-pairs-aux (squash lst))))
(defun tell-triads-on-scale-aux (lst)
(let ((l (collect-pairs lst)))
(do ((ll l (cdr ll)))
((null ll))
(format t "~% ~a : ~a." (car ll) (get-triads-on-scale (car ll))))))
(defun tell-triads-on-scale (wn)
(tagbody
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a." (car l1))
(tell-triads-on-scale-aux l2)))
;;;
;;; c:\\program files\\acl62\\music40.cl
;;;
(load "c:\\program files\\acl62\\music39.cl")
(defun collect-triads-on-scales-of-CM7 ()
(remove-duplicate
(append (fget-i 'triads-on-scale 'CM7-ion)
(fget-i 'triads-on-scale 'CM7-lyd))))
(defun collect-triads-on-scales-of-Cm7 ()
(remove-duplicate
(append (fget-i 'triads-on-scale 'Cm7-dor)
(fget-i 'triads-on-scale 'Cm7-phr)
(fget-i 'triads-on-scale 'Cm7-aeo)
(fget-i 'triads-on-scale 'Cm7-n)
(fget-i 'triads-on-scale 'Cm7-h)
(fget-i 'triads-on-scale 'Cm7-m)
(fget-i 'triads-on-scale 'Cm7-dor-2))))
(defun collect-triads-on-scales-of-Cm7-5 ()
(remove-duplicate
(append (fget-i 'triads-on-scale 'Cm7-5-loc)
(fget-i 'triads-on-scale 'Cm7-5-loc+2))))
(defun collect-triads-on-scales-of-C7 ()
(remove-duplicate
(append (fget-i 'triads-on-scale 'C7-mix)
(fget-i 'triads-on-scale 'C7-lyd-7)
(fget-i 'triads-on-scale 'C7-hmp5)
(fget-i 'triads-on-scale 'C7-mmp5)
(fget-i 'triads-on-scale 'C7-alt)
(fget-i 'triads-on-scale 'C7-comd)
(fget-i 'triads-on-scale 'C7-wt)
(fget-i 'triads-on-scale 'C7-mixsus4)
(fget-i 'triads-on-scale 'C7-mix-6))))
(defun collect-triads-on-scales-of-Cdim7 ()
(fget-i 'triads-on-scale 'Cdim7-dim))
;;;
;;; (collect-triads-on-scales "CM7")
;;;
(defun collect-triads-on-scales (chord)
(cond ((search-s1-in-s2 "m7-5" chord)
(modulate-key1-to-key2 (collect-triads-on-scales-of-Cm7-5) 'C (involve-atom-p chord)))
((search-s1-in-s2 "dim" chord)
(modulate-key1-to-key2 (collect-triads-on-scales-of-Cdim7) 'C (involve-atom-p chord)))
((search-s1-in-s2 "m7" chord)
(modulate-key1-to-key2 (collect-triads-on-scales-of-Cm7) 'C (involve-atom-p chord)))
((search-s1-in-s2 "M7" chord)
(modulate-key1-to-key2 (collect-triads-on-scales-of-CM7) 'C (involve-atom-p chord)))
((search-s1-in-s2 "7" chord)
(modulate-key1-to-key2 (collect-triads-on-scales-of-C7) 'C (involve-atom-p chord)))))
;;;
;;; (tell-triads-on-scales *w1*)
;;;
(defun tell-triads-on-scales-aux (l)
(let ((lst (collect-chords l)))
(do ((ll lst (cdr ll)))
((null ll))
(format t "~% ~a : ~a." (car ll) (collect-triads-on-scales (car ll))))))
(defun tell-triads-on-scales (wn)
(tagbody
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a." (car l1))
(tell-triads-on-scales-aux l2)))
;;;
;;; c:\\program files\\acl62\\music41.cl
;;;
(load "c:\\program files\\acl62\\music40.cl")
(defun tell-a-pair-again (l)
(let ((lst (collect-pairs l)))
(do ((ll lst (cdr ll)))
((null ll))
(format t "~%************************ ~a ***********************." (car ll))
(tell-a-pair-aux (car ll)))))
;;;
;;; (tell-pairs-again *w1*)
;;;
(defun tell-pairs-again (wn)
(tagbody
(my-randomize)
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(tell-a-pair-again l2)))
;;;
;;; (indicate-a-key 'C 'major) (indicate-a-key 'C 'minor) etc.
;;;
(defun indicate-a-key (key type)
(format t "~%***** On the key ~a. *****" (concatenate 'string (string key) "-" (string type)))
(format t "~%~a." (rest (instantiate-a-key key type))))
;;;
;;; (get-chords-of-a-function-in-a-key 'C 'major 'tonic)
;;;
(defun get-chords-of-a-function-in-a-key (key type function)
(let ((lst (instantiate-a-key key type)))
(cdr (second (assoc function (cdr lst))))))
;;;
;;; (get-all-DC-chords "G7")
;;;
(defun get-all-DC-chords (dominant-chord)
(append (get-DC dominant-chord 1)
(list (car (get-DC dominant-chord 2)))
(list (car (get-DC dominant-chord 3)))
(list (car (get-DC dominant-chord 4)))))
(defun indicate-all-DC-chords (dc)
(format t "~%For ~a all DC chords are ~a." dc (get-all-DC-chords dc)))
;;;
;;; c:\\program files\\acl62\\music42.cl
;;;
(load "c:\\program files\\acl62\\music41.cl")
(make-frame-from-list
'(chords-on-scale
(CM7-ion-2 (value "CM7" "Dm7" "Em7" "FM7" "G7" "Am7" "Bm7-5"))
(Cm7-dor-2 (value "Cm7" "Dm7" "-EM7" "F7" "Gm7" "Am7-5" "-BM7"))
(Cm7-phr-2 (value "Cm7" "-DM7" "-E7" "Fm7" "Gm7-5" "-AM7" "-Bm7"))
(CM7-lyd-2 (value "CM7" "D7" "Em7" "+Fm7-5" "GM7" "Am7" "Bm7"))
(C7-mix-2 (value "C7" "Dm7" "Em7-5" "FM7" "Gm7" "Am7" "-BM7"))
(Cm7-aeo-2 (value "Cm7" "Dm7-5" "-EM7" "Fm7" "Gm7" "-AM7" "-B7"))
(Cm7-5-loc-2 (value "Cm7-5" "-DM7" "-Em7" "Fm7" "-GM7" "-AM7" "-Bm7"))
(Cm7-n-2 (value "Cm7" "Dm7-5" "-EM7" "Fm7" "Gm7" "-AM7" "-B7"))
(Cm7-h-2 (value "CmM7" "Dm7-5" "-EaugM7" "Fm7" "G7" "-AM7" "Bdim"))
(Cm7-m-2 (value "CmM7" "Dm7" "-EaugM7" "F7" "G7" "Am7-5" "Bm7-5" "Cm7"
"-B7" "-AM7" "Gm7" "Fm7" "-EM7" "Dm7-5"))
(Cm7-dor-2-2 (value "Cm7-5" "-DaugM7" "-E7" "F7" "Gm7-5" "Am7-5" "-BmM7"))
(Cm7-5-loc+2-2 (value "Cm7-5" "Dm7-5" "-EmM7" "Fm7" "-GaugM7" "-A7" "-B7"))
(C7-lyd-7-2 (value "C7" "D7" "Em7-5" "+Fm7-5" "GmM7" "Am7" "-BaugM7"))
(C7-hmp5-2 (value "Fm7" "-Ddim7" "Edim7" "Gdim7" "-Bdim7"))
(C7-mmp5-2 (value "C7" "Dm7-5" "Em7-5" "FmM7" "Gm7" "-AaugM7" "-B7"))
(C7-alt-2 (value "Cm7-5" "-DmM7" "-Em7" "EaugM7" "-G7" "-A7" "-Bm7-5"))
(C7-comd-2 (value "Cdim7" "-Ddim7" "-Edim7" "Edim7" "-Gdim7" "Gdim7" "Adim7" "-Bdim7"))
(Cdim7-dim-2 (value "Cdim7" "Ddim7" "-Edim7" "Fdim7" "-Gdim7" "-Adim7" "Adim7" "Bdim7"))
(C7-wt-2 (value "Caug" "Daug" "Eaug" "-Gaug" "-Aaug" "-Baug"))
(C7-mixsus4-2 (value "C7" "Dm7" "Em7-5" "FM7" "Gm7" "Am7" "-BM7"))
(C7-mix-6-2 (value "C7" "Dm7-5" "Em7-5" "FmM7" "Gm7" "-AaugM7" "-B7"))))
;;;
;;; (get-chords-on-scale '("CM7" ion))
;;;
(defun get-chords-on-scale (pair)
(case (second pair)
(ion (modulate-key1-to-key2 (fget-i 'chords-on-scale 'CM7-ion-2) 'C (involve-atom-p (first pair))))
(dor (modulate-key1-to-key2 (fget-i 'chords-on-scale 'Cm7-dor-2) 'C (involve-atom-p (first pair))))
(phr (modulate-key1-to-key2 (fget-i 'chords-on-scale 'Cm7-phr-2) 'C (involve-atom-p (first pair))))
(lyd (modulate-key1-to-key2 (fget-i 'chords-on-scale 'CM7-lyd-2) 'C (involve-atom-p (first pair))))
(mix (modulate-key1-to-key2 (fget-i 'chords-on-scale 'C7-mix-2) 'C (involve-atom-p (first pair))))
(aeo (modulate-key1-to-key2 (fget-i 'chords-on-scale 'Cm7-aeo-2) 'C (involve-atom-p (first pair))))
(loc (modulate-key1-to-key2 (fget-i 'chords-on-scale 'Cm7-5-loc-2) 'C (involve-atom-p (first pair))))
(n (modulate-key1-to-key2 (fget-i 'chords-on-scale 'Cm7-n-2) 'C (involve-atom-p (first pair))))
(h (modulate-key1-to-key2 (fget-i 'chords-on-scale 'Cm7-h-2) 'C (involve-atom-p (first pair))))
(m (modulate-key1-to-key2 (fget-i 'chords-on-scale 'Cm7-m-2) 'C (involve-atom-p (first pair))))
(dor-2 (modulate-key1-to-key2 (fget-i 'chords-on-scale 'Cm7-dor-2-2) 'C (involve-atom-p (first pair))))
(loc+2 (modulate-key1-to-key2 (fget-i 'chords-on-scale 'Cm7-5-loc+2-2) 'C (involve-atom-p (first pair))))
(lyd-7 (modulate-key1-to-key2 (fget-i 'chords-on-scale 'C7-lyd-7-2) 'C (involve-atom-p (first pair))))
(hmp5 (modulate-key1-to-key2 (fget-i 'chords-on-scale 'C7-hmp5-2) 'C (involve-atom-p (first pair))))
(mmp5 (modulate-key1-to-key2 (fget-i 'chords-on-scale 'C7-mmp5-2) 'C (involve-atom-p (first pair))))
(alt (modulate-key1-to-key2 (fget-i 'chords-on-scale 'C7-alt-2) 'C (involve-atom-p (first pair))))
(comd (modulate-key1-to-key2 (fget-i 'chords-on-scale 'C7-comd-2) 'C (involve-atom-p (first pair))))
(dim (modulate-key1-to-key2 (fget-i 'chords-on-scale 'Cdim7-dim-2) 'C (involve-atom-p (first pair))))
(wt (modulate-key1-to-key2 (fget-i 'chords-on-scale 'C7-wt-2) 'C (involve-atom-p (first pair))))
(mixsus4 (modulate-key1-to-key2 (fget-i 'chords-on-scale 'C7-mixsus4-2) 'C (involve-atom-p (first pair))))
(mix-6 (modulate-key1-to-key2 (fget-i 'chords-on-scale 'C7-mix-6-2) 'C (involve-atom-p (first pair))))))
;;;
;;; (tell-chords-on-scale *w1*)
;;;
(defun tell-chords-on-scale-aux (lst)
(let ((l (collect-pairs lst)))
(do ((ll l (cdr ll)))
((null ll))
(format t "~% ~a : ~a." (car ll) (get-chords-on-scale (car ll))))))
(defun tell-chords-on-scale (wn)
(tagbody
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a." (car l1))
(tell-chords-on-scale-aux l2)))
(defun collect-chords-on-scales-of-CM7 ()
(remove-duplicate
(append (fget-i 'chords-on-scale 'CM7-ion-2)
(fget-i 'chords-on-scale 'CM7-lyd-2))))
(defun collect-chords-on-scales-of-Cm7 ()
(remove-duplicate
(append (fget-i 'chords-on-scale 'Cm7-dor-2)
(fget-i 'chords-on-scale 'Cm7-phr-2)
(fget-i 'chords-on-scale 'Cm7-aeo-2)
(fget-i 'chords-on-scale 'Cm7-n-2)
(fget-i 'chords-on-scale 'Cm7-h-2)
(fget-i 'chords-on-scale 'Cm7-m-2)
(fget-i 'chords-on-scale 'Cm7-dor-2-2))))
(defun collect-chords-on-scales-of-Cm7-5 ()
(remove-duplicate
(append (fget-i 'chords-on-scale 'Cm7-5-loc-2)
(fget-i 'chords-on-scale 'Cm7-5-loc+2-2))))
(defun collect-chords-on-scales-of-C7 ()
(remove-duplicate
(append (fget-i 'chords-on-scale 'C7-mix-2)
(fget-i 'chords-on-scale 'C7-lyd-7-2)
(fget-i 'chords-on-scale 'C7-hmp5-2)
(fget-i 'chords-on-scale 'C7-mmp5-2)
(fget-i 'chords-on-scale 'C7-alt-2)
(fget-i 'chords-on-scale 'C7-comd-2)
(fget-i 'chords-on-scale 'C7-wt-2)
(fget-i 'chords-on-scale 'C7-mixsus4-2)
(fget-i 'chords-on-scale 'C7-mix-6-2))))
(defun collect-chords-on-scales-of-Cdim7 ()
(fget-i 'chords-on-scale 'Cdim7-dim))
;;;
;;; (collect-chords-on-scales "CM7")
;;;
(defun collect-chords-on-scales (chord)
(cond ((search-s1-in-s2 "m7-5" chord)
(modulate-key1-to-key2 (collect-chords-on-scales-of-Cm7-5) 'C (involve-atom-p chord)))
((search-s1-in-s2 "dim" chord)
(modulate-key1-to-key2 (collect-chords-on-scales-of-Cdim7) 'C (involve-atom-p chord)))
((search-s1-in-s2 "m7" chord)
(modulate-key1-to-key2 (collect-chords-on-scales-of-Cm7) 'C (involve-atom-p chord)))
((search-s1-in-s2 "M7" chord)
(modulate-key1-to-key2 (collect-chords-on-scales-of-CM7) 'C (involve-atom-p chord)))
((search-s1-in-s2 "7" chord)
(modulate-key1-to-key2 (collect-chords-on-scales-of-C7) 'C (involve-atom-p chord)))))
;;;
;;; (tell-chords-on-scales *w1*)
;;;
(defun tell-chords-on-scales-aux (l)
(let ((lst (collect-chords l)))
(do ((ll lst (cdr ll)))
((null ll))
(format t "~% ~a : ~a." (car ll) (collect-chords-on-scales (car ll))))))
(defun tell-chords-on-scales (wn)
(tagbody
(format t "~%***** ~a *****" (second (first wn)))
(format t "~%The original key is ~a." (first (first wn)))
(format t "~%Enter a key.")
loop1
(setf l1 (read-sentence))
(if (not (key-p (car l1)))
(go loop1))
(if (equal (car l1) (first (first wn)))
(setf l2 (cdr wn))
(setf l2 (modulate-key1-to-key2 (cdr wn) (first (first wn)) (car l1))))
(format t "~%***** The key is ~a." (car l1))
(tell-chords-on-scales-aux l2)))
コメント
コメントを投稿