Add markovian lovecraft generation

main
Eric Ihli 4 years ago
parent 3782b6072a
commit 98ffd872ba

@ -61,6 +61,35 @@ words, then you're stuck trying to rhyme with the single syllable
Implementation Implementation
-------------- --------------
2020-10-20
++++++++++
Start with a phrase.
"Please turn on your magic beam".
Convert it to syllables.
``...(Y AO R) (M AE) (J IH K) (B IY M)``
Find all words that rhyme in any way whatsoever.
Weight each possible rhyming word.
Choose by weight.
Remove syllables from target phrase equal to syllables of chosen word.
Find all words that either rhyme or are markov selections of previous word.
Weight each possible word.
Choose by weight.
Prev
++++
What would it look like to solve the problem for a single grouping of syllables into words? What would it look like to solve the problem for a single grouping of syllables into words?
In the case of In the case of

@ -4,6 +4,8 @@
org.clojure/data.priority-map {:mvn/version "1.0.0"} org.clojure/data.priority-map {:mvn/version "1.0.0"}
org.clojure/core.async {:mvn/version "1.2.603"} org.clojure/core.async {:mvn/version "1.2.603"}
inflections {:mvn/version "0.13.2"} inflections {:mvn/version "0.13.2"}
com.taoensso/tufte {:mvn/version "2.2.0"}
enlive {:mvn/version "1.1.6"}
com.taoensso/timbre {:mvn/version "4.10.0"}} com.taoensso/timbre {:mvn/version "4.10.0"}}
:aliases {:dev {:extra-paths ["test"] :aliases {:dev {:extra-paths ["test"]
:extra-deps {}}}} :extra-deps {}}}}

