Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Arithmetic.MontgomeryReduction.Proofs. (* For MontgomeryReduction *)
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tuple Crypto.Util.Prod Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Crypto.Util.ZUtil.Log2.
Require Import Crypto.Util.ZUtil.AddGetCarry Crypto.Util.ZUtil.MulSplit.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.ZUtil.Definitions.
Import Coq.Lists.List ListNotations. Local Open Scope Z_scope.

Section primitives.
  Definition mulx (bitwidth : Z) := Eval cbv [Z.mul_split_at_bitwidth] in Z.mul_split_at_bitwidth bitwidth.
  Definition addcarryx (bitwidth : Z) := Eval cbv [Z.add_with_get_carry Z.add_with_carry Z.get_carry] in Z.add_with_get_carry bitwidth.
  Definition subborrowx (bitwidth : Z) := Eval cbv [Z.sub_with_get_borrow Z.sub_with_borrow Z.get_borrow Z.get_carry Z.add_with_carry] in Z.sub_with_get_borrow bitwidth.
  Definition cmovznz (bitwidth : Z) (cond : Z) (z nz : Z)
    := dlet t := (0 - Z.bneg (Z.bneg cond)) mod 2^bitwidth in Z.lor (Z.land (Z.value_barrier t) nz) (Z.land (Z.value_barrier (Z.lnot_modulo t (2^bitwidth))) z).
  Definition cmovznz_by_mul (bitwidth : Z) (cond : Z) (z nz : Z)
    := dlet t := cond * (2^bitwidth - 1) in Z.lor (Z.land (Z.value_barrier t) nz) (Z.land (Z.value_barrier (Z.lnot_modulo t (2^bitwidth))) z).

  Lemma mulx_correct (bitwidth : Z)
        (x y : Z)
    : mulx bitwidth x y = ((x * y) mod 2^bitwidth, (x * y) / 2^bitwidth).
  Proof using Type.
    change mulx with Z.mul_split_at_bitwidth.
    rewrite <- Z.mul_split_at_bitwidth_div, <- Z.mul_split_at_bitwidth_mod; eta_expand.
    eta_expand; reflexivity.
  Qed.

  Lemma addcarryx_correct (bitwidth : Z)
        (c x y : Z)
    : addcarryx bitwidth c x y = ((c + x + y) mod 2^bitwidth, (c + x + y) / 2^bitwidth).
  Proof using Type.
    cbv [addcarryx Let_In]; reflexivity.
  Qed.

  Lemma subborrowx_correct (bitwidth : Z)
        (b x y : Z)
    : subborrowx bitwidth b x y = ((-b + x + -y) mod 2^bitwidth, -((-b + x + -y) / 2^bitwidth)).
  Proof using Type.
    cbv [subborrowx Let_In]; reflexivity.
  Qed.

  Lemma cmovznz_correct bitwidth cond z nz
    : 0 <= z < 2^bitwidth
      -> 0 <= nz < 2^bitwidth
      -> cmovznz bitwidth cond z nz = Z.zselect cond z nz.
  Proof using Type.
    intros.
    assert (0 < 2^bitwidth) by lia.
    assert (0 <= bitwidth) by auto with zarith.
    assert (0 < bitwidth -> 1 < 2^bitwidth) by auto with zarith.
    pose proof Z.log2_lt_pow2_alt.
    assert (bitwidth = 0 \/ 0 < bitwidth) by lia.
    repeat first [ progress cbv [cmovznz Z.zselect Z.bneg Let_In Z.lnot_modulo]
                 | progress split_iff
                 | progress subst
                 | progress Z.ltb_to_lt
                 | progress destruct_head'_or
                 | congruence
                 | lia
                 | progress break_innermost_match_step
                 | progress break_innermost_match_hyps_step
                 | progress autorewrite with zsimplify_const in *
                 | progress pull_Zmod
                 | progress intros
                 | rewrite !Z.sub_1_r, <- Z.ones_equiv, <- ?Z.sub_1_r
                 | rewrite Z_mod_nz_opp_full by (Z.rewrite_mod_small; lia)
                 | rewrite (Z.land_comm (Z.ones _))
                 | rewrite Z.land_ones_low by auto with lia
                 | progress Z.rewrite_mod_small ].
  Qed.

  Lemma cmovznz_by_mul_correct bitwidth cond z nz
    : 0 <= cond < 2^1
      -> 0 <= z < 2^bitwidth
      -> 0 <= nz < 2^bitwidth
      -> cmovznz_by_mul bitwidth cond z nz = Z.zselect cond z nz.
  Proof using Type.
    intros.
    assert (0 < 2^bitwidth) by lia.
    assert (0 <= bitwidth) by auto with zarith.
    assert (0 < bitwidth -> 1 < 2^bitwidth) by auto with zarith.
    pose proof Z.log2_lt_pow2_alt.
    assert (bitwidth = 0 \/ 0 < bitwidth) by lia.
    assert (cond = 0 \/ cond = 1) by lia.
    repeat first [ progress cbv [cmovznz_by_mul Z.zselect Let_In Z.lnot_modulo Z.lnot Z.pred]
                 | progress split_iff
                 | progress subst
                 | progress Z.ltb_to_lt
                 | progress destruct_head'_or
                 | congruence
                 | lia
                 | progress break_innermost_match_step
                 | progress break_innermost_match_hyps_step
                 | progress autorewrite with zsimplify_const in *
                 | progress (push_Zmod; pull_Zmod)
                 | progress intros
                 | rewrite !Z.sub_1_r, <- Z.ones_equiv, <- ?Z.sub_1_r
                 | rewrite Z_mod_nz_opp_full by (Z.rewrite_mod_small; lia)
                 | rewrite (Z.land_comm (Z.ones _))
                 | rewrite Z.land_ones_low by auto with lia
                 | progress Z.rewrite_mod_small
                 | replace (-Z.ones bitwidth + -1) with (-2^bitwidth) by (rewrite Z.ones_equiv, <- Z.sub_1_r; lia) ].
  Qed.
End primitives.


Require Import Coq.Init.Datatypes.
Require Import Coq.Program.Tactics.
Import Coq.Init.Notations.
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Require Import univalence.
Require Import equivalences.
Require Import equivalencesDefinitions.
Require Import propositionsSets.

Section prodStrictlyAssoc.
Search prod.

(*  the proof of the following Lemma is at
    the end of equivalences.v. *)
Definition halfAdjointEquivImpliesContractible {X Y:Type}
  (f:X->Y):
  HalfAdjointEquiv f -> IsContractibleMap f.
Proof.
Admitted.

Definition associator (X Y Z:Type):
  (prod (prod X Y) Z) -> (prod X (prod Y Z)).
Proof.
  intro. induction X0. induction a.
  apply (a,(b0,b)).
Defined.

Definition associatorInverse (X Y Z:Type):
  (prod X (prod Y Z)) -> (prod (prod X Y) Z).
Proof.
(* define the inverse to the associator here *)
Defined.

Definition assocIsInv {X Y Z:Type} (v:(prod X (prod Y Z))):
  Id (associator X Y Z (associatorInverse X Y Z v)) v.
Proof.
(* your proof here *)
Defined.

Definition assocIsInv2 {X Y Z:Type} (v:prod (prod X Y) Z):
  Id (associatorInverse X Y Z (associator X Y Z v)) v.
Proof.
(* your proof here *)
Defined.

Definition associatorIsEquiv {X Y Z:Type}:
  IsContractibleMap (associator X Y Z).
Proof.
(* your proof here - use the fact that haequiv are contractible maps *)
Defined.

Lemma productStrictlyAssoc {X Y Z:Type}:
  Id (prod (prod X Y) Z) (prod X (prod Y Z)).
Proof.
(* your proof here *)
Defined.

End prodStrictlyAssoc.


Require Import CT.Category.
Require Import CT.Functor.
Require Import CT.Instance.Category.ProductCategory.
Require Import CT.Instance.Functor.Endofunctor.

(** [F : AxB -> C]. _Bifunctors_ are functors from a product category to another
    category. These (or rather their specialized form [ProductFunctor]) show up
    as tensors in [MonoidalCategory] instances.
*)
Program Definition Bifunctor (A B C : Category) := Functor (ProductCategory A B) C.

(* TODO: Explain this better. *)
(** Given two morphisms \(f, g\), do the "right thing" by applying them to
    the first and second components on both ends of a morphism respectively,
    thus lifting it into the codomain category of the given (implicit)
    functor. *)
Definition bimap
           {A B C : Category}
           {F : Bifunctor A B C}
           {a b : ob A}
           {c d : ob B}
           (f : mor a b)
           (g : mor c d) :
  mor (F_ob F (a, c)) (F_ob F (b, d)) :=
  @F_mor (ProductCategory A B) C F (a, c) (b, d) (f, g).

(* TODO: Write a bunch of theorems about bimap. *)


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2008-08-08

boolean functions on lists
*)

Set Implicit Arguments.

From Coq Require Import Arith Lia.
From CoLoR Require Import ListUtil BoolUtil EqUtil LogicUtil.

Section S.

  Variables (A : Type) (beq : A -> A -> bool)
            (beq_ok : forall x y, beq x y = true <-> x = y).

  Ltac case_beq := EqUtil.case_beq beq beq_ok.

