;;;
;;; (load "c:\\program files\\acl62\\music52.cl")
;;;
(load "c:\\program files\\acl62\\music12.cl")
(defun get-all-UST (chord-name)
(rest (second (assoc 'all (get-UST chord-name)))))
(defun translate-number-to-sound-flat (n offset key)
(let ((num (confine-a-number (+ n offset))))
(case num
(1.0 'do)
(1.5 '-re)
(2.0 're)
(2.5 '-mi)
(3.0 'mi)
(3.5 'fa)
(4.0 '-so)
(4.5 'so)
(5.0 '-la)
(5.5 'la)
(6.0 '-si)
(6.5 'si))))
(defun translate-number-to-sound-sharp (n offset key)
(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-list-of-number-to-sound-flat (l offset key)
(mapcar #'(lambda (e) (translate-number-to-sound-flat e offset key)) l))
(defun translate-list-of-number-to-sound-sharp (l offset key)
(mapcar #'(lambda (e) (translate-number-to-sound-sharp e offset key)) l))
(defun get-chord-tone-flat (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-flat lst num (involve-character-p scn))))
(defun get-chord-tone-sharp (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-sharp lst num (involve-character-p scn))))
(defun get-UST-with-a-note-flat (note chord-name)
(do ((lst (get-all-UST chord-name) (cdr lst))
(w))
((null lst) w)
(let ((lst-flat (get-chord-tone-flat (car lst))))
(if (member note lst-flat)
(push (list note (car lst) lst-flat) w)))))
(defun get-UST-with-a-note-sharp (note chord-name)
(do ((lst (get-all-UST chord-name) (cdr lst))
(w))
((null lst) w)
(let ((lst-sharp (get-chord-tone-sharp (car lst))))
(if (member note lst-sharp)
(push (list note (car lst) lst-sharp) w)))))
;;;
;;; (get-UST-with-a-note 're "CM7")
;;;
(defun get-UST-with-a-note (note chord-name)
(remove-duplicate (append (get-UST-with-a-note-flat note chord-name)
(get-UST-with-a-note-sharp note chord-name))))
;;;
;;; (get-all-tension-notes-M7 'C)
;;;
(defun get-all-tension-notes-M7 (char)
(remove-duplicate (append (get-tension-note char 'ion)
(get-tension-note char 'lyd))))
(defun get-all-tension-notes-m7 (char)
(remove-duplicate (append (get-tension-note char 'dor)
(get-tension-note char 'phr)
(get-tension-note char 'aeo)
(get-tension-note char 'n)
(get-tension-note char 'h)
(get-tension-note char 'dor-2))))
(defun get-all-tension-notes-7 (char)
(remove-duplicate (append (get-tension-note char 'mix)
(get-tension-note char 'lyd-7)
(get-tension-note char 'alt)
(get-tension-note char 'hmp5)
(get-tension-note char 'comd)
(get-tension-note char 'wt))))
(defun get-all-tension-notes-7sus4 (char)
(remove-duplicate (append (get-tension-note char 'mixsus4))))
(defun get-all-tension-notes-m7-5 (char)
(remove-duplicate (append (get-tension-note char 'loc)
(get-tension-note char 'loc+2))))
(defun get-all-tension-notes-mM7 (char)
(remove-duplicate (append (get-tension-note char 'h)
(get-tension-note char 'm)
(get-tension-note char 'dor))))
(defun get-all-tension-notes-dim7 (char)
(remove-duplicate (append (get-tension-note char 'dim))))
;;;
;;; (get-all-tension-notes "CM7")
;;;
(defun get-all-tension-notes (chord-name)
(cond ((equal (get-chord-type2 chord-name) "M7")
(get-all-tension-notes-M7 (intern (involve-char-p chord-name))))
((equal (get-chord-type2 chord-name) "m7")
(get-all-tension-notes-m7 (intern (involve-char-p chord-name))))
((equal (get-chord-type2 chord-name) "7")
(get-all-tension-notes-7 (intern (involve-char-p chord-name))))
((equal (get-chord-type2 chord-name) "7sus4")
(get-all-tension-notes-7sus4 (intern (involve-char-p chord-name))))
((equal (get-chord-type2 chord-name) "m7-5")
(get-all-tension-notes-m7-5 (intern (involve-char-p chord-name))))
((equal (get-chord-type2 chord-name) "mM7")
(get-all-tension-notes-mM7 (intern (involve-char-p chord-name))))
((equal (get-chord-type2 chord-name) "dim7")
(get-all-tension-notes-dim7 (intern (involve-char-p chord-name))))
))
;;;
;;;(get-UST-with-notes-in-a-list '(do re mi) "CM7")
;;;(((do "Am" (la do mi) ))
;;; ((re "Bm" (si re -so)) (re "D" (re -so la)) (re "G" (so si re)) (re "Bm" (si re +fa)) (re "D" (re +fa la)))
;;; ((mi "Em" (mi so si)) (mi "Am" (la do mi))))
;;;
(defun get-UST-with-notes-in-a-list (lst chord-name)
(do ((l lst (cdr l))
(w))
((null l) (reverse w))
(push (get-UST-with-a-note (car l) chord-name) w)))
;;;
;;;(show-UST-with-notes-in-a-list '(do re mi) "CM7")
;;;***((do Am (la do mi) ))
;;;***((re Bm (si re -so)) (re D (re -so la)) (re G (so si re)) (re Bm (si re +fa)) (re D (re +fa la)))
;;;***((mi Em (mi so si)) (mi Am (la do mi)))
;;;
(defun show-UST-with-notes-in-a-list (lst chord-name)
(do ((l lst (cdr l)))
((null l))
(format t "~%***~a" (get-UST-with-a-note (car l) chord-name))))
;;;
;;;(get-UST-with-notes-for-pair '("CM7" ion))
;;;(((do "Am" (la do mi) ))
;;; ((re "Bm" (si re -so)) (re "D" (re -so la)) (re "G" (so si re)) (re "Bm" (si re +fa)) (re "D" (re +fa la)))
;;; ((mi "Em" (mi so si)) (mi "Am" (la do mi))) (fa No-UST) ((so "Em" (mi so si)) (so "G" (so si re)))
;;; ((la "D" (re -so la)) (la "Am" (la do mi)) (la "D" (re +fa la)))
;;; ((si "Bm" (si re -so)) (si "Em" (mi so si)) (si "G" (so si re)) (si "Bm" (si re +fa)))
;;; ((do "Am" (la do mi) )))
;;;
(defun get-UST-with-notes-for-pair (pair)
(do ((l (chord-scale pair) (cdr l))
(w))
((null l) (reverse w))
(let ((l2 (get-UST-with-a-note (car l) (car pair)))
(note (car l)))
(if (null l2)
(push (list note 'No-UST) w)
(push l2 w)))))
;;;
;;;(show-UST-with-notes-for-pair '("CM7" ion))
;;;***((do Am (la do mi) ))
;;;***((re Bm (si re -so)) (re D (re -so la)) (re G (so si re)) (re Bm (si re +fa)) (re D (re +fa la)))
;;;***((mi Em (mi so si)) (mi Am (la do mi)))
;;;*** fa::No UST
;;;***((so Em (mi so si)) (so G (so si re)))
;;;***((la D (re -so la)) (la Am (la do mi)) (la D (re +fa la)))
;;;***((si Bm (si re -so)) (si Em (mi so si)) (si G (so si re)) (si Bm (si re +fa)))
;;;***((do Am (la do mi) ))
;;;
;;;(show-UST-with-notes-for-pair '("G7" alt))
;;;***((so Em (mi so si)) (so +D (-mi so -si)) (so +D (+re so +la)))
;;;***((+so +Cm (+do mi +so)) (+so +Gm (+so si +re)) (+so Fm (fa +so do)) (+so E (mi +so si))
;;; (+so +C (+do fa +so)))
;;;***((+la +Am (+la +do fa)) (+la +D (+re so +la)) (+la +A (+la re fa)))
;;;***((si Em (mi so si)) (si +Gm (-la si -mi)) (si E (mi -la si)) (si +Gm (+so si +re)) (si E (mi +so si)))
;;;***((do F (fa la do) ) (do Fm (fa -la do) ) (do Fm (fa +so do) ))
;;;***((re Dm (re fa la)) (re +A (-si re fa)) (re +A (+la re fa)))
;;;***((fa +Am (-si -re fa)) (fa Dm (re fa la)) (fa F (fa la do)) (fa Fm (fa -la do)) (fa +C (-re fa -la))
;;; (fa +A (-si re fa)) (fa +Am (+la +do fa)) (fa Fm (fa +so do)) (fa +C (+do fa +so)) (fa +A (+la re fa)))
;;;***((so Em (mi so si)) (so +D (-mi so -si)) (so +D (+re so +la)))
;;;
(defun show-UST-with-notes-for-pair (pair)
(do ((l (chord-scale pair) (cdr l)))
((null l))
(let ((l2 (get-UST-with-a-note (car l) (car pair)))
(note (car l)))
(if (null l2)
(format t "~%*** ~a::No UST" note)
(format t "~%***~a" l2)))))
;;;
;;;(get-chord-with-tension "CM7")--->((do mi so si) (re la -so))
;;;
(defun get-chord-with-tension (chord-name)
(list (get-chord-tone chord-name) (get-all-tension-notes chord-name)))
;;;
;;;(get-a-UST-at-random-from-pair '("CM7" ion))--->(so si re)
;;;
(defun get-a-UST-at-random-from-pair (pair)
(let ((USTs (get-all-UST (car pair))))
(get-chord-tone (nth (random (length USTs)) USTs))))
;;;
;;;(get-chord-with-tension-from-pair '("CM7" ion))--->(do mi so si re la -so)
;;;cg-user(41): (get-chord-with-tension-from-pair '("G7" all))--->(so si re fa la mi +do +so +la +re)
;;;
(defun get-chord-with-tension-from-pair (pair)
(squash (get-chord-with-tension (car pair))))
;;;
;;;(get-all-tension-notes "Am7")
;;;(si re fa +fa)
;;;