@ -1,15 +1,16 @@
(ns example.real-estate) (ns example.real-estate
(:require [com.owoga.frp.infrastructure :as frp]))
(defrelvar Offer (frp/defrelvar Offer
:address string? #(string? (:address %))
:offer-price number? #(number? (:offer-price %))
:offer-date inst? #(inst? (:offer-date %))
:bidder-name string? #(string? (:bidder-name %))
:bidder-address string?) #(string? (:bidder-address %)))
(defrelvar Property (frp/defrelvar Property
:address string? #(string? (:address %))
:price number? #(number? (:price %))
:photo string? #(string? (:photo %))
:agent-name string? #(string? (:agent-name %))
:date-registered inst?) #(inst? (:date-registered %)))

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

@ -1,56 +1,57 @@
(ns com.owoga.frp.infrastructure (ns com.owoga.frp.infrastructure
(:require [clojure.set :as set])) (:require [clojure.set :as set])
(defprotocol PRelations (:refer-clojure :exclude [extend]))
(load! [this relations])
(insert!
[this relation]
[this & relations])
(delete! [this & relations])
(update! [this old-relation new-relation])
(clear! [this]))
(defprotocol PRelVar (defprotocol PRelVar
(restrict [this criteria]) (extend [this extensions & constraints])
(restrict [this criteria & constraints]) (restrict [this criteria & constraints])
(project [this attributes])
(project [this attributes & constraints]) (project [this attributes & constraints])
(product [this relvar])
(product [this relvar & constraints]) (product [this relvar & constraints])
(union [this relvar])
(union [this relvar & constraints]) (union [this relvar & constraints])
(intersection [this relvar])
(intersection [this relvar & contstraints]) (intersection [this relvar & contstraints])
(difference [this relvar])
(difference [this relvar & constraints]) (difference [this relvar & constraints])
(join [this relvar])
(join [this relvar & constraints]) (join [this relvar & constraints])
(divide [this relvar])
(divide [this relvar & constraints]) (divide [this relvar & constraints])
(rename [this renames])
(rename [this renames & constraints])) (rename [this renames & constraints]))
(defprotocol PRelations
(load! [this relations])
(insert!
[this relation]
[this & relations])
(delete! [this & relations])
(update! [this old-relation new-relation])
(clear! [this]))
(declare extend-)
(declare project-) (declare project-)
(declare restrict-) (declare restrict-)
(deftype RelVar [relvar xf constraints] (deftype RelVar [relvar xf constraints]
PRelVar PRelVar
(extend
[this extensions & constraints]
(extend- this extensions constraints))
(project (project
[this attributes constraints] [this attributes & constraints]
(project- this (map #(select-keys % attributes)) constraints)) (project- this attributes constraints))
(restrict (restrict
[this criteria constraints] [this criteria & constraints]
(restrict- this (filter criteria) constraints)) (restrict- this criteria constraints))
clojure.lang.IDeref clojure.lang.IDeref
(deref [_] (into #{} xf @relvar))) (deref [_] (into #{} xf @relvar)))
(deftype BaseRelVar [relvar-name store constraints] (deftype BaseRelVar [relvar-name store constraints]
PRelVar PRelVar
(extend
[this extensions & constraints]
(extend- this extensions constraints))
(project (project
[this attributes constraints] [this attributes & constraints]
(project- this (map #(select-keys % attributes)) constraints)) (project- this attributes constraints))
(restrict (restrict
[this criteria constraints] [this criteria & constraints]
(restrict- this (filter criteria) constraints)) (restrict- this criteria constraints))
PRelations PRelations
(load! [this relations] (reset! store relations)) (load! [this relations] (reset! store relations))
@ -76,11 +77,18 @@
clojure.lang.IDeref clojure.lang.IDeref
(deref [_] @store)) (deref [_] @store))
(defn project- [relvar xf constraints] (defn extend- [relvar extensions constraints]
(->RelVar relvar xf constraints)) (let [xf (map (fn [element]
(map (fn [[k f]]
(assoc element k (f element)))
extensions)))]
(->RelVar relvar xf constraints)))
(defn project- [relvar attributes constraints]
(->RelVar relvar (map #(select-keys % attributes)) constraints))
(defn restrict- [relvar xf constraints] (defn restrict- [relvar criteria constraints]
(->RelVar relvar xf constraints)) (->RelVar relvar (filter criteria) constraints))
(def *constraints* (atom {})) (def *constraints* (atom {}))

@ -23,13 +23,18 @@
rimes (p/rimes syllables) rimes (p/rimes syllables)
onsets (p/onset+nucleus syllables) onsets (p/onset+nucleus syllables)
nuclei (p/nucleus syllables)] nuclei (p/nucleus syllables)]
(->Word (->> (->Word
(first word) (first word)
syllables syllables
(count syllables) (count syllables)
rimes rimes
onsets onsets
nuclei))) nuclei)
(#(assoc % :norm-word (string/lower-case
(string/replace
(:word %)
#"\(\d+\)"
"")))))))
(def words (->> dictionary (def words (->> dictionary
(map u/prepare-word) (map u/prepare-word)
@ -297,6 +302,7 @@
(map pprint-table) (map pprint-table)
(string/join "\n") (string/join "\n")
(println)) (println))
(let [phrase "give him two lips like roses in clover" (let [phrase "give him two lips like roses in clover"
targets (->> phrase targets (->> phrase
(:syllables (phrase->word words phrase)) (:syllables (phrase->word words phrase))

@ -6,7 +6,6 @@
Bare minimum functional relational architecture in Clojure. Bare minimum functional relational architecture in Clojure.
* Architecture * Architecture
** Essential State ** Essential State
This component consists solely of a specification of the essential state for the This component consists solely of a specification of the essential state for the
@ -35,23 +34,6 @@ def relvar Offer :: {address: address
bidderAddress: address} bidderAddress: address}
#+END_EXAMPLE #+END_EXAMPLE
Restrict is a unary operation which allows the selection of a subset of therecords in a relation according to some desired criteria
Project is a unary operation which creates a new relation corresponding to the old relation with various attributes removed from the records
Product is a binary operation corresponding to the cartesian product of mathematics
Union is a binary operation which creates a relation consisting of all records in either argument relation
Intersection is a binary operation which creates a relation consisting of all records in both argument relations
Difference is a binary operation which creates a relation consisting of all records in the first but not the second argument relation
Join is a binary operation which constructs all possible records that result from matching identical attributes of the records of the argument relations
Divide is a ternary operation which returns all records of the first argument which occur in the second argument associated with each record of the third argument
http://users.abo.fi/soini/divisionEnglish.pdf
** Distinction between Relvar and Relation ** Distinction between Relvar and Relation
Operations on Relvars return other Relvars ("Derived" Relvars). Operations on Relvars return other Relvars ("Derived" Relvars).
@ -68,35 +50,74 @@ Let's start by imagining a nice syntax for this.
#+NAME: real estate example relvar definitions #+NAME: real estate example relvar definitions
#+BEGIN_SRC clojure :noweb no-export :tangle ../../../../example/real_estate.clj #+BEGIN_SRC clojure :noweb no-export :tangle ../../../../example/real_estate.clj
(ns example.real-estate) (ns example.real-estate
(:require [com.owoga.frp.infrastructure :as frp]))
(defrelvar Offer
:address string? (frp/defrelvar Offer
:offer-price number? #(string? (:address %))
:offer-date inst? #(number? (:offer-price %))
:bidder-name string? #(inst? (:offer-date %))
:bidder-address string?) #(string? (:bidder-name %))
#(string? (:bidder-address %)))
(defrelvar Property
:address string? (frp/defrelvar Property
:price number? #(string? (:address %))
:photo string? #(number? (:price %))
:agent-name string? #(string? (:photo %))
:date-registered inst?) #(string? (:agent-name %))
#(inst? (:date-registered %)))
#+END_SRC #+END_SRC
** Relvar protocols ** Creating RelVars
This way the relvar and constraints can't easily be evaluated in seperate parts
of the code that might allow relations that violate soon-to-be constraints to be
loaded
The PRelVar functions return a RelVar that is not data-modifiable - it doesn't #+NAME: defrelvar
have the load!, insert!, delete!, etc... functions. #+BEGIN_SRC clojure :noweb no-export
(defmacro defrelvar
[relvar-name & constraints]
`(->BaseRelVar '~relvar-name (atom #{}) [~@constraints]))
#+END_SRC
For performance reasons, we do still need a way to persist derived relvars ** Definining derived and base relvars
somewhere. We'll eventually want to define some type of semantics for specifying
that a derived relation be cached rather than requiring it to be recalculated
every time the relations of its base relvar are updated.
#+NAME: relvar protocols BaseRelVars will have a protocol for loading/deleting/updating elements in the relation.
#+BEGIN_SRC clojure :noweb no-export
Both BaseRelVars and RelVars (a.k.a. DerivedRelVars) will have a protocol for relational algebra.
Both types of relvars can be derefed to access the collection of relations.
#+NAME: base relvars
#+BEGIN_SRC clojure
(deftype BaseRelVar [relvar-name store constraints]
PRelVar
<<relational algebra>>
PRelations
<<relations data manipulation>>
clojure.lang.IDeref
(deref [_] @store))
#+END_SRC
#+NAME: relvar protocol
#+BEGIN_SRC clojure
(defprotocol PRelVar
(extend [this extensions & constraints])
(restrict [this criteria & constraints])
(project [this attributes & constraints])
(product [this relvar & constraints])
(union [this relvar & constraints])
(intersection [this relvar & contstraints])
(difference [this relvar & constraints])
(join [this relvar & constraints])
(divide [this relvar & constraints])
(rename [this renames & constraints]))
#+END_SRC
#+NAME: relations protocol
#+BEGIN_SRC clojure
(defprotocol PRelations (defprotocol PRelations
(load! [this relations]) (load! [this relations])
(insert! (insert!
@ -105,26 +126,74 @@ every time the relations of its base relvar are updated.
(delete! [this & relations]) (delete! [this & relations])
(update! [this old-relation new-relation]) (update! [this old-relation new-relation])
(clear! [this])) (clear! [this]))
#+END_SRC
The algebraic manipulations of derived relvars are stored as a transform function that is transduced when the relvar is derefed.
#+NAME: derived relvars
#+BEGIN_SRC clojure
(deftype RelVar [relvar xf constraints]
PRelVar
<<relational algebra>>
clojure.lang.IDeref
(deref [_] (into #{} xf @relvar)))
#+END_SRC
Let's define something simple to test what we have so far.
#+NAME: relations data manipulation
#+BEGIN_SRC clojure
(load! [this relations])
#+END_SRC
#+NAME: test defrelvar
#+BEGIN_SRC clojure
(deftest test-defrelvar
(testing "failed constraint raises"
(let [Offer (frp/defrelvar Offer (fn [offers] (map #(> (:price %) 0) offers)))]
(is (thrown-with-msg?
Exception
#"Constraint Exception"
(frp/insert! Offer {:price -1})))))
(testing "passed constraint doesn't raise"
(let [Offer (frp/defrelvar Offer (fn [offers] (map #(> (:price %) 0) offers)))]
(frp/insert! Offer {:price 20})
(is (= @Offer #{{:price 20}})))))
#+END_SRC
** Relvar protocols
The PRelVar functions return a RelVar that is not data-modifiable - it doesn't
have the load!, insert!, delete!, etc... functions.
For performance reasons, we do still need a way to persist derived relvars
somewhere. We'll eventually want to define some type of semantics for specifying
that a derived relation be cached rather than requiring it to be recalculated
every time the relations of its base relvar are updated.
#+NAME: relvar protocols
#+BEGIN_SRC clojure :noweb no-export
(defprotocol PRelVar (defprotocol PRelVar
(restrict [this criteria]) (extend [this extensions & constraints])
(restrict [this criteria & constraints]) (restrict [this criteria & constraints])
(project [this attributes])
(project [this attributes & constraints]) (project [this attributes & constraints])
(product [this relvar])
(product [this relvar & constraints]) (product [this relvar & constraints])
(union [this relvar])
(union [this relvar & constraints]) (union [this relvar & constraints])
(intersection [this relvar])
(intersection [this relvar & contstraints]) (intersection [this relvar & contstraints])
(difference [this relvar])
(difference [this relvar & constraints]) (difference [this relvar & constraints])
(join [this relvar])
(join [this relvar & constraints]) (join [this relvar & constraints])
(divide [this relvar])
(divide [this relvar & constraints]) (divide [this relvar & constraints])
(rename [this renames])
(rename [this renames & constraints])) (rename [this renames & constraints]))
(defprotocol PRelations
(load! [this relations])
(insert!
[this relation]
[this & relations])
(delete! [this & relations])
(update! [this old-relation new-relation])
(clear! [this]))
#+END_SRC #+END_SRC
** Part 1. of Infrastructure for Essential State ** Part 1. of Infrastructure for Essential State
@ -153,6 +222,7 @@ implementing these types/functions.
#+NAME: relvar implementations #+NAME: relvar implementations
#+BEGIN_SRC clojure :noweb yes #+BEGIN_SRC clojure :noweb yes
(declare extend-)
(declare project-) (declare project-)
(declare restrict-) (declare restrict-)
@ -173,37 +243,72 @@ implementing these types/functions.
clojure.lang.IDeref clojure.lang.IDeref
(deref [_] @store)) (deref [_] @store))
(defn project- [relvar xf constraints] (defn extend- [relvar extensions constraints]
(->RelVar relvar xf constraints)) (let [xf (map (fn [element]
(map (fn [[k f]]
(assoc element k (f element)))
extensions)))]
(->RelVar relvar xf constraints)))
(defn project- [relvar attributes constraints]
(->RelVar relvar (map #(select-keys % attributes)) constraints))
(defn restrict- [relvar xf constraints] (defn restrict- [relvar criteria constraints]
(->RelVar relvar xf constraints)) (->RelVar relvar (filter criteria) constraints))
<<constraints>> <<constraints>>
#+END_SRC #+END_SRC
Extend a relvar with an additional key.
#+NAME: extend
#+BEGIN_SRC clojure
(defn extend- [relvar extensions constraints]
(let [xf (map (fn [element]
(map (fn [[k f]]
(assoc element k (f element)))
extensions)))]
(->RelVar relvar xf constraints)))
#+END_SRC
#+NAME: test extend
#+BEGIN_SRC clojure
(deftest test-extend
(testing "extend-"
(let [Offer (frp/->BaseRelVar 'Offer (atom #{}) '())]
(frp/load! Offer #{{:price 1e6}})
(frp/extend- Offer [:price-band (fn [e] (if (> (:price e) 1e6) :high :low))])
(is (= :low (-> @Offer first :price-band))))))
#+END_SRC
Clojure's core set library includes a =project= function, but I'm not sure if Clojure's core set library includes a =project= function, but I'm not sure if
it returns a transducer. I'll mark that as a todo. Look into whether this it returns a transducer. I'll mark that as a todo. Look into whether this
map/select-keys can be replaced by =set/project=. map/select-keys can be replaced by =set/project=.
#+NAME: relational algebra for derived relvars #+NAME: relational algebra for derived relvars
#+BEGIN_SRC clojure #+BEGIN_SRC clojure
(extend
[this extensions & constraints]
(extend- this extensions constraints))
(project (project
[this attributes constraints] [this attributes & constraints]
(project- this (map #(select-keys % attributes)) constraints)) (project- this attributes constraints))
(restrict (restrict
[this criteria constraints] [this criteria & constraints]
(restrict- this (filter criteria) constraints)) (restrict- this criteria constraints))
#+END_SRC #+END_SRC
#+NAME: relational algebra for base relvars #+NAME: relational algebra for base relvars
#+BEGIN_SRC clojure #+BEGIN_SRC clojure
(extend
[this extensions & constraints]
(extend- this extensions constraints))
(project (project
[this attributes constraints] [this attributes & constraints]
(project- this (map #(select-keys % attributes)) constraints)) (project- this attributes constraints))
(restrict (restrict
[this criteria constraints] [this criteria & constraints]
(restrict- this (filter criteria) constraints)) (restrict- this criteria constraints))
#+END_SRC #+END_SRC
#+NAME: relations manipulations #+NAME: relations manipulations
@ -233,7 +338,9 @@ map/select-keys can be replaced by =set/project=.
#+BEGIN_SRC clojure :noweb no-export :tangle ../frp/infrastructure.clj #+BEGIN_SRC clojure :noweb no-export :tangle ../frp/infrastructure.clj
(ns com.owoga.frp.infrastructure (ns com.owoga.frp.infrastructure
(:require [clojure.set :as set])) (:require [clojure.set :as set])
(:refer-clojure :exclude [extend]))
<<relvar protocols>> <<relvar protocols>>
<<relvar implementations>> <<relvar implementations>>
#+END_SRC #+END_SRC
@ -297,85 +404,6 @@ loaded
(is (= @Offer #{{:price 20}}))))) (is (= @Offer #{{:price 20}})))))
#+END_SRC #+END_SRC
#+NAME: essential state infrastructure
#+BEGIN_SRC clojure :noweb no-export
(defmacro candidate-key [relvar tuple]
`(swap! constraints assoc-in ['~relvar :candidate-key] '~tuple))
(defn unique-on? [ks coll]
(every?
(fn [el]
(let [vs (select-keys el ks)]
(= 1 (count (filter #(= (select-keys % ks) vs) coll)))))
coll))
(deftype RelVar [relvar-name spec store]
PRelVar
(relset! [_ data]
(let [namespaced-data
(into #{} (map (fn [x]
(into {} (map (fn [[k v]]
[(keyword (str (namespace spec)) (str relvar-name "-" (name k))) v])
x)))
data))
unique-on (get-in @constraints [(symbol relvar-name) :candidate-key])]
(cond
(not (s/valid? spec namespaced-data))
(throw (ex-info (s/explain-str spec data) {}))
(not (unique-on? unique-on data))
(throw (ex-info "Failed unique constraint" {:unique-on unique-on}))
:else
(reset! store data))))
clojure.lang.IDeref
(deref [_] @store))
(defrelvar dictionary-word
:id int?
:spelling string?
:syllables (s/coll-of string?))
(candidate-key dictionary-word (:id))
(defrelvar rhyme-request
:id int?
:spelling string?
:syllable-groups (s/coll-of (s/coll-of string?)))
(deriverelvar
rhyming-dictionary-word
dictionary-word
{:rimes rimes
:onsets onsets
:nuclei nuclei})
(relset! dictionary-word #{{:id 1 :spelling "attorney" :syllables '("AH" "T" "ER" "N" "IY")}
{:id 2 :spelling "poverty" :syllables '("P" "AH" "V" "ER" "T" "IY")}
{:id 3 :spelling "bother" :syllables '("B" "AH" "TH" "ER")}
{:id 4 :spelling "me" :syllables '("M" "IY")}})
(relset! rhyme-request #{{:id 1 :spelling "thirty" :syllable-groups '(("TH" "ER" "T" "IY"))}})
#+END_SRC
#+BEGIN_SRC clojure
(require '[clojure.spec.alpha :as s])
(s/def ::test (s/coll-of (s/coll-of string?)))
(s/valid? ::test '(("a" "b") ("c")))
(defmacro foo
[]
(let [t (fn [] (s/def ::foo string?))]
(t)))
(macroexpand '(do ()))
(s/valid? ::foo "hi")
#+END_SRC
#+NAME: namespace and requires #+NAME: namespace and requires
#+BEGIN_SRC clojure :noweb no-export #+BEGIN_SRC clojure :noweb no-export
(ns com.owoga.prhyme.tar-pit (ns com.owoga.prhyme.tar-pit
@ -402,7 +430,22 @@ loaded
** Essential Logic ** Essential Logic
Derived-relation definitions, integrity constraints, and functions. Restrict is a unary operation which allows the selection of a subset of therecords in a relation according to some desired criteria
Project is a unary operation which creates a new relation corresponding to the old relation with various attributes removed from the records
Product is a binary operation corresponding to the cartesian product of mathematics
Union is a binary operation which creates a relation consisting of all records in either argument relation
Intersection is a binary operation which creates a relation consisting of all records in both argument relations
Difference is a binary operation which creates a relation consisting of all records in the first but not the second argument relation
Join is a binary operation which constructs all possible records that result from matching identical attributes of the records of the argument relations
Divide is a ternary operation which returns all records of the first argument which occur in the second argument associated with each record of the third argument
http://users.abo.fi/soini/divisionEnglish.pdf
** Accidental state and control ** Accidental state and control
@ -412,16 +455,6 @@ A declarative specification of a set of performance optimizations for the system
A specification of the required interfaces to the outside world. A specification of the required interfaces to the outside world.
#+BEGIN_SRC clojure :noweb no-export
<<namespace and requires>>
<<frp infrastructure>>
<<essential state>>
<<essential logic>>
<<accidental state (performance hints)>>
<<interface (feeders and observers)>>
#+END_SRC
* Essential Logic * Essential Logic
Derived relvar names and definitions. Derived relvar names and definitions.
@ -445,12 +478,20 @@ PropertyInfo = extend(Property,
#+END_EXAMPLE #+END_EXAMPLE
#+BEGIN_SRC clojure :eval no #+BEGIN_SRC clojure :eval no
(defn price-band-for-price [price] (frp/defrelvar Property
(if (> price 1e6) :high :low)) (fn [properties] (map #(number? (:price %)) properties))
(fn [properties] (map #(string? (:address %) properties))))
(frp/extend Property
[:price-band price-band-for-price])
(defn price-band-for-price [property]
(if (> (:price property) 1e6) :high :low))
(defn area-code-for-address [address] (defn area-code-for-address [address]
(if (re-matches #"(?i).*louisiana.*" address) :local :non-local)) (if (re-matches #"(?i).*louisiana.*" address) :local :non-local))
(def room-info-relvar (atom #{})) (def room-info-relvar (atom #{}))
(add-watch (add-watch
room-relvar room-relvar
@ -479,6 +520,24 @@ PropertyInfo = extend(Property,
new-state))))) new-state)))))
#+END_SRC #+END_SRC
#+BEGIN_SRC clojure
(defn extend
"Extend a relvar with new attributes.
The exensions will be functions that receive a relation element as the first argument"
[relvar & extensions]
(map (fn [element#]
(map (fn [extension#]
(let [k (first extension#)
f (list
(first (rest extension#))
element#
(rest extension))
f (first (rest extension#))
r (rest (rest extension#))
fun (list f element# r)]
(into element (extension# element#))))))))
#+END_SRC
When thinking about how to implement the derived relation above, it will help to think about how it will be used. When thinking about how to implement the derived relation above, it will help to think about how it will be used.
Output from relvars (base and derived) comes from Observers. Output from relvars (base and derived) comes from Observers.
@ -518,4 +577,6 @@ Despite this the intention is not for observers to be used as a substitute for t
(is (= @Offer #{{:address "123 Fake St." :price 1.5e5}}))))) (is (= @Offer #{{:address "123 Fake St." :price 1.5e5}})))))
<<test defrelvar>> <<test defrelvar>>
<<test extend>>
#+END_SRC #+END_SRC

@ -0,0 +1,523 @@
(ns com.owoga.prhyme.util.lovecraft
(:require [net.cgrand.enlive-html :as html]
[clojure.string :as string]
[com.owoga.prhyme.util.weighted-rand :as wr]
[com.owoga.prhyme.core :as prhyme]
[taoensso.tufte :as tufte :refer [defnp p profiled profile]]
[com.owoga.prhyme.frp :as frp]
[clojure.java.io :as io]
[clojure.set :as set]))
(tufte/add-basic-println-handler! {})
(def ^:dynamic *base-url* "https://www.hplovecraft.com/writings/texts/")
(def words-map
(into {} (map #(vector (string/lower-case (:word %)) %) frp/words)))
(defn fetch-url [url]
(html/html-resource (java.net.URL. url)))
(comment
(fetch-url *base-url*))
(defn links []
(map
#(str *base-url* (first (html/attr-values % :href)))
(html/select
(fetch-url *base-url*)
[:li :> [:a (html/attr? :href)]])))
(defn contentful-sections [nodes]
(->> nodes
(map html/text)
(filter #(> (count %) 100))))
(defn text-from-link [link]
(->> (html/select
(fetch-url link)
[:body])
(first)
(html/text)
((fn [s] (string/replace s #"[\s\u00A0]+" " ")))))
(defn cleanup [content]
(-> content
(string/replace #"Return to.*$" "")
(string/replace #"Home.*?This Site" "")
(string/replace #"[^a-zA-Z -]+" "")))
(defn tokens [content]
(string/split content #"\s+"))
(defn append-to-file [filepath text]
(with-open [w (io/writer filepath :append true)]
(.write w text)))
(defn scrape []
(run!
(fn [link]
(->> (text-from-link link)
(cleanup)
(#(str % "\n"))
(append-to-file "lovecraft.txt")))
(take 10 (links))))
(defn tokens-from-file [file]
(with-open [r (io/reader file)]
(tokens (slurp r))))
(defn window [n]
(fn [coll]
(cond
(empty? coll) []
(< (count coll) n) []
:else (cons (take n coll)
(lazy-seq ((window n) (drop n coll)))))))
(defnp markov [tokens]
(->> tokens
(map
(fn [token]
(let [k (butlast token)
v (last token)]
[k v])))
(reduce
(fn [a [k v]]
(update-in a [k v] (fnil inc 0)))
{})))
(defnp running-total
([coll]
(running-total coll 0))
([coll last-val]
(cond
(empty? coll) nil
:else (cons (+ last-val (first coll))
(lazy-seq
(running-total
(rest coll)
(+ last-val (first coll))))))))
(defnp weighted-rand [weights]
(let [running-weights (running-total weights)
rand-val (rand (last running-weights))]
(loop [i 0]
(if (> (nth running-weights i) rand-val)
i
(recur (inc i))))))
(defnp choose-from-markov-possibilities [possibilities]
(if (empty? possibilities)
nil
(let [weights (vals possibilities)
rng (wr/from-weights weights)
index (wr/nextr rng nil)]
(nth (keys possibilities) index))))
(def word-set (into #{} (->> prhyme/words
(map first)
(map string/lower-case)
(map #(string/replace % #"\(\d+\)" "")))))
(defn normalize-tokens [tokens]
(->> tokens
(map string/lower-case)
(filter word-set)))
(defn main []
(->> (tokens-from-file "lovecraft.txt")
(reverse)
(normalize-tokens)
((window 2))
(markov)
(into {})))
(defn make-markov-picker [markov-data]
(fn [k]
(choose-from-markov-possibilities
(get markov-data k {}))))
(defn synonym?
"Given a possibility, like [\"foo\" 3]
which says that foo follows a particular key with
a weight of 3, a word is a synonym of that possibility
if the word is a synonym ."
[p synonyms]
(synonyms p))
(defnp adjust-for-synonyms
"If a word is in a set of synonyms, adjust its weight upwards."
[synonyms]
(fn [possibilities]
(reduce
(fn [p s]
(if (s p)
(update p s #(* 5 %))
p))
possibilities
synonyms)))
(defnp adjust-for-rimes
[target-rime dictionary]
(fn [possibilities]
(into
{}
(map
(fn [[p v]]
(let [possibility (get dictionary p)
factor (count
(frp/consecutive-matching
target-rime
possibility
:rimes))]
[p (* v (max 1 (* factor 4)))]))
possibilities))))
(comment
((adjust-for-synonyms #{"war" "famine"})
{"war" 1
"disease" 3})
;; => {"war" 5, "disease" 3}
((adjust-for-rimes
(frp/make-word ["magic" "M" "AE" "JH" "IH" "K"])
words-map)
{"tragic" 3
"trick" 2
"foo" 1})
;; => {"tragic" 24, "trick" 8, "foo" 1}
)
(defonce lovecraft-markov (read-string (slurp "lovecraft.edn")))
(defonce markover (make-markov-picker lovecraft-markov))
(defn markov-key [key-fn]
(fn [text]
(key-fn text)))
(defn gen-from [m p initial]
(loop [r (list initial)]
(cond
(p r) (recur (cons (m (list (first r))) r))
:else r)))
(defn rhyming-words
"List of rhyming words sorted by quality of rhyme."
[target]
(let [target-phrase (->> target
(frp/phrase->word frp/words)
(#(assoc % :rimes? true)))]
(->> target-phrase
(#(assoc % :rimes? true))
(frp/prhyme frp/words)
(sort-by
#(- (count
(frp/consecutive-matching
%
target-phrase
:rimes)))))))
(defn markov-rhymes [markov-data rhyming-words]
(->> (map
(fn [word]
(->> word
:word
string/lower-case
(#(string/replace % #"\(\d+\)" ""))
(#(vector % (get markov-data (list %))))))
rhyming-words)
(into #{})
(remove
(fn [[w p]]
(nil? p)))))
(defn markov-gen [markov-data initial]
(let [m (make-markov-picker markov-data)]
(loop [r initial]
(if (> (count r) 5)
r
(recur (cons (m (list (first r)))
r))))))
(defn make-rhymes [markov-data target]
(let [target-word (frp/phrase->word frp/words target)
rhyming-words (rhyming-words target)
markov--rhymes (markov-rhymes markov-data rhyming-words)
rime-adjuster (adjust-for-rimes target-word words-map)
modified-markov-data
(merge
markov-data
(into {}
(map (fn [[word weights]]
[word (rime-adjuster weights)])
markov--rhymes)))]
(->> rhyming-words
(markov-rhymes modified-markov-data)
(map
(fn [[k v]]
(markov-gen modified-markov-data (list k))))
(map #(remove nil? %)))))
(defn adjust-for-over-syllables
"Adjust weights to prefer not going over the number
of syllables of the target word."
[target]
(fn [words]
(p :adjust-for-syllables
(map
(fn [word]
(if (or (nil? (:syllable-count word))
(nil? (:syllables target)))
(println word target))
(cond
(= (:syllable-count word) (count (:syllables target)))
(as-> word word
(assoc word :weight (* 3 (:weight word)))
(assoc word :adjusted-for-syllables-factor 3))
(< (:syllable-count word) (count (:syllables target)))
(as-> word word
(assoc word :weight (* 2 (:weight word)))
(assoc word :adjusted-for-syllables-factor 2))
:else
(as-> word word
(assoc word :weight (* 1 (:weight word)))
(assoc word :adjusted-for-syllables-factor 1))))
words))))
(comment
(let [words (->> ["distort" "kiss" "sport"]
(map #(frp/phrase->word frp/words %))
(map #(assoc % :weight 1)))
target (->> "report"
(frp/phrase->word frp/words)
(#(assoc % :syllables (:syllables %))))
adjuster (adjust-for-over-syllables target)]
(adjuster words)))
(defn adjust-for-rhymes
"Adjust weights to prefer words that rhyme"
[target]
(fn [words]
(p :adjust-for-rhymes
(map
(fn [word]
(let [factor (max 0.001 (count (frp/consecutive-matching word target :rimes)))]
(as-> word word
(assoc word :weight (* factor (:weight word)))
(assoc word :adjust-for-rhyme-factor factor))))
words))))
(defn adjust-for-rhymes-1
"Adjust weights to prefer words that rhyme"
[target percent]
(fn [words]
(let [ratio (/ percent (- 1 percent))
[rhymes non-rhymes]
((juxt filter remove)
(fn [word]
(< 0 (count (frp/consecutive-matching word target :rimes))))
words)
weight-non-rhymes (apply + (map :weight non-rhymes))
target-weight-rhymes (* ratio weight-non-rhymes)
count-rhymes (max 1 (count rhymes))
adjustment-rhyme (/ target-weight-rhymes count-rhymes)]
(concat
non-rhymes
(map
(fn [rhyme]
(as-> rhyme rhyme
(assoc rhyme :weight (* adjustment-rhyme (:weight rhyme)))
(assoc rhyme :adjust-for-rhyme-factor adjustment-rhyme)))
rhymes)))))
(comment
(let [words (->> ["distort" "kiss" "sport"]
(map #(frp/phrase->word frp/words %))
(map #(assoc % :weight 1)))
target (->> "report"
(frp/phrase->word frp/words)
(#(assoc % :remaining-syllables (:syllables %))))
rhyme-adjuster (adjust-for-rhymes target)
syllable-count-adjuster (adjust-for-over-syllables target)]
(syllable-count-adjuster (rhyme-adjuster words))))
(defn adjust-for-membership [set_]
(fn [words]
(map
(fn [word]
(if (set_ (:norm-word word))
(as-> word word
(assoc word :weight (* 2 (:weight word)))
(assoc word :adjust-for-membership-factor 2))
(assoc word :adjust-for-membership-factor 1)))
words)))
(defn filter-for-membership [set_]
(fn [words]
(map
(fn [word]
(if-not (set_ (:norm-word word))
(as-> word word
(assoc word :weight (* 0.01 (:weight word)))
(assoc word :filter-for-membership-factor 0.01))
word))
words)))
(defn adjust-for-markov [markov-options]
(let [markov-set (into #{} (map first (keys markov-options)))]
(fn [words]
(let [result (map
(fn [word]
(if (markov-set (:norm-word word))
(as-> word word
(assoc word :weight (* 100 (:weight word)))
(assoc word :adjust-for-markov-factor 100))
(assoc word :adjust-for-markov-factor 1)))
words)]
result))))
(comment
(let [markov-adjuster (adjust-for-markov (lovecraft-markov '("help")))]
(take 5 (markov-adjuster frp/words))))
(defn e-prhyme
"2020-10-21 iteration"
[words markov target stop?]
(let [target (assoc target :original-syllables (:syllables target))
words (map #(assoc % :weight 1) words)
words (take (int 1e5) words)]
(loop [target target
result '()
sentinel 0]
(if (or (stop? target result)
(> sentinel 5))
result
(let [markov-options (markov (list (first result)))
markov-adjuster (adjust-for-markov markov-options)
syllable-count-adjuster (adjust-for-over-syllables target)
rhyme-adjuster (adjust-for-rhymes-1 target 0.8)
lovecraft-set (into #{} (map (comp first first) lovecraft-markov))
lovecraft-adjuster (adjust-for-membership lovecraft-set)
lovecraft-filter (filter-for-membership lovecraft-set)
adjust (comp lovecraft-adjuster
rhyme-adjuster
syllable-count-adjuster
markov-adjuster
lovecraft-filter)
weighted-words (p :adjust
(->> (adjust words)
(remove #(= 0 (:weight %)))))
rng (p :from-weights (wr/from-weights (map :weight weighted-words)))
index (p :nextr (wr/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)))))))
(def words (map #(assoc % :weight 1) frp/words))
(comment
(let [orig-target (frp/phrase->word frp/words "please turn on your magic beam")]
(repeatedly
10
(fn []
(e-prhyme
frp/words
lovecraft-markov
(frp/phrase->word frp/words "please turn on your magic beam")
(fn [target result]
(<= (count (:syllables orig-target))
(apply + (map :syllable-count result)))))))))
(comment
(frp/phrase->word frp/words "distort bad man")
(repeatedly 10 #(make-rhymes lovecraft-markov "bad man"))
(rhyming-words "magic beam")
((make-markov-picker lovecraft-markov) '("no"))
(markov-gen lovecraft-markov '("world"))
(interleave
(->> "your eyes"
(make-rhymes lovecraft-markov)
(map
(fn [[k v]]
(markov-gen lovecraft-markov (list k)))))
(->> "pretty"
(make-rhymes lovecraft-markov)
(map
(fn [[k v]]
(markov-gen lovecraft-markov (list k))))
(remove nil?)))
(frp/phrase->word frp/words "well-off")
(frp/prhyme frp/words (assoc (words-map "well") :rimes? true))
)
(defn ghost
"Rhyme a phrase with markov"
[words word]
(let [rhymes (frp/prhyme words word)
norm-rhyme-words (->> rhymes
(map :word)
(map string/lower-case)
(map #(string/replace % #"\(\d+\)" ""))
(into #{})
(filter #(get lovecraft-markov (list %))))
keyer (markov-key #(list (first (string/split % #"\s"))))]
(->> norm-rhyme-words
(map (fn [w]
(gen-from markover #(< (count %) 5) w))))))
(comment
(take 10 lovecraft-markov)
(ghost frp/words (assoc (frp/make-word ["dream" "D" "R" "IY" "M"])
:rimes?
true)))
(comment
(->> (frp/make-word ["dream" "D" "R" "IY" "M"])
(#(assoc % :rimes? true))
(frp/prhyme frp/words)
(take 10))
(->> (main)
(#(spit "lovecraft.edn" (pr-str %))))
(let [t (read-string (slurp "lovecraft.edn"))]
(take 20 t))
)
(comment
(->> (tokens-from-file "lovecraft.txt")
(reverse)
(normalize-tokens)
((window 2))
(markov)
(take 10)
(into {})
(#(get % '("away")))
(choose-from-markov-possibilities))
(markov [["boy" "good"] ["the" "over"]
["ran" "he"] ["walked" "he"]
["walked" "he"] ["walked" "she"]])
(tokens-from-file "lovecraft.txt")
(scrape)
(def test-links (take 3 (links)))
(->> (text-from-link (first test-links))
(cleanup))
(->> (text-from-link (first test-links))
(append-to-file "test.txt" "hi"))
(take 3 (html/select (fetch-url (first test-links)) [:body]))
)

@ -0,0 +1,86 @@
(ns com.owoga.prhyme.util.weighted-rand
(:import clojure.lang.PersistentQueue))
(defprotocol Rand
(nextr [_ rng]))
;; Vose's alias method
;; http://www.keithschwarz.com/darts-dice-coins/
(deftype Vose [n ^ints alias ^doubles prob]
Rand
;; returns the index of the chosen weight
(nextr [_ rng] ;; not using the rng for now
(let [i (rand-int n)
p (aget prob i)]
(if (or (= p 1.0)
(< (rand) p))
i
(aget alias i)))))
(defn ^:private make-vose [dist]
(let [N (count dist)
alias (int-array N)
prob (double-array N)]
(if (zero? N)
(->Vose N alias prob)
(let [^doubles ps (->> dist
(map (partial * N))
(into-array Double/TYPE))
[small large] (loop [i 0
[small large] [PersistentQueue/EMPTY
PersistentQueue/EMPTY]
ps (seq ps)]
(if (seq ps)
(let [p (first ps)]
(if (< p 1)
(recur (inc i)
[(conj small i) large]
(rest ps))
(recur (inc i)
[small (conj large i)]
(rest ps))))
[small large]))
[small large] (loop [small small
large large]
(if (and (seq small) (seq large))
(let [l (first small)
g (first large)
small (pop small)
large (pop large)]
(aset-double prob l (aget ps l))
(aset-int alias l g)
(let [pg (- (+ (aget ps g) (aget ps l))
1.0)]
(aset-double ps g pg)
(if (< pg 1)
(recur (conj small g) large)
(recur small (conj large g)))))
[small large]))]
(doseq [g (concat large small)]
(aset-double prob g 1))
(->Vose N alias prob)))))
(defn from-weights [ws]
(let [N (count ws)
tot (reduce + 0.0 ws)
dist (if (zero? tot)
(repeat N (/ 1 tot))
(map #(/ % tot) ws))]
(make-vose (vec dist))))
(comment
(let [ws [1 2 4 8]
rng (from-weights ws)]
(nextr rng nil)))
(comment
(let [ws [1 2 1 3 3]
rng (from-weights ws)
chosen (repeatedly 1000000 #(nextr rng nil))
accuracy (mapv (comp float
#(/ % 100000)
(frequencies chosen))
(range (count ws)))]
accuracy))

@ -26,3 +26,10 @@
(let [Offer (frp/defrelvar Offer (fn [offers] (map #(> (:price %) 0) offers)))] (let [Offer (frp/defrelvar Offer (fn [offers] (map #(> (:price %) 0) offers)))]
(frp/insert! Offer {:price 20}) (frp/insert! Offer {:price 20})
(is (= @Offer #{{:price 20}}))))) (is (= @Offer #{{:price 20}})))))
(deftest test-extend
(testing "extend-"
(let [Offer (frp/->BaseRelVar 'Offer (atom #{}) '())]
(frp/load! Offer #{{:price 1e6}})
(frp/extend- Offer [:price-band (fn [e] (if (> (:price e) 1e6) :high :low))])
(is (= :low (-> @Offer first :price-band))))))

Loading…
Cancel
Save