Clojure state monad..

core.clj

(ns grime.core
  (:require [grime.state :as st :refer [run-state state >> >>=]]))

(def world-state
  {:last-entity-id -1
   :entities       {}})

(defn mutate [entity f & args]
  (state
   (fn [world]
     [nil (apply update-in world [:entities entity] f args)])))

(defn guard [pred f]
  (state
   (fn [world]
     (if (st/eval-state pred world)
       (run-state f world))
        [nil world])))

(defn exists? [entity]
  (state
   (fn [world]
     [(contains? (:entities world) entity) world])))

(defn query [path]
  (state
   (fn [world]
     [(get-in world (into [:entities] path))
      world])))

(defn acquire [location thing]
  (mutate location update :contents (fnil conj #{}) thing))

(defn dispose [location thing]
  (mutate location update :contents (fnil disj #{}) thing))

(defn occupy [thing location]
  (mutate thing assoc :location location))

(defn move [thing location]
  (>> (>>= (query [thing :location])
           (fn [cur-location]
             (guard (exists? cur-location)
                    (dispose cur-location thing))))
      (acquire location thing)
      (occupy thing location)))

core_test.clj

(ns grime.core-test
  (:require [clojure.test :refer :all]
            [grime.core :refer :all]
            [grime.state :as st :refer [run-state exec-state eval-state]]))

(defn run-world [f world-state]
  (f world-state))

(def world
  {:entities
   {0 {:id       0
       :name     "Guy"
       :location 1}
    1 {:id       1
       :name     "Somewhere Dark"
       :contents #{0}}
    2 {:id   2
       :name "The Forest"}
    3 {:id       3
       :name     "a wooden stick"
       :location 0}}})

(def guy 0)
(def dark 1)
(def forest 2)
(def wand 3)

(deftest basic-test
  (is (-> (exists? guy)
          (eval-state world)))
  (is (not (-> (exists? 50)
               (eval-state world))))
  (is (-> (move guy forest)
          (exec-state world)
          (get-in [:entities guy :location])
          (= forest))))

state.clj

(ns grime.state
  (:refer-clojure :exclude [get put]))

(defprotocol IState
  (run-state [this initial-state]))

(deftype State [f]
  IState
  (run-state [this initial-state]
    (f initial-state)))

(defn eval-state [m s]
  (first (run-state m s)))

(defn exec-state [m s]
  (second (run-state m s)))

(defn state [f] (State. f))

(defn return [v]
  (state
   (fn [state] [v state])))

(defn >>=
  ([m] m)
  ([m k]
   (state
    (fn [st]
      (let [[x st2] (run-state m st)]
        (run-state (k x) st2)))))
  ([m k & ks]
   (reduce >>= (>>= m k) ks )))

(defn >>
  ([m] m)
  ([m k]
   (>>= m (fn [x] k)))
  ([m k & ks]
   (reduce >> (>> m k) ks)))

(defn lift [f & args]
  (comp return (apply partial f args)))

(defn get []
  (state
   (fn [st]
     [st st])))

(defn put
  ([] put)
  ([s] (state
        (fn [_]
          [nil s]))))

(defn modify [f]
  (state
   (fn [s]
     [nil (f s)])))

(defn gets [f]
  (state (fn [s] [(f s) s])))

(comment
  (run-state
   (>>= (get)
        (lift * 2)
        (lift + 3)
        (lift inc)
        (put))
   5)

  ;;Example code that doesn't look so nice.
  (defn find-two-guys [guy1 guy2]
    (>>= (query [guy1 :location])
         (fn [loc1]
           (>>= (query [guy2 :location])
                (fn [loc2]
                  (return [loc1 loc2]))))))

  ;;Getting funny with formatting.
  (defn find-two-guys [guy1 guy2]
    (>>= (query [guy1 :location])
    (fn [loc1]
    (>>= (query [guy2 :location])
    (fn [loc2]
    (return [loc1 loc2]))))))
)