(load "c:\\program files\\acl62\\music51.cl")



;;;
;;;(get-all-UST "Am7")
;;;("Em" "E" "F" "G" "C" "Bm")
;;;
(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") 
;;;((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)))
;;;
(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 'wt)
                            (get-tension-note char 'comd))))

(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 "Am7")
;;;(si re fa +fa)
;;;
(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))))
        ))