(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Reals Psatz.

Require Import Xreal.
Require Import Basic.
Require Import Sig.
Require Import Interval.
Require Import Float.
Require Import Transcend.

Module FloatIntervalFull (F : FloatOps with Definition even_radix := true) <: IntervalOps.

Module F' := FloatExt F.
Module T := TranscendentalFloatFast F.
Include FloatInterval F.

Definition s1 := F.ZtoS 1.
Definition s2 := F.ZtoS 2.
Definition s3 := F.ZtoS 3.
Definition sm1 := F.ZtoS (-1).
Definition c1 := F.fromZ 1.
Definition cm1 := F.fromZ (-1).
Definition c3 := F.fromZ 3.

Definition pi prec :=
  scale2 (T.pi4 prec) s2.

Lemma pi_correct :
  forall prec, contains (convert (pi prec)) (Xreal PI).
Proof.
intros prec.
unfold pi.
replace (Xreal PI) with (Xmul (Xreal (PI/4)) (Xreal (Raux.bpow radix2 2))).
  apply scale2_correct, T.pi4_correct.
change (Raux.bpow _ _) with 4%R.
simpl.
apply f_equal.
field.
Qed.

(* accurate only for |xi| <= 2 * pi *)
Definition cos prec xi :=
  match abs xi with
  | Ibnd xl xu =>
    if F'.le xu xl then T.cos_fast prec xl else
    let pi4 := T.pi4 prec in
    if F'.le xu (F.scale2 (lower pi4) s2) then
      bnd (lower (T.cos_fast prec xu)) (upper (T.cos_fast prec xl))
    else
      if F'.le xu (F.scale2 (lower pi4) s3) then
        if F'.le (F.scale2 (upper pi4) s2) xl then
          bnd (lower (T.cos_fast prec xl)) (upper (T.cos_fast prec xu))
        else
          bnd cm1 (F.max (upper (T.cos_fast prec xl)) (upper (T.cos_fast prec xu)))
      else
        let d := F.sub_exact xu xl in
        if F'.le d c3 then
          let m := F.scale2 (F.add_exact xl xu) sm1 in
          let d := F.scale2 d sm1 in
          let c := T.cos_fast prec m in
          meet (bnd cm1 c1) (add prec c (bnd (F.neg d) d))
        else bnd cm1 c1
  | Inan => Inan
  end.

Lemma cos_correct :
  forall prec, extension Xcos (cos prec).
Proof.
intros prec xi x Hx.
unfold cos.
generalize (abs_correct xi x Hx) (abs_ge_0' xi).
destruct (abs xi) as [|xl xu].
easy.
intros Ha Hal.
simpl in Hal.
destruct x as [|x] ; try easy.
unfold Xbind.
replace (Rtrigo_def.cos x) with (Rtrigo_def.cos (Rabs x)).
2: unfold Rabs ; case Rcase_abs ; intros _ ; try easy ; apply cos_neg.
clear Hx.
assert (Hcxl := T.cos_fast_correct prec xl).
assert (Hcxu := T.cos_fast_correct prec xu).
case_eq (F'.le xu xl).
  intros Hl.
  apply F'.le_correct in Hl.
  simpl in Ha.
  destruct (F.toX xu) as [|xur] ; try easy.
  destruct (F.toX xl) as [|xlr] ; try easy.
  replace (Rabs x) with xlr.
  exact Hcxl.
  apply Rle_antisym.
  apply Ha.
  now apply Rle_trans with (2 := Hl).
intros _.
unfold cm1, c1, c3, sm1, s2, s3.
case_eq (F'.le xu (F.scale2 (lower (T.pi4 prec)) (F.ZtoS 2))).
  intros Hu.
  apply F'.le_correct in Hu.
  simpl in Ha.
  destruct (F.toX xu) as [|xur] ; try easy.
  assert (Hxur: (xur <= PI)%R).
    revert Hu.
    rewrite F.scale2_correct by easy.
    change (Raux.bpow _ _) with 4%R.
    generalize (T.pi4_correct prec).
    destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
    now rewrite F.nan_correct.
    intros [H _] Hu.
    destruct (F.toX pi4l) as [|pi4r] ; try easy.
    apply Rle_trans with (1 := Hu).
    lra.
  clear Hu.
  split.
    apply proj2 in Ha.
    destruct (T.cos_fast prec xu) as [|cu cu'] ; simpl.
      now rewrite F.nan_correct.
    destruct Hcxu as [Hcu _].
    destruct (F.toX cu) as [|cur] ; try easy.
    apply Rle_trans with (1 := Hcu).
    apply cos_decr_1 with (4 := Hxur) (5 := Ha).
    apply Rabs_pos.
    now apply Rle_trans with xur.
    apply Rle_trans with (2 := Ha).
    apply Rabs_pos.
  generalize (T.cos_fast_correct prec xl).
  destruct (T.cos_fast prec xl) as [|cl' cl] ; simpl.
    intros _.
    now rewrite F.nan_correct.
  destruct (F.toX xl) as [|xlr] ; try easy.
  intros [_ Hl].
  destruct (F.toX cl) as [|clr] ; try easy.
  apply Rle_trans with (2 := Hl).
  apply cos_decr_1 with (1 := Hal).
  apply Rle_trans with (2 := Hxur).
  now apply Rle_trans with (Rabs x).
  apply Rabs_pos.
  now apply Rle_trans with xur.
  apply Ha.
intros _.
case_eq (F'.le xu (F.scale2 (lower (T.pi4 prec)) (F.ZtoS 3))).
  intros Hu.
  apply F'.le_correct in Hu.
  simpl in Ha.
  destruct (F.toX xu) as [|xur] ; try easy.
  assert (Hxur: (xur <= 2 * PI)%R).
    revert Hu.
    rewrite F.scale2_correct by easy.
    change (Raux.bpow _ _) with 8%R.
    generalize (T.pi4_correct prec).
    destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
    now rewrite F.nan_correct.
    intros [H _] Hu.
    destruct (F.toX pi4l) as [|pi4r] ; try easy.
    apply Rle_trans with (1 := Hu).
    lra.
  clear Hu.
  case_eq (F'.le (F.scale2 (upper (T.pi4 prec)) (F.ZtoS 2)) xl).
    intros Hl.
    apply F'.le_correct in Hl.
    destruct (F.toX xl) as [|xlr].
    now destruct (F.toX (F.scale2 (upper (T.pi4 prec)) (F.ZtoS 2))).
    assert (Hxlr: (PI <= xlr)%R).
      revert Hl.
      rewrite F.scale2_correct by easy.
      change (Raux.bpow _ _) with 4%R.
      generalize (T.pi4_correct prec).
      destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
      now rewrite F.nan_correct.
      intros [_ H] Hl.
      destruct(F.toX pi4u) as [|pi4r] ; try easy.
      apply Rle_trans with (2 := Hl).
      lra.
    clear Hl.
    split.
      destruct (T.cos_fast prec xl) as [|cl cl'] ; simpl.
        now rewrite F.nan_correct.
      destruct Hcxl as [Hcl _].
      destruct (F.toX cl) as [|clr] ; try easy.
      apply Rle_trans with (1 := Hcl).
      apply cos_incr_1 with (1 := Hxlr) (5 := proj1 Ha).
      apply Rle_trans with (2 := Hxur).
      apply Rle_trans with (1 := proj1 Ha) (2 := proj2 Ha).
      apply Rle_trans with (1 := Hxlr) (2 := proj1 Ha).
      apply Rle_trans with (1 := proj2 Ha) (2 := Hxur).
    destruct (T.cos_fast prec xu) as [|cu' cu] ; simpl.
      now rewrite F.nan_correct.
    destruct Hcxu as [_ Hcu].
    destruct (F.toX cu) as [|cur] ; try easy.
    apply Rle_trans with (2 := Hcu).
    apply cos_incr_1 with (4 := Hxur) (5 := proj2 Ha).
    apply Rle_trans with (1 := Hxlr) (2 := proj1 Ha).
    apply Rle_trans with (1 := proj2 Ha) (2 := Hxur).
    apply Rle_trans with (1 := Hxlr).
    apply Rle_trans with (1 := proj1 Ha) (2 := proj2 Ha).
  intros _.
  split.
    rewrite F.fromZ_correct.
    apply COS_bound.
  rewrite F.max_correct.
  destruct (T.cos_fast prec xl) as [|cl' cl] ; simpl.
    now rewrite F.nan_correct.
  destruct (F.toX xl) as [|xlr] ; try easy.
  destruct Hcxl as [_ Hcl].
  destruct (F.toX cl) as [|clr] ; try easy.
  destruct (T.cos_fast prec xu) as [|cu' cu] ; simpl.
    now rewrite F.nan_correct.
  destruct Hcxu as [_ Hcu].
  destruct (F.toX cu) as [|cur] ; try easy.
  destruct (Rle_dec (Rabs x) PI) as [Hx|Hx].
    apply Rle_trans with (2 := Rmax_l _ _).
    apply Rle_trans with (2 := Hcl).
    apply cos_decr_1 with (1 := Hal) (3 := Rabs_pos _) (4 := Hx) (5 := proj1 Ha).
    apply Rle_trans with (1 := proj1 Ha) (2 := Hx).
  apply Rle_trans with (2 := Rmax_r _ _).
  apply Rle_trans with (2 := Hcu).
  apply Rnot_le_lt, Rlt_le in Hx.
  apply cos_incr_1 with (1 := Hx) (4 := Hxur) (5 := proj2 Ha).
  apply Rle_trans with (1 := proj2 Ha) (2 := Hxur).
  apply Rle_trans with (1 := Hx) (2 := proj2 Ha).
intros _.
case_eq (F'.le (F.sub_exact xu xl) (F.fromZ 3)).
  intros Hd.
  apply F'.le_correct in Hd.
  revert Hd.
  rewrite F.sub_exact_correct, F.fromZ_correct.
  case_eq (F.toX xu) ; try easy ; intros xur Hur.
  case_eq (F.toX xl) ; try easy ; intros xlr Hlr.
  intros _.
  apply meet_correct.
    unfold convert, bnd.
    rewrite 2!F.fromZ_correct.
    apply COS_bound.
  set (m := ((xlr + xur) / 2)%R).
  replace (Xreal (Rtrigo_def.cos (Rabs x)))
      with (Xadd (Xcos (Xreal m)) (Xreal (Rtrigo_def.cos (Rabs x) - Rtrigo_def.cos m)))
      by (apply (f_equal Xreal) ; ring).
  apply add_correct.
    replace (Xreal m) with (F.toX (F.scale2 (F.add_exact xl xu) (F.ZtoS (-1)))).
      apply T.cos_fast_correct.
    unfold m, T.toR.
    rewrite F.scale2_correct, F.add_exact_correct by easy.
    now rewrite Hlr, Hur.
  simpl.
  rewrite F.neg_correct, F.scale2_correct by easy.
  rewrite F.sub_exact_correct, Hlr, Hur.
  simpl.
  apply Raux.Rabs_le_inv.
  destruct (MVT_abs Rtrigo_def.cos (fun t => Ropp (sin t)) m (Rabs x)) as [v [-> _]].
  intros c _.
  apply derivable_pt_lim_cos.
  apply Rle_trans with (1 * Rabs (Rabs x - m))%R.
  apply Rmult_le_compat_r.
  apply Rabs_pos.
  rewrite Rabs_Ropp.
  apply Rabs_le, SIN_bound.
  rewrite Rmult_1_l.
  apply Rabs_le.
  revert Ha.
  simpl.
  rewrite Hlr, Hur.
  unfold m.
  change (Z.pow_pos 2 1) with 2%Z.
  lra.
intros _.
unfold convert, bnd.
rewrite 2!F.fromZ_correct.
apply COS_bound.
Qed.

(* accurate only for |xi| <= 5/2*pi *)
Definition sin prec xi :=
  match xi with
  | Ibnd xl xu =>
    if F'.le xu xl then T.sin_fast prec xl else
    let pi4 := T.pi4 prec in
    let pi2 := F.scale2 (lower pi4) s1 in
    match F'.le (F.neg pi2) xl, F'.le xu pi2 with
    | true, true =>
      bnd (lower (T.sin_fast prec xl)) (upper (T.sin_fast prec xu))
    | true, false =>
      cos prec (sub prec (scale2 pi4 s1) xi)
    | _, _ =>
      neg (cos prec (add prec xi (scale2 pi4 s1)))
    end
  | Inan => Inan
  end.

Theorem sin_correct :
  forall prec, extension Xsin (sin prec).
Proof.
intros prec [|xl xu] [|x] Hx ; try easy.
generalize Hx.
intros [Hxl Hxu].
simpl.
case_eq (F'.le xu xl).
  intros Hl.
  apply F'.le_correct in Hl.
  assert (Hsxl := T.sin_fast_correct prec xl).
  destruct (F.toX xu) as [|xur] ; try easy.
  destruct (F.toX xl) as [|xlr] ; try easy.
  replace x with xlr.
  exact Hsxl.
  apply Rle_antisym with (1 := Hxl).
  now apply Rle_trans with (2 := Hl).
intros _.
unfold s1.
set (pi2 := F.scale2 (lower (T.pi4 prec)) (F.ZtoS 1)).
case_eq (F'.le (F.neg pi2) xl).
  intros Hpl.
  generalize (F'.le_correct _ _ Hpl).
  xreal_tac xl.
    now case (F.toX (F.neg pi2)).
  clear Hpl. intros Hpl.
  case_eq (F'.le xu pi2).
    intros Hpu.
    generalize (F'.le_correct _ _ Hpu).
    xreal_tac xu. easy.
    xreal_tac pi2. easy.
    clear Hpu. intros Hpu.
    revert Hpl.
    rewrite F.neg_correct, X1.
    simpl.
    intros Hpl.
    generalize (F.scale2_correct (lower (T.pi4 prec)) 1 (refl_equal _)).
    intros X2.
    change (F.toX pi2 = Xmul (F.toX (lower (T.pi4 prec))) (Xreal 2)) in X2.
    rewrite X1 in X2. clear X1.
    revert X2.
    generalize (T.pi4_correct prec).
    case (T.pi4 prec) ; simpl.
      now rewrite F.nan_correct.
    intros p.
    xreal_tac p. easy.
    intros _ [Hp _] H.
    injection H.
    clear H X1. intros H.
    assert (Hpl': (-(PI/2) <= r)%R).
      apply Rle_trans with (2 := Hpl).
      apply Ropp_le_contravar.
      rewrite H.
      replace (PI / 2)%R with (PI / 4 * 2)%R by field.
      apply Rmult_le_compat_r with (2 := Hp).
      now apply IZR_le.
    assert (Hpu': (r0 <= PI/2)%R).
      apply Rle_trans with (1 := Hpu).
      rewrite H.
      replace (PI / 2)%R with (PI / 4 * 2)%R by field.
      apply Rmult_le_compat_r with (2 := Hp).
      now apply IZR_le.
    split.
      generalize (T.sin_fast_correct prec xl).
      destruct (T.sin_fast prec xl) as [|yl yu].
        simpl.
        now rewrite F.nan_correct.
      rewrite X.
      simpl.
      xreal_tac yl. easy.
      intros [Hy _].
      apply Rle_trans with (1 := Hy).
      assert (H' := Rle_trans _ _ _ Hxu Hpu').
      apply sin_incr_1 ; try easy.
      now apply Rle_trans with x.
      now apply Rle_trans with r.
    generalize (T.sin_fast_correct prec xu).
    destruct (T.sin_fast prec xu) as [|yl yu].
      simpl.
      now rewrite F.nan_correct.
    rewrite X0.
    simpl.
    xreal_tac yu. easy.
    intros [_ Hy].
    apply Rle_trans with (2 := Hy).
    assert (H' := Rle_trans _ _ _ Hpl' Hxl).
    apply sin_incr_1 ; try easy.
    now apply Rle_trans with r0.
    now apply Rle_trans with x.
  intros _.
  rewrite <- cos_shift.
  change (Xreal (Rtrigo_def.cos (PI / 2 - x))) with (Xcos (Xsub (Xreal (PI / 2)) (Xreal x))).
  apply cos_correct.
  apply sub_correct with (2 := Hx).
  replace (PI / 2)%R with (PI / 4 * 2)%R by field.
  apply (scale2_correct _ (Xreal (PI / 4)) 1%Z).
  apply T.pi4_correct.
intros _.
rewrite <- (Ropp_involutive x).
rewrite sin_neg.
apply (neg_correct _ (Xreal _)).
rewrite <- cos_shift.
replace (PI / 2 - - x)%R with (x + PI / 2)%R by ring.
change (Xreal (Rtrigo_def.cos (x + PI / 2))) with (Xcos (Xadd (Xreal x) (Xreal (PI / 2)))).
apply cos_correct.
apply (add_correct _ _ _ _ _ Hx).
replace (PI / 2)%R with (PI / 4 * 2)%R by field.
apply (scale2_correct _ (Xreal (PI / 4)) 1%Z).
apply T.pi4_correct.
Qed.

(* meaningful only for |xi| <= pi/2 *)
Definition tan prec xi :=
  match xi with
  | Ibnd xl xu =>
    if F'.le xu xl then T.tan_fast prec xl else
    let pi2 := F.scale2 (lower (T.pi4 prec)) s1 in
    match F'.lt (F.neg pi2) xl, F'.lt xu pi2 with
    | true, true =>
      bnd (lower (T.tan_fast prec xl)) (upper (T.tan_fast prec xu))
    | _, _ => Inan
    end
  | Inan => Inan
  end.

Lemma tan_correct :
  forall prec, extension Xtan (tan prec).
Proof.
intros prec [|xl xu] [|x] Hx ; try easy.
unfold tan.
case_eq (F'.le xu xl).
  intros Hl.
  apply F'.le_correct in Hl.
  assert (Htxl := T.tan_fast_correct prec xl).
  unfold convert in Hx, Hl.
  destruct (F.toX xu) as [|xur] ; try easy.
  destruct (F.toX xl) as [|xlr] ; try easy.
  replace x with xlr.
  exact Htxl.
  apply Rle_antisym with (1 := proj1 Hx).
  apply Rle_trans with (2 := Hl).
  apply Hx.
unfold s1.
intros _.
case_eq (F'.lt (F.neg (F.scale2 (lower (T.pi4 prec)) (F.ZtoS 1))) xl) ; try easy.
intros Hlt1.
apply F'.lt_correct in Hlt1.
case_eq (F'.lt xu (F.scale2 (lower (T.pi4 prec)) (F.ZtoS 1))) ; try easy.
intros Hlt2.
apply F'.lt_correct in Hlt2.
generalize (T.tan_correct prec xl) (T.tan_correct prec xu).
simpl in Hx.
destruct (F.toX xl) as [|rl].
now destruct (F.toX (F.neg (F.scale2 (lower (T.pi4 prec)) (F.ZtoS 1)))).
destruct (F.toX xu) as [|ru] ; try easy.
intros Hl Hu.
rewrite bnd_correct.
rewrite F.neg_correct in Hlt1.
rewrite F.scale2_correct in Hlt1, Hlt2 by easy.
generalize (T.pi4_correct prec).
destruct (T.pi4 prec) as [|pi4l pi4u].
simpl in Hlt1.
now rewrite F.nan_correct in Hlt1.
intros [Hpil _].
simpl in Hlt1, Hlt2.
destruct (F.toX pi4l) as [|pi4r] ; try easy.
simpl in Hlt1, Hlt2.
apply (Rmult_le_compat_r 2) in Hpil.
2: now apply IZR_le.
unfold Rdiv in Hpil.
replace (PI * /4 * 2)%R with (PI / 2)%R in Hpil by field.
assert (H1: (- PI / 2 < rl)%R).
  apply Rle_lt_trans with (2 := Hlt1).
  unfold Rdiv.
  rewrite Ropp_mult_distr_l_reverse.
  now apply Ropp_le_contravar.
assert (H2: (ru < PI / 2)%R).
  now apply Rlt_le_trans with (pi4r * 2)%R.
unfold Xtan'.
simpl.
case is_zero_spec.
simpl in Hx.
apply Rgt_not_eq, cos_gt_0.
apply Rlt_le_trans with (2 := proj1 Hx).
unfold Rdiv.
now rewrite <- Ropp_mult_distr_l_reverse.
now apply Rle_lt_trans with ru.
unfold Xtan' in Hl, Hu.
intros _.
split.
- destruct (T.tan_fast prec xl) as [|tl tu].
  simpl.
  now rewrite F.nan_correct.
  revert Hl.
  simpl.
  case is_zero_spec ; try easy.
  intros _ [H _].
  destruct (F.toX tl) as [|rtl] ; try easy.
  apply Rle_trans with (1 := H).
  destruct (proj1 Hx) as [Hx'|Hx'].
  apply Rlt_le.
  apply tan_increasing ; try easy.
  now apply Rle_lt_trans with ru.
  rewrite Hx'.
  apply Rle_refl.
- destruct (T.tan_fast prec xu) as [|tl tu].
  simpl.
  now rewrite F.nan_correct.
  revert Hu.
  simpl.
  case is_zero_spec ; try easy.
  intros _ [_ H].
  destruct (F.toX tu) as [|rtu] ; try easy.
  apply Rle_trans with (2 := H).
  destruct (proj2 Hx) as [Hx'|Hx'].
  apply Rlt_le.
  apply tan_increasing ; try easy.
  now apply Rlt_le_trans with rl.
  rewrite Hx'.
  apply Rle_refl.
Qed.

Definition atan prec xi :=
  match xi with
  | Ibnd xl xu =>
    Ibnd
     (if F.real xl then lower (T.atan_fast prec xl)
      else F.neg (F.scale2 (upper (T.pi4 prec)) s1))
     (if F.real xu then upper (T.atan_fast prec xu)
      else F.scale2 (upper (T.pi4 prec)) s1)
  | Inan => Inan
  end.

Lemma atan_correct :
  forall prec, extension Xatan (atan prec).
Proof.
intros prec [|xl xu] [|x] Hx ; try easy.
assert (Hpi := T.pi4_correct prec).
simpl.
rewrite 2!F.real_correct.
simpl in Hx.
unfold s1.
split.
- generalize (proj1 Hx). clear Hx.
  case_eq (F.toX xl).
  intros _ _.
  rewrite F.neg_correct.
  rewrite F.scale2_correct by easy.
  destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
  now rewrite F.nan_correct.
  simpl in Hpi.
  destruct (F.toX pi4u) as [|rpi4] ; try easy.
  apply Rlt_le.
  apply Rle_lt_trans with (2 := proj1 (atan_bound x)).
  replace (- PI / 2)%R with (-(PI / 4 * 2))%R by field.
  apply Ropp_le_contravar.
  apply Rmult_le_compat_r with (2 := proj2 Hpi).
  now apply IZR_le.
  intros rl Hl Hx.
  generalize (T.atan_correct prec xl).
  destruct (T.atan_fast prec xl) as [|al au].
  intros _.
  simpl.
  now rewrite F.nan_correct.
  simpl.
  rewrite Hl.
  destruct (F.toX al) as [|ral] ; try easy.
  intros [H _].
  apply Rle_trans with (1 := H).
  destruct Hx as [Hx|Hx].
  now apply Rlt_le, atan_increasing.
  rewrite Hx.
  apply Rle_refl.
- generalize (proj2 Hx). clear Hx.
  case_eq (F.toX xu).
  intros _ _.
  rewrite F.scale2_correct by easy.
  destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
  now rewrite F.nan_correct.
  simpl in Hpi.
  destruct (F.toX pi4u) as [|rpi4] ; try easy.
  apply Rlt_le.
  apply Rlt_le_trans with (1 := proj2 (atan_bound x)).
  replace (PI / 2)%R with (PI / 4 * 2)%R by field.
  apply Rmult_le_compat_r with (2 := proj2 Hpi).
  now apply IZR_le.
  intros rl Hl Hx.
  generalize (T.atan_correct prec xu).
  destruct (T.atan_fast prec xu) as [|al au].
  intros _.
  simpl.
  now rewrite F.nan_correct.
  simpl.
  rewrite Hl.
  destruct (F.toX au) as [|rau] ; try easy.
  intros [_ H].
  apply Rle_trans with (2 := H).
  destruct Hx as [Hx|Hx].
  now apply Rlt_le, atan_increasing.
  rewrite Hx.
  apply Rle_refl.
Qed.

Definition exp prec xi :=
  match xi with
  | Ibnd xl xu =>
    Ibnd
     (if F.real xl then lower (T.exp_fast prec xl) else F.zero)
     (if F.real xu then upper (T.exp_fast prec xu) else F.nan)
  | Inan => Inan
  end.

Theorem exp_correct :
  forall prec, extension Xexp (exp prec).
Proof.
intros prec [|xl xu].
trivial.
intros [|x].
trivial.
intros (Hxl, Hxu).
split.
(* lower *)
clear Hxu.
rewrite F.real_correct.
xreal_tac xl.
rewrite F.zero_correct.
simpl.
apply Rlt_le.
apply exp_pos.
generalize (T.exp_fast_correct prec xl).
destruct (T.exp_fast prec xl) as [|yl yu].
unfold lower.
now rewrite F.nan_correct.
rewrite X.
intros (H, _).
simpl.
xreal_tac2.
apply Rle_trans with (1 := H).
now apply Raux.exp_le.
(* upper *)
clear Hxl.
rewrite F.real_correct.
xreal_tac xu.
now rewrite F.nan_correct.
generalize (T.exp_fast_correct prec xu).
destruct (T.exp_fast prec xu) as [|yl yu].
unfold upper.
now rewrite F.nan_correct.
rewrite X.
intros (_, H).
simpl.
xreal_tac2.
apply Rle_trans with (2 := H).
now apply Raux.exp_le.
Qed.

Definition ln prec xi :=
  match xi with
  | Ibnd xl xu =>
    if F'.lt F.zero xl then
      Ibnd
        (lower (T.ln_fast prec xl))
        (if F.real xu then upper (T.ln_fast prec xu) else F.nan)
    else Inan
  | Inan => Inan
  end.

Theorem ln_correct :
  forall prec, extension Xln (ln prec).
Proof.
intros prec [|xl xu].
easy.
unfold Xln'.
intros [|x].
easy.
simpl.
intros [Hl Hu].
case_eq (F'.lt F.zero xl) ; intros Hlt ; try easy.
apply F'.lt_correct in Hlt.
rewrite F.zero_correct in Hlt.
simpl in Hlt.
case is_positive_spec.
intros Hx.
split.
generalize (T.ln_fast_correct prec xl).
case T.ln_fast.
intros _.
simpl.
now rewrite F.nan_correct.
intros l u.
simpl.
case_eq (Xln (F.toX xl)).
easy.
intros lnx Hlnx.
intros [H _].
destruct (F.toX l) as [|lr].
easy.
apply Rle_trans with (1 := H).
destruct (F.toX xl) as [|xlr].
easy.
revert Hlnx.
unfold Xln'.
simpl.
case is_positive_spec.
intros _ H'.
injection H'.
intros <-.
destruct Hl as [Hl|Hl].
now apply Rlt_le, ln_increasing.
rewrite Hl.
apply Rle_refl.
easy.
rewrite F.real_correct.
case_eq (F.toX xu).
now rewrite F.nan_correct.
intros xur Hxu.
rewrite Hxu in Hu.
generalize (T.ln_fast_correct prec xu).
case T.ln_fast.
intros _.
simpl.
now rewrite F.nan_correct.
intros l u.
simpl.
rewrite Hxu.
unfold Xln'.
simpl.
case is_positive_spec.
intros _.
intros [_ H].
destruct (F.toX u) as [|ur].
easy.
apply Rle_trans with (2 := H).
destruct Hu as [Hu|Hu].
now apply Rlt_le, ln_increasing.
rewrite Hu.
apply Rle_refl.
easy.
intros Hx.
destruct (F.toX xl) as [|xlr].
easy.
elim Rle_not_lt with (1 := Hx).
now apply Rlt_le_trans with xlr.
Qed.

End FloatIntervalFull.


Require Import ZArith.
Require Import Reals.
Require Import RPolS.
Require Import PolSBase.
Require Import PolFBase.
Require Import PolAux.
Require Import PolAuxList.
Require Import RSignTac.

Definition Rfactor :=
  factor Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Definition Rfactor_minus :=
  factor_sub Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Ltac Rfactor_term term1 term2 :=
let term := constr:(Rminus term1 term2) in
let rfv := FV RCst Rplus Rmult Rminus Ropp term (@nil R) in
let fv := Trev rfv in
let expr1 := mkPolexpr Z RCst Rplus Rmult Rminus Ropp term1 fv in
let expr2 := mkPolexpr Z RCst Rplus Rmult Rminus Ropp term2 fv in
let re := eval vm_compute in (Rfactor_minus (PEsub expr1 expr2)) in
let factor := match re with (PEmul ?X1 _) => X1 end in
let expr3 := match re with (PEmul _ (PEsub ?X1 _)) => X1 end in
let expr4 := match re with (PEmul _ (PEsub _ ?X1 )) => X1 end in
let
 re1' :=
  eval
     unfold
      Rconvert_back, convert_back,  pos_nth,  jump,
         hd,  tl, Z2R, P2R in (Rconvert_back (PEmul factor expr3) fv) in
let re1'' := eval lazy beta in re1' in
let
 re2' :=
  eval
     unfold
      Rconvert_back, convert_back,  pos_nth,  jump,
         hd,  tl, Z2R, P2R in (Rconvert_back (PEmul factor expr4) fv) in
let re2'' := eval lazy beta in re2' in
replace2_tac term1 term2 re1'' re2''; [idtac| ring | ring].

Ltac rpolf :=
progress (
(try
match goal with
| |- (?X1 = ?X2)%R =>  Rfactor_term X1 X2
| |- (?X1 <> ?X2)%R =>  Rfactor_term X1 X2
| |- Rlt ?X1 ?X2 => Rfactor_term X1 X2
| |- Rgt ?X1 ?X2 =>Rfactor_term X1 X2
| |- Rle ?X1 ?X2 => Rfactor_term X1 X2
| |- Rge ?X1 ?X2 =>Rfactor_term X1 X2
| _ => fail end)); try (rsign_tac); try repeat (rewrite Rmult_1_l || rewrite Rmult_1_r).

Ltac hyp_rpolf H :=
progress (
generalize H;
(try
match type of H with
  (?X1 = ?X2)%R =>  Rfactor_term X1 X2
| (?X1 <> ?X2)%R =>  Rfactor_term X1 X2
| Rlt ?X1 ?X2 => Rfactor_term X1 X2
| Rgt ?X1 ?X2 =>Rfactor_term X1 X2
| Rle ?X1 ?X2 => Rfactor_term X1 X2
| Rge ?X1 ?X2 =>Rfactor_term X1 X2
| _ => fail end)); clear H; intros H; try (hyp_rsign_tac H); try repeat rewrite Rmult_1_l in H.


(* Función de búsqueda *)
Fixpoint lookup1 (key: N) (t: binTrie1) : option nat :=
match t with
| empty1 => None
| leaf1 x => Some x
| trie1 t1 t2 => if (N.even key) then lookup1 (N.div2 key) t1
                else lookup1 (N.div2 key) t2
end.


(** Coq coding by choukh, Aug 2020 **)

Require Import ZFC.Lib.Natural.

(* 以ω为指标集的集族的并 *)
Definition IFUnion : (set → set) → set :=
  λ F, ⋃{F n | n ∊ ω}.
Notation "'⋃ᵢ' F" := (IFUnion F)
  (at level 9, right associativity).

Lemma IFUnionI : ∀ F : set → set, ∀n ∈ ω, F n ⊆ ⋃ᵢ F.
Proof.
  intros F n Hn. unfold Sub. now apply FUnionI.
Qed.

Lemma IFUnionE : ∀ F : set → set, ∀x ∈ ⋃ᵢ F, ∃n ∈ ω, x ∈ F n.
Proof.
  intros F x Hx. apply FUnionE in Hx as [n [Hn H]].
  exists n. split; auto.
Qed.

Lemma nat_IFUnionI : ∀ F : nat → set, ∀ n : nat, F n ⊆ ⋃ᵢ F.
Proof.
  intros * x Hx. eapply FUnionI. apply (embed_ran n).
  rewrite proj_embed_id. apply Hx.
Qed.

Lemma nat_IFUnionE : ∀ F : nat → set, ∀x ∈ ⋃ᵢ F, ∃ n, x ∈ F n.
Proof.
  intros F x Hx. apply FUnionE in Hx as [n [Hn H]].
  exists n. apply H.
Qed.


Require Export Iron.Language.SystemF2r.TyEnv.
Require Export Iron.Language.SystemF2r.Ty.
Require Export Iron.Language.SystemF2r.Ki.

(* Expressions *)
Inductive exp : Type :=
 | XVar  : nat -> exp
 | XLAM  : exp -> exp
 | XAPP  : exp -> ty  -> exp
 | XLam  : ty  -> exp -> exp
 | XApp  : exp -> exp -> exp.
Hint Constructors exp.

(* Weak normal forms cannot be reduced further by
   call-by-value evaluation. *)
Inductive wnfX : exp -> Prop :=
 | Wnf_XVar
   : forall i
   , wnfX (XVar i)

 | Wnf_XLAM
   : forall x1
   , wnfX (XLAM x1)

 | Wnf_XLam
   : forall t1 x2
   , wnfX (XLam t1 x2).
Hint Constructors wnfX.

(* A well formed expression is closed under the given environments *)
Fixpoint wfX (kn: nat) (tn: nat) (xx: exp) : Prop :=
 match xx with
 | XVar ti    => ti < tn
 | XLAM x     => wfX (S kn) tn x
 | XAPP x t   => wfX kn tn x  /\ wfT kn t
 | XLam t x   => wfT kn t     /\ wfX kn (S tn) x
 | XApp x1 x2 => wfX kn tn x1 /\ wfX kn tn x2
 end.
Hint Unfold wfX.

(* A closed expression is well formed under an empty environment. *)
Definition closedX (xx: exp) : Prop
 := wfX O O xx.
Hint Unfold closedX.

(* Values are closed expressions that cannot be reduced further *)
Inductive value : exp -> Prop :=
 | Value
   :  forall xx
   ,  wnfX xx -> closedX xx
   -> value xx.
Hint Constructors value.

Lemma value_wnfX
 : forall xx, value xx -> wnfX xx.
 Proof. intros. inverts H. auto. Qed.
Hint Resolve value_wnfX.

Lemma value_closedX
 : forall xx, value xx -> closedX xx.
 Proof. intros. inverts H. auto. Qed.
Hint Resolve value_closedX.

(********************************************************************)
(* Lift type indices in expressions. *)
Fixpoint liftTX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar _     => xx

  |  XLAM x
  => XLAM (liftTX (S d) x)

  |  XAPP x t
  => XAPP (liftTX d x)   (liftTT 1 d t)

  |  XLam t x
  => XLam (liftTT 1 d t) (liftTX d x)

  |  XApp x1 x2
  => XApp (liftTX d x1)  (liftTX d x2)
 end.

(* Lift value indices in expressions. *)
Fixpoint liftXX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar ix
  => if le_gt_dec d ix
      then XVar (S ix)
      else xx

  |  XLAM x
  => XLAM (liftXX d x)

  |  XAPP x t
  => XAPP (liftXX d x) t

  |  XLam t x
  => XLam t (liftXX (S d) x)

  |  XApp x1 x2
  => XApp (liftXX d x1) (liftXX d x2)
 end.

(********************************************************************)
(* Substitution of Types in Exps *)
Fixpoint substTX (d: nat) (u: ty) (xx: exp) : exp :=
  match xx with
  | XVar _     => xx

  |  XLAM x
  => XLAM (substTX (S d) (liftTT 1 0 u) x)

  |  XAPP x t
  => XAPP (substTX d u x)  (substTT d u t)

  |  XLam t x
  => XLam (substTT d u t)  (substTX d u x)

  |  XApp x1 x2
  => XApp (substTX d u x1) (substTX d u x2)
 end.

(* Substitution of Exps in Exps *)
Fixpoint substXX (d: nat) (u: exp) (xx: exp) : exp :=
  match xx with
  | XVar ix
  => match nat_compare ix d with
     | Eq => u
     | Gt => XVar (ix - 1)
     | _  => XVar  ix
     end

  |  XLAM x
  => XLAM (substXX d (liftTX 0 u) x)

  |  XAPP x t
  => XAPP (substXX d u x) t

  |  XLam t x
  => XLam t (substXX (S d) (liftXX 0 u) x)

  |  XApp x1 x2
  => XApp (substXX d u x1) (substXX d u x2)
  end.


Require Import List.

Section NoetherianImplStreamless.
  Variable A : Set.

  Fixpoint existsLi (P:A->Prop) (l:list A) : Prop :=
    match l with
      | nil => False
      | h::tail => (P h \/ (existsLi P tail))
    end.

  Fixpoint goodLi (R:A-> A->Prop) (l:list A) : Prop :=
    match l with
      | nil => False
      | a::tail => (existsLi (R a) tail \/ goodLi R tail)
    end.

  Inductive accessible (P: list A->Prop) (l:list A): Prop:=
  | accessibleBase: P l -> accessible P l
  | accessibleInd: (forall x : A, accessible P (x :: l)) -> accessible P l.

  Fixpoint Initials (n:nat) (f: nat -> A) : list A :=
    match n with
      | 0 => nil
      | S n => (f n) :: (Initials n f)
    end.

  Definition Noetherian (R: A -> A ->Prop) : Prop := accessible (goodLi R) nil.
  Definition Streamless  (R: A -> A ->Prop) : Prop := forall f:nat -> A,exists n:nat, (goodLi R) (Initials n f).

  Definition goodLiImplGoodF (R:A-> A->Prop)  (f:nat -> A) (l:list A) : Prop :=  goodLi R l -> goodLi R (Initials (length l) f).
  Definition raListImpliesRaF (R:A->A->Prop)  (f:nat -> A) (l:list A) : Prop :=  forall a:A, existsLi (R a) l -> existsLi (R a) (Initials (length l) f).

  (* This version is rather verbose to make clear what happens, it can be made shorter by using "inversion H1;auto"  *)
  Lemma noeimplstrHelp (R: A -> A ->Prop) (f:nat->A) : forall l:list A, accessible (goodLi R) l  -> (goodLiImplGoodF R f l) -> (raListImpliesRaF R f l) -> exists m, (goodLi R) (Initials m f).
  Proof.
    intros l acc eqGood eqRRel .
    unfold goodLiImplGoodF in eqGood.
    unfold raListImpliesRaF in eqRRel.
    induction acc.
    exists (length l).
    apply eqGood;auto.
    pose (H0 (f (length l))).
    apply e.
    intro H1.
    simpl.
    inversion H1.
    left.
    apply eqRRel.
    exact H2.
    right.
    apply eqGood.
    exact H2.
    (* inversion H1;auto. *)
    intros a H1.
    inversion H1.
    simpl.
    left.
    exact H2.
    right.
    pose (eqRRel a) as e0.
    apply e0;auto.
  Qed.

  Lemma NoeimplStr (R:A->A->Prop) : Noetherian R -> Streamless R.
  Proof.
    unfold Noetherian.
    intros acc f.
    apply noeimplstrHelp with (l:=nil);auto.
    intro H; contradiction H.
    intros a H; contradiction H.
  Qed.

End NoetherianImplStreamless.


(* experimentations on HoTT *)
(* requires coq 8.5 *)

Require Import Utf8 QArith NPeano.
Require Import chap1 chap2.
Set Universe Polymorphism.

(* no default implicit without arguments *)
Arguments eq_refl [A] x.

Notation "⊥" := False.
Notation "⊤" := True.
Notation "'ℬ'" := (bool : Type).
Notation "A ⇔ B" := ((A → B) * (B → A))%type (at level 100).
Notation "( x , y ) '_{' P }" := (existT P x y)
  (at level 0, format "'[' ( x ,  y ) _{ P } ']'", only parsing).

(*
Tactic Notation "transparent" "assert" "(" ident(H) ":" lconstr(type) ")" :=
 refine (let H := (_ : type) in _).
*)
Tactic Notation "transparent" "assert" "(" ident(H) ":" lconstr(type) ")" :=
 unshelve (refine (let H := (_ : type) in _)).

Open Scope nat_scope.

Theorem Nat_le_neq_lt : ∀ a b, a ≤ b → a ≠ b → a < b.
Proof.
intros a b Hab Hnab.
apply le_lt_eq_dec in Hab.
destruct Hab as [Hle| Heq]; [ assumption | idtac ].
exfalso; apply Hnab; assumption.
Qed.

(* Chapter 3 - Sets and logic *)

(* 3.1 Sets and n-types *)

(* Definition 3.1 *)

Definition isSet A := ∀ (x y : A) (p q : x = y), p = q.

(* personal solution *)
Definition ex_3_1_2_tac : isSet True.
Proof.
intros x y p q.
destruct x, y.
refine (match p with eq_refl _ => _ end).
refine (match q with eq_refl _ => _ end).
reflexivity.
Defined.

Definition ex_3_1_2 : isSet True :=
  λ (x y : True),
  match x with
  | I =>
      match y with
      | I =>
          λ p q,
          match p with
          | eq_refl _ => match q with eq_refl _ => eq_refl _ end
          end
      end
  end.

(* "For by Theorem 2.8.1, for any x, y : 1 the type (x = y) is
    equivalent to 1. Since any two elements of 1 are equal, this
    implies that any two elements of x = y are equal." *)

(* hott_2_8_1 : ∀ x y : True, (x = y) ≃ True *)

(* ex_3_1_2_alt_tac *)

Definition isSet_True : isSet ⊤.
Proof.
intros x y p q.
pose proof hott_2_8_1 x y as r.
destruct r as (f, ((g, Hg), (h, Hh))).
unfold "◦", "∼", id in Hg, Hh.
pose proof Hh p as Hp.
pose proof Hh q as Hq.
destruct (f p), (f q).
subst p q; reflexivity.
Defined.

(* "Example 3.1.3. The type 0 is a set, for given any x, y : 0 we may
    deduce anything we like, by the induction principle of 0." *)

Definition ex_3_1_3_tac : isSet False.
Proof.
intros x y p q.
destruct x.
Defined.

Definition ex_3_1_3 : isSet False := λ x y, match x with end.

(* bool is also a set *)

Definition isSet_bool : isSet ℬ.
Proof.
intros x y p q.
destruct x, y; try discriminate p.
 refine (match p with eq_refl _ => _ end).
 refine (match q with eq_refl _ => _ end).
 reflexivity.

 refine (match p with eq_refl _ => _ end).
 refine (match q with eq_refl _ => _ end).
 reflexivity.
Defined.

(* "Example 3.1.4. The type ℕ of natural numbers is also a set. This
    follows from Theorem 2.13.1, since all equality types x =_{ℕ} y
    are equivalent to either 1 or 0, and any two inhabitants of 1 or 0
    are equal. We will see another proof of this fact in Chapter 7." *)

(* ℕ.hott_2_13_1 : ∀ m n : ℕ, (m = n) ≃ ℕ.code m n *)

Definition N_code_equiv_1_or_0 m n :
  (N.code m n ≃ True) + (N.code m n ≃ False).
Proof.
destruct (eq_nat_dec m n) as [H1| H1].
 left; subst m.
 exists (λ c, I); apply qinv_isequiv.
 exists (λ _, N.r n).
 unfold "◦", "∼", id; simpl.
 split; [ intros u; destruct u; reflexivity | intros c ].
 induction n; [ destruct c; reflexivity | apply IHn ].

 right.
 exists (λ c, H1 (N.decode m n c)); apply qinv_isequiv.
 exists (λ p : False, match p with end).
 unfold "◦", "∼", id.
 split; [ intros p; destruct p | ].
 intros c; destruct (H1 (N.decode m n c)).
Defined.

(* ex_3_1_4 *)

Definition isSet_nat_tac : isSet ℕ.
Proof.
intros m n p q.
pose proof N.hott_2_13_1 m n as r.
pose proof N_code_equiv_1_or_0 m n as s.
destruct s as [s| s].
 eapply equiv_compose in s; [ | apply r ].
 destruct s as (f, ((g, Hg), (h, Hh))).
 unfold "◦", "∼", id in Hg, Hh.
 pose proof Hh p as Hp.
 pose proof Hh q as Hq.
 destruct (f p), (f q).
 subst p q; reflexivity.

 eapply equiv_compose in s; [ | apply r ].
 destruct s as (f, ((g, Hg), (h, Hh))).
 exfalso; apply f, p.
Defined.

Definition isSet_nat : isSet ℕ :=
  λ (m n : ℕ) (p q : m = n),
  match N_code_equiv_1_or_0 m n with
  | inl s =>
      match s ◦◦ N.hott_2_13_1 m n with
      | existT _ f (existT _ g Hg, existT _ h Hh) =>
          match f p with
          | I =>
              λ (Hp0 : h I = p),
              match f q as u1 return (h u1 = q → p = q) with
              | I =>
                  λ Hq0 : h I = q,
                  eq_ind (h I) (λ p0 : m = n, p0 = q)
                    (eq_ind (h I)
                       (λ q0 : m = n, h I = q0) (eq_refl _) q Hq0) p
                    Hp0
              end (Hh q)
          end (Hh p)
      end
  | inr s =>
      match s ◦◦ N.hott_2_13_1 m n with
      | existT _ f _ => match f p with end
      end
  end.

(* "Example 3.1.5. If A and B are sets, then so is A × B." *)

(* not sure of what I've done in this proof, but I completed it;
   perhaps simplifiable, understandable? *)
Definition ex_3_1_5 {A B} : isSet A → isSet B → isSet (A * B).
Proof.
intros r s x y p q.
pose proof cartesian.hott_2_6_2 x y as e.
destruct x as (xa, xb).
destruct y as (ya, yb); simpl in e.
apply quasi_inv in e.
destruct e as (f, ((g, Hg), (h, Hh))).
unfold "◦", "∼", id in Hg, Hh.
pose proof Hh p as Hhp.
pose proof Hh q as Hhq.
destruct (f p) as (fpa, fpb).
destruct (f q) as (fqa, fqb).
pose proof r xa ya fpa fqa as Hra.
pose proof s xb yb fpb fqb as Hrb.
destruct Hra, Hrb.
destruct Hhp; assumption.
Defined.

(* "Similarly, if A is a set and B : A → U is such that each B(x) is a
    set, then Σ(x:A),B(x) is a set." *)

(* just like ex_3_1_5 above, not sure of what I've done in this proof,
   but I completed it; perhaps simplifiable, understandable too? *)
Definition ex_3_1_5_bis A B :
  isSet A → (Π (x : A), isSet (B x)) → isSet (Σ (x : A), B x).
Proof.
intros r s x y p q.
pose proof Σ_type.hott_2_7_2 B x y as e.
destruct x as (xa, xb).
destruct y as (ya, yb); simpl in e.
destruct e as (f, ((g, Hg), (h, Hh))).
unfold "◦", "∼", id in Hg, Hh.
pose proof Hh p as Hhp.
pose proof Hh q as Hhq.
destruct (f p) as (fpa, fpb).
destruct (f q) as (fqa, fqb).
pose proof r xa ya fpa fqa as Hra.
destruct Hhp.
subst fpa.
rewrite <- Hhq.
apply ap, ap, s.
Defined.

(* "Example 3.1.6. If A is any type and B : A → U is such that each
    B(x) is a set, then the type Π (x:A), B(x) is a set." *)

Section ex_3_1_6.

Import Π_type.

Definition ex_3_1_6 A B : (Π (a : A), isSet (B a)) → isSet (Π (a : A), B a).
Proof.
intros r f g p q.
unfold isSet in r.
pose proof funext_prop_uniq_princ f g p as Hp.
pose proof funext_prop_uniq_princ f g q as Hq.
assert (∀ x : A, happly _ _ p x = happly _ _ q x) as Hx by (intros; apply r).
apply funext in Hx.
rewrite Hp, Hq, Hx.
reflexivity.
Defined.

End ex_3_1_6.

(* "Definition 3.1.7. A type A is a 1-type if for all x, y : A and p,
    q : x = y and r, s : p = q, we have r = s." *)

Definition is1Type A := ∀ (x y : A) (p q : x = y) (r s : p = q), r = s.

(* "Lemma 3.1.8. If A is a set (that is, isSet(A) is inhabited), then
    A is a 1-type." *)

Section lemma_3_1_8.

Import Σ_type2.

(* required, but general purpose lemma, tac and exp versions *)
Definition compose_cancel_l_tac {A} {x y z : A} (p : x = y) (q r : y = z) :
  p • q = p • r
  → q = r.
Proof.
intros H.
eapply (dotl p⁻¹) in H.
eapply compose.
 eapply compose; [ | apply H ].
 eapply compose; [ | eapply invert, compose_assoc ].
 eapply compose; [ apply lu | apply dotr ].
 apply invert, compose_invert_l.

 eapply compose; [ eapply compose_assoc | ].
 eapply compose; [ | eapply invert, lu ].
 apply dotr, compose_invert_l.
Defined.

Definition compose_cancel_l {A} {x y z : A} (p : x = y) (q r : y = z) :
  p • q = p • r
  → q = r
:=
  λ s,
  lu q • ((compose_invert_l p)⁻¹ •r q) • (compose_assoc p⁻¹ p q)⁻¹ •
  (p⁻¹ •l s) •
  compose_assoc p⁻¹ p r • (compose_invert_l p •r r) • (lu r)⁻¹.

Definition compose_cancel_r_tac {A} {x y z : A} (p q : x = y) (r : y = z) :
  p • r = q • r
  → p = q.
Proof.
intros H.
eapply (dotr r⁻¹) in H.
eapply compose.
 eapply compose; [ | apply H ].
 eapply compose; [ | eapply compose_assoc ].
 eapply compose; [ apply ru | apply dotl ].
 apply invert, compose_invert_r.

 eapply compose; [ eapply invert, compose_assoc | ].
 eapply compose; [ | eapply invert, ru ].
 apply dotl, compose_invert_r.
Defined.

Definition compose_cancel_r {A} {x y z : A} (p q : x = y) (r : y = z) :
  p • r = q • r
  → p = q
:=
  λ s,
  ru p • (p •l (compose_invert_r r)⁻¹) • compose_assoc p r r⁻¹
  • (s •r r⁻¹)
  • (compose_assoc q r r⁻¹)⁻¹ • (q •l compose_invert_r r) • (ru q)⁻¹.

(* magic lemma to prove isSet → is1Type and also used later for
   ispType → isSpType *)
Definition compose_insert_tac {A x} (f : Π (y : A), x = y) {y z} (p : y = z) :
  f y • p = f z.
Proof.
eapply compose; [ | apply (apd f p) ].
eapply invert; destruct p; simpl; apply ru.
Defined.

Definition compose_insert {A x} (f : Π (y : A), x = y) {y z} (p : y = z) :
  f y • p = f z
:=
  match p return f y • p = transport (eq x) p (f y) with
  | eq_refl _ => (ru (f y))⁻¹
  end
  • apd f p.

(* done but not obvious at all; I had to look at the way they did it,
   and I am sure I don't understand the point *)
Definition hott_3_1_8_tac {A} : isSet A → is1Type A.
Proof.
intros f x y p q r s.
apply (compose_cancel_l (f x y p p)).
eapply compose; [ eapply (compose_insert (f x y p)) | ].
apply invert, compose_insert.
Defined.

Definition hott_3_1_8 {A} : isSet A → is1Type A :=
  λ f x y p q r s,
  let g := f x y p in
  compose_cancel_l (g p) r s (compose_insert g r • (compose_insert g s)⁻¹).

End lemma_3_1_8.

(* generalization *)

Definition isProp A : Type := Π (x : A), Π (y : A), x = y.

Fixpoint ispType (A : Type) p : Type :=
  match p with
  | 0 => isProp A
  | S p' => ∀ x y : A, ispType (x = y) p'
  end.

(* A n-type has property 'ispType A (S n)', because the n of n-types
   starts at -1 *)

Definition ispType_isSpType_tac {A : Type} n : ispType A n → ispType A (S n).
Proof.
intros f x y.
revert A f x y.
induction n; intros.
 intros p q.
 apply (compose_cancel_l (f x x)).
 eapply compose; [ eapply (compose_insert (f x)) | ].
 apply invert, compose_insert.

 intros p q; apply IHn, f.
Defined.

Definition ispType_isSpType {A : Type} n : ispType A n → ispType A (S n) :=
  nat_rect
    (λ n, ∀ A, ispType A n → ispType A (S n))
    (λ A f x y p q,
     compose_cancel_l (f x x) p q
       (compose_insert (f x) p • (compose_insert (f x) q)⁻¹))
    (λ n IHn A f x y, IHn (x = y) (f x y))
    n A.

(* "Example 3.1.9. The universe U is not a set." *)

Definition ex_3_1_9_tac : ¬isSet Type.
Proof.
intros r.
unfold isSet in r.
pose proof r bool bool (ua bool_eq_bool_id) (ua bool_eq_bool_negb) as s.
apply (ap idtoeqv) in s.
eapply compose in s; [ | eapply invert, idtoeqv_ua ].
eapply invert, compose in s; [ | eapply invert, idtoeqv_ua ].
unfold bool_eq_bool_id, bool_eq_bool_negb in s.
simpl in s.
injection s; intros H _ _.
assert (negb true = true) as H1; [ rewrite H; reflexivity | ].
revert H1; apply Σ_type2.hott_2_12_6.
Defined.

Definition isSet_Type_counterex (r : isSet Type) {A B} (p q : A ≃ B) : p = q :=
 (idtoeqv_ua p)⁻¹ • ap idtoeqv (r A B (ua p) (ua q)) • idtoeqv_ua q.

Definition ex_3_1_9 : ¬ isSet Type :=
  λ r : isSet Type,
  let ni : negb = id :=
    match isSet_Type_counterex r bool_eq_bool_negb bool_eq_bool_id with
    | eq_refl _ => eq_refl (Σ_type.pr₁ (pr₂ (Σ_type.pr₂ bool_eq_bool_negb)))
    end
  in
  Σ_type2.hott_2_12_6 (eq_ind_r (λ b, b true = true) (eq_refl true) ni).

(* 3.2 Propositions as types? *)

Section hott_3_2_2.
Import Σ_type.
Import Π_type.

(* "Theorem 3.2.2. It is not the case that for all A : Type we have
    ¬(¬A)→A." *)

Definition hott_3_2_2_tac : notT (∀ A, notT (notT A) → A).
Proof.
intros f.
set (u := (λ g, g true) : notT (notT bool)); simpl in u.
set (nn A := notT (notT A)).
assert (p : pr₁ bool_eq_bool_negb (f _ u) = f _ u).
 eapply compose; [ eapply invert, ua_pcr | ].
 eapply compose; [ | apply (happly _ _ (apd f (ua bool_eq_bool_negb))) ].
 eapply invert, compose.
  apply
    (happly _ _ (@hott_2_9_4 _ nn id _ _ (ua bool_eq_bool_negb) (f bool)) u).

  apply ap, ap, funext; intros g; destruct (g true).

 eapply no_fixpoint_negb, p.
Defined.

Definition hott_3_2_2 : notT (∀ A : Type, notT (notT A) → A)
:=
  λ f,
  let e := bool_eq_bool_negb in
  let u (x : notT ℬ) := x true in
  let nn A := notT (notT A) in
  no_fixpoint_negb (f bool u)
    ((ua_pcr e (f bool u))⁻¹
      • (happly _ _ (@hott_2_9_4 _ nn id _ _ (ua e) (f bool)) u
         • ap ((ua e)⁎ ◦ f bool)
             (funext (λ (x : notT bool), match x true with end)))⁻¹
      • happly _ _ (apd f (ua e)) u).

End hott_3_2_2.

(* "Corollary 3.2.7. It is not the case that for all A : Type we have
    A+(¬A)." *)

Definition hott_3_2_7_tac : notT (∀ A, A + notT A).
Proof.
intros g.
apply hott_3_2_2; intros A u.
destruct (g A) as [a| w]; [ apply a | destruct (u w) ].
Defined.

Definition hott_3_2_7 : notT (∀ A, A + notT A)
:=
  λ g,
  hott_3_2_2
    (λ A u,
     match g A with
     | inl a => a
     | inr w => match u w with end
     end).

(* "3.3 Mere propositions" *)

(* "Definition 3.3.1. A type P is a mere proposition if for all x, y :
    P we have x = y." *)

(* Print isProp. *)

(* "Lemma 3.3.2. If P is a mere proposition and x0 : P, then P ≃ 1." *)

Definition hott_3_3_2_tac P : isProp P → ∀ x₀ : P, P ≃ True.
Proof.
intros HP x₀.
exists (λ _, I); apply qinv_isequiv.
exists (λ _, x₀).
split; intros x; [ destruct x; reflexivity | apply HP ].
Defined.

Definition hott_3_3_2 P : isProp P → ∀ x₀ : P, P ≃ True
:=
  λ (HP : isProp P) (x₀ : P),
  existT isequiv (λ _, I)
    (qinv_isequiv (λ _, I)
       (existT _ (λ _, x₀)
          (λ x, match x with I => eq_refl (id I) end,  λ x, HP _ x))).

(* "Lemma 3.3.3. If P and Q are mere propositions such that P → Q and
    Q → P, then P ≃ Q." *)

Definition hott_3_3_3_tac P Q :
  isProp P → isProp Q → (P → Q) → (Q → P) → P ≃ Q.
Proof.
intros p q f g.
exists f; apply qinv_isequiv; exists g.
split; intros x; [ apply q | apply p ].
Defined.

Definition hott_3_3_3 P Q : isProp P → isProp Q → (P → Q) → (Q → P) → P ≃ Q
:=
  λ (p : isProp P) (q : isProp Q) (f : P → Q) (g : Q → P),
  existT isequiv f (qinv_isequiv f (existT _ g (λ y, q _ y, λ x, p _ x))).

Definition isContractible P := (isProp P * (P ≃ True))%type.

(* "Lemma 3.3.4. Every mere proposition is a set." *)

Definition isProp_isSet A : isProp A → isSet A := ispType_isSpType 0.

(* "Lemma 3.3.5. For any type A, the types isProp(A) and isSet(A)
    are mere propositions." *)

Section Lemma_3_3_5.

Import Π_type.

Definition hott_3_3_5_i_tac A : isProp (isProp A).
Proof.
intros f g.
eapply funext; intros x.
eapply funext; intros y.
apply (isProp_isSet _ f).
Defined.

Definition hott_3_3_5_i A : isProp (isProp A) :=
  λ f g, funext (λ x, funext (λ y, isProp_isSet A f x y (f x y) (g x y))).

Definition hott_3_3_5_ii_tac A : isProp (isSet A).
Proof.
intros f g.
eapply funext; intros x.
eapply funext; intros y.
eapply funext; intros p.
eapply funext; intros q.
apply (ispType_isSpType 1), f.
Defined.

Definition hott_3_3_5_ii A : isProp (isSet A) :=
  λ f g,
  funext
    (λ x,
     funext
       (λ y,
        funext
          (λ p,
           funext
             (λ q, ispType_isSpType 1 f x y p q (f x y p q) (g x y p q))))).

Definition isProp_isequiv {A B} (f : A → B) : isProp (isequiv f).
Proof.
intros e₁ e₂.
pose proof equivalence_isequiv f as pf.
destruct pf as ((qi, iq), eqv).
apply eqv.
Defined.

End Lemma_3_3_5.

(* "3.4 Classical vs. intuitionistic logic" *)

(* "law of excluded middle in homotopy type theory:
       LEM : Π (A:Type), (isProp(A) → (A + ¬A))      (3.4.1)" *)

Definition LEM := Π (A : Type), (isProp A → (A + notT A)).

(* "law of double negation
       Π (A:Type), (isProp A → (¬¬A → A))            (3.4.2)" *)

Definition LDN := Π (A : Type), (isProp A → (notT (notT A) → A)).

(* LEM and LDN are logically equivalent (ex 3.18) *)

Definition isProp_notT_tac A : isProp (A → ⊥).
Proof.
intros x y.
apply Π_type.funext; intros z; destruct (x z).
Defined.

Definition isProp_notT A : isProp (A → ⊥) :=
  λ x y : A → ⊥, Π_type.funext (λ (z : A), match x z with end).

Definition LEM_LDN : (LEM → LDN) * (LDN → LEM).
Proof.
split.
 intros HLEM A HP HNA.
 destruct (HLEM A HP) as [x| x]; [ apply x | destruct (HNA x) ].

 intros HLDN A HPA.
 apply HLDN.
 intros x y.
 destruct x as [x| x].
  destruct y as [y| y]; [ apply Σ_type2.inl_equal, HPA | destruct (y x) ].

  destruct y as [y| y]; [ destruct (x y) | ].
  apply Σ_type2.inr_equal.
  apply HLDN; [ apply (ispType_isSpType 0), isProp_notT | ].
  intros HNE; apply HNE, isProp_notT.

  intros HNA; apply HNA.
  right; intros HA; apply HNA.
  left; apply HA.
Defined.

(* "For emphasis, the proper version (3.4.1) may be denoted LEM-₁" *)

Definition LEM_p p := Π (A : Type), (ispType A p → (A + notT A)).
Definition LEM_inf := Π (A : Type), (A + notT A).

(* "Definition 3.4.3.
      (i) A type A is called decidable if A + ¬A.
     (ii) Similarly, a type family B : A → Type is decidable if
              Π(a:A)(B(a) + ¬B(a)).
    (iii) In particular, A has decidable equality if
              Π(a,b:A)((a = b) + ¬(a = b))." *)

Definition isDecidable A := (A + notT A)%type.
Definition isDecidableFamily A B := Π (a : A), (B a + notT (B a)).
Definition hasDecidableEq A := Π (a : A), Π (b : A), ((a = b) + notT (a = b)).

(* "3.5 Subsets and propositional resizing" *)

Section hott_3_5.

Import Σ_type.

(* "Lemma 3.5.1. Suppose P : A → Type is a type family such that P(x) is
    a mere proposition for all x : A. If u, v : Σ(x:A) P(x) are such
    that pr₁(u) = pr₁(v), then u = v." *)

Definition hott_3_5_1_my_proof_tac {A} (P : A → Type) :
  (Π (x : A), isProp (P x))
  → ∀ u v : (Σ (x : A), P x),
  pr₁ u = pr₁ v
  → u = v.
Proof.
intros HP u v p.
destruct u as (ua, up); simpl in p.
destruct v as (va, vp); simpl in p.
eapply compose; [ eapply (pair_eq p), HP | reflexivity ].
Defined.

Definition hott_3_5_1_my_proof {A} (P : A → Type) :
  (Π (x : A), isProp (P x))
  → ∀ u v : (Σ (x : A), P x),
  pr₁ u = pr₁ v
  → u = v
:=
  λ HP u v,
  match u with existT _ ua up =>
    match v with existT _ va vp =>
    λ p, pair⁼ p (HP va (transport P p up) vp)
    end
  end.

(* their proof *)

Definition hott_3_5_1_tac A (P : A → Type) :
  (Π (x : A), isProp (P x))
  → ∀ u v : (Σ (x : A), P x),
  pr₁ u = pr₁ v
  → u = v.
Proof.
intros HP u v p.
pose proof @hott_2_7_2 A P u v as H.
destruct H as (f, ((g, Hg), (h, Hh))).
apply g, (existT _ p), HP.
Defined.

Definition hott_3_5_1 A (P : A → Type) :
  (Π (x : A), isProp (P x))
  → ∀ u v : (Σ (x : A), P x),
  pr₁ u = pr₁ v
  → u = v
:=
  λ HP u v p,
  match hott_2_7_2 P u v with
  | existT _ _ (existT _ g _, _) =>
      g (existT _ p (HP (pr₁ v) (p⁎ (pr₂ u)) (pr₂ v)))
  end.

Definition SetU := {A : Type & isSet A}.
Definition PropU := {A : Type & isProp A}.

Definition SetU_equiv_eq A B s t :
  (existT isSet A s = existT isSet B t) ≃ (A = B).
Proof.
exists
  (λ p : existT isSet A s = existT isSet B t,
   match p in (_ = s0) return (let (b, _) := s0 in A = b) with
   | eq_refl _ => eq_refl A
   end).
apply qinv_isequiv.
exists (hott_3_5_1 _ isSet hott_3_3_5_ii (existT isSet A s) (existT isSet B t)).
unfold "◦", "∼", id; simpl.
split.
 intros p.
 unfold hott_3_5_1; simpl.
 destruct (hott_2_7_2 isSet (existT isSet A s) (existT isSet B t)) as (f, H).
 destruct H as ((g, Hg), (h, Hh)).
 unfold hott_3_3_5_ii; simpl.
 destruct p; simpl.
 (* equivalent, equivalent... are they really equivalent?
    or just logically equivalent? *)
Abort.

End hott_3_5.

(* "Recall that for any two universes Ui and Ui+1, if A : Ui then also
    A : Ui+1. Thus, for any (A, s) : SetUi we also have (A, s) : SetUi+1,
    and similarly for PropUi , giving natural maps
       SetUi → SetUi+1,              (3.5.3)
       PropUi → PropUi+1.            (3.5.4)" *)

(* ok, but I don't know how to program the hierarchy of universes in Coq;
   and the following axiom cannot be written either *)

(* "Axiom 3.5.5 (Propositional resizing). The map PropUi → PropUi+1 is
    an equivalence." *)

(* "3.6 The logic of mere propositions" *)

Section hott_3_6.

(* "Example 3.6.1. If A and B are mere propositions, so is A x B." *)

Definition ex_3_6_1 {A B} : isProp A → isProp B → isProp (A * B).
Proof.
intros HA HB x y.
destruct x as (xa, xb).
destruct y as (ya, yb).
apply cartesian.pair_eq; simpl.
split; [ apply HA | apply HB ].
Defined.

(* "Example 3.6.2. If A is any type and B : A → Type is such that for all
    x : A, the type B(x) is a mere proposition, then Π(x:A) B(x) is a
    mere proposition." *)

Import Π_type.

Definition ex_3_6_2 {A B} :
  (Π (x : A), isProp (B x)) → isProp (Π (x : A), B x).
Proof.
intros HP f g.
apply funext; intros x; apply HP.
Defined.

Definition isPropImp {A B} : isProp B → isProp (A → B).
Proof.
intros * H.
intros; apply ex_3_6_2; intros x; apply H.
Defined.

Definition isPropNot {A} : isProp A → isProp (notT A).
Proof.
intros. apply isPropImp; intros x y; destruct x.
Defined.

End hott_3_6.

(* "3.7 Propositional truncation" *)

Axiom PT : Type → Type.
Arguments PT _%type.
Notation "∥ A ∥" := (PT A) (A at level 0, format "∥ A ∥") : type_scope.

Axiom PT_intro : ∀ A, A → ∥A∥.
Arguments PT_intro [A] x.
Notation "╎ A ╎" := (PT_intro A) (A at level 0, format "╎ A ╎") : type_scope.

Axiom PT_eq : ∀ A, isProp ∥A∥.
(* Arguments PT_eq [A] x y. *)

(* "If B is a mere proposition and we have f : A → B, then there is an
    induced g : ∥A∥ → B such that g(|a|) ≡ f(a) for all a : A." *)

Axiom PT_rec : ∀ A B (f : A → B), isProp B →
  Σ (g : ∥A∥ → B), ∀ a, g (PT_intro a) = f a.

Definition PT_elim {A} : isProp A → ∥A∥ → A :=
  λ PA, Σ_type.pr₁ (PT_rec A A id PA).
Definition PT_intro_not {A} : notT A → notT ∥A∥ :=
  λ f, Σ_type.pr₁ (PT_rec A ⊥ f (λ x y : ⊥, match x with end)).

(* "3.8 The axiom of choice" *)

Definition ACX X :=
  ∀ (A : X → Type) (P : Π (x : X), (A x → Type)),
  isSet X
  → (Π (x : X), isSet (A x))
  → (Π (x : X), Π (a : A x), isProp (P x a))
  → (Π (x : X), ∥ (Σ (a : A x), P x a) ∥)
  → ∥ (Σ (g : Π (x : X), A x), Π (x : X), P x (g x)) ∥.

Definition AC := ∀ (X : Type), ACX X.

Definition AC_3_8_3 :=
  ∀ (X : Type) (Y : X → Type), isSet X → (Π (x : X), isSet (Y x))
  → (Π (x : X), ∥ (Y x) ∥) → ∥ (Π (x : X), Y x) ∥.

Definition hott_3_8_2 : AC ≃ AC_3_8_3.
Proof.
apply hott_3_3_3.
 do 7 (apply ex_3_6_2; intros); apply PT_eq.

 do 5 (apply ex_3_6_2; intros); apply PT_eq.

 intros AC₁ X Y SX SY YX.
 unfold AC in AC₁; rename AC₁ into AC.
 assert (H1 : ∀ x : X, Y x → isProp ⊤).
  intros _ _ x y.
  apply (Σ_type.pr₁ (quasi_inv (hott_2_8_1 x y))), x.

  assert (H2 : ∀ x : X, ∥{_ : Y x & ⊤}∥).
   intros x.
   apply (PT_rec (Y x)); [ | apply PT_eq | apply YX ].
   intros y; apply PT_intro, (existT (λ (_ : Y x), True) (y : Y x) I).

   pose proof AC X Y (λ _ _, ⊤) SX SY H1 H2 as H; simpl in H.
   assert (f : {_ : ∀ x : X, Y x & X → ⊤} → ∥(∀ x : X, Y x)∥).
    intros H3; apply PT_intro, H3.

    assert (PB : isProp ∥(∀ x : X, Y x)∥) by apply PT_eq.
    apply (Σ_type.pr₁ (PT_rec _ _ f PB) H).

 unfold AC.
 intros H X A P SX SA PP H1.
 pose proof (λ A P, ua (quasi_inv (@UnivProp.hott_2_15_7 X A P))) as H3.
 rewrite H3.
 apply (λ S, H X (λ x, Σ (a : A x), P x a) SX S H1); intros x.
 apply ex_3_1_5_bis; [ apply SA | intros y; apply isProp_isSet, PP ].
Defined.

Definition isProp_Σ_type_tac {A B} :
  isProp A → (Π (x : A), isProp (B x)) → isProp Σ (x : A), B x.
Proof.
intros PA PB (x₁, x₂) (y₁, y₂).
pose proof (PA x₁ y₁) as H; destruct H.
pose proof (PB x₁ x₂ y₂) as H; destruct H.
reflexivity.
Defined.

Definition isProp_Σ_type {A B} :
  isProp A → (Π (x : A), isProp (B x)) → isProp Σ (x : A), B x
:=
  λ PA PB x,
  match x with
  | existT _ x₁ x₂ =>
      λ y,
      match y with
      | existT _ y₁ y₂ =>
          match PA x₁ y₁ with
          | eq_refl _ =>
              λ y₂,
              match PB x₁ x₂ y₂  with
              | eq_refl _ => eq_refl (existT B x₁ x₂)
              end
          end y₂
      end
  end.

Definition AC_3_8_3_equiv :=
  ∀ (X : Type) (Y : X → Type), isSet X → (Π (x : X), isSet (Y x))
  → (Π (x : X), ∥ (Y x) ∥) ≃ ∥ (Π (x : X), Y x) ∥.

Definition AC_equiv_3_8_3_equiv : AC ≃ AC_3_8_3_equiv.
Proof.
eapply equiv_compose; [ apply hott_3_8_2 |  ].
apply hott_3_3_3.
 do 5 (apply ex_3_6_2; intros).
 intros u v; apply PT_eq.

 do 4 (apply ex_3_6_2; intros).
 unfold equivalence.
 apply isProp_Σ_type.
  apply ex_3_6_2; intros.
  intros u v; apply PT_eq.

  intros y; apply isProp_isequiv.

 unfold AC_3_8_3, AC_3_8_3_equiv.
 intros AC X Y SX SY.
 apply hott_3_3_3.
  apply ex_3_6_2; intros; intros u v; apply PT_eq.

  intros u v; apply PT_eq.

  intros H; apply AC; assumption.

  intros H x.
  pose proof (λ B PB H1, Σ_type.pr₁ (PT_rec (∀ x : X, Y x) B H1 PB) H) as H1.
  apply H1; [ apply PT_eq | intros H2; apply PT_intro, H2 ].

 unfold AC_3_8_3, AC_3_8_3_equiv.
 intros AC X Y SX SY.
 apply hott_3_3_3.
  apply ex_3_6_2; intros; intros u v; apply PT_eq.

  intros u v; apply PT_eq.

  intros H; apply AC; assumption.

  intros H x.
  pose proof (λ B PB H1, Σ_type.pr₁ (PT_rec (∀ x : X, Y x) B H1 PB) H) as H1.
  apply H1; [ apply PT_eq | intros H2; apply PT_intro, H2 ].
Defined.

(* equivalence is a set, whenever A and B are *)

Definition isSet_equiv {A B : Set} : isSet A → isSet B → isSet (A ≃ B).
Proof.
intros SA SB.
apply ex_3_1_5_bis; [ apply ex_3_1_6; intros; apply SB | idtac ].
intros f; apply isProp_isSet, isProp_isequiv.
Defined.

(* "Lemma 3.8.5. There exists a type X and a family Y : X → Type such
    that each Y(x) is a set, but such that (3.8.3) is false." *)

(* If I understand well, the axiom of choice is not compatible with
   families of sets whose father is not a set. *)

Definition pair_eq_bool_trunc := Σ (A : Type), ∥(ℬ = A)∥.

Definition equiv_eq_pair_trunc A B p q :
  ((existT _ A p : pair_eq_bool_trunc) = existT _ B q) ≃ (A ≃ B).
Proof.
intros; simpl.
exists
  (λ H,
   (λ
    H2 : Σ_type.pr₁ (existT (λ A0 : Type, ∥(ℬ = A0)∥) A p)
         ≃ Σ_type.pr₁ (existT (λ A0 : Type, ∥(ℬ = A0)∥) B q), H2)
     (idtoeqv (ap Σ_type.pr₁ H))).
apply qinv_isequiv.
exists (λ r : A ≃ B, Σ_type.pair_eq (ua r) (PT_eq _ ((ua r)⁎ p) q)).
unfold "◦", "∼", id; simpl.
split.
 intros r.
 rewrite <- idtoeqv_ua; f_equal.
 destruct (ua r); simpl; unfold id.
 destruct (PT_eq _ p q); reflexivity.

 intros r.
 rewrite ua_idtoeqv.
 refine match r with
        | eq_refl _ => _
        end; simpl; unfold id.
 assert (SA : isSet ∥(ℬ = A)∥) by apply isProp_isSet, PT_eq.
 assert (H : PT_eq _ p p = eq_refl p) by apply SA.
 rewrite H; reflexivity.
Defined.

Definition equiv_eq_bool_trunc :
  (existT (λ A, ∥(ℬ = A)∥) ℬ (PT_intro (eq_refl ℬ)) =
   existT (λ A, ∥(ℬ = A)∥) ℬ (PT_intro (eq_refl ℬ))) ≃
   (ℬ ≃ ℬ).
Proof.
intros; apply equiv_eq_pair_trunc.
Defined.

Definition hott_3_8_5 :
  Σ (X : Type), Σ (Y : X → Type),
  notT ((Π (x : X), ∥(Y x)∥) → ∥(Π (x : X), Y x)∥).
Proof.
set (X := Σ (A : Type), ∥(ℬ = A)∥).
set (x₀ := existT _ ℬ (PT_intro (eq_refl ℬ)):X); simpl in x₀.
set (Y := λ x, x₀ = x : Type); simpl in Y.
exists X, Y; intros H1.
apply (@PT_intro_not (∀ x, Y x)).
 intros H2; subst Y; simpl in H2.
 assert (PX : isProp X).
  intros x y.
  transitivity x₀; [ symmetry; apply H2 | apply H2 ].

  apply isProp_isSet in PX.
  destruct equiv_eq_bool_trunc as (f, ((g, Hg), _)).
  pose proof (PX x₀ x₀ (g bool_eq_bool_id) (g bool_eq_bool_negb)) as s.
  unfold bool_eq_bool_id, bool_eq_bool_negb in s; simpl in s.
  apply (ap f) in s.
  eapply compose in s; [ symmetry in s | eapply invert, Hg ].
  eapply compose in s; [ symmetry in s | eapply invert, Hg ].
  apply EqdepFacts.eq_sigT_fst in s.
  pose proof (hap s false) as H3.
  revert H3; apply Σ_type2.hott_2_12_6.

 apply H1; intros (A, p); subst x₀.
 apply (PT_rec (ℬ = A)); [ | apply PT_eq | assumption ].
 intros q; destruct q.
 apply PT_intro, (Σ_type.pair_eq (eq_refl ℬ)), PT_eq.
Defined.

(* "3.9 The principle of unique choice" *)

(* Lemma 3.9.1 *)

Definition hott_3_9_1_tac {P} : isProp P → P ≃ ∥P∥.
Proof.
intros PP.
apply hott_3_3_3; [ assumption | apply PT_eq | apply PT_intro | ].
apply PT_elim; assumption.
Defined.

Definition hott_3_9_1 {P} : isProp P → P ≃ ∥P∥ :=
  λ (PP : isProp P),
  hott_3_3_3 P ∥P∥ PP (PT_eq P) (PT_intro (A:=P)) (PT_elim PP).

(* "Corollary 3.9.2 (The principle of unique choice). Suppose a type
    family P : A → U such that
         (i) For each x, the type P(x) is a mere proposition, and
        (ii) For each x we have ∥P(x)∥.
    Then we have ∏ (x:A) P(x)." *)

Definition hott_3_9_2 {A P} :
  (Π (x : A), isProp (P x)) → (Π (x : A), ∥(P x)∥) → Π (x : A), P x.
Proof.
intros PP PTP x.
apply PT_elim; [ apply PP | apply PTP ].
Defined.

(* "3.10 When are propositions truncated?" *)

(* "3.11 Contractibility" *)

Section Contr.
Import Σ_type.

(* "In Lemma 3.3.2 we observed that a mere proposition which is
    inhabited must be equivalent to 1, and it is not hard to see
    that the converse also holds." *)

Definition hott_3_3_2_conv P : ∀ x₀ : P, P ≃ ⊤ → isProp P.
Proof.
intros x₀ H x y.
destruct H as (f, ((g, Hg), (h, Hh))).
unfold "◦", "∼", id in Hg, Hh.
do 2 (rewrite <- Hh; symmetry).
apply ap.
destruct (f x), (f y); reflexivity.
Defined.

(* "Definition 3.11.1. A type A is *contractible*, or a *singleton*,
    if there is a : A, called the *center of contraction*, such that
    a = x for all x : A. We denote the specified path a = x by contr_x." *)

Definition isContr A := Σ (a : A), Π (x : A), a = x.

(* "Lemma 3.11.3. For a type A, the following are logically
    equivalent.
        (i) A is contractible in the sense of Definition 3.11.1.
       (ii) A is a mere proposition, and there is a point a : A.
      (iii) A is equivalent to 1." *)

Definition isContr_isProp A : isContr A → isProp A.
Proof.
intros p x y.
destruct p as (a, p).
transitivity a; [ symmetry; apply p | apply p ].
Defined.

Definition hott_3_11_3_i_ii A : isContr A → isProp A * Σ (a : A), ⊤.
Proof.
intros p.
split; [ apply isContr_isProp; assumption | ].
destruct p as (a, p).
exists a; constructor.
Defined.

Definition hott_3_11_3_ii_iii A : isProp A * (Σ (a : A), ⊤) → A ≃ ⊤.
Proof.
intros (p, (a, _)).
apply hott_3_3_2; assumption.
Defined.

Definition hott_3_11_3_iii_i A : A ≃ ⊤ → isContr A.
Proof.
intros p.
apply EqStr.equiv_fun in p.
destruct p as (f, (g, (Hg, Hh))).
exists (g I); intros x.
etransitivity; [ | apply Hg ].
destruct (f x); reflexivity.
Defined.

(* "Lemma 3.11.4. For any type A, the type isContr(A) is a mere
    proposition." *)

Definition hott_3_11_4 A : isProp (isContr A).
Proof.
intros c c'.
assert (isProp A) as r by (apply isContr_isProp; assumption).
destruct c as (a, p).
destruct c' as (a', p').
set (q := p a').
apply (pair_eq q).
unfold transport.
destruct q; unfold id.
apply isProp_isSet in r.
apply Π_type.funext; intros x; apply r.
Defined.

(* "Corollary 3.11.5. If A is contractible, then so is isContr(A)." *)

Definition hott_3_11_5 A : isContr A → isContr (isContr A).
Proof.
intros c.
apply hott_3_11_3_iii_i, hott_3_11_3_ii_iii.
split; [ apply hott_3_11_4 | ].
exists c; constructor.
Defined.

(* "Lemma 3.11.6. If P : A → U is a type family such that each P(a)
    is contractible, then ∏ (x:A) P(x) is contractible." *)

Definition hott_3_11_6 {A P} :
  (Π (a : A), isContr (P a)) → isContr (Π (x : A), P x).
Proof.
intros p.
unfold isContr.
exists (λ a, pr₁ (p a)); intros f.
apply Π_type.funext; intros x.
pose proof p x as q.
apply isContr_isProp in q; apply q.
Defined.

(* "Of course, if A is equivalent to B and A is contractible, then so
    is B." *)

Definition equiv_contr {A B} : A ≃ B → isContr A → isContr B.
Proof.
intros p q.
apply hott_3_11_3_i_ii, hott_3_11_3_ii_iii in q.
apply quasi_inv in p.
eapply equiv_compose in q; [ | apply p ].
apply hott_3_11_3_iii_i; assumption.
Defined.

(* "By definition, a *retraction* is a function r : A → B such that
    there exists a function s : B → A, called its *section*, and a
    homotopy : ∏ (y:B) (r(s(y)) = y); then we say that B is a
    *retract* of A." *)

Definition retraction A B :=
  Σ (r : A → B), Σ (s : B → A), Π (y : B), (r (s y) = y).

Definition section {A B} : retraction A B → B → A := λ r, pr₁ (pr₂ r).

Definition retract A : Type := Σ (B : Type), retraction A B.

(* "Lemma 3.11.7. If B is a retract of A, and A is contractible, then
    so is B." *)

Definition hott_3_11_7_tac A B (r : retraction A B) : isContr A → isContr B.
Proof.
intros p.
destruct r as (r, (s, q)).
destruct p as (a₀, p).
exists (r a₀); intros b₀.
eapply compose; [ | apply (q b₀) ].
apply ap, p.
Defined.

Definition hott_3_11_7 A B (r : retraction A B) : isContr A → isContr B
:=
  λ (p : isContr A),
  match r with
  | existT _ r (existT _ s q) =>
      match p with
      | existT _ a₀ p =>
          existT (λ b, ∀ b₀, b = b₀) (r a₀) (λ b₀, ap r (p (s b₀)) • q b₀)
      end
  end.

(* "Lemma 3.11.8. For any A and any a : A, the type Σ (x:A) (a = x)
    is contractible." *)

Definition hott_3_11_8 {A} : ∀ a : A, isContr (Σ (x : A), a = x).
Proof.
intros a.
exists (existT _ a (eq_refl a)).
intros (x, p).
destruct p; reflexivity.
Defined.

(* "Lemma 3.11.9. Let P : A → U be a type family.
      (i) If each P(x) is contractible, then ∑(x:A) P(x) is
          equivalent to A.
     (ii) If A is contractible with center a, then ∑(x:A) P(x) is
          equivalent to P(a)." *)

Definition hott_3_11_9_i {A P} :
  (Π (x : A), isContr (P x)) → (Σ (x : A), P x) ≃ A.
Proof.
intros p.
exists pr₁; apply qinv_isequiv.
exists (λ x, existT _ x (pr₁ (p x))).
unfold "◦", "∼", id; simpl.
split; [ reflexivity | intros x ].
destruct x as (a, q); simpl.
apply (pair_eq (eq_refl a)); simpl; unfold id.
assert (isProp (P a)) as H; [ | apply H ].
apply isContr_isProp, p.
Defined.

Definition hott_3_11_9_ii_tac {A P} (p : isContr A) (a := pr₁ p) :
  (Σ (x : A), P x) ≃ P a.
Proof.
subst a; destruct p as (a, p); simpl.
exists (λ q : {x : A & P x}, transport P (p (pr₁ q))⁻¹ (pr₂ q)).
apply qinv_isequiv.
exists (λ q : P a, existT (λ x : A, P x) a (transport P (p a) q)).
unfold "◦", "∼", id; simpl.
split.
 intros x.
 eapply compose; [ apply transport_compose |  ].
 eapply compose; [ apply transport_compat, compose_invert_r | reflexivity ].

 intros (b, q); simpl.
 apply (pair_eq (p b)).
 eapply compose; [ apply transport_compose |  ].
 eapply compose; [ apply transport_compose |  ].
 eapply compose; [ apply transport_compat, compose_assoc |  ].
 eapply compose; [ eapply invert, transport_compose | ].
 set (x := (p b)⁻¹).
 set (y := p b).
 destruct y; simpl; subst x; unfold id.
 eapply (@compose _ _ (transport P (eq_refl a) q)); [ | reflexivity ].
 apply hap, ap, compose_invert_l.
Defined.

Definition hott_3_11_9_ii {A P} (p : isContr A) (a := pr₁ p) :
  (Σ (x : A), P x) ≃ P a
:=
  let _ := pr₁ p in
  match p return (Σ (x : A), P x) ≃ P (pr₁ p) with
  | existT _ a p =>
      existT isequiv
        (λ q, transport P (p (pr₁ q))⁻¹ (pr₂ q))
        (qinv_isequiv (λ q : {x : A & P x}, transport P (p (pr₁ q))⁻¹ (pr₂ q))
           (existT _
              (λ q, existT P a (transport P (p a) q))
              (λ x,
               transport_compose P (p a) (p a)⁻¹ x
               • transport_compat (p a • (p a)⁻¹) (eq_refl a)
                   (compose_invert_r (p a)),
               λ x,
               match x return
                 existT P a
                   (transport P (p a) (transport P (p (pr₁ x))⁻¹ (pr₂ x)))
                 = x
               with
               | existT _ b q =>
                   pair⁼ (p b)
                     (transport_compose P (p a) (p b) (transport P (p b)⁻¹ q)
                      • transport_compose P (p b)⁻¹ (p a • p b) q
                      • transport_compat ((p b)⁻¹ • (p a • p b))
                           ((p b)⁻¹ • p a • p b)
                           (compose_assoc (p b)⁻¹ (p a) (p b))
                      • (transport_compose P ((p b)⁻¹ • p a) (p b) q)⁻¹
                      • match p b as e in (_ = y) return
                          (∀ q,
                           transport P e (transport P ((p y)⁻¹ • p a) q) = q)
                        with
                        | eq_refl _ =>
                            hap (ap (transport P) (compose_invert_l (p a)))
                        end q)
               end)))
  end.

(* "Lemma 3.11.10. A type A is a mere proposition if and only if for
    all x, y : A, the type x =_{A} y is contractible." *)

Definition hott_3_11_10 {A} : isProp A ⇔ ∀ x y : A, isContr (x = y).
Proof.
split; intros p x y; [ | apply p ].
exists (p x y); intros q.
generalize p; intros r.
apply isProp_isSet in p.
apply p.
Defined.

End Contr.

(* "Exercises" *)

(* "Exercise 3.1. Prove that if A ≃ B and A is a set, then so is B." *)

Section ex_3_1.
Import Σ_type.

Definition ex_3_1_tac A B : A ≃ B → isSet A → isSet B.
Proof.
intros AB SA x y p q.
destruct AB as (f, ((g, fg), _)).
apply Π_type.funext in fg.
assert (r : ∀ p, ap id p = transport (λ u, u x = u y) fg (ap (f ◦ g) p)).
 intros t; destruct fg; reflexivity.

 apply (@compose _ _ (ap id p)); [ destruct p; reflexivity | apply invert ].
 apply (@compose _ _ (ap id q)); [ destruct q; reflexivity | ].
 eapply compose; [ apply r | apply invert ].
 eapply compose; [ apply r | apply ap ].
 eapply compose; [ eapply invert | eapply ap_composite ].
 eapply compose; [ | eapply ap_composite ].
 apply ap, SA.
Defined.

Definition ex_3_1 A B : A ≃ B → isSet A → isSet B
:=
  λ (AB : A ≃ B) (SA : isSet A) (x y : B) (p q : x = y),
  match AB with
  | existT _ f (existT _ g fg, _) =>
      let fg := Π_type.funext fg in
      let r t :=
        match fg in (_ = z) return
          (ap z t = transport (λ u : B → B, u x = u y) fg (ap (f ◦ g) t))
        with
        | eq_refl _ =>
            eq_refl
              (transport (λ u : B → B, u x = u y)
                 (eq_refl (f ◦ g)) (ap (f ◦ g) t))
        end
      in
      match p return (p = ap id p) with
      | eq_refl _ => eq_refl (ap id (eq_refl x))
      end
      • r p
      • ap (transport (λ u : B → B, u x = u y) fg)
          ((ap_composite g f p)⁻¹
           • (ap (ap f) (SA (g x) (g y) (ap g q) (ap g p)))⁻¹
           • ap_composite g f q)
      • (r q)⁻¹
      • match q return (ap id q = q) with
        | eq_refl _ => eq_refl (ap id (eq_refl x))
        end
  end.

End ex_3_1.

(* "Exercise 3.2. Prove that if A and B are sets, then so is A + B." *)

Section ex_3_2.
Import Σ_type.

Definition ex_3_2 {A B} : isSet A → isSet B → isSet (A + B).
Proof.
intros SA SB x y p q.
destruct x as [x| x].
 destruct y as [y| y]; [ | discriminate p ].
 set (e := @Σ_type2.inl_eq_equiv A B x y).
 set (f := pr₁ e).
 set (g := pr₁ (fst (pr₂ e))).
 assert (r : ∀ p, g (f p) = p).
  intros r; subst f g.
  destruct e as (f, ((g, Hg), (h, Hh))); simpl in *.
  pose proof EqStr.quasi_inv_l_eq_r f g h Hg Hh as H.
  eapply compose; [ apply H | apply Hh ].

  eapply compose; [ eapply invert | apply r ].
  eapply compose; [ eapply invert | apply r ].
  apply ap, SA.

 destruct y as [y| y]; [ discriminate p | ].
 set (e := @Σ_type2.inr_eq_equiv A B x y).
 set (f := pr₁ e).
 set (g := pr₁ (fst (pr₂ e))).
 assert (r : ∀ p, g (f p) = p).
  intros r; subst f g.
  destruct e as (f, ((g, Hg), (h, Hh))); simpl in *.
  pose proof EqStr.quasi_inv_l_eq_r f g h Hg Hh as H.
  eapply compose; [ apply H | apply Hh ].

  eapply compose; [ eapply invert | apply r ].
  eapply compose; [ eapply invert | apply r ].
  apply ap, SB.
Defined.

End ex_3_2.

(* "Exercise 3.3. Prove that if A is a set and B : A → U is a type
    family such that B (x) is a set for all x : A, then ∑ (x:A) B(x)
    is a set." *)

(* already done in 3.1.5 *)
Definition ex_3_3 {A B} : isSet A → (Π (x : A), isSet (B x))
  → isSet (Σ (x : A), B x).
Proof.
intros SA SB.
apply ex_3_1_5_bis; assumption.
Defined.

(* "Exercise 3.4. Show that A is a mere proposition if and only if
    A → A is contractible." *)

Definition ex_3_4 {A} : isProp A ⇔ isContr (A → A).
Proof.
split; intros p.
 exists id; intros f.
 apply Π_type.funext; intros; apply p.

 destruct p as (f, p).
 intros x y.
 set (g := (λ _ : A, x)).
 set (h := (λ _ : A, y)).
 eapply (@compose _ _ (g x)); [ apply eq_refl | destruct (p g) ].
 eapply (@compose _ _ (h x)); [ destruct (p h) | apply eq_refl ].
 apply eq_refl.
Defined.

(* "Exercise 3.5. Show that isProp A ≃ (A → isContr A)." *)

Definition ex_3_5 {A} : isProp A ≃ (A → isContr A).
Proof.
apply hott_3_3_3.
 apply hott_3_3_5_i.

 apply isPropImp, hott_3_11_4.

 intros p a.
 exists a; intros b; apply p.

 intros f x y.
 destruct (f x) as (a, p).
 destruct (f y) as (b, q).
 eapply compose; [ | apply p ].
 eapply compose; [ | apply q ].
 eapply invert, q.
Defined.

(* "Exercise 3.6. Show that if A is a mere proposition, then so is
     A + (¬A). Thus, there is no need to insert a propositional
     truncation in (3.4.1)." *)

Definition ex_3_6 {A} : isProp A → isProp (A + notT A).
Proof.
intros SA x y.
destruct x as [x| x].
 destruct y as [y| y]; [ apply ap, SA | destruct (y x) ].
 destruct y as [y| y]; [ destruct (x y) | ].
 apply ap, Π_type.funext; intros a; destruct (x a).
Defined.

(* "Exercise 3.7. More generally, show that if A and B are mere
    propositions and ¬(A×B), then A+B is also a mere proposition." *)

Definition ex_3_7 {A B} : isProp A → isProp B → notT (A * B) → isProp (A + B).
Proof.
intros SA SB NAB x y.
destruct x as [x| x].
 destruct y as [y| y]; [ apply ap, SA | destruct (NAB (x, y)) ].
 destruct y as [y| y]; [ destruct (NAB (y, x)) | apply ap, SB ].
Defined.

(* "Exercise 3.8. Assuming that some type isequiv(f) satisfies
    conditions (i)–(iii) of §2.4, show that the type ∥qinv(f)∥
    satisfies the same conditions and is equivalent to isequiv(f)." *)

Section ex_3_8.
Import Σ_type.

Definition ex_3_8_i {A B} (isequiv : (A → B) → Type) :
  equiv_prop isequiv
  → ∀ f : A → B,
    (qinv f → ∥(qinv f)∥) *
    (∥(qinv f)∥ → qinv f) *
    (∀ e₁ e₂ : ∥(qinv f)∥, e₁ = e₂).
Proof.
intros p f.
pose proof p f as H.
destruct H as ((qi, iq), pf).
split; [ | apply PT_eq ].
split; [ apply PT_intro | ].
intros q.
pose proof (PT_rec (qinv f) (isequiv f) qi pf) as r.
destruct r as (h, r).
apply iq, h, q.
Defined.

Definition ex_3_8_ii {A B} (isequiv : (A → B) → Type) :
  equiv_prop isequiv
  → ∀ f : A → B, isequiv f ≃ ∥(qinv f)∥.
Proof.
intros p f.
pose proof p f as H.
destruct H as ((qi, iq), pf).
pose proof ex_3_8_i isequiv p f as H.
destruct H as ((qf, fq), pq).
apply hott_3_3_3.
 intros e₁ e₂; apply pf.

 intros e₁ e₂; apply pq.

 intros r; apply qf, iq, r.

 intros r; apply qi, fq, r.
Defined.

End ex_3_8.

(* "Exercise 3.9. Show that if LEM holds, then the type
    Prop : ≡ ∑ (A:U) isProp(A) is equivalent to 2." *)

Definition uip_refl_True : ∀ p : I = I, p = eq_refl I.
Proof.
intros p; refine (match p with eq_refl _ => _ end); reflexivity.
Defined.

Definition ex_3_9 : LEM → (Σ (A : Type), isProp A) ≃ ℬ.
Proof.
intros lem.
set
  (f := λ p : {A : Type & isProp A},
   match p with
   | existT _ A PA => match lem A PA with inl _ => true | inr _ => false end
   end).
exists f; apply qinv_isequiv.
set
  (g x y :=
   match x return (x = y) with I => match y with I => eq_refl I end end).
set (h (x y : ⊥) := match x return x = y with end).
exists
  (λ b : bool,
   if b then existT (λ A : Type, isProp A) ⊤ g
   else existT (λ A : Type, isProp A) ⊥ h).
unfold "◦", "∼", id; simpl.
split.
 intros b; destruct b; simpl.
  destruct (lem ⊤ g) as [x| x]; [ apply eq_refl | destruct x; constructor ].
  destruct (lem ⊥ h) as [x| x]; [ destruct x | reflexivity ].

 intros (A, PA); simpl.
 destruct (lem A PA) as [a| b].
  assert (p : ⊤ ≃ A) by (apply quasi_inv, hott_3_3_2; [ apply PA | apply a]).
  eapply (Σ_type.pair_eq (ua p)).
  destruct (ua p); simpl; unfold id; simpl.
  apply Π_type.funext; intros x.
  apply Π_type.funext; intros y.
  destruct x, y.
  subst g; simpl.
  set (u := PA I I); simpl in u.
  refine (match u with eq_refl _ => _ end).
  apply eq_refl.

  assert (p : ⊥ ≃ A).
   exists (λ a : ⊥, match a with end); apply qinv_isequiv; exists b.
   unfold "◦", "∼", id.
   split; [ intros a; destruct (b a) | intros x; destruct x ].

   eapply (Σ_type.pair_eq (ua p)).
   destruct (ua p); simpl; unfold id; simpl.
   apply Π_type.funext; intros x; destruct x.
Defined.

(* "Exercise 3.10. Show that if U_{i+1} satisfies LEM, then the
    canonical inclusion Prop_{U_{i}} → Prop_{U+{i+1}} is an
    equivalence." *)

(* don't know how to define Prop_{i} in Coq... *)

(* "Exercise 3.11. Show that it is not the case that for all A : U we
    have ∥A∥ → A. (However, there can be particular types for which
    ∥A∥ → A. Exercise 3.8 implies that qinv (f) is such.)" *)

(* With the recursion principle of ∥A∥ (§3.7) that we defined as
   "PT_rec", we can define the case A≡B and f≡id, resulting on the
   existence of the function g of type isProp A → ∥A∥ → A. Therefore,
   if A is a mere proposition, we indeed have ∥A∥ → A. We named
   this particular case "PT_elim". *)

(* and since ∥qinv f∥ ≃ isequiv f (exercise 3.8), there is a function
   of type ∥qinv f∥ → isequiv f. But by the property (ii) of isequiv
   in §2.4, we have isequiv f → qinv f. So ∥qinv f∥ → qinv f. *)

(* "Exercise 3.12. Show that if LEM holds, then for all A : U we have
    ∥(∥A∥ → A)∥. (This property is a very simple form of the axiom of
    choice, which can fail in the absence of LEM; see [KECA13].)" *)

(* very strange proof; in the case when A is not a mere proposition,
   we artifially create an element of A by the following steps:
   - using LEM to save the opposite of the goal in the hypotheses, as H
   - the new goal is then the contradiction ⊥
   - putting isProp A as new goal by applying notT (isProp A)
   - introducing then x et y as elements of A
   - setting it is a contradiction (exfalso)
   - putting H back as goal
   Since we have values of type A, x and y, in the hypotheses, we can
   prove A, therefore ∥A∥→A, therefore ∥(∥A∥→A)∥. *)

Definition ex_3_12_tac : LEM → ∀ A, ∥(∥A∥ → A)∥.
Proof.
intros lem A.
pose proof hott_3_3_5_i A as PPA.
pose proof lem (isProp A) PPA as H.
destruct H as [PA| NPA]; [ apply PT_intro, PT_elim, PA; assumption | ].
pose proof lem _ (PT_eq (∥A∥ → A)) as H.
destruct H as [H| H]; [ apply H | exfalso ].
apply NPA; intros x y.
exfalso; apply H.
apply PT_intro; intros; apply x.
Defined.

Definition ex_3_12 : LEM → ∀ A, ∥(∥A∥ → A)∥ :=
  λ (lem : LEM) (A : Type),
  match lem (isProp A) (hott_3_3_5_i A) with
  | inl PA => PT_intro (PT_elim PA)
  | inr NPA =>
      match lem ∥(∥A∥ → A)∥ (PT_eq (∥A∥ → A)) with
      | inl H => H
      | inr H =>
          match NPA (λ x y, match H (PT_intro (λ _, x)) with end) with end
      end
  end.

(* "Exercise 3.13. We showed in Corollary 3.2.7 that the following
    naive form of LEM is inconsistent with univalence:
                 Π (A : U) (A + (¬A))
    In the absence of univalence, this axiom is consistent. However,
    show that it implies the axiom of choice (3.8.1)." *)

(* according to hott_3_8_2, AC ≃ AC_3_8_3, but hott_3_8_2 uses ua *)
(* according to AC_equiv_3_8_3_equiv, AC ≃ AC_3_8_3_equiv, but
   AC_equiv_3_8_3_equiv uses AC_3_8_3 that uses ua *)

(* So this exercise, which is said to be in a context where univalence
   is not set, is not allowed to use these lemmas; the definition of
   AC must remain the initial one. *)

Definition ex_3_13_tac : (Π (A : Type), A + notT A) → AC.
Proof.
intros lem.
intros X A P SX SA PXA T.
clear SX SA PXA. (* not used hypotheses *)
apply PT_intro.
exists
   (λ (x : X),
    match lem (Σ (a : A x), P x a) with
    | inl (existT _ a _) => a
    | inr p => match PT_intro_not p (T x) with end
    end).
intros x.
destruct (lem (Σ (a : A x), P x a)) as [(a, p)| p]; [ apply p | ].
destruct (PT_intro_not p (T x)).
Defined.

Definition ex_3_13 : (Π (A : Type), A + notT A) → AC
:=
  λ lem X A P _ _ _ T,
  PT_intro
    (existT (λ g : ∀ x : X, A x, ∀ x : X, P x (g x))
       (λ x : X,
        match lem {a : A x & P x a} with
        | inl (existT _ a _) => a
        | inr p => match PT_intro_not p (T x) return (A x) with end
        end)
       (λ (x : X),
        let s := lem {a : A x & P x a} in
        match s return
          (P x
             match s with
             | inl (existT _ a _) => a
             | inr p => match PT_intro_not p (T x) return (A x) with end
             end)
        with
        | inl (existT _ a p) => p
        | inr p => match PT_intro_not p (T x) with end
        end)).

(* "Exercise 3.14. Show that assuming LEM, the double negation ¬¬A
    has the same universal property as the propositional truncation
    ∥A∥, and is therefore equivalent to it. Thus, under LEM, the
    propositional truncation can be defined rather than taken as a
    separate type former." *)

(*
PT_intro: ∀ A : Type, A → ∥A∥
PT_eq: ∀ A : Type, isProp ∥A∥
PT_rec:
  ∀ (A B : Type) (f : A → B),
  isProp B → Σ (g : ∥A∥ → B), ∀ a : A, g (PT_intro a) = f a
*)

Definition DN_intro {A} : A → notT (notT A).
Proof.
intros a p; destruct (p a).
Defined.

(* no need to LEM, but uses function extensionality *)
Definition DN_eq₀ {A} : isProp (notT (notT A)).
Proof.
intros x y.
apply Π_type.funext; intros a; destruct (x a).
Defined.

Definition DN_eq : LEM → ∀ A : Type, isProp (notT (notT A)).
Proof.
intros lem A x y.
unfold LEM in lem.
destruct (lem _ (hott_3_3_5_i A)) as [p| p].
 apply (isPropNot (isPropNot p)).

Abort. (* blocked; perhaps DN_eq₀ is the only solution? *)

Definition DN_rec : LEM
  → ∀ A B (f : A → B), isProp B
  → Σ (g : notT (notT A) → B), ∀ a, g (DN_intro a) = f a.
Proof.
intros lem A B f PB.
unfold LEM in lem.
destruct (lem _ (hott_3_3_5_i A)) as [PA| NPA].
 destruct (lem A PA) as [a| na].
  exists (λ _, f a).
  intros a'; apply PB.

  exists (λ nna : notT (notT A), match nna na return B with end).
  intros a; destruct (na a).

 destruct (lem B PB) as [b| nb].
  exists (λ _, b).
  intros a; apply PB.

  exfalso; apply NPA; intros a.
  destruct (nb (f a)).
Defined.

Definition ex_3_14 : LEM → ∀ A, notT (notT A) ≃ ∥A∥.
Proof.
intros lem A.
destruct (lem _ (hott_3_3_5_i A)) as [PA| NPA].
 exists (λ p, PT_intro (pr₁ LEM_LDN lem A PA p)); apply qinv_isequiv.
 exists (λ p q, q (Σ_type.pr₁ (PT_rec A A id PA) p)); simpl.
 split; [ intros x; apply PT_eq | ].
 intros f; apply Π_type.funext; intros x; destruct (f x).

 assert (f : notT (notT A) → ∥A∥).
  intros nna.
  apply PT_intro.
  unfold LEM in lem.
  (* wrong if A is not a Prop; cf 3.2.2 *)
Abort.

(* version where hypothesis "isProp A" has been added *)
(* but not satisfactory since when A is a mere proposition, ∥A∥ is
   not interesting at all *)
Definition ex_3_14_not_satis : LEM → ∀ A, isProp A → (notT (notT A) ≃ ∥A∥).
Proof.
intros HLEM A HPA.
exists (λ p, PT_intro (pr₁ LEM_LDN HLEM A HPA p)); apply qinv_isequiv.
exists (λ p q, q (Σ_type.pr₁ (PT_rec A A id HPA) p)); simpl.
split; [ intros x; apply PT_eq | ].
intros f; apply Π_type.funext; intros x; destruct (f x).
Defined.

(* version with naive version of LEM, instead of normal LEM *)
Definition ex_3_14 : (Π (A : Type), A + notT A) → ∀ A, notT (notT A) ≃ ∥A∥.
Proof.
intros lem A.
exists
  (λ nna : notT (notT A),
   PT_intro
     (match lem A with
      | inl a => a
      | inr na => match nna na return A with end
      end)).
apply qinv_isequiv.
exists
  (λ (x : ∥A∥),
   match lem A with
   | inl a => λ (na : notT A), match na a with end
   | inr na => match PT_intro_not na x with end
   end).
unfold "◦", "∼", id; simpl.
split.
 intros x.
 destruct (lem A) as [a| na]; [ apply PT_eq | ].
 destruct (PT_intro_not na x).

 intros nna.
 destruct (lem A) as [a| na]; [ | destruct (nna na) ].
 apply Π_type.funext; intros na; destruct (nna na).
Defined.

(* "Exercise 3.15. Show that if we assume propositional resizing as in
    §3.5, then the type
          Π (P : Prop), (A → P) → P
    has the same universal property as ∥A∥. Thus, we can also define
    the propositional truncation in this case." *)

(*
PT_intro: ∀ A : Type, A → ∥A∥
PT_eq: ∀ A : Type, isProp ∥A∥
PT_rec:
  ∀ (A B : Type) (f : A → B),
  isProp B → Σ (g : ∥A∥ → B), ∀ a : A, g (PT_intro a) = f a
*)

Definition APP A := Π (P : Type), isProp P → (A → P) → P.

Definition APP_intro {A} : A → APP A.
Proof.
intros a P PP p; apply p, a.
Defined.

Definition APP_eq {A} : isProp (APP A).
Proof.
intros f g.
apply Π_type.funext; intros P.
apply Π_type.funext; intros PP.
apply Π_type.funext; intros h.
apply PP.
Defined.

Definition APP_rec {A B} (f : A → B) :
  isProp B → Σ (g : APP A → B), ∀ a : A, g (APP_intro a) = f a.
Proof.
intros PB.
exists (λ (g : APP A), g B PB f).
intros a; apply eq_refl.
Defined.

Definition ex_3_15 {A} : APP A ≃ ∥A∥.
Proof.
exists (λ g : APP A, g ∥A∥ (PT_eq A) (@PT_intro A)).
apply qinv_isequiv.
assert (∥A∥ → APP A) as g.
 intros x P PP i.
 exfalso; revert x.
 pose proof (@APP_rec P P id PP) as R.
 destruct R as (h, R); unfold id in R.
 (* Seems not working; perhaps they are not equivalent? This is indeed
    possible, since the wording of this exercise does not say they are. *)
Abort.

(* "Exercise 3.16. Assuming LEM, show that double negation commutes
    with universal quantification of mere propositions over sets. That
    is, show that if X is a set and each Y(x) is a mere proposition,
    then LEM implies
          (Π (x:X) ¬¬Y(x)) ≃ ¬¬ (Π (x:X) Y(x))
    Observe that if we assume instead that each Y(x) is a set, then
    (3.11.11) becomes equivalent to the axiom of choice (3.8.3)." *)

Section ex_3_16.
Import Σ_type.

Definition ex_3_16_i {X Y} : isSet X → (Π (x : X), isProp (Y x))
  → LEM → (Π (x : X), notT (notT (Y x))) ≃ notT (notT (Π (x : X), Y x)).
Proof.
intros SX PY lem.
apply hott_3_3_3.
 apply ex_3_6_2; intros x; apply isPropNot, isPropNot, PY.

 apply isPropNot, isPropNot, ex_3_6_2, PY.

 intros NNY NY; apply NY; intros x.
 destruct (lem (Y x) (PY x)) as [p| p]; [ apply p | ].
 destruct (NNY x p).

 intros NNY x q; apply q.
 destruct (lem (Y x) (PY x)) as [p| p]; [ apply p | ].
 exfalso; apply NNY; intros r.
 destruct (p (r x)).
Defined.

Definition ex_3_16_ii :
  LEM
  → (∀ X Y, isSet X → (Π (x : X), isSet (Y x))
     → (Π (x : X), notT (notT (Y x))) ≃ notT (notT (Π (x : X), Y x)))
    ≃ AC_3_8_3.
Proof.
intros lem.
(*
assert
  ((∀ X Y, isSet X → (Π (x : X), isSet (Y x))
    → (Π (x : X), notT (notT (Y x))) ≃ notT (notT (Π (x : X), Y x)))
   → AC_3_8_3) as ffff.
 intros p X Y SX SY q.
 destruct (lem _ (PT_eq (∀ x : X, Y x))) as [r| r]; [ apply r | ].
 exfalso; apply r, PT_intro; intro x.
 destruct (lem _ (hott_3_3_5_i (Y x))) as [PY| NPY].
  apply PT_elim; [ apply PY | apply q ].

  assert (s : ∀ x : X, notT (notT (Y x))).
   intros x' nx'.
   apply PT_intro_not in nx'.
   destruct (nx' (q x')).

   pose proof pr₁ (p X Y SX SY) s as t.
   exfalso; apply t; intros u.
   apply r, PT_intro, u.
Show Proof.
*)
exists
  (λ p X Y SX SY q,
   match lem ∥(∀ x : X, Y x)∥ (PT_eq (∀ x : X, Y x)) with
   | inl r => r
   | inr r =>
       match
         (r
            (PT_intro
               (λ x,
                match lem (isProp (Y x)) (hott_3_3_5_i (Y x)) with
                | inl PY => PT_elim PY (q x)
                | inr _ =>
                    match
                      (((pr₁ (p X Y SX SY)
                           (λ x' nx',
                            match PT_intro_not nx' (q x') return ⊥ with end)
                           (λ u, r (PT_intro u)))) : ⊥)
                    with end
                end)))
       with end
   end).
apply qinv_isequiv.
assert
  (AC_3_8_3
   → (∀ X Y, isSet X → (Π (x : X), isSet (Y x))
     → (Π (x : X), notT (notT (Y x))) ≃ notT (notT (Π (x : X), Y x))))
  as gggg.
 intros ac X Y SX SY.
 pose proof ac X Y SX SY as p.
 assert (isProp (∀ x : X, ∥(Y x)∥)) as q.
  apply ex_3_6_2; intros x; apply PT_eq.

  destruct (lem (∀ x : X, ∥(Y x)∥) q) as [r| r].
   pose proof p r as s.
(*
   assert ((∀ x : X, notT (notT (Y x))) → notT (notT (∀ x : X, Y x))) as ffff.
    intros t u; apply u; intros x.
    apply PT_intro_not in u; destruct (u s).
   Show Proof.
*)
   exists (λ _ u, u (λ x, match PT_intro_not u s with end)).
   apply qinv_isequiv.
(*
   assert (notT (notT (∀ x : X, Y x)) → (∀ x : X, notT (notT (Y x)))) as ffff.
    intros t x u; apply u.
    apply PT_intro_not in u; destruct (u (r x)).
   Show Proof.
*)
   exists (λ _ x u, u (match PT_intro_not u (r x) with end)).
   unfold "◦", "∼", id; simpl.
   split.
    intros x; apply Π_type.funext; intros nx; destruct (x nx).

    intros f; apply Π_type.funext; intros x.
    apply Π_type.funext; intros nx; destruct (f x nx).

   assert ((∀ x : X, notT (notT (Y x))) → notT (notT (∀ x : X, Y x))) as ffff.
    intros t u; apply u; intros x.
    pose proof t x as v.
    exfalso; apply v; intros w.
(* well, the proof seems not trivial; it is perhaps the reason why the
   wording of this exercise says "observe that" instead of "prove that";
   I give up. *)
Abort.

End ex_3_16.

(* "Exercise 3.17. Show that the rules for the propositional
    truncation given in §3.7 are sufficient to imply the following
    induction principle: for any type family B:∥A∥→U such that each
    B(x) is a mere proposition, if for every a:A we have B(|a|), then
    for every x:∥A∥ we have B(x)." *)

Definition ex_3_17 A B : (Π (x : ∥A∥), isProp (B x))
  → (Π (a : A), B (PT_intro a)) → (Π (x : ∥A∥), B x).
Proof.
intros PB BA x.
assert (f : A → B x).
 intros a.
 pose proof BA a as s.
 destruct (PT_eq _ x (PT_intro a)); apply s.

 destruct (PT_rec A (B x) f (PB x)) as (g, s).
 apply g, x.
Defined.

(* "Exercise 3.18. Show that the law of excluded middle (3.4.1) and
    the law of double negation (3.4.2) are logically equivalent." *)

(* already done *)
Definition ex_3_18 : LEM ⇔ LDN.
Proof. apply LEM_LDN. Defined.

(* "Exercise 3.19. Suppose P:ℕ→U is a decidable family of mere
    propositions. Prove that
         ∥Σ (n:ℕ) P(n)∥ → Σ (n:ℕ) P(n)." *)

(* return 0 if not enough iterations, else S n for n *)
Fixpoint first_such_that P (DP : isDecidableFamily ℕ P) m n :=
  match m with
  | 0 => 0
  | S m' =>
      match DP n with
      | inl _ => S n
      | inr _ => first_such_that P DP m' (S n)
      end
  end.

Definition first_such_that_prop P (DP : isDecidableFamily ℕ P) m n a :
  first_such_that P DP (S n) a = S m
  → P m * ∀ b, a ≤ b → b < m → notT (P b).
Proof.
intros p; simpl in p.
destruct (DP a) as [q| q].
 injection p; intros; subst a.
 split; [ apply q | intros b Ha Hb ].
 apply Nat.nlt_ge in Ha; destruct (Ha Hb).

 revert m a p q.
 induction n; intros; [ discriminate p | simpl in p ].
 destruct (DP (S a)) as [r| r].
  injection p; intros; subst m.
  split; [ apply r | intros b Ha Hb ].
  apply Nat.succ_le_mono, Nat.le_antisymm in Hb; [ | apply Ha ].
  destruct Hb; apply q.

  eapply IHn in p; [ | apply r ].
  destruct p as (p, s).
  split; [ apply p | intros b Ha Hb ].
  destruct (le_dec (S a) b) as [t| t].
   apply s; [ apply t | apply Hb ].

   apply Nat.nle_gt in t.
   apply Nat.succ_le_mono, Nat.le_antisymm in t; [ | apply Ha ].
   destruct t; apply q.
Defined.

Definition no_first_such_that_prop P (DP : isDecidableFamily ℕ P) n a :
  first_such_that P DP (S n) a = 0
  → notT (P (a + n)).
Proof.
intros p; simpl in p.
destruct (DP a) as [q| q]; [ discriminate p | ].
revert a p q.
induction n; intros; [ rewrite Nat.add_0_r; apply q | ].
simpl in p.
destruct (DP (S a)) as [r| r]; [ discriminate p | ].
rewrite <- Nat.add_succ_comm.
apply IHn; [ apply p | apply r ].
Defined.

Definition smallest_such_that P : isDecidableFamily ℕ P
  → (Σ (n : ℕ), P n)
  → (Σ (n : ℕ), (P n * ∀ m, m < n → notT (P m))%type).
Proof.
intros DP (n, p).
remember (first_such_that P DP (S n) 0) as x eqn:Hx; symmetry in Hx.
destruct x as [| m].
 apply no_first_such_that_prop in Hx; destruct (Hx p).

 exists m; apply first_such_that_prop in Hx.
 destruct Hx as (q, r); split; [ apply q | intros a Ha ].
 apply r; [ apply Nat.le_0_l | apply Ha ].
Defined.

Definition isProp_first_such_that P (PP : Π (n : ℕ), isProp (P n)) :
  isProp (Σ (n : ℕ), (P n * (∀ m : ℕ, m < n → notT (P m)))%type).
Proof.
intros q r.
destruct q as (m, (pm, q)).
destruct r as (n, (pn, r)).
destruct (lt_eq_lt_dec m n) as [[Hmn| Hmn] | Hmn].
 destruct (r m Hmn pm).

 subst m.
 apply (Σ_type.pair_eq (eq_refl n)); simpl; unfold id.
 apply split_pair_eq.
 split; [ apply PP | ].
 apply Π_type.funext; intros m.
 apply Π_type.funext; intros s.
 apply isPropNot, PP.

 destruct (q n Hmn pn).
Defined.

Definition ex_3_19_tac P : isDecidableFamily ℕ P
  → (Π (n : ℕ), isProp (P n))
  → ∥(Σ (n : ℕ), P n)∥
  → Σ (n : ℕ), P n.
Proof.
intros DP PP p.
set (A := Σ (n : ℕ), P n) in p |-*.
set (B := Σ (n : ℕ), (P n * (∀ m : ℕ, m < n → notT (P m)))%type).
set (f := smallest_such_that P DP : A → B).
set (PB := isProp_first_such_that P PP : isProp B).
set (g := Σ_type.pr₁ (PT_rec A B f PB)).
destruct (g p) as (n, (pn, _)).
exists n; apply pn.
Defined.

Definition ex_3_19 P : isDecidableFamily ℕ P
  → (Π (n : ℕ), isProp (P n))
  → ∥(Σ (n : ℕ), P n)∥
  → Σ (n : ℕ), P n
:=
  λ DP PP p,
  let f := smallest_such_that P DP in
  let PB := isProp_first_such_that P PP in
  match Σ_type.pr₁ (PT_rec _ _ f PB) p with
  | existT _ n (pn, _) => existT P n pn
  end.

(* "Exercise 3.20. Prove Lemma 3.11.9(ii): if A is contractible with
    center a, then Σ (x:A) P(x) is equivalent to P(a)." *)

(* already done: see hott_3_11_9_ii *)

(* "Exercise 3.21. Prove that isProp(P) ≃ (P ≃ ∥P∥)." *)

Definition ex_3_21 P : isProp P ≃ (P ≃ ∥P∥).
Proof.
apply hott_3_3_3.
 apply hott_3_3_5_i.

 intros p q.
 destruct p as (f, p).
 destruct q as (g, q).
 assert (PP : isProp (P → ∥P∥)) by (apply isPropImp, PT_eq).
 assert (f = g) by apply PP; subst g.
 destruct (equivalence_isequiv f) as (r, s).
 assert (p = q) by apply s; subst q.
 reflexivity.

 apply hott_3_9_1.

 intros p q r.
 destruct p as (f, (_, (h, Hh))).
 unfold "◦", "∼", id in Hh.
 eapply compose; [ eapply invert | apply Hh ].
 eapply compose; [ eapply invert | apply Hh ].
 apply ap, PT_eq.
Defined.

(* "Exercise 3.22. As in classical set theory, the finite version of
    the axiom of choice is a theorem. Prove that the axiom of choice
    (3.8.1) holds when X is a finite type Fin(n) (as defined in
    Exercise 1.9)." *)

Definition Fin_succ_equiv : ∀ n, Fin (S n) ≃ Fin n + ⊤.
Proof.
intros n.
exists
  (λ (p : Fin (S n)),
   match p with
   | elem _ i _ =>
       match lt_dec i n with
       | left p => inl (elem n i p)
       | right _ => inr I
       end
   end).
apply qinv_isequiv.
exists
  (λ p : Fin n + ⊤,
   match p with
   | inl (elem _ i ilt) => elem (S n) i (Nat.lt_lt_succ_r i n ilt)
   | inr _ => elem (S n) n (Nat.lt_succ_diag_r n)
   end).
unfold "◦", "∼", id; simpl.
split.
 intros [ (i, ilt) | x].
  destruct (lt_dec i n) as [p| p]; [ | destruct (p ilt) ].
  apply ap, ap, le_unique.

  destruct (lt_dec n n) as [p| p]; [ | destruct x; apply eq_refl ].
  exfalso; revert p; apply Nat.lt_irrefl.

 intros (i, ilt).
 destruct (lt_dec i n) as [p| p]; [ apply ap, le_unique | ].
 apply Nat.nlt_ge, Nat.succ_le_mono in p.
 apply Nat.le_antisymm in p; [ | apply ilt ].
 apply Nat.succ_inj in p; subst i.
 apply ap, le_unique.
Defined.

Definition isSet_Fin : ∀ n, isSet (Fin n).
Proof.
intros n.
induction n.
 intros x y p q.
 destruct x as (i, ilt).
 exfalso; clear p q; apply Nat.nlt_0_r in ilt; destruct ilt.

 eapply ex_3_1; [ eapply quasi_inv, Fin_succ_equiv | ].
 eapply ex_3_2; [ apply IHn | apply isSet_True ].
Defined.

Definition Fin_x n := elem (S n) n (Nat.lt_succ_diag_r n).

Definition PT_and_elim A B : ∥(A * B)∥ → ∥A∥ * ∥B∥.
Proof.
intros p.
split.
 set (q := PT_rec (A * B) ∥A∥ (λ p, PT_intro (fst p)) (PT_eq _)).
 destruct q as (g, q); apply g, p.

 set (q := PT_rec (A * B) ∥B∥ (λ p, PT_intro (snd p)) (PT_eq _)).
 destruct q as (g, q); apply g, p.
Defined.

Definition PT_and_intro A B : ∥A∥ → ∥B∥ → ∥(A * B)∥.
Proof.
intros x y.
assert (f : A → ∥(A * B)∥).
 intros a.
 assert (f : B → ∥(A * B)∥) by (intros b; apply PT_intro; split; assumption).
 set (r := PT_rec B ∥(A * B)∥ f (PT_eq _)).
 destruct r as (g, r); apply g, y.

 set (r := PT_rec A ∥(A * B)∥ f (PT_eq _)).
 destruct r as (g, r); apply g, x.
Defined.

Definition PT_and_equiv A B : ∥(A * B)∥ ≃ ∥A∥ * ∥B∥.
Proof.
apply hott_3_3_3.
 apply PT_eq.

 apply ex_3_6_1; apply PT_eq.

 apply PT_and_elim.

 intros (x, y).
 apply PT_and_intro; assumption.
Defined.

Definition ex_3_22_Fin_0 : ACX (Fin 0).
Proof.
intros A P SX SA PP T.
apply PT_intro.
assert (g : ∀ x : Fin 0, A x).
 destruct x as (n, nlt); destruct (Nat.nlt_0_r n nlt).

 exists g; intros x.
 destruct x as (n, nlt); destruct (Nat.nlt_0_r n nlt).
Defined.

Definition and_imp A B C : (A → B) → (A * C → B * C)%type.
Proof.
intros p (a, c).
split; [ apply p, a | apply c ].
Defined.

Definition ex_3_22 n : ACX (Fin n).
Proof.
intros A P SX SA PP T.
revert A P SX SA PP T.
induction n; intros; [ apply ex_3_22_Fin_0; assumption |  ].
set
 (An :=
  λ x : Fin n,
  match x with
  | elem _ i lti => A (elem (S n) i (Nat.lt_lt_succ_r i n lti))
  end).
set
 (Pn :=
  λ x : Fin n,
  match x return (An x → Type) with
  | elem _ i ilt => P (elem (S n) i (Nat.lt_lt_succ_r i n ilt))
  end).
pose proof
 (λ x : Fin n,
  match x return (isSet (An x)) with
  | elem _ i ilt => SA (elem (S n) i (Nat.lt_lt_succ_r i n ilt))
  end) as SAn.
pose proof
 (λ x : Fin n,
  match x return (∀ a : An x, isProp (Pn x a)) with
  | elem _ i ilt => PP (elem (S n) i (Nat.lt_lt_succ_r i n ilt))
  end) as PPn.
pose proof
 (λ x : Fin n,
  match x return ∥{a : An x & Pn x a}∥ with
  | elem _ i ilt => T (elem (S n) i (Nat.lt_lt_succ_r i n ilt))
  end) as Tn.
assert
 (H1 : (Π (x : Fin (S n)), ∥(Σ (a : A x), P x a)∥) ≃
  (Π (x : Fin (n)), ∥(Σ (a : An x), Pn x a)∥) *
   ∥(Σ (a : A (Fin_x n)), P (Fin_x n) a)∥).
 apply hott_3_3_3.
  apply ex_3_6_2; intros x; apply PT_eq.

  apply ex_3_6_1; [ apply ex_3_6_2; intros y; apply PT_eq | apply PT_eq ].

  intros p.
  split; [ intros y; apply Tn | apply T ].

  intros (p, q); apply T.

 eapply ua in H1.
 pose proof (IHn An Pn (isSet_Fin n) SAn PPn) as p.
 apply and_imp with (C := ∥{a : A (Fin_x n) & P (Fin_x n) a}∥) in p.
  destruct p as (p, q).
  eapply PT_and_intro in p; [ clear q | apply q ].
  set
   (A₀ :=
    ({a : A (Fin_x n) & P (Fin_x n) a} *
     {g : ∀ x : Fin n, An x & ∀ x : Fin n, Pn x (g x)})%type).
  set (B₀ := ∥{g : ∀ x : Fin (S n), A x & ∀ x : Fin (S n), P x (g x)}∥).
  assert (f₀ : A₀ → B₀).
   intros ((an, q), (g, r)); subst B₀; apply PT_intro.
   set
    (h :=
     λ x : Fin (S n),
     match x as f return (A f) with
     | elem _ i ilt =>
         let s1 := lt_dec i n in
         match s1 with
         | left H3 =>
             let x0 := g (elem n i H3) in
             transport A
               (ap (elem (S n) i)
                  (le_unique (S i) (S n) (Nat.lt_lt_succ_r i n H3) ilt)) x0
         | right H3 =>
             (λ H : ∀ n1 m : ℕ, ¬ n1 < m → m ≤ n1,
              (λ H4 : n ≤ i,
               (λ H0 : ∀ n1 m : ℕ, n1 ≤ m → S n1 ≤ S m,
                (λ H5 : S n ≤ S i,
                 (λ H6 : S i = S n,
                  (λ H7 : i = n,
                   eq_rect_r
                     (λ i0 : ℕ, ∀ ilt0 : i0 < S n, A (elem (S n) i0 ilt0))
                     (λ ilt0 : n < S n,
                      transport A
                        (ap (elem (S n) n)
                           (le_unique (S n) (S n) (Nat.lt_succ_diag_r n) ilt0))
                        an) H7 ilt) (Nat.succ_inj i n H6))
                   (Nat.le_antisymm (S i) (S n) ilt H5))
                  (H0 n i H4))
                 (λ n1 m : ℕ,
                  match Nat.succ_le_mono n1 m with
                  | conj x0 _ => x0
                  end)) (H i n H3))
               (λ n1 m : ℕ, match Nat.nlt_ge n1 m with
                            | conj x0 _ => x0
                            end)
         end
     end).
   exists h.
   intros (i, ilt); subst h; simpl.
   destruct (lt_dec i n) as [H2| H2].
    unfold Fin_x in q.
    set (x := r (elem n i H2)).
    unfold Pn in x; simpl in x.
    unfold transport.
    destruct
     (ap (elem (S n) i) (le_unique (S i) (S n) (Nat.lt_lt_succ_r i n H2) ilt)).
    apply x.

    unfold eq_rect_r; simpl.
    unfold eq_rect; simpl.
    destruct
     (eq_sym
        (Nat.succ_inj i n
           (Nat.le_antisymm (S i) (S n) ilt
              (match Nat.succ_le_mono n i with
               | conj x0 _ => x0
               end (match Nat.nlt_ge i n with
                    | conj x0 _ => x0
                    end H2))))).
    unfold transport; simpl.
    destruct
     (ap (elem (S n) n) (le_unique (S n) (S n) (Nat.lt_succ_diag_r n) ilt)).
    apply q.

   pose proof (PT_rec A₀ B₀ f₀ (PT_eq _)) as q.
   destruct q as (g, q).
   apply g, p.

  split; [ intros x; apply Tn | apply T ].
Defined.


Require Import Reals.
Local Open Scope R_scope.
From ValidSDP Require Import validsdp.

Let p (x0 x1 x2 x3 x4 x5 : R) :=
  (0 - x1) * x2 - x0 * x3 + x1 * x4 + x2 * x5 - x4 * x5
  + x0 * (0 - x0 + x1 + x2 - x3 + x4 + x5).

Let b1 (x0 x1 x2 x3 x4 x5 : R) :=
  (x0 - 4/1) * (63504/10000 - x0).

Let b2 (x0 x1 x2 x3 x4 x5 : R) :=
  (x1 - 4/1) * (63504/10000 - x1).

Let b3 (x0 x1 x2 x3 x4 x5 : R) :=
  (x2 - 4/1) * (63504/10000 - x2).

Let b4 (x0 x1 x2 x3 x4 x5 : R) :=
  (x3 - 4/1) * (63504/10000 - x3).

Let b5 (x0 x1 x2 x3 x4 x5 : R) :=
  (x4 - 4/1) * (63504/10000 - x4).

Let b6 (x0 x1 x2 x3 x4 x5 : R) :=
  (x5 - 8/1) * (254016/10000 - x5).

Theorem p_nonneg (x0 x1 x2 x3 x4 x5 : R) :
  b1 x0 x1 x2 x3 x4 x5 >= 0 ->
  b2 x0 x1 x2 x3 x4 x5 >= 0 ->
  b3 x0 x1 x2 x3 x4 x5 >= 0 ->
  b4 x0 x1 x2 x3 x4 x5 >= 0 ->
  b5 x0 x1 x2 x3 x4 x5 >= 0 ->
  b6 x0 x1 x2 x3 x4 x5 >= 0 ->
  p x0 x1 x2 x3 x4 x5 >= 0.
Proof.
unfold b1, b2, b3, b4, b5, b6, p.
validsdp.
Qed.


Require Import FP.Data.Function.
Require Import FP.Structures.Eqv.
Require Import FP.Relations.Setoid.
Require Import FP.Relations.Function.

Import FunctionNotation.
Import ProperNotation.

Section Eqv.
  Context {A} {A_Eqv:Eqv A}.
  Context {B} {B_Eqv:Eqv B}.
  Definition function_Eqv : Eqv (A -> B) :=
    { eqv := (eqv ==> eqv) }.
End Eqv.