(************************************************************************)
(*         *      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)         *)
(************************************************************************)
(** Efficient implementation of [MSetInterface.S] for positive keys, inspired from the [FMapPositive] module.  This module was adapted by Alexandre Ren, Damien Pous, and Thomas Braibant (2010, LIG, CNRS, UMR 5217), from the [FMapPositive] module of Pierre Letouzey and Jean-Christophe Filliâtre, which in turn comes from the [FMap] framework of a work by Xavier Leroy and Sandrine Blazy (used for building certified compilers). *)
Set Implicit Arguments.
Local Open Scope lazy_bool_scope.
Local Open Scope positive_scope.
Local Unset Elimination Schemes.
Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
Module E:=PositiveOrderedTypeBits.
Definition elt := positive : Type.
Inductive tree :=
| Leaf : tree
| Node : tree -> bool -> tree -> tree.
Scheme tree_ind := Induction for tree Sort Prop.
Definition t := tree : Type.
Definition empty : t := Leaf.
Fixpoint is_empty (m : t) : bool :=
match m with
| Leaf => true
| Node l b r => negb b &&& is_empty l &&& is_empty r
end.
Fixpoint mem (i : positive) (m : t) {struct m} : bool :=
match m with
| Leaf => false
| Node l o r =>
match i with
| 1 => o
| i~0 => mem i l
| i~1 => mem i r
end
end.
Fixpoint add (i : positive) (m : t) : t :=
match m with
| Leaf =>
match i with
| 1 => Node Leaf true Leaf
| i~0 => Node (add i Leaf) false Leaf
| i~1 => Node Leaf false (add i Leaf)
end
| Node l o r =>
match i with
| 1 => Node l true r
| i~0 => Node (add i l) o r
| i~1 => Node l o (add i r)
end
end.
Definition singleton i := add i empty.
(** helper function to avoid creating empty trees that are not leaves *)
Definition node (l : t) (b: bool) (r : t) : t :=
if b then Node l b r else
match l,r with
| Leaf,Leaf => Leaf
| _,_ => Node l false r end.
Fixpoint remove (i : positive) (m : t) {struct m} : t :=
match m with
| Leaf => Leaf
| Node l o r =>
match i with
| 1 => node l false r
| i~0 => node (remove i l) o r
| i~1 => node l o (remove i r)
end
end.
Fixpoint union (m m': t) : t :=
match m with
| Leaf => m'
| Node l o r =>
match m' with
| Leaf => m
| Node l' o' r' => Node (union l l') (o||o') (union r r')
end
end.
Fixpoint inter (m m': t) : t :=
match m with
| Leaf => Leaf
| Node l o r =>
match m' with
| Leaf => Leaf
| Node l' o' r' => node (inter l l') (o&&o') (inter r r')
end
end.
Fixpoint diff (m m': t) : t :=
match m with
| Leaf => Leaf
| Node l o r =>
match m' with
| Leaf => m
| Node l' o' r' => node (diff l l') (o&&negb o') (diff r r')
end
end.
Fixpoint equal (m m': t): bool :=
match m with
| Leaf => is_empty m'
| Node l o r =>
match m' with
| Leaf => is_empty m
| Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r'
end
end.
Fixpoint subset (m m': t): bool :=
match m with
| Leaf => true
| Node l o r =>
match m' with
| Leaf => is_empty m
| Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r'
end
end.
(** reverses [y] and concatenate it with [x] *)
Fixpoint rev_append (y x : elt) : elt :=
match y with
| 1 => x
| y~1 => rev_append y x~1
| y~0 => rev_append y x~0
end.
Infix "@" := rev_append (at level 60).
Definition rev x := x@1.
Section Fold.
Variables B : Type.
Variable f : positive -> B -> B.
(** the additional argument, [i], records the current path, in reverse order (this should be more efficient: we reverse this argument only at present nodes only, rather than at each node of the tree). we also use this convention in all functions below *)
Fixpoint xfold (m : t) (v : B) (i : positive) :=
match m with
| Leaf => v
| Node l true r =>
xfold r (f (rev i) (xfold l v i~0)) i~1
| Node l false r =>
xfold r (xfold l v i~0) i~1
end.
Definition fold m i := xfold m i 1.
End Fold.
Section Quantifiers.
Variable f : positive -> bool.
Fixpoint xforall (m : t) (i : positive) :=
match m with
| Leaf => true
| Node l o r =>
(negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0
end.
Definition for_all m := xforall m 1.
Fixpoint xexists (m : t) (i : positive) :=
match m with
| Leaf => false
| Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0
end.
Definition exists_ m := xexists m 1.
Fixpoint xfilter (m : t) (i : positive) : t :=
match m with
| Leaf => Leaf
| Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1)
end.
Definition filter m := xfilter m 1.
Fixpoint xpartition (m : t) (i : positive) : t * t :=
match m with
| Leaf => (Leaf,Leaf)
| Node l o r =>
let (lt,lf) := xpartition l i~0 in
let (rt,rf) := xpartition r i~1 in
if o then
let fi := f (rev i) in
(node lt fi rt, node lf (negb fi) rf)
else
(node lt false rt, node lf false rf)
end.
Definition partition m := xpartition m 1.
End Quantifiers.
(** uses [a] to accumulate values rather than doing a lot of concatenations *)
Fixpoint xelements (m : t) (i : positive) (a: list positive) :=
match m with
| Leaf => a
| Node l false r => xelements l i~0 (xelements r i~1 a)
| Node l true r => xelements l i~0 (rev i :: xelements r i~1 a)
end.
Definition elements (m : t) := xelements m 1 nil.
Fixpoint cardinal (m : t) : nat :=
match m with
| Leaf => O
| Node l false r => (cardinal l + cardinal r)%nat
| Node l true r => S (cardinal l + cardinal r)
end.
(** would it be more efficient to use a path like in the above functions ? *)
Fixpoint choose (m: t) : option elt :=
match m with
| Leaf => None
| Node l o r => if o then Some 1 else
match choose l with
| None => option_map xI (choose r)
| Some i => Some i~0
end
end.
Fixpoint min_elt (m: t) : option elt :=
match m with
| Leaf => None
| Node l o r =>
match min_elt l with
| None => if o then Some 1 else option_map xI (min_elt r)
| Some i => Some i~0
end
end.
Fixpoint max_elt (m: t) : option elt :=
match m with
| Leaf => None
| Node l o r =>
match max_elt r with
| None => if o then Some 1 else option_map xO (max_elt l)
| Some i => Some i~1
end
end.
(** lexicographic product, defined using a notation to keep things lazy *)
Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end.
Definition compare_bool a b :=
match a,b with
| false, true => Lt
| true, false => Gt
| _,_ => Eq
end.
Fixpoint compare (m m': t): comparison :=
match m,m' with
| Leaf,_ => if is_empty m' then Eq else Lt
| _,Leaf => if is_empty m then Eq else Gt
| Node l o r,Node l' o' r' =>
lex (compare_bool o o') (lex (compare l l') (compare r r'))
end.
Definition In i t := mem i t = true.
Definition Equal s s' := forall a : elt, In a  s <-> In a  s'.
Definition Subset s s' := forall a : elt, In a s -> In a s'.
Definition Empty s := forall a : elt, ~ In a s.
Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).
Definition eq := Equal.
Definition lt m m' := compare m m' = Lt.
(** Specification of [In] *)
#[global]
Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In.
(** Specification of [eq] *)
Local Instance eq_equiv : Equivalence eq.
Local Opaque node.
(** Specification of [is_empty] *)

(* Specifications: *)
Lemma is_empty_spec: forall s, is_empty s = true <-> Empty s.
(** Specification of [subset] *)
Lemma subset_Leaf_s: forall s, Leaf [<=] s.
(** Specification of [equal] (via subset) *)
Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s.
Lemma equal_spec: forall s s', equal s s' = true <-> Equal s s'.
Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }.
Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq.
Lemma compare_gt: forall s s', compare s s' = Gt -> lt s' s.
Lemma compare_eq: forall s s', compare s s' = Eq -> eq s s'.
Lemma compare_spec : forall s s' : t, CompSpec eq lt s s' (compare s s').
Section lt_spec.