avl_tree.clj

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

red_black.clj

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