Require Import SetInterface SetFacts SetDecide.
Set Implicit Arguments.
Unset Strict Implicit.

Generalizable All Variables.
Local Open Scope set_scope.

(** This file corresponds to [FSetProperties.v] in the standard
   library and provides the same results for the typeclass-based
   version.
   *)
Hint Unfold transpose compat_op.

Lemma In_dec : forall `{HF : @FSetSpecs A HA F}
  x s, {In x s} + {~ In x s}.
Proof.
  intros; generalize (mem_iff s x); case (mem x s); intuition.
Qed.

Definition Add `{HF : @FSetSpecs A HA F} x s s' :=
  forall y, In y s' <-> x === y \/ In y s.

Lemma Add_Equal `{HF : @FSetSpecs A HA F} :
  forall x s s', Add x s s' <-> s' [=] add x s.
Proof.
  unfold Add.
  split; intros.
  red; intros.
  rewrite H; clear H.
  fsetdec.
  fsetdec.
Qed.

Ltac expAdd := repeat rewrite Add_Equal; intros.

Section BasicProperties.
  Context `{HF : @FSetSpecs elt Helt F}.
  Variable s s' s'' s1 s2 s3 : set elt.
  Variable x x' : elt.

  Lemma equal_refl : s[=]s.
  Proof. fsetdec. Qed.

  Lemma equal_sym : s[=]s' -> s'[=]s.
  Proof. fsetdec. Qed.

  Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3.
  Proof. fsetdec. Qed.

  Lemma subset_refl : s[<=]s.
  Proof. fsetdec. Qed.

  Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
  Proof. fsetdec. Qed.

  Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
  Proof. fsetdec. Qed.

  Lemma subset_equal : s[=]s' -> s[<=]s'.
  Proof. fsetdec. Qed.

  Lemma subset_empty : empty[<=]s.
  Proof. fsetdec. Qed.

  Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2.
  Proof. fsetdec. Qed.

  Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
  Proof. fsetdec. Qed.

  Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2.
  Proof. fsetdec. Qed.

  Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2.
  Proof. fsetdec. Qed.

  Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
  Proof. fsetdec. Qed.

  Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
  Proof. intuition fsetdec. Qed.

  Lemma empty_is_empty_1 : Empty s -> s[=]empty.
  Proof. fsetdec. Qed.

  Lemma empty_is_empty_2 : s[=]empty -> Empty s.
  Proof. fsetdec. Qed.

  Lemma add_equal : In x s -> add x s [=] s.
  Proof. fsetdec. Qed.

  Lemma add_add : add x (add x' s) [=] add x' (add x s).
  Proof. fsetdec. Qed.

  Lemma remove_equal : ~ In x s -> remove x s [=] s.
  Proof. fsetdec. Qed.

  Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'.
  Proof. fsetdec. Qed.

  Lemma add_remove : In x s -> add x (remove x s) [=] s.
  Proof. fsetdec. Qed.

  Lemma remove_add : ~In x s -> remove x (add x s) [=] s.
  Proof. fsetdec. Qed.

  Lemma singleton_equal_add : singleton x [=] add x empty.
  Proof. fsetdec. Qed.

  Lemma remove_singleton_empty :
    In x s -> remove x s [=] empty -> singleton x [=] s.
  Proof. fsetdec. Qed. (** Bizarrement long ! *)

  Lemma union_sym : union s s' [=] union s' s.
  Proof. fsetdec. Qed.

  Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'.
  Proof. fsetdec. Qed.

  Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
  Proof. fsetdec. Qed.

  Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
  Proof. fsetdec. Qed.

  Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
  Proof. fsetdec. Qed.

  Lemma add_union_singleton : add x s [=] union (singleton x) s.
  Proof. fsetdec. Qed.

  Lemma union_add : union (add x s) s' [=] add x (union s s').
  Proof. fsetdec. Qed.

  Lemma union_remove_add_1 :
    union (remove x s) (add x s') [=] union (add x s) (remove x s').
  Proof. fsetdec. Qed.

  Lemma union_remove_add_2 :
    In x s -> union (remove x s) (add x s') [=] union s s'.
  Proof. fsetdec. Qed.

  Lemma union_subset_1 : s [<=] union s s'.
  Proof. fsetdec. Qed.

  Lemma union_subset_2 : s' [<=] union s s'.
  Proof. fsetdec. Qed.

  Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''.
  Proof. fsetdec. Qed.

  Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
  Proof. fsetdec. Qed.

  Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
  Proof. fsetdec. Qed.

  Lemma empty_union_1 : Empty s -> union s s' [=] s'.
  Proof. fsetdec. Qed.

  Lemma empty_union_2 : Empty s -> union s' s [=] s'.
  Proof. fsetdec. Qed.

  Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s').
  Proof. fsetdec. Qed.

  Lemma inter_sym : inter s s' [=] inter s' s.
  Proof. fsetdec. Qed.

  Lemma inter_subset_equal : forall s s', s[<=]s' -> inter s s' [=] s.
  Proof. fsetdec. Qed.

  Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
  Proof. fsetdec. Qed.

  Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
  Proof. fsetdec. Qed.

  Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
  Proof. fsetdec. Qed.

  Lemma union_inter_1 :
      inter (union s s') s'' [=] union (inter s s'') (inter s' s'').
  Proof. fsetdec. Qed.

  Lemma union_inter_2 :
      union (inter s s') s'' [=] inter (union s s'') (union s' s'').
  Proof. fsetdec. Qed.

  Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s').
  Proof. fsetdec. Qed.

  Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'.
  Proof. fsetdec. Qed.

  Lemma empty_inter_1 : Empty s -> Empty (inter s s').
  Proof. fsetdec. Qed.

  Lemma empty_inter_2 : Empty s' -> Empty (inter s s').
  Proof. fsetdec. Qed.

  Lemma inter_subset_1 : inter s s' [<=] s.
  Proof. fsetdec. Qed.

  Lemma inter_subset_2 : inter s s' [<=] s'.
  Proof. fsetdec. Qed.

  Lemma inter_subset_3 : s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'.
  Proof. fsetdec. Qed.

  Lemma empty_diff_1 : Empty s -> Empty (diff s s').
  Proof. fsetdec. Qed.

  Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
  Proof. fsetdec. Qed.

  Lemma diff_subset : diff s s' [<=] s.
  Proof. fsetdec. Qed.

  Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty.
  Proof. fsetdec. Qed.

  Lemma remove_diff_singleton : remove x s [=] diff s (singleton x).
  Proof. fsetdec. Qed.

  Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty.
  Proof. fsetdec. Qed.

  Lemma diff_inter_all : union (diff s s') (inter s s') [=] s.
  Proof. fsetdec. Qed.

  Lemma Add_add : Add x s (add x s).
  Proof. expAdd; fsetdec. Qed.

  Lemma Add_remove : In x s -> Add x (remove x s) s.
  Proof. expAdd; fsetdec. Qed.

  Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s'').
  Proof. expAdd; fsetdec. Qed.

  Lemma inter_Add :
    In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s'').
  Proof. (* expAdd; rewrite Add_Equal in H0; fsetdec. Qed. *) (** trop lent *)
    expAdd; rewrite H0; clear H0; fsetdec.
  Qed.

  Lemma union_Equal : In x s'' -> Add x s s' -> union s s'' [=] union s' s''.
  Proof. (* expAdd; rewrite Add_Equal in H0; fsetdec. Qed.  *) (** trop lent *)
    expAdd; rewrite H0; clear H0; fsetdec.
  Qed.

  Lemma inter_Add_2 : ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''.
  Proof.
    expAdd; rewrite H0; clear H0; fsetdec.
  Qed.

End BasicProperties.

Hint Immediate @equal_sym @add_remove @remove_add @union_sym @inter_sym: set.
Hint Resolve @equal_refl @equal_trans @subset_refl @subset_equal
  @subset_antisym @subset_trans @subset_empty @subset_remove_3 @subset_diff
  @subset_add_3 @subset_add_2 @in_subset @empty_is_empty_1 @empty_is_empty_2
  @add_equal @remove_equal @singleton_equal_add @union_subset_equal
  @union_equal_1 @union_equal_2 @union_assoc @add_union_singleton @union_add
  @union_subset_1 @union_subset_2 @union_subset_3 @inter_subset_equal
  @inter_equal_1 @inter_equal_2 @inter_assoc @union_inter_1 @union_inter_2
  @inter_add_1 @inter_add_2 @empty_inter_1 @empty_inter_2 @empty_union_1
  @empty_union_2 @empty_diff_1 @empty_diff_2 @union_Add @inter_Add
  @union_Equal @inter_Add_2 @not_in_union @inter_subset_1 @inter_subset_2
  @inter_subset_3 @diff_subset @diff_subset_equal @remove_diff_singleton
  @diff_inter_empty @diff_inter_all @Add_add @Add_remove @Equal_remove
  @add_add : set.

(** * Properties of elements *)
Lemma elements_Empty `{HF : @FSetSpecs A HA F} :
  forall s, Empty s <-> elements s = nil.
Proof.
  intros.
  unfold Empty.
  split; intros.
  assert (forall a, ~ List.In a (elements s)).
  red; intros.
  apply (H a).
  rewrite elements_iff.
  rewrite InA_alt; exists a; auto.
  destruct (elements s) as [|e ?]; auto.
  elim (H0 e); simpl; auto.
  red; intros.
  rewrite elements_iff in H0.
  rewrite InA_alt in H0; destruct H0.
  rewrite H in H0; destruct H0 as (_,H0); inversion H0.
Qed.

Lemma elements_empty `{HF : @FSetSpecs A HA F} :
  elements empty = nil.
Proof.
  intros; rewrite <-elements_Empty; auto with set.
Qed.

(** * Conversions between lists and sets *)
Definition of_list `{HF : @FSetSpecs A HA F} (l : list A) :=
  List.fold_right add empty l.

Definition to_list `{HF : @FSetSpecs A HA F} :=
  elements.

Lemma of_list_1 `{HF : @FSetSpecs A HA F} :
  forall l x, In x (of_list l) <-> InA _eq x l.
Proof.
  induction l; simpl; intro x.
  rewrite empty_iff, InA_nil. intuition.
  rewrite add_iff, InA_cons, IHl. intuition.
Qed.

Lemma of_list_2 `{HF : @FSetSpecs A HA F} :
  forall l, equivlistA _eq (to_list (of_list l)) l.
Proof.
  unfold to_list; red; intros.
  rewrite <- elements_iff; apply of_list_1.
Qed.

