Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X.
Include Ops I X.
(** Generic definition of binary-search-trees and proofs of specifications for generic functions such as mem or fold. *)
Include MSetGenTree.Props X I.
(** Automation and dedicated tactics *)
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.
(* Sometimes functional induction will expose too much of a tree structure. The following tactic allows factoring back a Node whose internal parts occurs nowhere else. *)
(* TODO: why Ltac instead of Tactic Notation don't work ? why clear ? *)
Tactic Notation "factornode" ident(s) :=
try clear s;
match goal with
| |- context [Node ?l ?x ?r ?h] =>
set (s:=Node l x r h) in *; clearbody s; clear l x r h
| _ : context [Node ?l ?x ?r ?h] |- _ =>
set (s:=Node l x r h) in *; clearbody s; clear l x r h
end.
(** Inductions principles for some of the set operators *)
Functional Scheme bal_ind := Induction for bal Sort Prop.
Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
Functional Scheme merge_ind := Induction for merge Sort Prop.
Functional Scheme concat_ind := Induction for concat Sort Prop.
Functional Scheme inter_ind := Induction for inter Sort Prop.
Functional Scheme diff_ind := Induction for diff Sort Prop.
Functional Scheme union_ind := Induction for union Sort Prop.
(** Notations and helper lemma about pairs and triples *)
Declare Scope pair_scope.
Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope.
Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope.
Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope.
Local Open Scope pair_scope.
(** ** Singleton set *)
Instance singleton_ok x : Ok (singleton x).
(** ** Helper functions *)
Instance create_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
Ok (create l x r).
Instance bal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
Ok (bal l x r).
(** ** Insertion *)
Local Open Scope Int_scope.
(** ** Join *)
(** Function/Functional Scheme can't deal with internal fix. Let's do its job by hand: *)
Ltac join_tac :=
let l := fresh "l" in
intro l; induction l as [| lh ll _ lx lr Hlr];
[ | intros x r; induction r as [| rh rl Hrl rx rr _]; unfold join;
[ | destruct ((rh+2) <? lh) eqn:LT;
[ match goal with |- context b [ bal ?a ?b ?c] =>
replace (bal a b c)
with (bal ll lx (join lr x (Node rh rl rx rr))); [ | auto]
end
| destruct ((lh+2) <? rh) eqn:LT';
[ match goal with |- context b [ bal ?a ?b ?c] =>
replace (bal a b c)
with (bal (join (Node lh ll lx lr) x rl) rx rr); [ | auto]
end
| ] ] ] ]; intros.
Instance join_ok : forall l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r),
Ok (join l x r).
(** ** Extraction of minimum element *)
Instance remove_min_ok l x r : forall h `(Ok (Node h l x r)),
Ok (remove_min l x r)#1.
Local Hint Resolve remove_min_gt_tree : core.
(** ** Merging two trees *)
Instance merge_ok s1 s2 : forall `(Ok s1, Ok s2)
`(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2),
Ok (merge s1 s2).
(** ** Deletion *)
Instance remove_ok s x `(Ok s) : Ok (remove x s).
(** ** Concatenation *)

Lemma concat_spec : forall s1 s2 y,
InT y (concat s1 s2) <-> InT y s1 \/ InT y s2.