(** * Exploring equality via homotopy and proof assistants - Day 3 - Inductive types and their equalities *)
(** This file contains the exercises for Day 3.  Some are explicitly marked as "Homework"; the rest can be done either in class or for homework.

  If the Macs in the computer lab do not have CoqIDE installed, you can go to https://coq.inria.fr/coq-85, download CoqIDE_8.5beta2.dmg, open it, and run CoqIDE directly, without installing it.

  When doing exercises on your own, feel free to skip around; there are some interesting puzzles near the bottom.

  If you feel like you know exactly how a proof will go, but find it painful and tedious to write out the proof terms explicitly, come find me.  Coq has a lot of support for automation and taking care of things that are easy and verbose, so you don't have to. Proving should feel like a game.  If it doesn't, I can probably help you with that.  *)

(** The following are placeholders; [admit] indicates that something should be filled in later. *)

Axiom admit : forall {T}, T.

(** Compatibility between Coq 8.5 and 8.4 *)

Set Asymmetric Patterns.

(* begin hide *)
(** Some filled in exercises from yesterday; feel free to paste more here. *)

Notation refl := eq_refl.
Definition sym : forall A (x y : A), x = y -> y = x := eq_sym.
(** We allow writing [sym p] to mean [sym _ _ _ p] *)
Arguments sym {A x y} p, A x y p.
Definition trans : forall A (x y z : A), x = y -> y = z -> x = z
  := eq_trans.