Lemma of_list_3 `{HF : @FSetSpecs A HA F} :
  forall s, of_list (to_list s) [=] s.
Proof.
  unfold to_list; red; intros.
  rewrite of_list_1; symmetry; apply elements_iff.
Qed.

(** * Fold *)

Section Fold.
  Notation NoDup := (NoDupA _eq).
  Notation InA := (InA _eq).
  Notation t := (set _).

  Context `{HF : @FSetSpecs elt Helt F}.
  Let t := set elt.
  Hint Extern 1 (Equivalence _) => apply OT_Equivalence.

  (** ** Induction principles for fold (contributed by S. Lescuyer) *)

  (** In the following lemma, the step hypothesis is deliberately restricted
      to the precise set s we are considering. *)
  Theorem fold_rec :
    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
      (forall s', Empty s' -> P s' i) ->
      (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' ->
        P s' a -> P s'' (f x a)) ->
      P s (fold f s i).
  Proof.
    intros A P f i s Pempty Pstep.
    rewrite fold_1, <- fold_left_rev_right.
    set (l:=rev (elements s)).
    assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' ->
      P s' a -> P s'' (f x a)).
    intros; eapply Pstep; eauto.
    rewrite elements_iff, <- InA_rev; auto.
    assert (Hdup : NoDup l) by
      (unfold l; apply NoDupA_rev; eauto using elements_3w).
    assert (Hsame : forall x, In x s <-> InA x l) by
      (unfold l; intros; rewrite elements_iff, InA_rev; intuition).
    clear Pstep; clearbody l; revert s Hsame; induction l.
    (* empty *)
    intros s Hsame; simpl.
    apply Pempty. intro x. rewrite Hsame, InA_nil; intuition.
    (* step *)
    intros s Hsame; simpl.
    apply Pstep' with (of_list l); auto.
    inversion_clear Hdup; rewrite of_list_1; auto.
    red. intros. rewrite Hsame, of_list_1, InA_cons; intuition.
    apply IHl.
    intros; eapply Pstep'; eauto.
    inversion_clear Hdup; auto.
    exact (of_list_1 l).
  Qed.

  (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this
      case, [P] must be compatible with equality of sets *)
  Theorem fold_rec_bis :
    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
      (forall s s' a, s[=]s' -> P s a -> P s' a) ->
      (P empty i) ->
      (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) ->
      P s (fold f s i).
  Proof.
    intros A P f i s Pmorphism Pempty Pstep.
    apply fold_rec; intros.
    apply Pmorphism with empty; auto with set.
    rewrite Add_Equal in H1; auto with set.
    apply Pmorphism with (add x s'); auto with set.
  Qed.

  Lemma fold_rec_nodep :
    forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t),
     P i -> (forall x a, In x s -> P a -> P (f x a)) ->
     P (fold f s i).
  Proof.
    intros; apply (fold_rec_bis (P := fun _ => P)); auto.
  Qed.

  (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] :
      the step hypothesis must here be applicable to any [x].
      At the same time, it looks more like an induction principle,
      and hence can be easier to use. *)
  Lemma fold_rec_weak :
    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A),
    (forall s s' a, s[=]s' -> P s a -> P s' a) ->
    P empty i ->
    (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) ->
    forall s, P s (fold f s i).
  Proof.
    intros; apply fold_rec_bis; auto.
  Qed.

  Lemma fold_rel :
    forall (A B:Type)(R : A -> B -> Type)
     (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t),
     R i j ->
     (forall x a b, In x s -> R a b -> R (f x a) (g x b)) ->
     R (fold f s i) (fold g s j).
  Proof.
    intros A B R f g i j s Rempty Rstep.
    do 2 rewrite fold_1, <- fold_left_rev_right.
    set (l:=rev (elements s)).
    assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by
      (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto).
    clearbody l; clear Rstep s.
    induction l; simpl; auto.
  Qed.

  (** From the induction principle on [fold], we can deduce some general
      induction principles on sets. *)
  Lemma set_induction :
    forall P : t -> Type,
      (forall s, Empty s -> P s) ->
      (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') ->
      forall s, P s.
  Proof.
    intros; apply
      (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto.
  Qed.

  Lemma set_induction_bis :
    forall P : t -> Type,
      (forall s s', s [=] s' -> P s -> P s') ->
      P empty ->
      (forall x s, ~In x s -> P s -> P (add x s)) ->
      forall s, P s.
  Proof.
    intros.
    apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s);
      eauto.
  Qed.

  (** [fold] can be used to reconstruct the same initial set. *)
  Lemma fold_identity : forall s, fold add s empty [=] s.
  Proof.
    intros.
    apply fold_rec with (P:=fun s acc => acc[=]s); auto with set.
    intros. rewrite H2; rewrite Add_Equal in H1; auto with set.
  Qed.

  (** ** Alternative (weaker) specifications for [fold] *)

  (** When [FSets] was first designed, the order in which Ocaml's [Set.fold]
      takes the set elements was unspecified. This specification reflects
      this fact:
  *)
  Lemma fold_0 :
    forall s (A : Type) (i : A) (f : elt -> A -> A),
      exists l : list elt,
        NoDup l /\
        (forall x : elt, In x s <-> InA x l) /\
        fold f s i = fold_right f i l.
  Proof.
    intros; exists (rev (elements s)); split.
    apply NoDupA_rev; eauto with set.
    split; intros.
    rewrite elements_iff; do 2 rewrite InA_alt.
    split; destruct 1;
      generalize (In_rev (elements s) x0); exists x0; intuition.
    rewrite fold_left_rev_right.
    apply fold_1.
  Qed.

  (** An alternate (and previous) specification for [fold] was based on
      the recursive structure of a set. It is now lemmas [fold_1] and
      [fold_2]. *)
  Lemma fold_1 :
   forall s (A : Type) {eqA : A -> A -> Prop}
     `{st : Equivalence A eqA} (i : A) (f : elt -> A -> A),
   Empty s -> eqA (fold f s i) i.
  Proof.
    unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))).
    rewrite H3; clear H3.
    generalize H H2; clear H H2; case l; simpl; intros.
    reflexivity.
    elim (H e).
    elim (H2 e); intuition.
  Qed.

  Lemma fold_2 :
   forall s s' x (A : Type) {eqA : A -> A -> Prop}
     `{st : Equivalence A eqA} (i : A) (f : elt -> A -> A)
     `{Proper _ (_eq ==> eqA ==> eqA) f},
   transpose eqA f ->
   ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
  Proof.
    intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2)));
      destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
    rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
    apply fold_right_add with (eqA:=_eq)(eqB:=eqA); auto.
    rewrite <- Hl1; auto.
    intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1;
      rewrite (H2 a); intuition.
  Qed.

  (** In fact, [fold] on empty sets is more than equivalent to
      the initial element, it is Leibniz-equal to it. *)

  Lemma fold_1b :
    forall s (A : Type)(i : A) (f : elt -> A -> A),
      Empty s -> (fold f s i) = i.
  Proof.
    intros.
    rewrite fold_1; auto.
  Qed.

  Section Fold_More.
    Variable A : Type.
    Context `{st : Equivalence A eqA}.
    Variable (f:elt->A->A).
    Context {Comp : Proper (_eq ==> eqA ==> eqA) f}.
    Hypothesis Ass : transpose eqA f.

    Lemma fold_commutes :
      forall i s x, eqA (fold f s (f x i)) (f x (fold f s i)).
    Proof.
      intros.
      apply fold_rel with (R:=fun u v => eqA u (f x v)); intros.
      reflexivity.
      transitivity (f x0 (f x b)); auto; rewrite H0; reflexivity.
    Qed.

    (** ** Fold is a morphism *)
    Lemma fold_init : forall i i' s, eqA i i' -> eqA (fold f s i) (fold f s i').
    Proof.
      intros. apply fold_rel with (R:=eqA); auto.
      intros; rewrite H1; reflexivity.
    Qed.

    Lemma fold_equal :
      forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
    Proof.
      intros i s; pattern s; apply set_induction; clear s; intros.
      transitivity i.
      apply fold_1; auto.
      symmetry; apply fold_1; auto.
      rewrite <- H0; auto.
      transitivity (f x (fold f s i)).
      apply (fold_2 (eqA := eqA)); auto.
      symmetry; apply (fold_2 (eqA := eqA)); auto.
      unfold Add in *; intros.
      rewrite <- H2; auto.
    Qed.

    (** ** Fold and other set operators *)

    Lemma fold_empty : forall i, fold f empty i = i.
    Proof.
      intros; apply fold_1b; auto with set.
    Qed.

    Lemma fold_add : forall i s x, ~In x s ->
      eqA (fold f (add x s) i) (f x (fold f s i)).
    Proof.
      intros; apply (fold_2 (st:=st)); auto with set.
    Qed.

    Lemma add_fold :
      forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i).
    Proof.
      intros; apply fold_equal; auto with set.
    Qed.

    Lemma remove_fold_1 :
      forall i s x, In x s -> eqA (f x (fold f (remove x s) i)) (fold f s i).
    Proof.
      intros.
      symmetry.
      apply (fold_2 (st:=st)); auto with set.
    Qed.

    Lemma remove_fold_2 :
      forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i).
    Proof.
      intros.
      apply fold_equal; auto with set.
    Qed.

    Lemma fold_union_inter :
      forall i s s',
        eqA (fold f (union s s') (fold f (inter s s') i))
        (fold f s (fold f s' i)).
    Proof.
      intros; pattern s; apply set_induction; clear s; intros.
      transitivity (fold f s' (fold f (inter s s') i)).
      apply fold_equal; auto with set.
      transitivity (fold f s' i).
      apply fold_init; auto.
      apply fold_1; auto with set.
      symmetry; apply fold_1; auto.
      rename s'0 into s''.
      destruct (In_dec x s').
      (* In x s' *)
      transitivity
        (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set.
      apply fold_init; auto.
      apply (fold_2 (eqA:=eqA)); auto with set.
      rewrite inter_iff; intuition.
      transitivity (f x (fold f s (fold f s' i))).
      transitivity (fold f (union s s') (f x (fold f (inter s s') i))).
      apply fold_equal; auto.
      apply equal_sym; apply union_Equal with x; auto with set.
      transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
      apply fold_commutes; auto.
      apply Comp; auto.
      symmetry; apply (fold_2 (eqA:=eqA)); auto.
      (* ~(In x s') *)
      transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))).
      apply (fold_2 (eqA:=eqA)); auto with set.
      transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
      apply Comp;auto.
      apply fold_init;auto.
      apply fold_equal;auto.
      apply equal_sym; apply inter_Add_2 with x; auto with set.
      transitivity (f x (fold f s (fold f s' i))).
      apply Comp; auto.
      symmetry; apply (fold_2 (eqA:=eqA)); auto.
    Qed.

    Lemma fold_diff_inter :
      forall i s s',
        eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i).
    Proof.
      intros.
      transitivity (fold f (union (diff s s') (inter s s'))
        (fold f (inter (diff s s') (inter s s')) i)).
      symmetry; apply fold_union_inter; auto.
      transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)).
      apply fold_equal; auto with set.
      apply fold_init; auto.
      apply (fold_1 (eqA:=eqA)); auto with set.
    Qed.

    Lemma fold_union :
      forall i s s', (forall x, ~(In x s/\In x s')) ->
        eqA (fold f (union s s') i) (fold f s (fold f s' i)).
    Proof.
      intros.
      transitivity (fold f (union s s') (fold f (inter s s') i)).
      apply fold_init; auto.
      symmetry; apply fold_1; auto with set.
      unfold Empty; intro a; generalize (H a); set_iff; tauto.
      apply fold_union_inter; auto.
    Qed.
  End Fold_More.

  Lemma fold_plus :
   forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p.
  Proof.
    intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto.
  Qed.
End Fold.

(** * Cardinal *)

(** ** Characterization of cardinal in terms of fold *)

Lemma cardinal_fold `{HF : @FSetSpecs elt Helt F} :
  forall s, cardinal s = fold (fun _ => S) s 0.
Proof.
  intros; rewrite cardinal_1; rewrite SetInterface.fold_1; auto.
  symmetry; apply fold_left_length; auto.
Qed.

(** ** Old specifications for [cardinal]. *)

Lemma cardinal_0 `{HF : @FSetSpecs elt Helt F} :
  forall s, exists l : list elt,
    NoDupA _eq l /\
    (forall x : elt, In x s <-> InA _eq x l) /\
    cardinal s = length l.
Proof.
  intros; exists (elements s); intuition.
  apply cardinal_1.
Qed.

Lemma cardinal_1 `{HF : @FSetSpecs elt Helt F} :
  forall s, Empty s -> cardinal s = 0.
Proof.
  intros; rewrite cardinal_fold; apply fold_1; auto.
Qed.

Lemma cardinal_2 `{HF : @FSetSpecs elt Helt F} :
  forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s).
Proof.
  intros; do 2 rewrite cardinal_fold.
  change S with ((fun _ => S) x).
  apply (fold_2 (eqA:=@eq _)) ; auto.
  repeat intro; vm_compute; congruence.
Qed.

(** ** Cardinal and (non-)emptiness *)

Lemma cardinal_Empty `{HF : @FSetSpecs elt Helt F} :
  forall s, Empty s <-> cardinal s = 0.
Proof.
  intros.
  rewrite elements_Empty, SetInterface.cardinal_1.
  destruct (elements s); intuition; discriminate.
Qed.

Lemma cardinal_inv_1 `{HF : @FSetSpecs elt Helt F} :
  forall s, cardinal s = 0 -> Empty s.
Proof.
  intros; rewrite cardinal_Empty; auto.
Qed.
Hint Resolve @cardinal_inv_1.

Lemma cardinal_inv_2 `{HF : @FSetSpecs elt Helt F} :
  forall s n, cardinal s = S n -> { x : elt | In x s }.
Proof.
  intros; rewrite SetInterface.cardinal_1 in H.
  generalize (elements_2 (s:=s)).
  destruct (elements s); try discriminate.
  exists e; auto.
Qed.

Lemma cardinal_inv_2b `{HF : @FSetSpecs elt Helt F} :
  forall s, cardinal s <> 0 -> { x : elt | In x s }.
Proof.
  intros s;
    generalize (@cardinal_inv_2 _ _ _ _ s); destruct cardinal;
    [intuition|eauto].
Qed.

(** ** Cardinal is a morphism *)

Lemma Equal_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall s s', s[=]s' -> cardinal s = cardinal s'.
Proof.
  symmetry.
  remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H.
  induction n; intros.
  apply cardinal_1; rewrite <- H; auto.
  destruct (cardinal_inv_2 Heqn) as (x,H2).
  revert Heqn.
  rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set.
  rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set.
Qed.

Instance cardinal_m `{HF : @FSetSpecs elt Helt F} :
  Proper (Equal ==> @eq nat) cardinal.
Proof.
  repeat intro; auto using Equal_cardinal.
Qed.

Hint Resolve @Add_add @Add_remove @Equal_remove @cardinal_inv_1 @Equal_cardinal.

(** ** Cardinal and set operators *)

Lemma empty_cardinal `{HF : @FSetSpecs elt Helt F} :
  cardinal empty = 0.
Proof.
  intros; rewrite cardinal_fold; apply fold_1; auto with set.
Qed.

Hint Immediate @empty_cardinal @cardinal_1 : set.

Lemma singleton_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall x, cardinal (singleton x) = 1.
Proof.
  intros.
  rewrite (singleton_equal_add x).
  replace 0 with (cardinal empty); auto with set.
  apply cardinal_2 with x; auto with set. fsetdec.
Qed.

Hint Resolve @singleton_cardinal: set.

Lemma diff_inter_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s .
Proof.
  intros; do 3 rewrite cardinal_fold.
  rewrite <- fold_plus.
  apply fold_diff_inter with (eqA:=@Logic.eq nat); auto.
  repeat intros; vm_compute; congruence.
Qed.

Lemma union_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall s s', (forall x, ~(In x s/\In x s')) ->
    cardinal (union s s')=cardinal s+cardinal s'.
Proof.
  intros; do 3 rewrite cardinal_fold.
  rewrite <- fold_plus.
  apply (fold_union (eqA:=@eq _)); auto.
  repeat intros; vm_compute; congruence.
Qed.

Lemma subset_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall s s', s[<=]s' -> cardinal s <= cardinal s' .
Proof.
  intros.
  rewrite <- (diff_inter_cardinal s' s).
  rewrite (inter_sym s' s).
  rewrite (inter_subset_equal H); auto with arith.
Qed.

Lemma subset_cardinal_lt `{HF : @FSetSpecs elt Helt F} :
  forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
Proof.
  intros.
  rewrite <- (diff_inter_cardinal s' s).
  rewrite (inter_sym s' s).
  rewrite (inter_subset_equal H).
  generalize (@cardinal_inv_1 _ _ _ _ (diff s' s)).
  destruct (cardinal (diff s' s)).
  intro H2; destruct (H2 (refl_equal _) x).
  set_iff; auto.
  intros _.
  change (0 + cardinal s < S n + cardinal s).
  apply Plus.plus_lt_le_compat; auto with arith.
Qed.

Theorem union_inter_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall s s', cardinal (union s s') + cardinal (inter s s') =
    cardinal s  + cardinal s' .
Proof.
  intros.
  do 4 rewrite cardinal_fold.
  do 2 rewrite <- fold_plus.
  apply fold_union_inter with (eqA:=@Logic.eq nat); auto.
  repeat intros; vm_compute; congruence.
Qed.

Lemma union_cardinal_inter `{HF : @FSetSpecs elt Helt F} :
  forall s s', cardinal (union s s') =
    cardinal s + cardinal s' - cardinal (inter s s').
Proof.
  intros.
  rewrite <- union_inter_cardinal.
  rewrite Plus.plus_comm.
  auto with arith.
Qed.

Lemma union_cardinal_le `{HF : @FSetSpecs elt Helt F} :
   forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
Proof.
  intros; generalize (union_inter_cardinal s s').
  intros; rewrite <- H; auto with arith.
Qed.

Lemma add_cardinal_1 `{HF : @FSetSpecs elt Helt F} :
  forall s x, In x s -> cardinal (add x s) = cardinal s.
Proof.
  auto with set.
Qed.

Lemma add_cardinal_2 `{HF : @FSetSpecs elt Helt F} :
  forall s x, ~In x s -> cardinal (add x s) = S (cardinal s).
Proof.
  intros.
  do 2 rewrite cardinal_fold.
  change S with ((fun _ => S) x);
    apply fold_add with (eqA:=@Logic.eq nat); auto.
  repeat intros; vm_compute; congruence.
Qed.

Lemma remove_cardinal_1 `{HF : @FSetSpecs elt Helt F} :
  forall s x, In x s -> S (cardinal (remove x s)) = cardinal s.
Proof.
  intros.
  do 2 rewrite cardinal_fold.
  change S with ((fun _ =>S) x).
  apply remove_fold_1 with (eqA:=@Logic.eq nat); auto.
  repeat intros; vm_compute; congruence.
Qed.

Lemma remove_cardinal_2 `{HF : @FSetSpecs elt Helt F} :
  forall s x, ~In x s -> cardinal (remove x s) = cardinal s.
Proof.
  auto with set.
Qed.

Hint Resolve @subset_cardinal @union_cardinal @add_cardinal_1 @add_cardinal_2.

(** Now comes some properties specific to the element ordering,
   invalid for Weak Sets. *)
(** First, a specialized version of SortA_equivlistA_eqlistA: *)
Lemma sort_equivlistA_eqlistA
  `{HF : @FSetSpecs elt Helt F} :
  forall l l' : list elt, sort _lt l -> sort _lt l' ->
    equivlistA _eq l l' -> eqlistA _eq l l'.
Proof.
  intros; apply SortA_equivlistA_eqlistA with _lt;
    eauto with typeclass_instances.
Qed.

Definition gtb `{Helt : OrderedType elt} (x y : elt) := x >> y.
Definition leb `{Helt : OrderedType elt} (x : elt) :=
  fun y => negb (x >> y).

Definition elements_lt
  `{HF : @FSetSpecs elt Helt F} x s :=
  List.filter (gtb x) (elements s).
Definition elements_ge
  `{HF : @FSetSpecs elt Helt F} x s :=
  List.filter (leb x) (elements s).

Lemma gtb_1 `{Helt : OrderedType elt} : forall x y, gtb x y = true <-> y <<< x.
Proof.
  intros; unfold gtb; destruct (gt_dec x y); intuition;
    try discriminate; order.
Qed.

Lemma leb_1 `{Helt : OrderedType elt} :
  forall x y, leb x y = true <-> ~y <<< x.
Proof.
  intros; unfold leb, gtb; destruct (gt_dec x y); intuition;
    try discriminate; order.
Qed.

Instance gtb_m `{Helt : OrderedType elt} :
  forall x, Proper (_eq ==> @eq bool) (gtb x).
Proof.
  red; intros x a b H.
  unfold gtb; destruct (gt_dec x a); destruct (gt_dec x b);
    auto; rewrite H in H0; contradiction.
Qed.
Corollary gtb_compat `{Helt : OrderedType elt} :
  forall x, compat_bool _eq (gtb x).
Proof.
  repeat intro; rewrite H; reflexivity.
Qed.

Instance leb_m `{Helt : OrderedType elt} :
  forall x, Proper (_eq ==> @eq bool) (leb x).
Proof.
  red; intros x a b H; unfold leb.
  f_equal; apply gtb_m; auto.
Qed.
Corollary leb_compat `{Helt : OrderedType elt} :
  forall x, compat_bool _eq (leb x).
Proof.
  repeat intro; rewrite H; reflexivity.
Qed.
Hint Resolve @leb_compat @gtb_compat.

(* Ltac normalize_notations := *)
(*   match goal with *)
(*  | H : ?R ?x ?y |- _ => *)
(*    progress ((change (x === y) in H) || (change (x <<< y) in H) || *)
(*      (change (x >>> y) in H)); normalize_notations *)
(*  | H : ~(?R ?x ?y) |- _ => *)
(*    progress ((change (x =/= y) in H) || (change (~ x <<< y) in H) || *)
(*      (change (~ y <<< x) in H)); normalize_notations *)
(*  | |- ?R ?x ?y => *)
(*    progress (change (x === y) || change (x <<< y) || change (y <<< x)) *)
(*  | |- ~?R ?x ?y => *)
(*    progress (change (x =/= y) || change (~x <<< y) || change (~y <<< x)) *)
(*  | _ => idtac *)
(*   end. *)

Lemma elements_split
  `{HF : @FSetSpecs elt Helt F} :
  forall x s, elements s = (elements_lt x s ++ elements_ge x s)%list.
Proof.
  unfold elements_lt, elements_ge, leb; intros.
  eapply (@filter_split _ _eq _ _lt); eauto with set typeclass_instances.
  intros; destruct (gt_dec x x0); destruct (gt_dec x y); try discriminate.
  order.
Qed.

Lemma elements_Add
  `{HF : @FSetSpecs elt Helt F} :
  forall s s' x, ~In x s -> Add x s s' ->
    eqlistA _eq (elements s') (elements_lt x s ++ x :: elements_ge x s)%list.
Proof.
  assert (Z : forall x, Proper (_eq ==> eq) (leb x)).
  repeat intro; unfold leb;
    destruct (gt_dec x x0); destruct (gt_dec x y); order.
  assert (Z' : forall x, Proper (_eq ==> eq) (gtb x)).
  repeat intro; unfold gtb;
    destruct (gt_dec x x0); destruct (gt_dec x y); order.
  intros; unfold elements_ge, elements_lt.
  apply sort_equivlistA_eqlistA; auto with set.
  apply (@SortA_app _ _eq); auto.
  apply (@filter_sort _ _eq); auto with set; eauto with set; intros; order.
  constructor; auto.
  apply (@filter_sort _ _eq); auto with set; eauto with set;
    try (intros; order).
  rewrite Inf_alt by
    (apply (@filter_sort _ _eq); eauto with set; intros; order).
  intros; rewrite filter_InA in H1; auto; destruct H1.
  rewrite leb_1 in H2.
  rewrite <- elements_iff in H1.
  assert (x =/= y). intro abs; apply H; rewrite abs; auto. order.
  intros.
  rewrite filter_InA in H1; auto; destruct H1.
  rewrite gtb_1 in H3.
  inversion_clear H2.
  order.
  rewrite filter_InA in H4; auto; destruct H4.
  rewrite leb_1 in H4.
  order.
  red; intros a.
  rewrite InA_app_iff; auto. rewrite InA_cons.
  rewrite !filter_InA; auto.
  do 2 rewrite <- elements_iff.
  rewrite leb_1; rewrite gtb_1.
  rewrite (H0 a); intuition.
  destruct (compare_dec a x); intuition.
  right; right; split; auto.
  order.
Qed.

Definition Above `{HF : @FSetSpecs elt Helt F}
  x s := forall y, In y s -> y <<< x.
Definition Below `{HF : @FSetSpecs elt Helt F}
  x s := forall y, In y s -> x <<< y.

Lemma elements_Add_Above
  `{HF : @FSetSpecs elt Helt F} :
  forall s s' x, Above x s -> Add x s s' ->
    eqlistA _eq (elements s') (elements s ++ x::nil)%list.
Proof.
  intros.
  apply sort_equivlistA_eqlistA; auto with set.
  apply (@SortA_app _ _eq); auto with set.
  intros.
  inversion_clear H2.
  rewrite <- elements_iff in H1.
  apply lt_eq with x; auto.
  inversion H3.
  red; intros a.
  rewrite InA_app_iff; auto; rewrite InA_cons; rewrite InA_nil.
  do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
Qed.

Lemma elements_Add_Below
  `{HF : @FSetSpecs elt Helt F} :
  forall s s' x, Below x s -> Add x s s' ->
    eqlistA _eq (elements s') (x::elements s).
Proof.
  intros.
  apply sort_equivlistA_eqlistA; auto with set.
  change (sort _lt ((x::nil) ++ elements s)).
  apply (@SortA_app _ _eq); auto with set.
  intros.
  inversion_clear H1.
  rewrite <- elements_iff in H2.
  apply eq_lt with x; auto.
  inversion H3.
  red; intros a.
  rewrite InA_cons.
  do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
Qed.

(** Two other induction principles on sets: we can be more restrictive
   on the element we add at each step.  *)
Lemma set_induction_max
  `{HF : @FSetSpecs elt Helt F} :
  forall P : set elt -> Type,
    (forall s, Empty s -> P s) ->
    (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') ->
    forall s, P s.
Proof.
  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
  case_eq (max_elt s); intros.
  apply X0 with (remove e s) e; auto with set.
  apply IHn.
  assert (S n = S (cardinal (remove e s))).
  rewrite Heqn; apply cardinal_2 with e; auto with set.
  inversion H0; auto.
  red; intros.
  rewrite remove_iff in H0; destruct H0.
  generalize (@max_elt_2 _ _ _ _ s e y H H0); order.

  assert (H0:=max_elt_3 H).
  rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn.
Qed.

Lemma set_induction_min
  `{HF : @FSetSpecs elt Helt F} :
  forall P : set elt -> Type,
    (forall s, Empty s -> P s) ->
    (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') ->
    forall s, P s.
Proof.
  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
  case_eq (min_elt s); intros.
  apply X0 with (remove e s) e; auto with set.
  apply IHn.
  assert (S n = S (cardinal (remove e s))).
   rewrite Heqn; apply cardinal_2 with e; auto with set.
  inversion H0; auto.
  red; intros.
  rewrite remove_iff in H0; destruct H0.
  generalize (@min_elt_2 _ _ _ _ s e y H H0); order.

  assert (H0:=min_elt_3 H).
  rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn.
Qed.

(** More properties of [fold] : behavior with respect to Above/Below *)
Lemma fold_3
  `{HF : @FSetSpecs elt Helt F} :
  forall s s' x (A : Type) (eqA : A -> A -> Prop)
    (st : Equivalence eqA) (i : A)
    (f : elt -> A -> A) `{Proper _ (_eq ==> eqA ==> eqA) f},
    Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
Proof.
  intros.
  do 2 rewrite SetInterface.fold_1.
  do 2 rewrite <- fold_left_rev_right.
  change (f x (fold_right f i (rev (elements s)))) with
    (fold_right f i (rev (x::nil)++rev (elements s))).
  apply (@fold_right_eqlistA _ _eq A eqA st); auto.
  rewrite <- distr_rev.
  apply eqlistA_rev.
  apply elements_Add_Above; auto.
Qed.

Lemma fold_4
  `{HF : @FSetSpecs elt Helt F} :
  forall s s' x (A : Type) (eqA : A -> A -> Prop)
    (st : Equivalence eqA) (i : A)
    (f : elt -> A -> A) `{Proper _ (_eq ==> eqA ==> eqA) f},
    Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)).
Proof.
  intros.
  do 2 rewrite SetInterface.fold_1.
  set (g:=fun (a : A) (e : elt) => f e a).
  change (eqA (fold_left g (elements s') i) (fold_left g (x::elements s) i)).
  unfold g.
  do 2 rewrite <- fold_left_rev_right.
  apply (@fold_right_eqlistA elt _eq A eqA st); auto.
  apply eqlistA_rev.
  apply elements_Add_Below; auto.
Qed.

(** The following results have already been proved earlier, *)
(*    but we can now prove them with one hypothesis less: *)
(*    no need for [(transpose eqA f)]. *)
Section FoldOpt.
  Lemma fold_equal_ord
    `{HF : @FSetSpecs elt Helt F} :
    forall (A : Type) {eqA : A -> A -> Prop}
     `{st : Equivalence A eqA} (i : A) (f : elt -> A -> A)
     `{Proper _ (_eq ==> eqA ==> eqA) f},
     forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
  Proof.
    intros; do 2 rewrite SetInterface.fold_1.
    do 2 rewrite <- fold_left_rev_right.
    apply (@fold_right_eqlistA _ _eq A eqA st); auto.
    apply eqlistA_rev.
    apply sort_equivlistA_eqlistA; auto with set.
    red; intro a; do 2 rewrite <- elements_iff; auto.
  Qed.

  Lemma add_fold_ord
    `{HF : @FSetSpecs elt Helt F} :
    forall (A : Type) {eqA : A -> A -> Prop}
     `{st : Equivalence A eqA} (i : A) (f : elt -> A -> A)
     `{Proper _ (_eq ==> eqA ==> eqA) f},
     forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i).
  Proof.
    intros; apply (fold_equal_ord (st:=st)); auto with set.
  Qed.

  Lemma remove_fold_2_ord
    `{HF : @FSetSpecs elt Helt F} :
    forall (A : Type) {eqA : A -> A -> Prop}
     `{st : Equivalence A eqA} (i : A) (f : elt -> A -> A)
     `{Proper _ (_eq ==> eqA ==> eqA) f},
     forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i).
  Proof.
    intros; apply (fold_equal_ord (st:=st)); auto with set.
  Qed.
End FoldOpt.

(** An alternative version of [choose_3] *)
Lemma choose_equal
  `{HF : @FSetSpecs elt Helt F} :
  forall s s', Equal s s' ->
  match choose s, choose s' with
    | Some x, Some x' => x === x'
    | None, None => True
    | _, _ => False
  end.
Proof.
  intros s s' H.
  generalize (choose_1 (s:=s))(choose_2 (s:=s))
    (choose_1 (s:=s'))(choose_2 (s:=s'))(choose_3 (s:=s) (s':=s'));
    destruct (choose s); destruct (choose s'); simpl; intuition.
  apply H5 with e; rewrite <-H; auto.
  apply H5 with e; rewrite H; auto.
Qed.

(** * Facts about [For_all] and [Exists]: since these predicates
   quantify over a finite set, they are dual in a classical way when
   they are applied to decidable properties (such as in [for_all]
   and [exists]). *)
Section For_all_Exists.
  Context `{HF : @FSetSpecs elt Helt F}.
  Variable f : elt -> bool.
  Context `{Hf : Proper _ (_eq ==> @eq bool) f}.

  Property For_all_Exists_iff : forall s,
    For_all (fun x => f x = true) s <-> ~ (Exists (fun x => f x = false) s).
  Proof.
    apply set_induction_bis; unfold For_all; unfold Exists; intros;
      split; intros; try intros [w Hw].
    (* morphism *)
    rewrite <- H in Hw.
    apply (proj1 H0); [| exists w; exact Hw].
    intro y; rewrite H; exact (H1 y).
    apply (proj2 H0); [| rewrite H; assumption].
    intros [y Hy]; apply H1; exists y; rewrite <- H; assumption.
    (* init *)
    contradiction (empty_1 (proj1 Hw)).
    contradiction (empty_1 H0).
    (* step *)
    apply (proj1 H0).
    intros; auto with set.
    destruct Hw as [Hw1 Hw2]; exists w; split; auto.
    apply add_3 with x; auto; intro abs.
    rewrite (H1 w) in Hw2; [discriminate | rewrite abs; auto with set].
    rewrite add_iff in H2; destruct H2 as [Hx | Hs].
    rewrite <- Hx; case_eq (f x); auto; intro.
    contradiction H1; exists x; split; [auto with set | assumption].
    apply (proj2 H0); auto.
    intros [w Hw]; apply H1; exists w; intuition (auto with set).
  Qed.

  Property Exists_For_all_iff : forall s,
     Exists (fun x => f x = true) s <-> ~ For_all (fun x => f x = false) s.
  Proof.
    apply set_induction_bis; unfold For_all; unfold Exists; intros;
      split; try intros [w Hw]; try intro Hall.
    (* morphism *)
    rewrite <- H in Hw.
    apply (proj1 H0); [exists w; exact Hw|].
    intro y; rewrite H; exact (Hall y).
    destruct (proj2 H0) as [w Hw].
    intro Z; apply Hall; intros; apply Z; rewrite H; auto.
    exists w; rewrite <- H; auto.
    (* init *)
    contradiction (empty_1 (proj1 Hw)).
    contradiction Hall; intros; contradiction (empty_1 H).
    (* step *)
    apply (proj1 H0).
    destruct Hw as [Hw1 Hw2]; exists w; split; auto.
    apply add_3 with x; auto; intro abs.
    rewrite (Hall w) in Hw2; [discriminate | rewrite abs; auto with set].
    intros; auto with set.
    case_eq (f x); intros.
    exists x; split; auto with set.
    destruct (proj2 H0) as [w Hw].
    intro Z; apply Hall; intros.
    rewrite add_iff in H2; destruct H2; auto. rewrite <- H2; assumption.
    exists w; intuition (auto with set).
  Qed.
End For_all_Exists.

(** * More precise reflexive view of [for_all] and [_exists] than the one
   in [SetFacts] using the duality results above. *)
Section for_all_exists_spec.
  Context `{HF : @FSetSpecs elt Helt F}.
  Variable s : set elt.
  Variable f : elt -> bool.

  CoInductive for_all_spec : bool -> Prop :=
  | for_all_spec_true :
    forall (Htrue : For_all (fun x => f x = true) s), for_all_spec true
  | for_all_spec_false :
    forall w (Hin : In w s) (Hw : f w = false), for_all_spec false.
  CoInductive exists_spec : bool -> Prop :=
  | exists_spec_true :
    forall w (Hin : In w s) (Hw : f w = true), exists_spec true
  | exists_spec_false :
    forall (Hfalse : For_all (fun x => f x = false) s), exists_spec false.

  Context `{Hf : Proper _ (_eq ==> @eq bool) f}.
  Property for_all_dec2 : for_all_spec (for_all f s).
  Proof.
    destruct (@for_all_dec _ _ _ _ s f Hf).
    constructor; assumption.
    set (negf := fun x => negb (f x)).
    assert (Exists (fun x => negf x = true) s).
    rewrite Exists_For_all_iff.
    intro abs; apply Hfalse; repeat intro; generalize (abs x H).
    unfold negf; destruct (f x); auto.
    repeat intro; unfold negf; rewrite H; reflexivity.
    destruct H as [w [Hw1 Hw2]]; constructor 2 with w; auto.
    unfold negf in Hw2; destruct (f w); auto.
  Qed.
  Property exists_dec2 : exists_spec (exists_ f s).
  Proof.
    destruct (@exists_dec _ _ _ _ s f Hf).
    destruct Htrue as [w Hw]; constructor 1 with w; tauto.
    constructor 2.
    repeat intro; case_eq (f x); auto; intros.
    contradiction Hfalse; exists x; tauto.
  Qed.
End for_all_exists_spec.


Require Import Sty Shape Tac.

Lemma shape_dec :
  forall S sh, {shape S = sh} + {shape S <> sh}.
Proof. decide equality. Qed.

Definition shape_prop (sh : Shape) (S : Sty) : Prop :=
  match sh with
  | unitS => S = unit
  | sendS => exists B S', S = send B S'
  | recvS => exists B S', S = recv B S'
  | echoiceS => exists S1 S2, S = echoice S1 S2
  | ichoiceS => exists S1 S2, S = ichoice S1 S2
  | muS => exists X S', S = mu X S'
  | varS => exists X, S = var X
  end
.

Lemma shape_inv_helper S sh (p : shape S = sh) : shape_prop sh S.
Proof. destruct sh; destruct S; simpl; try discriminate; iauto. Qed.

Ltac shape_inv H :=
  let inv S sh p :=
    let H := fresh in
    pose proof (shape_inv_helper S sh p) as H;
    simpl in H;
    try (decompose_ex H);
    rewrite H in *;
    clear H p
  in
    match type of H with
    | shape ?S = ?sh => inv S sh H
    | ?sh = shape ?S => symmetry in H; shape_inv H
    end
.

Ltac shape_inv_auto :=
  match goal with
  | H : shape _ = _ |- _ => shape_inv H
  | H : _ = shape _ |- _ => shape_inv H
  end;
  try shape_inv_auto
.


Unset Positivity Checking.
Inductive BushSenior (A : Type) : Type :=
| E : BushSenior A
| N : A -> BushSenior (BushSenior (BushSenior A)) -> BushSenior A.
Set Positivity Checking.

Arguments E {A}.
Arguments N {A} _ _.

Unset Guard Checking.
Fixpoint map {A B : Type} (f : A -> B) (b : BushSenior A) {struct b} : BushSenior B :=
match b with
| E => E
| N x b' => N (f x) (map (map (map f)) b')
end.

Fixpoint sum (b : BushSenior nat) : nat :=
match b with
| E => 0
| N x b' => x + sum (map sum (map (map sum) b'))
end.

Fixpoint size {A : Type} (b : BushSenior A) {struct b} : nat :=
match b with
| E => 0
| N _ b' => 1 + sum (map sum (map (map size) b'))
end.

Fixpoint nums (n : nat) : BushSenior nat :=
match n with
| 0 => N 0 E
| S n' => N n (map (map nums) (map nums (nums n')))
end.

