Add more chords and their metadata

- Pull chords from tonal.js - Store interval names instead of semitones to preserve context (e.g. aug5 or m6) - Show more chord info on hover (long name, aliases) - Sort diatonic scale chords by ascending complexity (the order of pitch/BASE-CHORD)
cofinley · Sep 17, 2023 · 9ae55a7 · 9ae55a7
1 parent e8d7077
commit 9ae55a7
Show file tree

Hide file tree

Showing 9 changed files with 273 additions and 147 deletions.
diff --git a/src/why_does_that_sound_good/algo/chord.cljc b/src/why_does_that_sound_good/algo/chord.cljc
@@ -3,30 +3,9 @@
    [why-does-that-sound-good.pitch :as pitch]
    [why-does-that-sound-good.utils :as utils]))
 
-(def CHORD-INTERVAL-NAMES
-  {0 :1
-   1 :m2
-   2 :M2
-   3 :m3
-   4 :M3
-   5 :4
-   6 :-5
-   7 :5
-   8 :+5
-   9 :6
-   10 :m7
-   11 :M7
-   12 :o
-   13 :-9
-   14 :9
-   15 :-10
-   17 :11
-   18 :+11
-   21 :13})
-
 (def ALL-CHORDS
   (into {} (for [root-pitch (vals pitch/REVERSE-NOTES)
-                 [chord-type intervals] pitch/CHORD
+                 [chord-type {:keys [intervals]}] pitch/CHORD
                  :let [chord-desc {:root root-pitch :chord-type chord-type}
                        pitches (set (map #(pitch/interval->pitch root-pitch %) intervals))]]
              [chord-desc pitches])))
@@ -76,7 +55,7 @@
         {matched-chord-pitches true
          unmatched-chord-pitches false} (group-by #(some? (val %)) chord-pitch->note-names)]
     {:matched-note-names (flatten (vals matched-chord-pitches))
-     :unmatched-pitches (or (keys unmatched-chord-pitches) (list))
+     :unmatched-chord-pitches (or (keys unmatched-chord-pitches) (list))
      :unmatched-note-names (flatten (filter (fn [note-names]
                                               (not (some #(= % note-names) (vals chord-pitch->note-names))))
                                             (vals note-pitch->note-names)))}))
@@ -88,7 +67,7 @@
   [original-notes chord-pitches]
   (let [original-octave-center (utils/median (map pitch/note->octave original-notes))
         matches (match-pitches-to-note-names chord-pitches original-notes)]
-    (loop [chord-pitches-remaining (:unmatched-pitches matches)
+    (loop [chord-pitches-remaining (:unmatched-chord-pitches matches)
            original-note-names-remaining (:unmatched-note-names matches)
            chord-notes []]
       (if (empty? chord-pitches-remaining)
@@ -105,11 +84,14 @@
                  (conj chord-notes chord-note)))))))
 
 (defn chord->readable-intervals [{:keys [root chord-type]}]
-  (let [intervals (pitch/CHORD chord-type)]
-    (reduce (fn [m interval]
+  (let [chord-details (get pitch/CHORD chord-type)
+        intervals (:intervals chord-details)
+        interval-names (:interval-names chord-details)]
+    (reduce (fn [m [i interval]]
               (let [pitch (pitch/interval->pitch root interval)
-                    readable-interval (CHORD-INTERVAL-NAMES interval)]
-                (assoc m pitch readable-interval))) {} intervals)))
+                    readable-interval (nth interval-names i)]
+                (assoc m pitch readable-interval))) {}
+            (map-indexed vector intervals))))
 
 (defn block->chords [block & {:keys [min-chord-similarity find-closest?]
                               :or {min-chord-similarity 0.90 find-closest? false}}]

diff --git a/src/why_does_that_sound_good/algo/scale.cljc b/src/why_does_that_sound_good/algo/scale.cljc
@@ -70,16 +70,17 @@
                                :or {octave 4}}]
   (let [root-note (pitch/note (str (name root-pitch) octave))
         all-scale-intervals (scale-pitches->intervals scale-pitches root-pitch)
-        diatonic-chord-types (filter (fn [[_ chord-intervals]]
-                                       (set/subset? chord-intervals all-scale-intervals))
-                                     pitch/CHORD)]
-    (map (fn [[chord-type chord-intervals]]
-           {:root root-pitch
-            :chord-type chord-type
-            :chord-intervals chord-intervals
-            :chord-pitches->readable-intervals (chord/chord->readable-intervals {:root root-pitch :chord-type chord-type})
-            :chord-notes (map #(+ root-note %) (sort chord-intervals))})
-         diatonic-chord-types)))
+        diatonic-chords (filter (fn [[_ {:keys [intervals]}]]
+                                  (set/subset? intervals all-scale-intervals))
+                                pitch/CHORD)]
+    (->> diatonic-chords
+         (map (fn [[chord-type {:keys [intervals]}]]
+                {:root root-pitch
+                 :chord-type chord-type
+                 :chord-pitches->readable-intervals (chord/chord->readable-intervals {:root root-pitch :chord-type chord-type})
+                 :chord-notes (map #(+ root-note %) (sort intervals))}))
+         ;; Sort by increasing complexity
+         (sort-by #(get pitch/CHORD-ORDER (:chord-type %))))))
 
 (defn scale->diatonic-chords
   "For each pitch in scale, construct their diatonic chords"
@@ -105,7 +106,6 @@
             (let [root-pitch (:root chord)
                   all-chords-for-root (get all-chords root-pitch)]
               (assoc all-chords root-pitch
-                     ;; TODO: after similarity, sort by 'popularity'/complexity
                      (sort-by (comp - #(or (:similarity %) 0))
                               (map (fn [all-chord]
                                      (if (= (:chord-type chord) (:chord-type all-chord))

diff --git a/src/why_does_that_sound_good/components/live_suggestion_panel.cljs b/src/why_does_that_sound_good/components/live_suggestion_panel.cljs
@@ -31,7 +31,8 @@
        [:div
         {:class "flex flex-col gap-y items-start"}
         [:span
-         {:class "font-semibold text-xl"}
+         {:class "font-semibold text-xl"
+          :title (utils/chord-tooltip s)}
          (utils/music-structure->str s)]
         [similarity-badge (:similarity s)]]
        [:div

diff --git a/src/why_does_that_sound_good/components/scales_pane.cljs b/src/why_does_that_sound_good/components/scales_pane.cljs
@@ -46,7 +46,7 @@
            [chevron-up-icon]]
           [:div.flex.flex-col.items-center.cursor-pointer
            {:on-click #(re-frame/dispatch [::events/on-notes-play (:chord-notes chord)])
-            :title "Click to play"}
+            :title (str/join "\n\n" ["Click to play" (utils/chord-tooltip chord)])}
            [:span.font-semibold chord-str]
            (when-let [s (:similarity chord)]
              [similarity-badge s])]

diff --git a/src/why_does_that_sound_good/events.cljs b/src/why_does_that_sound_good/events.cljs
@@ -427,8 +427,10 @@
                     (let [section-block-ids (:block-ids section)
                           blocks (vals (select-keys (get-in db [:data :blocks]) section-block-ids))
                           pregenerated-block-chord-suggestions (select-keys (:chord-suggestions db) section-block-ids)]
-                      (when (<= 2 (count blocks))
-                        (assoc m section-id (scale/mem-blocks->scales blocks :pregenerated-block-chord-suggestions pregenerated-block-chord-suggestions :find-closest? true)))))
+                      (if (<= 2 (count blocks))
+                        (let [scales (scale/mem-blocks->scales blocks :pregenerated-block-chord-suggestions pregenerated-block-chord-suggestions :find-closest? true)]
+                          (assoc m section-id scales))
+                        (assoc m section-id {}))))
                   {}
                   (get-in db [:data :sections])))))