Module BalanceProps(X:Orders.OrderedType)(Import M : MakeRaw X).
Local Notation Rd := (Node Red).
Local Notation Bk := (Node Black).
(** ** Red-Black invariants *)
(** In a red-black tree : - a red node has no red children - the black depth at each node is the same along all paths. The black depth is here an argument of the predicate. *)
Inductive rbt : nat -> tree -> Prop :=
| RB_Leaf : rbt 0 Leaf
| RB_Rd n l k r :
notred l -> notred r -> rbt n l -> rbt n r -> rbt n (Rd l k r)
| RB_Bk n l k r : rbt n l -> rbt n r -> rbt (S n) (Bk l k r).
(** A red-red tree is almost a red-black tree, except that it has a _red_ root node which _may_ have red children. Note that a red-red tree is hence non-empty, and all its strict subtrees are red-black. *)
Inductive rrt (n:nat) : tree -> Prop :=
| RR_Rd l k r : rbt n l -> rbt n r -> rrt n (Rd l k r).
(** An almost-red-black tree is almost a red-black tree, except that it's permitted to have two red nodes in a row at the very root (only). We implement this notion by saying that a quasi-red-black tree is either a red-black tree or a red-red tree. *)
Inductive arbt (n:nat)(t:tree) : Prop :=
| ARB_RB : rbt n t -> arbt n t
| ARB_RR : rrt n t -> arbt n t.
(** The main exported invariant : being a red-black tree for some black depth. *)
Class Rbt (t:tree) :=  RBT : exists d, rbt d t.
(** ** Basic tactics and results about red-black *)
Scheme rbt_ind := Induction for rbt Sort Prop.
Local Hint Constructors rbt rrt arbt : core.
Local Hint Extern 0 (notred _) => (exact I) : core.
Ltac invrb := intros; invtree rrt; invtree rbt; try contradiction.
Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end.
Ltac nonzero n := destruct n as [|n]; [try split; invrb|].
Local Hint Resolve rr_nrr_rb : core.
Local Hint Resolve arb_nrr_rb arb_nr_rb : core.
(** ** A Red-Black tree has indeed a logarithmic depth *)
Definition redcarac s := rcase (fun _ _ _ => 1) (fun _ => 0) s.
(** ** Singleton *)
(** ** [makeBlack] and [makeRed] *)
(** ** Balancing *)
(** ** Insertion *)
(** The next lemmas combine simultaneous results about rbt and arbt. A first solution here: statement with [if ... then ... else] *)
Definition ifred s (A B:Prop) := rcase (fun _ _ _ => A) (fun _ => B) s.
Instance add_rb x s : Rbt s -> Rbt (add x s).
(** ** Deletion *)
(** A second approach here: statement with ... /\ ... *)
(** A third approach : Lemma ... with ... *)
Instance remove_rb s x : Rbt s -> Rbt (remove x s).
(** ** Treeify *)
Definition treeify_rb_invariant size depth (f:treeify_t) :=
forall acc,
size <= length acc ->
rbt depth (fst (f acc)) /\
size + length (snd (f acc)) = length acc.
(** The black depth of [treeify l] is actually a log2, but we don't need to mention that. *)
Instance treeify_rb l : Rbt (treeify l).
(** ** Filtering *)
Instance filter_rb f s : Rbt (filter f s).
Instance partition_rb1 f s : Rbt (fst (partition f s)).
Instance partition_rb2 f s : Rbt (snd (partition f s)).
(** ** Union, intersection, difference *)
Instance fold_add_rb s1 s2 : Rbt s2 -> Rbt (fold add s1 s2).
Instance fold_remove_rb s1 s2 : Rbt s2 -> Rbt (fold remove s1 s2).

Lemma union_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (union s1 s2).