Paweł Wieczorek avatar Paweł Wieczorek committed 6700f75 Draft

Balancing is working

Comments (0)

Files changed (2)

     = '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) "" 
 
 let singleton a = AVL.make_leaf a
 
-let insert a t = AVL.insert false a t
+let insert a t = AVL.insert a t
 
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.