Add ability to grade rhymes by quality

web/deps.edn

@@ -19,7 +19,7 @@
   ring/ring-core {:mvn/version "1.8.2"}
   environ {:mvn/version "1.2.0"}
   prhyme {:local/root "/home/eihli/src/prhyme"}
-  com.owoga/phonetics {:mvn/version "0.1.3"}}
+  com.owoga/phonetics {:local/root "/home/eihli/src/phonetics"}}
  :paths ["src" "resources"]
  :aliases {:dev {:extra-paths ["dev"]
                  :extra-deps {hawk {:mvn/version "0.2.11"}

web/src/com/darklimericks/linguistics/core.clj

@@ -1,9 +1,12 @@
 (ns com.darklimericks.linguistics.core
   (:require [com.owoga.prhyme.data.dictionary :as dict]
             [com.owoga.prhyme.core :as prhyme]
+            [com.owoga.prhyme.util :as util]
             [com.darklimericks.server.models :as models]
             [com.owoga.corpus.markov :as markov]
-            [clojure.string :as string]))
+            [clojure.string :as string]
+            [com.owoga.phonetics :as phonetics]
+            [com.owoga.phonetics.stress-manip :as stress-manip]))
 
 (defn gen-artist []
   (->> [(rand-nth (seq dict/adjectives))
@@ -17,19 +20,143 @@
        (map string/capitalize)
        (string/join " ")))
 
+(defn perfect-rhyme
+  [phones]
+  (->> phones
+       reverse
+       (util/take-through stress-manip/primary-stress?)
+       first
+       reverse
+       (#(cons (first %)
+               (stress-manip/remove-any-stress-signifiers (rest %))))))
 
+(comment
+  (perfect-rhyme (first (phonetics/get-phones "technology")))
+  ;; => ("AA1" "L" "AH" "JH" "IY")
+  )
+
+(defn perfect-rhyme-sans-consonants
+  [phones]
+  (->> phones
+       perfect-rhyme
+       (remove phonetics/consonant)))
+
+(comment
+  (perfect-rhyme-sans-consonants (first (phonetics/get-phones "technology")))
+  ;; => ("AA1" "AH" "IY")
+  )
+
+(defn perfect-rhyme?
+  [phones1 phones2]
+  (apply = (map perfect-rhyme [phones1 phones2])))
+
+(defn perfect-rhyme-sans-consonants?
+  [phones1 phones2]
+  (apply = (map perfect-rhyme-sans-consonants [phones1 phones2])))
+
+(comment
+  (apply perfect-rhyme? (map (comp first phonetics/get-phones) ["technology" "ecology"]));; => true
+  (apply perfect-rhyme? (map (comp first phonetics/get-phones) ["technology" "economy"]));; => false
+  (apply perfect-rhyme-sans-consonants? (map (comp first phonetics/get-phones) ["technology" "economy"]));; => true
+  (apply perfect-rhyme-sans-consonants? (map (comp first phonetics/get-phones) ["technology" "trilogy"]));; => false
+  (apply perfect-rhyme? (map (comp first phonetics/get-phones) ["bother me" "poverty"]))
+  (apply perfect-rhyme? (map (comp first phonetics/phrase-phones) ["bother me" "poverty"]))
+  (phonetics/phrase-phones "bother me");; => [["B" "AA1" "DH" "ER0" "M" "IY1"]]
+  (phonetics/phrase-phones "poverty");; => [["P" "AA1" "V" "ER0" "T" "IY0"]]
+  )
+
+(defn number-of-matching-vowels-with-stress
+  [phones1 phones2]
+  (let [[vowels1 vowels2] (map (partial filter phonetics/vowel?) [phones1 phones2])]
+    (->> [vowels1 vowels2]
+         (apply map vector)
+         (filter (partial apply =))
+         (filter (comp (partial re-find #"1") first))
+         count)))
+
+(comment
+  (apply
+   number-of-matching-vowels-with-stress
+   (map first (map phonetics/get-phones ["technology" "ecology"])))
+  (apply
+   number-of-matching-vowels-with-stress
+   (map first (map phonetics/get-phones ["biology" "ecology"])))
+  )
+
+(defn number-of-matching-vowels-any-stress
+  [phones1 phones2]
+  (let [[vowels1 vowels2] (map (partial filter phonetics/vowel?) [phones1 phones2])]
+    (->> [vowels1 vowels2]
+         (map (partial map phonetics/remove-stress))
+         (apply map vector)
+         (filter (partial apply =))
+         count)))
+
+(comment
+  (apply
+   number-of-matching-vowels-any-stress
+   (map first (map phonetics/get-phones ["economy" "ecology"])))
+  (apply
+   number-of-matching-vowels-any-stress
+   (map first (map phonetics/get-phones ["biology" "ecology"])))
+  )
+
+(defn quality-of-rhyme-phones
+  "Points for:
+  - Perfect rhyme
+  - Perfect rhyme sans consonants
+  - Number of matching stressed vowels
+  - Number of matching any-stressed vowels
+  "
+  [phones1 phones2]
+  (let [perfect? (if (perfect-rhyme? phones1 phones2) 1 0)
+        perfect-sans-consonants? (if (perfect-rhyme-sans-consonants? phones1 phones2) 1 0)
+        num-matching-stressed (number-of-matching-vowels-with-stress phones1 phones2)
+        num-matching-any-stress (number-of-matching-vowels-any-stress phones1 phones2)]
+    (println perfect? perfect-sans-consonants? num-matching-stressed num-matching-any-stress)
+    (+ perfect?
+       perfect-sans-consonants?
+       num-matching-stressed
+       num-matching-any-stress)))
+
+(comment
+  (->> [["economy" "ecology"]
+        ["biology" "ecology"]
+        ["bother me" "poverty"]
+        ["property" "properly"]]
+       (map (partial map (comp first phonetics/phrase-phones)))
+       (map (partial apply quality-of-rhyme-phones)))
+
+  )
 (defn rhymes
   "All rhymes. Slightly flexible. Ordered by number of rhyming syllables.
   Most generic and likely desired rhyming algorithm."
   [target]
-  (->>  (prhyme/phrase->all-flex-rhyme-tailing-consonants-phones target)
+  (->> target
-        (map first)
+       (phonetics/get-phones)
-        (map reverse)
+       (mapcat (partial
-        (mapcat (partial markov/rhyme-choices models/rhyme-trie))
+                markov/rhymes
-        (sort-by (comp - count first))
+                models/rhyme-trie-unstressed-trailing-consonants))
-        (mapcat second)))
+       (mapcat second)))
+
+(defn rhymes-with-frequencies
+  [target trie database]
+  (let [rhymes- (rhymes target)
+        freqs (map
+               (comp
+                (fnil int 0)
+                second
+                (partial get models/markov-trie)
+                (partial conj [1 1 1])
+                database)
+               rhymes-)]
+    (distinct (sort-by (comp - second) (map vector rhymes- freqs)))))
 
 (comment
+  (markov/rhymes models/rhyme-trie-unstressed-trailing-consonants (phonetics/get-phones "food"))
   (rhymes "food")
 
+  (get models/markov-trie [(models/database "food")])
+  (rhymes-with-frequencies "technology" models/markov-trie models/database)
+
   )

web/src/com/darklimericks/server/handlers.clj

@@ -17,7 +17,8 @@
             [com.darklimericks.db.artists :as db.artists]
             [com.darklimericks.server.views :as views]
             [com.darklimericks.server.limericks :as limericks]
-            [com.darklimericks.linguistics.core :as linguistics]))
+            [com.darklimericks.linguistics.core :as linguistics]
+            [com.darklimericks.server.models :as models]))
 
 (defmethod ig/init-key ::handler [_ {:keys [router]}]
   (http/ring-handler
@@ -265,7 +266,10 @@
 
 (defn show-rhyme-suggestion [db cache]
   (fn [request]
-    (let [suggestions (linguistics/rhymes (:rhyme-target (:params request)))]
+    (let [suggestions (linguistics/rhymes-with-frequencies
+                       (:rhyme-target (:params request))
+                       models/markov-trie
+                       models/database)]
       {:status 201
        :headers {"Content-Type" "text/html; charset=utf-8"}
        :body (views/wrapper

web/src/com/darklimericks/server/limericks.clj

@@ -118,43 +118,6 @@
 
   )
 
-(def rhyme-trie-unstressed-trailing-consonants
-  (markov/->RhymeTrie
-   models/rhyme-trie
-   (fn [phones]
-     (->> phones
-          prhyme/take-vowels-and-tail-consonants
-          prhyme/remove-all-stress))
-   (fn [phones choices]
-     (every? phonetics/consonant (butlast phones)))))
-
-
-(comment
-  (let [result {'[a 8]
-                [[[["P" "AE1" "S"] "pass"]
-                  [["P" "ER0" "EH1" "N" "IY0" "AH0" "L" "IY0"] "perennially"]
-                  [["Y" "UW1"] "you"]
-                  [["T" "UW1"] "to"]]
-                 [[["OW1" "V" "ER0" "P" "AE2" "S"] "overpass"]
-                  [["AH0" "N"] "an"]
-                  [["AO1" "N"] "on"]
-                  [["M" "AH0" "N" "IH2" "P" "Y" "AH0" "L" "EY1" "SH" "AH0" "N"]
-                   "manipulation"]]
-                 [[["M" "IH1" "D" "AH0" "L" "K" "L" "AE1" "S"] "middle-class"]
-                  [["HH" "AY1" "D" "IH0" "NG"] "hiding"]
-                  [["M" "AA1" "N" "S" "T" "ER0"] "monster"]
-                  [["K" "R" "UW1" "AH0" "L"] "cruel"]]],
-                '[b 5]
-                [[[["R" "EY1" "S"] "race"]
-                  [["M" "AH0" "T" "IH1" "R" "IY0" "AH0" "L"] "material"]]
-                 [[["B" "AO1" "R" "G" "EY0" "S"] "borges"]
-                  [["IY2" "K" "W" "AH0" "L" "IH1" "B" "R" "IY0" "AH0" "M"] "equilibrium"]]]}
-        [[a1 a2 a2] [b1 b2]] (vals result)]
-    (->> [a1 a2 b1]
-         (map reverse)
-         (map (partial map second))))
-
-  )
 
 (defn generate-limerick-worker [db message]
   (timbre/info "Begin generate limerick worker.")
@@ -166,8 +129,7 @@
           scheme
           models/database
           models/markov-trie
-          rhyme-trie-unstressed-trailing-consonants))
+          models/rhyme-trie-unstressed-trailing-consonants))
-
         limerick (->> [a1 a2 b1 b2 a3]
                       (map reverse)
                       (map (partial map second))

web/src/com/darklimericks/server/models.clj

@@ -2,6 +2,8 @@
   (:require [taoensso.nippy :as nippy]
             [com.owoga.trie :as trie]
             [com.owoga.tightly-packed-trie :as tpt]
+            [com.owoga.prhyme.core :as prhyme]
+            [com.owoga.phonetics :as phonetics]
             [clojure.java.io :as io]
             [com.owoga.corpus.markov :as markov]))
 
@@ -15,3 +17,40 @@
 (def markov-trie (tpt/load-tightly-packed-trie-from-file
                   (io/resource "models/markov-tightly-packed-trie-4-gram-backwards.bin")
                   (markov/decode-fn database)))
+
+(def rhyme-trie-unstressed-trailing-consonants
+  (markov/->RhymeTrie
+   rhyme-trie
+   (fn [phones]
+     (->> phones
+          prhyme/take-vowels-and-tail-consonants
+          prhyme/remove-all-stress))
+   (fn [phones choices]
+     (every? phonetics/consonant (butlast phones)))))
+
+(comment
+  (let [result {'[a 8]
+                [[[["P" "AE1" "S"] "pass"]
+                  [["P" "ER0" "EH1" "N" "IY0" "AH0" "L" "IY0"] "perennially"]
+                  [["Y" "UW1"] "you"]
+                  [["T" "UW1"] "to"]]
+                 [[["OW1" "V" "ER0" "P" "AE2" "S"] "overpass"]
+                  [["AH0" "N"] "an"]
+                  [["AO1" "N"] "on"]
+                  [["M" "AH0" "N" "IH2" "P" "Y" "AH0" "L" "EY1" "SH" "AH0" "N"]
+                   "manipulation"]]
+                 [[["M" "IH1" "D" "AH0" "L" "K" "L" "AE1" "S"] "middle-class"]
+                  [["HH" "AY1" "D" "IH0" "NG"] "hiding"]
+                  [["M" "AA1" "N" "S" "T" "ER0"] "monster"]
+                  [["K" "R" "UW1" "AH0" "L"] "cruel"]]],
+                '[b 5]
+                [[[["R" "EY1" "S"] "race"]
+                  [["M" "AH0" "T" "IH1" "R" "IY0" "AH0" "L"] "material"]]
+                 [[["B" "AO1" "R" "G" "EY0" "S"] "borges"]
+                  [["IY2" "K" "W" "AH0" "L" "IH1" "B" "R" "IY0" "AH0" "M"] "equilibrium"]]]}
+        [[a1 a2 a2] [b1 b2]] (vals result)]
+    (->> [a1 a2 b1]
+         (map reverse)
+         (map (partial map second))))
+
+  )

web/src/com/darklimericks/server/views.clj

@@ -210,5 +210,5 @@
   [request suggestions]
   [:div
    (wgu request)
-   (for [suggestion suggestions]
+   (for [[suggestion freq] suggestions]
-     [:div suggestion])])
+     [:div suggestion freq])])