Arguments trans {A x y z} p q, A x y z p q.
Definition J : forall (A : Type) (x : A) (y : A)
                      (H : x = y)
                      (P : forall (y' : A) (H' : x = y'), Type),
                 P x refl -> P y H
  := fun A x y H P k => match H with
                          | refl => k
                        end.
Arguments J {A} {x} {y} H P _.
Definition ap : forall A B (f : A -> B) (x y : A), x = y -> f x = f y
  := fun A B f x y p
     => match p with
          | refl => refl
        end.

Arguments ap {A B} f {x y} p, {A B} f x y p, A B f x y p.

(* end hide *)

(** ** Guiding Puzzles *)

(** There are three guiding questions for today:

 1. What are (inductive) types?
 2. What does it mean to say that two inhabitants of a given type are equal?
 3. Where is equality under-specified, and how can we extend the patterns we see to fill in these areas? *)

(** *** Puzzle 1: contractibility of based path spaces *)

(** We use the notation [{ x : T | P x }] to denote the type of pairs [(x; p)] which consist of an inhabitant [x : T] and a proof [p : P x]. *)

Notation "{ x  |  P }" := ({ x : _ & P }) : type_scope.
Notation "{ x : A  |  P }" := ({ x : A & P }) : type_scope.
Notation "( x ; p )" := (existT _ x p).

(** A type is called contractible if there is a (continuous!) function showing that all inhabitants are equal to a particular one. *)

Definition is_contractible : Type -> Type
  := fun A => { center : A | forall y : A, center = y }.

(** Puzzle: The following theorem is provable.  Prove it. *)

Definition contractible_pointed
: forall (A : Type) (y : A),
    is_contractible { x : A | y = x }
  := admit.

(** Note that [x = y :> T] means [x : T], [y : T], and [x = y].  It is the notation for [@eq T x y].  It is how we write $x =_T y$ #x =T y# in Coq. *)

(** Since equals are inter-substitutable, we should be able to prove: *)

Definition contractible_to_UIP
: forall (A : Type) (y : A)
         (x : A)
         (p p' : y = x),
    ((x; p) = (x; p') :> { x : A | y = x })
    -> p = p'
  := admit.

(** But it turns out that we can't prove this.  Why not?  Give both a formal, type theoretic reason (what terms don't typecheck?), and a topological reason. *)

(** *** Puzzle 2: understanding the encode-decode method *)

(** Here is a concrete puzzle for the second question:

  To classify the equality of a given type, we give a "code" for each pair of elements.  We must say how to "encode" equality proofs, and how to "decode" codes into equality proofs.  We want this to be an isomorphism, i.e., [encode ∘ decode] and [decode ∘ encode] should both be the identity function.  It turns out that we don't need to know anything about [encode] or [decode] other than their existance to ensure this; we can always adjust [decode] to create an inverse to [encode], as long as a particular property holds of [code].  What is that property?

  More concretely, the puzzle is to fill in the following holes. *)

Section general_classification.

  Definition code_correct_P
  : forall {A : Type} (code : A -> A -> Type), Type
    := admit.

  (** We assume we are given a type, a [code], an [encode], and a [decode].  We introduce the assumptions as we get to definitions that should need them. *)

  Context {A : Type} (code : A -> A -> Type)
          (decode' : forall x y, code x y -> x = y).

  Definition decode
  : forall {x y}, code x y -> x = y
    := admit.

  Context (encode : forall x y, x = y -> code x y).

  Definition deencode
  : forall {x y} (p : x = y),
      decode (encode _ _ p) = p
    := admit.

  (** For this last one, we'll need the correctness property on codes. *)

  Context (code_correct : code_correct_P code).

  Definition endecode
  : forall {x y} (p : code x y),
      encode _ _ (decode p) = p
    := admit.

End general_classification.

(** The following sanity check on the classification should be provable: *)

Section sanity_checks.

  (** [x = y] should be a valid code *)

  Definition eq_is_valid_code
  : forall {A : Type},
      code_correct_P (fun x y : A => x = y)
    := admit.

  (** If you didn't choose a silly correctness property like [code = (fun x y => x = y)], then your proof should generalize to the following: *)

  (** Suppose we are given a valid encoding. *)

  Context {A : Type} (code : A -> A -> Type)
          (encode : forall x y, x = y -> code x y)
          (decode : forall x y, code x y -> x = y)
          (endecode : forall x y (p : code x y), encode _ _ (decode _ _ p) = p)
          (deencode : forall x y (p : x = y), decode _ _ (encode _ _ p) = p).

  (** Then it should satisfy your validity principle. *)

  Definition valid_code_is_valid : code_correct_P code
    := admit.

End sanity_checks.

(** *** Puzzle 3 *)

(** Classify the equalities of types.  That is, fill in the following: *)

Definition Type_code
: forall (x y : Type), Type
  := admit.

Definition Type_encode
: forall {x y : Type}, x = y -> Type_code x y
  := admit.

(** The following are unprovable in Coq, currently.  They are collectively known as the "univalence axiom". *)

Axiom Type_decode
: forall {x y : Type}, Type_code x y -> x = y.
Axiom Type_endecode
: forall {x y : Type} (p : Type_code x y),
    Type_encode (Type_decode p) = p.
Axiom Type_deencode
: forall {x y : Type} (p : x = y),
    Type_decode (Type_encode p) = p.

(** This was all very abstract.  Let's drill down with some exmples. *)

(** ** Inductive Types *)

(** First, we must understand the types which we are classifying the path-spaces of. *)

(** An inductive type is specified by introduction and elimination rules; introduction rules tell you how to create inhabitants (elements) of a type, and elimination rules tell you how to use such inhabitants.  Coq generate eliminations rules automatically, but we will try to come up with the first few without peeking. *)

Inductive unit : Set := tt.

(** Coq has special syntax for [nat], so we don't overwrite it. *)

(** Inductive nat' : Type := ... *)

(** Inductive Empty_set : Type := ... *)

(** Anecdote: Proving [unit -> Empty_set] (i.e., [True -> False]) by recursion on [unit], if we assume that [True = (False -> False)] *)

(** Any that we don't do in class are homework *)

Inductive bool : Type := true | false.

(** A notational helper. *)

Add Printing If bool.

(** Inductive prod (A B : Type) : Type := ... *)

(** Some notational helpers *)

(**
<<
Arguments pair {A B} _ _.

Add Printing Let prod.

Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.

Example prod_1 := (1, 1) : nat * nat.
Example prod_2 := (1, 2) : nat * nat.
Example prod_3 := (true, true) : bool * bool.
Example prod_4 := (1, true) : nat * bool.

(** We use curlie braces so that we don't have to pass the arguments explicitly all the time. *)

Definition fst
: forall {A B}, A * B -> A
:= admit.

Definition snd
: forall {A B}, A * B -> B
:= admit.

>> *)

(** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)

(** Inductive sum (A B : Type) : Type := ... *)

(** Notational helpers *)

(**
<<
Notation "x + y" := (sum x y) : type_scope.

Arguments inl {A B} _ , [A] B _.
Arguments inr {A B} _ , A [B] _.
>> *)

Example sum_1 := inl tt : unit + nat.
Example sum_2 := inr 0 : unit + nat.

(** Inductive sigT A (B : A -> Type) : Type := ... *)

(** Notational helpers *)

(**
<<
Arguments sigT {A} B.
Arguments existT {A} B _ _.
Notation "{ a : A  & B }" := (sigT (A:=A) (fun a => B)) : type_scope.
>> *)

Notation "{ a  |  B }" := ({ a : _ & B }) : type_scope.
Notation "{ a : A  |  B }" := ({ a : A & B }) : type_scope.
Notation "( a ; b )" := (existT _ a b).

Example non_dependent_pair_1 :=
  (true; 0) : sigT (fun a : bool => nat).
Example non_dependent_pair_2 :=
  (true; 1) : { a : bool | nat }.
Example non_dependent_pair_3 :=
  (false; 1) : { a : bool | nat }.
Example dependent_pair_1 :=
  (true; 1) : { a : bool | if a then nat else unit }.
Example dependent_pair_2 :=
  (true; 0) : { a : bool | if a then nat else unit }.
Example dependent_pair_3 :=
  (false; tt) : { a : bool | if a then nat else unit }.
Fail Example dependent_pair_4 :=
  (false; 0) : { a : bool | if a then nat else unit }.

(** The projections *)

(**
<<
Definition projT1
: forall {A B}, { a : A | B a } -> A
  := admit.

Definition projT2
: forall {A B} (x : { a : A | B a}), B (projT1 x)
  := admit.
>> *)

(** Notational helpers for the projections *)

Notation "x .1" := (projT1 x) (at level 3, format "x '.1'").
Notation "x .2" := (projT2 x) (at level 3, format "x '.2'").

(** Inductive option (A : Type) : Type := ... *)

(** Inductive list (A : Type) : Type := ... *)

(** Function types also have intro and elim rules, though they don't have syntactic forms.  Can you describe them? *)

(** Note well: [J] is the eliminator for the equality type. *)

(** *** Provable equalities *)

(** What equalities of types are provable? *)

Inductive unit1 := tt1.
Inductive unit2 := tt2.

(** *** Provable inequalities *)

(** What equalities of types are provably absurd? *)

(** More generally, when are two types provably different? *)

(** *** Isomorphisms *)

(** We can define a notion of isomorphism: *)

Class IsIsomorphism {A B} (f : A -> B)
  := { iso_inv : B -> A;
       right_inv : forall x : B, f (iso_inv x) = x;
       left_inv : forall x : A, iso_inv (f x) = x }.

Arguments iso_inv {A B} f {_} _.
Arguments right_inv {A B f _ _}, {A B} f {_} _.
Arguments left_inv {A B f _ _}, {A B} f {_} _.

Record Isomorphic A B
  := { iso_fun : A -> B;
       iso_isiso : IsIsomorphism iso_fun }.

Arguments iso_fun {A B} _ _.

(** Let us use an object of type [Isomorphic] as a function: *)

Coercion iso_fun : Isomorphic >-> Funclass.

(** Tell Coq that the function associated to an [Isomorphic] object is always an isomorphism. *)

Existing Instance iso_isiso.

Notation "A <~=~> B" := (Isomorphic A B) (at level 70).
Notation "A ≅ B" := (Isomorphic A B) (at level 70).

(** We can prove the standard properties about isomorphisms: *)

Definition Isomorphic_refl : forall {A}, A ≅ A
  := admit.

Definition Isomorphic_inverse : forall {A B}, A ≅ B -> B ≅ A
  := admit.

Definition Isomorphic_compose : forall {A B C}, A ≅ B -> B ≅ C -> A ≅ C
  := admit.

(** We would like to prove the last corresponding law: *)

Definition Isomorphic_ap : forall (f : Type -> Type) {A B}, A ≅ B -> f A ≅ f B
  := admit.

(** But it's not provable!  Here's a counter-example: *)

(** Recall the taboo from earlier; we can't prove equality of two identical types defined separately.  But if we could prove [Isomorphic_ap], then we could prove this! *)

Definition iso_unit2_unit1 : unit2 ≅ unit1
  := admit.

Definition taboo1 : unit1 = unit2 :> Type
  := admit.

(** Ooops!  We'll be coming back to this soon. *)

(** More practice: You can prove the higher groupoid laws about isomorphisms, but it's a bit of a pain. *)

(** Before dealing with the taboo above, let's classify the equality space of isomorphisms. *)

(** ** Equality classification *)

(** We can classify the equality types.  For each type, we come up with a simpler type that represents ("codes for") its equality type.  Then we prove that this type is isomorphic to the given equality type.  The exercises here are all to help understand how the encode-decode method works, to build up to function extensionality and univalence, and, for sigma types, to solve the first puzzle.  We'll do them as needed to explain the method; the rest are (optional) homework.  There are more exercises at the bottom of the file. *)

(** *** [unit] *)

Definition unit_code : forall (x y : unit), Type
  := admit.

(** We use curlie braces to not have to pass the [x] and [y] around all the time. *)

Definition unit_encode : forall {x y : unit}, x = y -> unit_code x y
  := admit.

Definition unit_decode : forall {x y : unit}, unit_code x y -> x = y
  := admit.

Definition unit_endecode : forall {x y} (p : unit_code x y),
                             unit_encode (unit_decode p) = p
  := admit.

Definition unit_deencode : forall {x y} (p : x = y),
                             unit_decode (unit_encode p) = p
  := admit.

Definition unit_iso : forall x y : unit, (x = y) ≅ unit_code x y
  := fun x y
     => {| iso_fun := unit_encode;
           iso_isiso := {| iso_inv := unit_decode;
                           right_inv := unit_endecode;
                           left_inv := unit_deencode |} |}.

(** *** [bool] *)

Definition bool_code : forall (x y : bool), Type
  := admit.

Definition bool_encode : forall {x y : bool}, x = y -> bool_code x y
  := admit.

Definition bool_decode : forall {x y : bool}, bool_code x y -> x = y
  := admit.

Definition bool_endecode : forall {x y : bool} (p : bool_code x y),
                             bool_encode (bool_decode p) = p
  := admit.

Definition bool_deencode : forall {x y : bool} (p : x = y),
                             bool_decode (bool_encode p) = p
  := admit.

(** *** [Empty_set] *)

Definition Empty_set_code : forall (x y : Empty_set), Type
  := admit.

Definition Empty_set_encode : forall {x y : Empty_set},
                                x = y -> Empty_set_code x y
  := admit.

Definition Empty_set_decode : forall {x y : Empty_set},
                                Empty_set_code x y -> x = y
  := admit.

Definition Empty_set_endecode : forall {x y : Empty_set} (p : Empty_set_code x y),
                                  Empty_set_encode (Empty_set_decode p) = p
  := admit.

Definition Empty_set_deencode : forall {x y : Empty_set} (p : x = y),
                                  Empty_set_decode (Empty_set_encode p) = p
  := admit.

(** *** arrow types *)

Definition arrow_code : forall {A B} (f g : A -> B), Type
  := admit.

Definition arrow_encode : forall {A B} {f g : A -> B}, f = g -> arrow_code f g
  := admit.

(** The rest aren't currently provable in Coq; it's the axiom of functional extensionality. *)

Axiom arrow_decode : forall {A B} {f g : A -> B}, arrow_code f g -> f = g.
Axiom arrow_endecode : forall {A B} {f g : A -> B} (p : arrow_code f g),
                         arrow_encode (arrow_decode p) = p.
Axiom arrow_deencode : forall {A B} {f g : A -> B} (p : f = g),
                         arrow_decode (arrow_encode p) = p.

(** *** Pi types (dependent function types) *)

Definition function_code : forall {A B} (f g : forall a : A, B a), Type
  := admit.

Definition function_encode : forall {A B} {f g : forall a : A, B a}, f = g -> function_code f g
  := admit.

(** The rest aren't currently provable in Coq; it's the axiom of functional extensionality. *)

Axiom function_decode : forall {A B} {f g : forall a : A, B a}, function_code f g -> f = g.
Axiom function_endecode : forall {A B} {f g : forall a : A, B a} (p : function_code f g),
                            function_encode (function_decode p) = p.
Axiom function_deencode : forall {A B} {f g : forall a : A, B a} (p : f = g),
                            function_decode (function_encode p) = p.

(** *** [sigma] (dependent pairs) *)

(** Homework *)

Definition sigma_code : forall {A B} (x y : { a : A | B a }), Type
  := admit.

Definition sigma_encode : forall {A B} {x y : { a : A | B a }}, x = y -> sigma_code x y
  := admit.

Definition sigma_decode : forall {A B} {x y : { a : A | B a }}, sigma_code x y -> x = y
  := admit.

Definition sigma_endecode : forall {A B} {x y : { a : A | B a }} (p : sigma_code x y),
                             sigma_encode (sigma_decode p) = p
  := admit.

Definition sigma_deencode : forall {A B} {x y : { a : A | B a }} (p : x = y),
                             sigma_decode (sigma_encode p) = p
  := admit.

(** Back to isomorphisms. *)

Definition iso_code : forall {A B} (x y : A ≅ B), Type
  := admit.

Definition iso_encode : forall {A B} {x y : A ≅ B}, x = y -> iso_code x y
  := admit.

Definition iso_decode : forall {A B} {x y : A ≅ B}, iso_code x y -> x = y
  := admit.

Definition iso_endecode : forall {A B} {x y : A ≅ B} (p : iso_code x y),
                            iso_encode (iso_decode p) = p
  := admit.

Definition iso_deencode : forall {A B} {x y : A ≅ B} (p : x = y),
                            iso_decode (iso_encode p) = p
  := admit.

(** Ooops.  Turns out this isn't provable.  Challenge: Figure out why. *)

(** *** Equivalences *)

(** We can define a slight variation on isomorphisms, called "contractible fibers", which generalizes the notion of injective+surjective.  If you're interested in the various ways of formulating equivalences, Chapter 4 of the HoTT Book (http://homotopytypetheory.org/book/) is an excellent resource. *)

Class Contr (A : Type)
  := { center : A;
       contr : forall y, center = y }.

Arguments center A {_}.

Class IsEquiv {A B} (f : A -> B)
  := Build_IsEquiv : forall b, Contr { a : A | f a = b }.

Record Equiv A B
  := { equiv_fun : A -> B;
       equiv_isequiv : IsEquiv equiv_fun }.

Arguments equiv_fun {A B} _ _.
Arguments equiv_isequiv {A B} _ _.

(** Let us use an object of type [Equiv] as a function: *)

Coercion equiv_fun : Equiv >-> Funclass.

(** Tell Coq that the function associated to an [Equiv] object is
    always an equivalence. *)

Existing Instance equiv_isequiv.

Notation "A <~> B" := (Equiv A B) (at level 70).
Notation "A ≃ B" := (Equiv A B) (at level 70).

(** We can prove that an equivalence gives us an isomorphism very easily. *)

Definition iso_of_equiv : forall {A B}, A ≃ B -> A ≅ B.
Proof.
  refine admit.
Defined.

(** We can go the other way with more work. *)

(** Optional Homework: Complete this proof. *)

Definition equiv_of_iso : forall {A B}, A ≅ B -> A ≃ B.
Proof.
  refine admit.
Defined.

(** Now, we prove the following helper lemma, which lets us get the right codes for [Equiv].  We again assume functional extensionality. *)

Definition allpath_contr : forall {A} (x y : Contr A), x = y.
Proof.
  refine admit.
Defined.

Definition allpath_isequiv : forall {A B} (f : A -> B) (e1 e2 : IsEquiv f), e1 = e2.
Proof.
  refine admit.
Defined.

Definition equiv_code : forall {A B} (f g : A ≃ B), Type
  := admit.

Definition equiv_encode : forall {A B} {f g : A ≃ B}, f = g -> equiv_code f g
  := admit.

Definition equiv_decode : forall {A B} {f g : A ≃ B}, equiv_code f g -> f = g
  := admit.

Definition equiv_endecode : forall {A B} {f g : A ≃ B} (p : equiv_code f g),
                              equiv_encode (equiv_decode p) = p
  := admit.

Definition equiv_deencode : forall {A B} {f g : A ≃ B} (p : f = g),
                              equiv_decode (equiv_encode p) = p
  := admit.

(** Now that we have a "good" type of isomorphism/equivalence (one with the right equality type), we can go back to the question of [Isomorphic_ap]; Recall that we want to prove:

<<
Definition Isomorphic_ap : forall (f : Type -> Type) {A B}, A ≅ B -> f A ≅ f B.
>> *)

(** We can prove this by axiomatizing the codes for types: *)

Definition Type_code' : forall (x y : Type), Type
  := fun x y => x ≃ y.

Definition Type_encode' : forall {x y : Type}, x = y -> Type_code' x y
  := admit.

(** The following are unprovable in Coq, currently.  They are collectively known as the "univalence axiom". *)

Axiom Type_decode' : forall {x y : Type}, Type_code' x y -> x = y.
Axiom Type_endecode' : forall {x y : Type} (p : Type_code' x y),
                         Type_encode' (Type_decode' p) = p.
Axiom Type_deencode' : forall {x y : Type} (p : x = y),
                         Type_decode' (Type_encode' p) = p.

Definition Univalence : forall {x y : Type}, IsEquiv (@Type_encode' x y)
  := admit.

(** *** Homework: Playing with univalence *)

(** Using univalence, we can prove some things. *)

Definition Empty_set_eq : (Empty_set = Empty_set) = unit :> Type
  := admit.

Definition unit_eq : (unit = unit) = unit :> Type
  := admit.

Definition bool_eq : (bool = bool) = bool :> Type
  := admit.

Definition bool_arrow_bool_eq : (bool -> bool) = (bool * bool)%type
  := admit.

Definition prod_commutes : forall (A B : Type), (A * B = B * A)%type
  := admit.

(** Challenge: Show, without axioms, that univalence implies functional extensionality: *)

Definition univalence_implies_funext
: (forall A B, IsEquiv (@Type_encode' A B))
  -> (forall A B (f g : forall a : A, B a), (forall a, f a = g a) -> f = g)
  := admit.

(** Exercise 2.17 from the HoTT Book (http://homotopytypetheory.org/book/ - don't worry about reading the book):

  Show that if [A ≃ A'] and [B ≃ B'], then [(A * B) ≃ (A' * B')] in two ways: once using univalence, and once without assuming it. *)

Definition equiv_functor_prod_univalence
: (forall A B, IsEquiv (@Type_encode A B))
  -> forall A A' B B',
       A ≃ A' -> B ≃ B' -> (A * B ≃ A' * B')%type
  := admit.

Definition equiv_functor_prod_no_univalence
: forall A A' B B',
    A ≃ A' -> B ≃ B' -> (A * B ≃ A' * B')%type
  := admit.

(** Now prove that these two ways are equal *)

Definition equiv_functor_prod_eq
: forall univalence,
    equiv_functor_prod_univalence univalence = equiv_functor_prod_no_univalence
  := admit.

(** *** [prod] *)

Definition prod_code : forall {A B} (x y : A * B), Type
  := admit.

Definition prod_encode : forall {A B} {x y : A * B}, x = y -> prod_code x y
  := admit.

Definition prod_decode : forall {A B} {x y : A * B}, prod_code x y -> x = y
  := admit.

Definition prod_endecode : forall {A B} {x y : A * B} (p : prod_code x y),
                             prod_encode (prod_decode p) = p
  := admit.

Definition prod_deencode : forall {A B} {x y : A * B} (p : x = y),
                             prod_decode (prod_encode p) = p
  := admit.

(** *** [sum] *)

Definition sum_code : forall {A B} (x y : A + B), Type
  := admit.

Definition sum_encode : forall {A B} {x y : A + B}, x = y -> sum_code x y
  := admit.

Definition sum_decode : forall {A B} {x y : A + B}, sum_code x y -> x = y
  := admit.

Definition sum_endecode : forall {A B} {x y : A + B} (p : sum_code x y),
                             sum_encode (sum_decode p) = p
  := admit.

Definition sum_deencode : forall {A B} {x y : A + B} (p : x = y),
                             sum_decode (sum_encode p) = p
  := admit.

(** *** [nat] *)

(** Warmup: *)

Definition zero_ne_one : 0 = 1 -> Empty_set
  := admit.

(** Hint for the above: Use [J]. *)

Definition zero_ne_succ : forall n, 0 = S n -> Empty_set
  := admit.

Definition nat_code : forall (x y : nat), Type
  := admit.

Definition nat_encode : forall {x y : nat},
                                x = y -> nat_code x y
  := admit.

Definition nat_decode : forall {x y : nat},
                                nat_code x y -> x = y
  := admit.

Definition nat_endecode : forall {x y : nat} (p : nat_code x y),
                                  nat_encode (nat_decode p) = p
  := admit.

Definition nat_deencode : forall {x y : nat} (p : x = y),
                                  nat_decode (nat_encode p) = p
  := admit.

(** *** [option] *)

Definition option_code : forall {A} (x y : option A), Type
  := admit.

Definition option_encode : forall {A} {x y : option A}, x = y -> option_code x y
  := admit.

Definition option_decode : forall {A} {x y : option A}, option_code x y -> x = y
  := admit.

Definition option_endecode : forall {A} {x y : option A} (p : option_code x y),
                             option_encode (option_decode p) = p
  := admit.

Definition option_deencode : forall {A} {x y : option A} (p : x = y),
                             option_decode (option_encode p) = p
  := admit.

(** *** [list] *)

Definition list_code : forall {A} (x y : list A), Type
  := admit.

Definition list_encode : forall {A} {x y : list A}, x = y -> list_code x y
  := admit.

Definition list_decode : forall {A} {x y : list A}, list_code x y -> x = y
  := admit.

Definition list_endecode : forall {A} {x y : list A} (p : list_code x y),
                             list_encode (list_decode p) = p
  := admit.

Definition list_deencode : forall {A} {x y : list A} (p : x = y),
                             list_decode (list_encode p) = p
  := admit.

(** **** Homework: mere propositions *)

(** Homework; challenging problem *)

(** Recall the definition of contractibility above.  The reason that we can safely call this contractible is that all of the higher structure collapses.  That is, if all inhabitants of [A] are (continuously) equal, then all inhabitants of [x = y] for [x : A] and [y : A] are also equal.  Prove this, as follows. *)

(** First we define what it means for a type to be a "mere proposition", or to satisfy the uniqueness of identity proofs. *)

Definition is_prop : Type -> Type
  := fun A => forall x y : A, x = y.

(** We classify the equality type of propositions. *)

Definition prop_code : forall {A} (allpaths : is_prop A) (x y : A), Type
  := fun A allpaths x y => unit.

Definition prop_encode : forall {A} (allpaths : is_prop A) {x y : A},
                           x = y -> prop_code allpaths x y
  := admit.

Definition prop_decode : forall {A} (allpaths : is_prop A) {x y : A},
                           prop_code allpaths x y -> x = y
  := admit.

Definition prop_endecode : forall {A} (allpaths : is_prop A) {x y : A} (p : prop_code allpaths x y),
                            prop_encode allpaths (prop_decode allpaths p) = p
  := admit.

(** If you find this proof hard, and can't figure out why, think about the proof of [dec_deencode].  If you're still having trouble, look a bit further down for a hint. *)

Definition prop_deencode : forall {A} (allpaths : is_prop A) {x y : A} (p : x = y),
                             prop_decode allpaths (prop_encode allpaths p) = p
  := admit.

(** Hint: you may need to rewrite your [prop_decode] function.  The following lemmas may prove helpful. *)

(** Try to write an "adjuster" for [is_prop] that will always return something equal to [refl] (provably) when handed two judgmentally equal things. *)

Definition adjust_allpaths : forall {A}, is_prop A -> is_prop A
  := admit.

Definition adjust_allpaths_refl : forall {A} (allpaths : is_prop A) x,
                                   adjust_allpaths allpaths x x = refl
  := admit.

(** Now move these lemmas above [prop_decode] and try re-writing the codes so that you expect [prop_deencode] to work. *)

(** *** decidable types *)

(** Homework; challenging problem *)

(** More generally, we can do this for any type with decidable equality. *)

(** First we define what it means for a type to have decidable equality: it means that we have a (continuous!) function from pairs of inhabitants to proofs that either they are equal, or that their equality is absurd. *)

Definition decidable : Type -> Type
  := fun A => forall x y : A, (x = y) + (x = y -> Empty_set).

Definition dec_code : forall {A} (dec : decidable A) (x y : A), Type
  := admit.

Definition dec_encode : forall {A} (dec : decidable A) {x y : A},
                          x = y -> dec_code dec x y
  := admit.

Definition dec_decode : forall {A} (dec : decidable A) {x y : A},
                          dec_code dec x y -> x = y
  := admit.

Definition dec_endecode : forall {A} (dec : decidable A) {x y : A} (p : dec_code dec x y),
                            dec_encode dec (dec_decode dec p) = p
  := admit.

(** If you find this proof hard, and can't figure out why, look a bit further down for a hint. *)

Definition dec_deencode : forall {A} (dec : decidable A) {x y : A} (p : x = y),
                             dec_decode dec (dec_encode dec p) = p
  := admit.

(** Hint: you may need to rewrite your [dec_decode], [dec_code], and [dec_encode] functions, just as you did with [prop_decode].  The following lemmas may prove helpful. *)

(** Try to write an "adjuster" for decidable equality that will always return something equal to [refl] (provably) when handed two equal things. *)

Definition adjust_dec : forall {A}, decidable A -> decidable A
  := admit.

Definition adjust_dec_refl : forall {A} (dec : decidable A) (x : A),
                               adjust_dec dec x x = inl refl
  := admit.

(** Now move these lemmas above [dec_code] and try re-writing the codes so that you expect [dec_deencode] to work. *)

(** *** Pushing Further *)

(** Homework: Generalize the above two proofs to solve "Puzzle 2" far above.  (Don't forget to also do puzzle 1 while you're at it.) *)

(** Homework: Using the solution to Puzzle 2, show that it is sufficient to assume [function_decode] an axiom; the endecode and [deencode] proofs follow from puzzle 2. *)

Definition function_code' : forall {A B} (f g : forall a : A, B a), Type
  := admit.

Definition function_encode' : forall {A B} {f g : forall a : A, B a}, f = g -> function_code' f g
  := admit.

Axiom function_decode' : forall {A B} {f g : forall a : A, B a}, function_code' f g -> f = g.

Definition function_decode_adjusted' : forall {A B} {f g : forall a : A, B a}, function_code' f g -> f = g
  := admit.

Definition function_endecode' : forall {A B} {f g : forall a : A, B a} (p : function_code' f g),
                                  function_encode' (function_decode_adjusted' p) = p
  := admit.
Definition function_deencode' : forall {A B} {f g : forall a : A, B a} (p : f = g),
                                  function_decode_adjusted' (function_encode' p) = p
  := admit.


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

Require Import Arith Omega.

Set Implicit Arguments.

Tactic Notation "eq" "goal" "with" hyp(H) :=
  match goal with |- ?b => match type of H with ?t => replace b with t; auto end end.

Theorem nat_rev_ind (P : nat -> Prop) (HP : forall n, P (S n) -> P n) x y : x <= y -> P y -> P x.
Proof. induction 1; auto. Qed.

Reserved Notation "f ↑ n" (at level 1, left associativity).

Fixpoint iter X (f : X -> X) n x :=
  match n with
    | 0 => x
    | S n => f (f↑n x)
  end
where "f ↑ n" := (@iter _ f n).

Fact iter_plus X f a b (x : X) : f↑(a+b) x = f↑a (f↑b x).
Proof. induction a; simpl; f_equal; auto. Qed.

Tactic Notation "rew" "iter" constr(f) :=
  repeat match goal with
    | |- context[f ?x]           => change (f x) with (f↑1 x)
    | |- context[f↑?a (f↑?b ?x)] => rewrite <- (iter_plus f a b)
  end.

Section Tortoise_and_Hare_tail_recursive.

  (** This version only need a decidable binary relation R. It does
      not requires that R is equality @eq X *)

  Variables (X : Type)
            (R : X -> X -> Prop)
            (Rdec : forall x y : X, { R x y } + { ~ R x y }).

  Variable (f : X -> X) (x0 : X)
           (Hx0 : exists τ, 0 < τ /\ R (f↑τ x0) (f↑(2*τ) x0)).

  Inductive bar_tl i x y : Prop :=
    | in_bar_tl_0 : R x y                        -> bar_tl i x y
    | in_bar_tl_1 : bar_tl (S i) (f x) (f (f y)) -> bar_tl i x y.

  Let tortoise_hare_tail_rec :
    forall i x y, bar_tl i x y -> { k | i <= k /\ R (f↑(k-i) x) (f↑(2*(k-i)) y) }.
  Proof.
    refine (fix loop i x y H { struct H } :=
           match Rdec x y with
             | left E  => exist _ i _
             | right C => match loop (S i) (f x) (f (f y)) _ with
                            | exist _ k Hk => exist _ k _
                          end
           end).
    * split; auto; eq goal with E; f_equal; replace (i-i) with 0 by omega; reflexivity.
    * destruct H; auto; contradict C; trivial.
    * destruct Hk; split; try omega.
      revert H1; rew iter f; intros H1.
      eq goal with H1; do 2 f_equal; omega.
  Qed.

  Let bar_tl_1_fx0_ffx0 : bar_tl 1 (f x0) (f (f x0)).
  Proof.
    destruct Hx0 as (k & H1 & H2).
    apply in_bar_tl_0 with (i := k) in H2.
    revert k H1 H2; apply nat_rev_ind.
    intros ? H; apply in_bar_tl_1.
    rew iter f; eq goal with H; do 2 f_equal; omega.
  Qed.

  Definition tortoise_hare_tail : { τ | 0 < τ /\ R (f↑τ x0) (f↑(2*τ) x0) }.
  Proof.
    refine (match tortoise_hare_tail_rec bar_tl_1_fx0_ffx0 with
      | exist _ k Hk => exist _ k _
    end).
    destruct Hk as (? & Hk); split; try omega.
    revert Hk; rew iter f; intros Hk.
    eq goal with Hk; do 2 f_equal; omega.
  Defined.

End Tortoise_and_Hare_tail_recursive.

Check tortoise_hare_tail.
Recursive Extraction tortoise_hare_tail.


Require Import HoTT HitTactics.
Require Export FSets lattice_examples k_finite.

Section quantifiers.
  Context {A : Type} `{Univalence}.
  Variable (P : A -> hProp).

  Definition all : FSet A -> hProp.
  Proof.
    hinduction.
    - apply Unit_hp.
    - apply P.
    - intros X Y.
      apply (BuildhProp (X * Y)).
    - eauto with lattice_hints typeclass_instances.
    - eauto with lattice_hints typeclass_instances.
    - intros.
      apply path_trunctype ; apply prod_unit_l.
    - intros.
      apply path_trunctype ; apply prod_unit_r.
    - eauto with lattice_hints typeclass_instances.
  Defined.

  Lemma all_intro X : forall (HX : forall x, x ∈ X -> P x), all X.
  Proof.
    hinduction X ; try (intros ; apply path_ishprop).
    - intros.
      apply tt.
    - intros.
      apply (HX a (tr idpath)).
    - intros X1 X2 HX1 HX2 Hmem.
      split.
      * apply HX1.
        intros a Ha.
        refine (Hmem a (tr _)).
        apply (inl Ha).
      * apply HX2.
        intros a Ha.
        refine (Hmem a (tr _)).
        apply (inr Ha).
  Defined.

  Lemma all_elim X a : all X -> (a ∈ X) -> P a.
  Proof.
    hinduction X ; try (intros ; apply path_ishprop).
    - contradiction.
    - intros b Hmem Heq.
      strip_truncations.
      rewrite Heq.
      apply Hmem.
    - intros X1 X2 HX1 HX2 [Hall1 Hall2] Hmem.
      strip_truncations.
      destruct Hmem as [t | t].
      * apply (HX1 Hall1 t).
      * apply (HX2 Hall2 t).
  Defined.

  Definition exist : FSet A -> hProp.
  Proof.
    hinduction.
    - apply False_hp.
    - apply P.
    - apply lor.
    - eauto with lattice_hints typeclass_instances.
    - eauto with lattice_hints typeclass_instances.
    - eauto with lattice_hints typeclass_instances.
    - eauto with lattice_hints typeclass_instances.
    - eauto with lattice_hints typeclass_instances.
  Defined.

  Lemma exist_intro X a : a ∈ X -> P a -> exist X.
  Proof.
    hinduction X ; try (intros ; apply path_ishprop).
    - contradiction.
    - intros b Hin Pb.
      strip_truncations.
      rewrite <- Hin.
      apply Pb.
    - intros X1 X2 HX1 HX2 Hin Pa.
      strip_truncations.
      apply tr.
      destruct Hin as [t | t].
      * apply (inl (HX1 t Pa)).
      * apply (inr (HX2 t Pa)).
  Defined.

  Lemma exist_elim X : exist X -> hexists (fun a => a ∈ X * P a).
  Proof.
    hinduction X ; try (intros ; apply path_ishprop).
    - contradiction.
    - intros a Pa.
      apply (tr(a;(tr idpath,Pa))).
    - intros X1 X2 HX1 HX2 Hex.
      strip_truncations.
      destruct Hex.
      * specialize (HX1 t).
        strip_truncations.
        destruct HX1 as [a [Hin Pa]].
        refine (tr(a;(_,Pa))).
        apply (tr(inl Hin)).
      * specialize (HX2 t).
        strip_truncations.
        destruct HX2 as [a [Hin Pa]].
        refine (tr(a;(_,Pa))).
        apply (tr(inr Hin)).
  Defined.

  Context `{forall a, Decidable (P a)}.

  Global Instance all_decidable : (forall X, Decidable (all X)).
  Proof.
    hinduction ; try (apply _) ; try (intros ; apply path_ishprop).
  Defined.

  Global Instance exist_decidable : (forall X, Decidable (exist X)).
  Proof.
    hinduction ; try (apply _) ; try (intros ; apply path_ishprop).
  Defined.
End quantifiers.

Section exists_isIn.
  Context {A : Type} `{Univalence}.

  Theorem exist_isIn (a : A) (X : FSet A)
    : a ∈ X = exist (fun b => BuildhProp(Trunc (-1) (a = b))) X.
  Proof.
    hinduction X ; try (intros ; apply path_ishprop) ; cbn ; try reflexivity.
  Defined.
End exists_isIn.

Section simple_example.
  Context `{Univalence}.

  Definition P : nat -> hProp := fun n => BuildhProp(n = n).
  Definition X : FSet nat := {|0|} ∪ {|1|}.

  Definition simple_example : all P X.
  Proof.
    refine (from_squash (all P X)).
    compute.
    apply tt.
  Defined.
End simple_example.

Section pauli.
  Context `{Univalence}.

  Inductive Pauli : Type :=
  | XP : Pauli
  | YP : Pauli
  | ZP : Pauli
  | IP : Pauli.

  Definition Pauli_mult (x y : Pauli) : Pauli :=
    match x, y with
    | XP, XP => IP
    | XP, YP => ZP
    | XP, ZP => YP
    | YP, XP => ZP
    | YP, YP => IP
    | YP, ZP => XP
    | ZP, XP => YP
    | ZP, YP => XP
    | ZP, ZP => IP
    | IP, x => x
    | x, IP => x
    end.

  Definition not_XP (x : Pauli) :=
    match x with
    | XP => Empty
    | x => Unit
    end.

  Definition not_YP (x : Pauli) :=
    match x with
    | YP => Empty
    | x => Unit
    end.

  Definition not_ZP (x : Pauli) :=
    match x with
    | ZP => Empty
    | x => Unit
    end.

  Definition not_IP (x : Pauli) :=
    match x with
    | IP => Empty
    | x => Unit
    end.

  Global Instance decidable_eq_pauli : DecidablePaths Pauli.
  Proof.
    intros [ | | |] [ | | | ] ; try (apply (inl idpath)) ; try (refine (inr (fun p => _)))
    ; (refine (transport not_XP p tt) || refine (transport not_YP p tt)
    || refine (transport not_ZP p tt) || refine (transport not_IP p tt)).
  Defined.

  Global Instance Pauli_set : IsHSet Pauli.
  Proof.
    apply _.
  Defined.

  Definition Pauli_list : FSet Pauli := {|XP|} ∪ {|YP|} ∪ {|ZP|} ∪ {|IP|}.

  Ltac solve_in_list :=
    apply tr; try apply idpath;
    first [ apply inl ; solve_in_list | apply inr ; solve_in_list ].

  Theorem Pauli_finite : Kf Pauli.
  Proof.
    apply Kf_unfold.
    exists Pauli_list.
    unfold map.
    intros [ | | | ]; rewrite !union_isIn; solve_in_list.
  Defined.

  Theorem Pauli_all (P : Pauli -> hProp) : all P Pauli_list -> forall (x : Pauli), P x.
  Proof.
    intros HP x.
    refine (all_elim P Pauli_list x HP _).
    destruct x ; rewrite ?union_isIn; solve_in_list.
  Defined.

  Definition pauli_comm x y : hProp := BuildhProp(Pauli_mult x y = Pauli_mult y x).

  Theorem Pauli_mult_comm : all (fun x => all (fun y => pauli_comm x y) Pauli_list) Pauli_list.
  Proof.
    refine (from_squash (all _ _)).
    compute.
    apply tt.
  Defined.
End pauli.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Addition_D.

Coq < Goal forall a b c d e:Prop, ((a -> b) /\ ((b \/ c) -> (d /\ e)) /\ a) -> d.
1 subgoal

  ============================
   forall a b c d e : Prop, (a -> b) /\ (b \/ c -> d /\ e) /\ a -> d

Unnamed_thm < intros.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  e : Prop
  H : (a -> b) /\ (b \/ c -> d /\ e) /\ a
  ============================
   d

Unnamed_thm < decompose [and or] H.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  e : Prop
  H : (a -> b) /\ (b \/ c -> d /\ e) /\ a
  H0 : a -> b
  H2 : b \/ c -> d /\ e
  H3 : a
  ============================
   d

Unnamed_thm < apply H2.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  e : Prop
  H : (a -> b) /\ (b \/ c -> d /\ e) /\ a
  H0 : a -> b
  H2 : b \/ c -> d /\ e
  H3 : a
  ============================
   b \/ c

Unnamed_thm < left.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  e : Prop
  H : (a -> b) /\ (b \/ c -> d /\ e) /\ a
  H0 : a -> b
  H2 : b \/ c -> d /\ e
  H3 : a
  ============================
   b

Unnamed_thm < apply H0.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  e : Prop
  H : (a -> b) /\ (b \/ c -> d /\ e) /\ a
  H0 : a -> b
  H2 : b \/ c -> d /\ e
  H3 : a
  ============================
   a

Unnamed_thm < exact H3.
No more subgoals.

Unnamed_thm < Qed.
intros.
decompose [and or] H.
apply H2.
left.
apply H0.
exact H3.

Unnamed_thm is defined

Coq <

*)

Section Addition_D.
Goal forall a b c d e:Prop, ((a -> b) /\ ((b \/ c) -> (d /\ e)) /\ a) -> d.
intros.
decompose [and or] H.
apply H2.
left.
apply H0.
exact H3.
Qed.


(* A Simple Data Structure Lemma *)

Require Import Omega.
Inductive BTree : Type :=
    Leaf        : BTree
  | Single_Son  : BTree -> BTree
  | Binary_Sons : BTree -> BTree -> BTree.

Fixpoint empty_place (t : BTree) : nat :=
  match t with
  | Leaf              => 2
  | Single_Son t'     => 1 + empty_place t'
  | Binary_Sons t1 t2 => empty_place t1 + empty_place t2
  end.

Fixpoint node (t : BTree) : nat :=
  match t with
  | Leaf              => 1
  | Single_Son t'     => 1 + node t'
  | Binary_Sons t1 t2 => 1 + node t1 + node t2
  end.

Lemma l : forall t n, node t = n -> empty_place t = n + 1.
Proof.
  induction t;intros.
  - simpl in *. subst. auto.
  - simpl in *. destruct n.
    + inversion H.
    + assert(H' : node t = n).
      auto. apply IHt in H'. rewrite H'. auto.
  - simpl in *. destruct n.
    + inversion H.
    + assert(H' : node t1 + node t2 = n).
      auto. specialize (IHt1 (node t1)).
      specialize (IHt2 (node t2)).
      assert(H1 : node t1 = node t1). auto.
      assert(H2 : node t2 = node t2). auto.
      apply IHt1 in H1. apply IHt2 in H2.
      rewrite H1, H2. omega.
Qed.

Require Import Lia ssreflect.

Lemma k : forall t n, node t = n -> empty_place t = n + 1.
Proof.
  elim => /= [| t1 IH | t1 IH1 t2 IH2] n.
  + by move => <-.
  + by case: n => // n [/IH] ->.
  + case: n => // n [eq].
    have/IH1 ->: node t1 = n - node t2 by lia.
    by move: (IH2 _ eq_refl); lia.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq tuple.
From mathcomp Require Import choice path bigop finfun fintype matrix div ssralg.

(* Various lemmas around tuples (static length lists) in ssreflect *)

Program Definition tsplit_def {n} (x : (n.*2).-tuple bool) : n.-tuple bool * n.-tuple bool :=
  ([tuple of take n x], [tuple of drop n x]).
Next Obligation.
  apply/minn_idPl.
  clear x.
  induction n.
  done.
  eapply leq_trans.
  instantiate (1 := n.+1).
  done.
  rewrite doubleS.
  rewrite ltnS.
  eapply leq_trans.
  apply IHn.
  done.
Defined.
Next Obligation.
  rewrite -addnn.
  rewrite -addnBA.
  rewrite subnn addn0 //=.
  done.
Defined.

Program Definition tjoin_def {n} (p : (n.-tuple bool) * (n.-tuple bool)) : (n.*2).-tuple bool :=
  [tuple of fst p ++ snd p].
Next Obligation.
  rewrite addnn //=.
Defined.

Definition tsplit {n} := locked (@tsplit_def n).
Definition tjoin {n} := locked (@tjoin_def n).

Lemma tsplitK n : cancel (@tsplit n) tjoin.
  unlock tjoin tsplit.
  move => x.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  rewrite /tsplit_def //=.
  rewrite /tjoin_def //=.
  rewrite /eq_rect /eq_ind_r /eq_ind //=.
  destruct (addnn n); simpl.
  move: x.
  destruct (tsplit_def_obligation_1 n).
  destruct (tsplit_def_obligation_2 n).
  simpl; intro.
  have -> : n.*2 - n = n.
  rewrite -addnn -addnBA.
  rewrite subnn addn0 //=.
  done.
  rewrite cat_take_drop //=.
Qed.

Lemma tjoinK n : cancel (@tjoin n) tsplit.
  unlock tjoin tsplit.
  move => x.
  apply/eqP; rewrite /eq_op //= /eq_op //=; apply/eqP.
  rewrite /tsplit_def //=.
  rewrite /tjoin_def //=.
  rewrite /eq_rect.
  move: x.
  destruct (tsplit_def_obligation_1 n).
  destruct (tsplit_def_obligation_2 n).
  simpl; intro.
  destruct (tjoin_def_obligation_1 n x).
  simpl.
  apply/eqP; simpl.
  have -> : n + n - n = n.
  rewrite -addnBA.
  rewrite subnn addn0 //=.
  done.
  rewrite take_size_cat.
  rewrite drop_size_cat.
  rewrite !eq_refl //=.
  rewrite size_tuple //=.
  rewrite size_tuple //=.
Qed.

Definition select4 {A} (x : A * A * A * A) (sel : 2.-tuple bool) :=
  match tnth sel (inord 0), tnth sel (inord 1) with
    | false, false => x.1.1.1
    | false, true => x.1.1.2
    | true, false => x.1.2
    | true, true => x.2 end.

Definition xort {n : nat} (x y : n.-tuple bool) : n.-tuple bool :=
  [tuple of map (fun p => addb p.1 p.2) (zip x y)].

Infix "+t" := xort (at level 80).

Definition andt {n} (x y : n.-tuple bool) :=
  [tuple of [seq p.1 && p.2 | p <- zip x y]].

Infix "&t" := andt (at level 80).

Definition negt {n} (x : n.-tuple bool) :=
  [tuple of map negb x].

Notation "~t" := (negt).

Definition tzero (n : nat) : n.-tuple bool := [tuple of nseq n false].
Definition tone (n : nat) : n.-tuple bool := [tuple of nseq n true].

Lemma tnth_zip {n : nat} (x y : n.-tuple bool) i :
  tnth [tuple of zip x y] i = (tnth x i, tnth y i).
  rewrite (tnth_nth (false, false)).
  rewrite //=.
  rewrite nth_zip.
  rewrite -!tnth_nth //=.
  rewrite !size_tuple //=.
Qed.

Lemma xortK {n : nat} (x : n.-tuple bool) :
  xort x x = tzero n.
  apply/eqP; rewrite eqEtuple; apply/forallP => i.
  rewrite /xort.
  rewrite tnth_map.
  rewrite tnth_zip //=.
  rewrite addbb //=.
  rewrite /tzero tnth_nseq //=.
Qed.

Lemma xortC {n : nat} (x y : n.-tuple bool) :
  xort x y = xort y x.
  apply/eqP; rewrite eqE //=.
  induction n.
  rewrite (tuple0 x) (tuple0 y); done.
  rewrite (tuple_eta x) (tuple_eta y) //=.
  rewrite addbC.
  apply/eqP.
  congr (_ :: _).
  move: (IHn [tuple of behead x] [tuple of behead y]).
  simpl.
  move/eqP; done.
Qed.

Lemma xortA {n : nat} (x y z : n.-tuple bool) :
  xort (xort x y) z = xort x (xort y z).
  apply/eqP; rewrite eqE //=.
  induction n.
  rewrite (tuple0 x) (tuple0 y) (tuple0 z) //=.
  rewrite (tuple_eta x) (tuple_eta y) (tuple_eta z) //=.
  rewrite addbA; apply/eqP; congr(_ :: _).
  rewrite (eqP (IHn [tuple of behead x] [tuple of behead y] [tuple of behead z])) //=.
Qed.

Lemma andtC {n : nat} (x y : n.-tuple bool) :
  andt x y = andt y x.
  apply/eqP; rewrite eqE //=.
  induction n.
  rewrite (tuple0 x) (tuple0 y); done.
  rewrite (tuple_eta x) (tuple_eta y) //=.
  rewrite andbC.
  apply/eqP.
  congr (_ :: _).
  move: (IHn [tuple of behead x] [tuple of behead y]).
  simpl.
  move/eqP; done.
Qed.

Lemma andtA {n : nat} (x y z : n.-tuple bool) :
  andt (andt x y) z = andt x (andt y z).
  apply/eqP; rewrite eqE //=.
  induction n.
  rewrite (tuple0 x) (tuple0 y) (tuple0 z) //=.
  rewrite (tuple_eta x) (tuple_eta y) (tuple_eta z) //=.
  rewrite andbA; apply/eqP; congr(_ :: _).
  rewrite (eqP (IHn [tuple of behead x] [tuple of behead y] [tuple of behead z])) //=.
Qed.

Lemma xort_andt {n} (x y z : n.-tuple bool) :
  ((x +t y) &t z) = ((x &t z) +t (y &t z)).
  apply/eqP; rewrite eqE //=.
  induction n.
  rewrite (tuple0 x) (tuple0 y) (tuple0 z) //=.
  rewrite (tuple_eta x) (tuple_eta y) (tuple_eta z) //=.
  rewrite andb_addl; apply/eqP; congr (_ :: _).
  rewrite (eqP (IHn [tuple of behead x] [tuple of behead y] [tuple of behead z])) //=.
Qed.

Lemma xort_andt_xort {n} (x y z w : n.-tuple bool) :
  ((x +t y) &t (z +t w)) = ((x &t z) +t (y &t z) +t (x &t w) +t (y &t w)).
  rewrite xort_andt.
  rewrite (andtC x) xort_andt.
  rewrite (andtC y) xort_andt.
  rewrite (andtC z).
  rewrite !xortA.
  congr (xort _ _).
  rewrite -!xortA.
  congr (xort _ _); last by apply andtC.
  rewrite xortC.
  rewrite (andtC z).
  rewrite (andtC w).
  done.
Qed.

Lemma xort0 {n} (x : n.-tuple bool) :
  xort x (tzero n) = x.
  apply/eqP; rewrite eqE //=.
  induction n.
  rewrite (tuple0 x) //=.
  rewrite (tuple_eta x) //=.
  rewrite addbF.
  rewrite (eqP (IHn [tuple of behead x])) //=.
Qed.

  Lemma xort_inj_l {n} (x : n.-tuple bool) :
    injective (xort x).
    move => a b.
    intro.
    apply/eqP; rewrite eqE //=.
    move/eqP: H => H; rewrite eqE //= in H.
    induction n.
    rewrite (tuple0 a) (tuple0 b); done .
    rewrite (tuple_eta a) (tuple_eta b) //=.
    rewrite (tuple_eta a) (tuple_eta b) (tuple_eta x) //= in H.
    have -> : thead a = thead b.
    rewrite eqE //= in H; destruct (andP H).
    eapply addbI.
    apply (eqP H0).
    move/eqP: H => H.
    inversion H.
    suff : behead a == behead b.
    intros.
    rewrite eqE //= (eqP x0).
    rewrite //= eqseqE !eq_refl //=.
    suff : [tuple of behead a] == [tuple of behead b].
    rewrite eqE //=.
    eapply IHn.
    simpl.
    apply/eqP.
    apply H2.
  Qed.

  Lemma xort_inj_r {n} (x : n.-tuple bool) :
    injective (fun a => xort a x).
    move => a b.
    rewrite (xortC a) (xortC b).
    move/xort_inj_l; done.
  Qed.

Lemma thead_xort {n} (x y : n.+1.-tuple bool) :
  thead (xort x y) = (thead x) (+) (thead y).
  rewrite (tuple_eta x) (tuple_eta y) //=.
Qed.

Definition tnot {n} (x : n.-tuple bool) :=
  [tuple of map negb x].

Lemma thead_tnot {n} (x : n.+1.-tuple bool) :
  thead (tnot x) = ~~ (thead x).
    rewrite (tuple_eta x) //=.
Qed.

Lemma tsplitE1 {L} (m : (L.*2).-tuple bool) :
    (eq_rect (minn L L.*2) (tuple_of^~ bool) [tuple of
                take L m] L (TupleLems.tsplit_def_obligation_1 L))
      = (tsplit m).1.
  unlock tsplit.
  rewrite //=.
Qed.

Lemma tsplitE2 {L} (m : (L.*2).-tuple bool) :
    (eq_rect (L.*2 - L) (tuple_of^~ bool) [tuple of
                drop L m] L (TupleLems.tsplit_def_obligation_2 L))
      = (tsplit m).2.
  unlock tsplit; rewrite //=.
Qed.

Lemma tsplitE {L} (m : (L.*2).-tuple bool) :
  tsplit m = ((tsplit m).1, (tsplit m).2).
  destruct (tsplit m); done.
Qed.

Lemma leq_n_double n :
  n <= n.*2.
  rewrite -mul2n.
  rewrite leq_pmull //=.
Qed.

Lemma tsplit_nseq {L} b :
  tsplit [tuple of nseq L.*2 b] = ([tuple of nseq L b], [tuple of nseq L b]).
  rewrite tsplitE.
  apply/eqP; rewrite eqE //= eqE //=.
  rewrite -tsplitE1 //=.
  rewrite -tsplitE2 //=.
  apply/andP; split.
  destruct (tsplit_def_obligation_1 L); rewrite //=.
  rewrite take_nseq.
  have {1}-> //= : L = minn L L.*2.
  rewrite tsplit_def_obligation_1 //=.
  apply leq_n_double.
  destruct (tsplit_def_obligation_2 L); rewrite //=.
  rewrite eqE //=.
  rewrite drop_nseq //=.
Qed.

Lemma thead_nseq {n} {A} (b : A) : thead [tuple of nseq (n.+1) b] = b.
  rewrite (tuple_eta [tuple of nseq n.+1 b]) //=.
Qed.

Definition osplit {m n : nat} (x : 'I_(n * m)) :=
  (enum_val \o cast_ord (esym (mxvec_cast n m))) x.

Definition ojoin {n m} (x : 'I_n) (y : 'I_m) : 'I_(n * m) := mxvec_index x y.

Lemma ojoinK {m n : nat} (x : 'I_(n * m)) :
  ojoin (osplit x).1 (osplit x).2 = x.
    rewrite /ojoin /osplit.
    case/mxvec_indexP: x => i j /=.
    rewrite cast_ordK enum_rankK //=.
Qed.

Lemma osplitK {m n : nat} (x : 'I_n) (y : 'I_m) :
  osplit (ojoin x y) = (x, y).
  rewrite /ojoin /osplit.
  destruct x as [x Hx].
  destruct y as [y Hy].
  rewrite //=.
  rewrite cast_ordK enum_rankK //=.
Qed.

Definition tuple_of_matrix {n m} {A} (M : 'M[A]_(n, m)) : (n * m).-tuple A :=
  mktuple (fun i => M (osplit i).1 (osplit i).2).

Definition matrix_of_tuple {n m} {A} (t : (n * m).-tuple A) : 'M[A]_(n, m) :=
  \matrix_(i < n, j < m) (tnth t (ojoin i j)).

Lemma tuple_matrixK n m A :
  cancel (@tuple_of_matrix n m A) (@matrix_of_tuple n m A).
  move => M.
  apply/matrixP => i j.
  rewrite /tuple_of_matrix /matrix_of_tuple.
  rewrite mxE.
  rewrite !tnth_mktuple.
  rewrite osplitK //=.
Qed.

Lemma matrix_tupleK n m A :
  cancel (@matrix_of_tuple n m A) (@tuple_of_matrix n m A).
  move => t.
  apply/eq_from_tnth => i.
  rewrite /tuple_of_matrix.
  rewrite !tnth_mktuple.
  rewrite /matrix_of_tuple.
  rewrite mxE.
  rewrite ojoinK //=.
Qed.

Definition ttranspose {A} {m n} (t : (m * n).-tuple A) : (n * m).-tuple A :=
  tcast (mulnC _ _) t.

Definition texpand {A} {m} (t : m.-tuple A) : m.-tuple (1.-tuple A) :=
  [tuple of map (fun x => [tuple x]) t].

Lemma theadE' {n} {A} (xs : (n.+1).-tuple A) y (ys : seq A) :
  tval xs = y :: ys ->
  thead xs = y.
  intros.
  destruct xs; simpl in *.
  subst.
  rewrite //=.
Qed.

Ltac simp_tuple :=
  match goal with
    | [ |- context[thead _] ] => erewrite theadE'; last by done
  end.

Definition tflatten {n} {m} {A} (x : n.-tuple (m.-tuple A)) : (n * m).-tuple A :=
  tuple_of_matrix (\matrix_(i < n, j < m) tnth (tnth x i) j).

Definition tunflatten {n} {m} {A} (x : (n * m).-tuple A) : n.-tuple (m.-tuple A) :=
  mktuple (fun i =>
             mktuple (fun j =>
                        matrix_of_tuple x i j )).

Lemma tflattenK n m A :
  cancel (@tflatten n m A) (@tunflatten n m A).
  move => t; rewrite /tflatten /tunflatten.
  rewrite tuple_matrixK //=.
  apply eq_from_tnth => i; apply eq_from_tnth => j.
  rewrite //=.
  rewrite !tnth_mktuple mxE //=.
Qed.

Lemma tunflattenK n m A :
  cancel (@tunflatten n m A) (@tflatten n m A).
  move => t; rewrite /tflatten /tunflatten.
  erewrite eq_mx; last first.
  move => i j.
  rewrite !tnth_mktuple mxE //=.
  rewrite /tuple_of_matrix.
  apply eq_from_tnth => i.
  rewrite tnth_mktuple mxE.
  rewrite ojoinK //=.
Qed.

Definition tuple_of_rv {n} {A} (r : 'rV[A]_n) : n.-tuple A :=
  mktuple (fun i => r ord0 i).

Definition rv_of_tuple {n} {A} (r : n.-tuple A) : 'rV[A]_n :=
  \row_i (tnth r i).

Lemma tuple_rvK {n} {A} :
  cancel (@tuple_of_rv n A) (@rv_of_tuple n A).
  move => t; rewrite /rv_of_tuple /tuple_of_rv.
  apply rowP => i.
  rewrite mxE tnth_mktuple //=.
Qed.

Lemma rv_tupleK {n} {A} :
  cancel  (@rv_of_tuple n A) (@tuple_of_rv n A).
  move => t; rewrite /rv_of_tuple /tuple_of_rv.
  apply eq_from_tnth => i.
  rewrite tnth_mktuple.
  rewrite !mxE //=.
Qed.

Definition tuple_of_cv {n} {A} (r : 'cV[A]_n) : n.-tuple A :=
  mktuple (fun i => r i ord0).

Definition cv_of_tuple {n} {A} (r : n.-tuple A) : 'cV[A]_n :=
  \col_i (tnth r i).

Lemma tuple_cvK {n} {A} :
  cancel (@tuple_of_cv n A) (@cv_of_tuple n A).
  move => t; rewrite /cv_of_tuple /tuple_of_cv.
  apply colP => i.
  rewrite mxE tnth_mktuple //=.
Qed.

Lemma cv_tupleK {n} {A} :
  cancel  (@cv_of_tuple n A) (@tuple_of_cv n A).
  move => t; rewrite /cv_of_tuple /tuple_of_cv.
  apply eq_from_tnth => i.
  rewrite tnth_mktuple.
  rewrite !mxE //=.
Qed.

Definition tsplit4 {n} (x : n.*2.*2.-tuple bool) : n.-tuple bool * n.-tuple bool * n.-tuple bool * n.-tuple bool :=
  let p := tsplit x in
  let p1 := tsplit p.1 in
  let p2 := tsplit p.2 in
  (p1.1, p1.2, p2.1, p2.2).

Definition tjoin4 {n} (x : n.-tuple bool * n.-tuple bool * n.-tuple bool * n.-tuple bool) :
n.*2.*2.-tuple bool.
  set p := tjoin (x.1.1.1, x.1.1.2).
  set p2 := tjoin (x.1.2, x.2).
  exact (tjoin (p, p2)).
Defined.

Lemma tsplit4K {n} : cancel (@tsplit4 n) (@tjoin4 n).
  move => x.
  rewrite /tsplit4 //=.
  rewrite /tjoin4 //=.
 rewrite -tsplitE tsplitK.
 rewrite -tsplitE tsplitK.
 rewrite -tsplitE tsplitK.
 done.
Qed.

Lemma tjoin4K {n} : cancel (@tjoin4 n) (@tsplit4 n).
  move => x.
  rewrite /tsplit4 /tjoin4 //=.
  rewrite !tjoinK.
  destruct x as [[[a b] c] d].
  done.
Qed.

Definition thead1 {A} {n} (x : (S (S n)).-tuple A) : A :=
  thead [tuple of behead x].

Lemma eq_tuple {A} {n} (x y : n.-tuple A) :
  (tval x) = (tval y) ->
  x = y.
  destruct x, y; simpl in *.
  intro; subst.
  have: i = i0 by apply bool_irrelevance.
  intro; subst.
  done.
Qed.

Lemma tuple1P (x : 1.-tuple bool) :
  exists y,
  x = [tuple y].
  destruct x.
  destruct tval.
  done.
  destruct tval.
  simpl in *.
  exists b.
  apply eq_tuple; simpl; done.
  done.
Qed.

Notation "n .-bv" := (n.-tuple bool)
  (at level 2, format "n .-bv") : type_scope.


From Coqprime Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma primo80 : prime 2816249641.
Proof.
 apply (Pocklington_refl
         (Pock_certif 2816249641 11 ((23468747, 1)::(2,3)::nil) 1)
        ((Pock_certif 23468747 5 ((7, 3)::(2,1)::nil) 1282) ::
         (Proof_certif 7 prime7) ::
         (Proof_certif 2 prime2) ::
          nil)).
 native_cast_no_check (refl_equal true).
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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 half (half_arg0 : natural) : natural
           := match half_arg0 with
              | Zero => Zero
              | Succ Zero => Zero
              | Succ (Succ n) => Succ (half n)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
induction l1.
- intros. simpl. rewrite <- IHl1. reflexivity.
- intros. reflexivity.
Qed.

Lemma lem: forall l1 l2, len (append l1 l2) = len (append l2 l1).
Proof. induction l1.
  - intros. simpl. rewrite IHl1. rewrite <- lem2. reflexivity.
  - intros.  simpl. lfind.  reflexivity.
Admitted.

Theorem theorem0 : forall (x : lst) (y : lst), eq (half (len (append x y))) (half (len (append y x))).
Proof.
intros. f_equal. apply lem.
Qed.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf.

Require Import List. Import ListNotations.
Require Import Coq.Strings.String.

Definition relation (X:Type) := X -> X -> Prop.

Section Star.

  Variable A : Type.
  Variable R : relation A.

  Inductive star: relation A:=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

  Lemma star_one:
    forall a b, R a b -> star a b.
  Proof.
    eauto using star.
  Qed.

  Lemma star_trans:
    forall a b, star a b -> forall c, star b c -> star a c.
  Proof.
    induction 1; eauto using star.
  Qed.

  Hypothesis R_functional:
    forall a b c, R a b -> R a c -> b = c.

  Lemma star_star_inv:
    forall a b, star a b -> forall c, star a c -> star b c \/ star c b.
  Proof.
    induction 1; intros.
    - auto.
    - inversion H1; subst.
      + right. eauto using star.
      + assert (b = b0) by (eapply R_functional; eauto). subst b0.
        apply IHstar; auto.
  Qed.

  Definition irred a : Prop := forall b, ~(R a b).

  Lemma finseq_unique:
    forall a b b',
      star a b -> irred b ->
      star a b' -> irred b' ->
      b = b'.
  Proof.
    intros. destruct (star_star_inv _ _ H _ H1).
    - inversion H3; subst. auto. elim (H0 _ H4).
    - inversion H3; subst. auto. elim (H2 _ H4).
  Qed.

End Star.

Hint Constructors star : core.

Hint Resolve star_trans star_one : core.

Definition mul_dstep := star dexp DunfieldStep.
Notation "e ->>* e'" := ((star dexp DunfieldStep) e e') (at level 68).

Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0).
Notation "t ^^ u"       := (open_exp_wrt_exp t u) (at level 67).
Notation "e ^ x"        := (open_exp_wrt_exp e (e_var_f x)).

Notation "G |= t ~: T" := (Etyping G t T) (at level 69).

Notation "v ~-> A v'" := (TypedReduce v A v') (at level 68).

Notation "R 'star'" := (star exp R) (at level 69).

Notation "t ->* t'" := (step star t t') (at level 68).

(** [x # E] to be read x fresh from E captures the fact that
    x is unbound in E . *)

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.

Definition env := list (atom * exp).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  let E := gather_atoms_with (fun x : ctx => dom x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  constr:(A `union` B `union` C `union` D `union` F).
(*
Definition typed e A : Prop := Dtyping nil e A.
Definition well_typed e : Prop := exists A, Dtyping nil e A.
*)
(* ********************************************************************** *)
(** ** Regularity of relations *)

(** A typing relation holds only if the environment has no
   duplicated keys and the pre-term is locally-closed. *)

Lemma value_lc : forall v,
    value v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
Qed.

Lemma typing_regular_2 : forall G e T, Etyping G e T -> uniq G.
Proof.
  intros. induction* H.
  pick fresh y.
  assert (uniq ((y, A) :: G)) by auto.
  solve_uniq.

  pick fresh y.
  assert (uniq ((y, A) :: G)) by auto.
  solve_uniq.
Qed.

Hint Resolve typing_regular_2 : core.

Require Import Omega.

Lemma typing_regular_1 :
    forall e, forall G T, Etyping G e T -> lc_exp e.
Proof.
  intros e G T H.
  induction H;
    eauto.
Qed.

Hint Resolve typing_regular_1 : core.

(** Other properties *)

Lemma fv_in_dom:
  forall e,
  forall G T, Etyping G e T -> fv_exp e [<=] dom G.
Proof.
  intros G e T H.
  induction H; simpl; try fsetdec.
  - Case "typing_var".
    apply binds_In in H0.
    fsetdec.
  - Case "typing_abs".
    pick fresh x.
    assert (Fx : fv_exp (e ^ x) [<=] dom ([(x,A)] ++ G))
      by eauto.
    simpl in Fx.
    assert (Fy : fv_exp e [<=] fv_exp (e ^ x)) by
        eapply fv_exp_open_exp_wrt_exp_lower.
    fsetdec.
  - Case "typing_fix".
    pick fresh x.
    assert (Fx : fv_exp (e ^ x) [<=] dom ([(x,A)] ++ G))
      by eauto.
    simpl in Fx.
    assert (Fy : fv_exp e [<=] fv_exp (e ^ x)) by
        eapply fv_exp_open_exp_wrt_exp_lower.
    fsetdec.
Qed.

Lemma value_no_fv : forall v T,
    Etyping [] v T -> fv_exp v [<=] empty.
Proof.
  intro v.
  pose proof (fv_in_dom v).
  intuition eauto.
  forwards*: H H0.
Qed.

Lemma step_not_value: forall (v:exp),
    value v -> irred exp step v.
Proof.
  introv.
  unfold irred.
  induction v; introv H;
    inverts* H;
    unfold not;
    intros;
    inverts* H.
Qed.

Lemma value_no_step : forall (v t: exp),
    value v -> v ->* t -> v = t.
Proof.
  introv Val Red.
  induction* Red.
  lets : step_not_value Val H.
  tryfalse.
Qed.

Lemma multi_red_app1 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->* t1' -> (e_app t1 t2) ->* (e_app t1' t2).
Proof.
  introv ? Red.
  induction* Red.
Qed.

Lemma multi_red_app2 : forall v t t',
    value v -> lc_exp v -> t ->* t' -> (e_app v t) ->* (e_app v t').
Proof.
  introv Val ? Red.
  induction* Red.
Qed.

Lemma multi_red_merge1 : forall t1 t2 t1',
    lc_exp t2 ->
    t1 ->* t1' ->
    (e_merge t1 t2) ->* (e_merge t1' t2).
Proof.
  introv ? Red.
  induction* Red.
Qed.

Lemma multi_red_merge2 : forall v1 t2 t2',
    value v1 -> lc_exp v1 ->
    t2 ->* t2' ->
    (e_merge v1 t2) ->* (e_merge v1 t2').
Proof.
  introv Val ? Red.
  induction* Red.
Qed.

Lemma multi_red_merge3 : forall t1 t2 v1 v2,
    value v1 -> value v2 -> lc_exp v1 -> lc_exp t2 ->
    t1 ->* v1 -> t2 ->* v2 ->
    (e_merge t1 t2) ->* (e_merge v1 v2).
Proof.
  intros.
  apply star_trans with (b := e_merge v1 t2).
  sapply* multi_red_merge1.
  sapply* multi_red_merge2.
Qed.

Lemma Etyping_weaken : forall G E F t T,
    Etyping (E ++ G) t T ->
    uniq (E ++ F ++ G) ->
    Etyping (E ++ F ++ G) t T.
Proof.
  introv Typ; gen F;
    inductions Typ; introv Ok; autos*.
    + (* abs *)
      pick fresh x and apply Etyp_abs; eauto.
      rewrite_env (([(x, A)] ++ E) ++ F ++ G).
      apply~ H0.
      solve_uniq.
    + (* fix *)
      pick fresh x and apply Etyp_fix.
      rewrite_env (([(x, A)] ++ E) ++ F ++ G).
      apply~ H0.
      solve_uniq.
Qed.

Lemma Etyping_weakening : forall (E F : ctx)  e T,
    Etyping E e T ->
    uniq (F ++ E) ->
    Etyping (F ++ E) e T.
Proof.
  intros E F e T H J.
  rewrite_env (nil ++ F ++ E).
  apply~ Etyping_weaken.
Qed.

(** Typing is preserved by substitution. *)

Lemma subst_value : forall v T z u,
    Etyping [] v T -> subst_exp u z v = v.
Proof.
  intros v T z u Typ.
  lets* Fv: value_no_fv Typ.
  forwards*: subst_exp_fresh_eq.
  rewrite Fv.
  fsetdec.
Qed.

Lemma Etyping_subst : forall (E F : ctx) e u S T (z : atom),
    Etyping (F ++ [(z,S)] ++ E) e T ->
    Etyping E u S ->
    Etyping (F ++ E) ([z ~> u] e) T.
Proof.
  intros.
  remember (F ++ [(z,S)] ++ E) as E'.
  generalize dependent F.
  induction H; intros F Eq; subst; simpl; autos*;
    lets Lc  : typing_regular_1 H0;
    lets Uni : typing_regular_2 H0.
  -
    case_if*.
    substs.
    assert (A = S).
    eapply binds_mid_eq; eauto.
    substs.
    apply~ Etyping_weakening.
    solve_uniq.
  -
    pick fresh x and apply Etyp_abs; eauto.
    rewrite subst_exp_open_exp_wrt_exp_var; auto.
    rewrite_env (([(x, A)] ++ F) ++ E).
    apply~ H1.
  -
    pick fresh x and apply Etyp_fix.
    rewrite subst_exp_open_exp_wrt_exp_var; auto.
    rewrite_env (([(x, A)] ++ F) ++ E).
    apply~ H1.
  -
    lets : ((subst_value _ _ z u) H2).
    lets : ((subst_value _ _ z u) H3).
    rewrite H5.
    rewrite H6.
    apply~ Etyp_mergev.
    solve_uniq.
Qed.

(* doesn't hold in two anno *) (*
Lemma typing_uniq: forall G e A B,
    G |= e ~: A -> G |= e ~: B -> A = B.
Proof.
  intros G e A B Typ1 Typ2.
  gen B.
  induction Typ1;
    introv Typ2;
    try solve [inverts* Typ2].
  - inverts* Typ2.
    gen B.
    induction H0;
      introv Typ2;
      inverts* Typ2.
    forwards*: IHVtyping1.
    forwards*: IHVtyping2.
    congruence.
  - (* f_var *)
    inverts* Typ2.
    forwards*: binds_unique H0 H4 H2.
  - (* e_app *)
    inverts* Typ2.
    forwards*: IHTyp1_1.
    forwards*: IHTyp1_2.
    subst.
    inverts* H0.
  - (* and *)
    inverts* Typ2.
    forwards*: IHTyp1_1.
    forwards*: IHTyp1_2.
    congruence.
Qed.
*)

(* typing canonical *)
Lemma intersection_canonical : forall v A B,
    value v -> nil |=  v ~: t_and A B->
    exists v1 v2, v = e_merge v1 v2.
Proof.
  introv Val Typ. lets Typ' : Typ.
  inductions Typ;
    inverts Val;
    exists*.
Qed.
(*
Lemma unit_canonical : forall v,
    nil |= (e_val v) ~: t_top ->
    v = v_top.
Proof.
  introv Typ. lets Typ' : Typ. inductions Typ; inverts* H0.
Qed.
 *)
(* changes *)
Lemma abs_typing_canonical : forall G A B D e,
    Etyping G (e_abs A e D) B -> exists C, B = t_arrow C D /\ sub C A.
Proof.
  intros G A B D e H.
  inverts* H.
Qed.


Parameters p1 p2 t1 t2 : Prop.

Definition aff1 := p1 \/ p2.
Definition aff2 := p1.

Definition k := ((p1 /\ aff1) \/ (t1 /\ ~aff1)) /\ ((p2 /\ ~aff2) \/ (t2 /\ aff2)).

Definition h1 := ~(p1 /\ t1) /\ ~(p2 /\ t2).
Definition h2 := (p1 \/ t1) /\ (p2 \/ t2).

Lemma epreuve_5 : h1 /\ h2 /\ k -> p1 /\ t2.
Proof.
unfold k, h1, h2.
unfold aff1, aff2.
intros.
destruct H.
destruct H.
destruct H0.
destruct H0.
destruct H2.
destruct H2.
destruct H2.
destruct H4.
destruct H4.
elimtype False.
auto.
destruct H4.
split; assumption.
destruct H2.
elimtype False.
apply H5.
destruct H4.
destruct H4.
right.
assumption.
destruct H4.
left.
assumption.
Qed.


(** # Sequential accumulation points*)
Require Import Reals.
Require Import Lra.
Require Import Classical.
Require Import Classical_Pred_Type.
Require Import ClassicalChoice.

Require Import Waterproof.AllTactics.
Require Import Waterproof.notations.notations.
Require Import Waterproof.load.
Import databases_RealsAndIntegers.
Require Import Waterproof.load_database.Intuition.

Require Import Waterproof.set_search_depth.To_5.
Require Import Waterproof.theory.analysis.sequences.
Require Import Waterproof.theory.analysis.subsequences.

Open Scope R_scope.

Definition is_seq_acc_pt (a : ℕ → ℝ) (x : ℝ) : Prop :=
  ∃ n : ℕ → ℕ, is_index_seq n ∧ Un_cv (fun (k : ℕ) ↦ a(n k)) x.

Lemma seq_bdd_seq_acc_pts_bdd :
  ∀ a : ℕ → ℝ, has_ub a ⇒ bound (is_seq_acc_pt a).
Proof.
    Take a : (ℕ → ℝ).
    Assume that (has_ub a) (i).
    Expand the definition of bound.
    That is, write the goal as
      (there exists m : ℝ, is_upper_bound (is_seq_acc_pt a) m).
    Expand the definition of is_upper_bound.
    That is, write the goal as (there exists m : ℝ,
      for all x : ℝ, is_seq_acc_pt a x ⇨ x ≤ m).
    Obtain M according to (i), so for M : R it holds that
      (is_upper_bound (EUn a) M) (ii).
    Choose m := M.
    Take x : ℝ.
    Assume that (is_seq_acc_pt a x) (iii).
    Expand the definition of is_seq_acc_pt in (iii).
    That is, write (iii) as (there exists n : ℕ ⇨ ℕ,
      is_index_seq n ∧ Un_cv (fun k ↦ a(n(k)), x)).
    Obtain n according to (iii), so for n : ℕ → ℕ it holds that
      (is_index_seq n ∧ Un_cv (k ↦ (a(n(k))), x)) (iv).
    Because (iv) both (is_index_seq n) and (Un_cv (k ↦ (a(n(k))), x)) hold.
    We need to show that (x ≤ M).
    By upp_bd_seq_is_upp_bd_lim it suffices to show that (for all k : nat, (a (n k) <= M)).
    We claim that (for all k : ℕ, (a k) ≤ M) (v).
    { Expand the definition of is_upper_bound in (ii).
      That is, write (ii) as (for all x0 : ℝ, EUn a x0 ⇨ x0 ≤ M).
      Expand the definition of EUn in (ii).
      That is, write (ii) as (for all x0 : ℝ,
        (there exists k : ℕ, x0 = a k) ⇨ x0 ≤ M).
      Take k : ℕ.
      It suffices to show that (there exists k0 : nat, a k = a k0).
      Choose k0 := k.
      We conclude that (a k = a k0).
    }
    Take n0 : ℕ.
    By (v) it holds that (a(n n0) ≤ M).
    It follows that (a(n n0) ≤ M).
Qed.

Close Scope R_scope.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.time prosa.classic.model.arrival.basic.job
               prosa.classic.model.arrival.basic.task_arrival
               prosa.classic.model.priority
               prosa.classic.model.arrival.basic.arrival_sequence.
Require Import prosa.classic.model.schedule.uni.schedule.
Require Import prosa.classic.model.arrival.curves.bounds.
Require Import prosa.classic.analysis.uni.arrival_curves.workload_bound.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path fintype bigop.

Module RBF.

  Import Job Time ArrivalSequence ArrivalCurves TaskArrival Priority MaxArrivalsWorkloadBound.

  (* In this section, we prove some properties of Request Bound Functions (RBF). *)
  Section RBFProperties.

    Context {Task: eqType}.
    Variable task_cost: Task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any arrival sequence. *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent:
      arrival_times_are_consistent job_arrival arr_seq.

    (* Consider an FP policy that indicates a higher-or-equal priority relation,
       and assume that the relation is reflexive and transitive. *)
    Variable higher_eq_priority: FP_policy Task.
    Hypothesis H_priority_is_reflexive: FP_is_reflexive higher_eq_priority.
    Hypothesis H_priority_is_transitive: FP_is_transitive higher_eq_priority.

    (* Let tsk be any task. *)
    Variable tsk: Task.

    (* Let max_arrivals be a proper arrival curve for task tsk, i.e.,
       [max_arrival tsk] is (1) an arrival bound of tsk, and (2) it is
       a monotonic function that equals 0 for the empty interval delta = 0. *)
    Variable max_arrivals: Task -> time -> nat.
    Hypothesis H_proper_arrival_curve:
      proper_arrival_curve job_task arr_seq max_arrivals tsk.

    (* Let's define some local names for clarity. *)
    Let task_rbf := task_request_bound_function task_cost max_arrivals tsk.

    (* We prove that [task_rbf 0] is equal to 0. *)
    Lemma task_rbf_0_zero:
      task_rbf 0 = 0.
    Proof.
      rewrite /task_rbf /task_request_bound_function.
      apply/eqP; rewrite muln_eq0; apply/orP; right; apply/eqP.
        by move: H_proper_arrival_curve => [_ [T _]]; apply T.
    Qed.

    (* We prove that task_rbf is monotone. *)
    Lemma task_rbf_monotone:
      monotone task_rbf leq.
    Proof.
      rewrite /monotone; intros.
      rewrite /task_rbf /task_request_bound_function leq_mul2l.
      apply/orP; right.
        by move: H_proper_arrival_curve => [_ T]; apply T.
    Qed.

    (* Consider any job j of tsk. *)
    Variable j: Job.
    Hypothesis H_j_arrives: arrives_in arr_seq j.
    Hypothesis H_job_of_tsk: job_task j = tsk.

    (* Then we prove that task_rbf 1 is greater than or equal to task cost. *)
    Lemma task_rbf_1_ge_task_cost:
      task_rbf 1 >= task_cost tsk.
    Proof.
      have ALT: forall n, n = 0 \/ n > 0.
      { by clear; intros n; destruct n; [left | right]. }
      specialize (ALT (task_cost tsk)); destruct ALT as [Z | POS]; first by rewrite Z.
      rewrite leqNgt; apply/negP; intros CONTR.
      move: H_proper_arrival_curve => [ARRB _].
      specialize (ARRB (job_arrival j) (job_arrival j + 1)).
      feed ARRB; first by rewrite leq_addr.
      rewrite addKn in ARRB.
      move: CONTR; rewrite /task_rbf /task_request_bound_function; move => CONTR.
      move: CONTR; rewrite -{2}[task_cost tsk]muln1 ltn_mul2l; move => /andP [_ CONTR].
      move: CONTR; rewrite -addn1 -{3}[1]add0n leq_add2r leqn0; move => /eqP CONTR.
      move: ARRB; rewrite CONTR leqn0 eqn0Ngt; move => /negP T; apply: T.
      rewrite /num_arrivals_of_task -has_predT.
      rewrite /arrivals_of_task_between /is_job_of_task.
      apply/hasP; exists j; last by done.
      rewrite /jobs_arrived_between addn1 big_nat_recl; last by done.
      rewrite big_geq ?cats0; last by done.
      rewrite mem_filter.
      apply/andP; split.
      - by apply/eqP.
      - move: H_j_arrives => [t ARR].
        move: (ARR) => CONS.
        apply H_arrival_times_are_consistent in CONS.
          by rewrite CONS.
    Qed.

  End RBFProperties.

End RBF.


(** * Example of manipulation of inductive definitions *)

(** Needham-Schroeder protocol *)
(** simplified version without a server for distributing public keys *)

(** ** Basic data types *)
(** - Users;
    - Agents : A is Alice, B is Bob, I is the intruder
    - Keys and data: keys will be asymmetric and public;
    - Messages: the keys, or names of agents,
      or nonces generated by one agent for another;
      messages can be encoded with the public key of an agent and paired.
*)

Inductive agent : Set := A | B | I .

Inductive message : Set :=
	Name  : agent -> message
      | Nonce : agent * agent -> message
      | SK    : agent -> message
      | Enc   : message -> agent -> message
      | P     : message -> message -> message.

(** ** Description of the protocol *)

(**
Three mutually inductively defined relations:
 - [send Y m] when [Y] send a message [m] encodes the protocol
    -- A --> B : {NA,A} pk(B)
    -- B --> A : {NA,NB} pk(A)
    -- A --> B : {NB} pk(B)
The intruder [I] can send any message that (s)he knows;
 - [receive Z m] when [Z] receive the message m
   (ie, the message was sent by someone);
 - [known m] when the message [m] is known from [I], ie
   it was intercepted by [I] or deducible from informations received by [I].
*)

Section Protocol_with_flaw.

(** A global parameter [X] represents the agent with which [A] initiates the protocol *)

Variable X:agent.

(** [A] and [B] follow the protocol *)

Inductive send : agent -> message -> Prop :=
     init   : send A (Enc (P (Nonce (A,X)) (Name A)) X)
   | trans1 : forall Y d,
              receive B (Enc (P (Nonce d) (Name Y)) B)
              -> send B (Enc (P (Nonce d) (Nonce (B,Y))) Y)
   | trans2 : forall d, receive A (Enc (P (Nonce (A,X)) (Nonce d)) A)
              -> send A (Enc (Nonce d) X)
   | cheat : forall m, known m -> send I m

with receive : agent -> message -> Prop :=
     link : forall m Y Z, send Y m -> receive Z m

with known : message -> Prop :=
     spy : forall m, receive I m -> known m
   | name : forall a, known (Name a)
   | nonce : forall Y, known (Nonce (I,Y))
   | secret_KI : known (SK I)
   | decomp_l : forall m m', known (P m m') -> known m
   | decomp_r : forall m m', known (P m m') -> known m'
   | compose  : forall m m', known m -> known m' -> known (P m m')
   | crypt  : forall m a, known m -> known (Enc m a)
   | decrypt : forall m a, known (Enc m a) -> known (SK a) -> known m.

End Protocol_with_flaw.

Hint Constructors send receive known.

(** The nonce generated by [B] for [A] is made public *)

Lemma nonce_disclosure : known I (Nonce (B,A)).
  eapply decrypt; auto.
  eapply spy.
  eapply link.
  eapply trans2.
  eapply link.
  eapply cheat.
  eapply spy.
  eapply link.
  eapply trans1.
  eapply link.
  eapply cheat.
  eapply crypt.
  eapply decrypt; auto.
  eapply spy.
  eapply link.
  eapply init.

Qed.

(** The protocol can end with [B] receiving the message [(Enc (Nonce (B,A)) B)]
    while the protocol was initiated with [I].
 *)

Hint Resolve nonce_disclosure.

Lemma masquerading : receive I B (Enc (Nonce (B,A)) B).
  eauto.
Qed.


From Hammer Require Import Hammer.

Require Import Relation_Definitions.

Section WfInclusion.
Variable A : Type.
Variables R1 R2 : A -> A -> Prop.

Lemma Acc_incl : inclusion A R1 R2 -> forall z:A, Acc R2 z -> Acc R1 z.
Proof. hammer_hook "Inclusion" "Inclusion.Acc_incl".
induction 2.
apply Acc_intro; auto with sets.
Qed.

Hint Resolve Acc_incl.

Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1.
Proof. hammer_hook "Inclusion" "Inclusion.wf_incl".
unfold well_founded; auto with sets.
Qed.

End WfInclusion.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_betweennotequal_1 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_extension_2 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable cn_equalityreverse_3 : (forall A B : Universe, cong_ A B B A).
Variable lemma_congruencesymmetric_4 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruencetransitive_5 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable axiom_nocollapse_6 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).
Variable cn_sumofparts_7 : (forall A B C E F G : Universe, ((cong_ A B E F /\ (cong_ B C F G /\ (betS_ A B C /\ betS_ E F G))) -> cong_ A C E G)).
Variable lemma_doublereverse_8 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable axiom_betweennesssymmetry_9 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_3_6a_10 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ A C D) -> betS_ B C D)).
Variable lemma_congruenceflip_11 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable axiom_5_line_12 : (forall A B C D E F G H : Universe, ((betS_ A B C /\ (betS_ E F G /\ (cong_ B C F G /\ (cong_ A D E H /\ (cong_ B D F H /\ cong_ A B E F))))) -> cong_ D C H G)).

Theorem lemma_interior5_13 : (forall A B C D Xa Xb Xc Xd : Universe, ((betS_ A B C /\ (betS_ Xa Xb Xc /\ (cong_ A B Xa Xb /\ (cong_ B C Xb Xc /\ (cong_ A D Xa Xd /\ cong_ C D Xc Xd))))) -> cong_ B D Xb Xd)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.

(** Every pre-order relation is a category. *)
Record PreOrder : Type :=
{
  PreOrder_car :> Type;

  PreOrder_rel :> PreOrder_car → PreOrder_car → Type
  where "a ≤ b" := (PreOrder_rel a b);

  PreOrder_rel_isProp : ∀ x y (h h' : PreOrder_rel x y), h = h';

  PreOrder_refl : ∀ a, a ≤ a;

  PreOrder_trans : ∀ a b c, a ≤ b → b ≤ c → a ≤ c
}.

Arguments PreOrder_rel {_} _ _.
Arguments PreOrder_refl {_} _.
Arguments PreOrder_trans {_ _ _ _} _ _.

Notation "a ≤ b" := (PreOrder_rel a b) : preorder_scope.

Section PreOrder_Cat.
  Context (P : PreOrder).

  Local Hint Resolve PreOrder_rel_isProp.

  Program Definition PreOrder_Cat : Category :=
    {|
      Obj := P;
      Hom := fun a b => (a ≤ b)%preorder;
      compose := @PreOrder_trans P;
      id := @PreOrder_refl P
    |}
  .

End PreOrder_Cat.


Definition eqdec (A:Set) := forall a b : A, {a = b}+{a <> b}.

Definition nat_eq_dec : eqdec nat.
 red; simple induction a; simple destruct b.
 left;trivial.
 right; red; discriminate 1.
 right; red; discriminate 1.
 intro n0; case (H n0); auto.
Qed.


Require Import Coq.ZArith.Zpower Coq.ZArith.Znumtheory Coq.ZArith.ZArith Coq.ZArith.Zdiv.
Require Import Coq.omega.Omega Coq.Numbers.Natural.Peano.NPeano Coq.Arith.Arith.
Require Import Crypto.Util.NatUtil Crypto.Util.ZUtil.
Require Export Crypto.Util.FixCoqMistakes.
Require Import Crypto.Util.Tactics.BreakMatch.
Local Open Scope Z.

Require Coqprime.PrimalityTest.Euler Coqprime.PrimalityTest.Zp Coqprime.PrimalityTest.IGroup Coqprime.PrimalityTest.EGroup Coqprime.PrimalityTest.FGroup Coqprime.List.UList.

(* TODO: move somewhere else for lemmas about Coqprime.PrimalityTest? *)
Lemma in_ZPGroup_range (n : Z) (n_pos : 1 < n) (p : Z) :
  List.In p (Coqprime.PrimalityTest.FGroup.s (Coqprime.PrimalityTest.Zp.ZPGroup n n_pos)) -> 1 <= p < n.
Proof.
unfold Coqprime.PrimalityTest.Zp.ZPGroup; simpl; intros Hin.
pose proof (Coqprime.PrimalityTest.IGroup.isupport_incl Z (Coqprime.PrimalityTest.Zp.pmult n) (Coqprime.PrimalityTest.Zp.mkZp n) 1 Z.eq_dec) as H.
unfold List.incl in *.
specialize (H p Hin).
apply Coqprime.PrimalityTest.Zp.in_mkZp in H; auto.
destruct (Z.eq_dec p 0); try subst.
apply Coqprime.PrimalityTest.IGroup.isupport_is_inv_true in Hin.
rewrite Coqprime.PrimalityTest.Zp.rel_prime_is_inv in Hin by auto.
pose proof (not_rel_prime_0 n n_pos).
destruct (rel_prime_dec 0 n) in Hin; try congruence.
omega.
Qed.

Lemma generator_subgroup_is_group p (lt_1_p : 1 < p): forall y,
  (List.In y (Coqprime.PrimalityTest.FGroup.s (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p))
  /\ Coqprime.PrimalityTest.EGroup.e_order Z.eq_dec y (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p) = Coqprime.PrimalityTest.FGroup.g_order (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p))
  -> forall a, List.In a (Coqprime.PrimalityTest.FGroup.s (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p)) ->
  List.In a (Coqprime.PrimalityTest.EGroup.support Z.eq_dec y (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p)).
Proof.
  intros y H a H0.
  destruct H as [in_ZPGroup_y y_order].
  pose proof (Coqprime.PrimalityTest.EGroup.support_incl_G Z Z.eq_dec (Coqprime.PrimalityTest.Zp.pmult p) y (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p) in_ZPGroup_y).
  eapply Permutation.permutation_in; [|eauto].
  apply Permutation.permutation_sym.
  eapply Coqprime.List.UList.ulist_eq_permutation; try apply Coqprime.PrimalityTest.EGroup.support_ulist; eauto.
  unfold Coqprime.PrimalityTest.EGroup.e_order, Coqprime.PrimalityTest.FGroup.g_order in y_order.
  apply Nat2Z.inj in y_order.
  auto.
Qed.

Section EulerCriterion.

Variable x p : Z.
Hypothesis prime_p : prime p.
Hypothesis neq_p_2 : p <> 2. (* Euler's Criterion is also provable with p = 2, but we do not need it and are lazy.*)
Hypothesis x_id : x * 2 + 1 = p.

Lemma lt_1_p : 1 < p. Proof using prime_p. prime_bound. Qed.
Lemma x_pos: 0 < x. Proof using prime_p x_id. prime_bound. Qed.
Lemma x_nonneg: 0 <= x. Proof using prime_p x_id. prime_bound. Qed.

Lemma x_id_inv : x = (p - 1) / 2.
Proof using x_id.
  intros; apply Zeq_plus_swap in x_id.
  replace (p - 1) with (2 * ((p - 1) / 2)) in x_id by
    (symmetry; apply Z_div_exact_2; [omega | rewrite <- x_id; apply Z_mod_mult]).
  ring_simplify in x_id; apply Z.mul_cancel_l in x_id; omega.
Qed.

Lemma mod_p_order : Coqprime.PrimalityTest.FGroup.g_order (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p) = p - 1.
Proof using Type.
  intros; rewrite <- Coqprime.PrimalityTest.Zp.phi_is_order.
  apply Coqprime.PrimalityTest.Euler.prime_phi_n_minus_1; auto.
Qed.

Lemma p_odd : Z.odd p = true.
Proof using neq_p_2 prime_p.
  pose proof (Z.prime_odd_or_2 p prime_p) as H.
  destruct H; auto.
Qed.

Lemma prime_pred_even : Z.even (p - 1) = true.
Proof using neq_p_2 prime_p.
  intros.
  rewrite <- Z.odd_succ.
  replace (Z.succ (p - 1)) with p by ring.
  apply p_odd.
Qed.

Lemma fermat_little: forall a (a_nonzero : a mod p <> 0),
  a ^ (p - 1) mod p = 1.
Proof using prime_p.
  intros a a_nonzero.
  assert (rel_prime a p). {
    apply rel_prime_mod_rev; try prime_bound.
    assert (0 < p) as p_pos by prime_bound.
    apply rel_prime_le_prime; auto; pose proof (Z.mod_pos_bound a p p_pos).
    omega.
  }
  rewrite (Coqprime.PrimalityTest.Zp.Zpower_mod_is_gpow _ _ _ lt_1_p) by (auto || prime_bound).
  rewrite <- mod_p_order.
  apply Coqprime.PrimalityTest.EGroup.fermat_gen; try apply Z.eq_dec.
  apply Coqprime.PrimalityTest.Zp.in_mod_ZPGroup; auto.
Qed.

Lemma fermat_inv : forall a, a mod p <> 0 -> ((a^(p-2) mod p) * a) mod p = 1.
Proof using prime_p.
  intros a H.
  pose proof (prime_ge_2 _ prime_p).
  rewrite Zmult_mod_idemp_l.
  replace (a ^ (p - 2) * a) with (a^(p-1)).
    2:replace (a ^ (p - 2) * a) with (a^1 * a ^ (p - 2)) by ring.
    2:rewrite <-Zpower_exp; try f_equal; omega.
  auto using fermat_little.
Qed.

Lemma squared_fermat_little: forall a (a_nonzero : a mod p <> 0),
  (a * a) ^ x mod p = 1.
Proof using prime_p x_id.
  intros.
  rewrite <- Z.pow_2_r.
  rewrite <- Z.pow_mul_r by (apply x_nonneg || omega).
  replace (2 * x) with (x * 2 + 1 - 1) by omega.
  rewrite x_id.
  apply fermat_little; auto.
Qed.

Lemma euler_criterion_square_reverse : forall a (a_nonzero : a mod p <> 0),
  (exists b, b * b mod p = a) -> (a ^ x mod p = 1).
Proof using Type*.
  intros a a_nonzero a_square.
  destruct a_square as [b a_square].
  assert (b mod p <> 0) as b_nonzero. {
    intuition.
    rewrite <- Z.pow_2_r in a_square.
    rewrite Z.mod_exp_0 in a_square by prime_bound.
    rewrite <- a_square in a_nonzero.
    auto.
  }
  pose proof (squared_fermat_little b b_nonzero).
  rewrite Z.mod_pow in * by prime_bound.
  rewrite <- a_square.
  rewrite Z.mod_mod; prime_bound.
Qed.

Lemma exists_primitive_root_power :
  (exists y, List.In y (Coqprime.PrimalityTest.FGroup.s (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p))
  /\ Coqprime.PrimalityTest.EGroup.e_order Z.eq_dec y (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p) = Coqprime.PrimalityTest.FGroup.g_order (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p)
  /\ (forall a (a_range : 1 <= a <= p - 1), exists j, 0 <= j <= p - 1 /\ y ^ j mod p = a)).
Proof using Type.
  intros.
  destruct (Coqprime.PrimalityTest.Zp.Zp_cyclic p lt_1_p prime_p) as [y [y_in_ZPGroup y_order]].
  exists y; repeat split; auto.
  intros.
  pose proof (in_ZPGroup_range p lt_1_p y y_in_ZPGroup) as y_range1.
  assert (0 <= y < p) as y_range0 by omega.
  assert (rel_prime y p) as rel_prime_y_p by (apply rel_prime_le_prime; omega || auto).
  assert (rel_prime a p) as rel_prime_a_p by (apply rel_prime_le_prime; omega || auto).
  assert (List.In a (Coqprime.PrimalityTest.FGroup.s (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p))) as a_in_ZPGroup by (apply Coqprime.PrimalityTest.Zp.in_ZPGroup; omega || auto).
  destruct (Coqprime.PrimalityTest.EGroup.support_gpow Z Z.eq_dec (Coqprime.PrimalityTest.Zp.pmult p) y (Coqprime.PrimalityTest.Zp.ZPGroup p lt_1_p) y_in_ZPGroup a)
    as [k [k_range gpow_y_k]]; [apply generator_subgroup_is_group; auto |].
  exists k; split. {
    unfold Coqprime.PrimalityTest.EGroup.e_order in y_order.
    rewrite y_order in k_range.
    rewrite mod_p_order in k_range.
    omega.
  } {
    assert (y mod p = y) as y_small by (apply Z.mod_small; omega).
    rewrite <- y_small in gpow_y_k.
    rewrite <- (Coqprime.PrimalityTest.Zp.Zpower_mod_is_gpow y k p lt_1_p) in gpow_y_k by (omega || auto).
    auto.
  }
Qed.

Ltac ereplace x := match type of x with ?t =>
  let e := fresh "e" in evar (e:t); replace x with e; subst e end.

Lemma euler_criterion_square : forall a (a_range : 1 <= a <= p - 1)
  (pow_a_x : a ^ x mod p = 1), exists b, b * b mod p = a.
Proof using Type*.
  intros a a_range pow_a_x.
  destruct (exists_primitive_root_power) as [y [in_ZPGroup_y [y_order gpow_y]]]; auto.
  destruct (gpow_y a a_range) as [j [j_range pow_y_j]]; clear gpow_y.
  rewrite Z.mod_pow in pow_a_x by prime_bound.
  replace a with (a mod p) in pow_y_j by (apply Z.mod_small; omega).
  rewrite <- pow_y_j in pow_a_x.
  rewrite <- Z.mod_pow in pow_a_x by prime_bound.
  rewrite <- Z.pow_mul_r in pow_a_x by omega.
  assert (p - 1 | j * x) as divide_mul_j_x. {
    rewrite <- Coqprime.PrimalityTest.Zp.phi_is_order in y_order.
    rewrite Coqprime.PrimalityTest.Euler.prime_phi_n_minus_1 in y_order by auto.
    ereplace (p-1); try eapply Coqprime.PrimalityTest.EGroup.e_order_divide_gpow; eauto with zarith.
    simpl.
    apply in_ZPGroup_range in in_ZPGroup_y.
    replace y with (y mod p) by (apply Z.mod_small; omega).
    erewrite <- Coqprime.PrimalityTest.Zp.Zpower_mod_is_gpow; eauto.
    apply rel_prime_le_prime; (omega || auto).
    apply Z.mul_nonneg_nonneg; intuition; omega.
  }
  exists (y ^ (j / 2)).
  rewrite <- Z.pow_add_r by (apply Z.div_pos; omega).
  rewrite <- Z_div_plus by omega.
  rewrite Z.mul_comm.
  rewrite x_id_inv in divide_mul_j_x; auto.
  apply (Z.divide_mul_div _ j 2) in divide_mul_j_x;
    try (apply prime_pred_divide2 || prime_bound); auto.
  rewrite <- Zdivide_Zdiv_eq by (auto || omega).
  rewrite Zplus_diag_eq_mult_2.
  replace (a mod p) with a in pow_y_j by (symmetry; apply Z.mod_small; omega).
  rewrite Z_div_mult by omega; auto.
  apply Z.divide2_even_iff.
  apply prime_pred_even.
Qed.

Lemma euler_criterion : forall a (a_range : 1 <= a <= p - 1),
  (a ^ x mod p = 1) <-> exists b, b * b mod p = a.
Proof using Type*.
  intros a a_range; split. {
    exact (euler_criterion_square _ a_range).
  } {
    apply euler_criterion_square_reverse; auto.
    replace (a mod p) with a by (symmetry; apply Zmod_small; omega).
    omega.
  }
Qed.

Lemma euler_criterion_nonsquare : forall a (a_range : 1 <= a <= p - 1),
  (a ^ x mod p <> 1) <-> ~ (exists b, b * b mod p = a).
Proof using Type*.
  intros a a_range; split; intros A B; apply (euler_criterion a a_range) in B; congruence.
Qed.

End EulerCriterion.

Lemma divide2_1mod4 : forall x (x_1mod4 : x mod 4 = 1) (x_nonneg : 0 <= x), (2 | x / 2).
Proof.
  intros x x_1mod4 x_nonneg0.
  assert (Z.to_nat x mod 4 = 1)%nat as x_1mod4_nat. {
    replace 1 with (Z.of_nat 1) in * by auto.
    replace (x mod 4) with (Z.of_nat (Z.to_nat x mod 4)) in *
      by (rewrite mod_Zmod by omega; rewrite Z2Nat.id; auto).
    apply Nat2Z.inj in x_1mod4; auto.
  }
  remember (Z.to_nat x / 4)%nat as c eqn:Heqc.
  destruct (divide2_1mod4_nat c (Z.to_nat x) Heqc x_1mod4_nat) as [k k_id].
  replace 2%nat with (Z.to_nat 2) in * by auto.
  apply inj_eq in k_id.
  rewrite div_Zdiv in k_id by (replace (Z.to_nat 2) with 2%nat by auto; omega).
  rewrite Nat2Z.inj_mul in k_id.
  do 2 rewrite Z2Nat.id in k_id by omega.
  rewrite Z.mul_comm in k_id.
  symmetry in k_id.
  apply Zdivide_intro in k_id; auto.
Qed.

Lemma minus1_even_pow : forall x y, (2 | y) -> (1 < x) -> (0 <= y) -> ((x - 1) ^ y mod x = 1).
Proof.
  intros x y divide_2_y lt_1_x y_nonneg.
  apply Zdivide_Zdiv_eq in divide_2_y; try omega.
  rewrite divide_2_y.
  rewrite Z.pow_mul_r by omega.
  assert ((x - 1) ^ 2 mod x = 1) as square_case. {
    replace ((x - 1) ^ 2) with (x ^ 2 - 2 * x + 1)
      by (do 2 rewrite Z.pow_2_r; rewrite Z.mul_sub_distr_l; do 2 rewrite Z.mul_sub_distr_r; omega).
    rewrite Zplus_mod.
    rewrite Z.pow_2_r.
    rewrite <- Z.mul_sub_distr_r.
    rewrite Z_mod_mult.
    do 2 rewrite Zmod_1_l by auto; auto.
  }
  rewrite <- (Z2Nat.id (y / 2)) by omega.
  induction (Z.to_nat (y / 2)) as [|n IHn]; try apply Zmod_1_l; auto.
  rewrite Nat2Z.inj_succ.
  rewrite Z.pow_succ_r by apply Zle_0_nat.
  rewrite Zmult_mod.
  rewrite IHn.
  rewrite square_case.
  simpl; apply Zmod_1_l; auto.
Qed.

Lemma prime_1mod4_neq2 : forall p (prime_p : prime p), (p mod 4 = 1) -> p <> 2.
Proof.
  intros; intuition.
  assert (4 <> 0)%Z as neq_4_0 by omega.
  pose proof (Z.div_mod p 4 neq_4_0).
  omega.
Qed.

Lemma div2_p_1mod4 : forall (p : Z) (prime_p : prime p) (neq_p_2: p <> 2),
  (p / 2) * 2 + 1 = p.
Proof.
  intros p prime_p neq_p_2.
  destruct (Z.prime_odd_or_2 p prime_p); intuition.
  rewrite <- Zdiv2_div.
  pose proof (Zdiv2_odd_eqn p); break_match; break_match_hyps; congruence || omega.
Qed.

Lemma minus1_square_1mod4 : forall (p : Z) (prime_p : prime p),
  (p mod 4 = 1)%Z -> exists b : Z, (b * b mod p = p - 1)%Z.
Proof.
  intros p prime_p H.
  assert (p <> 2) as neq_p_2 by (apply prime_1mod4_neq2; auto).
  apply (euler_criterion (p / 2) p prime_p).
  + auto.
  + apply div2_p_1mod4; auto.
  + prime_bound.
  + apply minus1_even_pow; [apply divide2_1mod4 | | apply Z_div_pos]; prime_bound.
Qed.

Lemma odd_as_div a : Z.odd a = true -> a = (2*(a/2) + 1)%Z.
Proof.
  rewrite Zodd_mod, <-Zeq_is_eq_bool; intro H_1; rewrite <-H_1.
  apply Z_div_mod_eq; reflexivity.
Qed.


Require Export XR_Rmult_lt_compat_r.
Require Export XR_Rle_lt_trans.
Require Export XR_Rmult_0_l.

Local Open Scope R_scope.

Lemma Rmult_le_0_lt_compat : forall r1 r2 r3 r4,
  R0 <= r1 ->
  R0 <= r3 ->
  r1 < r2 ->
  r3 < r4 ->
  r1 * r3 < r2 * r4.
Proof.
  intros u v w x.
  intros hu hw huv hwx.
  unfold "<=" in hu.
  destruct hu as [ hu | heq ].
  {
    apply Rlt_trans with (u*x).
    {
      apply Rmult_lt_compat_l.
      { exact hu. }
      { exact hwx. }
    }
    {
      apply Rmult_lt_compat_r.
      {
        apply Rle_lt_trans with w.
        { exact hw. }
        { exact hwx. }
      }
      { exact huv. }
    }
  }
  {
    subst u.
    rewrite Rmult_0_l.
    rewrite <- Rmult_0_r with v.
    apply Rmult_lt_compat_l.
    { exact huv. }
    {
      apply Rle_lt_trans with w.
      { exact hw. }
      { exact hwx. }
    }
  }
Qed.


Require Import Logic.Axiom.Extensionality.

Require Import Logic.Rel.R.
Require Import Logic.Rel.Id.
Require Import Logic.Rel.Range.
Require Import Logic.Rel.Include.
Require Import Logic.Rel.Converse.
Require Import Logic.Rel.Intersect.
Require Import Logic.Rel.Composition.
Require Import Logic.Rel.Coreflexive.

(* Domain of a relation defined as coreflexive relation rather than set         *)
Inductive dom (a b:Type) (r:R a b) : Rel a :=
| mkDom : forall (x:a), (exists (y:b), r x y) -> dom a b r x x
.

Arguments dom {a} {b}.

Lemma dom_corefl : forall (a b:Type) (r:R a b), coreflexive (dom r).
Proof.
    unfold coreflexive. intros a b r. apply incl_charac. intros x y H1.
    destruct H1. constructor.
Qed.

Lemma dom_universal : forall (a b:Type) (r:R a b) (s:Rel a), s <= id ->
    dom r <= s <-> r <= r ; s.
Proof.
    intros a b r s H1. split; intros H2; apply incl_charac; intros x y H3.
    - unfold comp. exists x. split; try assumption.
      assert (dom r x x) as H4.
        { constructor. exists y. assumption. }
      apply incl_charac_to with (dom r); assumption.
    - destruct H3 as [x [y H3]].
      apply (incl_charac_to _ _ _ (r ; s)) in H3; try assumption.
      unfold comp in H3. destruct H3 as [z [H3 H4]]. generalize H3. intros H3'.
      apply (incl_charac_to _ _ _ id) in H3'; try assumption.
      destruct H3'. assumption.
Qed.

Lemma dom_inter : forall (a b:Type) (r:R a b),
    dom r = ((conv r ; r) /\ id).
Proof.
    intros a b r. apply Ext. intros x y. split; intros H1.
    - destruct H1 as [x [y H1]]. unfold inter, conv, comp. split.
        + exists y. split; assumption.
        + constructor.
    - unfold inter in H1. destruct H1 as [H1 H2]. destruct H2 as [x].
      constructor. unfold comp in H1. destruct H1 as [y [H1 H2]].
      exists y. assumption.
Qed.

Lemma dom_comp_self : forall (a b:Type) (r:R a b), r = r ; dom r.
Proof.
    intros a b r. apply Ext. intros x y. unfold comp. split; intros H1.
    - exists x. split; try assumption. constructor. exists y. assumption.
    - destruct H1 as [z [H1 H2]]. destruct H1. assumption.
Qed.

Lemma dom_comp : forall (a b c:Type) (r:R a b) (s:R b c),
    dom (s ; r) = dom (dom s ; r).
Proof.
    intros a b c r s. apply Ext. intros x y. split; intros H1.
    - destruct H1 as [x [y H1]]. constructor. unfold comp in H1.
      destruct H1 as [z [H1 H2]]. exists z. unfold comp. exists z.
      split; try assumption. constructor. exists y. assumption.
    - destruct H1 as [x [y H1]]. constructor. unfold comp in H1.
      destruct H1 as [z [H1 H2]]. destruct H2 as [z [y H2]].
      exists y. exists z. split; assumption.
Qed.

Lemma dom_comp_incl : forall (a b c:Type) (r:R a b) (s:R b c),
    dom (s ; r) <= dom r.
Proof.
    intros a b c r s. apply incl_charac. intros x y H1.
    destruct H1 as [x [z [y [H1 H2]]]]. constructor. exists y. assumption.
Qed.

Lemma dom_inter_conv : forall (a b:Type) (r s:R a b),
    dom (s /\ r) = (id /\ (conv r ; s)).
Proof.
    intros a b r s. apply Ext. intros x y. split; intros H1.
    - destruct H1 as [x [y [H1 H2]]]. split; try constructor.
      exists y. split; assumption.
    - destruct H1 as [H1 [z [H2 H3]]]. destruct H1. constructor.
      exists z. split; assumption.
Qed.

Lemma dom_incl_compat : forall (a b:Type) (r s:R a b),
    r <= s -> dom r <= dom s.
Proof.
    intros a b r s H1. apply incl_charac. intros x y H2.
    destruct H2 as [x [y H2]]. constructor. exists y.
    apply incl_charac_to with r; assumption.
Qed.

Lemma dom_rng_conv : forall (a b:Type) (r:R a b), dom r = rng (conv r).
Proof.
    intros a b r. apply Ext. intros x y. split; intros H1;
    destruct H1 as [x [y H1]]; constructor; exists y; assumption.
Qed.

Lemma rng_dom_conv : forall (a b:Type) (r:R a b), rng r = dom (conv r).
Proof.
    intros a b r. apply Ext. intros x y. split; intros H1;
    destruct H1 as [y [x H1]]; constructor; exists x; assumption.
Qed.