Require Import ssreflect.
Require Import Coq.Classes.EquivDec.
Require Import Metalib.Metatheory.

Require Import Coq.Structures.Orders.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Program.Equality.
Require Import Coq.Classes.RelationClasses.

Require Import dqtt_ott.
Require Import dqtt_inf.
Require Import usage.
Require Import dctx.
Require Import dctx_sub.
Require Import semimodule.
Require Import tactics.
Require Import structural.

Require Export beta.
Require Export inversion.

(* Theorem 6.4 *)
Lemma preservation: forall D G a A, Typing D G a A -> forall a', Step a a' -> Typing D G a' A.
Proof.
  induction 1; intros a' St.
  all: try solve [inversion St].
  - (* sub *) eapply T_sub; eauto.
  - (* weak *) eapply T_weak; eauto.
  - (* weak_def *) eapply T_weak_def; eauto.
  - (* app *)
    inversion St; subst.
    + eapply T_app. eauto. auto.
    + (* beta *)
      clear IHTyping1. clear IHTyping2.
      move: (Typing_regularity  H) => [GP TP].
      move: (Typing_regularity  H0) => [GA TA].
      move: (invert_Pi _ _ _ _ _ _ TP) => [M [G1' [G2' [r [S1 [T1 U]]]]]].

      pick fresh x for (fv_tm_tm a0 `union` dom D5 `union` fv_tm_tm (subst_def D5 B) \u fv_tm_tm B \u dom G1).
      move: (U x ltac:(auto)) => UU.

      rewrite (subst_tm_tm_intro x a0). fsetdec.
      rewrite (subst_tm_tm_intro x B). fsetdec.

      eapply invert_Lam with (x:=x) in H. 2: fsetdec.
      move: H => [B0 [EQ [GA0 [TP0 Ta]]]].
      repeat rewrite subst_def_Pi in EQ; eauto using Typing_lc_ctx.
      move: (invert_Beta_a_Pi0 EQ) => h0.
      move: (invert_Beta_a_Pi1 EQ) => h1.
      move: (invert_Beta_a_Pi2 EQ) => h2.
      move: (invert_Pi _ _ _ _ _ _ TP0) => [? [G3 [G4 [r1 [h3 [h4 h5]]]]]].
      subst q.
      move: (Typing_ctx_fv x TP0 ltac:(auto)) => FV. asimpl in FV.
      have h00: Typing D5 G2 b A0. eapply T_conv; eauto.
      move: (substitution _ nil _ nil _ _ _ _ _ Ta _ _ h00) => SS.
      asimpl in SS.
      move: (Typing_regularity  SS) => [G0 TB0].
      move: (substitution _ nil _ nil _ _ _ _ _ UU _ _ H0) => SU. asimpl in SU.
      eapply T_conv. eauto. eauto.
      have Frx: x `notin` fv_tm_tm (subst_def D5 B0). rewrite fv_subst_def. fsetdec. eauto using Typing_ctx_wff_regularity.
      move: (h2 x ltac:(auto)) => BV.
      repeat erewrite subst_def_subst_tm_tm; eauto using Typing_ctx_wff_regularity.
      have LC: lc_tm (subst_def D5 b). eapply subst_def_lc_tm; eauto using Typing_lc_ctx.
      eapply subst_Beta1; auto.
      repeat rewrite subst_def_open_tm_wrt_tm; eauto using Typing_lc_ctx.
      rewrite (subst_def_fresh_eq D5 (a_Var_f x)). intros x0 Fr0. simpl. fsetdec.
      auto.
 - (* beta *)
   eapply T_conv; eauto.
 - (* letunit *)
   inversion St; subst.
   + (* cong *)
     eapply T_conv.
     eapply T_UnitE; eauto.
     ++ pick fresh x.
       move: (H2 x ltac:(auto)) => h1.
       move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H) => SU. asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU. eapply Typing_lc; eauto.
       rewrite subst_tm_tm_fresh_eq in SU. eauto.
       rewrite subst_tm_same in SU. auto. eauto.
     ++ pick fresh x. rewrite (subst_tm_tm_intro x). eauto. rewrite (subst_tm_tm_intro x B a). eauto.
        eapply subst_def_Beta; eauto using Typing_lc_ctx.
        eapply subst_Beta2.
        move: (H3 x ltac:(auto)) => h. eapply Typing_lc. eauto.
        eapply B_Sym; eauto.
   + (* beta *)
     move: (invert_Unit H) => [G4 [h0 [h1 h2]]].
     eapply T_sub. eauto.
     rewrite (ctx_plus_comm _ D5); eclarify_ctx.
     eapply ctx_plus_sub; eclarify_ctx.
     auto.
 - (* let box *)
   inversion St; subst.
   + (* Cong *)
     clear H1 H3.
     eapply T_conv.
     ++ eapply T_letbox with (L := L).
        eapply IHTyping. auto.
        move=> x Fr.
        eapply H0. auto.
        move=> x Fr.
        eapply H2. auto.
     ++ pick fresh x.
        move: (H2 x ltac:(auto)) => TB.
        move: (substitution _ nil _ nil _ _ _ _ _ TB _ _ H) => SU. asimpl in SU.
        rewrite subst_tm_tm_open_tm_wrt_tm in SU.
        eapply Typing_lc; eauto.
        rewrite subst_tm_same in SU. auto.
        rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
        eauto.
     ++ pick fresh x.
        move: (H2 x ltac:(auto)) => TB.
        rewrite (subst_tm_tm_intro x). eauto.
        rewrite (subst_tm_tm_intro x B a). eauto.
        eapply subst_def_Beta; eauto using Typing_lc_ctx.
        eapply subst_Beta2.
        eapply Typing_lc. eauto.
        eapply B_Sym.
        eapply B_Step.
        auto.
   + (* beta *)
     clear H3. clear H1.
     pick fresh x.
     move: (H0 x ltac:(auto)) => h1.
     move: (Typing_ctx h1) => CA. destruct_ctx.
     move: (invert_box H) => [A0 [BB [G [T1 T2]]]].
     rewrite subst_def_Box in BB.
     move: (invert_Beta_Box1 BB) => BA.
     move: (invert_Beta_Box2 BB) => eq. subst q0.
     move: (Typing_regularity  H) => [GA TBA].
     move: (invert_Box TBA) => [h0 h2].
     have Ta0: (Typing D5 G a0 A). eapply T_conv. eapply T2. eauto. eapply B_Sym. eauto.
     move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ Ta0) => SU. asimpl in SU.
     rewrite subst_tm_tm_open_tm_wrt_tm in SU. eapply Typing_lc; eauto.
     rewrite subst_tm_same in SU. auto.
     rewrite subst_tm_tm_open_tm_wrt_tm in SU. eapply Typing_lc; eauto.
     simpl in SU. rewrite eq_dec_refl in SU.
     rewrite subst_tm_tm_fresh_eq in SU. { clear H11. fsetdec. }
     rewrite subst_tm_tm_fresh_eq in SU. { clear H11. fsetdec. }
     eapply T_sub. eauto.
     erewrite ctx_plus_comm; eclarify_ctx.
     eapply ctx_sub_ctx_plus. auto.
     eapply ctx_sub_refl. auto.
 - (* case *)
   inversion St; subst.
   + (* case cong *)
     have TBa : Typing D5 (ctx_plus G3 (ctx_mul r G1)) (open_tm_wrt_tm B a) a_Type.
     {
       pick fresh x.
       match goal with [H5 : forall y, y `notin` L -> _ ,
                        H0  : Typing ?D ?G a _  |- _ ] =>
          move: (H5 x ltac:(auto)) => h1;
          move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H0) => SU
       end.
       asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU.
       eapply Typing_lc; eauto.
       rewrite subst_tm_same in SU. auto.
       rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
       eauto.
     }
     eapply T_conv.
     eapply T_case; auto.
     eauto.
     pick fresh x.
     rewrite (subst_tm_tm_intro x B a'0); auto.
     rewrite (subst_tm_tm_intro x B a); auto.
     eapply subst_def_Beta; eauto using Typing_lc_ctx.
     eapply subst_Beta2.
     eapply Typing_lc. eauto.
     eapply B_Sym.
     eapply B_Step.
     auto.
   + (* case Beta1 *)
     match goal with [H0 : Typing ?D ?G  _ (a_Sum _ _) |- _ ] =>
        move: (invert_inj1 H0) => [A1' [A2' [G1' [Be [T1 T2]]]]];
        move: (Typing_regularity H0) => [Gr TS]
     end.
     repeat rewrite subst_def_Sum in Be.
     move: (invert_Beta_Sum1 Be) => Be1.
     move: (invert_Sum TS) => [BB [G3' [G4' [S [Ta Tb]]]]].
     eapply Typing_e.
     eapply T_app. eauto.
     eapply T_conv; eauto.
     eapply ctx_plus_comm; eclarify_ctx.
     match goal with [H1 : forall x, x `notin` ?L -> (open_tm_wrt_tm B1 (a_Var_f x)) = _ |- _ ] =>
        pick fresh x;
        move: (H1 x ltac:(auto)) => E
     end.
     apply (cong (subst_tm_tm a0 x)) in E.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     simpl in E.  destruct (x == x) eqn:E1. rewrite E1 in E.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     done.
   + (* case Beta1 *)
     match goal with [H0 : Typing ?D ?G  _ (a_Sum _ _) |- _ ] =>
        move: (invert_inj2 H0) => [A1' [A2' [G1' [Be [T1 T2]]]]];
        move: (Typing_regularity H0) => [Gr TS]
     end.
     repeat rewrite subst_def_Sum in Be.
     move: (invert_Beta_Sum2 Be) => Be1.
     move: (invert_Sum TS) => [BB [G3' [G4' [S [Ta Tb]]]]].
     eapply Typing_e.
     eapply T_app. eauto.
     eapply T_conv; eauto.
     eapply ctx_plus_comm; eclarify_ctx.
     match goal with [H1 : forall x, x `notin` ?L -> (open_tm_wrt_tm B2 (a_Var_f x)) = _ |- _ ] =>
        pick fresh x;
        move: (H1 x ltac:(auto)) => E
     end.
     apply (cong (subst_tm_tm a0 x)) in E.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     simpl in E.  destruct (x == x) eqn:E1. rewrite E1 in E.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     done.
 - (* Spread *)
   inversion St; subst.
   + (* case cong *)
     have Ta0 : Typing D5 G1 a'0 (a_Sigma q A1 A2).
     { eapply IHTyping. eauto. }
     have TBa0 : Typing D5 (ctx_plus G3 (ctx_mul r G1)) (open_tm_wrt_tm B a'0) a_Type.
     {
       pick fresh x.
       match goal with [H5 : forall y, y `notin` L -> _ ,
                        H0  : Typing ?D ?G a'0 _  |- _ ] =>
          move: (H5 x ltac:(auto)) => h1;
          move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H0) => SU
       end.
       asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU.
       eapply Typing_lc; eauto.
       rewrite subst_tm_same in SU. auto.
       rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
       eauto.
     }

     have TBa : Typing D5 (ctx_plus G3 (ctx_mul r G1)) (open_tm_wrt_tm B a) a_Type.
     {
       pick fresh x.
       match goal with [H5 : forall y, y `notin` L -> _ ,
                        H0  : Typing ?D ?G a _  |- _ ] =>
          move: (H5 x ltac:(auto)) => h1;
          move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H0) => SU
       end.
       asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU.
       eapply Typing_lc; eauto.
       rewrite subst_tm_same in SU. auto.
       rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
       eauto.
     }

     eapply T_conv with (A := open_tm_wrt_tm B a'0).
     eapply T_Spread; auto.
     eauto.
     pick fresh x.
     rewrite (subst_tm_tm_intro x B a); auto.
     rewrite (subst_tm_tm_intro x B a'0); auto.
     eapply subst_def_Beta; eauto using Typing_lc_ctx.
     eapply subst_Beta2.
     eapply Typing_lc. eauto.
     eapply B_Sym.
     eapply B_Step.
     auto.

   + (* case beta *)
     move: (invert_Tensor H0) => [A1' [A2' [q1 [Be [G1' [G2' [G3' [r' ?]]]]]]]].
     move: (Typing_regularity H0) => [G' TS].
     move: (invert_Sigma _ _ _ _ _ _ TS) => [_ [G1'' [G2'' [r'' ?]]]].
     repeat match goal with [H : _ /\ _ |- _ ] => destruct H  end.
     repeat rewrite subst_def_Sigma in Be.
     move: (invert_Beta_a_Sigma1 Be) => Be1.
     move: (invert_Beta_a_Sigma2 Be) => Be2.
     move: (invert_Beta_a_Sigma0 Be) => Be3.
     subst.

     pick fresh x for (dom D5 \u fv_tm_tm (subst_def D5 A2) \u fv_tm_tm (subst_def D5 A2') \u L \u fv_tm_tm b \u fv_tm_tm A2' \u fv_tm_tm B).
     pick fresh y.
     specialize (H1 x ltac:(auto) y ltac:(auto)). move: H1 => Tb.
     move: (Typing_ctx Tb) => C1.

     eapply substitution with (D2 := nil) (G2 := nil) (a := a0) in Tb.
     2: { eapply T_conv. eauto. eauto. eapply B_Sym. eauto. }
     asimpl in Tb.
     erewrite subst_tm_tm_open_tm_wrt_tm in Tb; eauto using Typing_lc.
     erewrite subst_tm_tm_close_tm_wrt_tm in Tb; eauto using Typing_lc.
     erewrite (subst_tm_tm_open_tm_wrt_tm B) in Tb; eauto using Typing_lc.
     simpl in Tb. destruct (x == x) eqn:E; rewrite E in Tb. 2: { done. } clear E e.
     destruct (y == x) eqn:E. { subst. clear Fr. solve_notin. }
     rewrite E in Tb. clear E n.
     rewrite subst_tm_tm_fresh_eq in Tb. { clear Fr0. fsetdec. }
     eapply Typing_e.
     eapply T_sub.
     3: { eauto. }
     eapply T_app.
     ++ eapply Tb.
     ++ eapply T_conv. eauto.
        replace a_Type with (subst_tm_tm a0 x a_Type).
        eapply substitution with (D2 := nil) (G2 := nil) (a := a0). simpl_env.
        eapply H6. { clear Fr0. fsetdec. } eapply T_conv. eauto. eauto. eapply B_Sym. auto. reflexivity.
        rewrite (subst_tm_tm_intro x). { clear Fr0. fsetdec. }
        repeat erewrite subst_def_subst_tm_tm; eauto using Typing_ctx_wff_regularity.
        eapply subst_Beta1; eauto using Typing_lc. eapply subst_def_lc_tm; eauto using Typing_lc_ctx. (* lc_tm (subst_def D5 a0) *)
        repeat erewrite subst_def_open_tm_wrt_tm.
        repeat erewrite (subst_def_fresh_eq D5 (a_Var_f x)).
        eapply B_Sym.
        eapply Be2.
        { clear Fr0. auto.  }
        { clear Fr0. intros. simpl. fsetdec. }
        all: eauto using Typing_lc_ctx.
     ++ destruct_ctx.
        simpl_env; eclarify_ctx.
        erewrite (ctx_plus_assoc _ _ G2); eclarify_ctx.
        erewrite ctx_plus_comm; eclarify_ctx.
        eapply ctx_sub_ctx_plus; eclarify_ctx.
        eapply ctx_sub_refl; eclarify_ctx.
     ++ rewrite subst_tm_tm_fresh_eq. { clear Fr0. fsetdec. }
        rewrite <- subst_tm_tm_spec.
        rewrite subst_tm_tm_open_tm_wrt_tm. eauto using Typing_lc.
        rewrite subst_tm_tm_fresh_eq. { clear Fr. fsetdec. }
        f_equal.
        simpl.
        destruct (y == y) eqn:E. 2: { done. } rewrite E.
        rewrite subst_tm_tm_fresh_eq. { clear Fr. fsetdec. }
        auto.
 - (* Case Prj1 *)
   inversion St; subst.
   + move: (Typing_regularity H) => [G4 Tw].
     move: (invert_With _ _ _ _ _ Tw) => [Be0 [G1' [G2' [r [SS [TA h0]]]]]].
     move: (invert_Pair H) => [A' [B' [Be [G3 [r1 [h1 [h2 h3]]]]]]].
     eapply T_conv; eauto 1.
     repeat rewrite subst_def_With in Be.
     eapply B_Sym.
     eapply invert_Beta_a_With1. eauto.
   + eauto.
 - (* Case Prj2 *)
   inversion St; subst.
   + move: (Typing_regularity H) => [G4 Tw].
     move: (invert_With _ _ _ _ _ Tw) => [Be0 [G1' [G2' [r [SS [TA h0]]]]]].
     move: (invert_Pair H) => [A' [B' [Be [G3 [r1 [h1 [h2 h3]]]]]]].
     have Tpp: (Typing D5 G (a_Prj1 (a_Pair a0 a')) A). { eauto. }
     have Tpp': (Typing D5 G (a_Prj1 (a_Pair a0 a')) A'). { eauto. }
     eapply B_Sym in Be.
     repeat rewrite subst_def_With in Be.
     pick fresh x for (fv_tm_tm (subst_def D5 B') \u fv_tm_tm (subst_def D5 B)
                                \u dom D5 \u fv_tm_tm B' \u fv_tm_tm B).
     eapply invert_Beta_a_With2 with (x0:=x) in Be; auto.
     specialize (h0 x ltac:(auto)).
     specialize (h3 x ltac:(auto)).
     eapply substitution with (D2:=nil) (G2:=nil) in Tpp. 2 : { simpl_env; eapply h0. }
     asimpl in Tpp.
     rewrite subst_tm_tm_open_tm_wrt_tm in Tpp; eauto using Typing_lc.
     rewrite subst_tm_same in Tpp; auto.
     rewrite subst_tm_tm_fresh_eq in Tpp; auto.

     eapply T_conv; eauto 1.

     eapply subst_Beta with (x:=x) (a0:=subst_def D5 a0)(a1:=subst_def D5 (a_Prj1 (a_Pair a0 a'))) in Be.
     erewrite subst_tm_tm_open_tm_wrt_tm in Be; eauto using Typing_lc, Typing_lc_ctx, subst_def_lc_tm.
     rewrite subst_tm_same in Be; auto.
     rewrite subst_tm_tm_fresh_eq in Be; auto.

     erewrite subst_tm_tm_open_tm_wrt_tm in Be; eauto using Typing_lc, Typing_lc_ctx, subst_def_lc_tm.
     rewrite subst_tm_same in Be; auto.
     rewrite subst_tm_tm_fresh_eq in Be; auto.

     rewrite subst_def_open_tm_wrt_tm; eauto using Typing_lc_ctx.
     rewrite subst_def_open_tm_wrt_tm; eauto using Typing_lc_ctx.

     eapply subst_def_Beta; eauto using Typing_lc_ctx.

   + move: (Typing_regularity H) => [Gw Tw].
     move: (invert_With _ _ _ _ _ Tw) => [Be [G0 [G1 [r [SS [h0 h1]]]]]].
     eapply T_conv.
     eauto.
     pick fresh x for (dom D5 \u fv_tm_tm (subst_def D5 B) \u fv_tm_tm B).
     have Tp1: Typing D5 G (a_Prj1 a) A. eauto.
     specialize (h1 x ltac:(auto)).
     eapply substitution with (D2 :=nil) (G2:=nil) in Tp1.
     2: { asimpl. eapply h1. }
     asimpl in Tp1.
     rewrite subst_tm_tm_open_tm_wrt_tm in Tp1. eauto using Typing_lc.
     rewrite subst_tm_same in Tp1; auto.
     rewrite subst_tm_tm_fresh_eq in Tp1; auto.
     eauto.
     pick fresh x for (dom D5 \u fv_tm_tm (subst_def D5 B) \u fv_tm_tm B \u fv_tm_tm a \u fv_tm_tm a'0).
     specialize (h1 x ltac:(auto)).
     rewrite (subst_tm_tm_intro x B); auto.
     rewrite (subst_tm_tm_intro x B (a_Prj1 a)); auto.
     eapply subst_def_Beta. eapply Typing_lc_ctx; eauto.
     eapply subst_Beta2; eauto. eapply Typing_lc; eauto.
Qed.

Ltac invert_value :=
  match goal with [ H : value ?a|- _ ]=> inversion H end;
  try match goal with [ H : ty ?a |- _ ] => inversion H end.

Ltac inconsistent :=
  match goal with [ H : Beta ?a ?b |- _ ] =>
     apply Beta_consistent in H; eauto; inversion H
  end.

Lemma canonical_Type : forall a A, Typing nil nil a A -> Beta a a_Type -> value a -> ty a.
Proof.
  intros a A h.
  dependent induction h; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H. subst. auto.
Qed.

Lemma canonical_Pi : forall a A q B1 B2, Typing nil nil a A -> Beta A (a_Pi q B1 B2) -> value a -> exists q1 a1 A1, a = a_Lam q1 A1 a1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0; subst; eauto.
Qed.

Lemma canonical_Sigma : forall a A q B1 B2, Typing nil nil a A -> Beta A (a_Sigma q B1 B2) -> value a ->
                                       exists a1 b1, a = a_Tensor a1 b1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. auto.
Qed.

Lemma canonical_Unit : forall a A, Typing nil nil a A -> Beta A a_TyUnit -> value a -> a = a_TmUnit.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. auto.
Qed.

Lemma canonical_Box : forall a A q B, Typing nil nil a A -> Beta A (a_Box q B) -> value a -> exists a1, a = a_box q a1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. destruct IHTyping; auto. eauto.
  - move: (invert_Beta_Box2 H0) => h0. subst. eauto.
Qed.

Lemma canonical_Sum : forall a A B1 B2, Typing nil nil a A -> Beta A (a_Sum B1 B2) -> value a -> exists a1, a = a_Inj1 a1 \/ a = a_Inj2 a1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. auto.
Qed.

Lemma canonical_Pair : forall a A B1 B2, Typing nil nil a A -> Beta A (a_With B1 B2) -> value a ->
                                       exists a1 b1, a = a_Pair a1 b1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. auto.
Qed.

(* Theorem 6.5 *)
Lemma progress : forall a A,
  Typing nil nil a A -> value a \/ exists a', Step a a'.
Proof.
  intros a A H. dependent induction H; eauto.
  - inversion H0. subst. eauto.
  - move: (Typing_ctx H) => C. move: (Typing_ctx H0) => C0. destruct_ctx.
    destruct IHTyping1; auto.
    + (* fun is a value *)
      have LC: lc_tm a. eapply Typing_lc; eauto.
      eapply canonical_Pi in H; auto. 2: { eapply B_Refl; eauto using Typing_lc2.  }
      destruct H as [q1 [A1 [a1' E]]]; auto. subst.
      inversion LC. subst.
      right. eexists.
      eapply S_Beta; eauto using Typing_lc.
    + (* fun steps *)
      destruct H1 as [a' SS].
      right. eexists. eauto using Typing_lc.
  - move: (Typing_ctx H) => C. move: (Typing_ctx H1) => C0. destruct_ctx.
    destruct IHTyping1; auto.
    + eapply canonical_Unit in H; auto. subst.
      right. eexists.
      eapply S_UnitBeta; eauto using Typing_lc.
    + destruct H0 as [a' SS].
      right. eexists.
      eapply S_UnitCong; eauto using Typing_lc.
  - move: (Typing_ctx H) => C. destruct_ctx.
    destruct IHTyping; auto.
    + have LC: lc_tm a. eauto using Typing_lc.
      pick fresh y.
      repeat match goal with [H : forall x, x `notin` ?L -> Typing _ _ _ _ |- _ ] => specialize (H y ltac:(auto)) end.
      move: (canonical_Box _ _ q A H) => h.
      destruct h as [a1 E]; auto.
      eapply B_Refl; eauto using Typing_lc2.
      subst.
      right. eexists.
      inversion LC.
      eapply S_BoxBeta; eauto using Typing_lc.
      eapply (lc_a_LetBoxB_exists y); eauto using Typing_lc.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc, Typing_lc2.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc2, Typing_lc2.
      eauto using Typing_lc.
    + destruct H4 as [a1 E]; auto.
      right. eexists.
      pick fresh y.
      eapply S_BoxCong; eauto using Typing_lc.
      eapply (lc_a_LetBoxB_exists y); eauto using Typing_lc.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc, Typing_lc2.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc2, Typing_lc2.
      eauto using Typing_lc.
  - move: (Typing_ctx H0) => C. destruct_ctx.
    have LC: lc_tm a. eapply Typing_lc; eauto.
    have LC2: lc_tm (a_Sum A1 A2). eapply Typing_lc2; eauto.
    destruct IHTyping1; auto.
    + eapply canonical_Sum in H0; auto.
      destruct H0 as [a0 [V1 | V2]]; subst.
      ++ right.
         eexists.
         inversion LC.
         eapply S_Case1Beta; eauto using Typing_lc.
      ++ right.
         eexists.
         inversion LC.
         eapply S_Case2Beta; eauto using Typing_lc.
    + destruct H7 as [a' SS].
      right. eexists.
      eapply S_CaseCong; eauto using Typing_lc.
  - right.
    move: (Typing_ctx H0) => C. destruct_ctx.
    have L1: lc_tm a by eauto using Typing_lc.
    have L2: lc_tm (a_Sigma q A1 A2) by eauto using Typing_lc2.
    have L4: lc_tm (a_Lam r (a_Sigma q A1 A2) B).
    { pick fresh y.
      move: (H3 y ltac:(auto)) => h.
      move: (Typing_lc h) => LB.
      eapply lc_a_Lam_exists. auto. eauto.
    }
    have L3: lc_tm (a_Spread a b (a_Lam r (a_Sigma q A1 A2) B)).
    {
      pick fresh y. pick fresh z.
      move: (H1 y ltac:(auto) z ltac:(auto)) => Tb.
      move: (Typing_lc Tb) => LB.
      eapply lc_a_Spread_exists; eauto.
    }
    destruct IHTyping; eauto.
    + have BB: Beta (a_Sigma q A1 A2) (a_Sigma q A1 A2).
      { eapply B_Refl; eauto. }
      move: (canonical_Sigma a _ q A1 A2 H0 BB H) => h.
      move: h => [a1 [b1 EQ]]. subst a.
      inversion L1. subst.
      eexists.
      eapply S_SpreadBeta; eauto using Typing_lc.
    + move: H => [a' SS].
      eexists.
      eapply S_SpreadCong; eauto.
  -
    move: (Typing_regularity H) => [Gr Hr].
    destruct IHTyping; eauto.
    have BB: Beta (a_With A B) (a_With A B). eapply B_Refl; eauto using Typing_lc.
    + move: (canonical_Pair _ _ _ _ H BB H0) => [a1' [b1' h]]. subst.
      have LC: (lc_tm (a_Pair a1' b1')). eauto using Typing_lc. inversion LC.
      right.
      exists a1'. eapply S_Prj1Beta; eauto using Typing_lc.
    + move: H0 => [a' SS].
      right. exists (a_Prj1 a'). eapply S_Prj1Cong. auto.
   - move: (Typing_regularity H) => [Gr Hr].
    destruct IHTyping; eauto.
    have BB: Beta (a_With A B) (a_With A B). eapply B_Refl; eauto using Typing_lc.
    + move: (canonical_Pair _ _ _ _ H BB H0) => [a1' [b1' h]]. subst.
      have LC: (lc_tm (a_Pair a1' b1')). eauto using Typing_lc. inversion LC.
      right.
      exists b1'. eapply S_Prj2Beta; eauto using Typing_lc.
    + move: H0 => [a' SS].
      right. exists (a_Prj2 a'). eapply S_Prj2Cong. auto.
Qed.


Require Export Iron.Language.SystemF2Cap.Store.Prop.
Require Export Iron.Language.SystemF2Cap.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.WfT.
Require Export Iron.Language.SystemF2Cap.Type.Exp.

(********************************************************************)
(* Only types of effect and closure kinds can be used in sums. *)
Definition SumKind (k : ki) : Prop
 := k = KEffect.
Hint Unfold SumKind.

(* Region kinds cannot be the result of type applications. *)
Definition AppKind (k : ki) : Prop
 := ~ (k = KRegion).
Hint Unfold AppKind.

(* Kinds judgement assigns a kind to a type *)
Inductive KindT : kienv -> stprops -> ty -> ki -> Prop :=
  | KiVar
    :  forall ke sp i k
    ,  (exists o, get i ke = Some (o, k))
    -> KindT ke sp (TVar i) k

  | KiForall
    :  forall ke sp k t
    ,  KindT (ke :> (OAbs, k)) sp t KData
    -> KindT ke    sp (TForall k t) KData

  | KiApp
    :  forall ke sp t1 t2 k11 k12
    ,  AppKind k12
    -> KindT ke sp t1 (KFun k11 k12)
    -> KindT ke sp t2 k11
    -> KindT ke sp (TApp t1 t2) k12

  | KiSum
    :  forall ke sp k t1 t2
    ,  SumKind k
    -> KindT ke sp t1 k -> KindT ke sp t2 k
    -> KindT ke sp (TSum t1 t2) k

  | KiBot
    :  forall ke sp k
    ,  SumKind k
    -> KindT ke sp (TBot k) k

  | KiCon0
    :  forall ke sp tc k
    ,  k = kindOfTyCon0 tc
    -> KindT ke sp (TCon0 tc) k

  | KiCon1
    :  forall ke sp tc t1 k1 k
    ,  KFun k1 k = kindOfTyCon1 tc
    -> KindT ke sp t1 k1
    -> KindT ke sp (TCon1 tc t1) k

  | KiCon2
    :  forall ke sp tc t1 t2 k1 k2 k
    ,  KFun k1 (KFun k2 k) = kindOfTyCon2 tc
    -> KindT ke sp t1 k1
    -> KindT ke sp t2 k2
    -> KindT ke sp (TCon2 tc t1 t2) k

  | KiRgn
    :  forall ke sp p
    ,  In (SRegion p) sp
    -> KindT ke sp (TRgn p) KRegion.

Hint Constructors KindT.

(********************************************************************)
(* Invert all hypothesis that are compound kinding statements. *)
Ltac inverts_kind :=
 repeat
  (match goal with
   | [ H: KindT _ _ (TVar _)      _  |- _ ] => inverts H
   | [ H: KindT _ _ (TForall _ _) _  |- _ ] => inverts H
   | [ H: KindT _ _ (TApp _ _)    _  |- _ ] => inverts H
   | [ H: KindT _ _ (TSum _ _)    _  |- _ ] => inverts H
   | [ H: KindT _ _ (TBot _ )     _  |- _ ] => inverts H
   | [ H: KindT _ _ (TCon0 _)     _  |- _ ] => inverts H
   | [ H: KindT _ _ (TCon1 _ _)   _  |- _ ] => inverts H
   | [ H: KindT _ _ (TCon2 _ _ _) _  |- _ ] => inverts H
   | [ H: KindT _ _ (TCap _) _       |- _ ] => inverts H
   end).

(********************************************************************)
(* Forms of types *)
Lemma kind_region
 :  forall t sp
 ,  KindT   nil sp t KRegion
 -> (exists p, t = TRgn p).
Proof.
 intros.
 destruct t; burn.

 - Case "TApp".
   inverts_kind.
   false. auto.

 - Case "TCon0".
   destruct t; nope.

 - Case "TCon1".
   destruct t; nope.

 - Case "TCon2".
   destruct t1; nope.

 - Case "TCap".
   destruct t.
   exists n. auto.
Qed.
Hint Resolve kind_region.

(* Well kinded sums have SumKind *)
Lemma kind_sumkind
 :  forall ke sp t1 t2 k
 ,  KindT ke sp (TSum t1 t2) k
 -> SumKind k.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve kind_sumkind.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

   Bind all the modules together, rename things for convenience.

   Require Export LanguageModule to get this.
*)

Set Implicit Arguments.
Require Export CpdtTactics.
Require Export Case.

Require Export EVarModuleDef.
Require Export EVarPathModuleDef.
Require Export TauModuleDef.
Require Export PathModuleDef.
Require Export PhiModuleDef.
Require Export TermModuleDef.
Require Export ContextFunDef.

(* Modules:
   kappa - K
   phi   - P
   Path  - Path
   Tau   - T
   Term  - TM
   TVar - TV.
   TVars - TVS.
   EVar - EV.
   EVars - EVS.
*)

Module LanguageModule.
  Module TM := TermModule.
  Include TM.Types.
(*
  Print Module K.
  Print Module P.
  Print Module Path.
  Print Module T.
  Print Module TM.
  Print Module TV.
  Print Module TVS.
  Print Module EV.
  Print Module EVS.
*)
  Module D := ContextFun TV K.
  (* Now what happens here if I use D.K/D.T vs TV.T T.K ? *)
  Definition Delta    := D.Context.

  (* Can I just drop these and get rid of some unfolding? Seems likely. *)
  Notation "x '~_d' a" := (D.ctxt x a D.dot)
                           (at level 27, left associativity).
  Notation "E '&_d' F" := (D.concat E F)
                           (at level 28, left associativity).

  Module G := ContextFun EV T.
  Definition Gamma    := G.Context.

  Notation "x '~_g' a" := (G.ctxt x a G.dot)
                           (at level 27, left associativity).
  Notation "E '&_g' F" := (G.concat E F)
                           (at level 28, left associativity).

  Module U := ContextFun EVarPathModule T.
  Definition Upsilon  := U.Context.

  Module H := ContextFun EV TM.
  Definition Heap     := H.Context.

  Notation "\{}_t" := (TVS.empty).
  Notation "\{ x }_t" := (TVS.singleton x).
  Notation "E \u_t F" := (TVS.union E F)
                           (at level 37, right associativity).
  Notation "E \n_t F" := (TVS.inter E F)
                           (at level 36, right associativity).
  Notation "E \-_t F" := (TVS.remove E F)
                           (at level 35).
  Notation "x \in_t E" := ((TVS.mem x E) = true) (at level 39).
  Notation "x \notin_t E" := ((TVS.mem x E) = false) (at level 39).
  Notation "E \c_t F" := (TVS.subset E F)
                           (at level 38).

  Notation "\{}_e" := (EVS.empty).
  Notation "\{ x }_e" := (EVS.singleton x).
  Notation "E \u_e F" := (EVS.union E F)
                           (at level 37, right associativity).
  Notation "E \n_e F" := (EVS.inter E F)
                           (at level 36, right associativity).
  Notation "E \-_e F" := (EVS.remove E F)
                           (at level 35).
  Notation "x \in_e E" := ((EVS.mem x E) = true) (at level 39).
  Notation "x \notin_e E" := ((EVS.mem x E) = false) (at level 39).
  Notation "E \c_e F" := (EVS.subset E F)
                           (at level 38).

End LanguageModule.
Export LanguageModule.


Set Implicit Arguments.
Require Import List Lia.
From Undecidability.HOU Require Import std.std calculus.calculus unification.higher_order_unification.
Import ListNotations.

Set Default Proof Using "Type".

(* * System Unification *)
Section SystemUnification.

  Variable (X: Const).

  Definition eq: Type := exp X * exp X.
  Definition eqs := list eq.

  Implicit Types (sigma: fin -> exp X) (e: eq) (E : eqs).

  Definition eq_typing  Gamma e A := Gamma ⊢ fst e : A /\ Gamma ⊢ snd e : A.

  Notation "Gamma ⊢₂ e : A" := (eq_typing Gamma e A) (at level 80, e at level 99).

  Reserved Notation  "Gamma ⊢₊₊ E : L" (at level 80, E at level 99).

  Inductive eqs_typing Gamma : eqs -> list type -> Prop :=
  | eqs_typing_nil: Gamma ⊢₊₊ nil : nil
  | eqs_typing_cons s t A E L: Gamma ⊢ s : A -> Gamma ⊢ t : A -> Gamma ⊢₊₊ E : L -> Gamma ⊢₊₊ ((s,t) :: E) : A :: L
  where  "Gamma ⊢₊₊ E : L" := (eqs_typing Gamma E L).

  Hint Constructors eqs_typing : core.

  Definition left_side E := map fst E.
  Definition right_side E := map snd E.

  Lemma left_typing Gamma E L: Gamma ⊢₊₊ E : L -> Gamma ⊢₊ left_side E : L.
  Proof. induction 1; cbn; eauto. Qed.
  Lemma right_typing Gamma E L: Gamma ⊢₊₊ E : L -> Gamma ⊢₊ right_side E : L.
  Proof. induction 1; cbn; eauto. Qed.

  Lemma typing_combine Gamma E L:
    Gamma ⊢₊ left_side E : L -> Gamma ⊢₊ right_side E : L -> Gamma ⊢₊₊ E : L.
  Proof.
    intros H1 H2; induction E in L, H1, H2 |-*; inv H1; inv H2; eauto.
    destruct a; eauto.
  Qed.

  Hint Resolve left_typing right_typing : core.

  Definition vars' (e: eq) := vars (fst e) ++ vars (snd e).
  Definition Vars' (E: list eq) := flat_map vars' E.

  Lemma Vars'_cons e E: Vars' (e :: E) = vars' e ++ Vars' E.
  Proof. reflexivity. Qed.

  Lemma Vars'_app E1 E2:
    Vars' (E1 ++ E2) = Vars' E1 ++ Vars' E2.
  Proof.
    unfold Vars'; now rewrite !flat_map_app.
  Qed.

  Hint Rewrite Vars'_cons Vars'_app : simplify.

  Definition subst_eq sigma e := let (s, t) := e in (sigma • s, sigma • t).

  Notation "sigma •₊₊ E" := (map (subst_eq sigma) E) (at level 69, right associativity).

  Lemma left_subst_eqs E sigma:
    left_side (sigma •₊₊ E) = sigma •₊ left_side E.
  Proof.
    unfold left_side; induction E as [| []]; cbn; congruence.
  Qed.

  Lemma right_subst_eqs E sigma:
    right_side (sigma •₊₊ E) = sigma •₊ right_side E.
  Proof.
    unfold right_side; induction E as [| []]; cbn; congruence.
  Qed.

  Hint Rewrite left_subst_eqs right_subst_eqs : simplify.

  Lemma equiv_eqs_pointwise sigma E:
    (sigma •₊ left_side E) ≡₊ (sigma •₊ right_side E) -> (forall s t, (s, t) ∈ E -> sigma • s ≡ sigma • t).
  Proof.
    induction E; cbn; intuition; subst.
    all: eapply equiv_lstep_cons_inv in H; intuition.
  Qed.

  Lemma equiv_pointwise_eqs sigma E:
    (forall s t, (s, t) ∈ E -> sigma • s ≡ sigma • t) ->
    (sigma •₊ left_side E) ≡₊ (sigma •₊ right_side E).
  Proof.
    induction E as [| [s t]]; cbn; intros; eauto; intuition.
    rewrite H; intuition.
    rewrite IHE; intuition.
  Qed.

  Lemma eqs_typing_preservation_subst Gamma E L Delta sigma:
      Gamma ⊢₊₊ E : L -> Delta ⊩ sigma : Gamma -> Delta ⊢₊₊ sigma •₊₊ E : L.
  Proof. induction 1; cbn; eauto. Qed.

  Definition all_terms (P: exp X -> Prop) (E: eqs) := forall s t, (s, t) ∈ E -> P s /\ P t.
  Definition all_eqs (P: exp X -> exp X -> Prop) (E: eqs) := forall s t, (s, t) ∈ E -> P s t.

  Lemma all_terms_cons P e E:
    all_terms P (e :: E) -> P (fst e) /\ P (snd e) /\ all_terms P E.
  Proof.
    destruct e as [s t]; intros H; cbn.
    specialize (H s t) as H'; cbn in H'; intuition.
    intros ???; eapply H; cbn; intuition.
  Qed.

  Lemma all_terms_cons_iff P e E:
    all_terms P (e :: E) <-> P (fst e) /\ P (snd e) /\ all_terms P E.
  Proof.
    unfold all_eqs; cbn; split.
    - eauto using all_terms_cons.
    - intros (? & ? & ?) ? ? [->|H']; firstorder.
  Qed.

  Hint Rewrite all_terms_cons_iff : simplify.

  Lemma all_terms_nil P: all_terms P nil.
  Proof. intros ??[]. Qed.

  Lemma all_terms_app P (E1 E2: eqs):
    all_terms P (E1 ++ E2) <-> all_terms P E1 /\ all_terms P E2.
  Proof.
    unfold all_eqs; split.
    - intros H; split; intros s t H'; eapply H; simplify; intuition.
    - intros [H1 H2] s t; simplify; intros [? % H1|? % H2]; intuition.
  Qed.

  Hint Rewrite all_terms_app : simplify.

  Class sysuni :=
  {
    Gammaᵤ'  : ctx;
    Eᵤ'  : eqs;
    Lᵤ'  : list type;
    Hᵤ' : Gammaᵤ' ⊢₊₊ Eᵤ' : Lᵤ';
  }.

  Definition SU (I: sysuni) := exists (Delta: ctx) (sigma: fin -> exp X),
      (Delta ⊩ sigma : Gammaᵤ') /\ forall s t, (s, t) ∈ Eᵤ' -> sigma • s ≡ sigma • t.

  Arguments SU: clear implicits.
  Hint Resolve Hᵤ' : core.

  Definition linearize_terms (S: list (exp X)) :=
    lambda AppR (var 0) (renL shift S).

  Lemma linearize_terms_subst sigma S: sigma • linearize_terms S = linearize_terms (sigma •₊ S).
  Proof. unfold linearize_terms; asimpl.
         rewrite !map_map; asimpl.
         f_equal. f_equal. eapply map_ext.
         intros ?; now asimpl.
  Qed.

  Lemma linearize_terms_equiv S T:
    linearize_terms S ≡ linearize_terms T <-> S ≡₊ T.
  Proof.
    split.
    - intros [? % list_equiv_anti_ren _] % equiv_lam_elim % equiv_AppR_elim; eauto.
      unfold shift; intros ??; congruence.
    - unfold linearize_terms. now intros ->.
  Qed.

  Lemma linearize_terms_typing Gamma S L A:
    Gamma ⊢₊ S : L -> Gamma ⊢ linearize_terms S : (Arr (rev L) A) → A.
  Proof.
    intros H; econstructor; eapply AppR_typing with (L := L).
    eapply listtyping_preservation_under_renaming; eauto.
    intros x ?; cbn; eauto.
    econstructor; eauto; simplify; cbn; intuition.
  Qed.

  Lemma linearize_vars S:
    vars (linearize_terms S) === Vars S.
  Proof.
    split.
    - intros ? H % vars_varof. inv H. eapply varof_vars in H1.
      rewrite AppR_vars in H1. simplify in H1. cbn in H1; intuition.
      discriminate. eapply in_flat_map in H as [? []].
      mapinj. eapply vars_ren in H0 as []. intuition.
      injection H1 as ->. eapply in_flat_map. eexists; eauto.
    - intros x H. eapply varof_vars; econstructor; eapply vars_varof.
      rewrite AppR_vars; simplify; right.
      eapply in_flat_map in H as [y]; eapply in_flat_map; exists (ren shift y).
      intuition. now eapply ren_vars.
  Qed.

  Hint Resolve linearize_terms_typing : core.

  Section Interreducible.

  Global Program Instance uni_sysuni (I: uni X): sysuni :=
     { Gammaᵤ' := Gammaᵤ; Eᵤ' := [(sᵤ, tᵤ)]; Lᵤ' := [Aᵤ]; Hᵤ' := _; }.

   Global Program Instance sysuni_uni (I: sysuni): uni X :=
       {
         Gammaᵤ := Gammaᵤ';
         sᵤ := linearize_terms (left_side Eᵤ');
         tᵤ := linearize_terms (right_side Eᵤ');
         Aᵤ := (Arr (rev Lᵤ') alpha) → alpha;
         H1ᵤ := _;
         H2ᵤ := _;
       }.

   Lemma U_SU: U X ⪯ SU.
   Proof.
     exists (uni_sysuni); intros I.
     split; intros (Delta & sigma & H1 & H2); exists Delta; exists sigma; intuition.
     firstorder; injection H; intros; subst; eauto.
     eapply H2; firstorder.
   Qed.

   Lemma SU_U: SU ⪯ U X.
   Proof.
     exists (sysuni_uni).
     intros I; split; intros (Delta & sigma & H1 & H2); exists Delta; exists sigma; destruct I; intuition;
       cbn [sᵤ tᵤ sysuni_uni] in *.
     rewrite !linearize_terms_subst, linearize_terms_equiv. now apply equiv_pointwise_eqs.
     eapply equiv_eqs_pointwise; eauto.
     now rewrite <-linearize_terms_equiv, <-!linearize_terms_subst.
   Qed.

  End Interreducible.

End SystemUnification.

Arguments SU : clear implicits.
Arguments sysuni : clear implicits.
Arguments Gammaᵤ' {_} {_}.
Arguments Eᵤ' {_} {_}.
Arguments Lᵤ' {_} {_}.

Notation "sigma •₊₊ E" := (map (subst_eq sigma) E) (at level 69, right associativity).
Notation  "Gamma ⊢₊₊ E : L" := (eqs_typing Gamma E L) (at level 80, E at level 99).
Notation "Gamma ⊢₂ e : A" := (eq_typing Gamma e A) (at level 80, e at level 99).

Global Hint Rewrite all_terms_cons_iff all_terms_app Vars'_app Vars'_cons: simplify.
#[export] Hint Resolve all_terms_nil : core.

(* ** Normalisation *)
Definition NSU {X: Const} (I: sysuni X) := exists Delta sigma,
    Delta ⊩ sigma : Gammaᵤ' /\ (forall s t, (s, t) ∈ Eᵤ' -> sigma • s ≡ sigma • t) /\
                 forall x, normal (sigma x).

Lemma SU_NSU X I: SU X I <-> NSU I.
Proof.
  split; intros (Delta & sigma & H1 & H2); [| exists Delta; exists sigma; intuition].
  eapply normalise_subst in H1 as (tau & H5 & H6 & H7).
  pose (theta x := if nth (@Gammaᵤ' _ I) x then tau x else var x).
  exists Delta. exists theta. intuition.
  + intros ???; unfold theta; rewrite H; eapply H7; eauto.
  + rewrite subst_pointwise_equiv with (sigma := theta) (tau := sigma).
    rewrite subst_pointwise_equiv with (sigma := theta) (tau := sigma); eauto.
    all: intros ? ?; enough (x ∈ dom Gammaᵤ') as D;
      [domin D; unfold theta; rewrite D|]; eauto.
    all: eapply Vars_listtyping.
    2, 4: eapply in_flat_map; eexists; (intuition eauto).
    2: change t with (snd (s, t)); eapply in_map; eauto.
    2: change s with (fst (s, t)); eapply in_map; eauto.
    eapply right_typing, @Hᵤ'.
    eapply left_typing, @Hᵤ'.
  + unfold theta; destruct nth eqn: ?; [|eauto].
    domin Heqo; eauto.
Qed.


Class monad (mon : Type -> Type) :=
  {
    ret : forall {A : Type},  A -> mon A;
    bind : forall {A B : Type}, mon A -> (A -> mon B) -> mon B
  }.

Delimit Scope monad_scope with monad.

Notation "x >>= f" := (bind x f) (at level 50, left associativity) : monad_scope.

Notation "x <- c1 ;; c2" := (bind c1 (fun x => c2))
                                  (at level 100, c1 at next level, right associativity) : monad_scope.

Open Scope monad.

Definition liftM {M : Type -> Type} `{monad M} {A B : Type} (f : A -> B)
           (m1: M A) : M B :=
  n1 <- m1 ;;
  ret (f n1).

Definition liftM2 {M : Type -> Type} `{monad M} {A1 A2 B : Type} (f : A1 -> A2 -> B)
           (m1: M A1) (m2 : M A2)  : M B :=
  n1 <- m1 ;;
  n2 <- m2 ;;
  ret (f n1 n2).

Instance optionMonad : monad option :=
  {
    ret A x := Some x;
    bind A B x f :=
      match x with
        | Some y => f y
        | None => None
      end
  }.

Definition State (St : Type) (A: Type) := St -> (A * St)%type.

Instance stateMonad {St : Type} : monad (State St) :=
  {
    ret A x := fun s => (x, s);
    bind A B x f :=
      fun s =>
        let (y, s') := x s in
        f y s'
  }.

Definition get {St} : State St St := fun st => (st, st).

Definition set {St} (ns : St) : State St unit := fun _ => (tt, ns).


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

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

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

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

(** * Relative error of the roundings *)

From Coq Require Import ZArith Reals Psatz.

Require Import Core.

Section Fprop_relative.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Section Fprop_relative_generic.

Variable fexp : Z -> Z.
Context { prop_exp : Valid_exp fexp }.

Section relative_error_conversion.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma relative_error_lt_conversion :
  forall x b, (0 < b)%R ->
  (x <> 0 -> Rabs (round beta fexp rnd x - x) < b * Rabs x)%R ->
  exists eps,
  (Rabs eps < b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x b Hb0 Hxb.
destruct (Req_dec x 0) as [Hx0|Hx0].
(* *)
exists 0%R.
split.
now rewrite Rabs_R0.
rewrite Hx0, Rmult_0_l.
apply round_0...
(* *)
specialize (Hxb Hx0).
exists ((round beta fexp rnd x - x) / x)%R.
split. 2: now field.
unfold Rdiv.
rewrite Rabs_mult.
apply Rmult_lt_reg_r with (Rabs x).
now apply Rabs_pos_lt.
rewrite Rmult_assoc, <- Rabs_mult.
rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.

Lemma relative_error_le_conversion :
  forall x b, (0 <= b)%R ->
  (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R ->
  exists eps,
  (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x b Hb0 Hxb.
destruct (Req_dec x 0) as [Hx0|Hx0].
(* *)
exists 0%R.
split.
now rewrite Rabs_R0.
rewrite Hx0, Rmult_0_l.
apply round_0...
(* *)
exists ((round beta fexp rnd x - x) / x)%R.
split. 2: now field.
unfold Rdiv.
rewrite Rabs_mult.
apply Rmult_le_reg_r with (Rabs x).
now apply Rabs_pos_lt.
rewrite Rmult_assoc, <- Rabs_mult.
rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.

Lemma relative_error_le_conversion_inv :
  forall x b,
  (exists eps,
   (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R) ->
  (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x b (eps, (Beps, Heps)).
assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|].
rewrite Heps; replace (_ - _)%R with (eps * x)%R; [|ring].
now rewrite Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|].
Qed.

Lemma relative_error_le_conversion_round_inv :
  forall x b,
  (exists eps,
   (Rabs eps <= b)%R /\ x = (round beta fexp rnd x * (1 + eps))%R) ->
  (Rabs (round beta fexp rnd x - x) <= b * Rabs (round beta fexp rnd x))%R.
Proof with auto with typeclass_instances.
intros x b.
set (rx := round _ _ _ _).
intros (eps, (Beps, Heps)).
assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|].
rewrite Heps; replace (_ - _)%R with (- (eps * rx))%R; [|ring].
now rewrite Rabs_Ropp, Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|].
Qed.

End relative_error_conversion.

Variable emin p : Z.
Hypothesis Hmin : forall k, (emin < k)%Z -> (p <= k - fexp k)%Z.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error :
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
assert (Hx': (x <> 0)%R).
intros T; contradict Hx; rewrite T, Rabs_R0.
apply Rlt_not_le, bpow_gt_0.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply error_lt_ulp...
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
assert (emin < ex)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
generalize (Hmin ex).
lia.
apply Rmult_le_compat_l.
apply bpow_ge_0.
apply He.
Qed.

(** 1+#ε# property in any rounding *)
Theorem relative_error_ex :
  forall x,
  (bpow emin <= Rabs x)%R ->
  exists eps,
  (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
intros _.
now apply relative_error.
Qed.

Theorem relative_error_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
Proof.
intros m x Hx.
apply relative_error.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Theorem relative_error_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_F2R_emin.
Qed.

Theorem relative_error_round :
  (0 < p)%Z ->
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
Proof with auto with typeclass_instances.
intros Hp x Hx.
assert (Hx': (x <> 0)%R).
intros T; contradict Hx; rewrite T, Rabs_R0.
apply Rlt_not_le, bpow_gt_0.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply error_lt_ulp.
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
generalize (Hmin ex).
lia.
apply Rmult_le_compat_l.
apply bpow_ge_0.
generalize He.
apply round_abs_abs...
clear rnd valid_rnd x Hx Hx' He.
intros rnd valid_rnd x _ Hx.
rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
now apply round_le.
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
generalize (Hmin ex).
lia.
Qed.

Theorem relative_error_round_F2R_emin :
  (0 < p)%Z ->
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
Proof.
intros Hp m x Hx.
apply relative_error_round.
exact Hp.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N :
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R.
Proof.
intros x Hx.
apply Rle_trans with (/2 * ulp beta fexp x)%R.
now apply error_le_half_ulp.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
assert (emin < ex)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
generalize (Hmin ex).
lia.
apply Rmult_le_compat_l.
apply bpow_ge_0.
apply He.
Qed.

(** 1+#ε# property in rounding to nearest *)
Theorem relative_error_N_ex :
  forall x,
  (bpow emin <= Rabs x)%R ->
  exists eps,
  (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N.
Qed.

Theorem relative_error_N_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
apply relative_error_N.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Theorem relative_error_N_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_F2R_emin.
Qed.

Theorem relative_error_N_round :
  (0 < p)%Z ->
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros Hp x Hx.
apply Rle_trans with (/2 * ulp beta fexp x)%R.
now apply error_le_half_ulp.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
generalize (Hmin ex).
lia.
apply Rmult_le_compat_l.
apply bpow_ge_0.
generalize He.
apply round_abs_abs...
clear rnd valid_rnd x Hx Hx' He.
intros rnd valid_rnd x _ Hx.
rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
now apply round_le.
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
generalize (Hmin ex).
lia.
Qed.

Theorem relative_error_N_round_F2R_emin :
  (0 < p)%Z ->
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros Hp m x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
apply relative_error_N_round with (1 := Hp).
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

End Fprop_relative_generic.

Section Fprop_relative_FLX.

Variable prec : Z.
Variable Hp : Z.lt 0 prec.

Lemma relative_error_FLX_aux :
  forall k, (prec <= k - FLX_exp prec k)%Z.
Proof.
intros k.
unfold FLX_exp.
lia.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error_FLX :
  forall x,
  (x <> 0)%R ->
  (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (mag beta x) as (ex, He).
specialize (He Hx).
apply relative_error with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

(** 1+#ε# property in any rounding in FLX *)
Theorem relative_error_FLX_ex :
  forall x,
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_FLX.
Qed.

Theorem relative_error_FLX_round :
  forall x,
  (x <> 0)%R ->
  (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (mag beta x) as (ex, He).
specialize (He Hx).
apply relative_error_round with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N_FLX :
  forall x,
  (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
destruct (mag beta x) as (ex, He).
specialize (He Hx).
apply relative_error_N with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

(** unit roundoff *)
Definition u_ro := (/2 * bpow (-prec + 1))%R.

Lemma u_ro_pos : (0 <= u_ro)%R.
Proof. apply Rmult_le_pos; [lra|apply bpow_ge_0]. Qed.

Lemma u_ro_lt_1 : (u_ro < 1)%R.
Proof.
unfold u_ro; apply (Rmult_lt_reg_l 2); [lra|].
rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, Rmult_1_r; [|lra].
apply (Rle_lt_trans _ (bpow 0));
  [apply bpow_le; lia|simpl; lra].
Qed.

Lemma u_rod1pu_ro_pos : (0 <= u_ro / (1 + u_ro))%R.
Proof.
apply Rmult_le_pos; [|apply Rlt_le, Rinv_0_lt_compat];
assert (H := u_ro_pos); lra.
Qed.

Lemma u_rod1pu_ro_le_u_ro : (u_ro / (1 + u_ro) <= u_ro)%R.
Proof.
assert (Pu_ro := u_ro_pos).
apply (Rmult_le_reg_r (1 + u_ro)); [lra|].
unfold Rdiv; rewrite Rmult_assoc, Rinv_l; [|lra].
assert (0 <= u_ro * u_ro)%R; [apply Rmult_le_pos|]; lra.
Qed.

Theorem relative_error_N_FLX' :
  forall x,
  (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x)
   <= u_ro / (1 + u_ro) * Rabs x)%R.
Proof with auto with typeclass_instances.
intro x.
assert (Pu_ro : (0 <= u_ro)%R).
{ apply Rmult_le_pos; [lra|apply bpow_ge_0]. }
destruct (Req_dec x 0) as [Zx|Nzx].
{ rewrite Zx, Rabs_R0, Rmult_0_r, round_0...
  now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. }
set (ufpx := bpow (mag beta x - 1)%Z).
set (rx := round _ _ _ _).
assert (Pufpx : (0 <= ufpx)%R); [now apply bpow_ge_0|].
assert (H_2_1 : (Rabs (rx - x) <= u_ro * ufpx)%R).
{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _);
    [now apply FLX_exp_valid|right].
  unfold ulp, cexp, FLX_exp, u_ro, ufpx; rewrite (Req_bool_false _ _ Nzx).
  rewrite Rmult_assoc, <-bpow_plus; do 2 f_equal; ring. }
assert (H_2_3 : (ufpx + Rabs (rx - x) <= Rabs x)%R).
{ apply (Rplus_le_reg_r (- ufpx)); ring_simplify.
  destruct (Rle_or_lt 0 x) as [Sx|Sx].
  { apply (Rle_trans _ (Rabs (ufpx - x))).
    { apply round_N_pt; [now apply FLX_exp_valid|].
      apply generic_format_bpow; unfold FLX_exp; lia. }
    rewrite Rabs_minus_sym, Rabs_pos_eq.
    { now rewrite Rabs_pos_eq; [right; ring|]. }
    apply (Rplus_le_reg_r ufpx); ring_simplify.
    now rewrite <-(Rabs_pos_eq _ Sx); apply bpow_mag_le. }
  apply (Rle_trans _ (Rabs (- ufpx - x))).
  { apply round_N_pt; [now apply FLX_exp_valid|].
    apply generic_format_opp, generic_format_bpow; unfold FLX_exp; lia. }
  rewrite Rabs_pos_eq; [now rewrite Rabs_left; [right|]|].
  apply (Rplus_le_reg_r x); ring_simplify.
  rewrite <-(Ropp_involutive x); apply Ropp_le_contravar; unfold ufpx.
  rewrite <-mag_opp, <-Rabs_pos_eq; [apply bpow_mag_le|]; lra. }
assert (H : (Rabs ((rx - x) / x) <= u_ro / (1 + u_ro))%R).
{ assert (H : (0 < ufpx + Rabs (rx - x))%R).
  { apply Rplus_lt_le_0_compat; [apply bpow_gt_0|apply Rabs_pos]. }
  apply (Rle_trans _ (Rabs (rx - x) / (ufpx + Rabs (rx - x)))).
  { unfold Rdiv; rewrite Rabs_mult; apply Rmult_le_compat_l; [apply Rabs_pos|].
    now rewrite (Rabs_Rinv _ Nzx); apply Rinv_le. }
  apply (Rmult_le_reg_r ((ufpx + Rabs (rx - x)) * (1 + u_ro))).
  { apply Rmult_lt_0_compat; lra. }
  field_simplify; [try unfold Rdiv; rewrite ?Rinv_1, ?Rmult_1_r| |]; lra. }
revert H; unfold Rdiv; rewrite Rabs_mult, (Rabs_Rinv _ Nzx); intro H.
apply (Rmult_le_reg_r (/ Rabs x)); [now apply Rinv_0_lt_compat, Rabs_pos_lt|].
now apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0|lra].
Qed.

(** 1+#ε# property in rounding to nearest in FLX *)
Theorem relative_error_N_FLX_ex :
  forall x,
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_FLX.
Qed.

Theorem relative_error_N_FLX'_ex :
  forall x,
  exists eps,
  (Rabs eps <= u_ro / (1 + u_ro))%R /\
  round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x.
apply relative_error_le_conversion...
{ apply u_rod1pu_ro_pos. }
now apply relative_error_N_FLX'.
Qed.

Lemma relative_error_N_round_ex_derive :
  forall x rx,
  (exists eps, (Rabs eps <= u_ro / (1 + u_ro))%R /\ rx = (x * (1 + eps))%R) ->
  exists eps, (Rabs eps <= u_ro)%R /\ x = (rx * (1 + eps))%R.
Proof.
intros x rx (d, (Bd, Hd)).
assert (Pu_ro := u_ro_pos).
assert (H := Rabs_le_inv _ _ Bd).
assert (H' := u_rod1pu_ro_le_u_ro); assert (H'' := u_ro_lt_1).
destruct (Req_dec rx 0) as [Zfx|Nzfx].
{ exists 0%R; split; [now rewrite Rabs_R0|].
  rewrite Rplus_0_r, Rmult_1_r, Zfx.
  now rewrite Zfx in Hd; destruct (Rmult_integral _ _ (sym_eq Hd)); [|lra]. }
destruct (Req_dec x 0) as [Zx|Nzx].
{ now exfalso; revert Hd; rewrite Zx, Rmult_0_l. }
set (d' := ((x - rx) / rx)%R).
assert (Hd' : (Rabs d' <= u_ro)%R).
{ unfold d'; rewrite Hd.
  replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra].
  unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp.
  rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra].
  apply (Rmult_le_reg_r (1 + d)); [lra|].
  rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra].
  apply (Rle_trans _ _ _ Bd).
  unfold Rdiv; apply Rmult_le_compat_l; [now apply u_ro_pos|].
  apply (Rle_trans _ (1 - u_ro / (1 + u_ro))); [right; field|]; lra. }
now exists d'; split; [|unfold d'; field].
Qed.

Theorem relative_error_N_FLX_round_ex :
  forall x,
  exists eps,
  (Rabs eps <= u_ro)%R /\
  x = (round beta (FLX_exp prec) (Znearest choice) x * (1 + eps))%R.
Proof.
intro x; apply relative_error_N_round_ex_derive, relative_error_N_FLX'_ex.
Qed.

Theorem relative_error_N_FLX_round :
  forall x,
  (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs(round beta (FLX_exp prec) (Znearest choice) x))%R.
Proof.
intro x.
apply relative_error_le_conversion_round_inv, relative_error_N_FLX_round_ex.
Qed.

End Fprop_relative_FLX.

Section Fprop_relative_FLT.

Variable emin prec : Z.
Variable Hp : Z.lt 0 prec.

Lemma relative_error_FLT_aux :
  forall k, (emin + prec - 1 < k)%Z -> (prec <= k - FLT_exp emin prec k)%Z.
Proof.
intros k Hk.
unfold FLT_exp.
generalize (Zmax_spec (k - prec) emin).
lia.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error_FLT :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_FLT_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x Zx.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_lt_0_compat.
apply bpow_gt_0.
now apply Rabs_pos_lt.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
now apply relative_error_FLT.
Qed.

Theorem relative_error_FLT_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_FLT_F2R_emin.
Qed.

(** 1+#ε# property in any rounding in FLT *)
Theorem relative_error_FLT_ex :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
intros _; now apply relative_error_FLT.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N_FLT :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_N with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

(** 1+#ε# property in rounding to nearest in FLT *)
Theorem relative_error_N_FLT_ex :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_FLT.
Qed.

Theorem relative_error_N_FLT_round :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_N_round with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_N_FLT_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
apply Rabs_pos.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
now apply relative_error_N_FLT.
Qed.

Theorem relative_error_N_FLT_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_le_conversion...
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
now apply relative_error_N_FLT_F2R_emin.
Qed.

Theorem relative_error_N_FLT_round_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros m x.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
apply Rabs_pos.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
apply relative_error_N_round with (emin := (emin + prec - 1)%Z)...
apply relative_error_FLT_aux.
Qed.

Lemma error_N_FLT_aux :
  forall x,
  (0 < x)%R ->
  exists eps, exists  eta,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\
  (Rabs eta <= /2 * bpow (emin))%R      /\
  (eps*eta=0)%R /\
  round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps) + eta)%R.
Proof.
intros x Hx2.
case (Rle_or_lt (bpow (emin+prec)) x); intros Hx.
(* *)
destruct relative_error_N_ex with (FLT_exp emin prec) (emin+prec)%Z prec choice x
  as (eps,(Heps1,Heps2)).
now apply FLT_exp_valid.
intros; unfold FLT_exp.
lia.
rewrite Rabs_right;[assumption|apply Rle_ge; now left].
exists eps; exists 0%R.
split;[assumption|split].
rewrite Rabs_R0; apply Rmult_le_pos.
apply Rlt_le, pos_half_prf.
apply bpow_ge_0.
split;[apply Rmult_0_r|idtac].
now rewrite Rplus_0_r.
(* *)
exists 0%R; exists (round beta (FLT_exp emin prec) (Znearest choice) x - x)%R.
split.
rewrite Rabs_R0; apply Rmult_le_pos.
apply Rlt_le, pos_half_prf.
apply bpow_ge_0.
split.
apply Rle_trans with (/2*ulp beta (FLT_exp emin prec) x)%R.
apply error_le_half_ulp.
now apply FLT_exp_valid.
apply Rmult_le_compat_l.
apply Rlt_le, pos_half_prf.
rewrite ulp_neq_0.
2: now apply Rgt_not_eq.
apply bpow_le.
unfold FLT_exp, cexp.
rewrite Zmax_right.
lia.
destruct (mag beta x) as (e,He); simpl.
assert (e-1 < emin+prec)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2:=Hx).
rewrite <- (Rabs_pos_eq x) by now apply Rlt_le.
now apply He, Rgt_not_eq.
lia.
split ; ring.
Qed.

Theorem relative_error_N_FLT'_ex :
  forall x,
  exists eps eta : R,
  (Rabs eps <= u_ro prec / (1 + u_ro prec))%R /\
  (Rabs eta <= /2 * bpow emin)%R /\
  (eps * eta = 0)%R /\
  round beta (FLT_exp emin prec) (Znearest choice) x
  = (x * (1 + eps) + eta)%R.
Proof.
intro x.
set (rx := round _ _ _ x).
assert (Pb := u_rod1pu_ro_pos prec).
destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs x)) as [MX|Mx].
{ destruct (relative_error_N_FLX'_ex prec Hp choice x) as (d, (Bd, Hd)).
  exists d, 0%R; split; [exact Bd|]; split.
  { rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]. }
  rewrite Rplus_0_r, Rmult_0_r; split; [reflexivity|].
  now rewrite <- Hd; apply round_FLT_FLX. }
assert (H : (Rabs (rx - x) <= /2 * bpow emin)%R).
{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _);
    [now apply FLT_exp_valid|].
  rewrite ulp_FLT_small; [now right|now simpl|].
  apply (Rlt_le_trans _ _ _ Mx), bpow_le; lia. }
exists 0%R, (rx - x)%R; split; [now rewrite Rabs_R0|]; split; [exact H|].
now rewrite Rmult_0_l, Rplus_0_r, Rmult_1_r; split; [|ring].
Qed.

Theorem relative_error_N_FLT'_ex_separate :
  forall x,
  exists x' : R,
  round beta (FLT_exp emin prec) (Znearest choice) x'
  = round beta (FLT_exp emin prec) (Znearest choice) x /\
  (exists eta, Rabs eta <= /2 * bpow emin /\ x' = x + eta)%R /\
  (exists eps, Rabs eps <= u_ro prec / (1 + u_ro prec) /\
               round beta (FLT_exp emin prec) (Znearest choice) x'
               = x' * (1 + eps))%R.
Proof.
intro x.
set (rx := round _ _ _ x).
destruct (relative_error_N_FLT'_ex x) as (d, (e, (Bd, (Be, (Hde0, Hde))))).
destruct (Rlt_or_le (Rabs (d * x)) (Rabs e)) as [HdxLte|HeLedx].
{ exists rx; split; [|split].
  { apply round_generic; [now apply valid_rnd_N|].
    now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. }
  { exists e; split; [exact Be|].
    unfold rx; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze].
    { now rewrite Zd, Rplus_0_r, Rmult_1_r. }
    exfalso; revert HdxLte; rewrite Ze, Rabs_R0; apply Rle_not_lt, Rabs_pos. }
  exists 0%R; split; [now rewrite Rabs_R0; apply u_rod1pu_ro_pos|].
  rewrite Rplus_0_r, Rmult_1_r; apply round_generic; [now apply valid_rnd_N|].
  now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. }
exists x; split; [now simpl|split].
{ exists 0%R; split;
    [rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]|ring]. }
exists d; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze].
{ split; [exact Bd|].
  assert (Ze : e = 0%R); [|now rewrite Ze, Rplus_0_r].
  apply Rabs_eq_R0, Rle_antisym; [|now apply Rabs_pos].
  now revert HeLedx; rewrite Zd, Rmult_0_l, Rabs_R0. }
now rewrite Ze, Rplus_0_r.
Qed.

End Fprop_relative_FLT.

Theorem error_N_FLT :
  forall (emin prec : Z), (0 < prec)%Z ->
  forall (choice : Z -> bool),
  forall (x : R),
  exists eps eta : R,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\
  (Rabs eta <= /2 * bpow emin)%R /\
  (eps * eta = 0)%R /\
  (round beta (FLT_exp emin prec) (Znearest choice) x
   = x * (1 + eps) + eta)%R.
Proof.
intros emin prec Pprec choice x.
destruct (Rtotal_order x 0) as [Nx|[Zx|Px]].
{ assert (Pmx : (0 < - x)%R).
  { now rewrite <- Ropp_0; apply Ropp_lt_contravar. }
  destruct (@error_N_FLT_aux emin prec Pprec
                             (fun t : Z => negb (choice (- (t + 1))%Z))
                             (- x)%R Pmx)
    as (d,(e,(Hd,(He,(Hde,Hr))))).
  exists d; exists (- e)%R; split; [exact Hd|split; [|split]].
  { now rewrite Rabs_Ropp. }
  { now rewrite Ropp_mult_distr_r_reverse, <- Ropp_0; apply f_equal. }
  rewrite <- (Ropp_involutive x), round_N_opp.
  now rewrite Ropp_mult_distr_l_reverse, <- Ropp_plus_distr; apply f_equal. }
{ assert (Ph2 : (0 <= / 2)%R).
  { apply (Rmult_le_reg_l 2 _ _ Rlt_0_2).
    rewrite Rmult_0_r, Rinv_r; [exact Rle_0_1|].
    apply Rgt_not_eq, Rlt_gt, Rlt_0_2. }
  exists 0%R; exists 0%R; rewrite Zx; split; [|split; [|split]].
  { now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. }
  { now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. }
  { now rewrite Rmult_0_l. }
  now rewrite Rmult_0_l, Rplus_0_l, round_0; [|apply valid_rnd_N]. }
now apply error_N_FLT_aux.
Qed.

End Fprop_relative.


Axiom magic : False.

(* Submitted by Dachuan Yu (bug #220) *)
Fixpoint T (n : nat) : Type :=
  match n with
  | O => nat -> Prop
  | S n' => T n'
  end.
Inductive R : forall n : nat, T n -> nat -> Prop :=
  | RO : forall (Psi : T 0) (l : nat), Psi l -> R 0 Psi l
  | RS :
      forall (n : nat) (Psi : T (S n)) (l : nat), R n Psi l -> R (S n) Psi l.
Definition Psi00 (n : nat) : Prop := False.
Definition Psi0 : T 0 := Psi00.
Lemma Inversion_RO : forall l : nat, R 0 Psi0 l -> Psi00 l.
inversion 1.
Abort.

(* Submitted by Pierre Casteran (bug #540) *)

Set Implicit Arguments.
Unset Strict Implicit.
Parameter rule : Set -> Type.

Inductive extension (I : Set) : Type :=
  | NL : extension I
  | add_rule : rule I -> extension I -> extension I.

Inductive in_extension (I : Set) (r : rule I) : extension I -> Type :=
  | in_first : forall e, in_extension r (add_rule r e)
  | in_rest : forall e r', in_extension r e -> in_extension r (add_rule r' e).

Implicit Arguments NL [I].

Inductive super_extension (I : Set) (e : extension I) :
extension I -> Type :=
  | super_NL : super_extension e NL
  | super_add :
      forall r (e' : extension I),
      in_extension r e ->
      super_extension e e' -> super_extension e (add_rule r e').

Lemma super_def :
 forall (I : Set) (e1 e2 : extension I),
 super_extension e2 e1 -> forall ru, in_extension ru e1 -> in_extension ru e2.
Proof.
 simple induction 1.
 inversion 1; auto.
 elim magic.
Qed.

(* Example from Norbert Schirmer on Coq-Club, Sep 2000 *)

Set Strict Implicit.
Unset Implicit Arguments.
Definition Q (n m : nat) (prf : n <= m) := True.
Goal forall (n m : nat) (H : S n <= m), Q (S n) m H = True.
intros.
dependent inversion_clear H.
elim magic.
elim magic.
Qed.

(* Submitted by Boris Yakobowski (bug #529) *)
(* Check that Inversion does not fail due to unnormalized evars *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Import Bvector.

Inductive I : nat -> Set :=
  | C1 : I 1
  | C2 : forall k i : nat, vector (I i) k -> I i.

Inductive SI : forall k : nat, I k -> vector nat k -> nat -> Prop :=
    SC2 :
      forall (k i vf : nat) (v : vector (I i) k) (xi : vector nat i),
      SI (C2 v) xi vf.

Theorem SUnique :
 forall (k : nat) (f : I k) (c : vector nat k) v v',
 SI f c v -> SI f c v' -> v = v'.
Proof.
induction 1.
intros H; inversion H.
Admitted.

(* Used to failed at some time *)

Set Strict Implicit.
Unset Implicit Arguments.
Parameter bar : forall p q : nat, p = q -> Prop.
Inductive foo : nat -> nat -> Prop :=
    C : forall (a b : nat) (Heq : a = b), bar a b Heq -> foo a b.
Lemma depinv : forall a b, foo a b -> True.
intros a b H.
inversion H.
Abort.

(* Check non-regression of bug #1968 *)

Inductive foo2 : option nat -> Prop := Foo : forall t, foo2 (Some t).
Goal forall o, foo2 o -> 0 = 1.
intros.
eapply trans_eq.
inversion H.

(* Check that the part of "injection" that is called by "inversion"
   does the same number of intros as the number of equations
   introduced, even in presence of dependent equalities that
   "injection" renounces to split *)

Fixpoint prodn (n : nat) :=
  match n with
  | O => unit
  | (S m) => prod (prodn m) nat
  end.

Inductive U : forall n : nat, prodn n -> bool -> Prop :=
| U_intro : U 0 tt true.

Lemma foo3 : forall n (t : prodn n), U n t true -> False.
Proof.
(* used to fail because dEqThen thought there were 2 new equations but
   inject_at_positions actually introduced only one; leading then to
   an inconsistent state that disturbed "inversion" *)
intros. inversion H.
Abort.


Require Import Category Strict_eq MLTT2F.Overture MLTT2F.Path_eq MLTT2F.Equivalences MLTT2F.Cylinder MLTT2F.Fibrant_replacement.
Set Universe Polymorphism.

Set Implicit Arguments.
(* g is a retract of f *)
(* f in the middle, g on the side *)
Record Retract {A B} (g : A -> B) {A' B'} (f : A' -> B') :=
  { ret_s : A -> A' ;
    ret_r : A' -> A ;
    ret_s' : B -> B' ;
    ret_r' : B' -> B ;
    ret_sr : ret_r o ret_s ≡≡ idmap ;
    ret_sr' : ret_r' o ret_s' ≡≡ idmap;
    ret_H1 : f o ret_s ≡≡ ret_s' o g ;
    ret_H2 : ret_r' o f ≡≡ g o ret_r }.
Unset Implicit Arguments.

Global Arguments Build_Retract {A B g A' B' f} s r s' r' sr sr' H1 H2 : rename.

Infix "RetractOf" := Retract (at level 30).

Lemma LP_Retract {A A' B' B C C' D D'}
      {f: A -> A'} {g: B' -> B} {f': C -> C'} {g': D' -> D}
      (Hf : f' RetractOf f) (Hg : g' RetractOf g)
  : LP (C:=TYPE) f g -> LP (C:=TYPE) f' g'.
Proof.
  intros H F G H1; cbn in *.
  assert (X: g o (ret_s Hg o F o ret_r Hf) ≡≡ ret_s' Hg o G o ret_r' Hf o f). {
    intro. ref (ret_H1 Hg _ E@ _). apply Eap.
    ref (Eap10 H1 _ E@ _). apply Eap.
    exact (ret_H2 Hf _)^E. }
  specialize (H ((ret_s Hg) o F o (ret_r Hf)) ((ret_s' Hg) o G o (ret_r' Hf)) (eq_funext X)).
  destruct H as [h [H2 H3]]; cbn in *.
  exists ((ret_r Hg) o h o (ret_s' Hf)). split; apply eq_funext; intro x; simpl.
  - transitivity (ret_r Hg (h (f (ret_s Hf x)))).
    repeat apply Eap. exact (ret_H1 Hf _)^E.
    transitivity (ret_r Hg (ret_s Hg (F (ret_r Hf (ret_s Hf x))))).
    apply Eap. apply (Eap10 H2).
    transitivity (F (ret_r Hf (ret_s Hf x))).
    apply (ret_sr Hg). apply Eap. apply (ret_sr Hf).
  - ref ((ret_H2 Hg _)^E E@ _).
    ref (Eap _ (Eap10 H3 _) E@ _).
    ref (ret_sr' Hg _ E@ _).
    apply Eap. exact (ret_sr' Hf _).
Defined.

Definition retract_id {A B} (f: A -> B) : f RetractOf f.
Proof.
  use Build_Retract; intro; cbn; try reflexivity.
Defined.

Record IsFibration {A B} (f : A -> B) := (* F *)
  { fib_A : Type ;
    fib_P : fib_A -> Type ;
    fib_Fib : FibrantF fib_P;
    fib_H : f RetractOf (π1 fib_P) }.

Global Arguments Build_IsFibration {A B f B'} P {FibP} H : rename.

Notation Fib := @IsFibration.

Definition fiber {A B} (f: A -> B) := λ y, ∃ x, repl_f f x = η y.

Let f' {A B} (f: A → B) : A -> ∃ y, fiber f y
  := λ x, (f x ; η x ; 1).

Definition LP_f'_F {A B} (f: A → B)
  : LLP (C:=TYPE) Fib (f' f).
Proof.
  intros A'' B'' g [B' P HP Hg].
  refine (LP_Retract (retract_id _) Hg _).
  intros F G H; cbn in *.
  transparent assert (α: ((∃ y, fiber f y) -> ∃ y, P (G y))). {
    refine (λ y, (y; _)). destruct y as [y [x p]].
    revert x p. rapply @repl_ind. cbn; intros x p.
    pose proof (Etransport P (Eap10 H x) (F x).2); cbn in X.
    refine (repl_J (λ y p, P (G (y; (η x; p)))) p X). }
  transparent assert (β: ((∃ y, P (G y)) -> sigT P)). {
    exact (λ w, (G w.1; w.2)). }
  exists (β o α). split; [|reflexivity].
  apply eq_funext; intro x.
  use eq_sigma; cbn. exact (Eap10 H _)^E.
  now rewrite Etransport_Vp.
Defined.

Definition wfs_AC_F : weak_factorization_system (@LLP TYPE (@IsFibration)) (@IsFibration).
Proof.
  use Build_weak_factorization_system; cbn.
  - intros A B f. exists (∃ y, fiber f y).
    exists (f' f). exists (π1 _).
    split; [reflexivity|]. split.
    + apply LP_f'_F.
    + refine (Build_IsFibration _ (retract_id _)).
  - intros A B f; split; auto.
  - intros A B f; split; intros Hf.
    + intros A' B' g Hg. now apply Hg.
    + assert (LP (C:=TYPE) (f' f) f). {
        apply Hf. apply LP_f'_F. }
      specialize (X idmap (π1 _) E1); cbn in X. destruct X as [g [Hg1 Hg2]].
      refine (Build_IsFibration (fiber f) _).
      refine (Build_Retract (f' f) g idmap idmap _ _ _ _);
        intro; try reflexivity; cbn.
      exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
Defined.

Record AFib A B (f : A -> B) := (* F *)
  { afib_A : Type ;
    afib_P : afib_A -> Type ;
    afib_Fib : FibrantF afib_P ;
    afib_H1 : ∀ y, Contr (afib_P y) ;
    afib_H2 : f RetractOf (π1 afib_P) }.

Global Arguments Build_AFib {A B f B'} P {FibP} HP H : rename.

Definition AFib_Fib {A B} (f: A -> B)
  : AFib _ _ f -> Fib _ _ f.
Proof.
  intros [B' P FibP HP H].
  exact (Build_IsFibration _ H).
Defined.

Section Cylinder.
  Context {X Y} {f: X -> Y}.

  Definition top' : X -> exists y, Cyl (repl_f f) (η y) := λ x, (f x; top (η x)).
  Definition base' : Y -> exists y, Cyl (repl_f f) (η y) := λ y, (y; base (η y)).
  (* Definition cyl_eq' `{Fibrant Y} : ∀ x, base' (f x) = top' x *)
    (* := λ x, path_sigma (Cyl f) 1 (cyl_eq x). *)
End Cylinder.

Definition LP_top'_AF {A B} (f: A → B)
  : LLP (C:=TYPE) AFib (top' (f:=f)).
Proof.
  intros A'' B'' g [B' P FibP HP Hg].
  refine (LP_Retract (retract_id _) Hg _).
  clear g Hg. intros F G H; cbn in *.
  use exist.
  - intro w. exists (G w).
    transparent assert (P': ((exists y, Cyl (repl_f f) y) -> Type)). {
      intro y. ref (_ (repl_sigma (Cyl (repl_f f)) y)).
      use repl_rec. exact (P o G). }
    assert (forall y w, P' (y; w)). {
      assert (FibrantF2 (fun y w => P' (y; w))).
      subst P'; use FibrantF_compose.
      use (Cyl_ind _ (FibP := X)); cbn.
      + use repl_ind; cbn.
        subst P'; use FibrantF_compose.
        intro x. exact ((Eap10 H x) E# (F x).2).
      + use repl_ind; cbn.
        subst P'; use FibrantF_compose.
        intro y. use center. apply HP.
      + unfold P'. use repl_ind; cbn.
        intro. use path_contr.
        apply irr_Contr, HP. }
    exact (X (η w.1) w.2).
  - split; cbn. 2: reflexivity.
    apply eq_funext; intro x. use eq_sigma. exact (Eap10 H x)^E.
    rew Etransport_Vp. reflexivity.
Defined.

Definition wfs_C_AF : weak_factorization_system (@LLP TYPE AFib) AFib.
Proof.
  use Build_weak_factorization_system; cbn.
  - intros A B f. exists (exists y, Cyl (repl_f f) (η y)).
    exists top'. exists (π1 _).
    split; [reflexivity|]. split.
    + apply LP_top'_AF.
    + ref (Build_AFib _ _ (retract_id _)); cbn.
      intro. apply  irr_Contr, Cyl_Contr.
  - intros; split; auto.
  - intros A B f; split; intros Hf.
    + intros A' B' g Hg. now apply Hg.
    + assert (LP (C:=TYPE) (top' (f:=f)) f). {
        apply Hf. apply LP_top'_AF. }
      specialize (X idmap (π1 _) E1); cbn in X. destruct X as [g [Hg1 Hg2]].
      ref (Build_AFib (fun y => Cyl (repl_f f) (η y)) _ _); cbn.
      intro. apply  irr_Contr, Cyl_Contr.
      refine (Build_Retract top' g idmap idmap _ _ _ _);
        intro; try reflexivity; cbn.
      exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
Defined.

Definition weak_eq_retract {A B A' B'}
           (f: A -> B) (f': A' -> B')
           (Hf': f' RetractOf f) (Hf: IsEquiv (repl_f f))
  : IsEquiv (repl_f f').
Proof.
  destruct Hf as [g Hg1 Hg2].
  destruct Hf' as [s r s' r' sr sr' Hf1 Hf2].
  refine (isequiv_adjointify (repl_f r o g o repl_f s') _ _); intro.
  - rew repl_f_compose. rew (eq_funext Hf2)^E.
    rewi repl_f_compose. ref (ap _ (Hg1 _) @ _).
    rew repl_f_compose. rew (eq_funext sr'). apply Eq_to_paths, repl_f_idmap.
  - rew repl_f_compose. rewi (eq_funext Hf1). rewi (repl_f_compose s).
    ref (ap _ (Hg2 _) @ _). rew repl_f_compose.
    rew (eq_funext sr). rew repl_f_idmap. exact 1.
Defined.

Definition two_out_of_three_weak_equiv
  : @two_out_of_three TYPE (λ A B f, IsEquiv (repl_f f)).
Proof.
  intros A B C f g; cbn in *. repeat split; intros H1 H2.
  - rewrite <- (eq_funext (repl_f_compose f g)).
    now apply isequiv_compose.
  - rewrite <- (eq_funext (repl_f_compose f g)) in H2.
    apply (cancelL_isequiv (Hg:=H1) (Hgf:=H2) (repl_f g)).
  - rewrite <- (eq_funext (repl_f_compose f g)) in H1.
    apply (cancelR_isequiv (Hf:=H2) (Hgf:=H1) (repl_f f)).
Defined.

Definition AFib_aux {B} {P: B -> Type} {FibP: FibrantF P} (H: IsEquiv (repl_f (π1 P)))
  : ∀ y, Contr (P y).
Proof.
  destruct H as [g Hg1 Hg2 Hg3]. intro y.
  ref (let f := repl_ind (X:=sigT P) (λ z, repl_rec P (repl_f pr1 z)) pr2 in _).
  use Build_Contr.
  - change (repl_rec P (η y)).
    refine (transport (repl_rec P) (Hg1 (η y)) (f (g (η y)))).
  - intro w.
    specialize (Hg3 (η (y; w))); cbn in Hg3. rew Hg3.
    rew (transport_compose (repl_rec P) (repl_f (π1 (λ x : B, P x))) (Hg2 (η (y; w))) _)^.
    exact (apD f (Hg2 (η (y; w)))).
Defined.

Definition AFib_ok {A B} (f: A -> B)
  : AFib _ _ f  <->  (IsEquiv (repl_f f) × Fib _ _ f).
Proof.
  split; intro H.
  - split.
    + destruct H as [B' P FibP HP Hf].
      eapply weak_eq_retract. exact Hf. clear f Hf.
      use isequiv_adjointify.
      * use repl_rec. intro x. apply η. exists x. apply HP.
      * use repl_ind; cbn. intro; exact 1.
      * use repl_ind; cbn. intros [x w]; cbn.
        rew (contr _ _ w). exact 1.
    + destruct H as [B' P FibP H1 H2]. econstructor. eassumption. exact H2.
  - ref (Build_AFib (fiber f) _ _).
    + pose proof (two_out_of_three_weak_equiv _ _ _ (f' f) pr1); cbn in X.
      destruct X as [_ [_ H2]]. specialize (H2 (fst H)).
      refine (AFib_aux (P:=fiber f) (H2 _)).
      clear H2 H.
      use isequiv_adjointify.
      * use repl_rec. exact (λ w, w.2.1).
      * use repl_ind; cbn. intros [y [x p]]; cbn.
        revert x p. use repl_ind; cbn. intros x p. compute.
        ref (repl_J (λ y p, η (f x; (η x; 1)) = η (y; (η x; p))) _ 1).
      * use repl_ind; cbn. intro; exact 1.
    + assert (LP (C:=TYPE) (f' f) f). {
        apply LP_f'_F. apply H. }
      specialize (X idmap pr1 E1); cbn in X. destruct X as [g [Hg1 Hg2]].
      refine (Build_Retract (f' f) g idmap idmap _ _ _ _);
        intro; try reflexivity; cbn.
      exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
Defined.

Definition LLPAFib_ok {A B} (f: A -> B)
  : LLP (C:=TYPE) Fib f  <->  (IsEquiv (repl_f f) × LLP (C:=TYPE) AFib f).
Proof.
  split.
  - intro H; split.
    + ref (let X := H _ B pr1 _ (f' f) idmap E1 in _).
      ref (Build_IsFibration _ (retract_id _)).
      destruct X as [g [Hg1 Hg2]]; cbn in *.
      use isequiv_adjointify.
      * use repl_rec. exact (λ w, (g w).2.1).
      * use repl_ind; cbn. intro x; pose (g x).2.2. cbn in *.
        rew p. apply Eq_to_paths, Eap. exact (Eap10 Hg2 _).
      * use repl_ind; cbn. intro x. rew (Eap10 Hg1 x).
        exact 1.
    + intros A' B' F Hf. apply H. now apply AFib_Fib.
  - intros [H2 H1] A' B' g Hg.
    ref (LP_Retract (f:=f' f) _ (retract_id _) _).
    +  clear A' B' g Hg.
       assert (X : AFib (∃ (y : B) (x : repl A), repl_f f x = η y) B pr1). {
         destruct H2 as [g Hg1 Hg2 Hg3].
         ref (Build_AFib _ _ (retract_id _)).
         intro y; cbn. exists (g (η y); Hg1 _).
         intros [x p].
         ref (path_sigma _ ((ap g p)^ @ Hg2 _) _).
         rew transport_paths_Fl. rew ap_pp. rew (Hg3 _)^.
         rew ap_V. rew inv_pp. rew inv_V.
         rew (ap_compose g (repl_f f) _)^.
         rew concat_pp_p. ref (moveR_Vp _ _ _ _).
         revert x p. use repl_ind; cbn; intros x p.
         refine (repl_J (fun y p => ap (λ x0, repl_f f (g x0)) p @ Hg1 (η y)
                                 = Hg1 (η (f x)) @ p) p _).
         cbn. exact (concat_1p _ @ (concat_p1 _)^). }
       specialize (H1 (sigT (fiber f)) B pr1 X (f' f) idmap E1); clear X.
       destruct H1 as [Ɣ [H H']]; cbn in *.
       use (Build_Retract idmap idmap Ɣ pr1); intro; try reflexivity.
       exact (Eap10 H' _). exact (Eap10 H^E _).
    + now apply LP_f'_F.
Defined.

Definition fibrant_types_give_fibrations {A: Type} {FibA: Fibrant A}
  : IsFibration (λ _:A, tt).
Proof.
  ref (Build_IsFibration (λ _:unit, A) _).
  ref (Build_Retract (λ x, (tt; x)) (π2 (λ _:unit, A)) idmap idmap _ _ _ _);
    intro; try reflexivity; cbn.
  destruct x as [[] y]; reflexivity.
Defined.

Definition type_model_structure : model_structure TYPE.
Proof.
  rapply Build_model_structure.
  - exact (λ A B f, IsEquiv (repl_f f)).
  - exact Fib.
  - exact (@LLP TYPE AFib).
  - apply two_out_of_three_weak_equiv.
  - eapply wfs_iff_R. apply @AFib_ok.
  (* exact wfs_C_AF. *)
    use Build_weak_factorization_system; cbn.
    + intros A B f. exists (exists y, Cyl (repl_f f) (η y)).
      exists top'. exists (π1 _).
      split; [reflexivity|]. split.
      * apply LP_top'_AF.
      * ref (Build_AFib _ _ (retract_id _)); cbn.
      intro. apply  irr_Contr, Cyl_Contr.
    + intros; split; auto.
    + intros A B f; split; intros Hf.
      * intros A' B' g Hg. now apply Hg.
      * assert (LP (C:=TYPE) (top' (f:=f)) f). {
          apply Hf. apply LP_top'_AF. }
        specialize (X idmap (π1 _) E1); cbn in X. destruct X as [g [Hg1 Hg2]].
        ref (Build_AFib (fun y => Cyl (repl_f f) (η y)) _ _); cbn.
      intro. apply  irr_Contr, Cyl_Contr.
        refine (Build_Retract top' g idmap idmap _ _ _ _);
          intro; try reflexivity; cbn.
        exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
  - eapply wfs_iff_L. apply @LLPAFib_ok. exact wfs_AC_F.
Defined.

Print Assumptions type_model_structure.

(* F are retracts of their π1 : Σ fiber -> B *)
Definition F_caract {A B} {f: A -> B}
  : IsFibration f <-> ∃ (g: sigT (fiber f) -> A), f o g ≡≡ pr1 × g o (f' f) ≡≡ idmap.
Proof.
  split.
  - intros [B' P FibP [s r s' r' rs rs' H1 H2]].
    use exist.
    + intros [y [x p]]. apply r. exists (s' y).
      revert x p. use repl_ind; cbn. intros x p.
      ref (repl_J (λ y _, P (s' y)) p _); cbn.
      ref ((H1 x) E# _). exact (s x).2.
    + split; cbn.
      * intros [y [x p]]; cbn.
        ref ((H2 _)^E E@ _); cbn. apply rs'.
      * intro x. ref (_ E@ rs x).
        apply Eap. use eq_sigma. exact (H1 _)^E.
        apply Etransport_Vp.
  - intros [g [H1 H2]].
    ref (Build_IsFibration (fiber f) _).
    ref (Build_Retract (f' f) g idmap idmap _ _ _ _);
      intro; cbn; try reflexivity.
    apply H2. sym H1.
Defined.

(* AC are retracts of their f' *)
Definition AC_caract {A B} (f: A -> B)
  : LLP (C:=TYPE) Fib f <-> ∃ (g: B -> sigT (fiber f)), g o f ≡≡ f' f × pr1 o g ≡≡ idmap.
Proof.
  split; intro H.
  - specialize (H (sigT (fiber f)) _ pr1 (Build_IsFibration _ (retract_id _))).
    specialize (H (f' f) idmap E1).
    destruct H as [g [H1 H2]]. exists g. split; apply Eap10; assumption.
  - intros X Y g Hg. ref (LP_Retract (f:=f' f) _ (retract_id _) _).
    use (Build_Retract idmap idmap H.1 pr1); try (intro; reflexivity).
    apply H.2. cbn. symmetry. apply H.2.
    now apply LP_f'_F.
Defined.

Record Cofib {A B} (f : A -> B) := (* C *)
  { cofib_A : Type ;
    cofib_B : Type ;
    cofib_k : cofib_A -> cofib_B ;
    cofib_H : f RetractOf (top' (f:=cofib_k)) }.
Arguments Build_Cofib {A B f A' B'} k H : rename.

(* C are injections into cylinders *)
Definition C_caract {A B} (f: A -> B)
  : LLP (C:=TYPE) AFib f <-> Cofib f.
Proof.
  split.
  - intro Hf. use (Build_Cofib f).
    specialize (Hf (exists y, Cyl (repl_f f) (η y)) B pr1).
    specialize (Hf (Build_AFib (fun y => Cyl (repl_f f) (η y))
                               (fun y => irr_Contr (Cyl_Contr (η y)))
                               (retract_id _))).
    specialize (Hf top' idmap E1).
    destruct Hf as [g [Hg1 Hg2]]; cbn in *.
    use (Build_Retract idmap idmap g pr1); intro; try reflexivity.
    exact (Eap10 Hg2 _). exact (Eap10 Hg1^E _).
  - intros [A' B' f' Hf] A'' B'' g Hg.
    use (LP_Retract Hf (retract_id _)).
      now apply LP_top'_AF.
Defined.

(* C are injections in THEIR cylinders *)
Definition C_caract2 {A B} (f: A -> B)
  : LLP (C:=TYPE) AFib f <-> ∃ (g: B -> (exists y, Cyl (repl_f f) (η y))), g o f ≡≡ top' × pr1 o g ≡≡ idmap.
Proof.
  split.
  - intro Hf.
    specialize (Hf (exists y, Cyl (repl_f f) (η y)) B pr1).
    specialize (Hf (Build_AFib (fun y => Cyl (repl_f f) (η y))
                               (fun y => irr_Contr (Cyl_Contr (η y)))
                               (retract_id _))).
    specialize (Hf top' idmap E1).
    destruct Hf as [g [Hg1 Hg2]]; cbn in *.
    exists g; split; now apply Eap10.
  - intros [g [H1 H2]].
    intros A' B' h H.
    ref (LP_Retract (f:=top' (f:=f)) _ (retract_id _) _).
    + use (Build_Retract idmap idmap g pr1); try (intro; reflexivity).
      exact H2. intro; cbn; sym H1.
    + apply LP_top'_AF. assumption.
Defined.

Definition Cofib_W {A B} (f: A -> B)
  : IsEquiv (repl_f (top' (f:=f))) <-> IsEquiv (repl_f f).
Proof.
  assert (H': IsEquiv (repl_f (π1 (fun y => Cyl (repl_f f) (η y))))). {
    use isequiv_adjointify. use repl_f. exact base'.
    intro; cbn. rew repl_f_compose; cbn. rew repl_f_idmap. exact 1.
    use repl_ind; cbn. intros [y w]; cbn.
    transparent assert (P :(forall y, Cyl (repl_f f) y -> Type)). {
      ref (fun y w => _ (repl_sigma   _ (y; w))).
      use repl_rec; cbn. exact (fun w => η (base' w.1) = η w). }
    assert (forall y w, P y w). {
      assert (FibrantF2 P).
      unfold P; use FibrantF_compose.
      use Cyl_ind; cbn.
      + use repl_ind; cbn.
        intro x. unfold base'.
        ref (transport (fun y => _ = η (f x; y)) (cyl_eq (η x)) 1).
      + use repl_ind; cbn.
        intro; exact 1.
      + use repl_ind; cbn.
        intro; exact 1. }
    exact (X (η y) w). }
  split; intro H.
  - pose proof (isequiv_compose H H').
    cbn in X; rewrite (eq_funext (repl_f_compose _ _)) in X.
    exact X.
  - ref (cancelL_isequiv (repl_f (π1 (fun y => Cyl (repl_f f) (η y))))).
    exact H'. cbn.
    rewrite (eq_funext (repl_f_compose
                          top' (π1 (fun y => Cyl (repl_f f) (η y))))).
    exact H.
Defined.

Record ACofib {A B} (f : A -> B) := (* AC *)
  { acofib_A : Type ;
    acofib_B : Type ;
    acofib_k : acofib_A -> acofib_B ;
    acofib_Hk : IsEquiv (repl_f acofib_k) ;
    acofib_H : f RetractOf (top' (f:=acofib_k)) }.

Arguments Build_ACofib {A B f A' B'} k Hk H : rename.

(* AC are injections into cylinders of weak equivalences *)
Definition AC_caract2 {A B} (f: A -> B)
  : LLP (C:=TYPE) Fib f <-> ACofib f.
Proof.
  use transitive_iff. 2: apply LLPAFib_ok. split.
  - intros [Hf H].
    ref (Build_ACofib f Hf _).
    specialize (H (exists y, Cyl (repl_f f) (η y)) B pr1).
    assert (AFib (exists y, Cyl (repl_f f) (η y)) B pr1). {
      ref (Build_AFib _ _ (retract_id _)).
      intro. apply  irr_Contr, Cyl_Contr. }
    specialize (H X top' idmap E1); clear X.
    destruct H as [g [H1 H2]]; cbn in *.
    ref (Build_Retract idmap idmap g pr1 _ _ _ _);
      intro; try reflexivity.
    now apply Eap10. exact (Eap10 H1 _)^E.
  - intros [A' B' k Hk H]; split.
    + ref (weak_eq_retract _ _ H _); clear H.
      revert Hk. apply Cofib_W.
    + apply C_caract. ref (Build_Cofib k H).
Defined.

Definition IsInjEq {A B} (f: A -> B)
  := ∃ (r: B -> repl A) (H1: r o f ≡≡ η) (H2: (repl_f f) o r == η),
  forall x, H2 (f x) ≡ Eq_to_paths (Eap (repl_f f) (H1 x)).

(* AC are injective equivalences *)
Definition AC_caract3 {A B} (f: A -> B)
  : LLP (C:=TYPE) Fib f <-> IsInjEq f.
Proof.
  use transitive_iff.
  2: apply AC_caract. split.
  - intros [g [H1 H2]]. exists (λ y, (g y).2.1).
    use exist. intro x. exact (Eap (λ w, w.2.1) (H1 x)).
    use exist. intro y. pose (g y).2.2. cbn in *.
    ref (concat_pE (g y).2.2 _). exact (Eap η (H2 y)).
    intro x; cbn.
    pose (EapD (λ w: sigT (fiber f), w.2.2) (H1 x)^E); cbn in *.
    rewi e; clear e.
    pose (Etransport_paths_FlFrE (f:=λ w, repl_f f w.2.1) (g:= η o pr1) (H1 x)^E E1);
      cbn in *.
    ref (Eap (λ p, concat_pE p (Eap η (H2 (f x)))) _ E@ _).
    2: exact e; clear e.
    ref (concat_pE_ETP _ _ E@ Eap Eq_to_paths (Eq_UIP _ _)).
  - intros [s [H1 [H2 H3]]].
    use exist. ref (fun y => (y; s y; H2 y)).
    split; cbn.
    intro x. ref (eq_sigma _ E1 _); cbn.
    ref (eq_sigma _ (H1 x) _). rew (H3 x).
    ref (Etransport_paths_FlFrE (H1 x) (Eap (repl_f f) (H1 x)) E@ _).
    ref (Eap Eq_to_paths (Eq_UIP _ E1)).
    reflexivity.
Defined.

Definition AF_caract {A B: Type} (f: A -> B)
  : AFib _ _ f <-> ∃ g : (∃ x, Cyl (repl_f f) (η x)) -> A, g o top' ≡≡ idmap × f o g ≡≡ pr1.
Proof.
  split.
  - intro H.
    pose proof (LP_top'_AF f _ _ f H idmap pr1 E1).
    destruct X as [g [Hg1 Hg2]]; cbn in *.
    exists g. split; ref (Eap10 _); assumption.
  - intros [g [Hg1 Hg2]]. use (Build_AFib (fun y => Cyl (repl_f f) (η y))).
    intro; cbn. apply irr_Contr. apply Cyl_Contr.
    ref (Build_Retract top' g idmap idmap _ _ _ _); cbn; try reflexivity.
    exact Hg1. intro; sym Hg2.
Defined.

Print Assumptions type_model_structure.
Print Assumptions F_caract.
Print Assumptions C_caract2.
Print Assumptions AF_caract.
Print Assumptions AC_caract.
Print Assumptions AC_caract3.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


From Games Require Import
     Utils
     Games.

From Coq Require Import
     List.

Import ListNotations.

Section ITrees.

  (**
     Let's work with inductive trees for now.

   *)

  Inductive itree (E: Type -> Type) (X: Type): Type :=
  | Ret (x: X)
  | Vis: forall {Y: Type}, E Y -> (Y -> itree E X) -> itree E X.

End ITrees.
Arguments Ret [_ _] _.
Arguments Vis [_ _ _] _ _.

Section Games_From_Interface.

  Inductive Event_E {E: Type -> Type}: Type :=
  | Req {Y} (e: E Y)
  | Ans {Y} (e: E Y) (y: Y).

  Notation "'stateE' E" := (list (@Event_E E)) (at level 10).

  Inductive move_from_E (E: Type -> Type): player -> stateE E -> stateE E -> Prop :=
  | MoveReq: forall Y (e: E Y) σ, move_from_E E P1 σ (Req e :: σ)
  | MoveAns: forall Y (e: E Y) σ y, move_from_E E P2 (Req e :: σ) (Ans e y :: Req e :: σ)
  .

  Definition Game_from_E (E: Type -> Type): Game :=
    {|
      state := stateE E;
      initial_state := [];
      move := move_from_E E
    |}.

  (* In order to interpret an itree as a strategy, we want to descend the itree
     following the trace described by the state, and use the head Vis event once
     it's done.
     However the return type of the event makes things messy.
   *)
  Fail
  Fixpoint get_next {E X} (t: itree E X) (σ: stateE E): option (@Event_E E) :=
    match σ with
    | [] =>
      match t with
      | Ret _ => None
      | Vis e _ => Some (Req e)
      end
    | Req _ :: Ans _ y :: σ =>
      match t with
      | Ret _ => None
      | Vis _ k => get_next (k y) σ
      end
    | _ => None
    end.

  Definition strategy_from_itree (E: Type -> Type) (X: Type) (t: itree E X): @strategy (Game_from_E E) P1.
  Abort.

End Games_From_Interface.