(* begin hide *)
Require Export HoTT Ch03.
Require Import HIT.TwoSphere.
(* end hide *)
(** printing <~> %\ensuremath{\eqvsym}% **)
(** printing == %\ensuremath{\sim}% **)
(** printing ^-1 %\ensuremath{^{-1}}% **)
(** * Equivalences *)

(** %\exer{4.1}{147}%
Consider the type of ``two-sided adjoint equivalence data'' for $f : A \to B$,
%\[
  \sm{g:B \to A}
  \sm{\eta : g \circ f \sim \idfunc{A}}
  \sm{\epsilon : f \circ g \sim \idfunc{B}}
  \left(\prd{x:A} f(\eta x) = \epsilon(f x)\right)
    \times
  \left(\prd{y:B} g(\epsilon y) = \eta(g y)\right)
\]%
By Lemma 4.2.2, we know that if $f$ is an equivalence, then this type is
inhabited.  Give a characterization of this type analogous to Lemma 4.1.1.
Give an example showing that this type is not generally a mere proposition.
*)

(** %\soln%
If $f : A \to B$ is an equivalence, then this type is equivalent to
$\prd{x:A}(\refl{x} = \refl{x})$.  The idea is that the extra half-adjoint
data pins down the path $x = x$ to $\refl{x}$, but the further data allows for
nontrivial paths $\refl{x} = \refl{x}$. To fix this one would have to
add another higher coherence condition.

To prove this, suppose that $e : \isequiv(f)$, so $(f, e) : \eqv{A}{B}$.  By
univalence, we may assume that $(f, e)$ is of the form $\idtoeqv(r)$ for some
$r : A = B$, and by path induction we can assume this is $\refl{A}$, so
$\idtoeqv(r)$ is $\idfunc{A}$.  Now our type reduces to
%\[
  \sm{g:A \to A}
  \sm{\eta : g \sim \idfunc{A}}
  \sm{\epsilon : g \sim \idfunc{A}}
  \left(\eta \sim \epsilon \right)
    \times
  \left((\lam{x}g(\epsilon x)) \sim (\lam{x}\eta(g x))\right)
\]%
and by function extensionality and associativity of $\Sigma$ types this is
equivalent to
%\[
  \sm{h : \sm{g:A \to A} (g = \idfunc{A})}
  \sm{\epsilon : \fst(h) = \idfunc{A}}
  \left(\snd(h) = \epsilon \right)
    \times
  \left((\lam{x}(\fst(h))(\epsilon x)) = (\lam{x}(\snd(h))((\fst(h)) x))\right)
\]%
But $\sm{g : A \to A}(g = \idfunc{A})$ is contractible with center
$(\idfunc{A}, \refl{\idfunc{A}})$, so our type is equivalent to
%\[
  \sm{\epsilon : \idfunc{A} = \idfunc{A}}
  \left(\refl{\idfunc{A}} = \epsilon \right)
    \times
  \left(\epsilon = \refl{\idfunc{A}}\right)
\]%
again by associativity, this is equivalent to
%\[
  \sm{h: \sm{\epsilon : \idfunc{A} = \idfunc{A}} (\epsilon =
  \refl{\idfunc{A}})}
  \left(\fst(h) = \refl{\idfunc{A}}\right)
\]%
and again we can apply 3.11.9 to obtain the equivalent $\refl{\idfunc{A}} =
\refl{\idfunc{A}}$.  By function extensionality, this is equivalent to
%\[
  \prd{x:A}(\refl{x} = \refl{x})
\]%

This type is not generally a mere proposition.  Clearly one term of this type is $x
\mapsto \refl{x}$.  In the case of $X \jdeq \Sn^{2}$, we get a different
inhabitant by sending $\base$ to $\surf$.  This is a generalization of Lemmas
6.4.1 and 6.4.2 of the HoTT Book.
*)

Theorem ex4_1 `{Univalence} (A B : Type) (f : A <~> B) :
  {g : B -> A & {h : g o f == idmap & {e : f o g == idmap &
    (forall x, ap f (h x) = e (f x)) * (forall y, ap g (e y) = h (g y))}}}
  <~>
  forall x : A, @idpath _ x = @idpath _ x.
Proof.
  set (p := path_universe f).
  assert (fisp : f = equiv_path _ _ p).
    apply path_equiv. apply path_forall; intro a. simpl.
    unfold p. symmetry. apply transport_path_universe.
  clearbody p. induction p. rewrite fisp. simpl.

  equiv_via ({g : A -> A & {h : g == idmap & {e : g == idmap &
    (h == e)
  * ((fun y => ap g (e y)) == (fun y => h (g y)))}}}).
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro g. simpl.
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro h. simpl.
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro e. simpl.
  simple refine (equiv_functor_prod' _ _).
  simple refine (equiv_functor_forall' _ _). apply equiv_idmap. intro b. simpl.
  simple refine (equiv_adjointify _ _ _ _).
    intro eq. apply ((ap_idmap _)^ @ eq).
    intro eq. apply ((ap_idmap _) @ eq).
    intro eq. hott_simpl.
    intro eq. hott_simpl.
  apply equiv_idmap.

  equiv_via ({g : A -> A & {h : g == idmap & {e : g == idmap &
   (h = e) * ((fun y => ap g (e y)) = (fun y => h (g y)))}}}).
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro g. simpl.
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro h. simpl.
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro e. simpl.
  simple refine (equiv_functor_prod' _ _).
  apply equiv_path_forall.
  apply equiv_path_forall.

  equiv_via ({h : {g : A -> A & g == idmap} & {e : h.1 == idmap &
   (h.2 = e) * ((fun y => ap h.1 (e y)) = (fun y => h.2 (h.1 y)))}}).
  refine (equiv_sigma_assoc _ _).

  transparent assert (HC : (Contr {g : A -> A & g == idmap})).
  exists (idmap; (fun x => 1)).
  intro h. destruct h as [g h].
  apply path_sigma_uncurried. simpl.
  exists (path_forall (fun x : A => x) g (fun x : A => (h x)^)).
  unfold pointwise_paths.
  apply path_forall; intro a.
  refine ((transport_forall_constant _ _ _) @ _).
  refine ((@path_forall_1_beta _ A (fun _ => A) a (fun z => z = a)
                               idmap g _ 1) @ _).
  refine ((transport_paths_l _ _) @ _).
  refine ((concat_p1 _) @ _).
  apply inv_V.
  equiv_via ({e : (center {g : A -> A & g == idmap}).1 == idmap &
   ((center {g : A -> A & g == idmap}).2 = e)
   * ((fun y => ap (center {g : A -> A & g == idmap}).1 (e y))
      = (fun y => (center {g : A -> A & g == idmap}).2
                     ((center {g : A -> A & g == idmap}).1 y)))}).
  refine (equiv_sigma_contr_base _ _ _).
  simpl. clear HC.

  equiv_via ({e : (fun x : A => x) == idmap &
             {p : (fun x => 1) = e
             & ((fun y : A => ap idmap (e y)) = (fun y : A => 1))}}).
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro e.
  simple refine (equiv_adjointify _ _ _ _); simpl.
  intro p. apply (fst p; snd p).
  intro p. split. apply p.1. apply p.2.
  intro p. simpl. apply eta_sigma.
  intro p. simpl. apply eta_prod.

  equiv_via ({h : {e : (fun x:A => x) == idmap & (fun x => 1) = e}
                    & (fun y : A => ap idmap (h.1 y)) = (fun y : A => 1)}).
  refine (equiv_sigma_assoc _ _).

  equiv_via ({h : {e : (fun x:A => x) == idmap & (fun x : A => 1) = e}
                    & (fun y : A => h.1 y) = (fun y : A => 1)}).
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro e. simpl.
  simple refine (equiv_adjointify _ _ _ _); simpl.
  intro eq. apply path_forall; intro a. refine (_ @ (apD10 eq a)).
    apply (ap_idmap _)^.
  intro eq. apply path_forall; intro a. refine ((ap_idmap _) @ _).
    apply (apD10 eq a).
  intro eq. refine (_ @ (eta_path_forall _ _ _)).
    apply (ap (path_forall _ _)). apply path_forall; intro a.
    apply moveR_Vp. refine ((apD10_path_forall _ _ _ a) @ _).
    reflexivity.
  intro eq. refine (_ @ (eta_path_forall _ _ _)).
    apply (ap (path_forall _ _)). apply path_forall; intro a.
    apply moveR_Mp. refine ((apD10_path_forall _ _ _ a) @ _).
    reflexivity.

  equiv_via ((fun y : A => (center {e : (fun x:A => x) == idmap & (fun x : A => 1) = e}).1 y) = (fun y : A => 1)).
  simple refine (equiv_sigma_contr_base _ _ _).

  simple refine (equiv_adjointify _ _ _ _).
  - intro eq. intro x. refine (_ @ (apD10 eq x)).
    apply (apD10 (center {e: (fun x:A => x) == idmap & (fun x:A => 1) = e}).2 x).
  - intro eq. apply path_forall. intro y.
    refine (_ @ (eq y)).
    apply (apD10 (center {e: (fun x:A => x) == idmap & (fun x:A => 1) = e}).2^ y).
  - intro eq. apply path_forall. intro x.
    apply moveR_Mp. refine ((apD10_path_forall _ _ _ _) @ _).
    refine (whiskerR _ (eq x)). refine (apD10_V _ x).
  - intro eq. apply (ap apD10)^-1. apply path_forall. intro x.
    refine ((apD10_path_forall _ _ _ _) @ _). apply moveR_Mp.
    refine (whiskerR _ (apD10 eq x)).
    refine (_ @ (apD10_V _ _)). f_ap.
Defined.

Lemma not_all_sets `{Univalence} : ~ forall A, IsHSet A.
Proof.
  intro oops.
  apply idmap_bool_ne_negb.
  refine ((equiv_path_path_universe _)^ @ _).
  refine (_ @ (equiv_path_path_universe _)). f_ap.
  apply oops.
Defined.

Lemma loop_ne_1 `{Univalence} : loop <> 1.
Proof.
  intro oops.
  apply not_all_sets. intros A x y. apply hprop_allpath.
  intros p q. induction q.
  refine ((S1_rec_beta_loop A x p)^ @ _).
  refine (ap (ap _) oops).
Defined.

Lemma Book_6_4_2 `{Univalence} : {h : forall (x : S1), x = x & h <> (fun x => 1)}.
Proof.
  simple refine (S1_ind _ loop _; _).
  - refine ((transport_paths_lr _ _) @ _).
    refine ((ap (fun w => w @ _) (concat_Vp _)) @ _).
    refine (concat_1p _).
  - intro oops. apply loop_ne_1.
    apply (apD10 oops Circle.base).
Defined.

Definition not_all_1type `{U : Univalence} : ~ (forall A, IsTrunc 1 A).
Proof.
  intro oops. apply Book_6_4_2.2.
  simple refine (equiv_hprop_allpath _ _ _ _).
  simple refine (trunc_equiv (@paths (S1 -> S1) idmap idmap) _).
  - apply apD10.
  - simple refine (trunc_equiv (@equiv_idmap S1 = @equiv_idmap S1)
                        (@path_equiv _ _ _ 1%equiv 1%equiv)^-1).
    apply hprop_allpath. simple refine (@set_path2 (S1 <~> S1) _ _ _).
    simple refine (trunc_equiv (S1 = S1) _).
    + apply equiv_path.
    + apply isequiv_equiv_path.
  - apply isequiv_apD10.
Defined.

Definition surf_ne_1 `{Univalence} : surf <> 1.
Proof.
  intro oops. apply not_all_1type.
  intros A x y p q. apply hprop_allpath. intros r s.
  induction s, p.
  refine ((S2_rec_beta_surf A x r)^ @ _).
  refine (ap (ap02 _) oops).
Defined.

Definition ap_homotopic {A B : Type} (f g : A -> B) (h : f == g)
         {x y : A} (q : x = y)
: ap f q = h x @ ap g q @ (h y)^.
Proof.
  apply moveL_pV. apply concat_Ap.
Defined.

Definition Book_6_4_2' `{Univalence}
: {h : forall x : S2, (idpath x) = 1 & h <> (fun x => 1)}.
Admitted.

