;;;
;;; c:\\program files\\acl62\\music54.cl
;;;
(load "c:\\program files\\acl62\\music27.cl")
(load "c:\\program files\\acl62\\music52.cl")
(make-frame-from-list
'(Left-Hand-Voicing
(v-C (value (mi so la re) (mi so si re) (la re mi so)
(si re mi so) (mi la re) (mi si re)
(la mi so) (la re so) (re mi so)
(do si) (si do) (re mi)))
(v-Cm7 (value (+re so la re) (la re +re so) (+re so +la re)
(+la re +re so)(+re la re) (la re so)
(re +re so) (+re +la re) (+la +re so)
(re +re so) (re +re) (do +la)))
(v-Cm7-5 (value (+re +fa +la re) (+la re +re +fa)
(+re +la re) (+la +re +fa)
(do +la) (fa +fa)))
(v-C7 (value (+la re mi la) (+la +do mi la)
(+la +do mi +so) (mi la +la re)
(mi la +la +do) (+la mi la)
(+la mi +so) (mi +la re) (mi +la +re)
(mi +la) (+la mi) (do +la)))
(v-Cdim7 (value (+re +fa la re) (la re +re +fa)
(+re la re) (la +re +so) (do la)))))
;;;
;;;(get-lhv-aux "FM7")
;;;((la do re so) (la do mi so) (re so la do)
;;; (mi so la do) (la re so) (la mi so) (re la do) (re so do)
;;; (so la do) (fa mi) ...)
;;;
(defun get-lhv-aux (chord-name)
(let ((char (intern (involve-char-p chord-name)))
(type (intern (get-chord-type2 chord-name))))
(case char
(C (case type
(M7 (fget 'Left-Hand-Voicing 'v-C 'value))
(m7 (fget 'Left-Hand-Voicing 'v-Cm7 'value))
(m7-5 (fget 'Left-Hand-Voicing 'v-Cm7-5 'value))
(|7| (fget 'Left-Hand-Voicing 'v-C7 'value))
(dim7 (fget 'Left-Hand-Voicing 'v-Cdim7 'value))))
(+C (case type
(M7 (mapcar #'m2-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'m2-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'m2-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'m2-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'m2-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(-D (case type
(M7 (mapcar #'m2-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'m2-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'m2-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'m2-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'m2-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(D (case type
(M7 (mapcar #'M2-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'M2-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'M2-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'M2-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'M2-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(+D (case type
(M7 (mapcar #'m3-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'m3-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'m3-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'m3-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'m3-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(-E (case type
(M7 (mapcar #'m3-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'m3-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'m3-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'m3-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'m3-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(E (case type
(M7 (mapcar #'M3-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'M3-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'M3-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'M3-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'M3-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(F (case type
(M7 (mapcar #'P4-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'P4-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'P4-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'P4-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'P4-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(+F (case type
(M7 (mapcar #'+4-5-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'+4-5-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'+4-5-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'+4-5-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'+4-5-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(-G (case type
(M7 (mapcar #'+4-5-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'+4-5-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'+4-5-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'+4-5-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'+4-5-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(G (case type
(M7 (mapcar #'P5-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'P5-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'P5-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'P5-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'P5-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(+G (case type
(M7 (mapcar #'m6-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'m6-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'m6-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'m6-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'m6-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(-A (case type
(M7 (mapcar #'m6-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'m6-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'m6-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'m6-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'m6-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(A (case type
(M7 (mapcar #'M6-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'M6-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'M6-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'M6-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'M6-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(+A (case type
(M7 (mapcar #'m7-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'m7-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'m7-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'m7-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'m7-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(-B (case type
(M7 (mapcar #'m7-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'m7-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'m7-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'m7-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'m7-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
(B (case type
(M7 (mapcar #'M7-up
(fget 'Left-Hand-Voicing 'v-C 'value)))
(m7 (mapcar #'M7-up
(fget 'Left-Hand-Voicing 'v-Cm7 'value)))
(m7-5 (mapcar #'M7-up
(fget 'Left-Hand-Voicing 'v-Cm7-5 'value)))
(|7| (mapcar #'M7-up
(fget 'Left-Hand-Voicing 'v-C7 'value)))
(dim7 (mapcar #'M7-up
(fget 'Left-Hand-Voicing 'v-Cdim7 'value)))))
)))
(defun get-lhv (cn)
(list cn (get-lhv-aux cn)))
;;;
;;;(show-lhv "G7")
;;;
;;;(G7
;;; ((fa la si mi) (fa +so si mi) (fa +so si +re) (si mi fa la)
;;; (si mi fa +so) (fa si mi) (fa si +re)
;;; (si fa la) (si fa +la) (si fa) (fa si) (so fa)))
;;;
(defun show-lhv (cn)
(format t "~%~a" (list cn (get-lhv-aux cn))))
;;;
;;;(get-a-lhv-at-random "-EM7")
;;;
;;; Enter an integer!
;;;900
;;;
;;;("-EM7" **lhv (so do fa) **chord (-mi so -si re)
;;; **tension (fa do la))
;;;
(defun get-a-lhv-at-random (cn)
(my-randomize)
(let ((lst (get-lhv-aux cn))
(chord-tone (get-chord-tone cn))
(tensions (get-all-tension-notes cn)))
(list cn
'**lhv (nth (random (length lst)) lst)
'**chord chord-tone '**tension tensions)))
|