(ns com.tailrecursion.blacktide.assignment-model
"Independent assignment semantics, event traces, and bounded source generators.
The interpreter models source assignments without using compiler lowering."
(:require [clojure.test.check.generators :as gen]))
(defn lit [value] {:op :const :value value})
(defn read-var [name] {:op :read :binding name})
(defn batch [op & writes] {:op op :writes (mapv vec (partition 2 writes))})
(defn sequence-of [& forms] {:op :do :forms (vec forms)})
(defn event [tag value] {:op :event :tag tag :value value})
(defn evaluate [form state]
(case (:op form)
:const [(:value form) state]
:read [(get-in state [:vars (:binding form)]) state]
:add (let [[a state] (evaluate (:left form) state)
[b state] (evaluate (:right form) state)] [(+ a b) state])
:do (reduce (fn [[_ state] form] (evaluate form state)) [nil state] (:forms form))
:if (let [[test state] (evaluate (:test form) state)]
(evaluate (if test (:then form) (:else form)) state))
:event (let [[value state] (evaluate (:value form) state)]
[value (update state :trace conj [(:tag form) value])])
:setq (reduce (fn [[_ state] [name rhs]]
(let [[value state] (evaluate rhs state)]
[value (assoc-in state [:vars name] value)]))
[nil state] (:writes form))
;; Snapshot every parallel RHS before applying any pending write.
:psetq (let [[values state]
(reduce (fn [[values state] [_ rhs]]
(let [[value state] (evaluate rhs state)]
[(conj values value) state]))
[[] state] (:writes form))]
[nil (update state :vars merge (zipmap (map first (:writes form)) values))])))
(defn execute [form vars]
(let [[value state] (evaluate form {:vars vars :trace []})]
(assoc state :value value)))
(defn expression [depth]
(let [leaf (gen/one-of [(gen/fmap lit (gen/choose -5 5))
(gen/fmap read-var (gen/elements '[x y]))])]
(if (zero? depth) leaf
(let [child (expression (dec depth))
writes (gen/vector (gen/tuple (gen/elements '[x y]) child) 0 3)]
(gen/one-of
[leaf
(gen/let [a child b child] {:op :add :left a :right b})
(gen/let [a child b child] (sequence-of a b))
(gen/let [test gen/boolean then child else child]
{:op :if :test (lit test) :then then :else else})
(gen/let [tag (gen/elements [:a :b :c]) value child] (event tag value))
(gen/let [writes writes] (sequence-of {:op :setq :writes writes} (read-var 'x)))
(gen/let [writes writes] (sequence-of {:op :psetq :writes writes} (read-var 'y)))])))))