Require Import prelude.

Class InverseFunction `(f:A → B) := inv_fun : B → A.
Arguments inv_fun {_ _} f {_}.
Notation "f ⁻¹" := (inv_fun f) : function_scope.
Hint Extern 2 (InverseFunction (@id ?A)) => eexact (@id A) : typeclass_instances.
Hint Extern 2 (InverseFunction (inv_fun ?f)) => eexact f : typeclass_instances.

Delimit Scope path_scope with path.
Bind Scope path_scope with Id.
Local Open Scope path_scope.

Definition inverse `(p : a = b :> A) : b = a
:= match p with refl => refl end.
Arguments inverse : simpl nomatch.

Definition concat {A:𝓤} {a b c : A} (p : a = b) (q : b = c) : a = c
:= match p,q with refl,refl => refl end.
Arguments concat : simpl nomatch.

Notation "1" := refl : path_scope.
Notation "p ⁻¹" := (inverse p) : path_scope.
Notation "p · q" := (concat p q) : path_scope.
Notation "( p ·)" := (λ q, concat p q) (format "( p  ·)") : path_scope.
Notation "(· q )" := (λ p, concat p q) (format "(·  q )") : path_scope.

(* Section 2.1: Types are Higher Groupoids *)

(* Names (and proofs) from
   https://github.com/HoTT/HoTT/blob/master/theories/Basics/PathGroupoids.v *)

(* Lemma 2.1.4 i *)
Definition concat_1p `(p : x = y :> A) : 1 · p = p
:= match p with refl => refl end.

Definition concat_p1 `(p : x = y :> A) : p · 1 = p
:= match p with refl => refl end.

(* Lemma 2.1.4 ii *)
Definition concat_pV `(p : x = y :> A) : p · p⁻¹ = 1
:= match p with refl => refl end.

Definition concat_Vp `(p : x = y :> A) : p⁻¹ · p = 1
:= match p with refl => refl end.

(* Lemma 2.1.4 iii *)
Definition inv_V `(p : x = y :> A) : p⁻¹⁻¹ = p
:= match p with refl => 1 end.

(* Lemma 2.1.4 iv *)
Definition concat_p_pp {A:𝓤} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) :
  p · (q · r) = (p · q) · r
:= match r with refl =>
     match q with refl =>
       match p with refl => refl
       end end end.

Definition concat_pp_p {A:𝓤} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) :
  (p · q) · r = p · (q · r)
:= match r with refl =>
     match q with refl =>
       match p with refl => refl
       end end end.

(* Horizontal composition of 2-dimensional paths *)
Definition concat2 {A:𝓤} {a b c : A} {p q : a = b} {r s : b = c} (α : p = q) (β : r = s)
  : p · r = q · s
:= match α, β with refl, refl => refl end.
Arguments concat2 : simpl nomatch.
Notation "p ∗ q" := (concat2 p q) : path_scope.

Definition whiskerL {A:𝓤} {x y z : A} (p : x = y)
  {q r : y = z} (h : q = r) : p · q = p · r
:= 1 ∗ h.
Notation "p ·ₗ α" := (whiskerL p α) : path_scope.

Definition whiskerR {A:𝓤} {x y z : A} {p q : x = y}
  (h : p = q) (r : y = z) : p · r = q · r
:= h ∗ 1.
Notation "α ·ᵣ p" := (whiskerR α p) : path_scope.

Definition concat_V_pp {A:𝓤} {x y z : A} (p : x = y) (q : y = z) :
  p⁻¹ · (p · q) = q
:= concat_p_pp _ _ _ · (concat_Vp _ ·ᵣ _) · concat_1p _.

Definition concat_p_Vp {A:𝓤} {x y z : A} (p : x = y) (q : x = z) :
  p · (p⁻¹ · q) = q
:= concat_p_pp _ _ _ · (concat_pV _ ·ᵣ _) · concat_1p _.

Definition concat_pp_V {A:𝓤} {x y z : A} (p : x = y) (q : y = z) :
  (p · q) · q⁻¹ = p
:= concat_pp_p _ _ _ · (_ ·ₗ concat_pV _) · concat_p1 _.

Definition concat_pV_p {A:𝓤} {x y z : A} (p : x = z) (q : y = z) :
  (p · q⁻¹) · q = p
:= concat_pp_p _ _ _ · (_ ·ₗ concat_Vp _) · concat_p1 _.

Definition cancelL {A:𝓤} {x y z : A} (p : x = y) (q r : y = z) :
  p · q = p · r → q = r
:= λ h, (concat_V_pp p q)⁻¹ · (p⁻¹ ·ₗ h) · concat_V_pp p r.

Definition cancelR {A:𝓤} {x y z : A} (p q : x = y) (r : y = z) :
  p · r = q · r → p = q
:= λ h, (concat_pp_V _ _)⁻¹ · (h ·ᵣ r⁻¹) · concat_pp_V _ _.

(* Eckmann-Hilton *)

Definition whiskerL_1p {A:𝓤} {x y : A} {p q : x = y} (α:p = q)
  : 1 ·ₗ α = concat_1p p · α · (concat_1p q)⁻¹
:= match α with 1 => (concat_pV _)⁻¹ · ((concat_p1 _)⁻¹ ·ᵣ _) end.

Definition whiskerR_p1 {A:𝓤} {x y : A} {p q : x = y} (α:p = q)
  : α ·ᵣ 1 = concat_p1 p · α · (concat_p1 q)⁻¹
:= match α with 1 => (concat_pV _)⁻¹ · ((concat_p1 _)⁻¹ ·ᵣ _) end.

Definition concat_1p_1 {A:𝓤} {x y : A} (p : x = y) : (1 · p) · 1 = p
  := (concat_1p _ ·ᵣ _) · concat_p1 _ .

Definition concat_1_p1 {A:𝓤} {x y : A} (p : x = y) : 1 · (p · 1) = p
  := (_ ·ₗ concat_p1 _) · concat_1p _ .

Definition concat2_whisker_rl {A:𝓤} {a b c : A} {p q : a = b} {r s : b = c}
  (α : p = q) (β : r = s) : α ∗ β = (α ·ᵣ r) · (q ·ₗ β)
:= match α, β with 1, 1 => 1 end.

Definition concat2_whisker_lr {A:𝓤} {a b c : A} {p q : a = b} {r s : b = c}
  (α : p = q) (β : r = s) : α ∗ β = (p ·ₗ β) · (α ·ᵣ s)
:= match α, β with 1, 1 => 1 end.

Class Point (A:𝓤) := point : A.
Arguments point A {Point}.

Definition Ω (A:𝓤) {a:Point A} := a = a.
Arguments Ω A {a}, A a.

Hint Extern 2 (Point (Ω ?A ?a)) => eexact (@refl A a) : typeclass_instances.

Theorem EckmannHilton (A:𝓤) {a:Point A} (α β : Ω (Ω A))
  : α · β = β · α .
Proof.
  pose proof whiskerR_p1 α · concat_1p_1 α as p.
  pose proof whiskerL_1p β · concat_1p_1 β as q.
  refine (_⁻¹ · (_ : α ∗ β = _)).
  * exact (concat2_whisker_rl α β · (p ∗ q)).
  * exact (concat2_whisker_lr α β · (q ∗ p)).
Defined.

(* Section 2.2: Functions are functors *)

Definition ap `(f : A → B) `(p:a = b :> A) : f a = f b :=
  match p with refl => refl end.
Arguments ap : simpl nomatch.

Definition ap2 `(f : A → B → C) `(p:a = a' :> A) `(q:b = b' :> B) : f a b = f a' b' :=
  match p, q with refl, refl => refl end.
Arguments ap2 : simpl nomatch.

(* Lemma 2.2.2 i : Functorality of functions *)
Definition ap_1 {A B : 𝓤} (x : A) (f : A → B) : ap f 1 = 1 :> (f x = f x)
:= refl.

Definition ap_pp {A B : 𝓤} (f : A → B) {x y z : A} (p : x = y) (q : y = z) :
  ap f (p · q) = (ap f p) · (ap f q)
:= match q with refl => match p with refl => refl end end.

(* Lemma 2.2.2 ii *)
Definition inverse_ap {A B : 𝓤} (f : A → B) {x y : A} (p : x = y) :
  (ap f p)⁻¹ = ap f p⁻¹
:= match p with refl => refl end.

Definition ap_V {A B : 𝓤} (f : A → B) {x y : A} (p : x = y) :
  ap f p⁻¹ = (ap f p)⁻¹
:= match p with refl => refl end.

(* Lemma 2.2.2 iv, iii : Functorality of ap *)
Definition ap_id {A : 𝓤} {x y : A} (p : x = y) : ap id p = p
:= match p with refl => refl end.

Definition ap_compose {A B C : 𝓤} (f : A → B) (g : B → C) {x y : A} (p : x = y) :
  ap (g ∘ f) p = ap g (ap f p)
:= match p with refl => refl end.

Definition ap_compose' {A B C : 𝓤} (f : A → B) (g : B → C) {x y : A} (p : x = y) :
  ap (λ a, g (f a)) p = ap g (ap f p)
:= match p with refl => refl end.

(* Section 2.3: Type families are fibrations *)

Definition transport `(C : A → 𝓤) `(p : x = y :> A) : C x → C y
:= λ u, match p with refl => u end.
Arguments transport : simpl nomatch.
Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.

Definition lift `{P:A → 𝓤} `(u : P x) `(p : x = y) : (x;u) = (y;(p#u))
:= match p with refl => refl end.
Arguments lift : simpl nomatch.

Definition apd `{P:A → 𝓤} (f : Π x, P x) `(p : x = y) : p # f x = f y
:= match p with refl => refl end.
Arguments apd : simpl nomatch.

Definition transport_const {A B:𝓤} `(p : x = y :> A) (b:B) : transport (λ _, B) p b = b
:= match p with refl => refl end.
Arguments transport_const : simpl nomatch.

(* Lemma 2.3.8 *)
Definition apd_nondep `(f:A → B) `(p : x = y :> A) : apd f p = transport_const p (f x) · ap f p
:= match p with refl => refl end.

Definition transport_1 `(P : A → 𝓤) `(u : P x) : 1 # u = u := refl.

(* Lemma 2.3.9 *)
Definition transport_pp `(P : A → 𝓤) {x y z : A} (p : x = y) (q : y = z) (u : P x) :
  p · q # u = q # p # u
:= match q with refl =>
     match p with refl => refl end
   end.

Definition transport_pV `(P : A → 𝓤) `(p : x = y) (z : P y)
  : p # p⁻¹ # z = z
:= (transport_pp P p⁻¹ p z)⁻¹ · ap (λ r, transport P r z) (concat_Vp p).

Definition transport_Vp `(P : A → 𝓤) `(p : x = y) (z : P x)
  : p⁻¹ # p # z = z
:= (transport_pp P p p⁻¹ z)⁻¹ · ap (λ r, transport P r z) (concat_pV p).

(* Lemma 2.3.10 *)
Definition transport_compose {A B:𝓤} (P : B → 𝓤) (f : A → B) `(p : x = y) (z : P (f x))
  : transport (P ∘ f) p z  =  transport P (ap f p) z
:= match p with refl => refl end.

(* Lemma 2.3.11 *)
Definition transport_fun_family {A:𝓤} (P Q : A → 𝓤) (f : Π x, P x → Q x) `(p : x = y)
  (u : P x) : transport Q p (f x u) = f y (transport P p u)
:= match p with refl => refl end.

(* Section 2.4: Homotopies and Equivalences *)

Definition Homotopy `{P:A → 𝓤} (f g : Π x, P x) := Π x, f x = g x.
Notation "f ~ g" := (Homotopy f g) (at level 70, no associativity) : type_scope.
Delimit Scope homotopy_scope with hom.
Bind Scope homotopy_scope with Homotopy.

(* Lemma 2.4.2 *)
Section homotopy_is_an_equivalence.
  Context `{P:A → 𝓤}.

  Definition hom_refl (f : Π x, P x) : f ~ f := λ x, refl.
  Definition hom_inverse {f g : Π x, P x} : f ~ g → g ~ f := λ H x, (H x)⁻¹.
  Definition hom_concat {f g h : Π x, P x} : f ~ g → g ~ h → f ~ h := λ F G x, F x · G x.
End homotopy_is_an_equivalence.

Notation "1" := (hom_refl _) : homotopy_scope.
Notation "p ⁻¹" := (hom_inverse p) : homotopy_scope.
Notation "p · q" := (hom_concat p q) : homotopy_scope.

(* Lemma 2.4.3 *)
Definition hom_natural {A B : 𝓤} {f g : A → B} (H:f ~ g) `(p: x = y :> A) :
  H x · ap g p = ap f p · H y.
Proof. destruct p. simpl. exact (concat_p1 _ · (concat_1p _)⁻¹). Defined.

(* Corollary 2.4.4 *)
Definition hom_id_natural `{f:A → A} (H:f ~ id) (x:A) :
  H (f x) = ap f (H x).
Proof.
  apply cancelR with (H x).
  exact ((H (f x) ·ₗ (ap_id _)⁻¹) · hom_natural H (H x)).
Defined.

Definition hom_compose {A B C:𝓤} {f g : A → B} {h k : B → C} : h ~ k → f ~ g → h ∘ f ~ k ∘ g
  := λ β α x, β _ · ap k (α _).
Notation "β ∗ α" := (hom_compose β α) : homotopy_scope.

Definition hom_compose_alt {A B C:𝓤} {f g : A → B} {h k : B → C} : h ~ k → f ~ g → h ∘ f ~ k ∘ g
  := λ β α x, ap h (α _) · β _.

Local Open Scope homotopy_scope.

Definition hom_compose_natural {A B C:𝓤} {f g : A → B} {h k : B → C} (β:h ~ k) (α:f ~ g)
  : β ∗ α ~ hom_compose_alt β α
  := λ x, hom_natural β (α x).

Definition hom_whiskerR {A B C : 𝓤} {g h : B → C} (β : g ~ h) (f : A → B)
  : g ∘ f ~ h ∘ f := β ∗ 1.
Notation "β ∘ᵣ f" := (hom_whiskerR β f) : homotopy_scope.

Definition hom_whiskerL {A B C : 𝓤} (h : B → C) {f g : A → B} (α : f ~ g)
  : h ∘ f ~ h ∘ g := 1 ∗ α.
Notation "h ∘ₗ α" := (hom_whiskerL h α) : homotopy_scope.

Definition qinv `(f:A → B) := Σ (g:B → A), (f ∘ g ~ id) × (g ∘ f ~ id).

Definition qinv_fun {A B} {f:A → B} : qinv f → B → A := pr₁.
Coercion qinv_fun : qinv >-> Funclass.

Definition qinv_id A : qinv (@id A) := (id; ((λ x, refl), (λ x, refl))).

Definition qinv_inverse `{f:A → B} (g:qinv f) : qinv g.
Proof. destruct g as [g[α β]]. exact (f;(β,α)). Defined.

Definition qinv_compose {A B C} {h:B → C} {f:A → B} : qinv f → qinv h → qinv (h ∘ f).
Proof. intros [g[α β]] [k[γ δ]]. exists (g ∘ k). split.
+ exact ((h ∘ₗ α ∘ᵣ k) · γ).
+ exact ((g ∘ₗ δ ∘ᵣ f) · β).
Defined.

Local Close Scope homotopy_scope.

Definition linv `(f:A → B) := Σ (g:B → A), g ∘ f ~ id.
Definition rinv `(f:A → B) := Σ (g:B → A), f ∘ g ~ id.
Definition biinv `(f:A → B) := linv f × rinv f.

Definition ishae `(f:A → B) := Σ (g:B → A) (η:g ∘ f ~ id) (ε:f ∘ g ~ id), Π x, ap f (η x) = ε (f x).

Definition ishae_to_qinv `{f:A → B} (e:ishae f) : qinv f
  := match e with (g;(η;(ε;_))) => (g;(ε, η)) end.
Coercion ishae_to_qinv : ishae >-> qinv.

(* Lemma 4.2.2 *)
Definition half_adjoint_implies_full {A B} (f:A → B) (g:B → A) (η:g ∘ f ~ id) (ε:f ∘ g ~ id)
  (τ:Π x, ap f (η x) = ε (f x)) : Π y, ap g (ε y) = η (g y).
Proof. intro y.
  apply (cancelL (ap (g ∘ f ∘ g) (ε y))).
  refine (_ · hom_natural η (ap g (ε y)) · (ap_compose g (g ∘ f) (ε y) ·ᵣ _)⁻¹).
  refine ((ap_compose (f ∘ g) g _ ·ᵣ _) · _⁻¹).
  refine (_ · (ap_pp g _ _)⁻¹ · ap (ap g) ((τ (g y) ·ᵣ _) · hom_natural ε (ε y)) · ap_pp g _ _).
  refine ((hom_id_natural η (g y) · ap_compose _ _ _ ·ᵣ _) · (_ ·ₗ _)).
  refine (ap_id _ · ap (ap g) (ap_id _)⁻¹).
Defined.

(* Theorem 4.2.3 *)
Definition qinv_to_ishae `{f:A → B} : qinv f → ishae f.
Proof.
  intros [g[ε η]]. exists g. exists η.
  exists (λ b, (ε (f (g b)))⁻¹ · (ap f (η (g b)) · ε b)).
  intros a.
  refine ((concat_V_pp _ _)⁻¹ · ap _ _).
  refine ( (_ ·ₗ (ap_id _)⁻¹) · hom_natural ε (ap f (η a)) · (_ ·ᵣ _)).
  refine (ap_compose _ _ _ · ap (ap f) _⁻¹).
  refine (hom_id_natural η a · ap_compose _ _ _).
Defined.
Coercion qinv_to_ishae : qinv >-> ishae.

Definition ishae_compose {A B C} {h:B → C} {f:A → B} : ishae f → ishae h → ishae (h ∘ f).
Proof. intros [g[β[α τ]]] [k[δ[γ ν]]]. exists (g ∘ k).
  exists ((g ∘ₗ δ ∘ᵣ f) · β)%hom.
  exists ((h ∘ₗ α ∘ᵣ k) · γ)%hom.
  intro x.
  unfold hom_whiskerL, hom_whiskerR, hom_compose, hom_refl, hom_concat, id. simpl.
  refine (_ · ((concat_p1 _ · concat_1p _)⁻¹ ·ᵣ _) · (_ ·ₗ ν _))%path.
  refine (ap_compose _ _ _ · ap (ap h) _ · ap_pp h _ _).
  refine (ap_pp f _ _ · (_ ·ₗ τ _) · _).
  refine ((ap (ap f) (concat_p1 _ · concat_1p _) ·ᵣ _) · _⁻¹).
  exact ((_ ·ₗ (ap_id _)⁻¹) · hom_natural α (δ (f x)) · (ap_compose _ _ _ ·ᵣ _)).
Defined.

Definition isequiv `(f:A → B) := ishae f.
Existing Class isequiv.
Identity Coercion Id_isequiv_to_ishae : isequiv >-> ishae.

Definition qinv_to_isequiv `{f:A → B} (g:qinv f) : isequiv f := (g:ishae f).
Coercion qinv_to_isequiv : qinv >-> isequiv.
Hint Extern 10 (isequiv ?f) => match goal with g : qinv f |- _ => eexact (qinv_to_isequiv g) end : typeclass_instances.

Definition qinv_to_biinv `{f:A → B} (g:qinv f) : biinv f.
Proof. destruct g as [g[α β]]. exact ((g;β),(g;α)). Defined.
Coercion qinv_to_biinv : qinv >-> biinv.

Local Open Scope homotopy_scope.

Definition biinv_to_qinv `{f:A → B} (e:biinv f) : qinv f.
Proof. destruct e as [[h β][g α]].
  pose proof (β ∘ᵣ g)⁻¹ · (h ∘ₗ α) : g ~ h as γ.
  pose proof (γ ∘ᵣ f) · β : g ∘ f ~ id as β'.
  exact (g;(α,β')).
Defined.
Coercion biinv_to_qinv : biinv >-> qinv.

Local Close Scope homotopy_scope.
Local Close Scope path_scope.

Definition id_isequiv A : isequiv (@id A) := (id;(1;(1;1)))%hom.
Hint Extern 2 (isequiv (@id ?A)) => eexact (id_isequiv A) : typeclass_instances.

Instance inverse_from_isequiv `(f:A → B) {e:isequiv f} : InverseFunction f := e.1.
Definition isequiv_inverse {A B} (f:A → B) {e:isequiv f} : isequiv f⁻¹ .
Proof. destruct e as [g[η[ε τ]]]. change (isequiv g).
  exists f. exists ε. exists η.
  exact (half_adjoint_implies_full f g η ε τ).
Defined.
Hint Extern 2 (isequiv (@inv_fun _ _ _ (inverse_from_isequiv _))) => eapply @isequiv_inverse : typeclass_instances.

Definition isequiv_compose {A B C} (f:A → B) (g:B → C) : isequiv f → isequiv g → isequiv (g ∘ f)
:= ishae_compose.
Hint Extern 2 (isequiv (_ ∘ _)) => eapply @isequiv_compose : typeclass_instances.

Definition equiv_linv_hom `(f:A → B) {e:isequiv f} : f⁻¹ ∘ f ~ id := e.2.1 .
Definition equiv_rinv_hom `(f:A → B) {e:isequiv f} : f ∘ f⁻¹ ~ id := e.2.2.1 .

Definition Equiv (A B : 𝓤) := sig (@isequiv A B).
Notation "A ≃ B" := (Equiv A B) (at level 75, no associativity) : type_scope.
Delimit Scope equiv_scope with equiv.
Bind Scope equiv_scope with Equiv.

Definition Equiv_fun {A B} : A ≃ B → A → B := pr₁.
Coercion Equiv_fun : Equiv >-> Funclass.
Hint Extern 0 (isequiv (Equiv_fun ?f)) => eexact (f.2) : typeclass_instances.

Definition eqv `(f:A → B) {e:isequiv f} : A ≃ B := (f; e).

Definition Equiv_from_qinv `(f:A → B) (g:qinv f) : A ≃ B := (f; _).

Definition Equiv_from_qinv_alt `(f:A → B) (g:B → A) (α: f ∘ g ~ id) (β: g ∘ f ~ id)
  : A ≃ B := Equiv_from_qinv f (g;(α,β)).

(* Lemma 2.4.12 *)
Section Equiv_is_an_equivalence.
  Definition equiv_id A : A ≃ A := (id; _).
  Definition equiv_inverse {A B} : A ≃ B → B ≃ A := λ f, (f⁻¹; _).
  Definition equiv_concat {A B C} : A ≃ B → B ≃ C → A ≃ C := λ f g, (g ∘ f; _).
End Equiv_is_an_equivalence.

Notation "1" := (equiv_id _) : equiv_scope.
Notation "p ⁻¹" := (equiv_inverse p) : equiv_scope.
Notation "p · q" := (equiv_concat p q) : equiv_scope.

Local Open Scope equiv_scope.

Definition equiv_concat2 {A B C} {f g:A ≃ B} {h k:B ≃ C} : f = g → h = k → f · h = g · k
:= λ p q, ap2 equiv_concat p q.
Notation "p ∗ q" := (equiv_concat2 p q) : equiv_scope.

Definition equiv_whiskerL {A B C} (f : A ≃ B) {h k : B ≃ C} (p: h = k) : f · h = f · k
:= (refl f ∗ p)%equiv.
Notation "f ·ₗ p" := (equiv_whiskerL f p) : equiv_scope.

Definition equiv_whiskerR {A B C} {f g : A ≃ B} (p: f = g) (h : B ≃ C) : f · h = g · h
:= (p ∗ refl h)%equiv.
Notation "p ·ᵣ h" := (equiv_whiskerR p h) : equiv_scope.

Local Close Scope equiv_scope.

Local Open Scope path_scope.

Definition path_precomp_isequiv `(p:x = y :> A) z : isequiv (λ (q:y = z), p · q) .
Proof.
  apply qinv_to_isequiv. exists (p⁻¹ ·).
  split; intros q; [ exact (concat_p_Vp _ _) | exact (concat_V_pp _ _) ].
Defined.
Hint Extern 2 (isequiv (_ ·)) => eapply @path_precomp_isequiv : typeclass_instances.

Definition path_postcomp_isequiv `(q:y = z :> A) x : isequiv (λ (p:x = y), p · q) .
Proof.
  apply qinv_to_isequiv. exists (· q⁻¹).
  split; intros p; [ exact (concat_pV_p _ _) | exact (concat_pp_V _ _) ].
Defined.
Hint Extern 2 (isequiv (· _)) => eapply @path_postcomp_isequiv : typeclass_instances.

Definition transport_isequiv `(B:A → 𝓤) `(p:x = y :> A) : isequiv (transport B p).
Proof.
  apply qinv_to_isequiv. exists (transport B p⁻¹).
  split; intros z; [ exact (transport_pV _ _ _) | exact (transport_Vp _ _ _) ].
Defined.
Hint Extern 2 (isequiv (transport _ _)) => eapply @transport_isequiv : typeclass_instances.

(* Section 2.6: Cartesian product types *)
Definition pair_eq_intro {A B} (x y : A × B) : (π₁ x = π₁ y) × (π₂ x = π₂ y) → x = y.
Proof. destruct x as [a b], y as [a' b']. simpl. intros [[] []]. exact refl. Defined.
Notation "pair⁼" := (pair_eq_intro _ _) : path_scope.

Definition pair_unique {A B} (x : A × B) : x = (π₁ x, π₂ x)
  := pair_eq_intro x (π₁ x, π₂ x) (refl, refl).

Definition pair_eq_compute {A B} {x y : A × B} :
  (λ r, (ap π₁ r, ap π₂ r)) ∘ pair_eq_intro x y ~ id.
Proof. destruct x as [a b], y as [a' b']. intros [p q]. simpl in p,q. destruct p,q. exact refl. Defined.

Definition pair_eq_compute1 {A B} {x y : A × B} (p:π₁ x = π₁ y) q
  : ap π₁ (pair⁼ (p,q)) = p
:= ap π₁ (pair_eq_compute (p,q)).

Definition pair_eq_compute2 {A B} {x y : A × B} (p:π₁ x = π₁ y) q
  : ap π₂ (pair⁼ (p,q)) = q
:= ap π₂ (pair_eq_compute (p,q)).

Definition pair_eq_unique {A B} {x y : A × B} (r: x = y) :
  r = pair⁼ (ap π₁ r, ap π₂ r).
Proof. destruct r, x as [a b]. exact refl. Defined.

(* Theorem 2.6.2 *)
Definition pair_eq_equiv {A B} (x y : A × B) : x = y ≃ (π₁ x = π₁ y) × (π₂ x = π₂ y)
:= (Equiv_from_qinv (λ r, (ap π₁ r, ap π₂ r)) (pair⁼; (pair_eq_compute, pair_eq_unique⁻¹)%hom)).

Definition pair_eq_inverse {A B} {x y : A × B} (p:π₁ x = π₁ y) q
  : (pair⁼ (p,q))⁻¹ = pair⁼ (p⁻¹,q⁻¹).
Proof. destruct x as [a b], y as [a' b']. simpl in p,q. destruct p,q. exact refl. Defined.

Definition pair_eq_concat {A B} {x y z: A × B} (p:π₁ x = π₁ y) q (p':π₁ y = π₁ z) q'
  : pair⁼ (p,q) · pair⁼ (p',q') = pair⁼ (p · p', q · q').
Proof. destruct x as [a b], y as [a' b'], z as [a'' b''].
  simpl in p,q,p',q'. destruct p,q,p',q'. exact refl.
Defined.

(* Theorem 2.6.4 *)
Definition pair_transport {Z} (A B: Z → 𝓤) {z w} (p:z = w :> Z) (x:A z × B z)
  : transport (λ z, A z × B z) p x = (transport A p (π₁ x), transport B p (π₂ x)).
Proof. destruct p. simpl. exact (pair_unique x). Defined.

(* Theorem 2.6.5 *)
Section pair_ap.
  Context {A B A' B' : 𝓤} (g:A → A') (h:B → B').
  Let f z := (g (π₁ z), h (π₂ z)).

  Definition pair_ap {x y : A × B} (p:π₁ x = π₁ y) (q:π₂ x = π₂ y)
  : ap f (pair⁼ (p,q)) = pair_eq_intro (f x) (f y) (ap g p, ap h q).
  Proof. destruct x as [a b], y as [a' b']. simpl in p,q. destruct p,q. exact refl. Defined.
End pair_ap.

(* Section 2.7: Σ-types *)
Definition sig_apd
 `{P: A → 𝓤} `{f:sig P → B} `{Q:B → Type} (g:Π x:sig P, Q (f x))
  {x y : sig P} (p:x = y)
  : ap f p # g x = g y
:= (transport_compose Q f p (g x))⁻¹ · apd g p.

Definition sig_eq_elim `{B: A → 𝓤} {x y : sig B}
  : x = y → Σ (p:pr₁ x = pr₁ y), p # pr₂ x = pr₂ y
:= λ p, (ap pr₁ p; sig_apd pr₂ p).

Definition sig_eq_intro `{B: A → 𝓤} (x y : sig B)
  :  (Σ (p:pr₁ x = pr₁ y), p # pr₂ x = pr₂ y) → x = y.
Proof. destruct x as [a b], y as [a' b']; simpl.
  intros [p q]. destruct p. simpl in q. destruct q. exact refl.
Defined.
Arguments sig_eq_intro : simpl nomatch.
Notation "sig⁼" := (sig_eq_intro _ _) : path_scope.

(* Corollary 2.7.3 *)
Definition sig_unique `{B: A → 𝓤} (x : sig B) : x = (pr₁ x; pr₂ x)
:= sig_eq_intro x (pr₁ x; pr₂ x) (refl; refl).

Definition sig_eq_compute `{B: A → 𝓤} {x y : sig B} :
  sig_eq_elim (x:=x) (y:=y) ∘ sig⁼ ~ id.
Proof. destruct x as [a b], y as [a' b']. intros [p q]. simpl in p,q.
  destruct p. simpl in q. destruct q. exact refl.
Defined.

Definition sig_eq_compute1 `{B: A → 𝓤} {x y : sig B} (p:pr₁ x = pr₁ y) q
  : ap pr₁ (sig⁼ (p;q)) = p
:= ap pr₁ (sig_eq_compute (p;q)).

Definition sig_eq_unique `{B: A → 𝓤} {x y : sig B} (r: x = y) :
  r = sig⁼ (ap pr₁ r; sig_apd pr₂ r).
Proof. destruct r, x as [a b]. exact refl. Defined.

(* Theorem 2.7.2 *)
Definition sig_eq_equiv `{B: A → Type} (x y : sig B)  : x = y ≃ Σ (p:pr₁ x = pr₁ y), p # pr₂ x = pr₂ y
:= (Equiv_from_qinv sig_eq_elim (sig⁼; (sig_eq_compute, sig_eq_unique⁻¹)%hom)).

Section sig_transport.
  Context `{P: A → 𝓤} (Q: sig P → 𝓤).
  Let R x := Σ (u: P x), Q (x; u).

  Definition sig_transport `(p : x = y :> A) (u: P x) (z : Q (x; u))
  : transport R p (u; z) = (p # u; transport Q (lift u p) z).
  Proof. destruct p. exact refl. Defined.
End sig_transport.

Definition apd2 `(f:A → B) `{P: A → 𝓤} `{Q:B → 𝓤} (g:Π (x:A), P x → Q (f x))
  `(p:x = y) {u:P x} {v: P y} (q:p # u = v) : ap f p # g x u = g y v
:= (transport_compose Q f p (g x u))⁻¹ · transport_fun_family P (Q ∘ f) g p u · ap (g y) q.

Section ap_sig_eq.
  Context `(f:A → B) `{P: A → 𝓤} `{Q:B → 𝓤} (g:Π (x:A), P x → Q (f x)).
  Let h z : sig Q := (f z.1; g z.1 z.2).

  Definition ap_sig_eq {x y : sig P} (p:x.1 = y.1) (q:p # x.2 = y.2) :
    ap h (sig⁼(p; q)) = sig_eq_intro (h x) (h y) (ap f p; apd2 f g p q).
  Proof. destruct x as [a u], y as [b v].
    simpl in p. destruct p.
    simpl in q. destruct q.
    exact refl.
  Defined.
End ap_sig_eq.

(* Section 2.8: The unity type *)

Definition unit_eq_intro {x y : 𝟏} : x = y.
Proof. destruct x,y. exact refl. Defined.
Notation "unit⁼" := unit_eq_intro : path_scope.

Definition unit_unique x : x = ★ := unit⁼.

Definition unit_eq_unique {x y : 𝟏} (p:x = y) : p = unit⁼.
Proof. destruct p, x. exact refl. Defined.

(* Theorem 2.8.1 *)
Definition unit_eq_equiv (x y : 𝟏) : x = y ≃ 𝟏
:= (Equiv_from_qinv_alt (λ _, ★) (λ _, unit⁼) (λ _, unit⁼) unit_eq_unique⁻¹)%hom.

(* Section 2.9: Π-types and the function extensionality axiom *)
Definition happly `{P:A → 𝓤} {f g : Π x, P x} (p:f = g) : f ~ g
:= match p with refl => hom_refl _ end.
Arguments happly : simpl nomatch.

Class StrongFunext := strong_funext : Π `{P:A → 𝓤} (f g : Π x, P x), isequiv (happly (f:=f) (g:=g)).
Hint Extern 2 (isequiv happly) => eapply @strong_funext : typeclass_instances.

Section StrongFunext_props.
  Context {SF:StrongFunext} `{P:A → 𝓤}.

  Definition funext_equiv (f g : Π x, P x) : (f = g) ≃ (f ~ g) := (happly; _).

  Context {f g : Π x, P x}.

  Definition funext (H:f ~ g) : f = g := (inv_fun happly) H.
  Definition funext_compute (H:f ~ g) : happly (funext H) = H := equiv_rinv_hom happly H.
  Definition funext_unique (p:f = g) : p = funext (happly p) := (equiv_linv_hom happly p)⁻¹.
End StrongFunext_props.

Class Funext := weak_funext : Π `{P:A → 𝓤} {f g : Π x, P x}, f ~ g → f = g.

Instance StrongFunext_from_weak : Funext → StrongFunext.
Proof. intros WF A P f g. apply qinv_to_isequiv.
  exists (λ H, (weak_funext 1%hom)⁻¹ · weak_funext H). split.
+ intro H. pose (H' := λ x, (g x; H x)).
  change g with (λ x, (H' x).1).
  change H with (λ x, (H' x).2).
  clearbody H'. clear H g.
  assert ((λ x, (f x; 1)) = H') as [].
  * apply WF. intro x. destruct (H' x) as [_ []]. exact refl.
  * exact (ap happly (concat_Vp (weak_funext (hom_refl f)))).
+ intros []. exact (concat_Vp _).
Defined.

Definition funext_id `{!StrongFunext} `{P:A → 𝓤} (f : Π x, P x) : funext 1%hom = refl f
  := (funext_unique 1)⁻¹.

Definition funext_concat {SF:StrongFunext} `{P:A → 𝓤} {f g h: Π x, P x} (G:f ~ g) (H:g ~ h)
   : funext (G · H) = funext G · funext H.
Proof.
  refine ((ap funext (ap2 hom_concat (funext_compute G) (funext_compute H)))⁻¹ · _).
  set (p := funext G). set (q := funext H). clearbody p q. destruct p, q. exact (funext_id f).
Defined.

Definition funext_inverse {SF:StrongFunext} `{P:A → 𝓤} {f g: Π x, P x} (H:f ~ g)
   : funext H⁻¹ = (funext H)⁻¹.
Proof.
  refine (ap (λ x, funext x⁻¹) (funext_compute H)⁻¹ · _).
  set (p := funext H). clearbody p. destruct p. exact (funext_id f).
Defined.

(* Section 2.10: Universes and the univalence axiom *)

Definition transport_id_isequiv {A B: Type} (p:A = B) : isequiv (transport id p)
  := match p with refl => _ : isequiv id end.
Arguments transport_id_isequiv : simpl nomatch.
Hint Extern 2 (isequiv (transport (@id Type) ?p)) => eexact (transport_id_isequiv p) : typeclass_instances.

(* Lemma 2.10.1 *)
Definition idtoeqv {A B:Type} (p:A = B) : A ≃ B := (transport id p; _).

Class Univalence := idtoeqv_isequiv : Π A B, isequiv (idtoeqv (A:=A) (B:=B)).
Hint Extern 2 (isequiv idtoeqv) => eapply @idtoeqv_isequiv : typeclass_instances.

Section Univalence_props.
  Context {U:Univalence}.

  Definition univalence A B : (A = B) ≃ (A ≃ B) := (idtoeqv; _).

  Context {A B : 𝓤}.

  Definition ua : A ≃ B → A = B := inv_fun idtoeqv.
  Definition ua_compute (f:A ≃ B) : idtoeqv (ua f) = f := equiv_rinv_hom idtoeqv f.
  Definition ua_unique (p:A = B) : p = ua (idtoeqv p) := (equiv_linv_hom idtoeqv p)⁻¹.
End Univalence_props.

Definition ua_id `{!Univalence} (A:𝓤) : ua 1%equiv = refl A
  := (ua_unique (refl A))⁻¹.

Definition ua_concat `{!Univalence} {A B C: 𝓤} (f:A ≃ B) (g:B ≃ C) : ua (f · g) = ua f · ua g.
Proof.
  refine ((ap ua (ua_compute f ∗ ua_compute g)%equiv)⁻¹ · _).
  set (p := ua f). set (q := ua g). clearbody p q. clear f g.
  destruct p, q. exact (ua_id _).
Defined.

Definition ua_inverse `{!Univalence} {A B: 𝓤} (f:A ≃ B) : ua f⁻¹ = (ua f)⁻¹.
Proof.
  refine ((ap (λ h, ua h⁻¹) (ua_compute f))⁻¹ · _).
  set (p := ua f). clearbody p. clear f. destruct p. exact (ua_id _).
Defined.

(* Lemma 2.10.5 *)
Definition transport_to_idtoeqv `{B: A → 𝓤} `(p:x = y :> A) (u:B x) :
  transport B p u = idtoeqv (ap B p) u
:= transport_compose id B p u.

(* Section 2.11: Identity type *)

Definition hom_inv_natural `{f:A → B} {g:B → A} (H: g ∘ f ~ id) `(p:x = y :> A)
  : H x · p = ap g (ap f p) · H y
:= (_ ·ₗ (ap_id _)⁻¹) · hom_natural H p · (ap_compose _ _ _ ·ᵣ _).

(* Theorem 2.11.1 *)
Definition ap_isequiv `(f:A → B) {e:isequiv f} (a a':A) : isequiv (ap f (a:=a) (b:=a')).
Proof.
  destruct (e : qinv f) as [g[α β]]; clear e.
  apply qinv_to_isequiv. exists (λ (p:f a = f a'), (β _)⁻¹ · ap g p · β _).
  split; unfold compose, id; intros p.
+ refine ((concat_V_pp (α _) _)⁻¹ · (_ ·ₗ _) · _).
  refine (hom_inv_natural α (ap f _) · (ap (ap f) _ ·ᵣ _)).
  refine ((ap_compose f g _)⁻¹ · _).
  refine ((concat_pp_V _ (β _))⁻¹ · _).
  refine ( ((hom_natural β _)⁻¹ · (_ ·ₗ ap_id _)) ·ᵣ _ · _) .
  refine (_ ·ᵣ _ · _).
  refine (concat_p_pp _ _ _ · (_ ·ᵣ _)).
  refine (concat_p_pp _ _ _ · (concat_pV _ ·ᵣ _)).
  refine (concat_pp_p _ _ _ · (concat_1p _ ∗ concat_pV _)).
  refine (_ ·ₗ _ · _).
  refine (ap (ap f) (concat_p1 _) ·ᵣ _ · (hom_inv_natural α p)⁻¹).
  exact (concat_V_pp _ _).
+ exact (concat_pp_p _ _ _ · (_ ·ₗ (hom_inv_natural β p)⁻¹) · concat_V_pp _ _).
Defined.
Hint Extern 2 (isequiv (ap _)) => eapply @ap_isequiv : typeclass_instances.

Definition concat_1p1 `(p:a = b :> A) : 1 · p · 1 = p
:= concat_p1 _ · concat_1p _.

(* Lemma 2.11.2 *)
Definition transport_Id_ax `(a:A) `(p:x₁ = x₂) (q:a = x₁) : transport (λ x, a = x) p q = q · p.
Proof. destruct p. exact (concat_p1 _)⁻¹. Defined.

Definition transport_Id_xa `(a:A) `(p:x₁ = x₂) (q:x₁ = a) : transport (λ x, x = a) p q = p⁻¹ · q.
Proof. destruct p. exact (concat_1p _)⁻¹. Defined.

Definition transport_Id_xx `(p:x₁ = x₂ :> A) (q:x₁ = x₁) : transport (λ x, x = x) p q = p⁻¹ · q · p.
Proof. destruct p. exact (concat_1p1 _)⁻¹. Defined.

(* Theorem 2.11.3 *)
Definition transport_Id {A B} (f g: A → B) `(p:a = a') (q:f a = g a)
  : transport (λ x, f x = g x) p q = (ap f p)⁻¹ · q · (ap g p).
Proof. destruct p. exact (concat_1p1 _)⁻¹. Defined.

(* Theorem 2.11.4 *)
Definition transport_Id_dep `{B:A → 𝓤} (f g: Π x, B x) `(p:a = a') (q:f a = g a)
  : transport (λ x, f x = g x) p q = (apd f p)⁻¹ · ap (transport B p) q · (apd g p).
Proof. destruct p. simpl. destruct q. exact refl. Defined.

(* Theorem 2.11.5 *)
Definition transport_Id_equiv `(p:a = a' :> A) (q:a = a) (r:a' = a')
  : (transport (λ x, x = x) p q = r) ≃ (q · p = p · r).
Proof. destruct p. exact (eqv (((concat_p1 _) ·) ∘ (· (concat_1p _)⁻¹))). Defined.

(* Section 2.12: Coproducts *)
Section coproducts.
  Context {A B:𝓤}.
  Section inl.
    Context (a₀:A).
    Let code (x : A + B) : 𝓤 := match x with inl a => a₀ = a | _ => 𝟎 end.
    Let encode (x : A + B) (p:inl a₀ = x) : code x := transport code p (refl a₀).
    Let decode (x : A + B) (c:code x) : inl a₀ = x.
    Proof. destruct x; [ exact (ap inl c) | destruct c]. Defined.

    Let β (x : A + B) : decode x ∘ encode x ~ id.
    Proof. intros []. exact refl. Defined.

    Let α (x : A + B) : encode x ∘ decode x ~ id.
    Proof. destruct x.
    + intros c.
      refine ((transport_compose code inl c _)⁻¹ · _).
      refine (transport_Id_ax _ _ _ · _).
      exact (concat_1p _).
    + intros [].
    Defined.

    Definition coproduct_inl_equiv_code (x : A + B) : (inl a₀ = x) ≃ code x
      := Equiv_from_qinv_alt (encode x) (decode x) (α x) (β x).
  End inl.

  Section inr.
    Context (b₀:B).
    Let code (x : A + B) : Type := match x with inr b => b₀ = b | _ => 𝟎 end.
    Let encode (x : A + B) (p:inr b₀ = x) : code x := transport code p (refl b₀).
    Let decode (x : A + B) (c:code x) : inr b₀ = x.
    Proof. destruct x; [ destruct c | exact (ap inr c) ]. Defined.

    Let β (x : A + B) : decode x ∘ encode x ~ id.
    Proof. intros []. exact refl. Defined.

    Let α (x : A + B) : encode x ∘ decode x ~ id.
    Proof. destruct x.
    + intros [].
    + intros c.
      refine ((transport_compose code inr c _)⁻¹ · _).
      refine (transport_Id_ax _ _ _ · _).
      exact (concat_1p _).
    Defined.

    Definition coproduct_inr_equiv_code (x : A + B) : (inr b₀ = x) ≃ code x
      := Equiv_from_qinv_alt (encode x) (decode x) (α x) (β x).
  End inr.

  Definition coproduct_inl_equiv a₁ a₂ : (@inl A B a₁ = inl a₂) ≃ (a₁ = a₂)
  := coproduct_inl_equiv_code _ _.

  Definition coproduct_inr_equiv b₁ b₂ : (@inr A B b₁ = inr b₂) ≃ (b₁ = b₂)
  := coproduct_inr_equiv_code _ _.

  Definition coproduct_inl_inr_equiv a b : (@inl A B a = inr b) ≃ 𝟎
  := coproduct_inl_equiv_code _ _.
  Definition coproduct_inr_inl_equiv b a : (@inr A B b = inl a) ≃ 𝟎
  := coproduct_inr_equiv_code _ _.

  Definition inl_eq_intro {a₁ a₂} : (a₁ = a₂) → (inl a₁ = inl a₂) := (coproduct_inl_equiv _ _)⁻¹.
  Definition inr_eq_intro {b₁ b₂} : (b₁ = b₂) → (inr b₁ = inr b₂) := (coproduct_inr_equiv _ _)⁻¹.
End coproducts.
Notation "inl⁼" := inl_eq_intro.
Notation "inr⁼" := inr_eq_intro.

Section sum_ap.
  Context {A B A' B' : 𝓤} (g:A → A') (h:B → B').
  Let f (z:A + B) := match z with
  | inl a => inl (g a)
  | inr b => inr (h b)
  end.

  Definition inl_ap `(p: x = y :> A) : ap f (inl⁼ p) = inl⁼ (ap g p)
  := match p with refl => refl end.

  Definition inr_ap `(q: x = y :> B) : ap f (inr⁼ q) = inr⁼ (ap h q)
  := match q with refl => refl end.
End sum_ap.

Local Open Scope bool_scope.

Definition bool_equiv_coproduct : 𝟐 ≃ 𝟏 + 𝟏.
Proof. apply (Equiv_from_qinv_alt
                (λ b, match b with 0 => inl ★ | 1 => inr ★ end)
                (λ x, match x with inl _ => 0 | inr _ => 1 end) ).
+ intros [[]|[]]; exact refl.
+ intros [|]; exact refl.
Defined.

Definition bool_0_eq_0_equiv : 0 = 0 ≃ 𝟏 :=
  (eqv (A:= 0 = 0) (ap bool_equiv_coproduct) · coproduct_inl_equiv _ _ · unit_eq_equiv _ _)%equiv.
Definition bool_1_eq_1_equiv : 1 = 1 ≃ 𝟏 :=
  (eqv (A:= 1%bool = 1%bool) (ap bool_equiv_coproduct) · coproduct_inr_equiv _ _ · unit_eq_equiv _ _)%equiv.
Definition bool_0_ne_1 : 0 = 1 ≃ 𝟎 :=
  (eqv (A:= 0 = 1%bool) (ap bool_equiv_coproduct) · coproduct_inl_inr_equiv _ _)%equiv.
Definition bool_1_ne_0 : 1 = 0 ≃ 𝟎 :=
  (eqv (A:= 1%bool = 0) (ap bool_equiv_coproduct) · coproduct_inr_inl_equiv _ _)%equiv.

Local Close Scope bool_scope.

(* Section 2.13: Natural numbers *)
Local Open Scope nat_scope.
Section naturals.
  Let code : ℕ → ℕ → 𝓤₀ := fix F (a b:ℕ) := match a, b with
  | 0, 0 => 𝟏
  | succ m, 0 => 𝟎
  | 0, succ n => 𝟎
  | succ m, succ n => F m n
  end.
  Let r : Π a, code a a := fix F (a:ℕ) := match a with
  | 0 => ★
  | succ n => F n
  end.

  Let encode m n (p:m = n) : code m n := transport (code m) p (r m).

  Let decode : Π m n, (code m n) → m = n := fix F (a b:ℕ) := match a, b with
  | 0, 0 => λ c, refl
  | succ m, 0 => λ c, match c with end
  | 0, succ n => λ c, match c with end
  | succ m, succ n => λ c, ap succ (F m n c)
  end.

  Let β (m n : ℕ) : decode m n ∘ encode m n ~ id.
  Proof. intros []. change (decode m m (r m) = refl). induction m.
  + exact refl.
  + exact (ap (ap succ) IHm · ap_1 _ _).
  Defined.

  Let α : Π m n, encode m n ∘ decode m n ~ id.
  Proof. refine (fix F (a b:ℕ) := match a, b with
  | 0, 0 => _
  | succ m, 0 => λ c, match c with end
  | 0, succ n => λ c, match c with end
  | succ m, succ n => λ c, _
  end).
  + intros []. exact refl.
  + unfold compose, id; simpl. unfold encode.
    refine ((transport_compose (code (succ m)) succ _ _)⁻¹ · _).
    change (transport (code m) (decode m n c) (r m) = c).
    change (encode m n (decode m n c) = c).
    exact (F m n c).
  Defined.

  Definition nat_eq_equiv_code m n : (m = n) ≃ code m n
  := Equiv_from_qinv_alt (encode m n) (decode m n) (α m n) (β m n).
End naturals.
Definition nat_eq_equiv_S0 m : (succ m = 0) ≃ 𝟎  := nat_eq_equiv_code _ _.
Definition nat_eq_equiv_0S m : (0 = succ m) ≃ 𝟎  := nat_eq_equiv_code _ _.
Definition nat_eq_equiv_SS m n : (succ m = succ n) ≃ (m = n)
:= (nat_eq_equiv_code (succ m) (succ n) · (nat_eq_equiv_code m n)⁻¹)%equiv.
Definition nat_discrete : Π (n:ℕ), (n = n) ≃ 𝟏 := fix F (a:ℕ) := match a with
| 0 => nat_eq_equiv_code 0 0
| succ n => (nat_eq_equiv_SS n n · F n)%equiv
end.
Definition nat_decidable : Π m n : ℕ, ((m = n) ≃ 𝟏) + ((m = n) ≃ 𝟎)
:= fix F (a:ℕ) := match a with
| 0 => λ b, match b with
       | 0 => inl (nat_discrete 0)
       | succ m => inr (nat_eq_equiv_0S _)
       end
| succ n => λ b, match b with
       | 0 => inr (nat_eq_equiv_S0 _)
       | succ m => match F n m with
                   | inl E => inl (nat_eq_equiv_SS _ _ · E)%equiv
                   | inr E => inr (nat_eq_equiv_SS _ _ · E)%equiv
                   end
       end
end.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Inductive matrix
  (a:Type) :=
  | mk_matrix : Z -> Z -> (map.Map.map Z (map.Map.map Z a)) -> matrix a.
Axiom matrix_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (matrix a).
Existing Instance matrix_WhyType.
Implicit Arguments mk_matrix [[a]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(matrix a)): (map.Map.map Z
  (map.Map.map Z a)) := match v with
  | (mk_matrix x x1 x2) => x2
  end.

(* Why3 assumption *)
Definition columns {a:Type} {a_WT:WhyType a} (v:(matrix a)): Z :=
  match v with
  | (mk_matrix x x1 x2) => x1
  end.

(* Why3 assumption *)
Definition rows {a:Type} {a_WT:WhyType a} (v:(matrix a)): Z :=
  match v with
  | (mk_matrix x x1 x2) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(matrix a)) (r:Z) (c:Z): a :=
  (map.Map.get (map.Map.get (elts a1) r) c).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(matrix a)) (r:Z) (c:Z)
  (v:a): (matrix a) := (mk_matrix (rows a1) (columns a1)
  (map.Map.set (elts a1) r (map.Map.set (map.Map.get (elts a1) r) c v))).

(* Why3 assumption *)
Definition valid_index {a:Type} {a_WT:WhyType a} (a1:(matrix a)) (r:Z)
  (c:Z): Prop := ((0%Z <= r)%Z /\ (r < (rows a1))%Z) /\ ((0%Z <= c)%Z /\
  (c < (columns a1))%Z).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (r:Z) (c:Z) (v:a): (matrix a) :=
  (mk_matrix r c (map.Map.const (map.Map.const v: (map.Map.map Z
  a)): (map.Map.map Z (map.Map.map Z a)))).

(* Why3 assumption *)
Inductive path: (matrix bool) -> Z -> Z -> Z -> Prop :=
  | Path_empty : forall (m:(matrix bool)) (i:Z) (j:Z) (k:Z), ((get m i
      j) = true) -> (path m i j k)
  | Path_cons : forall (m:(matrix bool)) (i:Z) (x:Z) (j:Z) (k:Z),
      ((0%Z <= x)%Z /\ (x < k)%Z) -> ((path m i x k) -> ((path m x j k) ->
      (path m i j k))).

(* Why3 goal *)
Theorem weakening : forall (m:(matrix bool)) (i:Z) (j:Z) (k1:Z) (k2:Z),
  ((0%Z <= k1)%Z /\ (k1 <= k2)%Z) -> ((path m i j k1) -> (path m i j k2)).
(* Why3 intros m i j k1 k2 (h1,h2) h3. *)
intros m i j k1 k2 (h1,h2) h3.
induction h3.
apply Path_empty; auto.
apply Path_cons with x; auto.
omega.
Qed.


(** This file gives some equational properties for manipulating matches.
 **)

Set Implicit Arguments.
Set Strict Implicit.

(** For backwards compatibility with hint locality attributes. *)
Set Warnings "-unsupported-attributes".

Create HintDb eq_rw discriminated.

Lemma eq_sym_eq
: forall T (a b : T) (pf : a = b) (F : T -> Type) val,
    match eq_sym pf in _ = x return F x with
      | eq_refl => val
    end =
    match pf in _ = x return F x -> F a with
      | eq_refl => fun x => x
    end val.
Proof.
  destruct pf. reflexivity.
Defined.

Lemma match_eq_sym_eq
: forall T (a b : T) (pf : a = b) F X,
    match pf in _ = t return F t with
      | eq_refl => match eq_sym pf in _ = t return F t with
                     | eq_refl => X
                   end
    end = X.
Proof.
  destruct pf. reflexivity.
Defined.
#[global]
Hint Rewrite match_eq_sym_eq : eq_rw.

Lemma match_eq_sym_eq'
: forall T (a b : T) (pf : a = b) F X,
    match eq_sym pf in _ = t return F t with
      | eq_refl => match pf in _ = t return F t with
                     | eq_refl => X
                   end
    end = X.
Proof.
  destruct pf. reflexivity.
Defined.
#[global]
Hint Rewrite match_eq_sym_eq' : eq_rw.

Lemma match_eq_match_eq
: forall T F (a b : T) (pf : a = b) X Y,
    X = Y ->
    match pf in _ = T return F T with
      | eq_refl => X
    end =
    match pf in _ = T return F T with
      | eq_refl => Y
    end.
Proof.
  intros. subst. auto.
Defined.

Lemma eq_sym_eq_trans
: forall T (a b c : T) (pf : a = b) (pf' : b = c),
    eq_sym (eq_trans pf pf') =
    eq_trans (eq_sym pf') (eq_sym pf).
Proof.
  clear. destruct pf. destruct pf'. reflexivity.
Defined.

(** Particular Instances **)
Lemma eq_Const_eq
: forall T (a b : T) (pf : a = b) (R : Type) val,
    match pf in _ = x return R with
      | eq_refl => val
    end = val.
Proof.
  destruct pf. reflexivity.
Defined.
#[global]
Hint Rewrite eq_Const_eq : eq_rw.

Lemma eq_Arr_eq
: forall T (a b : T) (pf : a = b) (F G : T -> Type) val x,
    match pf in _ = x return F x -> G x with
      | eq_refl => val
    end x =
    match pf in _ = x return G x with
      | eq_refl => val match eq_sym pf in _ = x return F x with
                         | eq_refl => x
                       end
    end.
Proof.
  destruct pf. reflexivity.
Defined.
#[global]
Hint Rewrite eq_Arr_eq : eq_rw.

Lemma eq_sym_eq_sym : forall (T : Type) (a b : T) (pf : a = b),
                        eq_sym (eq_sym pf) = pf.
Proof. destruct pf. reflexivity. Defined.
#[global]
Hint Rewrite eq_sym_eq_sym : eq_rw.

Ltac autorewrite_eq_rw :=
  repeat progress (autorewrite with eq_rw;
                   repeat match goal with
                            | |- context [ match ?X in @eq _ _ _ return _ -> _ with
                                             | eq_refl => _
                                           end ] => rewrite (eq_Arr_eq X)
                          end).

Require Export ExtLib.Data.Eq.UIP_trans.


(** Some utility functions and lemmas for QC. *)
Require Import Ceres.Ceres.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Set Warnings "-extraction-opaque-accessed,-extraction".

From ExtLib.Structures Require Export
     Functor Applicative Monads.

Require Import ExtLib.Data.Monads.StateMonad.

From Vellvm Require Import LLVMAst Util AstLib Syntax.CFG Semantics.TopLevel.
Require Import Integers Floats.

Require Import List.

Import ListNotations.
Import MonadNotation.
Import ApplicativeNotation.

From Coq Require Import
     ZArith List String Lia Bool.Bool.

Open Scope Z_scope.

Fixpoint max_nat_list (l : list nat) : nat :=
  match l with
  | [] => 0
  | x::rest => max x (max_nat_list rest)
  end.

(* TODO: how big should lists be? *)
Fixpoint sizeof_typ (t : typ) : nat :=
  match t with
  | TYPE_Pointer t            => S (sizeof_typ t)
  | TYPE_Array sz t           => S (sizeof_typ t)
  | TYPE_Function ret args    => max (sizeof_typ ret) (max_nat_list (map sizeof_typ args))
  | TYPE_Struct fields        => max_nat_list (map sizeof_typ fields)
  | TYPE_Packed_struct fields => max_nat_list (map sizeof_typ fields)
  | TYPE_Vector sz t          => S (sizeof_typ t)
  | _                         => 0
  end.

(* TODO: Move these *)
Fixpoint find_pred {A} (p : A -> bool) (l : list A) : option A
  := match l with
     | []   => None
     | x::xs =>
       if p x
       then Some x
       else find_pred p xs
     end.

Lemma list_sum_map :
  forall {X} (f : X -> nat) x xs,
    In x xs ->
    (list_sum (map f xs) >= f x)%nat.
Proof.
  induction xs; intros In; [contradiction|].
  destruct In; subst.
  - cbn. lia.
  - cbn. specialize (IHxs H).
    unfold list_sum in IHxs.
    lia.
Qed.


(** * 10 Data-Structural Bootstrapping *)

Require Import Div2 FunInd.

Require Import List.
Import ListNotations.

From CoqMTL Require Import Base.
From CoqMTL Require Import Control.Functor.
From CoqMTL Require Import Control.Monad.All.

From CoqAlgs Require Import Base.

(** ** 10.1 Structural Decomposition *)

(** *** 10.1.2 Binary Random-Access Lists Revisited *)

Inductive Seq (A : Type) : Type :=
    | Nil : Seq A
    | Zero : Seq (A * A) -> Seq A
    | One : A -> Seq (A * A) -> Seq A.

Arguments Nil  {A}.
Arguments Zero {A} _.
Arguments One  {A} _ _.

Definition empty {A : Type} : Seq A := Nil.

Definition isEmpty {A : Type} (s : Seq A) : bool :=
match s with
    | Nil => true
    | _ => false
end.

Fixpoint isEmpty' {A : Type} (s : Seq A) : bool :=
match s with
    | Nil => true
    | Zero s' => isEmpty' s'
    | One _ _ => false
end.

Function cons {A : Type} (x : A) (s : Seq A) : Seq A :=
match s with
    | Nil => One x Nil
    | Zero s' => One x s'
    | One h t => Zero (cons (x, h) t)
end.

Function uncons {A : Type} (s : Seq A) : option (A * Seq A) :=
match s with
    | Nil => None
    | Zero s' =>
        match uncons s' with
            | None => None
            | Some ((x, y), s'') => Some (x, One y s'')
        end
    | One h t => Some (h, Zero t)
end.

Definition head {A : Type} (s : Seq A) : option A :=
  fmap fst (uncons s).

Definition tail {A : Type} (s : Seq A) : option (Seq A) :=
  fmap snd (uncons s).

Fixpoint even (n : nat) : bool :=
match n with
    | 0 => true
    | 1 => false
    | S (S n') => even n'
end.

(** [lookup] *)
Inductive lookupGraph :
  nat -> forall A : Type, Seq A -> option A -> Type :=
    | graph_Nil :
        forall i A, lookupGraph i A Nil None
    | graph_Zero :
        forall i A s r,
          lookupGraph (div2 i) (A * A) s r ->
          lookupGraph i A (Zero s)
            (fmap (fun '(x, y) => if even i then x else y) r)
    | graph_One_0 :
        forall A h t,
          lookupGraph 0 A (One h t) (Some h)
    | graph_One_S :
        forall i A h t r,
          lookupGraph i A (Zero t) r -> lookupGraph (S i) A (One h t) r.

#[global] Hint Constructors lookupGraph : core.

Definition lookup_strong
  (i : nat) {A : Type} (s : Seq A)
  : {r : option A & lookupGraph i A s r}.
Proof.
  gen i. induction s as [| A s' | A h t]; intros.
    exists None. auto.
    destruct (IHs' (div2 i)). eauto.
    destruct i as [| i'].
      exists (Some h). constructor.
      destruct (IHt (div2 i')) as [r g]. eauto.
Defined.

Definition lookup
  (i : nat) {A : Type} (s : Seq A) : option A :=
    projT1 (lookup_strong i s).

(** [update] *)
Definition enhance {A : Type} (i : nat) (f : A -> A) : A * A -> A * A :=
  fun '(x, y) => if even i then (f x, y) else (x, f y).

Inductive fupdateGraph
  : nat -> forall A : Type, (A -> A) -> Seq A -> Seq A -> Type :=
    | fupdateGraph_Nil :
        forall i A f, fupdateGraph i A f Nil Nil
    | fupdateGraph_Zero :
        forall i A f s r,
          fupdateGraph (div2 i) (A * A) (enhance i f) s r ->
          fupdateGraph i A f (Zero s) (Zero r)
    | fupdateGraph_One_0 :
        forall A f h t,
          fupdateGraph 0 A f (One h t) (One (f h) t)
    | fupdateGraph_One_S :
        forall i A f h t r,
          fupdateGraph i A f (Zero t) r ->
            fupdateGraph (S i) A f (One h t) (cons h r).

#[global] Hint Constructors fupdateGraph : core.

Definition fupdate_strong
  (i : nat) (A : Type) (f : A -> A) (s : Seq A)
  : {r : Seq A & fupdateGraph i A f s r}.
Proof.
  gen i. gen f. induction s as [| A s' | A h t]; intros.
    exists Nil. auto.
    destruct (IHs' (enhance i f) (div2 i)). eauto.
    destruct i as [| i'].
      exists (One (f h) t). constructor.
      destruct (IHt (enhance i' f) (div2 i')) as [r g]. eauto.
Defined.

Definition fupdate
  (i : nat) {A : Type} (f : A -> A) (s : Seq A) : Seq A :=
    projT1 (fupdate_strong i A f s).

Definition update
  (i : nat) {A : Type} (y : A) (s : Seq A) : Seq A :=
    fupdate i (const y) s.

(** Other functions *)

Fixpoint fromList {A : Type} (l : list A) : Seq A :=
match l with
    | [] => Nil
    | h :: t => cons h (fromList t)
end.

Fixpoint zipjoin {A : Type} (l : list (A * A)) : list A :=
match l with
    | [] => []
    | (x, y) :: t => x :: y :: zipjoin t
end.

Fixpoint toList {A : Type} (s : Seq A) : list A :=
match s with
    | Nil => []
    | Zero s' => zipjoin (toList s')
    | One h t => h :: zipjoin (toList t)
end.

Fixpoint size {A : Type} (s : Seq A) : nat :=
match s with
    | Nil => 0
    | Zero s' => 2 * size s'
    | One h t => S (2 * size t)
end.

Fixpoint index {A : Type} (i : nat) (l : list A) {struct l} : option A :=
match l with
    | [] => None
    | h :: t =>
        match i with
            | 0 => Some h
            | S i' => index i' t
        end
end.

Fixpoint lupdate
  (i : nat) {A : Type} (f : A -> A) (l : list A) {struct l} : list A :=
match l with
    | [] => []
    | h :: t =>
        match i with
            | 0 => f h :: t
            | S i' => h :: lupdate i' f t
        end
end.

Fixpoint valid {A : Type} (s : Seq A) : Prop :=
match s with
    | Nil => True
    | Zero s' => s' <> Nil /\ valid s'
    | One _ t => valid t
end.

Fixpoint normalize {A : Type} (s : Seq A) : Seq A :=
match s with
    | Nil => Nil
    | Zero s' =>
        match normalize s' with
            | Nil => Nil
            | s'' => Zero s''
        end
    | One h t => One h (normalize t)
end.

(** Tests *)

(*
Definition to_1_10 := [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10].

Compute fromList to_1_10.
Compute update 5 42 (fromList to_1_10).
Compute lookup 1 (fromList to_1_10).
Compute lookup 5 (fromList to_1_10).
Compute update 1 42 (fromList to_1_10).
*)

(** Properties of [isEmpty]. *)

Lemma isEmpty_empty :
  forall (A : Type) (s : Seq A),
    isEmpty s = true <-> s = empty.
Proof.
  split; destruct s; compute; congruence.
Qed.

Lemma isEmpty_cons :
  forall (A : Type) (h : A) (t : Seq A),
    isEmpty (cons h t) = false.
Proof.
  destruct t; cbn; reflexivity.
Qed.

Lemma empty_valid :
  forall A : Type,
    valid (@empty A).
Proof.
  cbn. trivial.
Qed.

(** Properties of [isEmpty']. *)

Lemma isEmpty'_empty :
  forall A : Type,
    isEmpty' (@empty A) = true.
Proof.
  reflexivity.
Qed.

Lemma isEmpty'_cons :
  forall (A : Type) (h : A) (t : Seq A),
    isEmpty' (cons h t) = false.
Proof.
  induction t; cbn; rewrite ?IHt; reflexivity.
Qed.

Lemma isEmpty'_size :
  forall (A : Type) (s : Seq A),
    isEmpty' s = true <-> size s = 0.
Proof.
  split.
    induction s as [| s' | h t]; cbn; intro.
      reflexivity.
      rewrite IHs; auto.
      congruence.
    induction s as [| s' | h t]; cbn; intro.
      reflexivity.
      apply IHs. destruct (size s); inv H.
      inv H.
Qed.

(** Properties of cons *)

Lemma cons_not_Nil :
  forall (A : Type) (x : A) (s : Seq A),
    cons x s <> Nil.
Proof.
  induction s as [| s' | h t]; inv 1.
Qed.

Lemma cons_uncons :
  forall (A : Type) (x : A) (s s' : Seq A),
    uncons s = Some (x, s') -> cons x s' = s.
Proof.
  intros. functional induction @uncons A s.
    congruence.
    congruence.
    inv H. cbn. rewrite IHo; auto.
    inv H.
Qed.

Lemma cons_toList :
  forall (A : Type) (x : A) (s : Seq A),
    toList (cons x s) = x :: toList s.
Proof.
  intros. functional induction @cons A x s; cbn.
    reflexivity.
    reflexivity.
    rewrite IHs0. cbn. reflexivity.
Qed.

Lemma cons_size :
  forall (A : Type) (x : A) (s : Seq A),
    size (cons x s) = S (size s).
Proof.
  induction s as [| s' | h t]; cbn.
    reflexivity.
    reflexivity.
    rewrite <- ?plus_n_O. rewrite IHs. cbn. rewrite <- plus_n_Sm.
      reflexivity.
Qed.

Lemma cons_valid :
  forall (A : Type) (x : A) (s : Seq A),
    valid s -> valid (cons x s).
Proof.
  induction s as [| s' | h t]; cbn; intros; firstorder.
    apply cons_not_Nil.
Qed.

(** Properties of uncons *)

Lemma uncons_cons :
  forall (A : Type) (x : A) (s : Seq A),
    fmap (fun '(x, s) => (x, normalize s)) (uncons (cons x s)) =
    Some (x, normalize s).
Proof.
  intros. remember (cons x s) as w. gen s; gen x.
  functional induction @uncons A w; intros.
    symmetry in Heqw. apply cons_not_Nil in Heqw. contradiction.
    functional inversion Heqw; inj; subst.
      specialize (IHo (x, h) t eq_refl). rewrite e0 in IHo.
        cbn in *. congruence.
    functional inversion Heqw; inj; subst.
      specialize (IHo (x0, h) t eq_refl). rewrite e0 in IHo.
        cbn in *. inv IHo.
    functional inversion Heqw; inj; subst; cbn; reflexivity.
Qed.

(* TODO *) Lemma uncons_valid :
  forall (A : Type) (h : A) (t s : Seq A),
    valid s -> uncons s = None \/ (uncons s = Some (h, t) -> valid t).
Proof.
  intros until s. revert h t.
  functional induction uncons s;
  cbn.
    inv 1.
    inv 1.
    inv 1. right. inv 1. cbn. edestruct IHo.
      assumption.
      congruence.
      apply H. eassumption.
    intros. right. inv 1. cbn. split.
      admit.
      assumption.
Abort.

(** Properties of head *)

Lemma head_cons :
  forall (A : Type) (x : A) (s : Seq A),
    head (cons x s) = Some x.
Proof.
  intros. remember (cons x s) as w.
  gen s; gen x. unfold head.
  functional induction @uncons A w; cbn; intros.
    symmetry in Heqw. apply cons_not_Nil in Heqw. contradiction.
    functional inversion Heqw; inj; subst.
      specialize (IHo (x, h) t eq_refl). rewrite e0 in IHo. cbn in IHo.
        congruence.
    functional inversion Heqw; inj; subst.
      specialize (IHo (x0, h) t eq_refl). rewrite e0 in IHo. cbn in IHo.
        congruence.
    functional inversion Heqw; inj; subst; reflexivity.
Qed.

(** Properties of tail *)

Lemma uncons_cons' :
  forall (A : Type) (x y : A) (s s' : Seq A),
    uncons (cons x s) = Some (y, s') ->
      x = y /\ toList s = toList s'.
Proof.
  intros. functional induction (cons x s); cbn in *.
    inv H.
    inv H.
    destruct (uncons (cons (x, h) t)) eqn: Huc.
      destruct p, p. inv H. destruct (IHs0 _ _ eq_refl) as [Heq IH].
        cbn. rewrite IH. inv Heq.
      inv H.
Qed.

Lemma toList_tail :
  forall (A : Type) (s : Seq A),
    fmap toList (tail s) = match toList s with
                 | [] => None
                 | _ :: t => Some t
             end.
Proof.
  intros. unfold tail.
  functional induction @uncons A s; cbn.
    reflexivity.
    rewrite e0 in IHo. cbn in *. destruct (toList s') as [| h t]; cbn.
      reflexivity.
      congruence.
    apply cons_uncons in e0. rewrite <- e0, cons_toList. cbn. reflexivity.
    reflexivity.
Qed.

(** Properties of lookup and lookup *)

Lemma lookupGraph_unique :
  forall (i : nat) (A : Type) (s : Seq A) (r r' : option A),
    lookupGraph i A s r -> lookupGraph i A s r' -> r = r'.
Proof.
  induction 1; inv 1; try inj.
    cbn. f_equal. apply IHX. assumption.
    reflexivity.
    eauto.
Qed.

Lemma lookup_spec :
  forall (i : nat) (A : Type) (s : Seq A),
    lookupGraph i A s (@lookup i A s).
Proof.
  intros. unfold lookup. destruct (lookup_strong). cbn. assumption.
Qed.

Lemma lookup_eq :
  forall (i : nat) (A : Type) (s : Seq A),
    lookup i s =
    match s with
        | Nil => None
        | Zero s' => fmap (fun '(x, y) => if even i then x else y)
                          (lookup (div2 i) s')
        | One h t =>
            match i with
                | 0 => Some h
                | S i' => lookup i' (Zero t)
            end
    end.
Proof.
  intros. apply (@lookupGraph_unique i A s).
    apply lookup_spec.
    destruct s as [| s' | h t]; cbn.
      constructor.
      constructor. apply lookup_spec.
      destruct i as [| i']; cbn.
        constructor.
        constructor. apply lookup_spec.
Qed.

Lemma lookup_ind :
  forall P : nat -> forall A : Type, Seq A -> option A -> Prop,
    (forall (i : nat) (A : Type),
      P i A Nil None) ->
    (forall (i : nat) (A : Type) (s : Seq (A * A)%type),
      P (div2 i) (A * A)%type s (lookup (div2 i) s) ->
          P i A (Zero s) (lookup i (Zero s))) ->
    (forall (A : Type) (h : A) (t : Seq (A * A)%type),
      P 0 A (One h t) (lookup 0 (One h t))) ->
    (forall (i : nat) (A : Type) (h : A) (t : Seq (A * A)%type),
      P i A (Zero t) (lookup i (Zero t)) ->
        P (S i) A (One h t) (lookup (S i) (One h t))) ->
    forall (i : nat) (A : Type) (s : Seq A),
      P i A s (lookup i s).
Proof.
  intros.
  eapply (lookupGraph_ind (fun i A s r _ => P i A s (lookup i s))
           _ _ _ _ i A s (lookup i s) (lookup_spec i A s)).
Unshelve.
  all: cbn in *; intros; auto.
Defined.

Lemma index_aux :
  forall (i : nat) (A : Type) (l : list (A * A)%type),
    fmap (fun '(x, y) => if even i then x else y) (index (div2 i) l) =
    index i (zipjoin l).
Proof.
  intros. gen i. induction l as [| [x y] t]; cbn; intros.
    reflexivity.
    destruct i as [| [| i']]; cbn; auto.
Qed.

Lemma lookup_index :
  forall (i : nat) (A : Type) (s : Seq A),
    lookup i s = index i (toList s).
Proof.
  intros. functional induction (lookup i s) using lookup_ind; cbn.
    1, 3: reflexivity.
    rewrite lookup_eq, IHo, index_aux. reflexivity.
    rewrite lookup_eq. assumption.
Qed.

(** Properties of update *)

Lemma fupdate_spec :
  forall (i : nat) (A : Type) (f : A -> A) (s : Seq A),
    fupdateGraph i A f s (fupdate i f s).
Proof.
  intros. unfold fupdate. destruct (fupdate_strong i A f s). cbn.
  assumption.
Qed.

Lemma fupdate_ind :
  forall P : nat -> forall A : Type, (A -> A) -> Seq A -> Seq A -> Prop,
    (forall (i : nat) (A : Type) (f : A -> A),
      P i A f Nil Nil) ->
    (forall (i : nat) (A : Type) (f : A -> A) (s : Seq (A * A)),
      P (div2 i) (A * A)%type (enhance i f) s
        (fupdate (div2 i) (enhance i f) s) ->
          P i A f (Zero s) (fupdate i f (Zero s))) ->
    (forall (A : Type) (f : A -> A) (h : A) (t : Seq (A * A)),
      P 0 A f (One h t) (One (f h) t)) ->
    (forall (i : nat) (A : Type) (f : A -> A) (h : A) (t : Seq (A * A)),
      P i A f (Zero t) (fupdate i f (Zero t)) ->
        P (S i) A f (One h t) (fupdate (S i) f (One h t))) ->
    forall (i : nat) (A : Type) (f : A -> A) (s : Seq A),
      P i A f s (fupdate i f s).
Proof.
  intros.
  eapply (@fupdateGraph_ind (fun i A f s _ _ => P i A f s (fupdate i f s))
          _ _ _ _ i A f s (fupdate i f s) (fupdate_spec i A f s)).
Unshelve.
  all: cbn; intros; eauto.
Defined.

Lemma fupdateGraph_unique :
  forall (i : nat) (A : Type) (f : A -> A) (s r r' : Seq A),
    fupdateGraph i A f s r -> fupdateGraph i A f s r' -> r = r'.
Proof.
  induction 1; inv 1; inj; f_equal; eauto.
Qed.

Lemma fupdateGraph_correct :
  forall (i : nat) (A : Type) (f : A -> A) (s r : Seq A),
    fupdate i f s = r -> fupdateGraph i A f s r.
Proof.
  intros. subst. apply fupdate_spec.
Qed.

Lemma fupdateGraph_complete :
  forall (i : nat) (A : Type) (f : A -> A) (s r : Seq A),
    fupdateGraph i A f s r -> fupdate i f s = r.
Proof.
  intros. eapply fupdateGraph_unique.
    apply fupdateGraph_correct. reflexivity.
    assumption.
Qed.

Lemma fupdate_eq :
  forall (i : nat) (A : Type) (f : A -> A) (s : Seq A),
    fupdate i f s =
    match s with
        | Nil => Nil
        | Zero s' => Zero (fupdate (div2 i) (enhance i f) s')
        | One h t =>
            match i with
                | 0 => One (f h) t
                | S i' => cons h (fupdate i' f (Zero t))
            end
    end.
Proof.
  intros. apply (@fupdateGraph_unique i A f s).
    apply fupdate_spec.
    destruct s as [| s' | h t].
      constructor.
      constructor. apply fupdate_spec.
      destruct i as [| i'].
        constructor.
        constructor. apply fupdate_spec.
Qed.

Lemma enhance_SS :
  forall (i : nat) (A : Type) (f : A -> A),
    enhance (S (S i)) f = enhance i f.
Proof.
  reflexivity.
Qed.

Lemma lupdate_aux :
  forall (i : nat) (A : Type) (f : A -> A) (l : list (A * A)%type),
    zipjoin (lupdate (div2 i) (enhance i f) l) =
    lupdate i f (zipjoin l).
Proof.
  intros. gen i. gen f.
  induction l as [| [x y] t]; cbn; intros.
    reflexivity.
    destruct i as [| [| i']]; cbn; auto.
      rewrite enhance_SS, IHt. reflexivity.
Qed.

Lemma fupdate_lupdate :
  forall (i : nat) (A : Type) (f : A -> A) (s : Seq A),
    toList (fupdate i f s) = lupdate i f (toList s).
Proof.
  intros.
  functional induction (fupdate i f s) using fupdate_ind; cbn.
    1, 3: reflexivity.
    rewrite fupdate_eq. cbn. rewrite IHs0, lupdate_aux. reflexivity.
    rewrite fupdate_eq, cons_toList, IHs0. cbn. reflexivity.
Qed.

Lemma lookup_cons :
  forall (i : nat) (A : Type) (h : A) (t : Seq A),
    lookup (S i) (cons h t) = lookup i t.
Proof.
  intros. rewrite !lookup_index, cons_toList. cbn. reflexivity.
Qed.

Lemma lookup_fupdate :
  forall (i : nat) (A : Type) (f : A -> A) (s : Seq A),
    lookup i (fupdate i f s) = fmap_Option f (lookup i s).
Proof.
  intros.
  rewrite !lookup_index, !fupdate_lupdate.
  gen i. gen (toList s).
  induction l as [| h t]; cbn; intros.
    reflexivity.
    destruct i; cbn.
      reflexivity.
      apply IHt.
Qed.


(*|
#######################
Unfold notation in ltac
#######################

:Link: https://stackoverflow.com/q/48594507
|*)

(*|
Question
********

I noticed notations can be treated differently. For example ``<`` is
just notation for a regular definition and ``unfold "<"`` does work as
in the following example:
|*)

Theorem a : 4 < 5.
Proof.
  unfold "<". (* .unfold *)
Abort. (* .none *)

(*|
However, ``<=`` is notation associated with the type ``le`` and for
some reason ``unfold "<="`` doesn't work, as in the following example:
|*)

Theorem a : 4 <= 5.
Proof.
  Fail unfold "<=". (* .fails .unfold .no-goals *)
Abort. (* .none *)

(*|
Can I convert ``4 <= 5`` into ``le 4 5`` with some ltac command?
|*)

(*|
Answer (Anton Trunov)
*********************

This happens because ``<`` is interpreted as ``lt`` which is a
*definition* (`here
<https://coq.inria.fr/distrib/current/stdlib/Coq.Init.Peano.html#lt>`__):
|*)

Print lt. (* .unfold .no-in *)

(*|
You can achieve the same effect with ``unfold lt``.

In the same manner ``<=`` means ``le``, but you cannot unfold ``le``,
because it is a type constructor. The manual says that you can unfold
only a defined transparent constant or local definition.

The upshot here is that you don't unfold notations, you unfold the
definitions those notations refer to.
|*)

(*|
Answer (Yannick Forster)
************************

Adding to Anton's answer: If you already know how the notation is
defined and only want to make it visible in the goal, you could do
something like
|*)

Definition make_visible {X} (f : X) := f.

Notation "` f" := (make_visible f) (at level 5, format "` f").

Tactic Notation "unfold" "notation" constr(f) :=
  change f with (`f).
Tactic Notation "fold" "notation" constr(f) :=
  unfold make_visible.

Theorem a : 4 <= 5.
Proof.
  unfold notation le. (* .unfold *)
  fold notation le.
Abort. (* .none *)

(*| Edit: My first solution was |*)

Reset Initial. (* .none *)
Definition make_visible {X} (f : X) := (fun _ => f) tt.

(*| but, as Anton pointed out, this is easier. |*)


Set Printing Universes.

Fixpoint CardinalityRepresentative (n : nat) : Set :=
  match n with
    | O => Empty_set
    | S n' => sum (CardinalityRepresentative n') unit
  end.
(* Toplevel input, characters 104-143:
Error:
In environment
CardinalityRepresentative : nat -> Set
n : nat
n' : nat
The term "(CardinalityRepresentative n' + unit)%type" has type
 "Type (* max(Top.73, Top.74) *)" while it is expected to have type
"Set". *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E : Universe, ((wd_ A B /\ (wd_ C B /\ (wd_ D B /\ (wd_ A C /\ (wd_ E B /\ (wd_ A D /\ (wd_ C D /\ (wd_ A E /\ (wd_ C E /\ (wd_ D E /\ (col_ E A B /\ (col_ B D E /\ col_ A E C)))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Functors involving functor categories involving the terminal category *)
Require Import Category.Core Functor.Core FunctorCategory.Core Functor.Identity NaturalTransformation.Core NaturalTransformation.Paths Functor.Composition.Core.
Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors InitialTerminalCategory.NaturalTransformations.
Require Import HoTT.Basics HoTT.Types.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.

Section law1.
  Context `{Funext}.
  Context `{IsInitialCategory zero}.
  Context `{IsTerminalCategory one}.
  Local Notation "0" := zero : category_scope.
  Local Notation "1" := one : category_scope.

  Variable C : PreCategory.

  (** ** [C¹ → C] *)
  Definition functor : Functor (1 -> C) C
    := Build_Functor (1 -> C) C
                     (fun F => F (center _))
                     (fun s d m => m (center _))
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).

  Definition inverse_morphism_of
             s d (m : morphism C s d)
  : morphism (1 -> C)
             (Functors.from_terminal _ s)
             (Functors.from_terminal _ d).
  Proof.
    refine (Build_NaturalTransformation
              (Functors.from_terminal _ s)
              (Functors.from_terminal _ d)
              (fun _ => m)
              _).
    simpl; intros.
    etransitivity;
      [ apply right_identity
      | symmetry; apply left_identity ].
  Defined.

  Global Arguments inverse_morphism_of / _ _ _.

  (** ** [C → C¹] *)
  Definition inverse : Functor C (1 -> C).
  Proof.
    refine (Build_Functor
              C (1 -> C)
              (@Functors.from_terminal _ _ _ _ _)
              inverse_morphism_of
              _
              _
           );
    abstract (path_natural_transformation; trivial).
  Defined.
End law1.

Section law1'.
  Context `{Funext}.
  Context `{IsInitialCategory zero}.
  Context `{IsTerminalCategory one}.
  Local Notation "0" := zero : category_scope.
  Local Notation "1" := one : category_scope.

  Variable C : PreCategory.

  Global Instance: IsTerminalCategory (C -> 1) := {}.

  (** ** [1ˣ → 1] *)
  Definition functor' : Functor (C -> 1) 1
    := Functors.to_terminal _.

  (** ** [1 → 1ˣ] *)
  Definition inverse' : Functor 1 (C -> 1)
    := Functors.to_terminal _.

  (** ** [1ˣ ≅ 1] *)
  Definition law'
  : functor' o inverse' = 1
    /\ inverse' o functor' = 1
    := center _.
End law1'.


From Coq Require Import ssreflect ssrfun ssrbool.

From Ltac2 Require Import Ltac2.

From Coq Require Import Ensembles Bool String.
From Coq.Logic Require Import FunctionalExtensionality Eqdep_dec.
From Equations Require Import Equations.

Require Import Coq.Program.Tactics.

From MatchingLogic Require Import
    Syntax
    DerivedOperators_Syntax
    ProofSystem
    IndexManipulation
    wftactics
    ProofInfo
    BasicProofSystemLemmas
.
From MatchingLogic.ProofMode Require Import Basics
                                            Propositional.

From stdpp Require Import list tactics fin_sets coGset gmap sets.

From MatchingLogic.Utils Require Import stdpp_ext.

Import extralibrary.

Import
  MatchingLogic.Syntax.Notations
  MatchingLogic.Substitution.Notations
  MatchingLogic.DerivedOperators_Syntax.Notations
  MatchingLogic.ProofInfo.Notations
.

Set Default Proof Mode "Classic".

Section with_signature.
  Context {Σ : Signature}.
  Open Scope ml_scope.
  Open Scope string_scope.
  Open Scope list_scope.

  (*
    Γ ⊢ φ₁ → φ₂
    -------------------- (x ∉ FV(φ₂))
    Γ ⊢ (∃x. φ₁) → φ₂
  *)
  Lemma Ex_gen (Γ : Theory) (ϕ₁ ϕ₂ : Pattern) (x : evar) (i : ProofInfo)
      {pile : ProofInfoLe (
              {| pi_generalized_evars := {[x]};
                 pi_substituted_svars := ∅;
                 pi_uses_kt := false ;
                 pi_uses_advanced_kt := false ;
              |}) i} :
    x ∉ free_evars ϕ₂ ->
    Γ ⊢i ϕ₁ ---> ϕ₂ using i ->
    Γ ⊢i (exists_quantify x ϕ₁ ---> ϕ₂) using i.
  Proof.
    intros Hfev [pf Hpf].
    unshelve (eexists).
    {
      apply ProofSystem.Ex_gen.
      { pose proof (pf' := pf). apply proved_impl_wf in pf'.  wf_auto2. }
      { pose proof (pf' := pf). apply proved_impl_wf in pf'.  wf_auto2. }
      { exact pf. }
      { exact Hfev. }
    }
    {
      simpl.
      constructor; simpl.
      {
        rewrite elem_of_subseteq. intros x0 Hx0.
        rewrite elem_of_gset_to_coGset in Hx0.
        rewrite elem_of_union in Hx0.
        destruct Hx0.
        {
          rewrite elem_of_singleton in H. subst.
          eapply pile_impl_allows_gen_x.
          apply pile.
        }
        {
          inversion Hpf.
          apply pwi_pf_ge.
          rewrite elem_of_gset_to_coGset.
          assumption.
        }
      }
      {
        inversion Hpf.
        apply pwi_pf_svs.
      }
      {
        inversion Hpf.
        apply pwi_pf_kt.
      }
      {
        inversion Hpf.
        apply pwi_pf_kta.
      }
    }
  Defined.

  (*
     Γ ⊢ φ[y/x] → ∃x. φ
   *)
  Lemma Ex_quan (Γ : Theory) (ϕ : Pattern) (y : evar) :
    well_formed (patt_exists ϕ) ->
    Γ ⊢i (instantiate (patt_exists ϕ) (patt_free_evar y) ---> (patt_exists ϕ))
    using BasicReasoning.
  Proof.
    intros Hwf.
    unshelve (eexists).
    {
      apply ProofSystem.Ex_quan. apply Hwf.
    }
    {
      abstract (solve_pim_simple).
    }
  Defined.

  (*
    Γ ⊢ φ
    --------------
    Γ ⊢ ∀x. φ
  *)
  Lemma universal_generalization Γ ϕ x (i : ProofInfo) :
    ProofInfoLe ( (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false)) i ->
    well_formed ϕ ->
    Γ ⊢i ϕ using i ->
    Γ ⊢i patt_forall (ϕ^{{evar: x ↦ 0}}) using i.
  Proof.
    intros pile wfϕ Hϕ.
    unfold patt_forall.
    unfold patt_not at 1.
    replace (! ϕ^{{evar: x ↦ 0}})
      with ((! ϕ)^{{evar: x ↦ 0}})
      by reflexivity.
    apply Ex_gen.
    { exact pile. }
    { simpl. set_solver. }
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlAdd Hϕ.
    mlApply "0". mlExactn 0.
  Defined.

  (*
   Γ ⊢ (∀x. φ) → φ
   DO NOT use quantification here instead of opening
  *)
  Lemma forall_variable_substitution Γ ϕ x:
    well_formed (ex, ϕ) ->
    Γ ⊢i (all, ϕ) ---> ϕ^{evar:0 ↦ x} using BasicReasoning.
  Proof.
    intros wfϕ.

    unfold patt_forall.
    apply double_neg_elim_meta.
    { wf_auto2. }
    { wf_auto2. }
    toMLGoal.
    { wf_auto2. }
    mlIntro.
    mlIntro.
    mlApply "0".
    mlIntro.
    mlApply "2".
    pose proof (Htmp := Ex_quan Γ (!ϕ) x ltac:(wf_auto2)).
    rewrite /instantiate in Htmp.
    useBasicReasoning.
    mlAdd Htmp.
    mlApply "3". mlSimpl.
    mlIntro.
    mlApply "1".
    mlExactn 4.
  Defined.

  Lemma forall_variable_substitution_meta Γ ϕ x i:
    well_formed (ex, ϕ) ->
    Γ ⊢i (all, ϕ) using i -> Γ ⊢i ϕ^{evar:0 ↦ x} using i.
  Proof.
    intros WF H. eapply MP.
    2: gapply forall_variable_substitution.
    assumption.
    try_solve_pile.
    wf_auto2.
  Defined.

  (*
    Γ ⊢ φ₁ → φ₂
    -----------------------
    Γ ⊢ (∃x. φ₁) → (∃x. φ₂)
  *)
  Lemma ex_quan_monotone Γ x ϕ₁ ϕ₂ (i : ProofInfo)
    (pile : ProofInfoLe ( (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false)) i) :
    Γ ⊢i ϕ₁ ---> ϕ₂ using i ->
    Γ ⊢i (exists_quantify x ϕ₁) ---> (exists_quantify x ϕ₂) using i.
  Proof.
    intros H.
    pose proof (Hwf := proved_impl_wf Γ _ (proj1_sig H)).
    assert (wfϕ₁: well_formed ϕ₁ = true) by wf_auto2.
    assert (wfϕ₂: well_formed ϕ₂ = true) by wf_auto2.
    apply Ex_gen.
    { exact pile. }
    { simpl. rewrite free_evars_evar_quantify. clear. set_solver. }

    unfold exists_quantify.
    eapply syllogism_meta. 4: apply H.
    { wf_auto2. }
    { wf_auto2. }
    { wf_auto2. }
    clear H wfϕ₁ ϕ₁ Hwf.

    (* We no longer need to use [cast_proof] to avoid to ugly eq_sym terms;
       however, without [cast_proof'] the [replace] tactics does not work,
       maybe because of implicit parameters.
     *)
    eapply (cast_proof').
    {
      replace ϕ₂ with (instantiate (ex, ϕ₂^{{evar: x ↦ 0}}) (patt_free_evar x)) at 1.
      2: { unfold instantiate.
         rewrite bevar_subst_evar_quantify_free_evar.
         now do 2 apply andb_true_iff in wfϕ₂ as [_ wfϕ₂].
         reflexivity.
      }
      reflexivity.
    }
          (* i =  gpi *)
    useBasicReasoning.
    apply Ex_quan.
    abstract (wf_auto2).
  Defined.

  (*
     Γ ⊢ (∃x. φ₁ /\ φ₂) -> (∃x. φ₁)
  *)
  Lemma ex_quan_and_proj1 Γ x ϕ₁ ϕ₂:
    well_formed ϕ₁ = true ->
    well_formed ϕ₂ = true ->
    Γ ⊢i (exists_quantify x (ϕ₁ and ϕ₂)) ---> (exists_quantify x ϕ₁)
    using ( (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false)).
  Proof.
    intros wfϕ₁ wfϕ₂.
    apply ex_quan_monotone.
    { apply pile_refl. }
    toMLGoal.
    { wf_auto2. }
    mlIntro.
    mlDestructAnd "0". mlExactn 0.
  Defined.

  (*
     Γ ⊢ (∃x. φ₁ /\ φ₂) -> (∃x. φ₂)
  *)
  Lemma ex_quan_and_proj2 Γ x ϕ₁ ϕ₂:
    well_formed ϕ₁ = true ->
    well_formed ϕ₂ = true ->
    Γ ⊢i (exists_quantify x (ϕ₁ and ϕ₂)) ---> (exists_quantify x ϕ₂)
    using ( (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false)).
  Proof.
    intros wfϕ₁ wfϕ₂.
    apply ex_quan_monotone.
    { apply pile_refl. }
    toMLGoal.
    { wf_auto2. }
    mlIntro.
    mlDestructAnd "0".
    mlExactn 1.
  Defined.

  (*
   Γ ⊢ φ₁ → φ₂
   ----------------------------
   Γ ⊢ φ₁ → ∀x. φ₂
  *)
  (* identity *)
  Lemma strip_exists_quantify_l Γ x P Q i :
    x ∉ free_evars P ->
    well_formed_closed_ex_aux P 1 ->
    Γ ⊢i (exists_quantify x (P^{evar: 0 ↦ x}) ---> Q) using i ->
    Γ ⊢i (ex , P) ---> Q using i.
  Proof.
  intros Hx HwfcP H.
  unshelve (eapply (cast_proof' Γ _ _ _ _ H)).
  abstract (
    unfold exists_quantify;
    rewrite -> evar_quantify_evar_open by assumption;
    reflexivity
  ).
  Defined.

  (* identity *)
  Lemma strip_exists_quantify_r Γ x P Q i :
    x ∉ free_evars Q ->
    well_formed_closed_ex_aux Q 1 ->
    Γ ⊢i P ---> (exists_quantify x (Q^{evar: 0 ↦ x})) using i ->
    Γ ⊢i P ---> ex, Q using i.
  Proof.
  intros Hx HwfcP H.
  unshelve (eapply (cast_proof' Γ _ _ _ _ H)).
  abstract (
    unfold exists_quantify;
    rewrite -> evar_quantify_evar_open by assumption;
    reflexivity
  ).
  Defined.

  (* prenex-exists-and-left *)
  (*
   Γ ⊢ ((∃x. φ₁) /\ φ₂) → (∃x. (φ₁ /\ φ₂))
   *)
  Lemma prenex_exists_and_1 (Γ : Theory) ϕ₁ ϕ₂:
    well_formed (ex, ϕ₁) ->
    well_formed ϕ₂ ->
    Γ ⊢i ((ex, ϕ₁) and ϕ₂) ---> (ex, (ϕ₁ and ϕ₂))
    using ( (ExGen := {[fresh_evar (ϕ₂ ---> ex , (ϕ₁ and ϕ₂))]}, SVSubst := ∅, KT := false, AKT := false)).
  Proof.
    intros wfϕ₁ wfϕ₂.
    toMLGoal.
    { wf_auto2. }
    mlIntro. mlDestructAnd "0".
    fromMLGoal.

    remember (fresh_evar (ϕ₂ ---> (ex, (ϕ₁ and ϕ₂)))) as x.
    apply strip_exists_quantify_l with (x := x).
    { subst x. eapply evar_is_fresh_in_richer'.
      2: { apply set_evar_fresh_is_fresh'. }
      simpl. clear. set_solver.
    }
    { wf_auto2. }
    apply Ex_gen.
    { apply pile_refl. }
    { subst x. apply set_evar_fresh_is_fresh. }

    apply lhs_to_and.
    { wf_auto2. }
    { wf_auto2. }
    { wf_auto2. }

    eapply cast_proof'.
    {
      replace (ϕ₁^{evar: 0 ↦ x} and ϕ₂)
              with ((ϕ₁ and ϕ₂)^{evar: 0 ↦ x}).
      2: {
        unfold evar_open. mlSimpl.
        rewrite [bevar_subst _ _ ϕ₂]bevar_subst_not_occur.
        {
          wf_auto2.
        }
        reflexivity.
      }
      reflexivity.
    }
    useBasicReasoning.
    apply Ex_quan.
    wf_auto2.
  Defined.

  (* prenex-exists-and-right *)
  (*
     Γ ⊢ (∃x. (φ₁ /\ φ₂)) → ((∃x. φ₁) /\ φ₂)
  *)
  Lemma prenex_exists_and_2 (Γ : Theory) ϕ₁ ϕ₂:
    well_formed (ex, ϕ₁) ->
    well_formed ϕ₂ ->
    Γ ⊢i (ex, (ϕ₁ and ϕ₂)) ---> ((ex, ϕ₁) and ϕ₂)
    using ( (ExGen := {[fresh_evar ((ϕ₁ and ϕ₂))]}, SVSubst := ∅, KT := false, AKT := false)).
  Proof.
    intros wfϕ₁ wfϕ₂.
    toMLGoal.
    { wf_auto2. }
    mlIntro.
    mlSplitAnd.
    - fromMLGoal.
      remember (fresh_evar (ϕ₁ and ϕ₂)) as x.
      apply strip_exists_quantify_l with (x := x).
      { subst x. apply set_evar_fresh_is_fresh. }
      (* TODO: make wf_auto2 solve this *)
      { simpl. rewrite !andbT. split_and!.
        + wf_auto2.
        + wf_auto2.
      }
      apply strip_exists_quantify_r with (x := x).
      { subst x. eapply evar_is_fresh_in_richer'.
        2: { apply set_evar_fresh_is_fresh'. }
        simpl. clear. set_solver.
      }
      { wf_auto2. }
      apply ex_quan_monotone.
      { apply pile_refl. }

      unfold evar_open. mlSimpl.
      rewrite [bevar_subst _ _ ϕ₂]bevar_subst_not_occur.
      {
        wf_auto2.
      }
      toMLGoal.
      { wf_auto2. }
      mlIntro. mlDestructAnd "0". mlExactn 0.
    - fromMLGoal.
      remember (fresh_evar (ϕ₁ and ϕ₂)) as x.
      eapply cast_proof'.
      {
        rewrite -[ϕ₁ and ϕ₂](evar_quantify_evar_open x 0).
        { subst x. apply set_evar_fresh_is_fresh. }
        { wf_auto2. }
        reflexivity.
      }
      apply Ex_gen.
      { apply pile_refl. }
      { eapply evar_is_fresh_in_richer. 2: { subst x. apply set_evar_fresh_is_fresh'. }
        simpl. clear. set_solver.
      }

      unfold evar_open. mlSimpl.
      rewrite [bevar_subst _ _ ϕ₂]bevar_subst_not_occur.
      {
        wf_auto2.
      }
      toMLGoal.
      { wf_auto2. }
      mlIntro.
      mlDestructAnd "0".
      mlExactn 1.
  Defined.

  (*
     Γ ⊢ (∃x. (φ₁ /\ φ₂)) ↔ ((∃x. φ₁) /\ φ₂)
  *)
  Lemma prenex_exists_and_iff (Γ : Theory) ϕ₁ ϕ₂:
    well_formed (ex, ϕ₁) ->
    well_formed ϕ₂ ->
    Γ ⊢i (ex, (ϕ₁ and ϕ₂)) <---> ((ex, ϕ₁) and ϕ₂)
    using ( (ExGen := {[fresh_evar ((ϕ₁ and ϕ₂))]}, SVSubst := ∅, KT := false, AKT := false)).
  Proof.
    intros wfϕ₁ wfϕ₂.
    apply conj_intro_meta.
    { wf_auto2. }
    { wf_auto2. }
    - apply prenex_exists_and_2; assumption.
    - (* TODO we need a tactic to automate this change *)
      replace (fresh_evar (ϕ₁ and ϕ₂))
      with (fresh_evar (ϕ₂ ---> ex , (ϕ₁ and ϕ₂))).
      2: { cbn. unfold fresh_evar. apply f_equal. simpl. set_solver. }
     apply prenex_exists_and_1; assumption.
  Defined.

  (*
     This is basically [universal_generalization]
    but under an implication.
    I wonder if we could get an iterative version [forall_gen_iter]?
    Like,
    Γ ⊢ φ₁ → ... → φₖ → ψ
    ----------------------------
    Γ ⊢ φ₁ → ... → φₖ → ∀x. ψ
  *)
  Lemma forall_gen Γ ϕ₁ ϕ₂ x (i : ProofInfo):
    evar_is_fresh_in x ϕ₁ ->
    ProofInfoLe ( (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false)) i ->
    Γ ⊢i ϕ₁ ---> ϕ₂ using i ->
    Γ ⊢i ϕ₁ ---> all, (ϕ₂^{{evar: x ↦ 0}}) using i.
  Proof.
    intros Hfr pile Himp.
    pose proof (Hwf := proved_impl_wf _ _ (proj1_sig Himp)).
    pose proof (wfϕ₁ := well_formed_imp_proj1 _ _ Hwf).
    pose proof (wfϕ₂ := well_formed_imp_proj2 _ _ Hwf).
    toMLGoal.
    { wf_auto2. }
    mlIntro.
    mlApplyMetaRaw (useBasicReasoning _ (not_not_intro Γ ϕ₁ ltac:(wf_auto2))) in "0".
    fromMLGoal.
    apply modus_tollens.

    eapply cast_proof'.
    {
      replace (! ϕ₂^{{evar: x ↦ 0}})
              with ((! ϕ₂)^{{evar: x ↦ 0}})
                   by reflexivity.
      reflexivity.
    }
    apply Ex_gen.
    { exact pile. }
    { simpl. unfold evar_is_fresh_in in Hfr. clear -Hfr. set_solver. }
    apply modus_tollens; assumption.
  Defined.

  (*
   Γ ⊢ (∀x. φ) → φ

   This is the same as [forall_variable_substitution]
   except that here we have a ProofInfoLe assumption
   instead of a concrete [using] clause.
  *)
  Lemma forall_variable_substitution' Γ ϕ x (i : ProofInfo):
    well_formed (ex, ϕ) ->
    Γ ⊢i (all, ϕ) ---> ϕ^{evar:0 ↦ x} using i.
  Proof.
    intros wfϕ.
    pose proof (Htmp := forall_variable_substitution Γ ϕ x wfϕ).
    eapply useGenericReasoning. 2: apply Htmp. try_solve_pile.
  Defined.

  (*
    Γ ⊢ ∀x. φ
    ----------
    Γ ⊢ φ
  *)
  Lemma forall_elim Γ ϕ x (i : ProofInfo):
    well_formed (ex, ϕ) ->
    Γ ⊢i (all, ϕ) using i ->
    Γ ⊢i (ϕ^{evar: 0 ↦ x}) using i.
  Proof.
    intros wfϕ H.
    destruct i.
    eapply MP.
    2: eapply forall_variable_substitution'.
    2: wf_auto2.
    apply H.
  Defined.

  (*
   Γ ⊢ ∀x. (φ₁ → φ₂)
   ------------------
   Γ ⊢ (∃x. φ₁) → φ₂

  When applied backwards,
  turns an existential quantification on the LHS of an implication
  into an universal quantification on top.
  I wonder if we can get an iterative version, saying that
   Γ ⊢ ∀ x. (φ₁ → ... → φᵢ → ... → φₖ → ψ)
   ------------------
   Γ ⊢ φ₁ → ... → (∃x. φᵢ) → ... → φₖ → ψ

  Even better, I would like to have a version which says that
   Γ ⊢ ∀ x₁,...,xₘ,x. (φ₁ → ... → φᵢ → ... → φₖ → ψ)
   ------------------
   Γ ⊢ ∀ x₁,...,xₘ. (φ₁ → ... → (∃x. φᵢ) → ... → φₖ → ψ)

  because that would basically implement [mgDestructEx],
  assuming we hide the leading universal quantifiers.

  TODO: parameterize this lemma with a variable which is fresh in (ϕ₁ ---> ϕ₂),
  instead of hard-coding the fresh generation.
  *)
  Lemma prenex_forall_imp Γ ϕ₁ ϕ₂ i:
    well_formed (ex, ϕ₁) ->
    well_formed ϕ₂ ->
    ProofInfoLe ( (ExGen := {[fresh_evar (ϕ₁ ---> ϕ₂)]}, SVSubst := ∅, KT := false, AKT := false)) i ->
    Γ ⊢i (all, (ϕ₁ ---> ϕ₂)) using i ->
    Γ ⊢i (ex, ϕ₁) ---> (ϕ₂) using i.
  Proof.
    intros wfϕ₁ wfϕ₂ pile H.
    remember (fresh_evar (ϕ₁ ---> ϕ₂)) as x.
    apply (strip_exists_quantify_l Γ x).
    { subst x.
      eapply evar_is_fresh_in_richer'.
      2: { apply set_evar_fresh_is_fresh'. }
      simpl. set_solver.
    }
    { wf_auto2. }
    apply Ex_gen.
    { apply pile. }
    1: {
      subst x.
      eapply evar_is_fresh_in_richer'.
      2: { apply set_evar_fresh_is_fresh'. }
      simpl. set_solver.
    }

    eapply cast_proof'.
    {
      rewrite -[HERE in evar_open _ _ _ ---> HERE](evar_open_not_occur 0 x ϕ₂).
      {
        wf_auto2.
      }
      reflexivity.
    }
    eapply forall_elim with (x := x) in H.
    2: wf_auto2.
    unfold evar_open in *. simpl in *. exact H.
  Defined.

  Lemma Ex_gen_lifted (Γ : Theory) (ϕ₁ : Pattern) (l : hypotheses) (n : string) (g : Pattern) (x : evar)
    (i : ProofInfo) :
    evar_is_fresh_in x g ->
    evar_is_fresh_in_list x (patterns_of l) ->
    ProofInfoLe ( (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false)) i ->
    bevar_occur ϕ₁ 0 = false ->
    mkMLGoal Σ Γ (mkNH _ n ϕ₁::l) g i ->
    mkMLGoal Σ Γ (mkNH _ n (exists_quantify x ϕ₁)::l) g i.
  Proof.
    intros xfrg xfrl pile Hno0 H.
    mlExtractWF H1 H2.
    fromMLGoal.
    pose proof (H1' := H1).
    unfold Pattern.wf in H1. simpl in H1. apply andb_prop in H1. destruct H1 as [H11 H12].
    apply wf_ex_quan_impl_wf in H11. 2: assumption.
    unfold of_MLGoal in H. simpl in H.
    specialize (H H2).
    feed specialize H.
    {
      unfold Pattern.wf. simpl. rewrite H11 H12. reflexivity.
    }
    apply Ex_gen.
    { apply pile. }
    2: { assumption. }
    simpl.
    apply evar_fresh_in_foldr.
    split; assumption.
  Defined.

  (* Weakening under existential *)
  Local Example ex_exists Γ ϕ₁ ϕ₂ ϕ₃ i:
    well_formed (ex, ϕ₁) ->
    well_formed (ex, ϕ₂) ->
    well_formed ϕ₃ ->
    ProofInfoLe ( (ExGen := {[(evar_fresh (elements (free_evars ϕ₁ ∪ free_evars ϕ₂ ∪ free_evars (ex, ϕ₃))))]}, SVSubst := ∅, KT := false, AKT := false)) i ->
    Γ ⊢i (all, (ϕ₁ and ϕ₃ ---> ϕ₂)) using i ->
    Γ ⊢i (ex, ϕ₁) ---> ϕ₃ ---> (ex, ϕ₂) using i.
  Proof.
    intros wfϕ₁ wfϕ₂ wfϕ₃ pile H.
    toMLGoal.
    { wf_auto2. }
    mlIntro.
    remember (evar_fresh (elements (free_evars ϕ₁ ∪ free_evars ϕ₂ ∪ free_evars (ex, ϕ₃)))) as x.
    rewrite -[ϕ₁](evar_quantify_evar_open x 0).
    { subst x.
      eapply evar_is_fresh_in_richer'. 2: apply set_evar_fresh_is_fresh'. clear. set_solver.
    }
    wf_auto2.
    mlIntro.
    apply Ex_gen_lifted.
    { subst x. eapply evar_is_fresh_in_richer'. 2: apply set_evar_fresh_is_fresh'. clear. set_solver. }
    { constructor. 2: apply Forall_nil; exact I.
      subst x.
      eapply evar_is_fresh_in_richer'. 2: apply set_evar_fresh_is_fresh'. clear. set_solver.
    }
    { assumption. }
  Abort.

  Lemma existential_instantiation :
    forall Γ (φ : Pattern) x y, well_formed φ -> x <> y ->  y ∉ free_evars φ ->
      Γ ⊢i exists_quantify x φ ---> φ^[[evar: x ↦ patt_free_evar y]]
      using (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false).
  Proof.
    intros Γ φ x y WF xNy Hy.
    apply Ex_gen. apply pile_refl.
    apply evar_is_fresh_in_free_evar_subst. unfold evar_is_fresh_in. set_solver.
    toMLGoal.
    { wf_auto2. }
    mlIntro "H".
    mlAssert ("H0" : (all , φ^{{evar: x ↦ 0}})). wf_auto2.
  Abort.

  Lemma MLGoal_IntroVar : forall Γ l g i x,
    x ∉ free_evars g ->
    ProofInfoLe ( (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false)) i ->
    mkMLGoal Σ Γ l (g^{evar: 0 ↦ x}) i ->
    mkMLGoal Σ Γ l (all , g) i.
  Proof.
    unfold of_MLGoal. simpl. intros Γ l g i x xN PI H wf1 wf2.
    eapply prf_weaken_conclusion_iter_meta_meta. 5: apply H.
    all: try solve[wf_auto2].
    toMLGoal. wf_auto2. mlIntro "H". mlIntro "H0".
    epose proof (Ex_gen Γ (! g^{evar: 0 ↦ x}) ⊥ x i _ _).
    mlApplyMeta H0. unfold exists_quantify. simpl.
    rewrite evar_quantify_evar_open; auto.
    apply andb_true_iff in wf1 as [_ wf1].
    apply andb_true_iff in wf1 as [_ wf1]. simpl in wf1.
    now do 2 rewrite andb_true_r in wf1. mlExact "H0".
   Unshelve.
     set_solver.
  Abort.

  Lemma propagate_forall (Γ : Theory):
    forall ϕ₁ ϕ₂ x,
    well_formed ϕ₁ ->
    well_formed ϕ₂ ->
    x ∉ free_evars ϕ₁ ->
    Γ ⊢i ((all, (ϕ₁ ---> ϕ₂^{{evar:x↦0}})) ---> (ϕ₁ ---> all, ϕ₂^{{evar:x↦0}}))
      using (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false).
  Proof.
    intros ϕ₁ ϕ₂ x Wf1 Wf2 Hx. mlIntro "H". mlIntro "H0".
    mlAssert ("H1" : ((all, ϕ₁ ---> ϕ₂^{{evar:x↦0}}) and ϕ₁)). wf_auto2.
    { mlSplitAnd; mlAssumption. }
    mlClear "H". mlClear "H0".
    fromMLGoal.
    apply forall_gen.
    unfold evar_is_fresh_in. cbn.
    pose proof (evar_quantify_no_occurrence ϕ₂ x 0) as H. set_solver.
    try_solve_pile.
    mlIntro "H".
    mlDestructAnd "H".
    pose proof (forall_variable_substitution Γ (ϕ₁ ---> ϕ₂^{{evar: x↦0}}) x ltac:(wf_auto2)) as H0.
    cbn in H0. fold (evar_open x 0 ϕ₂^{{evar:x ↦ 0}}) in H0.
    rewrite evar_open_evar_quantify in H0. wf_auto2.
    rewrite bevar_subst_not_occur in H0. wf_auto2.
    mlRevertLast.
    mlApplyMeta H0. mlAssumption.
  Defined.

  Lemma universal_generalization_iter (Γ : Theory):
    forall (l : list Pattern) (ϕ : Pattern) x i,
    Pattern.wf l ->
    well_formed ϕ ->
    x ∉ free_evars_of_list l ->
    ProofInfoLe (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false) i ->
    Γ ⊢i foldr patt_imp ϕ l using i ->
    Γ ⊢i foldr patt_imp (all , ϕ^{{evar: x ↦ 0}}) l using i.
  Proof.
    induction l; intros ϕ x i Wfl Wfϕ Hx Hle H.
    - by apply universal_generalization.
    - apply reorder_last_to_head_meta in H. 2-4: wf_auto2.
      rewrite foldr_snoc in H. apply (IHl _ x) in H. 2-3: wf_auto2.
      2: { solve_free_evars 5. }
      simpl in H. rewrite evar_quantify_fresh in H.
      1: { solve_free_evars 5. }
      eapply prf_weaken_conclusion_iter_meta_meta in H.
      5: gapply propagate_forall.
      5,9: try_solve_pile.
      2-7: try by wf_auto2.
      2: solve_free_evars 5.
      apply reorder_head_to_last_meta. 1-3: wf_auto2.
      by rewrite foldr_snoc.
    Defined.

  Lemma MLGoal_forallIntro Γ l g (x : evar) i :
    x ∉ free_evars_of_list (patterns_of l) ->
    x ∉ free_evars g ->
    ProofInfoLe (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false) i ->
    mkMLGoal _ Γ l (g^{evar: 0 ↦ x}) i ->
    mkMLGoal _ Γ l (all, g) i.
  Proof.
    unfold of_MLGoal in *. simpl in *. intros Hx1 Hx2 Hi H Hwf1 Hwfl.
    rewrite <- (evar_quantify_evar_open x 0 g). 3: wf_auto2. 2: assumption.
    apply universal_generalization_iter. 1-2: wf_auto2.
    assumption. try_solve_pile.
    apply H; wf_auto2.
  Defined.

  (* NOTE: this is not too good with quantification in the concusion.
           Opening is better, when there is no condition about the
           freshness of variables (i.e. Ex_gen is not used). *)
  Lemma specialize_forall (Γ : Theory) :
    forall (l₁ l₂ : list Pattern) (ϕ ψ : Pattern) x i,
      well_formed ϕ -> well_formed (ex, ψ) -> Pattern.wf l₁ -> Pattern.wf l₂ ->
      Γ ⊢i foldr patt_imp ϕ (l₁ ++ ψ^{evar:0 ↦ x} :: l₂) using i ->
      Γ ⊢i foldr patt_imp ϕ (l₁ ++ (all, ψ) :: l₂) using i.
  Proof.
    intros.
    eapply prf_strenghten_premise_iter_meta_meta. 7: eassumption.
    1-5: wf_auto2.
    apply forall_variable_substitution'.
    wf_auto2.
  Defined.

  Lemma MLGoal_specializeAll Γ l₁ l₂ (g ψ : Pattern) x i name :
    mkMLGoal _ Γ (l₁ ++ (mkNH _ name (ψ^{evar:0 ↦ x})) :: l₂) g i ->
    mkMLGoal _ Γ (l₁ ++ (mkNH _ name (all, ψ)) :: l₂) g i.
  Proof.
    unfold of_MLGoal in *. simpl in *. intros H Hwf Hwfl.
    unfold patterns_of in *. rewrite map_app. rewrite map_app in Hwfl.
    simpl in *.
    eapply (specialize_forall Γ _ _ _ _ x).
    1-4: wf_auto2.
    rewrite map_app in H. simpl in H.
    apply H; wf_auto2.
  Defined.

  (* This is more efficient in proof term size, than the version below based on specialize: *)
  Lemma revert_forall_iter (Γ : Theory) :
    forall (l : list Pattern) (ϕ : Pattern) x,
    Pattern.wf l ->
    well_formed (ex, ϕ) ->
    Γ ⊢i foldr patt_imp (all , ϕ) l ---> foldr patt_imp ϕ^{evar: 0 ↦ x} l
      using BasicReasoning.
  Proof.
    intros l ϕ x Wfl Wfϕ. apply prf_weaken_conclusion_iter_meta. 1-3: wf_auto2.
    apply forall_variable_substitution. wf_auto2.
  Defined.

  Lemma revert_forall_iter_meta (Γ : Theory) :
    forall (l : list Pattern) (ϕ : Pattern) x i,
    Pattern.wf l ->
    well_formed (ex, ϕ) ->
    Γ ⊢i foldr patt_imp (all , ϕ) l using i ->
    Γ ⊢i foldr patt_imp (ϕ^{evar: 0 ↦ x}) l using i.
  Proof.
    intros l ϕ x i Wfl Wfϕ H.
    eapply MP. 2: gapply revert_forall_iter. 3-4: wf_auto2. 2: try_solve_pile.
    exact H.
  Defined.

  (* Here, we change opening in the conclusion to quantification in the premise
     to simplify pattern matching for the tactic *)
  Lemma MLGoal_revertAll Γ l g (x : evar) i :
    mkMLGoal _ Γ l (all, g^{{evar:x ↦ 0}}) i ->
    mkMLGoal _ Γ l g i.
  Proof.
    unfold of_MLGoal in *. simpl in *. intros H Hwf1 Hwfl.
    specialize (H ltac:(wf_auto2) ltac:(wf_auto2)).
    apply revert_forall_iter_meta with (x := x) in H. 2-3: wf_auto2.
    rewrite evar_open_evar_quantify in H. wf_auto2.
    assumption.
  Defined.

  Lemma ex_quan_iter (Γ : Theory) :
    forall (l : list Pattern) (ϕ : Pattern) x,
    Pattern.wf l ->
      well_formed (ex, ϕ) ->
      Γ ⊢i foldr patt_imp ϕ^{evar:0 ↦ x} l ---> foldr patt_imp (ex, ϕ) l
        using BasicReasoning.
  Proof.
    intros l ϕ x Wfl Wfϕ. apply prf_weaken_conclusion_iter_meta.
    1-3: wf_auto2.
    apply Ex_quan.
    wf_auto2.
  Defined.

  Lemma ex_quan_iter_meta (Γ : Theory) :
    forall (l : list Pattern) (ϕ : Pattern) x i,
    Pattern.wf l ->
      well_formed (ex, ϕ) ->
      Γ ⊢i foldr patt_imp ϕ^{evar:0 ↦ x} l using i ->
      Γ ⊢i foldr patt_imp (ex, ϕ) l using i.
  Proof.
    intros l ϕ x i Wfl Wfϕ H.
    eapply MP. exact H.
    gapply ex_quan_iter.
    1: try_solve_pile.
    all: wf_auto2.
  Defined.

  Lemma MLGoal_exists Γ l g (x : evar) i :
    mkMLGoal _ Γ l (g^{evar: 0 ↦ x}) i ->
    mkMLGoal _ Γ l (ex, g) i.
  Proof.
    unfold of_MLGoal in *. simpl in *. intros H Hwf1 Hwfl.
    eapply ex_quan_iter_meta.
    1-2: wf_auto2.
    apply H.
    1-2: wf_auto2.
  Defined.

  Lemma exists_elim Γ : forall l₁ l₂ g ϕ i x,
    well_formed (ex, ϕ) -> Pattern.wf l₁ -> Pattern.wf l₂ ->
    ProofInfoLe (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false) i ->
    x ∉ free_evars ϕ ->
    x ∉ free_evars g ->
    x ∉ free_evars_of_list l₁ ->
    x ∉ free_evars_of_list l₂ ->
    Γ ⊢i foldr patt_imp g (l₁ ++ ϕ^{evar:0 ↦ x} :: l₂) using i ->
    Γ ⊢i foldr patt_imp g (l₁ ++ (ex, ϕ) :: l₂) using i.
  Proof.
    intros l₁ l₂ g ϕ i x Hwf Hwfl1 Hwfl2 Hi Hin1 Hin2 Hin3 Hin4 H.
    apply reorder_middle_to_head_meta. 1-4: wf_auto2.
    apply reorder_head_to_middle_meta in H. 2-5: wf_auto2.
    pose proof (EG := Ex_gen Γ (ϕ^{evar:0↦x}) (foldr patt_imp g (l₁ ++ l₂)) x).
    simpl in *. unfold exists_quantify in EG.
    apply EG in H. 2: try_solve_pile.
    2: { clear EG H Hi. solve_free_evars 1. }
    clear EG.
    rewrite evar_quantify_evar_open in H. assumption. wf_auto2.
    assumption.
  Defined.

  Lemma MLGoal_destructEx Γ l₁ l₂ g (x : evar) name ϕ i :
    ProofInfoLe (ExGen := {[x]}, SVSubst := ∅, KT := false, AKT := false) i ->
    x ∉ free_evars_of_list (map nh_patt l₁) ->
    x ∉ free_evars_of_list (map nh_patt l₂) ->
    x ∉ free_evars ϕ ->
    x ∉ free_evars g ->
    mkMLGoal _ Γ (l₁ ++ (mkNH _ name ϕ^{evar:0 ↦ x}) :: l₂) g i ->
    mkMLGoal _ Γ (l₁ ++ (mkNH _ name (ex, ϕ)) :: l₂) g i.
  Proof.
    unfold of_MLGoal in *. simpl in *. intros Hi Hf1 Hf2 Hf3 Hf4 H Hwf Hwfl.
    unfold patterns_of in *. rewrite map_app. rewrite map_app in Hwfl.
    simpl in *.
    eapply exists_elim with (x := x).
    1-3: wf_auto2.
    try_solve_pile.
    1-4: solve_free_evars 5.
    rewrite map_app in H. simpl in H.
    apply H; wf_auto2.
  Defined.

End with_signature.

Open Scope ml_scope.
Open Scope string_scope.

Ltac solve_fresh :=
  (eapply not_elem_of_larger_impl_not_elem_of;
  [|apply x_eq_fresh_impl_x_notin_free_evars; reflexivity];
  simpl; clear; set_solver) +
  by (unfold evar_is_fresh_in;
  eapply evar_is_fresh_in_richer'; [|apply set_evar_fresh_is_fresh'];
  clear; set_solver).

Tactic Notation "mlIntroAll" constr(x) :=
_ensureProofMode;
apply (MLGoal_forallIntro _ _ _ x);
[   try subst x; try solve_fresh; try solve_free_evars 10
  | try subst x; try solve_fresh; try solve_free_evars 10
  | try subst x; try_solve_pile
  | unfold evar_open; mlSimpl;
    repeat (rewrite bevar_subst_not_occur; [by wf_auto2|])
].

Local Example forall_test_1 {Σ : Signature} Γ ϕ:
  well_formed ϕ ->
  Γ ⊢ all , (ϕ ---> ϕ and ϕ).
Proof.
  intro.
  toMLGoal. wf_auto2.
  mlIntroAll (fresh_evar ϕ).
  mlIntro "A". mlSplitAnd; mlAssumption.
Qed.

Local Example forall_test_2 {Σ : Signature} Γ ϕ ψ x:
  well_formed ϕ -> well_formed (ex, ψ) ->
  x ∉ free_evars ϕ ->
  x ∉ free_evars ψ ->
  Γ ⊢ ϕ ---> ψ^{evar:0 ↦ x} ->
  Γ ⊢ (ϕ ---> all, ψ).
Proof.
  intros.
  toMLGoal. wf_auto2.
  mlIntro. mlIntroAll x.
  by fromMLGoal.
Qed.

Tactic Notation "mlRevertAll" constr(x) :=
  _ensureProofMode;
  apply (MLGoal_revertAll _ _ _ x).

Local Example revert_test {Σ : Signature} Γ ϕ ψ x:
  well_formed ϕ -> well_formed (ex, ψ) ->
  x ∉ free_evars ϕ ->
  x ∉ free_evars ψ ->
  Γ ⊢ (ϕ ---> all, ψ) ->
  Γ ⊢ ϕ ---> ψ^{evar:0 ↦ x}.
Proof.
  intros.
  toMLGoal. wf_auto2.
  mlIntro. mlRevertAll x.
  rewrite evar_quantify_evar_open. 2: wf_auto2. assumption.
  by fromMLGoal.
Qed.

Local Example forall_revert_test_1 {Σ : Signature} Γ ϕ ψ:
  well_formed ϕ -> well_formed (ex, ψ) ->
  Γ ⊢ (ϕ ---> all, ψ) ->
  Γ ⊢ all, ϕ ---> ψ.
Proof.
  intros.
  remember (fresh_evar (ψ $ ϕ)) as x.
  toMLGoal. wf_auto2.
  mlIntroAll x.
  mlIntro. mlRevertAll x.
  fold (evar_open x 0 ψ).
  rewrite evar_quantify_evar_open. 1: subst x; solve_fresh.
  1: wf_auto2.
  by fromMLGoal.
Qed.

Local Example forall_revert_test_2 {Σ : Signature} Γ ϕ ψ ξ:
  well_formed ξ -> well_formed ϕ -> well_formed (ex, ψ) ->
  Γ ⊢ (ξ ---> ϕ ---> all, ψ) ->
  Γ ⊢ all, ξ ---> ϕ ---> ψ.
Proof.
  intros.
  remember (fresh_evar (ξ $ ψ $ ϕ)) as x.
  toMLGoal. wf_auto2.
  mlIntroAll x.
  do 2 mlIntro. mlRevertAll x.
  fold (evar_open x 0 ψ).
  rewrite evar_quantify_evar_open. 1: subst x; solve_fresh.
  1: wf_auto2.
  by fromMLGoal.
Qed.

Local Example destruct_or_f {Σ : Signature} Γ ϕ₁ ϕ₂ ψ:
  well_formed (ex, ϕ₁) -> well_formed (ex, ϕ₂) -> well_formed (ex, ψ) ->
  Γ ⊢ all, ϕ₁ ---> ψ -> Γ ⊢ all, ϕ₂ ---> ψ ->
  Γ ⊢ all, ϕ₁ or ϕ₂ ---> ψ.
Proof.
  intros.
  remember (fresh_evar (ψ $ ϕ₁ $ ϕ₂)) as x.
  toMLGoal. wf_auto2.
  mlIntroAll x.
  mlIntro. mlDestructOr "0".
  * mlRevertLast. mlRevertAll x. simpl.
    fold (evar_open x 0 ψ).
    rewrite evar_quantify_evar_open. 1: subst x; solve_fresh.
    1: wf_auto2.
    fold (evar_open x 0 ϕ₁).
    rewrite evar_quantify_evar_open. 1: subst x; solve_fresh.
    1: wf_auto2.
    by fromMLGoal.
  * mlAdd H3.
    mlRevertLast. mlRevertAll x. simpl.
    fold (evar_open x 0 ψ).
    rewrite evar_quantify_evar_open. 1: subst x; solve_fresh.
    1: wf_auto2.
    fold (evar_open x 0 ϕ₁).
    rewrite evar_quantify_evar_open. 1: subst x; solve_fresh.
    1: wf_auto2.
    mlAssumption.
Qed.

Tactic Notation "mlSpecialize" constr(name') "with" constr(var) :=
_ensureProofMode;
_mlReshapeHypsByName name';
apply (MLGoal_specializeAll _ _ _ _ _ var);
_mlReshapeHypsBack.

(* revert is a corollary of specialize: *)
Local Lemma Private_revert_forall_iter {Σ : Signature} (Γ : Theory) :
  forall (l : list Pattern) (ϕ : Pattern) x,
  Pattern.wf l ->
  well_formed ϕ ->
  Γ ⊢i foldr patt_imp (all , ϕ^{{evar: x ↦ 0}}) l ---> foldr patt_imp ϕ l
    using BasicReasoning.
Proof.
  intros l ϕ x Wfl Wfϕ. apply prf_weaken_conclusion_iter_meta. 1-3: wf_auto2.
  mlIntro "H".
  mlSpecialize "H" with x.
  rewrite evar_open_evar_quantify. wf_auto2.
  mlAssumption.
Qed.

Tactic Notation "mlExists" constr(var) :=
_ensureProofMode;
apply (MLGoal_exists _ _ _ var);
try (rewrite evar_open_evar_quantify;[by wf_auto2|]).

Local Lemma exists_test_1 {Σ : Signature} Γ ϕ :
  well_formed (ex, ϕ) ->
  Γ ⊢ (all, ϕ) ---> (ex, ϕ).
Proof.
  intro WF.
  mlIntro "H".
  remember (fresh_evar patt_bott) as y.
  (* we can prove this with a y which is not necessarily equal to x too, but it is tricky. *)
  mlSpecialize "H" with y.
  mlExists y.
  mlAssumption.
Qed.

Tactic Notation "mlDestructEx" constr(name') "as" constr(x) :=
_ensureProofMode;
_mlReshapeHypsByName name';
apply (MLGoal_destructEx _ _ _ _ x name');[
    try subst x; try_solve_pile
  | try subst x; try solve_fresh; try solve_free_evars 10
  | try subst x; try solve_fresh; try solve_free_evars 10
  | try subst x; try solve_fresh; try solve_free_evars 10
  | try subst x; try solve_fresh; try solve_free_evars 10
  | _mlReshapeHypsBack].

Local Lemma destructEx_Test {Σ : Signature} Γ ϕ ψ :
  well_formed (ex, ϕ) -> well_formed (ex, ψ) ->
  Γ ⊢ (ex, ϕ and ψ) ---> ex, ϕ.
Proof.
  intros WF1 WF2.
  mlIntro "H".
  remember (fresh_evar (ϕ $ ψ)) as x.
  mlDestructEx "H" as x. mlSimpl.
  mlDestructAnd "H".
  mlExists x.
  mlAssumption.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (Succ (plus lv0 lv1)) (plus lv0 (Succ lv1))).
Admitted.
QuickChick conj15eqsynthconj4.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RVIC2.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition rvic_clear_masked_spec (rvic: Pointer) (intid: Z64) (adt: RData) : option RData :=
    match intid with
    | VZ64 intid =>
      rely is_int64 intid;
      rely (peq (base rvic) rvic_loc);
      rely prop_dec (0 <= offset rvic < 16);
      let idx := intid / 64 in
      let bit := intid mod 64 in
      rely prop_dec (0 <= idx < 512);
      let slot := offset rvic in
      when gidx == ((buffer (priv adt)) @ slot);
      let gn := (gs (share adt)) @ gidx in
      rely g_tag (ginfo gn) =? GRANULE_STATE_REC;
      rely prop_dec (glock gn = Some CPU_ID);
      let bits := (r_mask_bits (g_rvic (gnorm gn))) @ idx in
      let bits' := Z.land bits (Z.lnot (Z.shiftl 1 bit)) in
      let rvic' := (g_rvic (gnorm gn)) {r_mask_bits: (r_mask_bits (g_rvic (gnorm gn))) # idx == bits'} in
      let g' := gn {gnorm: (gnorm gn) {g_rvic: rvic'}} in
      Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
    end.

End Spec.