(***********************************************************************)
(** boolean decidability of equality *)

  Fixpoint beq_list (l m : list A) :=
    match l, m with
    | nil, nil => true
    | x :: l', y :: m' => beq x y && beq_list l' m'
    | _, _ => false
    end.

  Lemma beq_list_refl : forall l, beq_list l l = true.

  Proof. induction l; simpl. refl. rewrite IHl, (beq_refl beq_ok). refl. Qed.

  Lemma beq_list_ok : forall l m, beq_list l m = true <-> l = m.

  Proof.
    induction l; destruct m; simpl; split; intro; try (refl || discr).
    destruct (andb_elim H). rewrite beq_ok in H0. subst a0.
    rewrite IHl in H1. subst m. refl.
    inversion H. subst a0. subst m. apply andb_intro.
    rewrite beq_ok. refl. rewrite IHl. refl.
  Qed.

  (*REMARK: this lemma does not use beq_ok *)
  Lemma beq_list_ok_in : forall l,
      forall hyp : forall x, In x l -> forall y, beq x y = true <-> x = y,
        forall m, beq_list l m = true <-> l = m.

  Proof.
    induction l; destruct m; split; intro; try (refl || discr).
    inversion H. destruct (andb_elim H1).
    assert (h : In a (a::l)). simpl. auto.
    ded (hyp _ h a0). rewrite H3 in H0. subst a0.
    apply tail_eq.
    assert (hyp' : forall x, In x l -> forall y, beq x y = true <-> x=y).
    intros x hx. apply hyp. simpl. auto.
    destruct (andb_elim H1). ded (IHl hyp' m). rewrite H5 in H4. exact H4.
    rewrite <- H. simpl. apply andb_intro.
    assert (h : In a (a::l)). simpl. auto.
    ded (hyp _ h a). rewrite H0. refl.
    assert (hyp' : forall x, In x l -> forall y, beq x y = true <-> x=y).
    intros x hx. apply hyp. simpl. auto.
    ded (IHl hyp' l). rewrite H0. refl.
  Qed.

(***********************************************************************)
(** membership *)

  Fixpoint mem (x : A) (l : list A) : bool :=
    match l with
    | nil => false
    | y :: m => beq x y || mem x m
    end.

  Lemma mem_ok x : forall l, mem x l = true <-> In x l.

  Proof.
    induction l; simpl; intros; auto. intuition. split; intro.
    destruct (orb_true_elim H). rewrite beq_ok in e. subst. auto. intuition.
    destruct H. subst. rewrite (beq_refl beq_ok). refl. intuition.
  Qed.

(***********************************************************************)
(** inclusion *)

  Fixpoint incl (l l' : list A) : bool :=
    match l with
    | nil => true
    | y :: m => mem y l' && incl m l'
    end.

  Lemma incl_ok : forall l l', incl l l' = true <-> l [= l'.

  Proof.
    induction l; simpl; intros; auto. intuition. apply incl_nil. split; intro.
    destruct (andb_elim H). rewrite mem_ok in H0. rewrite IHl in H1. intuition.
    destruct (incl_cons_l H). rewrite <- mem_ok in H0. rewrite <- IHl in H1.
    rewrite H0, H1. refl.
  Qed.

(***********************************************************************)
(** position of an element in a list *)

  Fixpoint position_aux (i : nat) (x : A) (l : list A) : option nat :=
    match l with
    | nil => None
    | y :: m => if beq x y then Some i else position_aux (S i) x m
    end.

  Definition position := position_aux 0.

  Lemma position_ko : forall x l, position x l = None <-> ~In x l.

  Proof.
    unfold position. cut (forall x l i, position_aux i x l = None <-> ~In x l).
    auto. induction l; simpl; intros. intuition. case_beq x a.
    intuition; discr. rewrite (beq_ko beq_ok) in H. ded (IHl (S i)). intuition.
  Qed.

  Lemma position_aux_plus x j k : forall l i,
      position_aux i x l = Some k -> position_aux (i+j) x l = Some (k+j).

  Proof.
    induction l; simpl. discr. case_beq x a; intros. inversion H.
    refl. assert (S(i+j) = S i+j). refl. rewrite H1. apply IHl. hyp.
  Qed.

  Lemma position_aux_S x k : forall l i,
      position_aux i x l = Some k -> position_aux (S i) x l = Some (S k).

  Proof.
    induction l; simpl. discr. case_beq x a; intros. inversion H.
    refl. apply IHl. hyp.
  Qed.

  Lemma position_aux_ok1 k x : forall l i,
      position_aux i x l = Some k -> k >= i /\ element_at l (k-i) = Some x.

  Proof.
    induction l; simpl. discr. case_beq x a. intros. inversion H.
    rewrite <- minus_n_n. intuition. destruct l. simpl. discr. intros.
    ded (IHl _ H0). assert (exists p', k - i = S p'). exists (k-i-1). lia.
    destruct H2. rewrite H2. assert (k - S i = x0). lia. rewrite <- H3.
    intuition.
  Qed.

  Lemma position_aux_ok2 i x : forall l k, element_at l k = Some x ->
    exists k', k' <= k /\ position_aux i x l = Some (i+k').

  Proof.
    induction l; simpl; intros. discr. case_beq x a.
    exists 0. intuition. rewrite (beq_ko beq_ok) in H0. destruct k.
    inversion H. subst. cong. destruct (IHl _ H). exists (S x0). intuition.
    rewrite <- plus_Snm_nSm. simpl. apply position_aux_S. hyp.
  Qed.

End S.

Arguments mem_ok [A beq] _ _ _.
Arguments beq_list_ok [A beq] _ _ _.
Arguments beq_list_ok_in [A beq l] _ _.
Arguments incl_ok [A beq] _ _ _.

(***********************************************************************)
(** tactics *)

Ltac incl beq_ok :=
  rewrite <- (incl_ok beq_ok); check_eq
    || fail 10 "list inclusion not satisfied".


From Hammer Require Import Hammer.

Set Implicit Arguments.
Local Unset Intuition Negation Unfolding.

Section ChoiceSchemes.

Variables A B :Type.

Variable P:A->Prop.

Definition RelationalChoice_on :=
forall R:A->B->Prop,
(forall x : A, exists y : B, R x y) ->
(exists R' : A->B->Prop, subrelation R' R /\ forall x, exists! y, R' x y).

Definition FunctionalChoice_on_rel (R:A->B->Prop) :=
(forall x:A, exists y : B, R x y) ->
exists f : A -> B, (forall x:A, R x (f x)).

Definition FunctionalChoice_on :=
forall R:A->B->Prop,
(forall x : A, exists y : B, R x y) ->
(exists f : A->B, forall x : A, R x (f x)).

Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) :=
forall R:forall x:A, B x -> Prop,
(forall x:A, exists y : B x, R x y) ->
(exists f : (forall x:A, B x), forall x:A, R x (f x)).

Definition InhabitedForallCommute_on (A : Type) (B : A -> Type) :=
(forall x, inhabited (B x)) -> inhabited (forall x, B x).

Definition FunctionalDependentChoice_on :=
forall (R:A->A->Prop),
(forall x, exists y, R x y) -> forall x0,
(exists f : nat -> A, f 0 = x0 /\ forall n, R (f n) (f (S n))).

Definition FunctionalCountableChoice_on :=
forall (R:nat->A->Prop),
(forall n, exists y, R n y) ->
(exists f : nat -> A, forall n, R n (f n)).

Definition FunctionalRelReification_on :=
forall R:A->B->Prop,
(forall x : A, exists! y : B, R x y) ->
(exists f : A->B, forall x : A, R x (f x)).

Definition DependentFunctionalRelReification_on (A:Type) (B:A -> Type) :=
forall (R:forall x:A, B x -> Prop),
(forall x:A, exists! y : B x, R x y) ->
(exists f : (forall x:A, B x), forall x:A, R x (f x)).

Require Import RelationClasses Logic.

Definition RepresentativeFunctionalChoice_on :=
forall R:A->A->Prop,
(Equivalence R) ->
(exists f : A->A, forall x : A, (R x (f x)) /\ forall x', R x x' -> f x = f x').

Definition SetoidFunctionalChoice_on :=
forall R : A -> A -> Prop,
forall T : A -> B -> Prop,
Equivalence R ->
(forall x x' y, R x x' -> T x y -> T x' y) ->
(forall x, exists y, T x y) ->
exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x').

Definition GeneralizedSetoidFunctionalChoice_on :=
forall R : A -> A -> Prop,
forall S : B -> B -> Prop,
forall T : A -> B -> Prop,
Equivalence R ->
Equivalence S ->
(forall x x' y y', R x x' -> S y y' -> T x y -> T x' y') ->
(forall x, exists y, T x y) ->
exists f : A -> B,
forall x : A, T x (f x) /\ (forall x' : A, R x x' -> S (f x) (f x')).

Definition SimpleSetoidFunctionalChoice_on A B :=
forall R : A -> A -> Prop,
forall T : A -> B -> Prop,
Equivalence R ->
(forall x, exists y, forall x', R x x' -> T x' y) ->
exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x').

Definition ConstructiveIndefiniteDescription_on :=
forall P:A->Prop,
(exists x, P x) -> { x:A | P x }.

Definition ConstructiveDefiniteDescription_on :=
forall P:A->Prop,
(exists! x, P x) -> { x:A | P x }.

Definition GuardedRelationalChoice_on :=
forall P : A->Prop, forall R : A->B->Prop,
(forall x : A, P x -> exists y : B, R x y) ->
(exists R' : A->B->Prop,
subrelation R' R /\ forall x, P x -> exists! y, R' x y).

Definition GuardedFunctionalChoice_on :=
forall P : A->Prop, forall R : A->B->Prop,
inhabited B ->
(forall x : A, P x -> exists y : B, R x y) ->
(exists f : A->B, forall x, P x -> R x (f x)).

Definition GuardedFunctionalRelReification_on :=
forall P : A->Prop, forall R : A->B->Prop,
inhabited B ->
(forall x : A, P x -> exists! y : B, R x y) ->
(exists f : A->B, forall x : A, P x -> R x (f x)).

Definition OmniscientRelationalChoice_on :=
forall R : A->B->Prop,
exists R' : A->B->Prop,
subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y.

Definition OmniscientFunctionalChoice_on :=
forall R : A->B->Prop,
inhabited B ->
exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x).

Definition EpsilonStatement_on :=
forall P:A->Prop,
inhabited A -> { x:A | (exists x, P x) -> P x }.

Definition IotaStatement_on :=
forall P:A->Prop,
inhabited A -> { x:A | (exists! x, P x) -> P x }.

End ChoiceSchemes.

Notation RelationalChoice :=
(forall A B : Type, RelationalChoice_on A B).
Notation FunctionalChoice :=
(forall A B : Type, FunctionalChoice_on A B).
Notation DependentFunctionalChoice :=
(forall A (B:A->Type), DependentFunctionalChoice_on B).
Notation InhabitedForallCommute :=
(forall A (B : A -> Type), InhabitedForallCommute_on B).
Notation FunctionalDependentChoice :=
(forall A : Type, FunctionalDependentChoice_on A).
Notation FunctionalCountableChoice :=
(forall A : Type, FunctionalCountableChoice_on A).
Notation FunctionalChoiceOnInhabitedSet :=
(forall A B : Type, inhabited B -> FunctionalChoice_on A B).
Notation FunctionalRelReification :=
(forall A B : Type, FunctionalRelReification_on A B).
Notation DependentFunctionalRelReification :=
(forall A (B:A->Type), DependentFunctionalRelReification_on B).
Notation RepresentativeFunctionalChoice :=
(forall A : Type, RepresentativeFunctionalChoice_on A).
Notation SetoidFunctionalChoice :=
(forall A  B: Type, SetoidFunctionalChoice_on A B).
Notation GeneralizedSetoidFunctionalChoice :=
(forall A B : Type, GeneralizedSetoidFunctionalChoice_on A B).
Notation SimpleSetoidFunctionalChoice :=
(forall A B : Type, SimpleSetoidFunctionalChoice_on A B).

Notation GuardedRelationalChoice :=
(forall A B : Type, GuardedRelationalChoice_on A B).
Notation GuardedFunctionalChoice :=
(forall A B : Type, GuardedFunctionalChoice_on A B).
Notation GuardedFunctionalRelReification :=
(forall A B : Type, GuardedFunctionalRelReification_on A B).

Notation OmniscientRelationalChoice :=
(forall A B : Type, OmniscientRelationalChoice_on A B).
Notation OmniscientFunctionalChoice :=
(forall A B : Type, OmniscientFunctionalChoice_on A B).

Notation ConstructiveDefiniteDescription :=
(forall A : Type, ConstructiveDefiniteDescription_on A).
Notation ConstructiveIndefiniteDescription :=
(forall A : Type, ConstructiveIndefiniteDescription_on A).

Notation IotaStatement :=
(forall A : Type, IotaStatement_on A).
Notation EpsilonStatement :=
(forall A : Type, EpsilonStatement_on A).

Definition ProofIrrelevance :=
forall (A:Prop) (a1 a2:A), a1 = a2.

Definition IndependenceOfGeneralPremises :=
forall (A:Type) (P:A -> Prop) (Q:Prop),
inhabited A ->
(Q -> exists x, P x) -> exists x, Q -> P x.

Definition SmallDrinker'sParadox :=
forall (A:Type) (P:A -> Prop), inhabited A ->
exists x, (exists x, P x) -> P x.

Definition ExcludedMiddle :=
forall P:Prop, P \/ ~ P.

Local Notation ExtensionalPropositionRepresentative :=
(forall (A:Type),
exists h : Prop -> Prop,
forall P : Prop, (P <-> h P) /\ forall Q, (P <-> Q) -> h P = h Q).

Local Notation ExtensionalPredicateRepresentative :=
(forall (A:Type),
exists h : (A->Prop) -> (A->Prop),
forall (P : A -> Prop), (forall x, P x <-> h P x) /\ forall Q, (forall x, P x <-> Q x) -> h P = h Q).

Local Notation ExtensionalFunctionRepresentative :=
(forall (A B:Type),
exists h : (A->B) -> (A->B),
forall (f : A -> B), (forall x, f x = h f x) /\ forall g, (forall x, f x = g x) -> h f = h g).

Lemma functional_rel_reification_and_rel_choice_imp_fun_choice :
forall A B : Type,
FunctionalRelReification_on A B -> RelationalChoice_on A B -> FunctionalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.functional_rel_reification_and_rel_choice_imp_fun_choice".
intros A B Descr RelCh R H.
destruct (RelCh R H) as (R',(HR'R,H0)).
destruct (Descr R') as (f,Hf).
firstorder.
exists f; intro x.
destruct (H0 x) as (y,(HR'xy,Huniq)).
rewrite <- (Huniq (f x) (Hf x)).
apply HR'R; assumption.
Qed.

Lemma fun_choice_imp_rel_choice :
forall A B : Type, FunctionalChoice_on A B -> RelationalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.fun_choice_imp_rel_choice".
intros A B FunCh R H.
destruct (FunCh R H) as (f,H0).
exists (fun x y => f x = y).
split.
intros x y Heq; rewrite <- Heq; trivial.
intro x; exists (f x); split.
reflexivity.
trivial.
Qed.

Lemma fun_choice_imp_functional_rel_reification :
forall A B : Type, FunctionalChoice_on A B -> FunctionalRelReification_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.fun_choice_imp_functional_rel_reification".
intros A B FunCh R H.
destruct (FunCh R) as [f H0].

intro x.
destruct (H x) as (y,(HRxy,_)).
exists y; exact HRxy.

exists f; exact H0.
Qed.

Corollary fun_choice_iff_rel_choice_and_functional_rel_reification :
forall A B : Type, FunctionalChoice_on A B <->
RelationalChoice_on A B /\ FunctionalRelReification_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.fun_choice_iff_rel_choice_and_functional_rel_reification".
intros A B. split.
intro H; split;
[ exact (fun_choice_imp_rel_choice H)
| exact (fun_choice_imp_functional_rel_reification H) ].
intros [H H0]; exact (functional_rel_reification_and_rel_choice_imp_fun_choice H0 H).
Qed.

Lemma rel_choice_and_proof_irrel_imp_guarded_rel_choice :
RelationalChoice -> ProofIrrelevance -> GuardedRelationalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.rel_choice_and_proof_irrel_imp_guarded_rel_choice".
intros rel_choice proof_irrel.
red; intros A B P R H.
destruct (rel_choice _ _ (fun (x:sigT P) (y:B) => R (projT1 x) y)) as (R',(HR'R,H0)).
intros (x,HPx).
destruct (H x HPx) as (y,HRxy).
exists y; exact HRxy.
set (R'' := fun (x:A) (y:B) => exists H : P x, R' (existT P x H) y).
exists R''; split.
intros x y (HPx,HR'xy).
change x with (projT1 (existT P x HPx)); apply HR'R; exact HR'xy.
intros x HPx.
destruct (H0 (existT P x HPx)) as (y,(HR'xy,Huniq)).
exists y; split. exists HPx; exact HR'xy.
intros y' (H'Px,HR'xy').
apply Huniq.
rewrite proof_irrel with (a1 := HPx) (a2 := H'Px); exact HR'xy'.
Qed.

Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice :
forall A B : Type, inhabited B -> RelationalChoice_on A B ->
IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.rel_choice_indep_of_general_premises_imp_guarded_rel_choice".
intros A B Inh AC_rel IndPrem P R H.
destruct (AC_rel (fun x y => P x -> R x y)) as (R',(HR'R,H0)).
intro x. apply IndPrem. exact Inh. intro Hx.
apply H; assumption.
exists (fun x y => P x /\ R' x y).
firstorder.
Qed.

Lemma guarded_rel_choice_imp_rel_choice :
forall A B : Type, GuardedRelationalChoice_on A B -> RelationalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.guarded_rel_choice_imp_rel_choice".
intros A B GAC_rel R H.
destruct (GAC_rel (fun _ => True) R) as (R',(HR'R,H0)).
firstorder.
exists R'; firstorder.
Qed.

Lemma subset_types_imp_guarded_rel_choice_iff_rel_choice :
ProofIrrelevance -> (GuardedRelationalChoice <-> RelationalChoice).
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.subset_types_imp_guarded_rel_choice_iff_rel_choice".
intuition auto using
guarded_rel_choice_imp_rel_choice,
rel_choice_and_proof_irrel_imp_guarded_rel_choice.
Qed.

Corollary guarded_iff_omniscient_rel_choice :
GuardedRelationalChoice <-> OmniscientRelationalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.guarded_iff_omniscient_rel_choice".
split.
intros GAC_rel A B R.
apply (GAC_rel A B (fun x => exists y, R x y) R); auto.
intros OAC_rel A B P R H.
destruct (OAC_rel A B R) as (f,Hf); exists f; firstorder.
Qed.

Lemma guarded_fun_choice_imp_indep_of_general_premises :
GuardedFunctionalChoice -> IndependenceOfGeneralPremises.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.guarded_fun_choice_imp_indep_of_general_premises".
intros GAC_fun A P Q Inh H.
destruct (GAC_fun unit A (fun _ => Q) (fun _ => P) Inh) as (f,Hf).
tauto.
exists (f tt); auto.
Qed.

Lemma guarded_fun_choice_imp_fun_choice :
GuardedFunctionalChoice -> FunctionalChoiceOnInhabitedSet.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.guarded_fun_choice_imp_fun_choice".
intros GAC_fun A B Inh R H.
destruct (GAC_fun A B (fun _ => True) R Inh) as (f,Hf).
firstorder.
exists f; auto.
Qed.

Lemma fun_choice_and_indep_general_prem_imp_guarded_fun_choice :
FunctionalChoiceOnInhabitedSet -> IndependenceOfGeneralPremises
-> GuardedFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.fun_choice_and_indep_general_prem_imp_guarded_fun_choice".
intros AC_fun IndPrem A B P R Inh H.
apply (AC_fun A B Inh (fun x y => P x -> R x y)).
intro x; apply IndPrem; eauto.
Qed.

Corollary fun_choice_and_indep_general_prem_iff_guarded_fun_choice :
FunctionalChoiceOnInhabitedSet /\ IndependenceOfGeneralPremises
<-> GuardedFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.fun_choice_and_indep_general_prem_iff_guarded_fun_choice".
intuition auto using
guarded_fun_choice_imp_indep_of_general_premises,
guarded_fun_choice_imp_fun_choice,
fun_choice_and_indep_general_prem_imp_guarded_fun_choice.
Qed.

Lemma omniscient_fun_choice_imp_small_drinker :
OmniscientFunctionalChoice -> SmallDrinker'sParadox.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.omniscient_fun_choice_imp_small_drinker".
intros OAC_fun A P Inh.
destruct (OAC_fun unit A (fun _ => P)) as (f,Hf).
auto.
exists (f tt); firstorder.
Qed.

Lemma omniscient_fun_choice_imp_fun_choice :
OmniscientFunctionalChoice -> FunctionalChoiceOnInhabitedSet.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.omniscient_fun_choice_imp_fun_choice".
intros OAC_fun A B Inh R H.
destruct (OAC_fun A B R Inh) as (f,Hf).
exists f; firstorder.
Qed.

Lemma fun_choice_and_small_drinker_imp_omniscient_fun_choice :
FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox
-> OmniscientFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.fun_choice_and_small_drinker_imp_omniscient_fun_choice".
intros AC_fun Drinker A B R Inh.
destruct (AC_fun A B Inh (fun x y => (exists y, R x y) -> R x y)) as (f,Hf).
intro x; apply (Drinker B (R x) Inh).
exists f; assumption.
Qed.

Corollary fun_choice_and_small_drinker_iff_omniscient_fun_choice :
FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox
<-> OmniscientFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.fun_choice_and_small_drinker_iff_omniscient_fun_choice".
intuition auto using
omniscient_fun_choice_imp_small_drinker,
omniscient_fun_choice_imp_fun_choice,
fun_choice_and_small_drinker_imp_omniscient_fun_choice.
Qed.

Theorem guarded_iff_omniscient_fun_choice :
GuardedFunctionalChoice <-> OmniscientFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.guarded_iff_omniscient_fun_choice".
split.
intros GAC_fun A B R Inh.
apply (GAC_fun A B (fun x => exists y, R x y) R); auto.
intros OAC_fun A B P R Inh H.
destruct (OAC_fun A B R Inh) as (f,Hf).
exists f; firstorder.
Qed.

Lemma iota_imp_constructive_definite_description :
IotaStatement -> ConstructiveDefiniteDescription.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.iota_imp_constructive_definite_description".
intros D_iota A P H.
destruct D_iota with (P:=P) as (x,H1).
destruct H; red in H; auto.
exists x; apply H1; assumption.
Qed.

Lemma epsilon_imp_constructive_indefinite_description:
EpsilonStatement -> ConstructiveIndefiniteDescription.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.epsilon_imp_constructive_indefinite_description".
intros D_epsilon A P H.
destruct D_epsilon with (P:=P) as (x,H1).
destruct H; auto.
exists x; apply H1; assumption.
Qed.

Lemma constructive_indefinite_description_and_small_drinker_imp_epsilon :
SmallDrinker'sParadox -> ConstructiveIndefiniteDescription ->
EpsilonStatement.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.constructive_indefinite_description_and_small_drinker_imp_epsilon".
intros Drinkers D_epsilon A P Inh;
apply D_epsilon; apply Drinkers; assumption.
Qed.

Lemma epsilon_imp_small_drinker :
EpsilonStatement -> SmallDrinker'sParadox.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.epsilon_imp_small_drinker".
intros D_epsilon A P Inh; edestruct D_epsilon; eauto.
Qed.

Theorem constructive_indefinite_description_and_small_drinker_iff_epsilon :
(SmallDrinker'sParadox * ConstructiveIndefiniteDescription ->
EpsilonStatement) *
(EpsilonStatement ->
SmallDrinker'sParadox * ConstructiveIndefiniteDescription).
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.constructive_indefinite_description_and_small_drinker_iff_epsilon".
intuition auto using
epsilon_imp_constructive_indefinite_description,
constructive_indefinite_description_and_small_drinker_imp_epsilon,
epsilon_imp_small_drinker.
Qed.

Require Import Wf_nat.
Require Import Decidable.

Lemma classical_denumerable_description_imp_fun_choice :
forall A:Type,
FunctionalRelReification_on A nat ->
forall R:A->nat->Prop,
(forall x y, decidable (R x y)) -> FunctionalChoice_on_rel R.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.classical_denumerable_description_imp_fun_choice".
intros A Descr.
red; intros R Rdec H.
set (R':= fun x y => R x y /\ forall y', R x y' -> y <= y').
destruct (Descr R') as (f,Hf).
intro x.
apply (dec_inh_nat_subset_has_unique_least_element (R x)).
apply Rdec.
apply (H x).
exists f.
intros x.
destruct (Hf x) as (Hfx,_).
assumption.
Qed.

Theorem dep_non_dep_functional_choice :
DependentFunctionalChoice -> FunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.dep_non_dep_functional_choice".
intros AC_depfun A B R H.
destruct (AC_depfun A (fun _ => B) R H) as (f,Hf).
exists f; trivial.
Qed.

Scheme and_indd := Induction for and Sort Prop.
Scheme eq_indd := Induction for eq Sort Prop.

Definition proj1_inf (A B:Prop) (p : A/\B) :=
let (a,b) := p in a.

Theorem non_dep_dep_functional_choice :
FunctionalChoice -> DependentFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.non_dep_dep_functional_choice".
intros AC_fun A B R H.
pose (B' := { x:A & B x }).
pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)).
destruct (AC_fun A B' R') as (f,Hf).
intros x. destruct (H x) as (y,Hy).
exists (existT (fun x => B x) x y). split; trivial.
exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_inf (Hf x))).
intro x; destruct (Hf x) as (Heq,HR) using and_indd.
destruct (f x); simpl in *.
destruct Heq using eq_indd; trivial.
Qed.

Theorem functional_choice_to_inhabited_forall_commute :
FunctionalChoice -> InhabitedForallCommute.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.functional_choice_to_inhabited_forall_commute".
intros choose0 A B Hinhab.
pose proof (non_dep_dep_functional_choice choose0) as choose;clear choose0.
assert (Hexists : forall x, exists _ : B x, True).
{ intros x;apply inhabited_sig_to_exists.
refine (inhabited_covariant _ (Hinhab x)).
intros y;exists y;exact I. }
apply choose in Hexists.
destruct Hexists as [f _].
exact (inhabits f).
Qed.

Theorem inhabited_forall_commute_to_functional_choice :
InhabitedForallCommute -> FunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.inhabited_forall_commute_to_functional_choice".
intros choose A B R Hexists.
assert (Hinhab : forall x, inhabited {y : B | R x y}).
{ intros x;apply exists_to_inhabited_sig;trivial. }
apply choose in Hinhab. destruct Hinhab as [f].
exists (fun x => proj1_sig (f x)).
exact (fun x => proj2_sig (f x)).
Qed.

Theorem dep_non_dep_functional_rel_reification :
DependentFunctionalRelReification -> FunctionalRelReification.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.dep_non_dep_functional_rel_reification".
intros DepFunReify A B R H.
destruct (DepFunReify A (fun _ => B) R H) as (f,Hf).
exists f; trivial.
Qed.

Theorem non_dep_dep_functional_rel_reification :
FunctionalRelReification -> DependentFunctionalRelReification.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.non_dep_dep_functional_rel_reification".
intros AC_fun A B R H.
pose (B' := { x:A & B x }).
pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)).
destruct (AC_fun A B' R') as (f,Hf).
intros x. destruct (H x) as (y,(Hy,Huni)).
exists (existT (fun x => B x) x y). repeat split; trivial.
intros (x',y') (Heqx',Hy').
simpl in *.
destruct Heqx'.
rewrite (Huni y'); trivial.
exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_inf (Hf x))).
intro x; destruct (Hf x) as (Heq,HR) using and_indd.
destruct (f x); simpl in *.
destruct Heq using eq_indd; trivial.
Qed.

Corollary dep_iff_non_dep_functional_rel_reification :
FunctionalRelReification <-> DependentFunctionalRelReification.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.dep_iff_non_dep_functional_rel_reification".
intuition auto using
non_dep_dep_functional_rel_reification,
dep_non_dep_functional_rel_reification.
Qed.

Lemma relative_non_contradiction_of_indefinite_descr :
forall C:Prop, (ConstructiveIndefiniteDescription -> C)
-> (FunctionalChoice -> C).
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.relative_non_contradiction_of_indefinite_descr".
intros C H AC_fun.
assert (AC_depfun := non_dep_dep_functional_choice AC_fun).
pose (A0 := { A:Type & { P:A->Prop & exists x, P x }}).
pose (B0 := fun x:A0 => projT1 x).
pose (R0 := fun x:A0 => fun y:B0 x => projT1 (projT2 x) y).
pose (H0 := fun x:A0 => projT2 (projT2 x)).
destruct (AC_depfun A0 B0 R0 H0) as (f, Hf).
apply H.
intros A P H'.
exists (f (existT _ A (existT _ P H'))).
pose (Hf' := Hf (existT _ A (existT _ P H'))).
assumption.
Qed.

Lemma constructive_indefinite_descr_fun_choice :
ConstructiveIndefiniteDescription -> FunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.constructive_indefinite_descr_fun_choice".
intros IndefDescr A B R H.
exists (fun x => proj1_sig (IndefDescr B (R x) (H x))).
intro x.
apply (proj2_sig (IndefDescr B (R x) (H x))).
Qed.

Lemma relative_non_contradiction_of_definite_descr :
forall C:Prop, (ConstructiveDefiniteDescription -> C)
-> (FunctionalRelReification -> C).
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.relative_non_contradiction_of_definite_descr".
intros C H FunReify.
assert (DepFunReify := non_dep_dep_functional_rel_reification FunReify).
pose (A0 := { A:Type & { P:A->Prop & exists! x, P x }}).
pose (B0 := fun x:A0 => projT1 x).
pose (R0 := fun x:A0 => fun y:B0 x => projT1 (projT2 x) y).
pose (H0 := fun x:A0 => projT2 (projT2 x)).
destruct (DepFunReify A0 B0 R0 H0) as (f, Hf).
apply H.
intros A P H'.
exists (f (existT _ A (existT _ P H'))).
pose (Hf' := Hf (existT _ A (existT _ P H'))).
assumption.
Qed.

Lemma constructive_definite_descr_fun_reification :
ConstructiveDefiniteDescription -> FunctionalRelReification.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.constructive_definite_descr_fun_reification".
intros DefDescr A B R H.
exists (fun x => proj1_sig (DefDescr B (R x) (H x))).
intro x.
apply (proj2_sig (DefDescr B (R x) (H x))).
Qed.

Require Import Setoid.

Theorem constructive_definite_descr_excluded_middle :
(forall A : Type, ConstructiveDefiniteDescription_on A) ->
(forall P:Prop, P \/ ~ P) -> (forall P:Prop, {P} + {~ P}).
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.constructive_definite_descr_excluded_middle".
intros Descr EM P.
pose (select := fun b:bool => if b then P else ~P).
assert { b:bool | select b } as ([|],HP).
red in Descr.
apply Descr.
rewrite <- unique_existence; split.
destruct (EM P).
exists true; trivial.
exists false; trivial.
intros [|] [|] H1 H2; simpl in *; reflexivity || contradiction.
left; trivial.
right; trivial.
Qed.

Corollary fun_reification_descr_computational_excluded_middle_in_prop_context :
FunctionalRelReification ->
(forall P:Prop, P \/ ~ P) ->
forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.fun_reification_descr_computational_excluded_middle_in_prop_context".
intros FunReify EM C H. intuition auto using
constructive_definite_descr_excluded_middle,
(relative_non_contradiction_of_definite_descr (C:=C)).
Qed.

Require Import Arith.

Theorem functional_choice_imp_functional_dependent_choice :
FunctionalChoice -> FunctionalDependentChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.functional_choice_imp_functional_dependent_choice".
intros FunChoice A R HRfun x0.
apply FunChoice in HRfun as (g,Rg).
set (f:=fix f n := match n with 0 => x0 | S n' => g (f n') end).
exists f; firstorder.
Qed.

Theorem functional_dependent_choice_imp_functional_countable_choice :
FunctionalDependentChoice -> FunctionalCountableChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.functional_dependent_choice_imp_functional_countable_choice".
intros H A R H0.
set (R' (p q:nat*A) := fst q = S (fst p) /\ R (fst p) (snd q)).
destruct (H0 0) as (y0,Hy0).
destruct H with (R:=R') (x0:=(0,y0)) as (f,(Hf0,HfS)).
intro x; destruct (H0 (fst x)) as (y,Hy).
exists (S (fst x),y).
red. auto.
assert (Heq:forall n, fst (f n) = n).
induction n.
rewrite Hf0; reflexivity.
specialize HfS with n; destruct HfS as (->,_); congruence.
exists (fun n => snd (f (S n))).
intro n'. specialize HfS with n'.
destruct HfS as (_,HR).
rewrite Heq in HR.
assumption.
Qed.

Require Import ClassicalFacts PropExtensionalityFacts.

Theorem repr_fun_choice_imp_ext_prop_repr :
RepresentativeFunctionalChoice -> ExtensionalPropositionRepresentative.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.repr_fun_choice_imp_ext_prop_repr".
intros ReprFunChoice A.
pose (R P Q := P <-> Q).
assert (Hequiv:Equivalence R) by (split; firstorder).
apply (ReprFunChoice _ R Hequiv).
Qed.

Theorem repr_fun_choice_imp_ext_pred_repr :
RepresentativeFunctionalChoice -> ExtensionalPredicateRepresentative.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.repr_fun_choice_imp_ext_pred_repr".
intros ReprFunChoice A.
pose (R P Q := forall x : A, P x <-> Q x).
assert (Hequiv:Equivalence R) by (split; firstorder).
apply (ReprFunChoice _ R Hequiv).
Qed.

Theorem repr_fun_choice_imp_ext_function_repr :
RepresentativeFunctionalChoice -> ExtensionalFunctionRepresentative.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.repr_fun_choice_imp_ext_function_repr".
intros ReprFunChoice A B.
pose (R (f g : A -> B) := forall x : A, f x = g x).
assert (Hequiv:Equivalence R).
{ split; try easy. firstorder using eq_trans. }
apply (ReprFunChoice _ R Hequiv).
Qed.

Theorem repr_fun_choice_imp_excluded_middle :
RepresentativeFunctionalChoice -> ExcludedMiddle.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.repr_fun_choice_imp_excluded_middle".
intros ReprFunChoice.
apply representative_boolean_partition_imp_excluded_middle, ReprFunChoice.
Qed.

Theorem repr_fun_choice_imp_relational_choice :
RepresentativeFunctionalChoice -> RelationalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.repr_fun_choice_imp_relational_choice".
intros ReprFunChoice A B T Hexists.
pose (D := (A*B)%type).
pose (R (z z':D) :=
let x := fst z in
let x' := fst z' in
let y := snd z in
let y' := snd z' in
x = x' /\ (T x y -> y = y' \/ T x y') /\ (T x y' -> y = y' \/ T x y)).
assert (Hequiv : Equivalence R).
{ split.
- split. easy. firstorder.
- intros (x,y) (x',y') (H1,(H2,H2')). split. easy. simpl fst in *. simpl snd in *.
subst x'. split; intro H.
+ destruct (H2' H); firstorder.
+ destruct (H2 H); firstorder.
- intros (x,y) (x',y') (x'',y'') (H1,(H2,H2')) (H3,(H4,H4')).
simpl fst in *. simpl snd in *. subst x'' x'. split. easy. split; intro H.
+ simpl fst in *. simpl snd in *. destruct (H2 H) as [<-|H0].
* destruct (H4 H); firstorder.
* destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder.
+ simpl fst in *. simpl snd in *. destruct (H4' H) as [<-|H0].
* destruct (H2' H); firstorder.
* destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder. }
destruct (ReprFunChoice D R Hequiv) as (g,Hg).
set (T' x y := T x y /\ exists y', T x y' /\ g (x,y') = (x,y)).
exists T'. split.
- intros x y (H,_); easy.
- intro x. destruct (Hexists x) as (y,Hy).
exists (snd (g (x,y))).
destruct (Hg (x,y)) as ((Heq1,(H',H'')),Hgxyuniq); clear Hg.
destruct (H' Hy) as [Heq2|Hgy]; clear H'.
+ split. split.
* rewrite <- Heq2. assumption.
* exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1, Heq2. subst; easy.
* intros y' (Hy',(y'',(Hy'',Heq))).
rewrite (Hgxyuniq (x,y'')), Heq. easy. split. easy.
split; right; easy.
+ split. split.
* assumption.
* exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1. subst x'; easy.
* intros y' (Hy',(y'',(Hy'',Heq))).
rewrite (Hgxyuniq (x,y'')), Heq. easy. split. easy.
split; right; easy.
Qed.

Theorem gen_setoid_fun_choice_imp_setoid_fun_choice  :
forall A B, GeneralizedSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.gen_setoid_fun_choice_imp_setoid_fun_choice".
intros A B GenSetoidFunChoice R T Hequiv Hcompat Hex.
apply GenSetoidFunChoice; try easy.
apply eq_equivalence.
intros * H <-. firstorder.
Qed.

Theorem setoid_fun_choice_imp_gen_setoid_fun_choice :
forall A B, SetoidFunctionalChoice_on A B -> GeneralizedSetoidFunctionalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.setoid_fun_choice_imp_gen_setoid_fun_choice".
intros A B SetoidFunChoice R S T HequivR HequivS Hcompat Hex.
destruct SetoidFunChoice with (R:=R) (T:=T) as (f,Hf); try easy.
{ intros; apply (Hcompat x x' y y); try easy. }
exists f. intros x; specialize Hf with x as (Hf,Huniq). intuition. now erewrite Huniq.
Qed.

Corollary setoid_fun_choice_iff_gen_setoid_fun_choice :
forall A B, SetoidFunctionalChoice_on A B <-> GeneralizedSetoidFunctionalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.setoid_fun_choice_iff_gen_setoid_fun_choice".
split; auto using gen_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_gen_setoid_fun_choice.
Qed.

Theorem setoid_fun_choice_imp_simple_setoid_fun_choice  :
forall A B, SetoidFunctionalChoice_on A B -> SimpleSetoidFunctionalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.setoid_fun_choice_imp_simple_setoid_fun_choice".
intros A B SetoidFunChoice R T Hequiv Hexists.
pose (T' x y := forall x', R x x' -> T x' y).
assert (Hcompat : forall (x x' : A) (y : B), R x x' -> T' x y -> T' x' y) by firstorder.
destruct (SetoidFunChoice R T' Hequiv Hcompat Hexists) as (f,Hf).
exists f. firstorder.
Qed.

Theorem simple_setoid_fun_choice_imp_setoid_fun_choice :
forall A B, SimpleSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.simple_setoid_fun_choice_imp_setoid_fun_choice".
intros A B SimpleSetoidFunChoice R T Hequiv Hcompat Hexists.
destruct (SimpleSetoidFunChoice R T Hequiv) as (f,Hf); firstorder.
Qed.

Corollary setoid_fun_choice_iff_simple_setoid_fun_choice :
forall A B, SetoidFunctionalChoice_on A B <-> SimpleSetoidFunctionalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.setoid_fun_choice_iff_simple_setoid_fun_choice".
split; auto using simple_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_simple_setoid_fun_choice.
Qed.

Theorem setoid_fun_choice_imp_fun_choice :
forall A B, SetoidFunctionalChoice_on A B -> FunctionalChoice_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.setoid_fun_choice_imp_fun_choice".
intros A B SetoidFunChoice T Hexists.
destruct SetoidFunChoice with (R:=@eq A) (T:=T) as (f,Hf).
- apply eq_equivalence.
- now intros * ->.
- assumption.
- exists f. firstorder.
Qed.

Corollary setoid_fun_choice_imp_functional_rel_reification :
forall A B, SetoidFunctionalChoice_on A B -> FunctionalRelReification_on A B.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.setoid_fun_choice_imp_functional_rel_reification".
intros A B SetoidFunChoice.
apply fun_choice_imp_functional_rel_reification.
now apply setoid_fun_choice_imp_fun_choice.
Qed.

Theorem setoid_fun_choice_imp_repr_fun_choice :
SetoidFunctionalChoice -> RepresentativeFunctionalChoice .
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.setoid_fun_choice_imp_repr_fun_choice".
intros SetoidFunChoice A R Hequiv.
apply SetoidFunChoice; firstorder.
Qed.

Theorem functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice :
FunctionalRelReification -> RepresentativeFunctionalChoice -> SetoidFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice".
intros FunRelReify ReprFunChoice A B R T Hequiv Hcompat Hexists.
assert (FunChoice : FunctionalChoice).
{ intros A' B'. apply functional_rel_reification_and_rel_choice_imp_fun_choice.
- apply FunRelReify.
- now apply repr_fun_choice_imp_relational_choice. }
destruct (FunChoice _ _ T Hexists) as (f,Hf).
destruct (ReprFunChoice A R Hequiv) as (g,Hg).
exists (fun a => f (g a)).
intro x. destruct (Hg x) as (Hgx,HRuniq).
split.
- eapply Hcompat. symmetry. apply Hgx. apply Hf.
- intros y Hxy. f_equal. auto.
Qed.

Theorem functional_rel_reification_and_repr_fun_choice_iff_setoid_fun_choice :
FunctionalRelReification /\ RepresentativeFunctionalChoice <-> SetoidFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.functional_rel_reification_and_repr_fun_choice_iff_setoid_fun_choice".
split; intros.
- now apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice.
- split.
+ now intros A B; apply setoid_fun_choice_imp_functional_rel_reification.
+ now apply setoid_fun_choice_imp_repr_fun_choice.
Qed.

Import EqNotations.

Theorem fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice :
FunctionalChoice -> ExtensionalFunctionRepresentative -> ExcludedMiddle -> RepresentativeFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice".
intros FunChoice SetoidFunRepr EM A R (Hrefl,Hsym,Htrans).
assert (H:forall P:Prop, exists b, b = true <-> P).
{ intros P. destruct (EM P).
- exists true; firstorder.
- exists false; easy. }
destruct (FunChoice _ _ _ H) as (c,Hc).
pose (class_of a y := c (R a y)).
pose (isclass f := exists x:A, f x = true).
pose (class := {f:A -> bool | isclass f}).
pose (contains (c:class) (a:A) := proj1_sig c a = true).
destruct (FunChoice class A contains) as (f,Hf).
- intros f. destruct (proj2_sig f) as (x,Hx).
exists x. easy.
- destruct (SetoidFunRepr A bool) as (h,Hh).
assert (Hisclass:forall a, isclass (h (class_of a))).
{ intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa).
rewrite <- Ha. apply Hc. apply Hrefl. }
pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class).
exists (fun a => f (f' a)).
intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split.
+ specialize Hf with (f' x). unfold contains in Hf. simpl in Hf. rewrite <- Hx in Hf. apply Hc. assumption.
+ intros y Hxy.
f_equal.
assert (Heq1: h (class_of x) = h (class_of y)).
{ apply Huniqx. intro z. unfold class_of.
destruct (c (R x z)) eqn:Hxz.
- symmetry. apply Hc. apply -> Hc in Hxz. firstorder.
- destruct (c (R y z)) eqn:Hyz.
+ apply -> Hc in Hyz. rewrite <- Hxz. apply Hc. firstorder.
+ easy. }
assert (Heq2:rew Heq1 in Hisclass x = Hisclass y).
{ apply proof_irrelevance_cci, EM. }
unfold f'.
rewrite <- Heq2.
rewrite <- Heq1.
reflexivity.
Qed.

Theorem setoid_functional_choice_first_characterization :
FunctionalChoice /\ ExtensionalFunctionRepresentative /\ ExcludedMiddle <-> SetoidFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.setoid_functional_choice_first_characterization".
split.
- intros (FunChoice & SetoidFunRepr & EM).
apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice.
+ intros A B. apply fun_choice_imp_functional_rel_reification, FunChoice.
+ now apply fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice.
- intro SetoidFunChoice. repeat split.
+ now intros A B; apply setoid_fun_choice_imp_fun_choice.
+ apply repr_fun_choice_imp_ext_function_repr.
now apply setoid_fun_choice_imp_repr_fun_choice.
+ apply repr_fun_choice_imp_excluded_middle.
now apply setoid_fun_choice_imp_repr_fun_choice.
Qed.

Theorem fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice :
FunctionalChoice -> ExtensionalPredicateRepresentative -> ProofIrrelevance -> RepresentativeFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice".
intros FunChoice PredExtRepr PI A R (Hrefl,Hsym,Htrans).
pose (isclass P := exists x:A, P x).
pose (class := {P:A -> Prop | isclass P}).
pose (contains (c:class) (a:A) := proj1_sig c a).
pose (class_of a := R a).
destruct (FunChoice class A contains) as (f,Hf).
- intros c. apply proj2_sig.
- destruct (PredExtRepr A) as (h,Hh).
assert (Hisclass:forall a, isclass (h (class_of a))).
{ intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa).
rewrite <- Ha; apply Hrefl. }
pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class).
exists (fun a => f (f' a)).
intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split.
+ specialize Hf with (f' x). simpl in Hf. rewrite <- Hx in Hf. assumption.
+ intros y Hxy.
f_equal.
assert (Heq1: h (class_of x) = h (class_of y)).
{ apply Huniqx. intro z. unfold class_of. firstorder. }
assert (Heq2:rew Heq1 in Hisclass x = Hisclass y).
{ apply PI. }
unfold f'.
rewrite <- Heq2.
rewrite <- Heq1.
reflexivity.
Qed.

Theorem setoid_functional_choice_second_characterization :
FunctionalChoice /\ ExtensionalPredicateRepresentative /\ ProofIrrelevance <-> SetoidFunctionalChoice.
Proof. hammer_hook "ChoiceFacts" "ChoiceFacts.setoid_functional_choice_second_characterization".
split.
- intros (FunChoice & ExtPredRepr & PI).
apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice.
+ intros A B. now apply fun_choice_imp_functional_rel_reification.
+ now apply fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice.
- intro SetoidFunChoice. repeat split.
+ now intros A B; apply setoid_fun_choice_imp_fun_choice.
+ apply repr_fun_choice_imp_ext_pred_repr.
now apply setoid_fun_choice_imp_repr_fun_choice.
+ red. apply proof_irrelevance_cci.
apply repr_fun_choice_imp_excluded_middle.
now apply setoid_fun_choice_imp_repr_fun_choice.
Qed.

Notation description_rel_choice_imp_funct_choice :=
functional_rel_reification_and_rel_choice_imp_fun_choice (compat "8.6").

Notation funct_choice_imp_rel_choice := fun_choice_imp_rel_choice (compat "8.6").

Notation FunChoice_Equiv_RelChoice_and_ParamDefinDescr :=
fun_choice_iff_rel_choice_and_functional_rel_reification (compat "8.6").

Notation funct_choice_imp_description := fun_choice_imp_functional_rel_reification (compat "8.6").


Require Import List.
Import ListNotations.

(** *Bibliothèque standard *)

Print nat.
Locate "+".
Print Nat.add.
Locate "*".
Print Nat.mul.

Print list.
Locate "++".
Print app.

Print True.

Print False.

Print or.
Locate "\/".

Print and.
Locate "/\".

Print not.
Locate "~".

(** *Logique : le tiers exclu *)

(* Axiomes possibles pour la logique classique *)

Definition tiersExclu : Prop := forall P : Prop, P \/ ~P.
Definition involutionNegation : Prop := forall P : Prop, ~~P -> P.
Definition implicationMaterielle : Prop := forall P Q : Prop, (P -> Q) -> (~P \/ Q).
Definition reciproqueContraposition : Prop := forall P Q : Prop, (~Q -> ~P) -> (P -> Q).
(* Indication pour la suite : si besoin, utiliser la tactique "unfold" pour déplier
   la définition d'une des propositions précédentes. *)

(* Réciproques valides *)

(*
  Indication :
  - la négation *~P* est définie comme *P -> False*.
 *)
Proposition reciproqueInvolutionNegation :
  forall P : Prop, P -> ~~P.
Proof.
  intros.

  simpl.
Admitted.

(*
  Indication :
  - décomposer la disjonction en hypothèse,
  - lorsque les hypothèses entrainent une contradiction,
  utiliser la tactique exfalso.
 *)
Proposition reciproqueImplicationMaterielle :
  forall P Q : Prop, (~P \/ Q) -> P -> Q.
Proof.
Admitted.

Proposition contraposition :
  forall P Q : Prop, (P -> Q) -> (~Q -> ~P).
Proof.
Admitted.

(* Equivalence des axiomes *)

(*
  Indication :
  - décomposer le tiers exclu appliqué à la proposition.
 *)
Proposition tiersExcluVersInvolutionNegation :
  tiersExclu -> involutionNegation.
Proof.
Admitted.

(*
  Indication :
  - appliquer l'involution de la négation à (P \/ ~P),
  - utiliser le fait que (~(P \/ ~P)) entraine ~P,
  - utiliser les tactiques "left" et "right" pour prouver une disjonction.
 *)
Proposition involutionNegationVersTiersExclu :
  involutionNegation -> tiersExclu.
Proof.
Admitted.

(*
  Indication :
  - décomposer la preuve de la disjonction (P \/ ~P) obtenue en appliquant
  le lemme involutionNegationVersTiersExclu à la proposition P.
 *)
Proposition involutionNegationVersImplicationMaterielle :
  involutionNegation -> implicationMaterielle.
Proof.
Admitted.

Check or_comm.
(*
  Indication :
  - utiliser la proposition or_comm exprimant la commutativité de la disjonction (or).
 *)
Proposition implicationMaterielleVersTiersExclu :
  implicationMaterielle -> tiersExclu.
Proof.
Admitted.

(*
  Indication :
  - utiliser deux propositions déjà montrées.
 *)
Proposition implicationMaterielleVersInvolutionNegation :
  implicationMaterielle -> involutionNegation.
Proof.
Admitted.

(*
  Indication :
  - utiliser l'involution de la négation.
 *)
Proposition implicationMaterielleVersReciproqueContraposition :
  implicationMaterielle -> reciproqueContraposition.
Proof.
Admitted.

(*
  Indication :
  - appliquer la réciproque de la contraposition à True et P.
 *)
Proposition reciproqueContrapositionVersInvolutionNegation :
  reciproqueContraposition -> involutionNegation.
Proof.
Admitted.

(** *Définitions inductives - La croissance de listes *)

Inductive EstCroissante : list nat -> Prop :=
| videCroissante : EstCroissante []
| singletonCroissante : forall a, EstCroissante [a]
| consConsCroissante :
    forall a b l, (a <= b)
             -> EstCroissante (b :: l) -> EstCroissante( a :: b :: l).

(*
  --------- [precVide]
  Prec m []

  (t : nat)  (r : list nat)  (m <= t)
  ----------------------------------- [precCons]
  Prec m (t :: r)
 *)
Inductive Prec(m : nat) : list nat -> Prop :=
(* à modifier *)
.

(* à compléter

----------------- [videCroissante2]

--------------------------------------------------------- [consCroissante2]

 *)

Inductive EstCroissante2 : list nat -> Prop :=
(* à modifier *)
.

(*
  Indication :
  - procéder par induction sur la preuve de (EstCroissante2 l) ;
  dans le cas d'une liste non vide, décomposer par cas la preuve
  du prédicat Prec.
 *)
Proposition adequation_estCroissante2 : forall l,
    EstCroissante2 l -> EstCroissante l.
Proof.
Admitted.

(*
  Indication :
  - procéder par induction sur la preuve de (EstCroissante l).
 *)
Proposition completude_estCroissante2 : forall l,
    EstCroissante l -> EstCroissante2 l.
Proof.
Admitted.

(** *Définitions inductives - Facteurs d'une liste *)

Proposition associativite_concatenation :
  forall T : Type,
  forall l1 l2 l3 : list T,
    l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
Admitted.

(* à compléter

------------------ [facteurPrefixe]

-------------------------------- [facteurInterne]

 *)

Inductive Facteur{A : Type}(k : list A) : list A -> Prop :=
| facteurPrefixe : forall l, Facteur k l (* à modifier *)
| facteurInterne : forall l, Facteur k l. (* à modifier *)

(*
  Indication :
  - procéder par induction sur la preuve de *Facteur k l*,
  - pour prouver l'existence, utiliser la tactique "exists w", où w est le terme
  montrant l'existence.
 *)
Lemma adequation_Facteur :
  forall A, forall k l : list A, Facteur k l -> exists k' k'', k' ++ k ++ k'' = l.
Proof.
Admitted.

(*
  Indication :
  - utiliser directement les constructeurs de Facteur.
 *)
Lemma completude_Facteur :
  forall A, forall k' k k'' l : list A, k' ++ k ++ k'' = l -> Facteur k l.
Proof.
Admitted.

(** *Entiers naturels - Des fonctions et des propositions utiles *)

(* Addition et ordre *)

Lemma neutraliteDroite_addition :
  forall n : nat, n = n + 0.
Proof.
Admitted.

Lemma sommeSuccesseurs :
  forall n m : nat,
    S n + S m = S (S (n + m)).
Proof.
Admitted.

(*
  Indication :
  - procéder par induction sur la preuve de (n2 <= n3).
 *)
Proposition transitivite_le :
  forall n1 n2 n3, n1 <= n2 -> n2 <= n3 -> n1 <= n3.
Proof.
Admitted.

Proposition zeroMin_le :
  forall n, 0 <= n.
Proof.
Admitted.

Lemma successeurCroissant_le :
  forall m n, m <= n -> S m <= S n.
Proof.
Admitted.

(*
  Indication :
  - procéder par induction sur m,
  - utiliser successeurCroissant_le.
 *)
Lemma compatibiliteAdditionGauche_le :
  forall m n1 n2, n1 <= n2 -> (m + n1) <= (m + n2).
Proof.
Admitted.

(*
  Indication :
  - procéder par induction sur la preuve de (m1 <= m2),
  - utiliser compatibiliteAdditionGauche_le.
 *)
Proposition compatibiliteAddition_le :
  forall m1 m2 n1 n2, m1 <= m2 -> n1 <= n2 -> (m1 + n1) <= (m2 + n2).
Proof.
Admitted.

(*
  Indication :
  - utiliser compatibiliteAddition_le.
 *)
Proposition compatibiliteAddition_zeroMinDroite_le :
  forall m1 m2 n, m1 <= m2 -> m1 <= (m2 + n).
Proof.
Admitted.

(* Maximum et puissance *)

Fixpoint max(m n : nat) : nat.
  exact (Nat.max m n). (* à modifier *)
Defined.

(*
  Indication :
  - procéder par induction sur m, avec une hypothèse de récurrence
  quantifiée universellement sur n.
 *)
Proposition commutativite_max :
  forall m n, max m n = max n m.
Proof.
Admitted.

Proposition idempotence_max :
  forall n, n = max n n.
Proof.
Admitted.

(*
  Indication :
  - procéder par induction sur m, avec une hypothèse de récurrence
  quantifiée universellement sur n.
 *)
Proposition majorantGauche_max :
  forall m n, m <= max m n.
Proof.
Admitted.

(*
  Indication :
  - utiliser la commutativité.
 *)
Proposition majorantDroite_max :
  forall m n, n <= max m n.
Proof.
Admitted.

Fixpoint puissance(m n : nat) : nat.
  exact (Nat.pow m n). (* à modifier *)
Defined.

(*
  Indication :
  - procéder par induction sur la preuve de (n1 <= n2).
 *)
Proposition croissance_puissance :
  forall (m n1 n2 : nat),
    n1 <= n2 -> puissance (S m) n1 <= puissance (S m) n2.
Proof.
Admitted.

(** *Arbres binaires - Un encadrement de la taille    *)

(* à compléter

-------  [arbreVide]

-----------------------  [arbreCons]

*)

Inductive Arbre(T : Type) : Type :=
(* à modifier *)
.

Proposition principeInductif_Arbre :
  forall (T : Type) (P : Arbre T -> Prop),
    (* à compléter *)
    forall (a : Arbre T), P a.
Proof.
Admitted.

Fixpoint hauteur{T : Type}(a : Arbre T) : nat.
  exact 0. (* à modifier *)
Defined.

Fixpoint taille{T : Type}(a : Arbre T) : nat.
  exact 0. (* à modifier *)
Defined.

Definition unArbre : Arbre nat.
Admitted.

Example hauteurArbre : hauteur (unArbre) = 3.
Admitted.

Example tailleArbre : taille (unArbre) = 5.
Admitted.

(*
  Indication :
  - procéder par induction sur l'arbre,
  - utiliser les propositions démontrées sur les entiers naturels.
 *)
Proposition majorationTaille_Arbre :
  forall T : Type,
  forall a : Arbre T,
    S (taille a) <= (puissance 2 (hauteur a)).
Proof.
Admitted.

(*
  Indication :
  - décomposer la preuve de (inhabited T) en hypothèse
  pour obtenir un élément de T,
  - procéder par induction sur n,
  - utiliser les propositions démontrées sur les entiers naturels,
  - pour prouver une conjonction, utiliser "split".
 *)
Print inhabited.
Proposition majorationOptimaleTaille_Arbre :
  forall T : Type,
    inhabited T ->
    forall n : nat,
    exists a : Arbre T,
      hauteur a = n
      /\
      S (taille a) = (puissance 2 (hauteur a)).
Proof.
Admitted.


(* Import in the following order to minimize trouble:
   stdlib, old corn things, mathclasses, new corn things *)

Require Import Limit.
Require Import abstract_algebra orders additional_operations streams series.

(*
Lemma forall_impl {A} (P Q: ∞ A → Prop) (H1:∀ t, P t → Q t) :
 ∀ t, ForAll P t → ForAll Q t.
Proof.
 cofix G.
 split.
 apply (H1 t).
 destruct H as [Ha _].
 exact Ha.
 destruct H as [_ Hb].
 apply (G (tl t) Hb).
Qed.
*)

(** This section is about computing a generalized version of
 a geometric series.

 A geometric series has the form $s_{i+1} = r * s_i$ for some
 ratio $0 < r < 1$ (should we allow negative values for $a$
 the series will be alternating, however, we don't allow this).

 We impose a further positivity restriction on the elements
 of the series, $0 ≤ s_i$.

*)

Section geom_sum.

(** We work abstractly of an ordered ring R *)
Context `{FullPseudoSemiRingOrder R}.

(** R is not automatically a SemiRing as this causes loops in
   instance search. So we add it locally as this is needed for
   rewrites, e.g. (1)
*)
Instance: SemiRing R := pseudo_srorder_semiring.

(** A geometric series is a series with a constant ratio
    between succesive terms. Here we parametrize by this ratio
*)
Variable r : R.
Hypothesis Hr : 0 < r < 1.

(** A slightly stricter (positive) version of [GeometricSeries],
  which specifies a slightly more general (less-than instead of
  equality) version of a geometric series.
*)
Definition ARGeometricSeries : ∞ R → Prop :=
  ForAll (λ xs, 0 ≤ hd (tl xs) ≤ r * hd xs).

Section properties.

Context `(gs: ARGeometricSeries s).

(** If [s] is a geometric series, then so is it's tail *)
Lemma gs_tl : ARGeometricSeries (tl s).
Proof.
  apply ForAll_tl; now assumption.
Qed.

(** Every element in a geometric series is positive *)
Lemma gs_positive : 0 ≤ hd s.
Proof.
  destruct gs as [GS FA].
  apply (maps.order_reflecting_pos (.*.) r); try tauto.
  rewrite rings.mult_0_r.
  transitivity (hd (tl s)); tauto.
Qed.

(** A geometric series is always decreasing *)
Lemma gs_decreasing : hd (tl s) ≤ hd s.
Proof.
  destruct gs.
  apply (maps.order_reflecting_pos (.*.) r); try tauto.
  transitivity (hd (tl s)); try tauto.
  rewrite <- (rings.mult_1_l (hd (tl s))) at 2.
  apply semirings.mult_le_compat; try solve [apply orders.lt_le; tauto].
   tauto.
  reflexivity.
Qed.

Notation "'x₀'" := (hd s).

(* if only...

   Notation "'xₙ₊1'" := (Str_nth (n + 1) s).
   Notation "'xₙ'"   := (Str_nth n s).
*)
Require Import nat_pow.

Lemma helper n `{xs:∞A} : Str_nth (1 + n) xs ≡ hd (tl (Str_nth_tl n xs)).
Admitted.

(* [peano_naturals.nat_induction] is a induction scheme that uses
   type classed naturals. *)

Lemma gs_nth_rn n : Str_nth n s ≤ r^n * x₀.
Proof.
  induction n using peano_naturals.nat_induction.
   rewrite nat_pow_0, rings.mult_1_l; compute; reflexivity.
  rewrite nat_pow_S.
  apply (ForAll_Str_nth_tl n) in gs.
  destruct gs as [[GS1 GS2] FA].
  replace (hd (Str_nth_tl n s)) with (Str_nth n s) in GS2 by auto.
  replace (hd (tl (Str_nth_tl n s))) with (Str_nth (1+n) s) in GS2.
  transitivity (r * Str_nth n s); [assumption|].
  rewrite <- associativity.
  apply (maps.order_preserving_nonneg (.*.) r).
   apply orders.lt_le. destruct Hr as [Ha Hb].
  auto.
  assumption.
  apply helper.
Admitted.

End properties.

(** A geometric series is decreasing and non negative. *)
Lemma gs_dnn `(gs: ARGeometricSeries s) : DecreasingNonNegative s.
Proof.
 revert s gs.
 cofix FIX; intros s gs.
 constructor.
  now split; auto using gs_positive, gs_tl, gs_decreasing.
 now apply FIX, gs_tl.
Qed.

End geom_sum.


Require Import Reals Interval.Tactic.

Goal forall x, (-1 / 3 <= x - x <= 1 / 7)%R.
Proof.
intros x.
interval with (i_bisect_diff x).
Qed.


Require Import Util CSet StableFresh Even.
Require Import InfiniteSubset SafeFirstInfiniteSubset Take TakeSet.

Set Implicit Arguments.

Record inf_partition  X `{OrderedType X}  :=
  { part_1 : inf_subset X;
    part_2 : inf_subset X;
    part_disj : forall x, part_1 x -> part_2 x -> False;
    part_cover : forall x, part_1 x + part_2 x;
  }.

Arguments inf_partition X {H}.

Lemma part_dich  X `{OrderedType X}  (p:inf_partition X) x
  : (part_1 p x /\ (part_2 p x -> False)) \/ (part_2 p x /\ (part_1 p x -> False)).
Proof.
  destruct (part_cover p x);
    pose proof (part_disj p x); cset_tac.
Qed.

Definition even_part : inf_partition nat.
Proof.
  refine (Build_inf_partition even_inf_subset odd_inf_subset _ _).
  - intros.
    unfold even_inf_subset in H. simpl in H.
    unfold odd_inf_subset in H0. simpl in H0.
    unfold odd in H0. unfold negb in H0. cases in H0; eauto.
  - intros.
    unfold even_inf_subset, odd_inf_subset, odd, negb; simpl.
    cases; eauto.
Defined.

Definition even_part_pos : inf_partition positive.
Proof.
  refine (Build_inf_partition even_inf_subset_pos odd_inf_subset_pos _ _).
  - intros.
    unfold even_inf_subset in H. simpl in H.
    unfold odd_inf_subset in H0. simpl in H0.
    unfold odd in H0. unfold negb in H0. cases in H0; eauto.
  - intros.
    unfold even_inf_subset, odd_inf_subset, odd, negb; simpl.
    rewrite <- even_pos_fast_correct.
    eapply even_or_odd.
Defined.

Arguments even_part_pos : simpl never.
Arguments even_part : simpl never.

(*
Require Import SafeFirst.

Lemma fresh_variable_always_exists_in_inf_subset X `{NaturalRepresentationSucc X}
      `{@NaturalRepresentationMax X H H0}
      (lv:set X) (p:inf_subset X) n
: safe (fun x => x ∉ lv /\ p x) n.
Proof.
  - decide (_lt (SetInterface.fold max lv (ofNat 0)) n).
    + decide (p n).
      * econstructor. split; eauto.
        intro. cset_tac'.
        eapply (@fold_max_lt X _ _ _ _) in H5; eauto.
        simpl in *. exfalso. nr. simpl in *. omega.
        eapply (@fold_max_lt X _ _ _ _) in H5; eauto.
        simpl in *. exfalso. nr. simpl in *. omega.
      * edestruct (inf_subset_inf p n); dcr. cbn in *.
        eapply (@safe_antitone _ _ _ _ _ _ _ x); eauto.
        econstructor; split; eauto.
        intro. cset_tac'.
        eapply (@fold_max_lt X _ _ _ _) in H8; eauto.
        simpl in *. exfalso. nr. simpl in *. omega.
        eapply (@fold_max_lt X _ _ _ _) in H8; eauto.
        simpl in *. exfalso. nr. simpl in *. omega.
    + decide (p (succ (SetInterface.fold max lv (ofNat 0)))).
      * eapply safe_antitone. eauto.
        instantiate (1:=succ (SetInterface.fold max lv (ofNat 0))).
        econstructor. split; eauto. intro.
        cset_tac'.
        eapply (@fold_max_lt X _ _ _ _) in H5; eauto.
        simpl in *. exfalso. nr. simpl in *. omega.
        eapply (@fold_max_lt X _ _ _ _) in H5; eauto.
        simpl in *. exfalso. nr. simpl in *. omega.
        simpl in *. nr. omega.
      * edestruct (inf_subset_inf p (succ (fold max lv (ofNat 0))));
          dcr.
        eapply (@safe_antitone _ _ _ _ _ _ _ x).
        econstructor; split; eauto.
        cset_tac'.
        eapply (@fold_max_lt X _ _ _ _) in H8; eauto.
        simpl in *. exfalso. clear H6. nr. omega.
        eapply (@fold_max_lt X _ _ _ _) in H8; eauto.
        simpl in *. exfalso. clear H6. nr. omega.
        simpl in *. clear H6. nr. omega.
        Grab Existential Variables. eauto. eauto.
Qed.
*)

Lemma fresh_variable_always_exists_in_inf_subset X `{OrderedType X}
      (lv:set X) (p:inf_subset X) k
  : forall n, cardinal lv <= n ->
         SafeFirstInfiniteSubset.safe p (fun x => x ∉ lv /\ p x) k.
Proof.
  intros. general induction n.
  - exploit (@cardinal_inv_1 _ _ _ _ lv); try omega; eauto.
    econstructor. intros.
    econstructor; intros.
    exfalso. revert H3. destr_sig. cset_tac.
  - econstructor; intros. clear H1.
    decide ((proj1_sig (inf_subset_inf p k)) ∈ lv).
    + econstructor; intros.
      eapply safe_impl'.
      eapply (IHn (lv \ singleton (proj1_sig (inf_subset_inf p k))) p).
      * rewrite cardinal_difference'; [|cset_tac].
        rewrite singleton_cardinal. omega.
      * revert i H1. repeat destr_sig. dcr. intros. cset_tac'.
        -- rewrite <- H10 in *. clear H10 x1. clear_trivial_eqs. eauto.
    + econstructor; intros.
      exfalso. revert n0 H1.
      destr_sig. cset_tac.
Qed.

Definition least_fresh_P X `{OrderedType X}
           (p:inf_subset X) (lv:set X) : X.
  refine (@safe_first X H p (fun x => x ∉ lv /\ p x) _ (proj1_sig (inf_subset_least p)) _).
  eapply fresh_variable_always_exists_in_inf_subset. reflexivity.
Defined.

(*Definition least_fresh_P' X `{OrderedType X}
           (p:inf_subset X) (lv:set X) : X.
  refine (@SafeFirstInfiniteSubset.safe_first X H p (fun x => x ∉ lv /\ p x) _
                                              (proj1_sig (inf_subset_least p)) _).
  - eapply fresh_variable_always_exists_in_inf_subset; eauto.
Defined.*)

Lemma least_fresh_P_full_spec X `{OrderedType X}
      p (G:set X)
  : least_fresh_P p G ∉ G
    /\ (forall m, p m ->  _lt m (least_fresh_P p G) -> m ∈ filter p G)
    /\ p (least_fresh_P p G).
Proof.
  unfold least_fresh_P.
  eapply safe_first_spec with
  (I:= fun n => forall m, p m -> _lt m n -> m ∈ filter p G).
  - intros. rewrite de_morgan_dec, <- in_dneg in H1.
    destruct H1.
    + decide (m === n); subst; eauto.
      * cset_tac.
      * exploit (H0 m); eauto.
        revert H3. destr_sig; dcr; intros.
        edestruct (H6 m); eauto.
        cset_tac.
    + decide (m === n); subst; eauto.
      * exfalso. eapply H1. rewrite <- e. eauto.
      * exploit (H0 m); eauto.
        revert H3. destr_sig; dcr; intros.
        edestruct (H6 m); eauto.
        cset_tac.
  - intros. cset_tac.
  - intros. exfalso.
    revert H1. destr_sig; dcr; intros.
    edestruct (H2 m); eauto.
Qed.

Lemma least_fresh_P_ext  X `{OrderedType X} p (G G' : ⦃X⦄)
  : G [=] G' -> least_fresh_P p G = least_fresh_P p G'.
Proof.
  intros. unfold least_fresh_P; eauto.
  eapply safe_first_ext. intros. rewrite H0. reflexivity.
Qed.

Lemma least_fresh_P_p X `{OrderedType X} (p:inf_subset X) G
  : p (least_fresh_P p G).
Proof.
  eapply least_fresh_P_full_spec.
Qed.

Definition stable_fresh_P  X `{OrderedType X} (isub:inf_subset X) : StableFresh X.
  refine (Build_StableFresh (fun lv _ => least_fresh_P isub lv) _ _).
  - intros. eapply least_fresh_P_full_spec.
  - intros. eapply least_fresh_P_ext; eauto.
Defined.

Lemma semantic_branch (P Q:Prop) `{Computable Q}
  : P \/ Q -> ((~ Q /\ P) \/ Q).
Proof.
  decide Q; clear H; intros; intuition.
Qed.

Definition least_fresh_P_oracle X `{OrderedType X}
           (p:inf_subset X) (lv:set X) (o:X->X) (x:X) :=
  let y := o x in
  if [p y /\ y ∉ lv]
  then y
  else least_fresh_P p lv.

Definition least_fresh_part X `{OrderedType X} (p:inf_partition X) (o2:X -> X)
           (G:set X) x :=
  if part_1 p x then
    least_fresh_P (part_1 p) G
  else
    least_fresh_P_oracle (part_2 p) G o2 x.

Lemma least_fresh_part_fresh X `{OrderedType X} p G x o2
  : least_fresh_part p o2 G x ∉ G.
Proof.
  unfold least_fresh_part; cases; eauto.
  - eapply least_fresh_P_full_spec.
  - unfold least_fresh_P_oracle. cases; dcr; eauto.
    eapply least_fresh_P_full_spec.
Qed.

Lemma least_fresh_part_1 X `{OrderedType X} (p:inf_partition X) G x o2
  : part_1 p x
    -> part_1 p (least_fresh_part p o2 G x).
Proof.
  unfold least_fresh_part; intros; cases.
  eapply least_fresh_P_full_spec.
Qed.

Lemma least_fresh_part_2  X `{OrderedType X} (p:inf_partition X) G x o2
  : part_2 p x
    -> part_2 p (least_fresh_part p o2 G x).
Proof.
  unfold least_fresh_part; intros. cases.
  - exfalso. eapply (part_disj p); eauto.
  - unfold least_fresh_P_oracle. cases; dcr; eauto.
    eapply least_fresh_P_full_spec.
Qed.

Lemma least_fresh_part_p1 X `{OrderedType X}
      (p:inf_partition X) G x o2
  : part_1 p (least_fresh_part p o2 G x) -> part_1 p x.
Proof.
  intros. edestruct part_cover; eauto.
  eapply least_fresh_part_2 in i.
  exfalso. eapply part_disj in H0; eauto.
Qed.

Lemma least_fresh_part_p2 X `{OrderedType X}
      (p:inf_partition X) G x o2
  : part_2 p (least_fresh_part p o2 G x) -> part_2 p x.
Proof.
  intros. edestruct part_cover; eauto.
  eapply least_fresh_part_1 in i.
  exfalso. eapply part_disj in H0; eauto.
Qed.

Lemma least_fresh_part_ext  X `{OrderedType X} p (G G' : ⦃X⦄) x o2
  : G [=] G' -> least_fresh_part p o2 G x = least_fresh_part p o2 G' x.
Proof.
  intros. unfold least_fresh_part, least_fresh_P_oracle; repeat cases; eauto using least_fresh_P_ext.
  exfalso. cset_tac.
  exfalso. cset_tac.
Qed.

Definition stable_fresh_part  X `{OrderedType X} (p:inf_partition X) (o2:X->X) : StableFresh X.
  refine (Build_StableFresh (least_fresh_part p o2) _ _).
  - intros. eapply least_fresh_part_fresh.
  - intros. eapply least_fresh_part_ext; eauto.
Defined.

Lemma least_fresh_list_part_ext  X `{OrderedType X} p n G G' o2
  : G [=] G'
    -> fst (fresh_list_stable (stable_fresh_part p o2) G n)
      = fst (fresh_list_stable (stable_fresh_part p o2) G' n).
Proof.
  eapply fresh_list_stable_ext.
  intros. eapply least_fresh_part_ext; eauto.
Qed.

Lemma fresh_list_stable_P_ext  X `{OrderedType X} p G L L'
  : ❬L❭ = ❬L'❭
    -> of_list (fst (fresh_list_stable (stable_fresh_P p) G L))
              ⊆ of_list (fst (fresh_list_stable (stable_fresh_P p) G L')).
Proof.
  intros. hnf; intros ? In.
  general induction H0; simpl in *.
  - cset_tac.
  - revert In. repeat let_pair_case_eq; repeat simpl_pair_eqs; subst; simpl; eauto.
    cset_tac.
Qed.

Lemma fresh_list_stable_P_ext_eq  X `{OrderedType X} p G L L'
  : ❬L❭ = ❬L'❭
    -> of_list (fst (fresh_list_stable (stable_fresh_P p) G L))
              [=] of_list (fst (fresh_list_stable (stable_fresh_P p) G L')).
Proof.
  split; intros.
  - eapply fresh_list_stable_P_ext; eauto.
  - eapply fresh_list_stable_P_ext; [symmetry|]; eauto.
Qed.

Lemma least_fresh_part_1_back  X `{OrderedType X} (p:inf_partition X) G x o2
  : part_1 p (least_fresh_part p o2 G x ) -> part_1 p x.
Proof.
  intros.
  decide (part_1 p x); eauto.
  destruct (part_cover p x); eauto.
  eapply least_fresh_part_2 in i.
  edestruct (part_disj p); eauto.
Qed.

Lemma least_fresh_part_2_back  X `{OrderedType X} (p:inf_partition X) G x o2
  : part_2 p (least_fresh_part p o2 G x) -> part_2 p x.
Proof.
  intros.
  decide (part_2 p x); eauto.
  destruct (part_cover p x); eauto.
  eapply least_fresh_part_1 in i.
  edestruct (part_disj p); eauto.
Qed.

Lemma cardinal_filter_part  X `{OrderedType X} p G Z o2
      (UNIQ:NoDupA _eq Z)
  : cardinal (filter (part_1 p)
                     (of_list (fst (fresh_list_stable (stable_fresh_part p o2) G Z))))
    = cardinal (filter (part_1 p) (of_list Z)).
Proof.
  general induction Z; simpl.
  - reflexivity.
  -  repeat let_pair_case_eq; repeat simpl_pair_eqs; subst; simpl.
    decide (part_1 p a).
    + rewrite filter_add_in; eauto using least_fresh_part_1.
      rewrite filter_add_in; eauto.
      rewrite !add_cardinal_2; eauto.
      * intro. inv UNIQ. cset_tac.
      * exploit (fresh_list_stable_spec (stable_fresh_part p o2));
        eauto using least_fresh_part_fresh.
        cset_tac'.
        eapply H0; cset_tac.
    + rewrite filter_add_notin; eauto.
      rewrite filter_add_notin; eauto.
      eauto using least_fresh_part_1_back.
Qed.

Lemma cardinal_smaller  X `{OrderedType X}
      p n (G:set X) (Z:list X) x o2
      (GET:get Z n x) (P1:part_1 p x) (ND: NoDupA _eq Z)
  : SetInterface.cardinal
    (filter (part_1 p)
       (of_list
          (take n
             (fst
                (fresh_list_stable (stable_fresh_part p o2) G Z)))))
    < SetInterface.cardinal (filter (part_1 p) (of_list Z)).
Proof.
  general induction Z; simpl;
    let_pair_case_eq; simpl_pair_eqs; subst; simpl; destruct n; simpl.
  - inv GET.
    + rewrite filter_incl; eauto. rewrite empty_cardinal.
      rewrite filter_add_in; eauto.
      rewrite add_cardinal_2. omega. inv ND.
      rewrite filter_incl; eauto.
  - inv GET.
    + decide (part_1 p a).
      * rewrite filter_add_in; eauto using least_fresh_part_1.
        rewrite filter_add_in; eauto.
        rewrite !add_cardinal_2.
        -- eapply lt_n_S.
           eapply IHZ; eauto.
        -- rewrite filter_incl; eauto.
        -- rewrite filter_incl, take_list_incl; eauto.
           hnf; intro IN.
           eapply fresh_list_stable_spec in IN. cset_tac.
      * rewrite filter_add_notin; eauto using least_fresh_part_1.
        rewrite filter_add_notin; eauto.
        intro; eapply n0. eapply least_fresh_part_p1; eauto.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega.

Require Import Definitions.

Require Import utils pos vec.
Require Import subcode sss.
Require Import tiles_solvable bsm_defs bsm_pcp.

Fact tile_concat_itau ln lt : tile_concat ln lt = (itau1 lt (rev ln), itau2 lt (rev ln)).
Proof.
  induction ln as [ | i ln IH ]; simpl; auto.
  rewrite itau1_app, itau2_app; simpl.
  unfold card, string; generalize (nth i lt ([] / [])); intros (a,b); rewrite IH.
  repeat rewrite <- app_nil_end; auto.
Qed.

(* tiles_solvable & iBPCP is the same predicate except that the existentially
   quantified list is reversed *)

Theorem tiles_solvable_iBPCP lt : tiles_solvable lt <-> iBPCP lt.
Proof.
  split.
  + intros (ln & H1 & H2 & H3).
    rewrite tile_concat_itau in H3.
    exists (rev ln).
    rewrite <- Forall_forall.
    repeat split; auto.
    * apply Forall_rev; auto.
    * contradict H1; rewrite <- (rev_involutive ln), H1; auto.
  + intros (ln & H1 & H2 & H3).
    exists (rev ln).
    rewrite tile_concat_itau, rev_involutive.
    repeat split; auto.
    * contradict H2; rewrite <- (rev_involutive ln), H2; auto.
    * apply Forall_rev, Forall_forall; auto.
Qed.

Local Notation "P // s ->> t" := (sss_compute (@bsm_sss _) P s t).
Local Notation "P // s ~~> t" := (sss_output (@bsm_sss _) P s t).
Local Notation "P // s ↓" := (sss_terminates (@bsm_sss _) P s).

Section iBPCP_BSM_HALTING.

  Let f (lt : list (card bool)) : BSM_PROBLEM.
  Proof.
    exists 4, 1, (pcp_bsm lt).
    exact (vec_set_pos (fun _ => nil)).
  Defined.

  Goal forall x, | pcp_bsm x| >= 80.
    intros; rewrite pcp_bsm_size; omega.
  Qed.

  Theorem iBPCP_BSM_HALTING : iBPCP ⪯ BSM_HALTING.
  Proof.
    exists f.
    intros lt.
    rewrite <- tiles_solvable_iBPCP.
    unfold BSM_HALTING; split.
    * intros H.
      apply pcp_bsm_sound with (v := vec_set_pos (fun _ => nil)) in H.
      match type of H with  _ // _ ->> (?q,?w) => exists (q, w) end.
      split; auto.
      simpl; omega.
    * intros ((q & w) & H).
      apply pcp_bsm_complete in H; tauto.
  Qed.

End iBPCP_BSM_HALTING.


Theorem noncontradiction : forall P : Prop, P /\ ~ P -> False.
Proof.
  intros P pf_P_and_nP.
  unfold not in pf_P_and_nP.
  destruct pf_P_and_nP as (pf_P & pf_nP).
  exact (pf_nP pf_P).
Qed.

Theorem explosion : forall P : Prop, False -> P.
Proof.
  intros P pf_False.
  case pf_False.
Qed.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint even (even_arg0 : natural) : bool
           := match even_arg0 with
              | Zero => true
              | Succ n => negb (even n)
              end.

Lemma lem: forall m n, even (plus m n) = negb (even (plus m (Succ n))).
Proof.
induction m.
  - intros. simpl. rewrite <- IHm. reflexivity.
  - intros. simpl. unfold negb. destruct (even n). reflexivity. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural), eq (even (plus x x)) true.
Proof.
induction x.
- simpl. rewrite <- lem. assumption.
- reflexivity.
Qed.