Commit 643e56c7 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Add the red-black tree test case (works until deletion which does not type).

parent 16c128d2
Pipeline #170 passed with stages
in 8 minutes and 10 seconds
......@@ -1154,13 +1154,7 @@ module Compile = struct
aux success (Types.diff t ty) rem
in
aux [] t tests;
List.map
(fun (t, a) ->
let ct = (* TODO CHECK THAT THIS IS CORRECT W.R.T static semantics. *)
Types.Subst.clean_type ~pos:Types.any ~neg:Types.empty Var.Set.empty t
in
(ct, a))
!accu
!accu
let get_tests facto pl f t d post =
let pl = Array.map (List.map f) pl in
......
......@@ -54,6 +54,14 @@
(rule (alias poly-ok) (action (diff poly-ok.exp poly-ok.out)))
; end: poly-ok.cd
; begin: red-black.cd
(rule (deps red-black.cd) (target red-black.cdo)
(action (ignore-outputs (with-accepted-exit-codes 0 (run cduce --compile %{deps})))))
(rule (deps red-black.cdo) (target red-black.out)
(action (ignore-stderr (with-stdout-to %{target} (with-accepted-exit-codes 0 (run cduce --run %{deps}))))))
(rule (alias red-black) (action (diff red-black.exp red-black.out)))
; end: red-black.cd
; begin: web_site.cd
(rule (deps web_site.cd) (target web_site.cdo)
(action (ignore-outputs (with-accepted-exit-codes 0 (run cduce --compile %{deps})))))
......@@ -72,5 +80,6 @@
(alias overloading)
(alias patricia)
(alias poly-ok)
(alias red-black)
(alias web_site)
))
......@@ -20,7 +20,7 @@ type Unbalanced('a) = <black elem='a>( [ Wrongtree ('a) RBtree('a) ]
************)
let balance ( Unbalanced('a) -> Rtree('a) ; 'b \Unbalanced('a) -> 'b\Unbalanced('a) )
let balance ( Unbalanced('a) -> Rtree('a) ; ('b \Unbalanced(Any)) -> ('b\Unbalanced(Any)) )
| <black (z)>[ <red (y)>[ <red (x)>[ a b ] c ] d ]
| <black (z)>[ <red (x)>[ a <red (y)>[ b c ] ] d ]
| <black (x)>[ a <red (z)>[ <red (y)>[ b c ] d ] ]
......@@ -92,69 +92,80 @@ let insert (x : 'a) (t : Btree('a)) : Btree('a)\[]=
Rtree('a) -> Rtree('a)|Wrongtree('a) )
| [] -> <red elem=x>[ [] [] ]
| (<(color) elem=y>[ a b ]) & z ->
if x << y then balance <(color) elem=y>[ (ins_aux a) b ]
if x << y then
balance <(color) elem=y>[ (ins_aux a) b ]
else if x >> y then balance <(color) elem=y>[ a (ins_aux b) ]
else z
in match ins_aux t with
| <_ (y)>[ a b ] -> <black (y)>[ a b ]
;;
/*
let is_empty ([] -> `true; Any \ [] -> `false) (*better type (Any\[] -> `false ; [] ->`true ) *)
| [] -> `true
| _ -> `false
let member (x : 'a) (t : RBtree('a)) : Bool =
(* better type: 'a -> ([] -> `false) & (RBtree('a) -> Bool) *)
let iter (f : 'a -> []) (t : RBtree('a)) : [] =
match t with
| [] -> `false
| <_ elem=y>[ left right ] ->
(y = x) || ( member x (if x<<y then left else right) )
[] -> []
| < _ elem=x>[t1 t2] -> iter f t1;f x; iter f t2
;;
let member
('a -> [] -> `false; 'a -> RBtree ('a) -> Bool) x ->
(fun ([] -> `false; RBtree ('a) -> Bool)
[] -> `false
| <_ elem=y>[ left right ] ->
(y = x) || ( member x (if x<<y then left else right)))
let singleton (x : 'a): Btree('a) = <black elem=x>[ [] [] ]
let cardinal ( RBtree('a) -> Int ) (* better type: [] -> 0, Any\[] -> [1--*] *)
let cardinal ([] -> 0; RBtree('a) \ [] -> 1--*)
| [] -> 0
| <_ ..>[ l r ] -> cardinal l + cardinal r + 1
/*
(* The though case: deletion *)
(* remove the rightmost leave of the tree and return a flag to state
whether the resulting tree decreased the the depth of black nodes *)
let remove_min (RBtree('a)\[] -> [RBtree('a) Bool 'a])
(* black leaf: remove it and flag the depth decrease *)
| <black elem=x>[ [] [] ] ->
[ [] `true x ]
(* black node with red child: promote the child to black *)
| <black elem=x>[ ([] <red elem=y>[ l r ])
| (<red elem=y>[ l r ] [] )] ->
[ <black elem=y>[ l r ] `false x ]
(* you cannot have a red node with one empty sibling *)
| <black elem=Any>[ ([] <red ..>Any)
| (<red ..>Any []) ] ->
raise "impossible"
(* red node with at least on empty child : remove it without any flag *)
| <red elem=x>[ ([] n) | (n []) ] ->
[ n `false x ]
(* general case of a node with two non empty childs *)
| <(c) elem=x>[ l\[] r\[] ] ->
let [ ll d e ] = remove_min l in
let tree = <(c) elem=x>[ ll r ] in
if d then
(bubble_left tree)@[e]
else
[ tree `false e ]
| _ -> raise "impossible"
let blackify( (<_ ('a)>'b) -> <black ('a)>'b )
| <_ (x)>y -> <black (x)>y
let redify( (<_ ('a)>'b) -> <red ('a)>'b )
| <_ (x)>y -> <red (x)>y
let remove_min (RBtree('a)\[] -> [RBtree('a) Bool 'a])
(* black leaf: remove it and flag the depth decrease *)
| <black elem=x>[ [] [] ] ->
[ [] `true x ]
(* black node with red child: promote the child to black *)
| <black elem=x>[ ([] <red elem=y>[ l r ])
| (<red elem=y>[ l r ] [] )] ->
[ <black elem=y>[ l r ] `false x ]
(* you cannot have a red node with one empty sibling *)
| <black elem=Any>[ ([] <red ..>Any)
| (<red ..>Any []) ] ->
raise "impossible"
(* red node with at least on empty child : remove it without any flag *)
| <red elem=x>[ ([] n) | (n []) ] ->
[ n `false x ]
(* general case of a node with two non empty childs *)
| <(c) elem=x>[ l\[] r\[] ] ->
let [ ll d e ] = remove_min l in
let tree = <(c) elem=x>[ ll r ] in
if d then
(bubble_left tree)@[e]
else
[ tree `false e ]
| _ -> raise "impossible"
let blackify( (<_ ('a)>'b) -> <black ('a)>'b )
| <_ (x)>y -> <black (x)>y
let redify( (<_ ('a)>'b) -> <red ('a)>'b )
| <_ (x)>y -> <red (x)>y
......@@ -209,4 +220,13 @@ let remove(x : 'a)(t : RBtree('a) ) : RBtree('a) =
if d then bubble_left tree else (tree, `false)
in
let (sol,_) = remove_aux t in sol
*/
*/
let [] =
let t = ref (Btree(Int)) [] in
let [] =
transform [ 100 10 1 300 4 24424 17 ] with
x -> t := insert x !t
in
iter (fun (Int -> []) x -> print [ !(string_of x) '\n']) !t
1
4
10
17
100
300
24424
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment