;;;
;;; 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))))