(************************************************************************)
(*         *      The Rocq Prover / The Rocq Development Team           *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(** * MSetGenTree : sets via generic trees  This module factorizes common parts in implementations of finite sets as AVL trees and as Red-Black trees. The nodes of the trees defined here include an generic information parameter, that will be the height in AVL trees and the color in Red-Black trees. Without more details here about these information parameters, trees here are not known to be well-balanced, but simply binary-search-trees.  The operations we could define and prove correct here are the one that do not build non-empty trees, but only analyze them :  - empty is_empty - mem - compare equal subset - fold cardinal elements - for_all exists_ - min_elt max_elt choose *)
Require Arith. (* contains deprecated dependencies *)
Local Open Scope list_scope.
Local Open Scope lazy_bool_scope.
(* For nicer extraction, we create induction principles only when needed *)
Local Unset Elimination Schemes.
Module Type InfoTyp.
Parameter t : Set.
End InfoTyp.
(** * Ops : the pure functions *)
Module Type Ops (X:OrderedType)(Info:InfoTyp).
Definition elt := X.t.
#[global]
Hint Transparent elt : core.
Inductive tree  : Type :=
| Leaf : tree
| Node : Info.t -> tree -> X.t -> tree -> tree.
(** ** The empty set and emptyness test *)
Definition empty := Leaf.
Definition is_empty t :=
match t with
| Leaf => true
| _ => false
end.
(** ** Membership test *)
(** The [mem] function is deciding membership. It exploits the binary search tree invariant to achieve logarithmic complexity. *)
Fixpoint mem x t :=
match t with
| Leaf => false
| Node _ l k r =>
match X.compare x k with
| Lt => mem x l
| Eq => true
| Gt => mem x r
end
end.
(** ** Minimal, maximal, arbitrary elements *)
Fixpoint min_elt (t : tree) : option elt :=
match t with
| Leaf => None
| Node _ Leaf x r => Some x
| Node _ l x r => min_elt l
end.
Fixpoint max_elt (t : tree) : option elt :=
match t with
| Leaf => None
| Node _ l x Leaf => Some x
| Node _ l x r => max_elt r
end.
Definition choose := min_elt.
(** ** Iteration on elements *)
Fixpoint fold {A: Type} (f: elt -> A -> A) (t: tree) (base: A) : A :=
match t with
| Leaf => base
| Node _ l x r => fold f r (f x (fold f l base))
end.
Fixpoint elements_aux acc s :=
match s with
| Leaf => acc
| Node _ l x r => elements_aux (x :: elements_aux acc r) l
end.
Definition elements := elements_aux nil.
Fixpoint rev_elements_aux acc s :=
match s with
| Leaf => acc
| Node _ l x r => rev_elements_aux (x :: rev_elements_aux acc l) r
end.
Definition rev_elements := rev_elements_aux nil.
Fixpoint cardinal (s : tree) : nat :=
match s with
| Leaf => 0
| Node _ l _ r => S (cardinal l + cardinal r)
end.
Fixpoint maxdepth s :=
match s with
| Leaf => 0
| Node _ l _ r => S (max (maxdepth l) (maxdepth r))
end.
Fixpoint mindepth s :=
match s with
| Leaf => 0
| Node _ l _ r => S (min (mindepth l) (mindepth r))
end.
(** ** Testing universal or existential properties. *)
(** We do not use the standard boolean operators of Coq, but lazy ones. *)
Fixpoint for_all (f:elt->bool) s := match s with
| Leaf => true
| Node _ l x r => f x &&& for_all f l &&& for_all f r
end.
Fixpoint exists_ (f:elt->bool) s := match s with
| Leaf => false
| Node _ l x r => f x ||| exists_ f l ||| exists_ f r
end.
(** ** Comparison of trees *)
(** The algorithm here has been suggested by Xavier Leroy, and transformed into c.p.s. by Benjamin Grégoire. The original ocaml code (with non-structural recursive calls) has also been formalized (thanks to Function+measure), see [ocaml_compare] in [MSetFullAVL]. The following code with continuations computes dramatically faster in Coq, and should be almost as efficient after extraction. *)
(** Enumeration of the elements of a tree. This corresponds to the "samefringe" notion in the literature. *)
Inductive enumeration :=
| End : enumeration
| More : elt -> tree -> enumeration -> enumeration.
(** [cons t e] adds the elements of tree [t] on the head of enumeration [e]. *)
Fixpoint cons s e : enumeration :=
match s with
| Leaf => e
| Node _ l x r => cons l (More x r e)
end.
(** One step of comparison of elements *)
Definition compare_more x1 (cont:enumeration->comparison) e2 :=
match e2 with
| End => Gt
| More x2 r2 e2 =>
match X.compare x1 x2 with
| Eq => cont (cons r2 e2)
| Lt => Lt
| Gt => Gt
end
end.
(** Comparison of left tree, middle element, then right tree *)
Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 :=
match s1 with
| Leaf => cont e2
| Node _ l1 x1 r1 =>
compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
end.
(** Initial continuation *)
Definition compare_end e2 :=
match e2 with End => Eq | _ => Lt end.
(** The complete comparison *)
Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).
Definition equal s1 s2 :=
match compare s1 s2 with Eq => true | _ => false end.
(** ** Subset test *)
(** In ocaml, recursive calls are made on "half-trees" such as (Node _ l1 x1 Leaf) and (Node _ Leaf x1 r1). Instead of these non-structural calls, we propose here two specialized functions for these situations. This version should be almost as efficient as the one of ocaml (closures as arguments may slow things a bit), it is simply less compact. The exact ocaml version has also been formalized (thanks to Function+measure), see [ocaml_subset] in [MSetFullAVL]. *)
Fixpoint subsetl (subset_l1 : tree -> bool) x1 s2 : bool :=
match s2 with
| Leaf => false
| Node _ l2 x2 r2 =>
match X.compare x1 x2 with
| Eq => subset_l1 l2
| Lt => subsetl subset_l1 x1 l2
| Gt => mem x1 r2 &&& subset_l1 s2
end
end.
Fixpoint subsetr (subset_r1 : tree -> bool) x1 s2 : bool :=
match s2 with
| Leaf => false
| Node _ l2 x2 r2 =>
match X.compare x1 x2 with
| Eq => subset_r1 r2
| Lt => mem x1 l2 &&& subset_r1 s2
| Gt => subsetr subset_r1 x1 r2
end
end.
Fixpoint subset s1 s2 : bool := match s1, s2 with
| Leaf, _ => true
| Node _ _ _ _, Leaf => false
| Node _ l1 x1 r1, Node _ l2 x2 r2 =>
match X.compare x1 x2 with
| Eq => subset l1 l2 &&& subset r1 r2
| Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2
| Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2
end
end.
End Ops.
(** * Props : correctness proofs of these generic operations *)
Module Type Props (X:OrderedType)(Info:InfoTyp)(Import M:Ops X Info).
(** ** Occurrence in a tree *)
Inductive InT (x : elt) : tree -> Prop :=
| IsRoot : forall c l r y, X.eq x y -> InT x (Node c l y r)
| InLeft : forall c l r y, InT x l -> InT x (Node c l y r)
| InRight : forall c l r y, InT x r -> InT x (Node c l y r).
Definition In := InT.
(** ** Some shortcuts *)
Definition Equal s s' := forall a : elt, InT a s <-> InT a s'.
Definition Subset s s' := forall a : elt, InT a s -> InT a s'.
Definition Empty s := forall a : elt, ~ InT a s.
Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x.
Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x.
(** ** Binary search trees *)
(** [lt_tree x s]: all elements in [s] are smaller than [x] (resp. greater for [gt_tree]) *)
Definition lt_tree x s := forall y, InT y s -> X.lt y x.
Definition gt_tree x s := forall y, InT y s -> X.lt x y.
(** [bst t] : [t] is a binary search tree *)
Inductive bst : tree -> Prop :=
| BSLeaf : bst Leaf
| BSNode : forall c x l r, bst l -> bst r ->
lt_tree x l -> gt_tree x r -> bst (Node c l x r).
(** [bst] is the (decidable) invariant our trees will have to satisfy. *)
Definition IsOk := bst.
Class Ok (s:tree) : Prop := ok : bst s.
#[global]
Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }.
Fixpoint ltb_tree x s :=
match s with
| Leaf => true
| Node _ l y r =>
match X.compare x y with
| Gt => ltb_tree x l && ltb_tree x r
| _ => false
end
end.
Fixpoint gtb_tree x s :=
match s with
| Leaf => true
| Node _ l y r =>
match X.compare x y with
| Lt => gtb_tree x l && gtb_tree x r
| _ => false
end
end.
Fixpoint isok s :=
match s with
| Leaf => true
| Node _  l x r => isok l && isok r && ltb_tree x l && gtb_tree x r
end.
(** ** Known facts about ordered types *)
Module Import MX := OrderedTypeFacts X.
(** ** Automation and dedicated tactics *)
Scheme tree_ind := Induction for tree Sort Prop.
Scheme bst_ind := Induction for bst Sort Prop.
Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core.
Local Hint Immediate MX.eq_sym : core.
Local Hint Unfold In lt_tree gt_tree : core.
Local Hint Constructors InT bst : core.
Local Hint Unfold Ok : core.
(** Automatic treatment of [Ok] hypothesis *)
Ltac clear_inversion H := inversion H; clear H; subst.
Ltac inv_ok := match goal with
| H:Ok (Node _ _ _ _) |- _ => clear_inversion H; inv_ok
| H:Ok Leaf |- _ => clear H; inv_ok
| H:bst ?x |- _ => change (Ok x) in H; inv_ok
| _ => idtac
end.
(** A tactic to repeat [inversion_clear] on all hyps of the form [(f (Node _ _ _ _))] *)
Ltac is_tree_constr c :=
match c with
| Leaf => idtac
| Node _ _ _ _ => idtac
| _ => fail
end.
Ltac invtree f :=
match goal with
| H:f ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
| H:f _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
| H:f _ _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
| _ => idtac
end.
Ltac inv := inv_ok; invtree InT.
Ltac intuition_in := repeat (intuition auto; inv).
(** Helper tactic concerning order of elements. *)
Ltac order := match goal with
| U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
| U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
| _ => MX.order
end.
(** [isok] is indeed a decision procedure for [Ok] *)

(* Specifications: *)
Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true.
Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true.
Lemma isok_iff : forall s, Ok s <-> isok s = true.
#[global]
Instance isok_Ok s : isok s = true -> Ok s | 10.