Skip to content

Instantly share code, notes, and snippets.

@mjm mjm/avl_tree.clj
Created Jan 27, 2009

Embed
What would you like to do?
(ns structures.avl-tree)
(defn height [tree]
(if (nil? tree)
0
(inc (max (height (:left tree))
(height (:right tree))))))
(defn balance [tree]
(- (height (:left tree))
(height (:right tree))))
(defn tree
([data] {:data data})
([data left right] {:data data
:left left
:right right}))
(defn- rotate-left [tree]
(assoc (:right tree)
:left (assoc tree
:right (:left (:right tree)))))
(defn- rotate-right [tree]
(assoc (:left tree)
:right (assoc tree
:left (:right (:left tree)))))
(defn- rotate-left-right [tree]
(rotate-right
(assoc tree
:left (rotate-left (:left tree)))))
(defn- rotate-right-left [tree]
(rotate-left
(assoc tree
:right (rotate-right (:right tree)))))
(defn- balanced [tree]
(let [bal (balance tree)]
(cond (> bal 1)
(if (> (balance (:left tree)) 0)
(rotate-right tree)
(rotate-left-right tree))
(< bal -1)
(if (< (balance (:right tree)) 0)
(rotate-left tree)
(rotate-right-left tree))
true tree)))
(defn insert [t val]
(if (nil? t)
(tree val)
(balanced
(cond (< val (:data t))
(assoc t :left (insert (:left t) val))
(> val (:data t))
(assoc t :right (insert (:right t) val))
true t))))
(defn- predecessor [t]
(loop [n (:left t)]
(if (:right n)
(recur (:right n))
n)))
(def delete)
(defn- delete-here [t val]
(cond (nil? (:left t))
(:right t)
(nil? (:right t))
(:left t)
true
(let [p (predecessor t)]
(assoc (assoc t :data (:data p))
:left (delete (:left t) (:data p))))))
(defn delete [t val]
(if (nil? t)
nil ; fail silently
(balanced
(cond (< val (:data t))
(assoc t :left (delete (:left t) val))
(> val (:data t))
(assoc t :right (delete (:right t) val))
true
(delete-here t val)))))
(defn tree-with [& data]
(loop [t nil
d data]
(if (empty? d)
t
(recur (insert t (first d)) (rest d)))))
(defn print-tree [tree]
(if (nil? tree)
"//"
(str "(" (:data tree)
(if (or (:left tree) (:right tree))
(str " " (print-tree (:left tree))
" " (print-tree (:right tree))))
")")))
(ns structures.red-black)
(defstruct tree :data :red :left :right)
(defn node
([data] (struct tree data true nil nil))
([data red?] (struct tree data red? nil nil)))
(def data (accessor tree :data))
(def left (accessor tree :left))
(def right (accessor tree :right))
(defn direction [t val]
(cond (< val (data t)) :left
(> val (data t)) :right))
(defn opposite [dir]
(cond (= dir :left) :right
(= dir :right) :left))
;;; This is probably unnecessary
(defn red? [t]
(and t (:red t)))
(defn single-rotate [t dir]
(let [opp (opposite dir)]
(assoc (opp t)
:red false
dir (assoc t
opp (dir (opp t))
:red true))))
(defn double-rotate [t dir]
(let [opp (opposite dir)]
(single-rotate (assoc t opp (single-rotate (opp t) opp)) dir)))
(defn rebalance [t dir]
(or (if (red? (dir t))
(if (red? ((opposite dir) t))
(assoc t
:red true
:left (assoc (left t) :red false)
:right (assoc (right t) :red false))
(cond (red? (dir (dir t)))
(single-rotate t (opposite dir))
(red? ((opposite dir) (dir t)))
(double-rotate t (opposite dir)))))
t))
(defn- insert-r [t val]
(if (nil? t)
(node val)
(if-let [dir (direction t val)]
(rebalance (assoc t dir (insert-r (dir t) val)) dir)
t)))
(defn insert [t val]
"Insert on the root of the tree."
(assoc (insert-r t val)
:red false))
(defn- red-violation? [t]
"Cannot have two joined red nodes in a tree"
(and (red? t)
(or (red? (left t))
(red? (right t)))))
(defn- bst-violation? [t]
(or (and (left t) (>= (data (left t)) (data t)))
(and (right t) (<= (data (right t)) (data t)))))
(defn- black-violation? [lh rh]
(not (= lh rh)))
(defn valid? [t]
(or (nil? t)
(and (not (red-violation? t))
(valid? ))))
(defn check [t]
(if (nil? t)
1
(do
(assert (not (red-violation? t)))
(assert (not (bst-violation? t)))
(let [lh (check (left t))
rh (check (right t))]
(assert (not (black-violation? lh rh)))
(if (red? t) lh (inc lh))))))
(defn tree-with [& data]
(loop [t nil
d data]
(if (empty? d)
t
(recur (insert t (first d)) (rest d)))))
(defn print-tree [t]
(if (nil? t)
"//"
(str "(" (:data t)
(if (red? t) "R" "B")
(if (or (left t) (right t))
(str " " (print-tree (:left t))
" " (print-tree (:right t))))
")")))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.