;;;
;;; c:\\program files\\acl62\\music2.cl
;;;
(load "c:\\program files\\acl62\\music1.cl")
(setf *print-length* 1000)
(defun +key-p (key)
(if (member key '(G +F B E A D +d +g +c +f b e))
t
nil))
(defun confine-a-number (n)
(prog (num)
(setf num (eval (cons '+ (multiple-value-list (floor n 7.0)))))
(cond ((and (>= num 0.8) (<= num 1.2)) (return 1.0))
((and (>= num 1.3) (<= num 1.7)) (return 1.5))
((and (>= num 1.8) (<= num 2.2)) (return 2.0))
((and (>= num 2.3) (<= num 2.7)) (return 2.5))
((and (>= num 2.8) (<= num 3.2)) (return 3.0))
((and (>= num 3.3) (<= num 3.7)) (return 3.5))
((and (>= num 3.8) (<= num 4.2)) (return 4.0))
((and (>= num 4.3) (<= num 4.7)) (return 4.5))
((and (>= num 4.8) (<= num 5.2)) (return 5.0))
((and (>= num 5.3) (<= num 5.7)) (return 5.5))
((and (>= num 5.8) (<= num 6.2)) (return 6.0))
((and (>= num 6.3) (<= num 6.7)) (return 6.5)))))
(defun translate-number-to-sound (n offset key)
(let ((num (confine-a-number (+ n offset))))
(case num
(1.0 'do)
(1.5 (if (+key-p key)
'+do
'-re))
(2.0 're)
(2.5 (if (+key-p key)
'+re
'-mi))
(3.0 'mi)
(3.5 'fa)
(4.0 (if (+key-p key)
'+fa
'-so))
(4.5 'so)
(5.0 (if (+key-p key)
'+so
'-la))
(5.5 'la)
(6.0 (if (+key-p key)
'+la
'-si))
(6.5 'si))))
(defun translate-list-of-number-to-sound (l offset key)
(mapcar #'(lambda (e) (translate-number-to-sound e offset key)) l))
(defun translate-alphabet-to-number (c)
(case c
(c 1.0)(C 1.0)
(+c 1.5)(+C 1.5)(-d 1.5)(-D 1.5)
(d 2.0)(D 2.0)
(+d 2.5)(+D 2.5)(-e 2.5)(-E 2.5)
(e 3.0)(E 3.0)
(f 3.5)(F 3.5)
(+f 4.0)(+F 4.0)(-g 4.0)(-G 4.0)
(g 4.5)(G 4.5)
(+g 5.0)(+G 5.0)(-a 5.0)(-A 5.0)
(a 5.5)(A 5.5)
(+a 6.0)(+A 6.0)(-b 6.0)(-B 6.0)
(b 6.5)(B 6.5)))
;;;
;;; (get-chordscale 'c 'ion) =====> (do re mi fa so la si do)
;;;
(defun get-chordscale (c csn)
(translate-list-of-number-to-sound (fget-i 'scale csn) (1- (translate-alphabet-to-number
c)) c))
;;;
;;; (get-tension-note 'C 'ion)
;;;
(defun get-tension-note (c csn)
(translate-list-of-number-to-sound (fget-i 'tension-note csn) (1- (translate-alphabet-to-number
c)) c))
;;;
;;;
;;;
(defun get-chord-type (scn)
(cond ((search-s1-in-s2 "7(+11 13)" scn) 'd7+1113)
((search-s1-in-s2 "7(+9+11)" scn) 'd7+9+11)
((search-s1-in-s2 "7(-9+11)" scn) 'd7-9+11)
((search-s1-in-s2 "7(9+11)" scn) 'd79+11)
((search-s1-in-s2 "M7(+11)" scn) 'M7+11)
((search-s1-in-s2 "mM7(11)" scn) 'mM711)
((search-s1-in-s2 "mM7(13)" scn) 'mM713)
((search-s1-in-s2 "7(+11)" scn) 'd7+11)
((search-s1-in-s2 "m7(11)" scn) 'm711)
((search-s1-in-s2 "m7(13)" scn) 'm713)
((search-s1-in-s2 "M7(13)" scn) 'M713)
((search-s1-in-s2 "mM7(9)" scn) 'mM79)
((search-s1-in-s2 "dimM7" scn) 'dimM7)
((search-s1-in-s2 "augM7" scn) 'augM7)
((search-s1-in-s2 "7sus4" scn) 'd7sus4)
((search-s1-in-s2 "(+11)" scn) 'M+11)
((search-s1-in-s2 "m(11)" scn) 'm11)
((search-s1-in-s2 "7(-9)" scn) 'd7-9)
((search-s1-in-s2 "madd9" scn) 'madd9)
((search-s1-in-s2 "7(+9)" scn) 'd7+9)
((search-s1-in-s2 "7(13)" scn) 'd713)
((search-s1-in-s2 "m7(9)" scn) 'm79)
((search-s1-in-s2 "M7(9)" scn) 'M79)
((search-s1-in-s2 "sus4" scn) 'sus4)
((search-s1-in-s2 "dim7" scn) 'dim7)
((search-s1-in-s2 "m7-5" scn) 'm7-5)
((search-s1-in-s2 "aug7" scn) 'aug7)
((search-s1-in-s2 "add9" scn) 'Madd9)
((search-s1-in-s2 "7(9)" scn) 'd79)
((search-s1-in-s2 "aug" scn) 'aug)
((search-s1-in-s2 "dim" scn) 'dim)
((search-s1-in-s2 "mM7" scn) 'mM7)
((search-s1-in-s2 "m69" scn) 'm69)
((search-s1-in-s2 "7-5" scn) 'd7-5)
((search-s1-in-s2 "-5" scn) 'M-5)
((search-s1-in-s2 "m7" scn) 'm7)
((search-s1-in-s2 "M7" scn) 'M7)
((search-s1-in-s2 "m6" scn) 'm6)
((search-s1-in-s2 "69" scn) 'M69)
((search-s1-in-s2 "m" scn) 'mt)
((search-s1-in-s2 "7" scn) 'd7)
((search-s1-in-s2 "6" scn) 'M6)
(t 'Mt)))
(defun involve-character-p (s)
(let ((lst '("+C" "-D" "+D" "-E"
"+F" "-G" "+G" "-A" "+A"
"-B" "C" "D" "E" "F"
"G" "A" "B")))
(do ((l lst (cdr l)))
((null l))
(cond ((search-s1-in-s2 (car l) s)
(return (intern (car l))))))))
;;;
;;; (get-chord-tone "CM7") =====> (do mi so si)
;;;
(defun get-chord-tone (scn)
(let ((num (1- (translate-alphabet-to-number (involve-character-p scn))))
(lst (fget-i 'code (get-chord-type scn))))
(translate-list-of-number-to-sound lst num (involve-character-p scn))))
;;;
;;; (get-guide-tone "CM7")
;;;
(defun get-guide-tone (scn)
(let ((num (1- (translate-alphabet-to-number (involve-character-p scn))))
(lst (fget-i 'guide-tone (get-chord-type scn))))
(translate-list-of-number-to-sound lst num (involve-character-p scn))))
;;;
;;;
;;;
(defun translate-roman-to-number (s)
(cond ((equal s "I") 1.0)
((or (equal s "+I") (equal s "-II")) 1.5)
((equal s "II") 2.0)
((or (equal s "+II") (equal s "-III")) 2.5)
((equal s "III") 3.0)
((equal s "IV") 3.5)
((or (equal s "+IV") (equal s "-V")) 4.0)
((equal s "V") 4.5)
((or (equal s "+V") (equal s "-VI")) 5.0)
((equal s "VI") 5.5)
((or (equal s "+VI") (equal s "-VII")) 6.0)
((equal s "VII") 6.5)))
(defun translate-number-to-roman (n offset key)
(let ((num (confine-a-number (+ n offset))))
(case num
(1.0 "I")
(1.5 (if (+key-p key)
"+I"
"-II"))
(2.0 "II")
(2.5 (if (+key-p key)
"+II"
"-III"))
(3.0 "III")
(3.5 "IV")
(4.0 (if (+key-p key)
"+IV"
"-V"))
(4.5 "V")
(5.0 (if (+key-p key)
"+V"
"-VI"))
(5.5 "VI")
(6.0 (if (+key-p key)
"+VI"
"-VII"))
(6.5 "VII"))))
(defun translate-number-to-alphabet (n offset key)
(let ((num (confine-a-number (+ n offset))))
(case num
(1.0 "C")
(1.5 (if (+key-p key)
"+C"
"-D"))
(2.0 "D")
(2.5 (if (+key-p key)
"+D"
"-E"))
(3.0 "E")
(3.5 "F")
(4.0 (if (+key-p key)
"+F"
"-G"))
(4.5 "G")
(5.0 (if (+key-p key)
"+G"
"-A"))
(5.5 "A")
(6.0 (if (+key-p key)
"+A"
"-B"))
(6.5 "B"))))
;;;
;;; (translate-roman-to-alphabet "II" 'C) =====> "D"
;;;
(defun translate-roman-to-alphabet (s key)
(let ((num (translate-roman-to-number s)))
(translate-number-to-alphabet num (1- (translate-alphabet-to-number
key)) key)))
;;;
;;; (translate-alphabet-to-roman 'D 'C) =====> "II"
;;;
(defun translate-alphabet-to-roman (c key)
(let ((num (translate-alphabet-to-number c)))
(translate-number-to-roman num (- 6.0 (1- (translate-alphabet-to-number
key))) key)))
(defun involve-roman-p (s)
(let ((lst '("-VII" "-III" "VII" "+VI" "-VI" "+IV" "III" "+II" "-II" "+I" "II" "IV" "-V" "+V" "VI" "V" "I")))
(do ((l lst (cdr l)))
((null l))
(cond ((search-s1-in-s2 (car l) s)
(return (car l)))))))
;;;
;;; (get-chord-name-from-roman "IIm7" 'D) =====> "Em7"
;;;
(defun get-chord-name-from-roman (s key)
(let* ((roman (involve-roman-p s))
(char (translate-roman-to-alphabet roman key)))
(replace-s1-with-s2-in-s roman char s)))
(defun replace-roman (l key)
(cond ((null l) nil)
((and (not (listp l)) (involve-roman-p (string l))) (get-chord-name-from-roman
(string l) key))
((atom l) l)
(t (cons (replace-roman (car l) key) (replace-roman (cdr l) key)))))
(defun get-key-type (Mm)
(if (equal Mm 'major)
'major-key
'minor-key))
;;;
;;; (instantiate-a-key 'C 'major)
;;;
(defun instantiate-a-key (key type)
(let ((lst (fget-frame (get-key-type type))))
(replace-roman lst key)))
(defun involve-char-p (s)
(let ((lst '("+C" "-D" "+D" "-E"
"+F" "-G" "+G" "-A" "+A"
"-B" "C" "D" "E" "F"
"G" "A" "B")))
(do ((l lst (cdr l)))
((null l))
(cond ((search-s1-in-s2 (car l) s)
(return (car l)))))))
(defun get-roman-from-chord-name (s key)
(let* ((chord (involve-char-p s))
(roman (translate-alphabet-to-roman (intern chord) key)))
(replace-s1-with-s2-in-s chord roman s)))
;;;
;;;
;;;
(defun back-to-roman (l key)
(cond ((null l) nil)
((and (not (listp l)) (involve-char-p (string l))) (get-roman-from-chord-name
(string l) key))
((atom l) l)
(t (cons (back-to-roman (car l) key) (back-to-roman (cdr l) key)))))
(defun get-UST-of-C (s)
(cond ((equal s "CM7") (cdr (fget-frame 'UST-CM7)))
((equal s "Cm7") (cdr (fget-frame 'UST-Cm7)))
((equal s "Cm") (cdr (fget-frame 'UST-Cm)))
((equal s "C7") (cdr (fget-frame 'UST-C7)))
((equal s "Cdim7") (cdr (fget-frame 'UST-Cdim7)))
((equal s "C7sus4") (cdr (fget-frame 'UST-C7sus4)))
((equal s "Cm7-5") (cdr (fget-frame 'UST-Cm7-5)))
((equal s "CmM7") (cdr (fget-frame 'UST-CmM7)))))
(defun get-chord-type2 (s)
(let ((lst '("7sus4" "dim7" "m7-5" "mM7"
"M7" "m7" "m" "7")))
(do ((l lst (cdr l)))
((null l))
(cond ((search-s1-in-s2 (car l) s)
(return (car l)))))))
(defun get-C-chord-name (s)
(concatenate 'string "C" (get-chord-type2 s)))
;;;
;;; (get-UST "CM7")
;;;
(defun get-UST (s)
(let* ((lst (get-UST-of-C (get-C-chord-name s)))
(roman (back-to-roman lst 'C)))
(replace-roman roman (intern (involve-char-p s)))))
;;;
;;;
;;;
(defun modulate-key1-to-key2 (l key1 key2)
(let ((lst (back-to-roman l key1)))
(replace-roman lst key2)))