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.
(** ** Deletion *)
Hint Rewrite del_spec : rb.
Instance del_ok s x `{Ok s} : Ok (del x s).
Hint Rewrite remove_spec : rb.
Instance remove_ok s x `{Ok s} : Ok (remove x s).
(** ** Removing the minimal element *)
(** ** Treeify *)
Notation ifpred p n := (if p then pred n else n%nat).
Definition treeify_invariant size (f:treeify_t) :=
forall acc,
size <= length acc ->
let (t,acc') := f acc in
cardinal t = size /\ acc = elements t ++ acc'.
(** ** Filter *)
Instance filter_ok s f `(Ok s) : Ok (filter f s).
(** ** Partition *)
(** ** union *)
Instance linear_union_ok s1 s2 `(Ok s1, Ok s2) :
Ok (linear_union s1 s2).
Instance fold_add_ok s1 s2 `(Ok s1, Ok s2) :
Ok (fold add s1 s2).
Instance union_ok s1 s2 `(Ok s1, Ok s2) : Ok (union s1 s2).
(** ** inter *)
Instance linear_inter_ok s1 s2 `(Ok s1, Ok s2) :
Ok (linear_inter s1 s2).
Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2).
Local Instance mem_proper s `(Ok s) :
Proper (X.eq ==> Logic.eq) (fun k => mem k s).
(** ** difference *)
Instance diff_inter_ok s1 s2 `(Ok s1, Ok s2) :
Ok (linear_diff s1 s2).
Instance fold_remove_ok s1 s2 `(Ok s2) :
Ok (fold remove s1 s2).
Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2).

Lemma fold_remove_spec s1 s2 x `(Ok s2) :
InT x (fold remove s1 s2) <-> InT x s2 /\ ~InT x s1.