;;;
;;; C:\\program files\\acl62\\music19.cl
;;;
(load "c:\\program files\\acl62\\music18.cl")
;;;
;;;(get-chord-tone-2 '("CM7" ion))
;;;(do mi so si)
;;;
(defun get-chord-tone-2 (pair)
(translate-flat-to-sharp-in-a-list (get-chord-tone (car pair))))
(defun get-chord-scale-2 (pair)
(translate-flat-to-sharp-in-a-list (chord-scale pair)))
(defun get-tension-note-2 (pair)
(translate-flat-to-sharp-in-a-list (tension-note pair)))
(defun get-guide-tone-2 (pair)
(translate-flat-to-sharp-in-a-list (guide-tone pair)))
(defun get-elements-of-melody-2 (pair)
(translate-flat-to-sharp-in-a-list (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))))
;;;
;;;(sharp-a-note 're)
;;;+re
;;;
(defun sharp-a-note (note)
(let ((num (translate-sound-to-number-2 note)))
(translate-number-to-sound-2 (+ 0.5 num) 0.0)))
;;;
;;;(flat-a-note 'do)
;;;si
;;;
(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))))
;;;
;;;(sharp-till-chord-tone 're '("CM7" ion))
;;;(re mi)
;;;
(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)))))
;;;
;;;(flat-till-chord-tone 're '("CM7" ion))
;;;(re do)
;;;
(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)))))
;;;
;;;(generate-a-phrase-aux '("CM7" ion))
;;;(mi si (re do) mi (la so) si (la si) (re do))
;;;
(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 generate-a-phrase-at-random-2 (pair)
(generate-a-phrase-of-n-notes pair (1+ (random 3))))
(defun generate-a-phrase-at-random-3 (pair)
(generate-a-phrase-of-n-notes pair (1+ (random 2))))
(defun generate-a-phrase-at-random-4 (pair)
(generate-a-phrase-of-n-notes pair (1+ (random 1))))
;;;
;;;(make-a-phrase '("CM7" ion "A7" hmp5))
;;;
;;;*********** On (CM7 ion A7 hmp5) ************
;;;*********** On (CM7 ion) ************
;;;Chord Scale: (do re mi fa so la si do)
;;;(mi si mi)
;;;(mi si re do la si re do la si)
;;;(si)
;;;(si)
;;;(re do mi re do si re mi)
;;;*********** On (CM7 ion A7 hmp5) ************
;;;*********** On (A7 hmp5) ************
;;;Chord Scale: (la +la do do re mi fa so la)
;;;(fa so fa mi fa so +la do so)
;;;(so +la la do do fa so do)
;;;(do)
;;;(do do)
;;;(fa mi do +la la fa so)
;;;nil
(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" (squash (generate-a-phrase-at-random (list
(first lst) (second lst)))))
(format t "~%~a" (squash (generate-a-phrase-at-random (list
(first lst) (second lst)))))
(format t "~%~a" (squash (generate-a-phrase-at-random (list
(first lst) (second lst)))))
(format t "~%~a" (squash (generate-a-phrase-at-random (list
(first lst) (second lst)))))
(format t "~%~a" (squash (generate-a-phrase-at-random (list
(first lst) (second lst)))))))
(defun make-a-phrase-2-aux (l)
(cond ((equal (length l) 2)
(do ((lst l (cddr lst))
(w))
((null lst) (reverse w))
(let ((l1 (cons (list (first lst) (second lst))
(squash (generate-a-phrase-at-random (list (first lst)
(second lst)))))))
(push l1 w))))
((equal (length l) 4)
(do ((lst l (cddr lst))
(n2)
(w))
((null lst) (reverse w))
(let ((l2 (cons (list (first lst) (second lst))
(squash (generate-a-phrase-at-random-2 (list (first lst)
(second lst)))))))
(push l2 w))))
((equal (length l) 6)
(do ((lst l (cddr lst))
(w))
((null lst) (reverse w))
(let ((l3 (cons (list (first lst) (second lst))
(squash (generate-a-phrase-at-random-3 (list (first lst)
(second lst)))))))
(push l3 w))))))
(defun make-a-phrase-2-aux-third (l)
(cond ((equal (length l) 2)
(do ((lst l (cddr lst))
(w))
((null lst) (reverse w))
(let ((l1 (cons (list (first lst) (second lst))
(squash (generate-a-phrase-at-random-2 (list (first lst)
(second lst)))))))
(push l1 w))))
((equal (length l) 4)
(do ((lst l (cddr lst))
(n2)
(w))
((null lst) (reverse w))
(let ((l2 (cons (list (first lst) (second lst))
(squash (generate-a-phrase-at-random-3 (list (first lst)
(second lst)))))))
(push l2 w))))
((equal (length l) 6)
(do ((lst l (cddr lst))
(w))
((null lst) (reverse w))
(let ((l3 (cons (list (first lst) (second lst))
(squash (generate-a-phrase-at-random-4 (list (first lst)
(second lst)))))))
(push l3 w))))))
(defun number-of-notes (l)
(cond ((equal (length l) 1)
(- (length (first l)) 1))
((equal (length l) 2)
(- (+ (length (first l)) (length (second l))) 2))
((equal (length l) 3)
(- (+ (length (first l)) (length (second l)) (length (third l)))
3))))
;;;
;;;(make-a-phrase-1-2-aux '("CM7" ion))
;;;(((("CM7" ion) si la so mi mi)) ***3beat*** (4 8.5 16 8.5 16) ***4beat*** (4 8pause 8 "3(8pause 8 8)" 4))
;;;(make-a-phrase-1-2-aux '("CM7" ion "Dm7" dor))
;;;(((("CM7" ion) mi) (("Dm7" dor) so la so fa do)) ***3beat*** (16 16 16 16 4 4) ***4beat***
;;; ("3(8pause 8pause 8)" "3(8 8 8)" "3(8pause 8pause 8)" 4))
;;;(make-a-phrase-1-2-aux '("CM7" ion "Dm7" dor "G7" alt))
;;;(((("CM7" ion) la si si) (("Dm7" dor) mi fa) (("G7" alt) re)) ***3beat*** (16 16 8 8pause 8 8 8) ***4beat***
;;; (8.5 16 "3(8pause 8 8)" 4 4))
;;;
(defun make-a-phrase-1-2-aux (pair)
(let ((l (make-a-phrase-2-aux pair))
(n))
(setf n (number-of-notes l))
(list l '***3beat*** (get-rythm-of-3beat n) '***4beat*** (get-rythm-of-4beat
n))))
(defun make-a-phrase-1-2 (pair)
(let ((l (make-a-phrase-2-aux pair))
(n))
(setf n (number-of-notes l))
(format t "~%***~a" (list l '***3beat*** (get-rythm-of-3beat
n) '***4beat*** (get-rythm-of-4beat n)))))
;;;
;;;(make-a-phrase-1-2-aux-third '("CM7" ion))
;;;(((("CM7" ion) re do la si)) ***3beat*** (8 8 4 4) ***4beat*** (8 8 2 4))
;;;(make-a-phrase-1-2-aux-third '("CM7" ion "Dm7" dor))
;;;(((("CM7" ion) mi mi) (("Dm7" dor) mi re so fa)) ***3beat*** (16 16 8 4 8 8) ***4beat***
;;; ("3(8pause 8 8)" "3(8pause 8pause 8)" 4 "3(8pause 8 8)"))
;;;(make-a-phrase-1-2-aux-third '("CM7" ion "Dm7" dor "G7" alt))
;;;(((("CM7" ion) re mi) (("Dm7" dor) mi re) (("G7" alt) +so so)) ***3beat***
;;; ("3(8pause 8pause 8)" 16 16 16 16 4) ***4beat*** (4 8.5 16 4 "3(8pause 8 8)")
;;;
(defun make-a-phrase-1-2-aux-third (pair)
(let ((l (make-a-phrase-2-aux-third pair))
(n))
(setf n (number-of-notes l))
(list l '***3beat*** (get-rythm-of-3beat n) '***4beat*** (get-rythm-of-4beat
n))))
(defun make-a-phrase-1-2-third (pair)
(let ((l (make-a-phrase-2-aux-third pair))
(n))
(setf n (number-of-notes l))
(format t "~%***~a" (list l '***3beat*** (get-rythm-of-3beat
n) '***4beat*** (get-rythm-of-4beat n)))))
;;;
;;;(make-phrases '(("CM7" ion "A7" hmp5) ("Dm7" dor "G7" alt) ("CM7" ion)))
;;;
;;;*********** On (CM7 ion A7 hmp5) ************
;;;*********** On (CM7 ion) ************
;;;Chord Scale: (do re mi fa so la si do)
;;;(mi la so re mi)
;;;(si mi re do)
;;;(la si mi re mi mi re mi mi)
;;;(la so la so mi re do si)
;;;(mi si)
;;;*********** On (CM7 ion A7 hmp5) ************
;;;*********** On (A7 hmp5) ************
;;;Chord Scale: (la +la do do re mi fa so la)
;;;(+la la +la do do so do)
;;;(do)
;;;(so fa mi +la la do)
;;;(do do do )
;;;(so do do do +la do +la do)
;;;*********** On (Dm7 dor G7 alt) ************
;;;*********** On (Dm7 dor) ************
;;;Chord Scale: (re mi fa so la si do re)
;;;(mi re fa do mi re fa)
;;;(fa do so fa so fa fa mi re)
;;;(fa mi re fa fa)
;;;(mi re mi fa)
;;;(fa)
;;;*********** On (Dm7 dor G7 alt) ************
;;;*********** On (G7 alt) ************
;;;Chord Scale: (so +so +la si do re fa so)
;;;(+la si)
;;;(do re do re +la +so so fa si)
;;;(+la si fa si do si do re +la si)
;;;(si re re +la +so so re do re)
;;;(+so +la si +la +so so si fa do si)
;;;*********** On (CM7 ion) ************
;;;*********** On (CM7 ion) ************
;;;Chord Scale: (do re mi fa so la si do)
;;;(si si)
;;;(si la si re do si)
;;;(si la so la so)
;;;(si mi mi mi si)
;;;(re mi la so si re do re mi si)
;;;nil
;;;
(defun make-phrases (l)
(do ((lst l (cdr lst)))
((null lst))
(make-a-phrase (car lst))))
;;;
;;;(make-phrases-1-2 '(("CM7" ion "A7" hmp5) ("Dm7" dor "G7" alt) ("CM7" ion)))
;;;
;;;***((((CM7 ion) si la si) ((A7 hmp5) fa mi)) ***3beat*** (8.5 16 4 8 8) ***4beat*** (4 8.5 16 4 4))
;;;***((((Dm7 dor) fa) ((G7 alt) si si +so +la si)) ***3beat*** (16 16 16 16 4 8pause 8) ***4beat***
;;; (8 16 16 8pause 8 8pause 8 4))
;;;***((((CM7 ion) la si re mi)) ***3beat*** (4 8.5 16 4) ***4beat*** (4 8 8 2))
;;;nil
;;;
(defun make-phrases-1-2 (l)
(do ((lst l (cdr lst)))
((null lst))
(make-a-phrase-1-2 (car lst))))
;;;
;;;(make-phrases-1-2-third '(("CM7" ion "A7" hmp5) ("Dm7" dor "G7" alt) ("CM7" ion)))
;;;
;;;***((((CM7 ion) la si mi) ((A7 hmp5) do do)) ***3beat*** (8 8 4 3(8pause 8 8)) ***4beat***
;;; (4 4 3(8pause 8 8) 4))
;;;***((((Dm7 dor) do) ((G7 alt) +la +so so)) ***3beat*** (3(8pause 8 8) 4 4) ***4beat*** (2 4 8 8))
;;;***((((CM7 ion) si si)) ***3beat*** (2 4) ***4beat*** (4 2.5))
;;;
(defun make-phrases-1-2-third (l)
(do ((lst l (cdr lst)))
((null lst))
(make-a-phrase-1-2-third (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)))
(defun auto-comp2-second (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-1-2 l2)))
(defun auto-comp2-third (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-1-2-third l2)))