(* Compute size (nums 8). *)

Set Guard Checking.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(* Jean-Francois.Monin@lannion.cnet.fr                                      *)
(* December 1994, Coq V5.10                                                 *)
(*                                                                          *)
(****************************************************************************)
(*                                 cps_Nx.v                                 *)
(****************************************************************************)

(*
   The following primitives  should be used in a section
   beginning with

Load DeclareNx.

*)

Section defcont.

Variable X : Set.
Variable P : Prop.
Variable e : P -> X.

Definition Nxglob (C : Prop) (A : Set) := (C -> P) -> (A -> X) -> X.

Let Nx := Nxglob.

Notation "c \/+ s" := (Nx c s)
  (at level 85, right associativity, format "c  \/+  '/  ' s").

Definition Nx_unit_glob (C : Prop) (A : Set) (a : A) :
  C \/+ A := fun (i : C -> P) (k : A -> X) => k a.

Definition Nx_raise_glob (C : Prop) (A : Set) (c : C) :
  C \/+ A := fun (i : C -> P) (k : A -> X) => e (i c).

Definition Nx_elim_Nx_glob (A A' : Set) (C C' : Prop)
  (f : A -> C' \/+ A') (j : C -> C') (nx : C \/+ A) :
  C' \/+ A' :=
  fun (i : C' -> P) (k : A' -> X) =>
  nx (fun c : C => i (j c)) (fun a : A => f a i k).

Definition Nx_handle_glob (C : Prop) (A : Set) (nx : C \/+ A) :
  (C -> P) -> (A -> X) -> X := nx.

End defcont.


(* Require Import core core_axioms fintype. *)
(* core_axioms can now be removed *)
Require Import core fintype.
Import ScopedNotations.

(* Lemma scons_eta {T} {n : nat} (f : fin (S n) -> T) : *)
(*   f var_zero .: shift >> f = f. *)
(* Proof. fext. intros [x|]; reflexivity.  Qed. *)

Lemma scons_eta' {T} {n : nat} (f : fin (S n) -> T) (x: fin (S n)):
  (f var_zero .: (shift >> f)) x = f x.
Proof.
  destruct x; reflexivity.
Qed.

(* Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (fin (S n) -> fin (S n)). *)
(* Proof. fext. intros [x|]; reflexivity. Qed. *)

Lemma scons_eta_id' {n : nat} (x: fin (S n)): (var_zero .: shift) x = id x.
Proof. destruct x; reflexivity. Qed.

(* Lemma scons_comp' {T:Type} {U} {m} {s: T} (sigma: fin m -> T) (tau: T -> U) : forall t, ((s .: sigma) >> tau) t = ((tau s) .: (sigma >> tau)) t. *)
(* Proof. *)
(*   intros [x|]. reflexivity. simpl. reflexivity. *)
(* Qed. *)

Lemma scons_comp' {T:Type} {U} {m} {s: T} (sigma: fin m -> T) (tau: T -> U) (t: fin (S m)): ((s .: sigma) >> tau) t = ((tau s) .: (sigma >> tau)) t.
Proof.
  destruct t; reflexivity.
Qed.

(* Lemma scons_comp (T: Type) U {m} (s: T) (sigma: fin m -> T) (tau: T -> U ) : *)
(*   (s .: sigma) >> tau = (tau s) .: (sigma >> tau) . *)
(* Proof. *)
(*   fext. intros [x|]. reflexivity. simpl. reflexivity. *)
(* Qed. *)

(* Lemma scons_p_head X m n (f : fin m -> X) (g : fin n -> X) : *)
(*   (zero_p m >> scons_p m f g) = f. *)
(* Proof. fext. intros z. unfold funcomp. apply scons_p_head'. Qed. *)

(* Lemma scons_p_tail X  m n (f : fin m -> X) (g : fin n -> X) : *)
(*   shift_p m  >> scons_p m f g = g. *)
(* Proof. fext. intros z. unfold funcomp. apply scons_p_tail'. Qed. *)

(* Lemma scons_p_comp {X Y m n} {f : fin m -> X} {g : fin n -> X} {h : X -> Y} : *)
(*   (scons_p m f g) >> h = scons_p m (f >> h) (g >> h). *)
(* Proof. fext. intros z. unfold funcomp. apply scons_p_comp'. Qed. *)

Ltac eta_reduce :=
     repeat match goal with
            | [|- context[(fun x => ?b x)]] => change (fun x => b x) with b
            end.

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         (* we don't use this additional comp *)
         (* | [|- context[comp ?f ?g]] => change (comp f g) with (g >> f) (* AsimplCompIdL *) *)
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h)) (* AsimplComp *)

         (* | [|- zero_p >> scons_p ?f ?g] => rewrite scons_p_head *)

         | [|- context[(?s .: ?sigma) var_zero]] => change ((s.:sigma) var_zero) with s
         | [|- context[(?s .: ?sigma) (shift ?m)]] => change ((s.:sigma) (shift m)) with (sigma m)

         | [|- context[idren >> ?f]] => change (idren >> f) with f
         | [|- context[?f >> idren]] => change (f >> idren) with f
         | [|- context[?f >> (?x .: ?g)]] => change (f >> (x .: g)) with g (* f should evaluate to shift *)
         (* the scons should always already be applied to an argument *)
         | [|- context[(?x2 .: (fun x => ?f (shift x))) ?y]] => change ((scons x2 (fun x => f (shift x))) y) with ((scons (f var_zero) (fun x => f (shift x))) y); rewrite (@scons_eta' _ _ f); idtac "scons_eta"
         | [|- context[(?f var_zero .: ?g) ?y]] => change ((scons (f var_zero) g) y) with ((scons (f var_zero) (fun x => f (shift x))) y); rewrite scons_eta'; idtac "scons_eta"
         (* we completely unfold funcomp *)
         (* |[|- _ =  ?h (?f ?s)] => change (h (f s)) with ((f >> h) s) *)
         (* |[|-  ?h (?f ?s) = _] => change (h (f s)) with ((f >> h) s) *)
         | [|- context[(scons ?s ?sigma) >> ?tau]] => rewrite scons_comp'; idtac "scons_comp"; eta_reduce
         | [|- context[scons (@var_zero ?n) shift]] => change (scons (@var_zero n) shift) with (fun x => (scons (@var_zero n) shift) x); rewrite scons_eta_id'; idtac "scons_eta_id"; eta_reduce
         | _ => progress autorewrite with FunctorInstances; idtac "autorewrite"
         end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
Ltac fsimplc :=
  repeat match goal with
         | [H: context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id]|- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s]|- _] => change (id s) with s in H
         | [H: context[comp ?f ?g]|- _] => change (comp f g) with (g >> f) in H (* AsimplCompIdL *)
         | [H: context[(?f >> ?g) >> ?h]|- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H (* AsimplComp *)
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) (shift ?m)]|- _] => change ((s.:sigma) (shift m)) with (sigma m) in H
                                                                                |[H : context[ _ =  ?h (?f ?s)]|- _] => change (h (f s)) with ((f >> h) s) in H
         (* |[H: context[?h (?f ?s) = _]|- _] => change (h (f s)) with ((f >> h) s) in H *)
         | [H: context[idren >> ?f]|- _] => change (idren >> f) with f in H
         | [H: context[?f >> idren]|- _] => change (f >> idren) with f in H
         | [H: context[?f >> (?x .: ?g)]|- _] =>
           change (f >> (x .: g)) with g in H
         (* | [H: context[?x2 .: shift >> ?f]|- _] => *)
         (*   change x2 with (f var_zero) in H; rewrite (@scons_eta _ _ f) in H *)
         (* | [H: context[?f var_zero .: ?g]|- _] => *)
           (* change g with (shift >> f) in H; rewrite scons_eta in H *)
         (* | _ => first [progress (rewrite scons_comp in * ) | progress (rewrite scons_eta_id in * ) | progress (autorewrite with FunctorInstances in * )] *)
         end.

(** Simplification in both the goal and the context *)
Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.

(* Hint Rewrite @scons_p_comp scons_p_head scons_p_tail : FunctorInstances. *)


Require Import Undecidability.Axioms.EA.
Require Import Undecidability.Shared.Pigeonhole.
Require Import Undecidability.Synthetic.FinitenessFacts.
Require Import Undecidability.Synthetic.reductions Undecidability.Synthetic.truthtables.
Require Import Undecidability.Synthetic.DecidabilityFacts Undecidability.Synthetic.SemiDecidabilityFacts.
Require Import Undecidability.Shared.ListAutomation.
Require Import List Arith.

Import ListNotations ListAutomationNotations.

Definition productive (p : nat -> Prop) := exists f : nat -> nat, forall c, (forall x, W c x -> p x) -> p (f c) /\ ~ W c (f c).

Lemma productive_nonenumerable p :
  productive p -> ~ enumerable p.
Proof.
  intros [f Hf] [c Hc] % W_spec.
  destruct (Hf c) as [H1 % Hc H2].
  eapply Hc. tauto.
Qed.

Lemma K0_productive :
  productive (compl K0).
Proof.
  exists (fun n => n). intros c H.
  specialize (H c). firstorder.
Qed.

Lemma productive_dedekind_infinite p :
  productive p -> dedekind_infinite p.
Proof.
  specialize List_id as [c_l c_spec]. intros [f Hf].
  eapply (weakly_generative_dedekind_infinite). econstructor.
  intros l.
  exists (f (c_l l)). intros Hl. split.
  - specialize (Hf (c_l l)).
    rewrite <- c_spec. eapply Hf.
    intros x. rewrite c_spec. eapply Hl.
  - eapply Hf. intros x. rewrite c_spec. eapply Hl.
Qed.

Lemma productive_subpredicate p :
  productive p ->
  exists q : nat -> Prop, enumerable q /\ dedekind_infinite q /\ (forall x, q x -> p x).
Proof.
  intros H.
  eapply dedekind_infinite_problem.
  eapply productive_dedekind_infinite. eauto.
Qed.

Lemma productive_red p q :
  p ⪯ₘ q -> productive p -> productive q.
Proof.
  intros [f Hf] [g Hg].
  specialize (SMN' f) as [k Hk].
  exists (fun c => f (g (k c))). intros c Hs.
  assert (Hkc : forall x, W (k c) x -> p x) by  (intros; now eapply Hf, Hs, Hk).
  split.
  - now eapply Hf, Hg.
  - intros ?. eapply Hg, Hk; eauto.
Qed.

Lemma many_one_complete_subpredicate p :
  m-complete p ->
  exists q : nat -> Prop, enumerable q /\ dedekind_infinite q /\ (forall x, q x -> compl p x).
Proof.
  intros Hcomp. eapply productive_subpredicate.
  eapply productive_red.
  - eapply red_m_complement. eapply Hcomp. eapply K0_enum.
  - eapply K0_productive.
Qed.

Definition simple (p : nat -> Prop) :=
  semi_decidable p /\ ~ exhaustible (compl p) /\ ~ exists q, semi_decidable q /\ ~ exhaustible q /\ (forall x, q x -> compl p x).

Lemma simple_non_semi_decidable p :
  simple p -> ~ semi_decidable (compl p).
Proof.
  intros (H1 & H2 & H3) H4.
  apply H3. eauto.
Qed.

Lemma simple_undecidable p :
  simple p -> ~ decidable p.
Proof.
  now intros ? ? % decidable_complement % decidable_semi_decidable % simple_non_semi_decidable.
Qed.

Lemma simple_m_incomplete p :
  simple p -> ~ m-complete p.
Proof.
  intros (H1 & H2 & H3) (q & Hq1 & Hq2 & Hq3) % many_one_complete_subpredicate.
  eapply H3. exists q; repeat split; eauto.
  - eapply enumerable_semi_decidable. eapply discrete_nat. eauto.
  - now eapply unbounded_non_finite, dedekind_infinite_unbounded.
Qed.

Lemma non_finite_non_empty {X} (p : X -> Prop) :
  ~ exhaustible p -> ~~ exists x, p x.
Proof.
  intros H1 H2. apply H1. exists []. firstorder.
Qed.

Lemma simple_no_cylinder p :
  (fun '((x, n) : nat * nat) => p x) ⪯₁ p -> ~ simple p.
Proof.
  intros [f [inj_f Hf]] (H1 & H2 & H3). red in Hf.
  apply (non_finite_non_empty _ H2). intros [x0 Hx0].
  apply H3.
  exists (fun x => exists n, x = f (x0, n)). split. 2:split.
  - exists (fun x n => Nat.eqb x (f (x0, n))).
    intros x. split; intros [n H]; exists n; destruct (Nat.eqb_spec x (f (x0, n))); firstorder congruence.
  - eapply unbounded_non_finite, dedekind_infinite_unbounded.
    exists (fun n => f (x0, n)). intros. split. eauto.
    now intros ? [=] % inj_f.
  - intros ? [n ->]. red. now rewrite <- (Hf (x0, n)).
Qed.


Require Import init.

Require Import zorn_real_base.
Require Import zorn_real_arch.
Require Import zorn_real_zorn.
Require Import zorn_real_quotient.

Require Import fraction_base.
Require Import fraction_plus.
Require Import fraction_mult.
Require Import fraction_order.
Require Import set.
Require Import polynomial_base.
Require Import ring_ideal.
Require Import nat.

Global Program Instance real_sup_complete : SupremumComplete le (U := real).
Next Obligation.
    rename H into a.
    rename H1 into Sa.
    destruct H0 as [b b_upper].
    pose (cut x := ¬is_upper_bound le S x).
    assert (cut_in : ∃ a, cut a).
    {
        exists (a - 1).
        intros a_upper.
        specialize (a_upper a Sa).
        rewrite <- le_plus_0_a_b_ba in a_upper.
        apply pos_neg in a_upper.
        rewrite neg_neg in a_upper.
        rewrite <- nlt_le in a_upper.
        apply a_upper.
        exact one_pos.
    }
    assert (cut_out : ∃ b, ¬cut b).
    {
        exists (b + 1).
        unfold cut.
        rewrite not_not.
        intros x Sx.
        specialize (b_upper x Sx).
        apply (trans b_upper).
        rewrite <- le_plus_0_a_b_ba.
        apply one_pos.
    }
    assert (cut_lt : ∀ l u, cut u → l ≤ u → cut l).
    {
        intros l u u_cut lu l_upper.
        apply u_cut.
        intros x Sx.
        specialize (l_upper x Sx).
        exact (trans l_upper lu).
    }
    pose (ZP := zorn_real_plus cut cut_in cut_out cut_lt).
    pose (ZPA := zorn_real_plus_assoc cut cut_in cut_out cut_lt).
    pose (ZPC := zorn_real_plus_comm cut cut_in cut_out cut_lt).
    pose (ZZ := zorn_real_zero cut cut_in cut_out cut_lt).
    pose (ZPZ := zorn_real_plus_lid cut cut_in cut_out cut_lt).
    pose (ZN := zorn_real_neg cut cut_in cut_out cut_lt).
    pose (ZPN := zorn_real_plus_linv cut cut_in cut_out cut_lt).
    pose (ZM := zorn_real_mult cut cut_in cut_out cut_lt).
    pose (ZL := zorn_real_ldist cut cut_in cut_out cut_lt).
    pose (ZMA := zorn_real_mult_assoc cut cut_in cut_out cut_lt).
    pose (ZMC := zorn_real_mult_comm cut cut_in cut_out cut_lt).
    pose (ZE := zorn_real_one cut cut_in cut_out cut_lt).
    pose (ZME := zorn_real_mult_lid cut cut_in cut_out cut_lt).
    pose (ZML := zorn_real_mult_lcancel cut cut_in cut_out cut_lt).
    pose (ZO := zorn_real_order cut cut_in cut_out cut_lt).
    pose (ZOC := zorn_real_order_le_connex cut cut_in cut_out cut_lt).
    pose (ZOA := zorn_real_order_le_antisym cut cut_in cut_out cut_lt).
    pose (ZOT := zorn_real_order_le_trans cut cut_in cut_out cut_lt).
    pose (ZOP := zorn_real_order_le_lplus cut cut_in cut_out cut_lt).
    pose (ZOM := zorn_real_order_le_mult cut cut_in cut_out cut_lt).
    pose (ZOML := zorn_real_order_le_mult_lcancel cut cut_in cut_out cut_lt).
    pose (ZT := zorn_real_quotient_not_trivial cut cut_in cut_out cut_lt).
    pose (ZA := zorn_real_quotient_arch cut cut_in cut_out cut_lt).
    pose (zrq := zorn_real_quotient cut cut_in cut_out cut_lt).
    pose (real_ext := frac zrq).
    pose (real_ext_not_trivial := frac_not_trivial zrq).
    pose (real_ext_plus := frac_plus zrq).
    pose (real_ext_plus_comm := frac_plus_comm zrq).
    pose (real_ext_plus_assoc := frac_plus_assoc zrq).
    pose (real_ext_zero := frac_zero zrq).
    pose (real_ext_plus_lid := frac_plus_lid zrq).
    pose (real_ext_neg := frac_neg zrq).
    pose (real_ext_plus_linv := frac_plus_linv zrq).
    pose (real_ext_mult := frac_mult zrq).
    pose (real_ext_mult_comm := frac_mult_comm zrq).
    pose (real_ext_mult_assoc := frac_mult_assoc zrq).
    pose (real_ext_ldist := frac_ldist zrq).
    pose (real_ext_one := frac_one zrq).
    pose (real_ext_mult_lid := frac_mult_lid zrq).
    pose (real_ext_div := frac_div zrq).
    pose (real_ext_mult_linv := frac_mult_linv zrq).
    pose (real_ext_order := frac_order zrq).
    pose (real_ext_le_connex := frac_le_connex zrq).
    pose (real_ext_le_antisym := frac_le_antisym zrq).
    pose (real_ext_le_trans := frac_le_trans zrq).
    pose (real_ext_le_lplus := frac_le_lplus zrq).
    pose (real_ext_le_mult := frac_le_mult zrq).
    pose (real_ext_arch := frac_arch zrq).
    pose (real_ext_aof := aof_ex real_ext).
    pose (PL := polynomial_ldist real_cring).
    pose proof (real_maximal real_ext_aof) as f_ex.
    cbn in f_ex.
    change (set_type (aof_set real_aof)) with real in f_ex.
    pose (f1 (x : real) := to_polynomial real_cring x).
    pose (f2 (x : polynomial real_cring) := to_qring
                    (zorn_real_ideal cut cut_in cut_out cut_lt) x : zrq).
    pose (f3 (x : zrq) := to_frac zrq x).
    pose (f4 (x : frac zrq) := aof_ex_f x).
    pose (f x := f4 (f3 (f2 (f1 x)))).
    assert (arch_ordered_homo real_aof real_ext_aof f) as f_homo.
    {
        unfold f, f1, f2, f3, f4.
        split; [>|split; [>|split; [>|split]]].
        -   rewrite to_polynomial_zero.
            rewrite to_qring_zero.
            rewrite to_frac_zero.
            reflexivity.
        -   rewrite to_polynomial_one.
            rewrite to_qring_one.
            rewrite to_frac_one.
            reflexivity.
        -   intros x y.
            rewrite to_polynomial_plus.
            rewrite to_qring_plus.
            rewrite to_frac_plus.
            unfold plus at 2; cbn.
            do 2 rewrite aof_ex_f_eq1.
            reflexivity.
        -   intros x y.
            rewrite to_polynomial_mult.
            rewrite to_qring_mult.
            rewrite to_frac_mult.
            unfold mult at 2; cbn.
            do 2 rewrite aof_ex_f_eq1.
            reflexivity.
        -   intros x y xy.
            unfold le; cbn.
            do 2 rewrite aof_ex_f_eq1.
            apply to_frac_le.
            1: exact ZOA.
            1: exact ZOT.
            apply (land (zorn_real_quotient_le _ _ _ _ _ _)).
            apply zorn_real_q_le_to_poly.
            exact xy.
    }
    prove_parts f_ex.
    {
        exists f.
        exact f_homo.
    }
    destruct f_ex as [f5 f5_homo].
    assert (∀ x, x = f5 (f x)) as f_eq.
    {
        intros x.
        assert ((λ x, f5 (f x)) = identity) as f_eq.
        {
            apply arch_ordered_homo_identity.
            apply (arch_ordered_homo_compose real_aof real_ext_aof real_aof).
            -   exact f_homo.
            -   exact f5_homo.
        }
        change x with (identity x) at 1.
        rewrite <- f_eq.
        reflexivity.
    }
    pose (α := f5 (f4 (f3 (f2 (polynomial_x real_cring))))).
    exists α.
    assert (∀ x y, zorn_real_q_le cut cut_in cut_out cut_lt x y →
        f5 (f4 (f3 (f2 x))) ≤ f5 (f4 (f3 (f2 y)))) as f_le.
    {
        intros x y xy.
        rewrite <- (arch_ordered_homo_le _ _ _ f5_homo).
        unfold f4, le; cbn.
        do 2 rewrite aof_ex_f_eq1.
        apply to_frac_le.
        1: exact ZOA.
        1: exact ZOT.
        apply (land (zorn_real_quotient_le _ _ _ _ _ _)).
        exact xy.
    }
    assert (∀ x, ¬is_upper_bound le S x → x ≤ α) as α_ge.
    {
        intros x x_nupper.
        unfold α.
        rewrite (f_eq x).
        apply f_le.
        apply zorn_real_q_le_in.
        exact x_nupper.
    }
    assert (∀ x, is_upper_bound le S x → α ≤ x) as α_le.
    {
        intros x x_upper.
        unfold α.
        rewrite (f_eq x).
        apply f_le.
        apply zorn_real_q_le_out.
        unfold cut.
        rewrite not_not.
        exact x_upper.
    }
    split.
    -   intros x Sx.
        classic_case (is_upper_bound le S x) as [x_upper|x_nupper].
        2: exact (α_ge _ x_nupper).
        classic_contradiction ltq.
        specialize (α_ge ((x + α) / 2)).
        prove_parts α_ge.
        {
            intros upper.
            specialize (upper x Sx).
            rewrite rdist in upper.
            rewrite le_plus_rlmove in upper.
            rewrite <- (plus_half x) in upper at 2.
            rewrite plus_llinv in upper.
            apply le_mult_rcancel_pos in upper.
            2: apply div_pos; exact two_pos.
            contradiction.
        }
        rewrite rdist in α_ge.
        rewrite le_plus_lrmove in α_ge.
        rewrite <- (plus_half α) in α_ge at 1.
        rewrite plus_rrinv in α_ge.
        apply le_mult_rcancel_pos in α_ge.
        2: apply div_pos; exact two_pos.
        contradiction.
    -   intros y y_upper.
        apply α_le.
        exact y_upper.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e383m421_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(************************************************************************)
(** * Documentation *)

(**

  - doc/overview.txt (the present file) gives a tour of the key
    features of TLC.

  - doc/conventions.txt describes the naming conventions in use.

  - doc/files.txt gives the list of files that have been cleaned up
    according to the new conventions and that compile in v8.6.

    DISCLAIMER: only the files marked "stable" in "doc/StableFiles.txt"
    have been cleaned up to compile in v8.6 and follow the new conventions.

*)

(************************************************************************)
(** * Tactics *)

(** TLC exports a bunch of tactics, to enhance and complete those provided
    by default. All tactics are implemented in Ltac. Native implementation
    would certainly allow clearer and more efficient implementations.

    - most tactics are defined in [LibTactics.v],
    - a couple of tactics are generalized later in other files (grep for "::="),
    - a bunch of tactics are defined in other files (grep for "Ltac"),
      mainly decision procedures for tautologies, inequalities, set equalities,...

*)

(************************************************************************)
(** * Organization of the files *)

(** Appart from LibTactics, the main files are organized as follows:

  Logic

     LibAxioms
     LibEqual
     LibLogic
     LibOperation
     LibReflect
     LibEpsilon
     LibChoice
     LibOperation
     LibWf
     LibFix

  Base datatypes

     LibBool
     LibProd
     LibSum
     LibUnit
     LibOption
     LibString
     LibInt
     LibNat
     LibList*

  Relations and structures

     LibRelation
     LibMonoid
     LibOrder
     LibMin

  Containers

     LibContainer
     LibSet
     LibMap
     ...

*)

(************************************************************************)
(** * Logic *)

(** TLC relies on classical logic. The file [LibAxiom.v] exports 3 axioms:
    - functional extensionality (dependent version)
    - propositional extensionality
    - indefinite description.

    All other classical logic results are derived from these axioms.
    See files [LibLogic.v], [LibEqual.v], [LibChoice] and [LibEpsilon.v].

    In particular, [LibLogic] exports strong classical logic, for deciding
    the truth of an arbitrary proposition.
*)

Lemma classicT : forall (P : Prop), {P} + {~ P}.

(** In practice, we use the notation [If P then v1 else v2] for introducing
    conditionals over propositions. *)

Notation "'If' P 'then' v1 'else' v2" :=
  (if (classicT P) then v1 else v2)
  (at level 200, right associativity) : type_scope.

(************************************************************************)
(** * Inhabited types *)

(** Inhabited types are very useful for two purposes:
    - to not overspecify the result of a partial function,
    - to apply the epsilon operator, e.g. to take the minimum of a set
      without providing a proof on the call site a proof that this set
      is nonempty,
    - to invoke the optimal fixed point combinator provided by TLC,
      in order to show that the return type of a partial function is
      inhabited.

    The typeclass is defined as follows, in the classic way.
*)

Class Inhab (A:Type) : Prop :=
  { Inhab_intro : (exists (x:A), True) }.

(** All usual types are proved inhabited. *)

Instance Inhab_list : forall A, Inhab (list A).
Proof using. intros. apply (Inhab_of_val nil). Qed.

(** The value [arbitrary] can be used as a dummy value at any place
    where a value of an inhabited type is expected. This definition
    relies on the indefinite description axiom to turn the [exists]
    into a strong existential. *)

Definition arbitrary `{Inhab A} : A :=
  sig_val (@indefinite_description A _ Inhab_intro).

(** A partial function, such as [List.nth], is defined only over
    inhabited types. Its result for invalid indices is specified
    to be equal to the [arbitrary] value of that type. *)

Fixpoint nth_def A (d:A) (n:nat) (l:list A) : A :=
  match l with
  | nil => d
  | x::l' =>
     match n with
     | 0 => x
     | S n' => nth_def d n' l'
     end
  end.

Definition nth `{IA:Inhab A} :=
  nth_def arbitrary.

(************************************************************************)
(** * Dependent types *)

(** TLC tries to avoid dependent types altogether. Let's be precise, thought:

    - Proof terms involve dependently-typed terms. But these are not meant
      to be written or read.
    - Strong sum, e.g. {P} + {~ P}, involves a dependent type, but TLC
      uses strong sums only in the statement of the [classicT] lemma.
    - Type-classes involve dependent types, but we view type-class as a
      simpler mechanism than general dependently-typed programming.

    In Coq in general, dependently-typed programming is sometimes unavoidable,
    e.g. for definining tricky partial recursive functions. However, thanks
    to classical logic and the use of the optimal fixed point combinator
    defined in [LibFix.v], we are able to define such functions without the
    need for dependent types.

*)

(************************************************************************)
(** * From boolean to propositions and back *)

(** In that classical logic setting, boolean and propositions become
    essentially isomorphic. On the one hand, any boolean can be viewed
    as a proposition, via the coercion [istrue]. *)

Coercion istrue (b : bool) : Prop := (b = true).

(** Reciprocally, any proposition can be turned into a boolean, using
    the operator [isTrue]. *)

Definition isTrue (P : Prop) : bool :=
  If P then true else false.

(** We illustrate the use of these two combinators in the context of
    specifying programs in Separation Logic. First, we show that it
    is useful to assert that the boolean output value of a function
    is equal to the boolean associated with the proposition [L = nil]. *)

Lemma is_empty_spec : forall (s:loc) (L:list A),
  app is_empty [s]
    PRE (s ~> Stack L)
    POST (fun (b:bool) => (s ~> Stack L) \* \[b = isTrue (L = nil)]).

(** The postcondition could also be stated [istrue b = (L = nil)],
    however the form [b = isTrue (L = nil)] is much more interesting
    because it allows for immediately substituting away [b] using
    the [subst] tactic. *)

(** The coercion [istrue] is probably less fundamental. It saves some
    noise. Consider the verification of an ML program of form
    [if b1 && !b2 then t1 else t2]. In the first branch of its analysis,
    it is convenient to view the assumption [b1 && !b2] instead of
    [(b1 && !b2) = true]. Moreover, the existence of a named coercion
    [istrue (b1 && !b2)] helps guiding the autorewrite tactic [rew_istrue]
    that we use to normalize the expression to [istrue b1 /\ ~ istrue b2],
    which is displayed as [b1 /\ ~ b2]. *)

(************************************************************************)
(** * Simplification by normalizing rewrite operations *)

(** In TLC, the [simpl] tactic is used as little as possible, for two
    reasons. First, its behavior is unspecified and is hard to control
    in practice. Often, one ends up with too much unfolding. Second,
    [simpl] does not work on operators that come from functor argumetns
    or that we wish to make abstract.

    Instead, TLC relies heavily on simplification by iterated rewriting,
    using the [autorewrite] tactic. For example, [rew_list] is a tactic
    for normalizing [list] operations, with respect to a base of rewriting
    lemma. The rule is that the set of lemmas in a rewriting base should
    always be terminating and (whenever possible) confluent. This makes
    the rewriting tactic robust with respect to the order in which the
    rewriting lemmas are considered. *)

Hint Rewrite app_cons_l app_nil_l app_nil_r app_assoc
  app_cons_one_r length_nil length_cons length_app ... : rew_list.

(** It is very unfortunate that, in the current version of Coq, we need
    to manually define shorthands for each rewriting base...
    Fortunately, a patch or plugin could easily resolve the issue. *)

Tactic Notation "rew_list" :=
  autorewrite with rew_list.
Tactic Notation "rew_list" "in" "*" :=
  autorewrite with rew_list in *.
Tactic Notation "rew_list" "in" hyp(H) :=
  autorewrite with rew_list in H.

(************************************************************************)
(** * Executable versions of definitions *)

(** TLC makes no effort at providing definitions that compute within Coq.
    We believe that such attempt is doomed.
    - Definitions that compute (or compute efficiently) are usually more
      complex than their non-constructive counterpart; yet, we'd like our
      definitions to always be as simple as possible, especially when they
      are part of the trusted base.
    - The ability to compute may require additional arguments, e.g. a
      comparison relation for sets, making the structure very heavy to use
      (when not impossible to use, e.g. a set defined as a functor prevents
      the specification of a polymorphic-recursive function in terms of a set),
      and drifting far away from standard mathematics.
    - For some partial recursive functions, the only way to define a computable
      function is to involve dependent types, for justifying termination on the
      domain. In the end, the function obtained computes very inefficiently.
      One would rather have a clean non-computable function, and a
      provably-equivalent function that simply caps its recursion depth.
*)

(** The plan (which is not yet implemented inside TLC) is that for every
    function, one may define a computable counterpart, either by hand or
    using the help of some generator. Such generator may be implemented
    using typeclasses, thought with some limitations, or may be implemented
    as a external plugin (as done e.g. in Isabelle/HOL).

    For example, [LibList.mem x l] is an inductively-defined proposition
    indicating whether the list [l] contains the element [x]. And
    [LibListX.mem x l] is a function that computes a boolean value
    indicating whether [x] belongs to [l], assuming the type of the elements
    feature a boolean comparison function for deciding equality.
    The lemma [LibListX.mem_eq] asserts:
    [forall `{Comparable A} (x:A) (l:list A),
      LibListX.mem_eq x l = isTrue (LibList.mem x l)]

    This lemmas allows to reason about code that computes using the executable
    version, using all the lemmas that hold about the logical function.
*)

(************************************************************************)
(** * Overloading *)

(** Overloading of operators is implemented using typeclasses,
    in particular for:
    - comparison operators (e.g. le, gt, etc...)
    - container operations (e.g. union, read in a map, etc..)

    and typeclasses are also used for all lemmas about these operations.

    In the long run, we plan to also use typeclasses for base types
    such as [nat] and [int]. However, due to inefficiencies in the
    current support for typeclasses, it would be too slow to use
    typeclasses in the current version of Coq for describing all basic
    arithmetic expressions. Thus, we stick to the traditional Coq
    approach, which is to rely on the scope mechanism to overload
    arithmetic operators.

*)

(************************************************************************)
(** * Order relations *)

(** See [LibOrder.v] and [LibSet.v] *)

(************************************************************************)
(** * Containers *)

(** See [LibContainer.v] and [Lib] *)

(************************************************************************)
(** * Fixed points *)

(** See [LibFixDemos.v] and [LibFix.v] and the corresponding paper. *)


(*** Tactics for manipulating polynomial equations *)
Require Coq.nsatz.Nsatz.
Require Import Coq.Lists.List.

Generalizable All Variables.
Lemma cring_sub_diag_iff {R zero eq sub} `{cring:Cring.Cring (R:=R) (ring0:=zero) (ring_eq:=eq) (sub:=sub)}
  : forall x y, eq (sub x y) zero <-> eq x y.
Proof.
  split;intros Hx.
  { eapply Nsatz.psos_r1b. eapply Hx. }
  { eapply Nsatz.psos_r1. eapply Hx. }
Qed.

Ltac get_goal := lazymatch goal with |- ?g => g end.

Ltac nsatz_equation_implications_to_list eq zero g :=
  lazymatch g with
  | eq ?p zero => constr:(p::nil)
  | eq ?p zero -> ?g => let l := nsatz_equation_implications_to_list eq zero g in constr:(p::l)
  end.

Ltac nsatz_reify_equations eq zero :=
  let g := get_goal in
  let lb := nsatz_equation_implications_to_list eq zero g in
  lazymatch (eval red in (Ncring_tac.list_reifyl (lterm:=lb))) with
    (?variables, ?le) =>
    lazymatch (eval compute in (List.rev le)) with
    | ?reified_goal::?reified_givens => constr:((variables, reified_givens, reified_goal))
    end
  end.

Ltac nsatz_get_free_variables reified_package :=
  lazymatch reified_package with (?fv, _, _) => fv end.

Ltac nsatz_get_reified_givens reified_package :=
  lazymatch reified_package with (_, ?givens, _) => givens end.

Ltac nsatz_get_reified_goal reified_package :=
  lazymatch reified_package with (_, _, ?goal) => goal end.

Require Import Coq.setoid_ring.Ring_polynom.
(* Kludge for 8.4/8.5 compatibility *)
Module Import mynsatz_compute.
  Import Nsatz.
  Global Ltac mynsatz_compute x := nsatz_compute x.
End mynsatz_compute.
Ltac nsatz_compute x := mynsatz_compute x.

Ltac nsatz_compute_to_goal sugar nparams reified_goal power reified_givens :=
  nsatz_compute (PEc sugar :: PEc nparams :: PEpow reified_goal power :: reified_givens).

Ltac nsatz_compute_get_leading_coefficient :=
  lazymatch goal with
    |- Logic.eq ((?a :: _ :: ?b) :: ?c) _ -> _ => a
  end.

Ltac nsatz_compute_get_certificate :=
  lazymatch goal with
    |- Logic.eq ((?a :: _ :: ?b) :: ?c) _ -> _ => constr:((c,b))
  end.

Ltac nsatz_rewrite_and_revert domain :=
  lazymatch type of domain with
  | @Integral_domain.Integral_domain ?F ?zero _ _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
    lazymatch goal with
    | |- eq _ zero => idtac
    | |- eq _ _ => rewrite <-(cring_sub_diag_iff (cring:=FCring))
    end;
    repeat match goal with
           | [H : eq _ zero |- _ ] => revert H
           | [H : eq _ _ |- _ ] => rewrite <-(cring_sub_diag_iff (cring:=FCring)) in H; revert H
           end
  end.

(** As per https://coq.inria.fr/bugs/show_bug.cgi?id=4851, [nsatz]
    cannot handle duplicate hypotheses.  So we clear them. *)
Ltac nsatz_clear_duplicates_for_bug_4851 domain :=
  lazymatch type of domain with
  | @Integral_domain.Integral_domain _ _ _ _ _ _ _ ?eq _ _ _ =>
    repeat match goal with
           | [ H : eq ?x ?y, H' : eq ?x ?y |- _ ] => clear H'
           end
  end.

Ltac nsatz_nonzero :=
  try solve [apply Integral_domain.integral_domain_one_zero
            |apply Integral_domain.integral_domain_minus_one_zero
            |trivial
            |assumption].

Ltac nsatz_domain_sugar_power domain sugar power :=
  let nparams := constr:(BinInt.Zneg BinPos.xH) in (* some symbols can be "parameters", treated as coefficients *)
  lazymatch type of domain with
  | @Integral_domain.Integral_domain ?F ?zero _ _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
    nsatz_clear_duplicates_for_bug_4851 domain;
    nsatz_rewrite_and_revert domain;
    let reified_package := nsatz_reify_equations eq zero in
    let fv := nsatz_get_free_variables reified_package in
    let interp := constr:(@Nsatz.PEevalR _ _ _ _ _ _ _ _ Fops fv) in
    let reified_givens := nsatz_get_reified_givens reified_package in
    let reified_goal := nsatz_get_reified_goal reified_package in
    nsatz_compute_to_goal sugar nparams reified_goal power reified_givens;
    let a := nsatz_compute_get_leading_coefficient in
    let crt := nsatz_compute_get_certificate in
    intros _ (* discard [nsatz_compute] output *); intros;
    apply (fun Haa refl cond => @Integral_domain.Rintegral_domain_pow _ _ _ _ _ _ _ _ _ _ _ domain (interp a) _ (BinNat.N.to_nat power) Haa (@Nsatz.check_correct _ _ _ _ _ _ _ _ _ _ FCring fv reified_givens (PEmul a (PEpow reified_goal power)) crt refl cond));
    [ nsatz_nonzero; cbv iota beta delta [Nsatz.PEevalR PEeval InitialRing.gen_phiZ InitialRing.gen_phiPOS]
    | solve [vm_compute; exact (eq_refl true)] (* exact_no_check (eq_refl true) *)
    | solve [repeat (split; [assumption|]); exact I] ]
  end.

Ltac nsatz_guess_domain :=
  match goal with
  | |- ?eq _ _ => constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  | |- not (?eq _ _) =>  constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  | [H: ?eq _ _ |- _ ] =>  constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  | [H: not (?eq _ _) |- _] =>  constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  end.

Ltac nsatz_sugar_power sugar power :=
  let domain := nsatz_guess_domain in
  nsatz_domain_sugar_power domain sugar power.

Ltac nsatz_power power :=
  let power_N := (eval compute in (BinNat.N.of_nat power)) in
  nsatz_sugar_power BinInt.Z0 power_N.

Ltac nsatz := nsatz_power 1%nat.

Tactic Notation "nsatz" := nsatz.
Tactic Notation "nsatz" constr(n) := nsatz_power n.

(** If the goal is of the form [?x <> ?y] and assuming [?x = ?y]
    contradicts any hypothesis of the form [?x' <> ?y'], we turn this
    problem about inequalities into one about equalities and give it
    to [nsatz]. *)
Ltac nsatz_contradict_single_hypothesis domain :=
  lazymatch type of domain with
  | @Integral_domain.Integral_domain _ ?zero ?one _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
    unfold not in *;
    match goal with
    | [ H : eq _ _ -> False |- eq _ _ -> False ]
      => intro; apply H; nsatz
    | [ H : eq _ _ -> False |- False ]
      => apply H; nsatz
    end
  end.

Ltac nsatz_contradict :=
  let domain := nsatz_guess_domain in
  nsatz_contradict_single_hypothesis domain
  || (unfold not;
      intros;
      lazymatch type of domain with
      | @Integral_domain.Integral_domain _ ?zero ?one _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
        assert (eq one zero) as Hbad;
        [nsatz; nsatz_nonzero
        |destruct (Integral_domain.integral_domain_one_zero (Integral_domain:=domain) Hbad)]
      end).