ring.clj

(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)))