Add rhyme generation helpers
Eric Ihli
4 years ago
parent
731ac8bd03
commit
ff17cdec32
Binary file not shown.
Binary file not shown.
Binary file not shown.
@ -0,0 +1,192 @@
|
||||
(ns com.owoga.prhyme.gen
|
||||
(:require [clojure.string :as string]
|
||||
[com.owoga.prhyme.util.weighted-rand :as weighted-rand]
|
||||
[com.owoga.prhyme.util.nlp :as nlp]
|
||||
[com.owoga.prhyme.frp :as frp]
|
||||
[com.owoga.prhyme.core :as prhyme]))
|
||||
|
||||
(def words-map
|
||||
(into {} (map #(vector (string/lower-case (:word %)) %) frp/words)))
|
||||
|
||||
(defn merge-phrase-words
|
||||
"Given multiple `Word`, like the words for 'well off', create a single `Word`
|
||||
that is syllabified as ('well' 'off') rather than as the combined ('weh'
|
||||
'loff'). Useful for finding single-word rhymes of multiple-word targets.
|
||||
|
||||
An example: 'war on crime' -> 'turpentine'."
|
||||
[phrase phrase-words]
|
||||
(loop [merged (first phrase-words)
|
||||
phrase-words (rest phrase-words)]
|
||||
(cond
|
||||
(and (empty? phrase-words) (empty? merged)) nil
|
||||
(empty? phrase-words) (assoc merged :word phrase)
|
||||
:else (recur (-> merged
|
||||
(assoc :syllables (concat (:syllables merged)
|
||||
(:syllables (first phrase-words))))
|
||||
(assoc :syllable-count (+ (:syllable-count merged)
|
||||
(:syllable-count (first phrase-words))))
|
||||
(assoc :rimes (concat (:rimes merged)
|
||||
(:rimes (first phrase-words))))
|
||||
(assoc :onsets (concat (:onsets merged)
|
||||
(:onsets (first phrase-words))))
|
||||
(assoc :nuclei (concat (:nuclei merged)
|
||||
(:nuclei (first phrase-words)))))
|
||||
(rest phrase-words)))))
|
||||
|
||||
(defn phrase->word
|
||||
"Given a word like 'well-off' or a phrase like 'war on poverty', return a Word
|
||||
that has the correct syllables, rimes, onsets, and nucleus. This way we can
|
||||
rhyme against phrases that aren't in the dictionary, as long as the words that
|
||||
make up the phrase are in the dictionary. Returns nil if the word is not in
|
||||
the dictionary."
|
||||
[words phrase]
|
||||
(->> (string/split phrase #"[ -]")
|
||||
(map (fn [phrase-word]
|
||||
(let [word (first (filter (fn [word]
|
||||
(= phrase-word (:norm-word word)))
|
||||
words))]
|
||||
(when (nil? word)
|
||||
(throw (ex-info "Word not found in dictionary." {:word phrase-word})))
|
||||
word)))
|
||||
(merge-phrase-words phrase)))
|
||||
|
||||
(defn adjust-for-markov
|
||||
[markov percent]
|
||||
(fn [[words target result]]
|
||||
(let [markov-options (markov (list (:norm-word (first result))))
|
||||
markov-option-avg (/ (apply + (vals markov-options))
|
||||
(max 1 (count markov-options)))]
|
||||
(if (nil? markov-options)
|
||||
[words target result]
|
||||
(let [[markovs non-markovs]
|
||||
((juxt filter remove)
|
||||
#(markov-options (:norm-word %))
|
||||
words)
|
||||
weight-non-markovs (apply + (map :weight non-markovs))
|
||||
target-weight-markovs (* 100 percent weight-non-markovs)
|
||||
count-markovs (count markovs)
|
||||
adjustment-markovs (if (= 0 count-markovs) 1 (/ target-weight-markovs count-markovs))]
|
||||
[(concat
|
||||
(map
|
||||
(fn [m]
|
||||
(let [option (markov-options (:norm-word m))]
|
||||
(as-> m m
|
||||
(assoc m :weight (* (/ option markov-option-avg) adjustment-markovs (:weight m)))
|
||||
(assoc m :adjustment-for-markov (* (/ option markov-option-avg) adjustment-markovs)))))
|
||||
markovs)
|
||||
non-markovs)
|
||||
target
|
||||
result])))))
|
||||
|
||||
(defn adjust-for-rimes
|
||||
[target-rime dictionary percent]
|
||||
(fn [[words target result]]
|
||||
(let [words-with-rime-count
|
||||
(map
|
||||
(fn [word]
|
||||
(assoc word :num-matching (count (frp/consecutive-matching target word :rimes))))
|
||||
words)
|
||||
|
||||
[rhyming non-rhyming]
|
||||
((juxt filter remove)
|
||||
#(< 0 (:num-matching %))
|
||||
words-with-rime-count)
|
||||
|
||||
weight-non-rhyming (apply + (map :weight non-rhyming))
|
||||
target-weight-rhyming (* 100 percent weight-non-rhyming)
|
||||
count-rhyming (count rhyming)
|
||||
adjustment-rhyming (if (= 0 count-rhyming) 1 (/ target-weight-rhyming count-rhyming))]
|
||||
[(concat
|
||||
(map
|
||||
(fn [word]
|
||||
(as-> word word
|
||||
(assoc word :weight (* adjustment-rhyming (:weight word)))
|
||||
(assoc word :adjustment-for-rimes adjustment-rhyming)))
|
||||
rhyming)
|
||||
non-rhyming)
|
||||
target
|
||||
result])))
|
||||
|
||||
(defn prhyme
|
||||
"2020-10-21 iteration"
|
||||
[words weights-adjuster target stop?]
|
||||
(let [target (assoc target :original-syllables (:syllables target))
|
||||
words (map #(assoc % :weight 1) words)]
|
||||
(loop [target target
|
||||
result '()
|
||||
sentinel 0]
|
||||
(if (or (stop? target result)
|
||||
(> sentinel 5))
|
||||
result
|
||||
(let [[weighted-words _ _] (weights-adjuster [words target result])
|
||||
rng (weighted-rand/from-weights (map :weight weighted-words))
|
||||
index (weighted-rand/nextr rng nil)
|
||||
selection (nth weighted-words index)
|
||||
new-target (->> target
|
||||
(#(assoc % :syllables (drop-last
|
||||
(:syllable-count
|
||||
selection)
|
||||
(:syllables
|
||||
target))))
|
||||
(#(assoc % :rimes (prhyme/rimes (:syllables %))))
|
||||
(#(assoc % :onsets (prhyme/onset+nucleus (:syllables %))))
|
||||
(#(assoc % :nuclei (prhyme/nucleus (:syllables %)))))
|
||||
result (cons selection result)]
|
||||
(recur new-target result (inc sentinel)))))))
|
||||
|
||||
(defn prhymer [words weights-adjuster target stop]
|
||||
(cons (prhyme
|
||||
words
|
||||
weights-adjuster
|
||||
target
|
||||
stop)
|
||||
(lazy-seq (prhymer words weights-adjuster target stop))))
|
||||
|
||||
(defn sentence-stop [target]
|
||||
(fn [inner-target result]
|
||||
(let [result-sentence (string/join " " (map :norm-word result))]
|
||||
(when-not (empty? result)
|
||||
(or (nlp/valid-sentence? result-sentence)
|
||||
(< (:syllable-count target)
|
||||
(apply + (map :syllable-count result)))
|
||||
(< 5 (count result)))))))
|
||||
|
||||
(defn gen-prhymes [words markov poem-lines]
|
||||
(let [words (map #(assoc % :weight 1) words)
|
||||
words-map (into {} (map #(vector (:norm-word %) %) words))]
|
||||
(map (fn [line]
|
||||
(let [target (frp/phrase->word words line)
|
||||
stop (sentence-stop target)
|
||||
weights-adjuster (comp (adjust-for-markov markov 0.9)
|
||||
(adjust-for-rimes target words-map 0.9))
|
||||
r (prhymer words weights-adjuster target stop)]
|
||||
(string/join " " (map #(:norm-word %) (first r)))))
|
||||
poem-lines)))
|
||||
|
||||
|
||||
|
||||
(comment
|
||||
(take 3 frp/words)
|
||||
(phrase->word frp/popular "well-off")
|
||||
(map (fn [line] (phrase->word frp/popular line))
|
||||
["mister sandman"
|
||||
"give me dream"
|
||||
"make him the cutest"
|
||||
"that have ever seen"])
|
||||
(defonce lovecraft-markov (read-string (slurp "lovecraft.edn")))
|
||||
(def adj (comp (adjust-for-markov lovecraft-markov 0.99)))
|
||||
(gen-prhymes frp/popular
|
||||
lovecraft-markov
|
||||
["mister sandman"
|
||||
"give me the dream"
|
||||
"make him the cutest"
|
||||
"that eye have ever seen"])
|
||||
(repeatedly 20 #(gen-prhymes frp/popular lovecraft-markov ["mister sandman"]))
|
||||
|
||||
(let [target (frp/phrase->word frp/words "i solemnly swear i am up to no good")
|
||||
words (map #(assoc % :weight 1) frp/popular)
|
||||
weights-adjuster (comp (adjust-for-markov lovecraft-markov 0.9)
|
||||
(adjust-for-rimes target words-map 0.9))
|
||||
stop (sentence-stop target)
|
||||
r (prhymer words weights-adjuster target stop)]
|
||||
(map (fn [p] (string/join " " (map #(:norm-word %) p))) (take 5 r))))
|
||||
Loading…
Reference in New Issue