Definition ex4_1' `{Univalence} : ~ IsHProp (forall x : S2, (idpath x) = 1).
Proof.
  intro oops. apply Book_6_4_2'.2.
  apply (equiv_hprop_allpath _ _ _ _).
Defined.

(** %\exerdone{4.2}{147}%
Show that for any $A, B : \UU$, the following type is equivalent to $A \eqvsym
B$.
%\[
  \sm{R : A \to B \to \UU}
  \left(\prd{a:A} \iscontr \left(\sm{b:B} R(a, b)\right)\right)
  \times
  \left(\prd{b:B} \iscontr \left(\sm{a:A} R(a, b)\right)\right).
\]%
Extract from this a definition of a type satisfying the three desiderata of
$\isequiv(f)$.
*)

(** %\soln%
Suppose that this type is inhabited; by induction we may suppose that the
inhabitant breaks down into
%\begin{align*}
  R &: A \to B \to \UU \\
  f &: \prd{a:A} \iscontr\left(\sm{b:B}R(a, b)\right) \\
  g &: \prd{b:B} \iscontr\left(\sm{a:A}R(a, b)\right)
\end{align*}%
We have to construct an element $e : \eqv{A}{B}$.  For the forward map, suppose
that $a : A$.  Then
%\[
  f(a) : \iscontr\left(\sm{b:B}R(a, b)\right)
\]%
so there is some $(b, p) : \sm{b:B}R(a,b)$, and we set $e(a) \defeq b$.  For
the inverse, suppose that $b:B$.  Then $g(b) : \iscontr(\sm{a:A}R(a, b))$, so
there is some center $(a, p) : \sm{a:A}R(a,b)$, and we set $e^{-1}(b) \defeq
a$.  To prove that these are quasi-inverses, suppose that $a : A$.  Then $f(a)
: \iscontr(\sm{b:B}R(a,b))$, so the center is $(b, p) : \sm{b:B}R(a,b)$ and
$e(a) \equiv b$.  But then $g(e(a)) : \iscontr(\sm{a:A}R(a, b))$, and the
center of this is $(a', q) : \sm{a:A}R(a,b)$, so $e^{-1}(e(a)) = a'$.  But
now we have $(a, p) : \sm{a:A}R(a, b)$, and since this type is contractible we
have $(a, q) = (a', p)$, hence $e^{-1}(e(a)) = a' = a$.  The other direction
goes just the same way.

For the other direction, suppose that $e : \eqv{A}{B}$, and consider the
relation $R \defeq \lam{a}{b}(e(a) = b) : A \to B \to \UU$.  For any $a : A$,
$\sm{b:B}(e(a) = b)$ is contractible by Lemma 3.11.8.  For any $b:B$,
$\sm{a:A}(e(a) = b)$ is equivalent to $\sm{a:A}(e^{-1}(b) = a)$, and this is
also contractible by Lemma 3.11.8.  So we have an element of the type above.

To show that these are quasi-inverses, let $e : \eqv{A}{B}$, and take it once
around the loop to get an equivalence with underlying map $e : A \to B$.  Since
an equivalence is determined by its underlying map, we're back where we
started.  For the other direction, suppose that we have an element of the type
in the problem statement, and take it once around the loop.  Since
contractibility is a mere proposition and products preserve these, it suffices
to show that the first components are equal, or that $(b' = b) = R(a, b)$ for
$b'$ the center of $\sm{b:B}R(a, b)$.  By univalence it suffices to show that
these are equivalent, and since they are mere propositions it suffices to show
that they logically imply one another.  Transport gives us the first
direction, and the other is given by the contractibility of $\sm{b:B}R(a, b)$.
So we've established an equivalence.

For $f : A \to B$, define
%\[
  \isequiv'(f) \defeq
  \left(\prd{a:A}\iscontr\left(\sm{b:B}(f(a) = b)\right)\right)
  \times
  \left(\prd{b:B}\iscontr\left(\sm{a:A}(f(a) = b)\right)\right)
\]%
To show that desideratum (i) is satisfied, suppose that $p : \qinv(f)$.  Then
$\isequiv(f)$ is inhabited, so $\eqv{A}{B}$ is as well.  But then the
equivalence just established gives us an element whose second entry is an
element of $\isequiv'(f)$.  So we have an arrow $\qinv(f) \to \isequiv'(f)$.
For the other direction, suppose that we have an element $p : \isequiv'(f)$.
Then $\lam{a}{b}(f(a) = b)$ gives us an element that our equivalence takes to
$\eqv{A}{B}$, and the second element of this is of type $\isequiv(f)$.  But
then we have $\isequiv(f) \to \qinv(f)$, so our desideratum is satisfied.
Finally, $\isequiv'(f)$ is constructed out of products of mere propositions, so
it too is a mere proposition.
*)

Definition equiv_to_contr_rel_equiv (A B : Type) :
  (A <~> B)
  ->
  {R : A -> B -> Type & (forall a, Contr {b : B & R a b})
                      * (forall b, Contr {a : A & R a b})}.
Proof.
  intro e.
  exists (fun a b => (e a = b)). split.
  intro a. apply contr_basedpaths.
  intro b. refine (@contr_equiv' {a : A & e^-1 b = a} _ _ _).
  simple refine (equiv_functor_sigma' _ _).
  apply equiv_idmap. intro a. simpl.
  simple refine (equiv_adjointify _ _ _ _).
  intro eq. simple refine (_ @ (eisretr e b)). apply (ap e). apply eq^.
  intro eq. simple refine (_ @ (eissect e a)). apply (ap e^-1). apply eq^.
  intro eq. induction eq. simpl.
  apply moveR_pM. refine (_ @ (concat_1p _)^). refine ((ap_V _ _) @ _).
  apply inverse2. refine ((ap_pp _ _ _) @ _).
  apply moveR_pM. refine ((ap_1 _ _ ) @ _). apply moveL_pV.
  refine ((concat_1p _) @ _). apply (eisadj e a)^.

  intro eq. induction eq. simpl.
  apply moveR_pM. refine ((ap_V _ _) @ _). refine (_ @ (concat_1p _)^).
  apply inverse2. refine ((ap_pp _ _ _) @ _). apply moveR_pM.
  refine ((ap_1 _ _) @ _). apply moveL_pV. refine ((concat_1p _) @ _).
  apply (other_adj _ _)^.
Defined.

Theorem isequiv_equiv_to_contr_rel_equiv `{Univalence} (A B : Type) :
  IsEquiv (equiv_to_contr_rel_equiv A B).
Proof.
  simple refine (isequiv_adjointify _ _ _ _).
  intro R. destruct R as [R [f g]].
  simple refine (equiv_adjointify _ _ _ _).
  intro a. apply (center {b : B & R a b}).1.
  intro b. apply (center {a : A & R a b}).1.

  intro b. simpl.
  destruct (center {a : A & R a b}) as [a p]. simpl.
  destruct (center {b0 : B & R a b0}) as [b' q]. change b with (b; p).1.
  apply (ap pr1). apply path_ishprop.

  intro a. simpl.
  destruct (center {b : B & R a b}) as [b q]. simpl.
  destruct (center {a0 : A & R a0 b}) as [a' p].
  change a with (@pr1 _ (fun a' => R a' b) (a; q)).
  apply (ap pr1). apply path_ishprop.

  intro R. apply path_sigma_hprop. destruct R as [R [f g]]. simpl.
  apply path_forall; intro a. apply path_forall; intro b.
  destruct (center {b0 : B & R a b0}) as [b' p]. simpl.
  apply path_universe_uncurried.
  simple refine (equiv_adjointify _ _ _ _).
  intro eq. apply (transport _ eq). apply p.
  intro q. change b with (b; q).1. change b' with (b'; p).1. apply (ap pr1).
  refine (path_contr _ _). apply (f a).
  intro q. refine ((pr2_path (path_contr (b'; p) (b; q))) @ _). reflexivity.
  intro eq. induction eq. simpl.
  path_via (@ap {b : B & R a b} _ pr1 (b'; p) _ 1). f_ap.
  apply concat_Vp.

  intro e. apply path_equiv. reflexivity.
Defined.

Definition qinv {A B : Type} (f : A -> B) :=
  {g : B -> A & (f o g == idmap) * (g o f == idmap)}.

Definition qinv_isequiv A B (f : A -> B) (p : qinv f) : IsEquiv f
  := isequiv_adjointify f p.1 (fst p.2) (snd p.2).

Definition isequiv_qinv : forall A B (f : A -> B), IsEquiv f -> qinv f.
Proof.
  intros A B f p. destruct p.
  exists equiv_inv. split. apply eisretr. apply eissect.
Defined.

Definition isequiv' {A B} (f : A -> B) :=
  (forall a, Contr {b : B & f a = b}) * (forall b, Contr {a : A & f a = b}).

Theorem ex4_2_i A B (f : A -> B) : qinv f -> isequiv' f.
Proof.
  intro p. apply qinv_isequiv in p.
  set (Hf := BuildEquiv A B f p).
  set (HR := equiv_to_contr_rel_equiv A B Hf).
  set (R := pr1 HR).
  set (Q := pr2 HR).
  split. apply (fst Q). apply (snd Q).
Defined.

Theorem ex4_2_ii A B (f : A -> B) : isequiv' f -> qinv f.
Proof.
  intro p. destruct p as [sect retr].
  transparent assert (g : (B -> A)).
  intro b. destruct (retr b). apply center.1.
  exists g. split.
  unfold g. intro b. destruct (retr b). apply center.2.
  unfold g. intro a. destruct (retr (f a)).
  apply (ap pr1 (contr (a; 1))).
Defined.

Lemma hprop_prod : forall A, IsHProp A -> forall B, IsHProp B -> IsHProp (A * B).
Proof.
  intros A HA B HB z z'.
  apply (trunc_equiv' _ (equiv_path_prod z z')).
Defined.

Theorem ex4_2_iii `{Funext} A B (f : A -> B) : IsHProp (isequiv' f).
Proof.
  unfold isequiv'.
  typeclasses eauto.
Defined.

(** %\exerdone{4.3}{147}%
Reformulate the proof of Lemma 4.1.1 without using univalence.
*)

(** %\soln%
Suppose that $f : A \to B$ such that $\qinv(f)$ is inhabited.  To show that
$\qinv(f) \eqvsym \prd{x:X}(x=x)$, note that by associativity we have
%\[
  \qinv(f) \eqvsym
  \sm{h : \sm{g : B \to A}(f \circ g \sim \idfunc{A})}
    (\fst(h) \circ f \sim \idfunc{A})
\]%
Now, because $f$ is an equivalence, by function extensionality $f \circ g \sim
\idfunc{A}$ is equivalent to $g = f^{-1}$.  But then $\sm{g : B \to A}(g =
f^{-1})$ is contractible with center $(f^{-1}, \refl{f^{-1}})$, so we've
reduced to the type $f^{-1} \circ f \sim \idfunc{A}$.  Again by function
extensionality, this is equivalent to $\prd{x:A}(x=x)$.
*)

Theorem concat_Ap_w (A B : Type) (f g : A -> B) (p : forall x : A, f x = g x)
         (x y : A) (q : x = y)
  : ap f q  = p x @ ap g q @ (p y)^.
Proof.
  apply moveL_pV. apply concat_Ap.
Defined.

Theorem Book_4_1_1 `{Funext} (A B : Type) (f : A <~> B) :
  qinv f <~> forall x : A, x = x.
Proof.
  unfold qinv.
  equiv_via ({h : {g : B -> A & (f o g == idmap)} & (h.1 o f == idmap)}).
  simple refine (equiv_adjointify _ _ _ _).
  intro w. exists (w.1; fst w.2). apply (snd w.2).
  intro w. exists w.1.1. split. apply w.1.2. apply w.2.
  intro w. destruct w as [[g h] e]. reflexivity.
  intro w. destruct w as [g [h e]]. reflexivity.

  transparent assert (H' : (Contr {g : B -> A & f o g == idmap})).
  exists (f^-1; eisretr f). intro h. destruct h as [w h].
  apply path_sigma_uncurried. simpl.
  exists (path_forall f^-1 w (fun b : B => ap f^-1 (h b)^ @ eissect f (w b))).
  unfold pointwise_paths.
  apply path_forall; intro b.
  refine ((transport_forall_constant _ _ _) @ _).
  refine ((@path_forall_1_beta _ B (fun _ => A) b (fun z => f z = b) _ _ _ _)
            @ _).
  refine ((transport_paths_Fl _ _) @ _).
  apply moveR_Vp. apply moveL_pM.
  refine (_ @ (ap_pp _ _ _)^).
  apply moveL_Mp. refine (_ @ (eisadj _ _)).
  apply moveR_Vp. apply moveL_pM.
  refine (_ @ (ap_compose _ _ _)).
  refine (_ @ (concat_Ap_w _ _ _ idmap (eisretr f) _ _ _)^).
  apply concat2. apply concat2. reflexivity. apply (ap_idmap _)^. reflexivity.

  equiv_via ((center {g : B -> A & f o g == idmap}).1 o f == idmap).
  refine (equiv_sigma_contr_base _ _ _).
  simpl. clear H'.

  simple refine (equiv_adjointify _ _ _ _).
  intro h. apply path_forall in h. intro x. refine ((eissect f _)^ @ _).
  apply (ap10 h x).
  intro h. intro x. refine ((eissect f _) @ _). apply (h x).
  intro h. apply path_forall; intro a.
  apply moveR_Vp. refine ((ap10_path_forall _ _ _ a) @ _). reflexivity.
  intro h. apply path_forall; intro a.
  apply moveR_Mp. apply concat2. reflexivity.
  refine ((ap10_path_forall _ _ _ a) @ _). reflexivity.
Defined.

(** %\exerdone{4.4}{147}%
Suppose $f : A \to B$ and $g : B \to C$ and $b : B$.
%\begin{itemize}
  \item[(i)] Show that there is a natural map $\hfib{g \circ f}{g(b)} \to
      \hfib{g}{g(b)}$ whose fiber over $(b, \refl{g(b)})$ is equivalent to
      $\hfib{f}{b}$.
  \item[(ii)] Show that $\hfib{g \circ f}{g(b)} \eqvsym \sm{w:\hfib{g}{g(b)}}
      \hfib{f}{\fst w}$.
\end{itemize}%
*)

(** %\soln%
(i) Unfolding the $\mathsf{fib}$ notation, we are looking for a map
%\[
  \left(\sm{a:A} (g(f(a)) = g(b))\right) \to
  \left(\sm{b':B} (g(b') = g(b))\right)
\]%
The obvious choice is $f^{*} \defeq (a, p) \mapsto (f(a), p)$.  We then must
show that $\hfib{f^{*}}{b, \refl{g(b)}} \eqvsym \hfib{f}{b}$.  We have this by
the following chain of equivalences:
%\begin{align*}
  \hfib{f^{*}}{b, \refl{g(b)}}
  &\equiv
  \sm{w : \sm{a:A}(g(f(a)) = g(b))}(f^{*}(w) = (b, \refl{g(b)}))
  \\&\eqvsym
  \sm{a:A}\sm{p : g(f(a)) = g(b)}(f^{*}(a, p) = (b, \refl{g(b)}))
  \\&\equiv
  \sm{a:A}\sm{p : g(f(a)) = g(b)}((f(a), p) = (b, \refl{g(b)}))
  \\&\eqvsym
  \sm{a:A}\sm{p : g(f(a)) = g(b)}\sm{q : f(a) = b} q_{*}(p) = \refl{g(b)}
  \\&\eqvsym
  \sm{a:A}\sm{q : f(a) = b}\sm{p : g(f(a)) = g(b)} q_{*}(p) = \refl{g(b)}
  \\&\eqvsym
  \sm{a:A}\sm{q : f(a) = b}\sm{p : g(f(a)) = g(b)} p = q^{-1}_{*}(\refl{g(b)})
  \\&\eqvsym
  \sm{a:A}(f(a) = b)
  \\&\equiv
  \hfib{f}{b}
\end{align*}%

(ii) In this case it's a bit easier to come up with a chain of equivalences in
the other direction.  We have
%\begin{align*}
  \sm{w : \hfib{g}{g(b)}}\hfib{f}{\fst w}
  &\eqvsym
  \sm{b' : B}\sm{p : g(b') = g(b)} \hfib{f}{b'}
  \\&\eqvsym
  \sm{a:A}\sm{b' : B}\sm{p : g(b') = g(b)} (f(a) = b')
  \\&\eqvsym
  \sm{a:A}\sm{b' : B}\sm{p : f(a) = b'} (g(b') = g(b))
  \\&\eqvsym
  \sm{a:A}\sm{w : \sm{b':B}(f(a) = b')} (g(\fst w) = g(b))
  \\&\eqvsym
  \sm{a:A} (g(f(a)) = g(b))
  \\&\equiv
  \hfib{g \circ f}(g(b))
\end{align*}%
*)

Lemma equiv_prod_unit (A : Type) : A <~> A * Unit.
Proof.
  refine (equiv_adjointify (fun a => (a, tt)) (fun z => fst z) _ _).
  intro z. apply path_prod. reflexivity. apply eta_unit.
  intro a. reflexivity.
Defined.

Module Ex4.

Variables (A B C D : Type) (f : A -> B) (g : B -> C) (b : B).

Definition f_star (z : hfiber (g o f) (g b)) : hfiber g (g b) :=
  (f z.1; z.2).

Theorem ex4_4_i : hfiber (f_star) (b; 1) <~> hfiber f b.
Proof.
  equiv_via {a : A & {p : g (f a) = g b & (f_star (a; p) = (b; 1))}}.
  apply equiv_inverse. refine (equiv_sigma_assoc _ _). unfold f_star. simpl.

  equiv_via {a : A & {p : g (f a) = g b & {q : f a = b &
               transport (fun x => g x = g b) q p = 1}}}.
  refine (equiv_functor_sigma_id _). intro a.
  refine (equiv_functor_sigma_id _). intro p.
  apply equiv_inverse.
  refine (equiv_path_sigma (fun x => g x = g b) (f a; p) (b; 1)).

  equiv_via {a : A & {q : f a = b & {p : g (f a) = g b &
               transport (fun x => g x = g b) q p = 1}}}.
  refine (equiv_functor_sigma_id _). intro a.
  refine (equiv_sigma_comm _ _ _).

  equiv_via {a : A & {q : f a = b & {p : g (f a) = g b &
               p = transport (fun x => g x = g b) q^ 1}}}.
  refine (equiv_functor_sigma_id _). intro a.
  refine (equiv_functor_sigma_id _). intro p.
  refine (equiv_functor_sigma_id _). intro q.
  refine (BuildEquiv _ _ _ (isequiv_moveL_transport_V _ _ _ _)).

  equiv_via {a : A & {q : f a = b & Unit}}.
  refine (equiv_functor_sigma_id _). intro a.
  refine (equiv_functor_sigma_id _). intro p.
  refine equiv_contr_unit.

  refine (equiv_functor_sigma_id _). intro a.
  equiv_via ((f a = b) * Unit). refine (equiv_const_sigma_prod _ _).
  apply equiv_inverse. refine (equiv_prod_unit _).
Defined.

Theorem ex4_4_ii
  : hfiber (g o f) (g b) <~> {w : hfiber g (g b) & hfiber f w.1}.
Proof.
  apply equiv_inverse. unfold hfiber.

  equiv_via {b' : B & {p : g b' = g b & {x : A & f x = b'}}}.
  apply equiv_inverse.
  refine (equiv_sigma_assoc _ _).

  equiv_via {b' : B & {x : A & {_ : g b' = g b & f x = b'}}}.
  refine (equiv_functor_sigma_id _). intro b'.
  refine (equiv_sigma_comm _ _ _).

  equiv_via {x : A & {b' : B & {_ : g b' = g b & f x = b'}}}.
  refine (equiv_sigma_comm _ _ _).

  refine (equiv_functor_sigma_id _). intro a.

  equiv_via {b' : B & {p : f a = b' & g b' = g b}}.
  refine (equiv_functor_sigma_id _). intro b'.
  equiv_via ((g b' = g b) * (f a = b')).
  refine (equiv_const_sigma_prod _ _).
  equiv_via ((f a = b') * (g b' = g b)).
  refine (equiv_prod_symm _ _).
  apply equiv_inverse.
  refine (equiv_const_sigma_prod _ _).

  equiv_via {w : {b' : B & f a = b'} & g w.1 = g b}.
  refine (equiv_sigma_assoc _ _).

  equiv_via (g (center {b' : B & f a = b'}).1 = g b).
  refine (equiv_sigma_contr_base _ _ _). simpl.

  simple refine (equiv_adjointify _ _ _ _).
  - intro eq. apply eq.
  - intro eq. apply eq.
  - intro eq. reflexivity.
  - intro eq. reflexivity.
Defined.

End Ex4.

(** %\exerdone{4.5}{147}%
Prove that equivalences satisfy the _2-out-of-6 property_: given $f : A \to B$
and $g : B \to C$ and $h : C \to D$, if $g \circ f$ and $h \circ g$ are
equivalences, so are $f$, $g$, $h$, and $h \circ g \circ f$.  Use this to give
a higher-level proof of Theorem 2.11.1.
*)

(** %\soln%
Suppose that $g \circ f$ and $h \circ g$ are equivalences.

 - $f$ is an equivalence with quasi-inverse $(g \circ f)^{-1} \circ g$.  It's a
   retract because
   %\begin{align*}
     f \circ (g \circ f)^{-1} \circ g
     &\sim
     (h \circ g)^{-1} \circ (h \circ g) \circ f \circ (g \circ f)^{-1} \circ g
     \\&\sim
     (h \circ g)^{-1} \circ h \circ g
     \\&\sim
     \idfunc{B}
   \end{align*}%
   and a section because $(g \circ f)^{-1} \circ g \circ f \sim \idfunc{A}$.

 - $g$ is an equivalence with quasi-inverse $(h \circ g)^{-1} \circ h$.  First
   we have
   %\begin{align*}
     g \circ (h \circ g)^{-1} \circ h
     &\sim
     g \circ (h \circ g)^{-1} \circ h \circ g \circ f \circ (g \circ f)^{-1}
     \\&\sim
     g \circ f \circ (g \circ f)^{-1}
     \\&\sim
     \idfunc{C}
   \end{align*}%
   and second $(h \circ g)^{-1} \circ h \circ g \sim \idfunc{B}$.

 - $h$ is an equivalence with quasi-inverse $g \circ (h \circ g)^{-1}$.  First,
   $h \circ g \circ (h \circ g)^{-1} \sim \idfunc{D}$, and we have
   $g \circ (h \circ g)^{-1} \circ h \sim \idfunc{C}$ by the previous part.

 - $h \circ g \circ f$ is an equivalence with quasi-inverse $f^{-1} \circ (h
   \circ g)^{-1}$.  Both directions are immediate:
   %\begin{align*}
     h \circ g \circ f \circ f^{-1} \circ (h \circ g)^{-1} &\sim \idfunc{D} \\
     f^{-1} \circ (h \circ g)^{-1} \circ h \circ g \circ f &\sim \idfunc{A}
   \end{align*}%

Now we must give a higher-level proof that if $f : A \to B$ is an equivalence,
then for all $a, a' : A$ so is $\mapfunc{f}$.  This uses the following
somewhat obvious fact, which I don't recall seeing in the text or proving yet:
if $f : A \to B$ is an equivalence and $f \sim g$, then $g$ is an equivalence.
This follows immediately from the assumption of function extensionality, but it
is true even without this assumption.
For any $a : A$ we have $f^{-1}(g(a)) = f^{-1}(f(a)) = a$
and for any $b : B$, $g(f^{-1}(b)) = f(f^{-1}(b)) = b$, giving $\isequiv(g)$.

Consider the sequence
%\[
   \left(a = a'\right) \xrightarrow{\mapfunc{f}}
   \left(f(a) = f(a')\right) \xrightarrow{\mapfunc{f^{-1}}}
   \left(f^{-1}(f(a)) = f^{-1}(f(a'))\right) \xrightarrow{\mapfunc{f}}
   \left(f(f^{-1}(f(a))) = f(f^{-1}(f(a')))\right)
\]%
Since $f$ is an equivalence, we have
%\[
  \alpha : \prd{b:B} f(f^{-1}(b)) = b
  \qquad\qquad
  \beta : \prd{a:A} f^{-1}(f(a)) = a
\]%
For all $p : a = a'$,
$\mapfunc{f^{-1}}(\mapfunc{f}(p)) = \beta_{a} \ct p \ct \beta_{a'}^{-1}$,
which follows from the functorality of $\mapfunc{}$ and the naturality of
homotopies (Lemmas 2.2.2 and 2.4.3).  In other words, the composition of the
first two arrows is homotopic to concatenating with $\beta$ on either side,
which is obviously an equivalence.  Similarly, the composition of the second
two arrows is homotopic to concatenating with the appropriate $\alpha$ on
either side, again an obvious equivalence.  So by the 2-out-of-6 property, the
first arrow is an equivalence, which was to be proved.
*)

Theorem two_out_of_six {A B C D : Type} (f : A -> B) (g : B -> C) (h : C -> D) :
  IsEquiv (g o f) -> IsEquiv (h o g) ->
  (IsEquiv f /\ IsEquiv g /\ IsEquiv h /\ IsEquiv (h o g o f)).
Proof.
  intros Hgf Hhg. split.

  (* case f *)
  refine (isequiv_adjointify f ((g o f) ^-1 o g) _ _).
  intro b.
  change (f (((g o f) ^-1 o g) b)) with ((f o (g o f) ^-1 o g) b).
  assert ((f o (g o f) ^-1 o g) b
          =
          ((h o g) ^-1 o (h o g) o f o (g o f) ^-1 o g) b).
  change (((h o g) ^-1 o (h o g) o f o (g o f) ^-1 o g) b)
         with ((((h o g) ^-1 ((h o g) ((f o (g o f) ^-1 o g) b))))).
  rewrite (eissect (h o g)). reflexivity.
  rewrite X.
  change (((h o g) ^-1 o (h o g) o f o (g o f) ^-1 o g) b)
         with ((((h o g) ^-1 o h) ((((g o f) ((g o f) ^-1 (g b))))))).
  rewrite (eisretr (g o f)).
  change (((h o g) ^-1 o h) (g b)) with (((h o g) ^-1 o (h o g)) b).
  apply (eissect (h o g)).

  intro a. apply (eissect (g o f)).

  split.
  (* case g *)
  refine (isequiv_adjointify g ((h o g) ^-1 o h) _ _).
  intro c.
  change (g (((h o g) ^-1 o h) c)) with ((g o (h o g) ^-1 o h) c).
  assert ((g o (h o g) ^-1 o h) c
          =
          (g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c).
  change ((g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c)
         with (((g o (h o g) ^-1 o h) ((g o f) ((g o f) ^-1 c)))).
  rewrite (eisretr (g o f)). reflexivity.
  rewrite X.
  change ((g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c)
         with (g (((h o g) ^-1 ((h o g) ((f o (g o f) ^-1) c))))).
  rewrite (eissect (h o g)).
  change (g ((f o (g o f) ^-1) c)) with (((g o f) o (g o f) ^-1) c).
  apply (eisretr (g o f)).

  intro b. apply (eissect (h o g)).

  split.
  (* case h *)
  refine (isequiv_adjointify h (g o (h o g) ^-1) _ _).
  intro d. apply (eisretr (h o g)).

  intro c.
  change ((g o (h o g) ^-1) (h c)) with ((g o (h o g) ^-1 o h) c).
  assert ((g o (h o g) ^-1 o h) c
          =
          (g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c).
  change ((g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c)
         with (((g o (h o g) ^-1 o h) ((g o f) ((g o f) ^-1 c)))).
  rewrite (eisretr (g o f)). reflexivity.
  rewrite X.
  change ((g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c)
         with (g ((h o g) ^-1 ((h o g) ((f o (g o f) ^-1) c)))).
  rewrite (eissect (h o g)).
  change (g ((f o (g o f) ^-1) c)) with (((g o f) o (g o f) ^-1) c).
  apply (eisretr (g o f)).

  (* case h o g o f *)
  refine (isequiv_adjointify (h o g o f) ((g o f) ^-1 o g o (h o g) ^-1) _ _).
  intro d.
  change ((h o g o f) (((g o f) ^-1 o g o (h o g) ^-1) d))
         with (h ((g o f) ((g o f) ^-1 ((g o (h o g) ^-1) d)))).
  rewrite (eisretr (g o f)).
  apply (eisretr (h o g)).

  intro a.
  change (((g o f) ^-1 o g o (h o g) ^-1) ((h o g o f) a))
         with ((((g o f) ^-1 o g) ((h o g) ^-1 ((h o g) (f a))))).
  rewrite (eissect (h o g)). apply (eissect (g o f)).
Qed.

Theorem isequiv_homotopic' : forall (A B : Type) (f g : A -> B),
  IsEquiv f -> f == g -> IsEquiv g.
Proof.
  intros A B f g p h.
  refine (isequiv_adjointify g f^-1 _ _).
  intros b. apply ((h (f^-1 b))^ @ (eisretr f b)).
  intros a. apply ((ap f^-1 (h a))^ @ (eissect f a)).
Defined.

Theorem Theorem2111' (A B : Type) (a a' : A) (f : A -> B) (H : IsEquiv f) :
  IsEquiv (fun p : a = a' => ap f p).
Proof.
  apply (two_out_of_six (fun p : a = a' => ap f p)
                        (fun p : (f a) = (f a') => ap f^-1 p)
                        (fun p : (f^-1 (f a)) = (f^-1 (f a')) => ap f p)).
  apply (isequiv_homotopic (fun p => (eissect f a) @ p @ (eissect f a')^)).
  intro p. induction p. hott_simpl.

  apply (isequiv_homotopic (fun p => (eisretr f (f a)) @ p @ (eisretr f (f a'))^)).
  intro p. induction p. hott_simpl.
Defined.

(** %\exer{4.6}{147}%
For $A, B : \UU$, define
%\[
  \mathsf{idtoqinv}(A, B) : (A = B) \to \sm{f : A \to B} \qinv(f)
\]%
by path induction in the obvious way.  Let %\qinv%-univalence denote the
modified form of the univalence axiom which asserts that for all $A, B : \UU$
the function $\mathsf{idtoqinv}(A, B)$ has a quasi-inverse.
%\begin{itemize}
  \item[(i)] Show that \qinv-univalence can be used instead of univalence in
      the proof of function extensionality in \S4.9.
  \item[(ii)] Show that \qinv-univalence can be used instead of univalence in
      the proof of Theorem 4.1.3.
  \item[(iii)] Show that \qinv-univalence is inconsistent.  Thus, the use of a
      ``good'' version of $\isequiv$ is essential in the statement of
      univalence.
\end{itemize}%
*)

(** %\soln%
(i)  The proof of function extensionality uses univalence in the proof of
Lemma 4.9.2.  Assume that $\UU$ is $\qinv$-univalent, and that $A, B, X : \UU$
with $e : A \eqvsym B$.  From $e$ we obtain $f : A \to B$ and $p :
\ishae(f)$, and from the latter we obtain an element $q : \qinv(f)$.
$\qinv$-univalence says that we may write $(f, q) = \mathsf{idtoqinv}_{A,
B}(r)$ for some $r : A = B$.  Then by path induction, we may assume that $r
\equiv \refl{A}$, making $e = \idfunc{A}$, and the function $g \mapsto g \circ
\idfunc{A}$ is clearly an equivalence $(X \to A) \eqvsym (X \to B)$,
establishing Lemma 4.9.2.  Since the rest of the section is either an
application of Lemma 4.9.2 or doesn't use the univalence axiom, the proof of
function extensionality goes through.
*)

Module Ex6.

Hypothesis qinv_univalence : forall A B, qinv (equiv_path A B).

Theorem Book_4_9_2 (A B X : Type) (e : A <~> B) : (X -> A) <~> (X -> B).
Proof.
  destruct e as [f p].
  assert (qinv f) as q. exists f^-1. split.
    apply (eisretr f). apply (eissect f).
  assert (A = B) as r. apply (qinv_univalence A B).
  apply (BuildEquiv _ _ f p).
  path_induction. apply equiv_idmap.
Defined.

(**
(ii) Theorem 4.1.3 provides an example of types $A$ and $B$ and a function $f:
A \to B$ such that $\qinv(f)$ is not a mere proposition, relying on the result
of Lemma 4.1.1.  Since Lemma 4.1.1 does not actually rely on univalence
%(cf.~Exercise 4.3)%, we only need to worry about the use of univalence in the
proof of Theorem 4.1.3.  Define $X \defeq \sm{A : \UU} \brck{\bool = A}$ and
$a \defeq (\bool, \lvert \refl{\bool} \rvert) : X$.  Let $e : \bool \eqvsym
\bool$ be the non-identity equivalence from Exercise 2.13, which gives us
$\lnot : \bool \to \bool$ and $r : \qinv(\lnot)$.  Define $q \defeq
\mathsf{idtoqinv}_{\bool, \bool}^{-1}(\lnot, r)$.  Now we can run the proof as
before, applying Lemma 4.1.2.

Here univalence is used only in establishing that $a = a$ is a set, by showing
that it's equivalent to $(\bool \eqvsym \bool)$.
*)

Lemma Book_4_1_2 `{Funext} (A : Type) (a : A) (q : a = a)
  : IsHSet (a = a) -> (forall x, Brck (a = x))
    -> (forall p : a = a, p @ q = q @ p)
    -> {f : forall (x : A), x = x & f a = q}.
Proof.
  intros eq g eta.
  transparent assert (Heq : (forall x y : A, IsHSet (x = y))).
  intros x y.
  assert (Brck (a = x)) as p by auto.
  assert (Brck (a = y)) as r by auto.
  strip_truncations.
  simple refine (@trunc_equiv (a = a) _ _ _ _ _).
  intros s. apply (p^ @ s @ r).
  apply isequiv_concat_lr.
  set (B := fun x => {r : x = x & forall s : a = x, (r = s^ @ q @ s)}).
  transparent assert (HB : (forall x, (IsHProp (B x)))).
  intro x. assert (Brck (a = x)) as p by auto.
  strip_truncations.
  apply hprop_allpath. intros rh r'h'.
  destruct rh as [r h], r'h' as [r' h'].
  apply path_sigma_uncurried. exists ((h p) @ (h' p)^). simpl.
  apply path_forall. intro t. apply Heq.
  transparent assert (f' : (forall x, B x)).
  intro x. assert (Brck (a = x)) as p by auto. strip_truncations.
  exists (p^ @ q @ p). intro s.
  apply moveL_pM. repeat (refine ((concat_pp_p _ _ _) @ _)).
  apply moveR_Vp. refine (_ @ (concat_pp_p _ _ _)).
  symmetry. apply eta.
  exists (fun x => (f' x).1).
  refine (((f' a).2 1) @ _).
  hott_simpl.
Defined.

(*
Theorem Book_4_1_3 `{Funext}
  : {A : Type & {B : Type & {f : A -> B & ~ IsHProp (qinv f)}}}.
Proof.
  set (X := {A : Type & Brck (Bool = A)}).
  exists X. exists X. exists idmap. intro H'.
  set (a := (Bool; tr 1) : X).
  assert (Q : (qinv (equiv_path Bool Bool))) by apply qinv_univalence.
  destruct Q as [path_equiv' [retr sect]].
  transparent assert (q : (a = a)).
    apply path_sigma_hprop. apply path_equiv'.
    apply (BuildEquiv _ _ negb isequiv_negb).
  transparent assert (e : (Bool <~> (a = a))).
    equiv_via (Bool <~> Bool). apply equiv_bool_aut_bool.
    equiv_via (Bool = Bool).
    refine (equiv_adjointify _ _ _ _).
    apply path_equiv'. apply equiv_path.
    intro eq. apply (sect eq). intro e. apply (retr e).
    refine (equiv_adjointify _ _ _ _).
    intro eq. apply path_sigma_uncurried. exists eq. apply path_ishprop.
    intro eq. apply (pr1_path eq).
    intro eq. destruct eq.
    refine (_ @ (eta_path_sigma_uncurried _)). f_ap.
    apply path_sigma_uncurried. exists 1. simpl. apply path_ishprop.
    intro eq.
    refine ((@pr1_path_sigma_uncurried Type _ a a _) @ _). reflexivity.
  assert (F : {f : forall x : X, x = x & f a = q}). apply Book_4_1_2.
  apply (trunc_equiv _ e).
  intro x. destruct x as [A eq]. strip_truncations. apply tr.
  unfold a. apply path_sigma_uncurried. exists eq. induction eq. reflexivity.
  intros p.
  set (b := e^-1 p). assert (pisb : p = e b). unfold b. symmetry. apply eisretr.
  set (b' := e^-1 q). assert (qisb' : q = e b'). unfold b'. symmetry.
    apply eisretr.
    clearbody b b'.
  rewrite pisb, qisb'.
  assert (path_equiv' (BuildEquiv _ _ idmap _) = 1).
  path_via (path_equiv' (equiv_path _ _ 1)). apply sect.
  assert (path_ishprop (transport (fun A : Type0 => Brck (Bool = A)) 1 (tr 1))
       (tr 1) = 1) by apply path_ishprop.
  destruct b, b'.
  reflexivity.
  admit.
  admit.
  reflexivity.

  assert (Heq : (q <> 1)).
  unfold q. intro Heq.
  assert (negb <> idmap) as CX. intro h. apply (negb_no_fixpoint true).
  apply (ap10 h true). apply CX.
  path_via (equiv_fun (BuildEquiv _ _ negb _)).
  path_via (equiv_fun (BuildEquiv Bool _ idmap _)). f_ap.
  path_via (equiv_path Bool Bool (path_equiv'
            {| equiv_fun := negb; equiv_isequiv := isequiv_negb |})).
  symmetry. apply retr.
  path_via (equiv_path Bool Bool (path_equiv'
            {| equiv_fun := idmap; equiv_isequiv := isequiv_idmap _ |})).
  f_ap.
  path_via ((path_sigma_hprop a a)^-1 (path_sigma_hprop a a (
    path_equiv' {| equiv_fun := negb; equiv_isequiv := isequiv_negb |}))).
  symmetry. apply eissect.
  path_via ((path_sigma_hprop a a)^-1 (path_sigma_hprop a a (
    path_equiv' {| equiv_fun := idmap; equiv_isequiv := isequiv_idmap _ |}))).
  f_ap.
  refine (Heq @ _).
  path_via (path_sigma_hprop a a ((path_equiv' o (equiv_path _ _)) 1)).
  rewrite (sect 1).
  path_via (path_sigma_hprop a a ((path_sigma_hprop a a)^-1 1)).
  symmetry. apply eisretr.
  apply eissect.
  apply (retr _).
  destruct F as [f eq].
  assert (Hf : (f <> (fun x => 1))).
  intro Hf. apply Heq. refine (eq^ @ _). apply (apD10 Hf a).
  assert (HP : (IsHProp (forall x : X, x = x))).
  apply (trunc_equiv' (Book_4_1_1 X X (BuildEquiv X X idmap _))).
  apply Hf. apply path_ishprop.
Admitted.
*)

(**
(iii) $\qinv$-univalence implies that all equivalences are half-adjoint
equivalences and this because for any $p : A = B$, $\idtoeqv(p)$ is
half-adjoint.  To see this, suppose that $p : A = B$, which by induction we may
assume is $\refl{A}$.  Then $\idtoeqv(p) \equiv (\idfunc{A}, \idfunc{A},
\lam{x:A}\refl{x}, \lam{x:A}\refl{x})$, and to show that this is a half-adjoint
equivalence we must inhabit the type
%\[
\left(
  \prd{x : A}\idfunc{A}((\lam{x'}\refl{x'})x)
             = (\lam{x'}\refl{x'})(\idfunc{A}x)
             \right)
  \equiv
  \left(
  \prd{x : A}\refl{x} = \refl{x}
  \right)
\]%
which is inhabited by reflexivity.  However, there are equivalences that aren't
half-adjoint, such as the one constructed in Exercise 4.1.
*)

End Ex6.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Lists.List.
Require Export Logic.lib.Relation_ext.

Instance list_Reflexive {A R} {EqA: @Equivalence A R}: Reflexive (Forall2 (@equiv A _ _)).
Proof.
  hnf; intros.
  induction x; constructor.
  + reflexivity.
  + auto.
Qed.

Instance list_Symmetric {A R} {EqA: @Equivalence A R}: Symmetric (Forall2 (@equiv A _ _)).
Proof.
  hnf; intros.
  revert y H; induction x; intros; destruct y; try solve [inversion H]; constructor.
  + inversion H; subst. symmetry. auto.
  + inversion H; subst. apply IHx; auto.
Qed.

Instance list_Transitive {A R} {EqA: @Equivalence A R}: Transitive (Forall2 (@equiv A _ _)).
Proof.
  hnf; intros.
  revert y z H H0; induction x; intros; destruct y, z; try solve [inversion H; subst; inversion H0]; constructor.
  + inversion H; inversion H0; subst. etransitivity; eauto.
  + inversion H; inversion H0; subst. eapply IHx; eauto.
Qed.

Instance list_Equivalence {A R} {EqA: @Equivalence A R}: Equivalence (Forall2 (@equiv A _ _)).
Proof.
  split.
  apply list_Reflexive.
  apply list_Symmetric.
  apply list_Transitive.
Qed.

(* The Instances-Searching for type classes are type oriented.
As resp_Equivalence is a (Equvalence B), it should not be involved
in Instances-Searching. Or else, searching engine will apply this
Instance, and do never terminate. *)

Lemma resp_Reflexive {A B} (f: A -> B) (R: relation B) {RR: Reflexive R}: Reflexive (respectful_relation f R).
Proof.
  intros.
  hnf; intros.
  unfold respectful_relation.
  reflexivity.
Qed.

Lemma resp_Symmetric {A B} (f: A -> B) (R: relation B) {SR: Symmetric R}: Symmetric (respectful_relation f R).
Proof.
  intros.
  hnf; intros.
  unfold respectful_relation.
  symmetry.
  auto.
Qed.

Lemma resp_Transitive {A B} (f: A -> B) (R: relation B) {TR: Transitive R}: Transitive (respectful_relation f R).
Proof.
  intros.
  hnf; intros.
  unfold respectful_relation.
  transitivity (f y); auto.
Qed.

Lemma resp_Equivalence {A B} (f: A -> B) (R: relation B) {ER: Equivalence R}: Equivalence (respectful_relation f R).
Proof.
  destruct ER.
  split.
  + apply resp_Reflexive; auto.
  + apply resp_Symmetric; auto.
  + apply resp_Transitive; auto.
Qed.


Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Quote.
Section Quote.

Variable A : Type.

Inductive varmap : Type :=
  | Empty_vm : varmap
  | Node_vm : A -> varmap -> varmap -> varmap.

Inductive index : Set :=
  | Left_idx : index -> index
  | Right_idx : index -> index
  | End_idx : index.

Fixpoint varmap_find (default_value : A) (i : index) (v : varmap) : A :=
  match i, v with
  | End_idx, Node_vm x _ _ => x
  | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2
  | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1
  | _, _ => default_value
  end.

Fixpoint index_eq (n m : index) : bool :=
  match n, m with
  | End_idx, End_idx => true
  | Left_idx n', Left_idx m' => index_eq n' m'
  | Right_idx n', Right_idx m' => index_eq n' m'
  | _, _ => false
  end.

End Quote.
End Quote.
Import Quote.

Lemma eqindexP : Equality.axiom index_eq.
Proof.
move=> x y; apply: (iffP idP) => [|<-]; last by elim: x.
by elim: x y => [x IH|x IH|] [y|y|] //= /IH ->.
Qed.

Canonical index_eqMixin := EqMixin eqindexP.
Canonical index_eqType := Eval hnf in EqType index index_eqMixin.

Fixpoint leq_index (x y : index) : bool :=
  match x, y with
    | End_idx, _ | Left_idx _, Right_idx _ => true
    | Left_idx x', Left_idx y' | Right_idx x', Right_idx y' => leq_index x' y'
    | _, _ => false
  end.

Definition geq_index (x y : index) : bool := leq_index y x.

Lemma leq_index_refl : reflexive leq_index.
Proof. by elim. Qed.

Lemma leq_index_trans : transitive leq_index.
Proof. by elim=> [x IH | x IH |] [y | y |] [z | z |] //=; apply: IH. Qed.

Lemma leq_index_antisym (x y : index) :
  leq_index x y -> leq_index y x -> x = y.
Proof. by elim: x y => [x IH | x IH |] [y | y |] //= *; f_equal; apply: IH. Qed.

Lemma leq_index_total (x y : index) : leq_index x y || leq_index y x.
Proof. by elim: x y => [x IH | x IH |] []. Qed.

Notation Singleton_vm x := (Node_vm x (Empty_vm _) (Empty_vm _)).

Definition varmap_find'
           (A : Type) (default : A) (v : varmap A) (i : index) : A :=
  varmap_find default i v.

Ltac myquote term tag default :=
  let lk (* lookup *) := constr: (varmap_find' default) in
  let find_tag term :=
    lazymatch term with
    | context [tag ?x] => eval pattern (tag x) in term
    | _ => constr: (tt)
    end
  in
  let rec pop term :=
    lazymatch term with
    | (let _ := tt in ?term') => pop term'
    | (let f' := ?f in let _ := tt in @?F f') =>
      let term' := eval cbv beta in (let f' := f in F f') in
      pop term'
    | (let f := lk ?m1 in let g := lk ?m2 in @?F f g) =>
      let term' := eval cbv beta in
        (let f := lk (Node_vm default m1 m2) in
         F (fun i => f (Left_idx i)) (fun i => f (Right_idx i)))
      in
      pop term'
    | _ => constr: (term)
    end
  in
  let rec push term :=
    lazymatch find_tag term with
    | (fun x' => let f := lk ?m1 in let g := lk ?m2 in @?F x' f g) (tag ?x) =>
      let term' := eval cbv beta in
        (let f := lk (Node_vm x m1 m2) in
         F (f End_idx) (fun i => f (Left_idx i)) (fun i => f (Right_idx i)))
      in
      let term' := push term' in
      constr: (let _ := tt in term')
    | (fun x' => let f := lk ?m in let _ := tt in @?F x' f) (tag ?x) =>
      eval cbv beta in (let f := lk m in F (tag x) f)
    | _ => constr: (term)
    end
  in
  let rec quote_rec term :=
    lazymatch find_tag term with
    | (fun x' => @?F x') (tag ?x) =>
      let term' := eval cbv beta in
        (let f := lk (Singleton_vm x) in F (f End_idx)) in
      let term'' := push term' in
      quote_rec term''
    | _ => pop term
    end
  in
  quote_rec term.

Ltac myquote' term tag default atoms :=
  let lk (* lookup *) := constr: (varmap_find' default) in
  let rec pop term :=
    lazymatch term with
    | (let _ := tt in ?term') => pop term'
    | (let f' := ?f in let _ := tt in @?F f') =>
      let term' := eval cbv beta in (let f' := f in F f') in
      pop term'
    | (let f := lk ?m1 in let g := lk ?m2 in @?F f g) =>
      let term' := eval cbv beta in
        (let f := lk (Node_vm default m1 m2) in
         F (fun i => f (Left_idx i)) (fun i => f (Right_idx i)))
      in
      pop term'
    | _ => constr: (term)
    end
  in
  let rec push_aux term n :=
    lazymatch n with
    | ?n'.+1 => let term' := constr: (let _ := tt in term) in push_aux term' n'
    | 0 => term
    end
  in
  let rec push term atoms n :=
    lazymatch atoms with
    | ?atom :: ?atoms' =>
      lazymatch eval pattern (tag atom) in term with
      | (fun x' => let f := lk ?m1 in let g := lk ?m2 in @?F x' f g) _ =>
        let term' := eval cbv beta in
          (let f := lk (Node_vm atom m1 m2) in
           F (f End_idx) (fun i => f (Left_idx i)) (fun i => f (Right_idx i)))
        in
        push term' atoms' (n.+1)
      | (fun x' => let f := lk ?m in let _ := tt in @?F x' f) _ =>
        let term' := eval cbv beta in (let f := lk m in F (tag atom) f) in
        let term'' := push_aux term' n in
        quote_rec term'' atoms
      | _ =>
        let term' := push_aux term n in
        quote_rec term' atoms
      end
    | _ => pop term
    end
  with quote_rec term atoms :=
    lazymatch atoms with
    | ?atom :: ?atoms' =>
      lazymatch eval pattern (tag atom) in term with
      | (fun x' => @?F x') _ =>
        let term' := eval cbv beta in
          (let f := lk (Singleton_vm atom) in F (f End_idx)) in
        push term' atoms' 0
      end
    | _ => pop term
    end
  in
  quote_rec term atoms.


Require Import VST.msl.Extensionality.

Class NatDed (A: Type) := mkNatDed {
  andp: A -> A -> A;
  orp: A -> A -> A;
  exp: forall {T:Type}, (T -> A) -> A;
  allp: forall {T:Type}, (T -> A) -> A;
  imp: A -> A -> A;
  prop: Prop -> A;
  derives: A -> A -> Prop;
  pred_ext: forall P Q, derives P Q -> derives Q P -> P=Q;
  derives_refl: forall P, derives P P;
  derives_trans: forall P Q R, derives P Q -> derives Q R -> derives P R;
  TT := prop True;
  FF := prop False;
  andp_right:  forall X P Q:A, derives X P -> derives X Q -> derives X (andp P Q);
  andp_left1:  forall P Q R:A, derives P R -> derives (andp P Q) R;
  andp_left2:  forall P Q R:A, derives Q R -> derives (andp P Q) R;
  orp_left: forall P Q R, derives P R -> derives Q R -> derives (orp P Q) R;
  orp_right1: forall P Q R, derives P Q -> derives P (orp Q R);
  orp_right2: forall P Q R, derives P R -> derives P (orp Q R);
  exp_right: forall {B: Type} (x:B) (P: A) (Q: B -> A),
                        derives P (Q x) -> derives P (exp Q);
  exp_left: forall {B: Type} (P: B -> A) (Q: A),
                      (forall x, derives (P x) Q) -> derives (exp P) Q;
  allp_left: forall {B}(P: B -> A) x Q, derives (P x) Q -> derives (allp P) Q;
  allp_right: forall {B}(P: A) (Q: B -> A),  (forall v, derives P (Q v)) -> derives P (allp Q);
  imp_andp_adjoint: forall P Q R, derives (andp P Q) R <-> derives P (imp Q R);
  prop_left: forall (P: Prop) Q, (P -> derives TT Q) -> derives (prop P) Q;
  prop_right: forall (P: Prop) Q, P -> derives Q (prop P);
  prop_imp_prop_left: forall (P Q: Prop), derives (imp (prop P) (prop Q)) (prop (P -> Q));
  allp_prop_left: forall {B: Type} (P: B -> Prop), derives (allp (fun b => prop (P b))) (prop (forall b, P b))
(* not_prop_right: forall (P: A) (Q: Prop), (Q -> derives P FF) -> derives P (prop (not Q)) *)
}.

#[global] Program Instance LiftNatDed (A B: Type) {ND: NatDed B} : NatDed (A -> B) :=
 mkNatDed (A -> B)
    (*andp*) (fun P Q x => andp (P x) (Q x))
    (*orp*) (fun P Q x => orp (P x) (Q x))
    (*exp*) (fun T (F: T -> A -> B) (a: A) => exp (fun x => F x a))
    (*allp*) (fun T (F: T -> A -> B) (a: A) => allp (fun x => F x a))
    (*imp*) (fun P Q x => imp (P x) (Q x))
    (*prop*) (fun P x => prop P)
    (*derives*) (fun P Q => forall x, derives (P x) (Q x))
     _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Next Obligation.
 intros; extensionality x; apply pred_ext; auto.
Defined.
Next Obligation.
 intros; apply derives_refl.
Defined.
Next Obligation.
 intros; eapply derives_trans; eauto.
Defined.
Next Obligation.
 intros; eapply andp_right; eauto.
Defined.
Next Obligation.
 intros; eapply andp_left1; eauto.
Defined.
Next Obligation.
 intros; eapply andp_left2; eauto.
Defined.
Next Obligation.
 intros; eapply orp_left; eauto.
Defined.
Next Obligation.
 intros; eapply orp_right1; eauto.
Defined.
Next Obligation.
 intros; eapply orp_right2; eauto.
Defined.
Next Obligation.
 intros; eapply exp_right; eauto.
Defined.
Next Obligation.
 intros; eapply exp_left; eauto.
Defined.
Next Obligation.
 intros; eapply allp_left; eauto.
Defined.
Next Obligation.
 intros; eapply allp_right; eauto.
Defined.
Next Obligation.
 intros; split; intros;  eapply imp_andp_adjoint; eauto.
Defined.
Next Obligation.
 intros; eapply prop_left; eauto.
Defined.
Next Obligation.
 intros; eapply prop_right; eauto.
Defined.
Next Obligation.
 intros; eapply prop_imp_prop_left; eauto.
Defined.
Next Obligation.
 intros; eapply allp_prop_left; eauto.
Defined.

Declare Scope logic.
Delimit Scope logic with logic.
Local Open Scope logic.
Declare Scope logic_derives.
Notation "P '|--' Q" := (derives P%logic Q%logic) (at level 80, no associativity) : logic_derives.
Open Scope logic_derives.
Notation "'EX' x .. y , P " :=
  (exp (fun x => .. (exp (fun y => P%logic)) ..)) (at level 65, x binder, y binder, right associativity) : logic.
Notation "'ALL' x .. y , P " :=
  (allp (fun x => .. (allp (fun y => P%logic)) ..)) (at level 65, x binder, y binder, right associativity) : logic.
Infix "||" := orp (at level 50, left associativity) : logic.
Infix "&&" := andp (at level 40, left associativity) : logic.
Notation "P '-->' Q" := (imp P Q) (at level 55, right associativity) : logic.
Notation "P '<-->' Q" := (andp (imp P Q) (imp Q P)) (at level 57, no associativity) : logic.
Notation "'!!' e" := (prop e) (at level 15) : logic.

Class SepLog (A: Type) {ND: NatDed A} := mkSepLog {
  emp: A;
  sepcon: A -> A -> A;
  wand: A -> A -> A;
  ewand: A -> A -> A;
  sepcon_assoc: forall P Q R, sepcon (sepcon P Q) R = sepcon P (sepcon Q R);
  sepcon_comm:  forall P Q, sepcon P Q = sepcon Q P;
  wand_sepcon_adjoint: forall (P Q R: A),  (sepcon P Q |-- R) <-> (P |-- wand Q R);
  sepcon_andp_prop: forall P Q R, sepcon P (!!Q && R) = !!Q && (sepcon P R);
  sepcon_derives: forall P P' Q Q' : A, (P |-- P') -> (Q |-- Q') -> sepcon P Q |-- sepcon P' Q';
(* how necessary is ewand? *)
(*  ewand_sepcon: forall (P Q R : A),  ewand (sepcon P Q) R = ewand P (ewand Q R);
  ewand_TT_sepcon: forall (P Q R: A),
                         andp (sepcon P Q) (ewand R TT) |--
                               sepcon (andp P (ewand R TT)) (andp Q (ewand R TT));
  exclude_elsewhere: forall P Q: A, sepcon P Q |-- sepcon (andp P (ewand Q TT)) Q;*)
  ewand_conflict: forall P Q R, (sepcon P Q |-- FF) -> andp P (ewand Q R) |-- FF
}.

Notation "P '*' Q" := (sepcon P Q) : logic.
Notation "P '-*' Q" := (wand P Q) (at level 60, right associativity) : logic.

#[global] Instance LiftSepLog (A B: Type) {NB: NatDed B}{SB: SepLog B} : SepLog (A -> B).
 apply (mkSepLog (A -> B) _ (fun rho => emp)
            (fun P Q rho => P rho * Q rho) (fun P Q rho => P rho -* Q rho)
            (fun P Q rho => ewand (P rho) (Q rho))).
 (* sepcon_assoc *) intros; extensionality rho; apply sepcon_assoc.
 (* sepcon_comm *) intros; extensionality rho; apply sepcon_comm.
 intros.  split. simpl. intuition.
    apply wand_sepcon_adjoint. auto.
    intro. intro rho.     apply <- wand_sepcon_adjoint; auto.
 simpl; intros. extensionality x. apply sepcon_andp_prop.
 simpl; intros; apply sepcon_derives; auto.
(* simpl; intros; extensionality x; apply ewand_sepcon.
 simpl; intros; eapply ewand_TT_sepcon.
 simpl; intros; eapply exclude_elsewhere.*)
 simpl; intros; eapply ewand_conflict; eauto.
Defined.

Class ClassicalSep  (A: Type) {ND: NatDed A}{SL: SepLog A} := mkCS {
   sepcon_emp: forall P, P * emp = P
}.

#[global] Instance LiftClassicalSep (A B: Type)  {NB: NatDed B}{SB: SepLog B}{CB: ClassicalSep B} :
        ClassicalSep (A -> B).
 apply mkCS.
 intros. extensionality x. simpl. apply sepcon_emp.
Qed.

Definition  extensible {A}{ND: NatDed A}{SL: SepLog A}(P:A) := sepcon P TT |-- P.

Class IntuitionisticSep (A: Type) {ND: NatDed A}{SL: SepLog A} := mkIS {
   all_extensible: forall P, extensible P
}.

#[global] Instance LiftIntuitionisticSep (A B: Type)  {NB: NatDed B}{SB: SepLog B}{IB: IntuitionisticSep B} :
        IntuitionisticSep (A -> B).
 apply mkIS.
 intros. intro. simpl. apply all_extensible.
Qed.

Class Indir (A: Type) {ND: NatDed A} := mkIndir {
  later: A -> A;
  now_later: forall P: A, P |-- later P;
  later_K: forall P Q, later (P --> Q) |-- later P --> later Q;
  later_allp: forall T (F: T -> A),  later (allp F) = ALL x:T, later (F x);
  later_exp: forall T (F: T-> A), EX x:T, later (F x) |-- later (exp F);
  later_exp': forall T (any:T) F, later (exp F) = EX x:T, later (F x);
  later_exp'': forall T F, later (exp F) |-- (EX x:T, later (F x)) || later FF;
(*  later_imp: forall P Q,  later(P --> Q) = later P --> later Q;*)
  later_prop: forall PP: Prop, later (!! PP) |-- !! PP || later FF;
  loeb: forall P,   (later P |-- P) ->  TT |-- P
}.

Notation "'|>' e" := (later e) (at level 20, right associativity): logic.

#[global] Instance LiftIndir (A: Type) (B: Type)  {NB: NatDed B}{IXB: Indir B} :
         @Indir (A -> B) (LiftNatDed A B).
 apply (mkIndir _ _ (fun P rho => later (P rho))); intros; simpl in *; intros.
 apply now_later.
 apply later_K.
 simpl; intros. extensionality rho. apply later_allp.
 simpl; intros. apply later_exp.
 simpl; intros. extensionality rho. apply later_exp'; auto.
 simpl; intros. apply later_exp''.
(* simpl; intros. extensionality rho. apply later_imp.*)
 simpl; intros. apply later_prop.
 simpl; intros. apply loeb; auto.
Defined.

Class SepIndir (A: Type) {NA: NatDed A}{SA: SepLog A}{IA: Indir A} := mkSepIndir {
  later_sepcon: forall P Q, |> (P * Q) = |>P * |>Q;
  later_wand: forall P Q, |> (P -* Q) = |>P -* |>Q(*;
  later_ewand: forall P Q, |> (ewand P Q) = ewand (|>P) (|>Q)*)
}.

#[global] Instance LiftSepIndir  (A: Type) (B: Type)  {NB: NatDed B} {SB: SepLog B}{IB: Indir B}{SIB: SepIndir B} :
     @SepIndir (A -> B) (LiftNatDed A B) (LiftSepLog A B) (LiftIndir A B).
 constructor.
 intros; simpl. extensionality rho.  apply later_sepcon.
 intros; simpl. extensionality rho.  apply later_wand.
(* intros; simpl. extensionality rho.  apply later_ewand.*)
Defined.

Class CorableSepLog (A: Type) {ND: NatDed A}{SL: SepLog A}:= mkCorableSepLog {
  corable: A -> Prop;
  corable_prop: forall P, corable (!! P);
  corable_andp: forall P Q, corable P -> corable Q -> corable (P && Q);
  corable_orp: forall P Q, corable P -> corable Q -> corable (P || Q);
  corable_imp: forall P Q, corable P -> corable Q -> corable (P --> Q);
  corable_allp: forall {B: Type} (P:  B -> A), (forall b, corable (P b)) -> corable (allp P);
  corable_exp: forall {B: Type} (P:  B -> A), (forall b, corable (P b)) -> corable (exp P);
  corable_sepcon: forall P Q, corable P -> corable Q -> corable (P * Q);
  corable_wand: forall P Q, corable P -> corable Q -> corable (P -* Q);
  corable_andp_sepcon1: forall P Q R, corable P ->  (P && Q) * R = P && (Q * R)
}.

#[global] Instance LiftCorableSepLog (A: Type) (B: Type) {NB: NatDed B} {SB: SepLog B} {CSL: CorableSepLog B} : @CorableSepLog (A -> B) (LiftNatDed A B) (LiftSepLog A B).
  apply (@mkCorableSepLog _ _ _ (fun P => forall b, corable (P b))); intros; simpl in *; intros.
  + apply corable_prop.
  + apply corable_andp; auto.
  + apply corable_orp; auto.
  + apply corable_imp; auto.
  + apply corable_allp; auto.
  + apply corable_exp; auto.
  + apply corable_sepcon; auto.
  + apply corable_wand; auto.
  + extensionality b.
    apply corable_andp_sepcon1; auto.
Defined.

Class CorableIndir (A: Type) {ND: NatDed A}{SL: SepLog A}{CSL: CorableSepLog A}{ID: Indir A} :=
  corable_later: forall P, corable P -> corable (|> P).

#[global] Instance LiftCorableIndir (A: Type) (B: Type) {NB: NatDed B} {SB: SepLog B} {CSL: CorableSepLog B} {ID: Indir B} {CI: CorableIndir B}: @CorableIndir (A -> B) (LiftNatDed A B) (LiftSepLog A B) (LiftCorableSepLog A B) (LiftIndir A B).
  unfold CorableIndir; simpl; intros.
  apply corable_later; auto.
Defined.

Lemma orp_comm: forall {A: Type} `{NatDed A} (P Q: A), P || Q = Q || P.
Proof.
  intros.
  apply pred_ext.
  + apply orp_left; [apply orp_right2 | apply orp_right1]; apply derives_refl.
  + apply orp_left; [apply orp_right2 | apply orp_right1]; apply derives_refl.
Qed.


Require Import util.
Require ast.
Require stream.
Require encode.
Require decode.

(* Prove that there is a bijection between encoding and decoding,
   since both encoding the result of decoding is identity
   and that decoding the result of encoding is identity *)

Lemma number_encdec:
  forall (bits: nat) (n: N) (s: stream.bit),
    (N.size_nat n) <= bits ->
    decode.number bits (encode.number bits n s) = Some (n, s).
Proof.
  induction bits; intros; simpl.
  - destruct n.
    + reflexivity.
    + contradict H. simpl.
      apply gt_not_le. apply positive_size_lt0.
  - admit.
Admitted.

Lemma number_decenc:
  forall (bits: nat) (n: N) (s s': stream.bit),
    decode.number bits s = Some (n, s') ->
    encode.number bits n s' = s.
Proof.
  induction bits; intros; simpl; simpl in H.
  - injection H. intros. symmetry. assumption.
  - mcase (stream.take s) H p H0.
    mcase (decode.number bits t) H p H1.
    admit.
Admitted.

Ltac plain_number_encdec :=
  intros;
  rewrite number_encdec;
  try reflexivity;
  try assumption.

Fact register_encdec: forall (n: N) (s: stream.bit),
    (N.size_nat n) <= ast.register_bits ->
    decode.register (encode.register (ast.reg n) s)
    = Some (ast.reg n, s).
Proof.
  unfold encode.register, decode.register.
  plain_number_encdec.
Qed.

Fact immediate_encdec: forall (n: N) (s: stream.bit),
    (N.size_nat n) <= ast.constant_bits ->
    decode.immediate (encode.immediate (ast.imm n) s)
    = Some (ast.imm n, s).
Proof.
  unfold encode.immediate, decode.immediate.
  plain_number_encdec.
Qed.

Fact displacement_encdec: forall (n: N) (s: stream.bit),
    (N.size_nat n) <= ast.constant_bits ->
    decode.displacement (encode.displacement (ast.dsp n) s)
    = Some (ast.dsp n, s).
Proof.
  unfold encode.displacement, decode.displacement.
  plain_number_encdec.
Qed.

Fact destination_encdec: forall (n: N) (s: stream.bit),
    (N.size_nat n) <= ast.constant_bits ->
    decode.destination (encode.destination (ast.dst n) s)
    = Some (ast.dst n, s).
Proof.
  unfold encode.destination, decode.destination.
  plain_number_encdec.
Qed.

Ltac number_encdec := rewrite number_encdec; try (simpl; omega).

Fact condition_encdec: forall (c: ast.condition) (s: stream.bit),
    decode.condition (encode.condition c s) = Some (c, s).
Proof.
  unfold decode.condition, encode.condition, encode.condition_num.
  intros.
  destruct c; number_encdec; reflexivity.
Qed.

Fact operator_encdec: forall (op: ast.operator) (s: stream.bit),
    decode.operator (encode.operator op s) = Some (op, s).
Proof.
  unfold decode.operator, encode.operator, encode.operator_num.
  intros.
  destruct op; number_encdec; reflexivity.
Qed.

Lemma reg_is_4bits: forall (n: N), ast.valid_register n -> N.size_nat n <= ast.register_bits.
Proof.
  intros.
  apply size_nat.
  unfold ast.valid_register in H.
  simpl.
  apply N.le_trans with (m:=7%N).
  assumption.
  compute.
  intros.
  discriminate.
Qed.

Ltac expect_encdec :=
  unfold decode.expect; number_encdec; rewrite N.eqb_refl.
Ltac register_encdec r H :=
  destruct r; rewrite register_encdec;
  try (inversion H; apply reg_is_4bits; assumption).
Ltac immediate_encdec i H :=
  destruct i; rewrite immediate_encdec;
  try (inversion H; assumption).
Ltac displacement_encdec i H :=
  destruct i; rewrite displacement_encdec;
  try (inversion H; assumption).
Ltac destination_encdec i H :=
  destruct i; rewrite destination_encdec;
  try (inversion H; assumption).

Lemma instruction_encdec:
  forall (i: ast.instruction) (s: stream.bit),
    ast.valid_instruction i ->
    decode.instruction (encode.instruction i s) = Some (i, s).
Proof.
  unfold decode.instruction, encode.instruction.
  intros.
  destruct i; rewrite number_encdec; try (simpl; omega).
  - expect_encdec. reflexivity.
  - expect_encdec. reflexivity.
  - unfold decode.rrmovl.
    rewrite condition_encdec.
    register_encdec r H.
    register_encdec r0 H.
    reflexivity.
  - unfold decode.irmovl.
    expect_encdec.
    expect_encdec.
    register_encdec r H.
    immediate_encdec i H.
    reflexivity.
  - unfold decode.rmmovl.
    expect_encdec.
    register_encdec r H.
    register_encdec r0 H.
    displacement_encdec d H.
    reflexivity.
  - unfold decode.mrmovl.
    expect_encdec.
    register_encdec r H.
    register_encdec r0 H.
    displacement_encdec d H.
    reflexivity.
  - unfold decode.OPl.
    rewrite operator_encdec.
    register_encdec r H.
    register_encdec r0 H.
    reflexivity.
  - unfold decode.jump.
    rewrite condition_encdec.
    destination_encdec d H.
    reflexivity.
  - unfold decode.call.
    expect_encdec.
    destination_encdec d H.
    reflexivity.
  - unfold decode.ret.
    expect_encdec.
    reflexivity.
  - unfold decode.pushl.
    expect_encdec.
    register_encdec r H.
    expect_encdec.
    reflexivity.
  - unfold decode.popl.
    expect_encdec.
    register_encdec r H.
    expect_encdec.
    reflexivity.
Qed.

Ltac injected H :=
  injection H; intros; subst; reflexivity.

Fact register_decenc:
  forall (r: ast.register) (s s': stream.bit),
    decode.register s = Some (r, s') ->
    encode.register r s' = s.
Proof.
  unfold encode.register, decode.register.
  intros. destruct r. apply number_decenc.
  mcase (decode.number ast.register_bits s) H p H0.
  injected H.
Qed.

Fact immediate_decenc:
  forall (i: ast.immediate) (s s': stream.bit),
    decode.immediate s = Some (i, s') ->
    encode.immediate i s' = s.
Proof.
  unfold encode.immediate, decode.immediate.
  intros. destruct i. apply number_decenc.
  mcase (decode.number ast.constant_bits s) H p H0.
  injected H.
Qed.

Fact displacement_decenc:
  forall (d: ast.displacement) (s s': stream.bit),
    decode.displacement s = Some (d, s') ->
    encode.displacement d s' = s.
Proof.
  unfold encode.displacement, decode.displacement.
  intros. destruct d. apply number_decenc.
  mcase (decode.number ast.constant_bits s) H p H0.
  injected H.
Qed.

Fact destination_decenc:
  forall (d: ast.destination) (s s': stream.bit),
    decode.destination s = Some (d, s') ->
    encode.destination d s' = s.
Proof.
  unfold encode.destination, decode.destination.
  intros. destruct d. apply number_decenc.
  mcase (decode.number ast.constant_bits s) H p H0.
  injected H.
Qed.

Fact condition_decenc:
  forall (c: ast.condition) (s s': stream.bit),
    decode.condition s = Some (c, s') ->
    encode.condition c s' = s.
Proof.
  unfold decode.condition, encode.condition, encode.condition_num.
  intros.
  mcase (decode.number 4 s) H p C0.
  destruct n; do 3 try destruct p; try discriminate;
    try (injection H; intros; subst; apply number_decenc; assumption).
Qed.

Fact operator_decenc:
  forall (c: ast.operator) (s s': stream.bit),
    decode.operator s = Some (c, s') ->
    encode.operator c s' = s.
Proof.
  unfold decode.operator, encode.operator, encode.operator_num.
  intros.
  mcase (decode.number 4 s) H p C0.
  destruct n; do 2 try destruct p; try discriminate;
    try (injection H; intros; subst; apply number_decenc; assumption).
Qed.

Fact decode_expect:
  forall (bits: nat) (e: N) (u: unit) (s s': stream.bit),
    decode.expect bits e s = Some (u, s') ->
    decode.number bits s = Some (e, s').
Proof.
  unfold decode.expect.
  intros.
  mcase (decode.number bits s) H p H0.
  mcase (n =? e)%N H p H1.
  injection H. intros. subst.
  apply Neqb_ok in H1. rewrite H1.
  reflexivity.
Qed.

Ltac decenc e H p HR :=
  mcase e H p HR;
  try apply decode_expect in HR;
  try apply register_decenc in HR;
  try apply immediate_decenc in HR;
  try apply destination_decenc in HR;
  try apply displacement_decenc in HR;
  try apply condition_decenc in HR;
  try apply operator_decenc in HR;
  try apply number_decenc in HR.

Lemma instruction_decenc:
  forall (i: ast.instruction) (s s': stream.bit),
    decode.instruction s = Some (i, s') ->
    encode.instruction i s' = s.
Proof.
  unfold decode.instruction.
  intros.
  decenc (decode.number 4 s) H p C0.
  destruct n; do 4 try destruct p; try discriminate.
  - decenc (decode.expect 4 0 s0) H p C1.
    injection H. intros. subst. reflexivity.
  - unfold decode.popl in H.
    decenc (decode.expect 4 0 s0) H p C1.
    decenc (decode.register s1) H p C2.
    decenc (decode.expect 4 15 s2) H p C3.
    injection H. intros. subst. reflexivity.
  - unfold decode.jump in H.
    decenc (decode.condition s0) H p C1.
    decenc (decode.destination s1) H p C2.
    injection H. intros. subst. reflexivity.
  - unfold decode.ret in H.
    decenc (decode.expect 4 0 s0) H p C1.
    injection H. intros. subst. reflexivity.
  - unfold decode.mrmovl in H.
    decenc (decode.expect 4 0 s0) H p C1.
    decenc (decode.register s1) H p C2.
    decenc (decode.register s2) H p C3.
    decenc (decode.displacement s3) H p C4.
    injection H. intros. subst. reflexivity.
  - unfold decode.irmovl in H.
    decenc (decode.expect 4 0 s0) H p C1.
    decenc (decode.expect 4 15 s1) H p C2.
    decenc (decode.register s2) H p C3.
    decenc (decode.immediate s3) H p C4.
    injection H. intros. subst. reflexivity.
  - unfold decode.pushl in H.
    decenc (decode.expect 4 0 s0) H p C1.
    decenc (decode.register s1) H p C2.
    decenc (decode.expect 4 15 s2) H p C3.
    injection H. intros. subst. reflexivity.
  - unfold decode.OPl in H.
    decenc (decode.operator s0) H p C1.
    decenc (decode.register s1) H p C2.
    decenc (decode.register s2) H p C3.
    injection H. intros. subst. reflexivity.
  - unfold decode.call in H.
    decenc (decode.expect 4 0 s0) H p C1.
    decenc (decode.destination s1) H p C2.
    injection H. intros. subst. reflexivity.
  - unfold decode.rmmovl in H.
    decenc (decode.expect 4 0 s0) H p C1.
    decenc (decode.register s1) H p C2.
    decenc (decode.register s2) H p C3.
    decenc (decode.displacement s3) H p C4.
    injection H. intros. subst. reflexivity.
  - unfold decode.rrmovl in H.
    decenc (decode.condition s0) H p C1.
    decenc (decode.register s1) H p C2.
    decenc (decode.register s2) H p C3.
    injection H. intros. subst. reflexivity.
  - decenc (decode.expect 4 0 s0) H p C1.
    injection H. intros. subst. reflexivity.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** Basic operations on floats: alignment, addition, multiplication *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_float_prop.

Section Float_ops.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Implicit Arguments Float [[beta]].

Definition Falign (f1 f2 : float beta) :=
  let '(Float m1 e1) := f1 in
  let '(Float m2 e2) := f2 in
  if Zle_bool e1 e2
  then (m1, (m2 * Zpower beta (e2 - e1))%Z, e1)
  else ((m1 * Zpower beta (e1 - e2))%Z, m2, e2).

Theorem Falign_spec :
  forall f1 f2 : float beta,
  let '(m1, m2, e) := Falign f1 f2 in
  F2R f1 = @F2R beta (Float m1 e) /\ F2R f2 = @F2R beta (Float m2 e).
Proof.
unfold Falign.
intros (m1, e1) (m2, e2).
generalize (Zle_cases e1 e2).
case (Zle_bool e1 e2) ; intros He ; split ; trivial.
now rewrite <- F2R_change_exp.
rewrite <- F2R_change_exp.
apply refl_equal.
omega.
Qed.

Theorem Falign_spec_exp:
  forall f1 f2 : float beta,
  snd (Falign f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros (m1,e1) (m2,e2).
unfold Falign; simpl.
generalize (Zle_cases e1 e2);case (Zle_bool e1 e2); intros He.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
Qed.

Definition Fopp (f1 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  Float (-m1)%Z e1.

Theorem F2R_opp :
  forall f1 : float beta,
  (F2R (Fopp f1) = -F2R f1)%R.
intros (m1,e1).
apply F2R_Zopp.
Qed.

Definition Fabs (f1 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  Float (Zabs m1)%Z e1.

Theorem F2R_abs :
  forall f1 : float beta,
  (F2R (Fabs f1) = Rabs (F2R f1))%R.
intros (m1,e1).
apply F2R_Zabs.
Qed.

Definition Fplus (f1 f2 : float beta) : float beta :=
  let '(m1, m2 ,e) := Falign f1 f2 in
  Float (m1 + m2) e.

Theorem F2R_plus :
  forall f1 f2 : float beta,
  F2R (Fplus f1 f2) = (F2R f1 + F2R f2)%R.
Proof.
intros f1 f2.
unfold Fplus.
generalize (Falign_spec f1 f2).
destruct (Falign f1 f2) as ((m1, m2), e).
intros (H1, H2).
rewrite H1, H2.
unfold F2R. simpl.
rewrite Z2R_plus.
apply Rmult_plus_distr_r.
Qed.

Theorem Fplus_same_exp :
  forall m1 m2 e,
  Fplus (Float m1 e) (Float m2 e) = Float (m1 + m2) e.
Proof.
intros m1 m2 e.
unfold Fplus.
simpl.
now rewrite Zle_bool_refl, Zminus_diag, Zmult_1_r.
Qed.

Theorem Fexp_Fplus :
  forall f1 f2 : float beta,
  Fexp (Fplus f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros f1 f2.
unfold Fplus.
rewrite <- Falign_spec_exp.
now destruct (Falign f1 f2) as ((p,q),e).
Qed.

Definition Fminus (f1 f2 : float beta) :=
  Fplus f1 (Fopp f2).

Theorem F2R_minus :
  forall f1 f2 : float beta,
  F2R (Fminus f1 f2) = (F2R f1 - F2R f2)%R.
Proof.
intros f1 f2; unfold Fminus.
rewrite F2R_plus, F2R_opp.
ring.
Qed.

Theorem Fminus_same_exp :
  forall m1 m2 e,
  Fminus (Float m1 e) (Float m2 e) = Float (m1 - m2) e.
Proof.
intros m1 m2 e.
unfold Fminus.
apply Fplus_same_exp.
Qed.

Definition Fmult (f1 f2 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  let '(Float m2 e2) := f2 in
  Float (m1 * m2) (e1 + e2).

Theorem F2R_mult :
  forall f1 f2 : float beta,
  F2R (Fmult f1 f2) = (F2R f1 * F2R f2)%R.
Proof.
intros (m1, e1) (m2, e2).
unfold Fmult, F2R. simpl.
rewrite Z2R_mult, bpow_plus.
ring.
Qed.

End Float_ops.


Create HintDb zf.

Module Type CZF.
  Notation "A ∧ B" := (prod A B) (at level 80).
  Notation "A ↔ B" := ((A -> B) ∧ (B -> A)) (at level 95).

  Parameter set : Type.

  Parameter equiv : set -> set -> Type.
  Notation "A ≡ B" := (equiv A B) (at level 70).
  Parameter equiv_refl : forall {x}, x ≡ x.
  Parameter equiv_sym : forall {x y}, x ≡ y -> y ≡ x.
  Parameter equiv_trans :
    forall {x y}, x ≡ y -> forall {z}, y ≡ z -> x ≡ z.
  Hint Resolve equiv_refl : zf.
  Hint Resolve equiv_sym : zf.
  Hint Resolve equiv_trans : zf.
  Axiom equiv_irrel : forall {x y} (p q: x ≡ y), p = q.
  Axiom equiv_real : forall {x y}, x ≡ y -> x = y.
  Hint Resolve equiv_irrel : zf.
  Hint Resolve equiv_real : zf.

  Parameter member : set -> set -> Type.
  Notation "A ∈ B" := (member A B) (at level 70).
  Parameter member_sound :
    forall {x y}, x ∈ y ->
    forall {z w}, x ≡ z -> y ≡ w -> z ∈ w.
  Parameter equiv_ext :
    forall {x y}, (forall {z}, z ∈ x ↔ z ∈ y) -> x ≡ y.
  Parameter equiv_def :
  forall {x y}, x ≡ y -> (forall {z}, z ∈ x ↔ z ∈ y).
  Notation "A ∉ B" := (A ∈ B -> False) (at level 70).
  Hint Resolve member_sound : zf.
  Hint Resolve equiv_ext : zf.
  Hint Resolve equiv_def : zf.
  Axiom member_irrel : forall {x y} (p q: x ∈ y), p = q.
  Hint Resolve member_irrel : zf.

  Definition subset A B := forall x, x ∈ A -> x ∈ B.
  Notation "A ⊆ B" := (subset A B) (at level 70).
  Lemma subset_sound :
    forall {x y}, x ⊆ y ->
    forall {z w}, x ≡ z -> y ≡ w -> z ⊆ w.
  Proof.
    unfold subset.
    eauto with zf.
  Qed.
  Axiom subset_irrel : forall {x y} (p p0: x ⊆ y), p = p0.
  Hint Resolve subset_sound : zf.
  Hint Resolve subset_irrel : zf.

  Parameter empty : set.
  Notation "∅" := empty.
  Parameter empty_prop : forall {x}, x ∉ ∅.
  Hint Resolve empty_prop : zf.

  Parameter insert : set -> set -> set.
  Notation "x +> y" := (insert x y) (at level 60).
  Parameter insert_sound :
    forall {x y z w}, x ≡ z -> y ≡ w -> x +> y ≡ z +> w.
  Parameter insert_prop :
    forall {x y}, x ∈ x +> y ∧ y ⊆ x +> y.
  Hint Resolve insert_sound : zf.
  Hint Resolve insert_prop : zf.

  Parameter union : set -> set.
  Notation "⋃ X" := (union X) (at level 60).
  Parameter union_sound :
    forall {x y}, x ≡ y -> ⋃x ≡ ⋃y.
  Parameter union_prop :
    forall {x y}, y ∈ x -> forall {z}, z ∈ y -> z ∈ ⋃x.
  Parameter union_def :
    forall {x z}, z ∈ ⋃x -> {y & z ∈ y ∧ y ∈ x}.
  Hint Resolve union_sound : zf.
  Hint Resolve union_prop : zf.

  Definition ordered_pair x y :=
    insert (insert x ∅) (insert (insert x (insert y ∅)) ∅).
  Notation "⟨ x , y ⟩" := (ordered_pair x y).
  Lemma pair_sound :
    forall {x y z w}, x ≡ z -> y ≡ w ->
                 ⟨x,y⟩ ≡ ⟨z,w⟩.
  Proof.
    unfold ordered_pair. intros.
    assert (x +> ∅ ≡ z +> ∅) by auto with zf.
    eauto with zf.
  Qed.
  Hint Resolve pair_sound : zf.

  Definition Suc x := x +> x.

  Parameter infinity : set.
  Notation "∞" := infinity (at level 60).
  Parameter infinity_prop :
    forall {x}, x ∈ ∞ -> Suc x ∈ ∞.
  Hint Resolve infinity_prop : zf.

  Definition left_total (P: set -> set -> Type) D := forall x, x ∈ D -> {y & P x y}.
  Definition functional (P: set -> set -> Type) := forall x y, P x y -> forall z, P x z -> y ≡ z.
  Definition relation_sound (P: set -> set -> Type) := forall x y, P x y -> forall z w, x ≡ z -> y ≡ w -> P z w.

  Definition formula P D := functional P ∧ relation_sound P ∧ left_total P D.

  Lemma left_total_sound : forall {P D}, left_total P D -> forall {E}, D ≡ E -> left_total P E.
  Proof.
    unfold left_total.
    eauto with zf.
  Defined.
  Hint Resolve left_total_sound : zf.

  Lemma formula_sound : forall {P D}, formula P D -> forall {E}, D ≡ E -> formula P E.
  Proof.
    unfold formula.
    intros. destruct X.
    split. auto.
    eauto with zf.
  Defined.
  Hint Resolve formula_sound : zf.

  Definition fun_sound : forall {I} (P: forall x, x ∈ I -> set) {J},
      I ≡ J -> forall x, x ∈ J -> set.
  Proof.
    intros.
    assert (x ∈ I) by eauto with zf.
    exact (P x X1).
  Defined.
  Hint Resolve fun_sound : zf.

  Parameter replacement : forall {I}, (forall x, x ∈ I -> set) -> set.
  Parameter collection : forall {P I}, formula P I -> set.
  Parameter replacement_sound : forall {I P J} (H: I ≡ J),
      replacement P ≡ replacement (fun_sound P H).
  Parameter collection_sound : forall {P I} (H: formula P I), forall {J} (H0: I ≡ J),
        collection H ≡ collection (formula_sound H H0).
  Parameter replacement_prop : forall {I P x}, x ∈ replacement P ↔ {i & {p: i ∈ I & P i p ≡ x}}.
  Parameter collection_prop : forall {P I} {H: formula P I} {x}, x ∈ collection H ↔ {i & i ∈ I ∧ P i x}.
  Hint Resolve replacement_sound : zf.
  Hint Resolve collection_sound : zf.
  Hint Resolve replacement_prop : zf.
  Hint Resolve collection_prop : zf.

  Definition prop_sound (P: set -> Type) := forall x y, x ≡ y -> P x = P y.

  Parameter induction :
    forall {P}, prop_sound P ->
           (forall x, (forall y, y ∈ x -> P y) -> P x) ->
           forall x, P x.
  Axiom induction_prop :
    forall {P} {H: prop_sound P} {H0 x}, induction H H0 x = H0 x (fun y _ => induction H H0 y).
End CZF.