;;;
;;; c:\\program files\\acl62\\music11.cl
;;;
(load "c:\\program files\\acl62\\music10.cl")

(defun translate-j-note-to-doremi (s-note)
  (cond ((equal s-note "ド") 'do)
      ((equal s-note "#ド") '+do)
      ((equal s-note "♭レ") '+do)
      ((equal s-note "#レ") '+re)
      ((equal s-note "♭ミ") '+re)
      ((equal s-note "#ミ") 'fa)
      ((equal s-note "#ファ") '+fa)
      ((equal s-note "♭ソ") '+fa)
      ((equal s-note "#ソ") '+so)
      ((equal s-note "♭ラ") '+so)
      ((equal s-note "#ラ") '+la)
      ((equal s-note "♭シ") '+la)
      ((equal s-note "#シ") 'do)
      ((equal s-note "レ") 're)
      ((equal s-note "ミ") 'mi)
      ((equal s-note "ファ") 'fa)
      ((equal s-note "ソ") 'so)
      ((equal s-note "ラ") 'la)
      ((equal s-note "シ") 'si)))

(defun replace-j-note-with-doremi (lst)
  (mapcar #'translate-j-note-to-doremi lst))

(defun replace-j-note-with-doremi-in-a-chord (s-cn)
  (replace-j-note-with-doremi (get-chord-tone s-cn)))

(defun translate-flat-to-sharp (c)
  (cond ((equal c '-do) 'si)
      ((equal c '-re) '+do)
      ((equal c '-mi) '+re)
      ((equal c '-fa) 'mi)
      ((equal c '-so) '+fa)
      ((equal c '-la) '+so)
      ((equal c '-si) '+la)
      ((equal c '+do) '+do)
      ((equal c '+re) '+re)
      ((equal c '+mi) 'fa)
      ((equal c '+fa) '+fa)
      ((equal c '+so) '+so)
      ((equal c '+la) '+la)
      ((equal c '+si) 'do)
      ((equal c 'do) 'do)
      ((equal c 're) 're)
      ((equal c 'mi) 'mi)
      ((equal c 'fa) 'fa)
      ((equal c 'so) 'so)
      ((equal c 'la) 'la)
      ((equal c 'si) 'si)
      ((equal c '--do) '+la)
      ((equal c '++do) 're)
      ((equal c '--re) 'do)
      ((equal c '++re) 'mi)
      ((equal c '--mi) 're)
      ((equal c '++mi) '+fa)
      ((equal c '--fa) '+re)
      ((equal c '++fa) 'so)
      ((equal c '--so) 'fa)
      ((equal c '++so) 'la)
      ((equal c '--la) 'so)
      ((equal c '++la) 'si)
      ((equal c '--si) 'la)
      ((equal c '++si) '+do)))

(defun translate-flat-to-sharp-in-a-list (lst)
  (mapcar #'translate-flat-to-sharp lst))

;;;
;;; (the-list-is-involved-in-a-chord '(do re mi) "CM7")
;;;
(defun the-list-is-involved-in-a-chord (lst s-cn)
  (sub-set-p (translate-flat-to-sharp-in-a-list lst)
          (replace-j-note-with-doremi-in-a-chord s-cn)))

(setf *chord-type* '("7" "M7" "mM7" "m7" "dimM7" "augM7" "7sus4" "sus4"
              "dim7" "m7-5" "aug7" "aug" "dim" "-5" "m6" "69" "m69" "6" ""))

(defun C-chord (type) (concatenate 'string "C" type))
(defun get-C-chords () (mapcar #'C-chord *chord-type*))
(defun +C-chord (type) (concatenate 'string "+C" type))
(defun get-+C-chords () (mapcar #'+C-chord *chord-type*))
(defun -D-chord (type) (concatenate 'string "-D" type))
(defun get--D-chords () (mapcar #'-D-chord *chord-type*))
(defun D-chord (type) (concatenate 'string "D" type))
(defun get-D-chords () (mapcar #'D-chord *chord-type*))
(defun +D-chord (type) (concatenate 'string "+D" type))
(defun get-+D-chords () (mapcar #'+D-chord *chord-type*))
(defun -E-chord (type) (concatenate 'string "-E" type))
(defun get--E-chords () (mapcar #'-E-chord *chord-type*))
(defun E-chord (type) (concatenate 'string "E" type))
(defun get-E-chords () (mapcar #'E-chord *chord-type*))
(defun F-chord (type) (concatenate 'string "F" type))
(defun get-F-chords () (mapcar #'F-chord *chord-type*))
(defun +F-chord (type) (concatenate 'string "+F" type))
(defun get-+F-chords () (mapcar #'+F-chord *chord-type*))
(defun -G-chord (type) (concatenate 'string "-G" type))
(defun get--G-chords () (mapcar #'-G-chord *chord-type*))
(defun G-chord (type) (concatenate 'string "G" type))
(defun get-G-chords () (mapcar #'G-chord *chord-type*))
(defun +G-chord (type) (concatenate 'string "+G" type))
(defun get-+G-chords () (mapcar #'+G-chord *chord-type*))
(defun -A-chord (type) (concatenate 'string "-A" type))
(defun get--A-chords () (mapcar #'-A-chord *chord-type*))
(defun A-chord (type) (concatenate 'string "A" type))
(defun get-A-chords () (mapcar #'A-chord *chord-type*))
(defun +A-chord (type) (concatenate 'string "+A" type))
(defun get-+A-chords () (mapcar #'+A-chord *chord-type*))
(defun -B-chord (type) (concatenate 'string "-B" type))
(defun get--B-chords () (mapcar #'-B-chord *chord-type*))
(defun B-chord (type) (concatenate 'string "B" type))
(defun get-B-chords () (mapcar #'B-chord *chord-type*))

;;;
;;;
;;;
(defun get-C-chords-which-involve-the-list (lst)
  (do ((l (get-C-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-+C-chords-which-involve-the-list (lst)
  (do ((l (get-+C-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get--D-chords-which-involve-the-list (lst)
  (do ((l (get--D-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-D-chords-which-involve-the-list (lst)
  (do ((l (get-D-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-+D-chords-which-involve-the-list (lst)
  (do ((l (get-+D-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get--E-chords-which-involve-the-list (lst)
  (do ((l (get--E-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-E-chords-which-involve-the-list (lst)
  (do ((l (get-E-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-F-chords-which-involve-the-list (lst)
  (do ((l (get-F-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-+F-chords-which-involve-the-list (lst)
  (do ((l (get-+F-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get--G-chords-which-involve-the-list (lst)
  (do ((l (get--G-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-G-chords-which-involve-the-list (lst)
  (do ((l (get-G-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-+G-chords-which-involve-the-list (lst)
  (do ((l (get-+G-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get--A-chords-which-involve-the-list (lst)
  (do ((l (get--A-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-A-chords-which-involve-the-list (lst)
  (do ((l (get-A-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-+A-chords-which-involve-the-list (lst)
  (do ((l (get-+A-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get--B-chords-which-involve-the-list (lst)
  (do ((l (get--B-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

(defun get-B-chords-which-involve-the-list (lst)
  (do ((l (get-B-chords) (cdr l))
     (w))
     ((null l) w)
   (cond ((the-list-is-involved-in-a-chord lst (car l))
        (push (car l) w)))))

;;;
;;; (get-chords-which-involve-the-notes '(+fa +la +do fa)) ===> ("+FM7" "-GM7")
;;;
(defun get-chords-which-involve-the-notes (lst)
  (append (get-C-chords-which-involve-the-list lst)
        (get-+C-chords-which-involve-the-list lst)
        (get--D-chords-which-involve-the-list lst)
        (get-D-chords-which-involve-the-list lst)
        (get-+D-chords-which-involve-the-list lst)
        (get--E-chords-which-involve-the-list lst)
        (get-E-chords-which-involve-the-list lst)
        (get-F-chords-which-involve-the-list lst)
        (get-+F-chords-which-involve-the-list lst)
        (get--G-chords-which-involve-the-list lst)
        (get-G-chords-which-involve-the-list lst)
        (get-+G-chords-which-involve-the-list lst)
        (get--A-chords-which-involve-the-list lst)
        (get-A-chords-which-involve-the-list lst)
        (get-+A-chords-which-involve-the-list lst)
        (get--B-chords-which-involve-the-list lst)
        (get-B-chords-which-involve-the-list lst)))