Module Type MakeRaw (X:Orders.OrderedType) <: MSetInterface.RawSets X.
Include Ops X.
(** Generic definition of binary-search-trees and proofs of specifications for generic functions such as mem or fold. *)
Include MSetGenTree.Props X Color.
Local Notation Rd := (Node Red).
Local Notation Bk := (Node Black).
Local Hint Immediate MX.eq_sym : core.
Local Hint Unfold In lt_tree gt_tree Ok : core.
Local Hint Constructors InT bst : core.
Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core.
Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core.
Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core.
Local Hint Resolve elements_spec2 : core.
(** ** Singleton set *)
Instance singleton_ok x : Ok (singleton x).
(** ** makeBlack, MakeRed *)
Instance makeBlack_ok s `{Ok s} : Ok (makeBlack s).
Instance makeRed_ok s `{Ok s} : Ok (makeRed s).
(** ** Generic handling for red-matching and red-red-matching *)
Definition isblack t :=
match t with Bk _ _ _ => True | _ => False end.
Definition notblack t :=
match t with Bk _ _ _ => False | _ => True end.
Definition notred t :=
match t with Rd _ _ _ => False | _ => True end.
Definition rcase {A} f g t : A :=
match t with
| Rd a x b => f a x b
| _ => g t
end.
Inductive rspec {A} f g : tree -> A -> Prop :=
| rred a x b : rspec f g (Rd a x b) (f a x b)
| relse t : notred t -> rspec f g t (g t).
Fact rmatch {A} f g t : rspec (A:=A) f g t (rcase f g t).
Definition rrcase {A} f g t : A :=
match t with
| Rd (Rd a x b) y c => f a x b y c
| Rd a x (Rd b y c) => f a x b y c
| _ => g t
end.
Notation notredred := (rrcase (fun _ _ _ _ _ => False) (fun _ => True)).
Inductive rrspec {A} f g : tree -> A -> Prop :=
| rrleft a x b y c : rrspec f g (Rd (Rd a x b) y c) (f a x b y c)
| rrright a x b y c : rrspec f g (Rd a x (Rd b y c)) (f a x b y c)
| rrelse t : notredred t -> rrspec f g t (g t).
Fact rrmatch {A} f g t : rrspec (A:=A) f g t (rrcase f g t).
Definition rrcase' {A} f g t : A :=
match t with
| Rd a x (Rd b y c) => f a x b y c
| Rd (Rd a x b) y c => f a x b y c
| _ => g t
end.
Fact rrmatch' {A} f g t : rrspec (A:=A) f g t (rrcase' f g t).
(** Balancing operations are instances of generic match *)
Fact lbal_match l k r :
rrspec
(fun a x b y c => Rd (Bk a x b) y (Bk c k r))
(fun l => Bk l k r)
l
(lbal l k r).
Fact rbal_match l k r :
rrspec
(fun a x b y c => Rd (Bk l k a) x (Bk b y c))
(fun r => Bk l k r)
r
(rbal l k r).
Fact rbal'_match l k r :
rrspec
(fun a x b y c => Rd (Bk l k a) x (Bk b y c))
(fun r => Bk l k r)
r
(rbal' l k r).
Fact lbalS_match l x r :
rspec
(fun a y b => Rd (Bk a y b) x r)
(fun l =>
match r with
| Bk a y b => rbal' l x (Rd a y b)
| Rd (Bk a y b) z c => Rd (Bk l x a) y (rbal' b z (makeRed c))
| _ => Rd l x r
end)
l
(lbalS l x r).
Fact rbalS_match l x r :
rspec
(fun a y b => Rd l x (Bk a y b))
(fun r =>
match l with
| Bk a y b => lbal (Rd a y b) x r
| Rd a y (Bk b z c) => Rd (lbal (makeRed a) y b) z (Bk c x r)
| _ => Rd l x r
end)
r
(rbalS l x r).
(** ** Balancing for insertion *)
Instance lbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
Ok (lbal l x r).
Instance rbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
Ok (rbal l x r).
Instance rbal'_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
Ok (rbal' l x r).
Hint Rewrite In_node_iff In_leaf_iff
makeRed_spec makeBlack_spec lbal_spec rbal_spec rbal'_spec : rb.
Ltac descolor := destruct_all Color.t.
Ltac destree t := destruct t as [|[|] ? ? ?].
Ltac autorew := autorewrite with rb.
Tactic Notation "autorew" "in" ident(H) := autorewrite with rb in H.
(** ** Insertion *)
Hint Rewrite ins_spec : rb.
Instance ins_ok s x `{Ok s} : Ok (ins x s).
Hint Rewrite add_spec' : rb.
Instance add_ok s x `{Ok s} : Ok (add x s).
(** ** Balancing for deletion *)
Instance lbalS_ok l x r :
forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (lbalS l x r).
Instance rbalS_ok l x r :
forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (rbalS l x r).
Hint Rewrite lbalS_spec rbalS_spec : rb.
(** ** Append for deletion *)
Ltac append_tac l r :=
induction l as [| lc ll _ lx lr IHlr];
[intro r; simpl
|induction r as [| rc rl IHrl rx rr _];
[simpl
|destruct lc, rc;
[specialize (IHlr rl); clear IHrl
|simpl;
assert (Hr:notred (Bk rl rx rr)) by (simpl; trivial);
set (r:=Bk rl rx rr) in *; clearbody r; clear IHrl rl rx rr;
specialize (IHlr r)
|change (append _ _) with (Rd (append (Bk ll lx lr) rl) rx rr);
assert (Hl:notred (Bk ll lx lr)) by (simpl; trivial);
set (l:=Bk ll lx lr) in *; clearbody l; clear IHlr ll lx lr
|specialize (IHlr rl); clear IHrl]]].
Fact append_rr_match ll lx lr rl rx rr :
rspec
(fun a x b => Rd (Rd ll lx a) x (Rd b rx rr))
(fun t => Rd ll lx (Rd t rx rr))
(append lr rl)
(append (Rd ll lx lr) (Rd rl rx rr)).
Fact append_bb_match ll lx lr rl rx rr :
rspec
(fun a x b => Rd (Bk ll lx a) x (Bk b rx rr))
(fun t => lbalS ll lx (Bk t rx rr))
(append lr rl)
(append (Bk ll lx lr) (Bk rl rx rr)).
Hint Rewrite append_spec : rb.

Lemma append_ok : forall x l r `{Ok l, Ok r},
lt_tree x l -> gt_tree x r -> Ok (append l r).