# Commits

committed 6700f75 Draft

Balancing is working

# src/AVL.ml

= 'a node ref
and 'a node
= Empty
-    | Node of 'a avl * 'a avl * int ref * 'a
+    | Node of 'a avl * 'a avl * int ref * 'a ref

(*********************************************************************************************************************
Empty

| Node(left_avl, right_avl, node_depth, a) ->
-        Node(clone left_avl, clone right_avl, ref !node_depth, a)
+        Node(clone left_avl, clone right_avl, clone_ref node_depth, clone_ref a)

+let rec balance_factor avl = balance_factor_node !avl
+and balance_factor_node = function
+    | Empty ->
+        0
+
+    | Node (left_avl, right_avl, node_depth, a) ->
+        depth left_avl - depth right_avl
+
+
+let recalculate_depth avl = match !avl with
+    | Empty ->
+        ()
+
+    | Node (left_avl, right_avl, node_depth, a) ->
+        node_depth := succ (max (depth left_avl) (depth right_avl))

(*********************************************************************************************************************
* Creators

let make_leaf_node a =
-    Node (make_empty (), make_empty (), ref 1, a)
+    Node (make_empty (), make_empty (), ref 1, ref a)

let make_leaf a = ref (make_leaf_node a)

let fold_inorder f acc avl = fold inorder_fold_strategy f acc avl
let fold_revorder f acc avl = fold revorder_fold_strategy f acc avl

+
+let rec check_invariant avl =
+    match !avl with
+        | Empty ->
+            true
+
+        | Node (left_avl, right_avl, depth, a) ->
+            let is_balanced = abs (balance_factor avl) < 2 in
+            is_balanced && check_invariant left_avl && check_invariant right_avl
+
+
(*********************************************************************************************************************
* Rotate
********************************************************************************************************************)

(*
-      *                 *
+      x                 y
/ \               / \
-    *   C   <---->    A   *
+    y   C   <---->    A   x
/ \                   / \
A   B                 B   C

let a_avl = clone_ref sub_left_avl in
let b_avl = clone_ref sub_right_avl in
let c_avl = clone_ref right_avl in
+                    let x     = clone_ref a in
+                    let y     = clone_ref sub_a in

right_avl     := !left_avl;
left_avl      := !a_avl;
sub_left_avl  := !b_avl;
-                    sub_right_avl := !c_avl
+                    sub_right_avl := !c_avl;
+
+                    sub_a := !x;
+                    a     := !y;
+
+                    recalculate_depth avl;
+                    recalculate_depth left_avl
+

end

let a_avl = clone_ref left_avl in
let b_avl = clone_ref sub_left_avl in
let c_avl = clone_ref sub_right_avl in
+                    let y     = clone_ref a in
+                    let x     = clone_ref sub_a in

left_avl      := !right_avl;
right_avl     := !c_avl;
sub_left_avl  := !a_avl;
-                    sub_right_avl := !b_avl
+                    sub_right_avl := !b_avl;
+
+                    sub_a := !y;
+                    a     := !x;
+
+                    recalculate_depth avl;
+                    recalculate_depth right_avl

end

* Balance
********************************************************************************************************************)

-let rec balance_factor avl = balance_factor_node !avl
-and balance_factor_node = function
-    | Empty ->
-        0
-
-    | Node (left_avl, right_avl, node_depth, a) ->
-        depth left_avl - depth right_avl
-
let balance_rr avl =
rotate_left avl

rotate_right right_avl;
rotate_left avl

+
let balance_ll avl =
rotate_right avl

if balance_factor right_avl < 1 then
balance_rr avl
else
-                (* right_left_case *)
-                ()
+                balance_rl avl

| n when n > 1 ->
if balance_factor left_avl < 1 then
-                ()
+                balance_lr avl
else
-                ()
+                balance_ll avl

| _ ->
()

-let no_rebalance_node _ = ()
+let no_rebalance _ = ()

let rec rebalance avl = match !avl with
| Empty ->
()

-    | Node (left_avl, right_avl, _, _) as node ->
+    | Node (left_avl, right_avl, _, _) ->
rebalance left_avl;
rebalance right_avl;
single_rebalance avl
* Insert
********************************************************************************************************************)

-let rec raw_insert balance_strategy allow_dup a avl =
-    avl := raw_insert_node balance_strategy allow_dup a !avl
+and raw_insert balance_strategy allow_dup a avl = match !avl with
+    | Empty ->
+        avl := make_leaf_node a

-and raw_insert_node balance_strategy allow_dup a = function
-    | Empty ->
-        make_leaf_node a
-
-    | Node(left_avl, right_avl, node_depth, b) as node ->
-        begin match compare a b with
+    | Node(left_avl, right_avl, node_depth, b) ->
+        begin match compare a !b with
| n when n < 0 ->
raw_insert balance_strategy allow_dup a left_avl

raw_insert balance_strategy allow_dup a left_avl
end;
incr node_depth;
-        balance_strategy node;
-        node
+        balance_strategy avl

-let insert allow_dup a = raw_insert single_rebalance_node allow_dup a
+let insert ?(allow_dup=false) a = raw_insert single_rebalance allow_dup a

+let insert_bst ?(allow_dup=false) a = raw_insert no_rebalance allow_dup a

-let insert_many allow_dup xs avl =
-    List.iter (fun a -> raw_insert no_rebalance_node allow_dup a avl) xs;
+let insert_many ?(allow_dup=false) xs avl =
+    List.iter (fun a -> raw_insert no_rebalance allow_dup a avl) xs;
rebalance avl

+(*********************************************************************************************************************
+ * Extract-element
+ ********************************************************************************************************************)
+
+let rec raw_extract balance_strategy selection_strategy avl = match !avl with
+    | Empty ->
+        failwith "Cannot extract from empty AVL tree"
+
+    | Node (left_avl, right_avl, node_depth, a) ->
+        let (selected_avl, other_avl) = selection_strategy left_avl right_avl in
+        if is_empty selected_avl then begin
+            avl := !other_avl;
+            a
+        end else
+            let extracted = raw_extract balance_strategy selection_strategy selected_avl in
+            balance_strategy avl;
+            extracted
+
+
+let raw_extract_max balance_strategy avl =
+    let selection_strategy left_avl right_avl = (right_avl, left_avl) in
+    raw_extract balance_strategy selection_strategy avl
+
+let raw_extract_min balance_strategy avl =
+    let selection_strategy left_avl right_avl = (left_avl, right_avl) in
+    raw_extract balance_strategy selection_strategy avl
+
+let extract_max avl = raw_extract_max single_rebalance avl
+let extract_min avl = raw_extract_min single_rebalance avl

(*********************************************************************************************************************
* Remove
********************************************************************************************************************)

-let rec raw_remove balance_strategy stop_after_first a avl =
-    avl := raw_remove_node balance_strategy stop_after_first a !avl
+let rec raw_remove balance_strategy stop_after_first a avl = match !avl with
+    | Empty ->
+        ()

-and raw_remove_node balance_strategy stop_after_first a = function
-    | Empty ->
-        Empty
+    | Node (left_avl, right_avl, node_depth, b) when !node_depth = 1 && compare a b = 0 ->
+        avl := Empty

-    | Node (left_avl, right_avl, node_depth, b) when !node_depth = 1 ->
-        Empty
+    | Node (left_avl, right_avl, node_depth, b) when is_empty left_avl && compare a b = 0 ->
+        avl := !right_avl

-    | Node (left_avl, right_avl, node_depth, b) as node ->
+    | Node (left_avl, right_avl, node_depth, b) when is_empty right_avl && compare a b = 0 ->
+        avl := !left_avl
+
+    | Node (left_avl, right_avl, node_depth, b) ->
begin match compare a b with
| n when n < 0 ->
raw_remove balance_strategy stop_after_first a left_avl;
-                node

| n when n > 0 ->
raw_remove balance_strategy stop_after_first a right_avl;
-                node

| _ ->
if not stop_after_first then begin
raw_remove balance_strategy stop_after_first a left_avl;
raw_remove balance_strategy stop_after_first a right_avl
end;
-                node
+                let left_max = raw_extract_max balance_strategy left_avl in
+                avl := Node (left_avl, right_avl, node_depth, left_max)
end

+let remove ?(stop_after_first=true) a avl = raw_remove single_rebalance stop_after_first a avl
+
(*********************************************************************************************************************
* To/From list
********************************************************************************************************************)

let to_list_flatten avl =
fold_inorder (fun acc a -> a::acc) [] avl
+
+(*********************************************************************************************************************
+ * print
+ *
+ * |- 4
+ *   |- 5
+ *   |  |- []
+ *   |  |- []
+ *   |
+ *   |- 9
+        |
+ *
+ ********************************************************************************************************************)
+
+let rec printer print_value prefix avl = match !avl with
+    | Empty ->
+        print_endline (prefix ^ "- []")
+
+    | Node (left_avl, right_avl, depth, a) ->
+        print_endline (prefix ^ "- " ^ print_value a);
+        printer print_value (prefix ^ "  |") right_avl;
+        print_endline (prefix ^ "  |");
+        printer print_value (prefix ^ "   ") left_avl
+
+let printer_int = printer (fun r -> string_of_int !r) ""

# src/Set.ml

let singleton a = AVL.make_leaf a

-let insert a t = AVL.insert false a t
+let insert a t = AVL.insert a t