Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
643e56c7
Commit
643e56c7
authored
Apr 27, 2021
by
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
Changes
4
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
lang/typing/patterns.ml
View file @
643e56c7
...
...
@@ -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
...
...
tests/full/good/dune.auto
View file @
643e56c7
...
...
@@ -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)
))
old/
tests/
poly
/red-black.cd
→
tests/
full/good
/red-black.cd
View file @
643e56c7
...
...
@@ -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
tests/full/good/red-black.exp
0 → 100644
View file @
643e56c7
1
4
10
17
100
300
24424
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment