Skip to content

Instantly share code, notes, and snippets.

@hiredman
Created January 4, 2018 21:44
Show Gist options
  • Save hiredman/f56a593bc92062dcdfeebded0ab6725e to your computer and use it in GitHub Desktop.
Save hiredman/f56a593bc92062dcdfeebded0ab6725e to your computer and use it in GitHub Desktop.
(ns com.manigfeald.twoq.ring
(:refer-clojure :exclude [pop peek update]))
(defprotocol Ring
(pop [ring])
(peek [ring])
(push [ring datum]))
(deftype Node [key value high low])
(defn build-tree [lo hi]
(let [mid (long (+ lo (/ (- hi lo) 2)))
new-lo (inc mid)
new-hi (dec mid)]
(cond
(= mid lo hi)
(Node. mid mid nil nil)
(= mid lo)
(Node. mid mid (build-tree new-lo hi) nil)
:else
(do
(assert (> hi mid lo) [hi mid lo])
(Node. mid
mid
(build-tree new-lo hi)
(build-tree lo new-hi))))))
(defn search [^Node root k]
(when root
(cond
(= k (.-key root)) (.-value root)
(> k (.-key root)) (recur (.-high root) k)
(< k (.-key root)) (recur (.-low root) k))))
(defn update [^Node root k v]
(assert root)
(cond
(= k (.-key root)) (Node. k v (.-high root) (.-low root))
(> k (.-key root)) (Node. (.-key root)
(.-value root)
(update (.-high root) k v)
(.-low root))
(< k (.-key root)) (Node. (.-key root)
(.-value root)
(.-high root)
(update (.-low root) k v))))
(deftype FixedRing [root read write entries limit]
Ring
(pop [ring]
(FixedRing. root (mod (inc read) limit) write (dec entries) limit))
(peek [ring]
(when (pos? entries)
(search root read)))
(push [ring datum]
(if (and (= read write)
(pos? entries))
false
(FixedRing. (update root write datum)
read
(mod (inc write) limit)
(inc entries)
limit))))
(defn fixed [n]
(assert (pos? n))
(FixedRing. (build-tree 0 n) 0 0 0 n))
(defn fixed-seq [ring]
(letfn [(f [^FixedRing ring]
(lazy-seq
(when (pos? (.-entries ring))
(cons (peek ring)
(f (pop ring))))))]
(f ring)))
(deftype Lens [get set])
(defn lupdate [^Lens lens v s]
((.-set lens) v s))
(defn view [^Lens lens s]
((.-get lens) s))
(defn lalter [lens fun & args]
(fn [s]
(lupdate lens (apply fun (view lens s) args) s)))
(defn lcompose [a b]
(Lens. (fn [s]
(view b (view a s)))
(fn [v s]
(let [x (view a s)
x (update b v s)]
(update a x s)))))
(defmacro flense [type]
(let [^Class t (resolve type)
fields (for [^java.lang.reflect.Method method (.getDeclaredMethods t)
:when (= (.getName method) "getBasis")
field (.invoke method type (object-array 0))]
field)]
`(do
~@(for [field fields
:let [data (gensym 'data)
node (with-meta (gensym 'node) {:tag type})]]
`(def ~(symbol (str "L" field))
(Lens. (fn [~node] (. ~node ~field))
(fn [~data ~node]
(new ~type
~@(for [f fields]
(if (= f field)
data
`(. ~node ~f)))))))))))
(flense Node)
(defprotocol Traversal
(tpush [traversal lens])
(tpop [traversal])
(here [traversal])
(talter [traversal fun])
(root? [traversal]))
(defrecord ATraversal [stack current]
Traversal
(tpush [traversal lens]
(->ATraversal (conj stack [lens current])
(view lens current)))
(tpop [traversal]
(let [[l v] (clojure.core/peek stack)]
(lupdate l current v)))
(here [traversal]
current)
(talter [traversal fun]
(->ATraversal stack (fun current)))
(root? [traversal]
(empty? stack)))
(defn unwind [traversal]
(if (root? traversal)
traversal
(recur (tpop traversal))))
(defn seek-to [root k]
(loop [t (->ATraversal () root)]
(let [kk (view Lkey (here t))]
(cond
(= k kk) t
(> k kk) (recur (tpush t Lhigh))
(< k kk) (recur (tpush t Llow))))))
(defn search'' [root k]
(view Lvalue (here (seek-to root k))))
(defn update'' [root k v]
(assert root)
(-> (seek-to root k)
(tpush Lvalue)
(talter (constantly v))
(unwind)
(here)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment