(** **********************************************************

Benedikt Ahrens, Chris Kapulkin, Mike Shulman

january 2013

************************************************************)

(** **********************************************************

Contents : Precomposition with a fully faithful and
           essentially surjective functor yields
           an essentially surjective functor

************************************************************)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.MoreFoundations.Univalence.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.

Local Open Scope cat.

Local Notation "FF ^-1" := (fully_faithful_inv_hom FF _ _ ).
Local Notation "F '^-i'" := (iso_from_fully_faithful_reflection F) (at level 20).
Local Notation "G 'O' F" := (functor_compose _ _ _ F G) (at level 25).

Ltac inv_functor HF x y :=
   let H:=fresh in
   set (H:= homotweqinvweq (weq_from_fully_faithful HF x y));
     simpl in H;
     unfold fully_faithful_inv_hom; simpl;
     rewrite H; clear H.

(** * Lengthy preparation for the main result of this file *)

Section precomp_w_ess_surj_ff_is_ess_surj.

(** ** Section variables *)

  Context (A B C: category).
  Hypothesis Ccat : is_univalent C.
  Variable H : functor A B.
  Hypothesis p : essentially_surjective H.
  Hypothesis fH : fully_faithful H.

(**  We prove that precomposition with a [H] yields an essentially surjective functor *)

Section essentially_surjective.

(** ** Specification of preimage [G] of a functor [F] *)

(** Given a functor [F] from [A] to [C], we construct [G] such that
       [F = G O H] *)

Variable F : functor A C.

Section preimage.

(** The type [X b] will be contractible, and [G] is defined as
     the first component of its center. *)

Local Definition X (b : B) := total2 (
 fun ck :
  total2 (λ c : C,
                ∏ a : A,
                     z_iso (H a) b -> z_iso (F a) c) =>
    ∏ t t' : total2 (λ a : A, z_iso (H a) b),
          ∏ f : pr1 t --> pr1 t',
             (#H f · pr2 t' = pr2 t ->
                    #F f · pr2 ck (pr1 t') (pr2 t') = pr2 ck (pr1 t) (pr2 t))).

Local Definition kX {b : B} (t : X b) := (pr2 (pr1 t)).

(** The following is the third component of the center of [X b] *)

Lemma X_aux_type_center_of_contr_proof (b : B) (anot : A) (hnot : z_iso (H anot) b) :
  ∏ (t t' : total2 (λ a :  A, z_iso (H a) b))
    (f : pr1 t --> pr1 t'),
  #H f· pr2 t' = pr2 t ->
  #F f·
  #F (fH^-1 (pr2 t'· inv_from_z_iso hnot)) =
  #F (fH^-1 (pr2 t· inv_from_z_iso hnot)).
Proof.
  intros t t' f.
  destruct t as [a h].
  destruct t' as [a' h'].
  simpl in *.
  intro star.
  rewrite <- functor_comp.
  apply maponpaths.
  apply (invmaponpathsweq
          (weq_from_fully_faithful fH a anot)).
  simpl.
  rewrite functor_comp.
  inv_functor fH a' anot.
  rewrite assoc.
  inv_functor fH a anot.
  rewrite <- star.
  apply idpath.
Qed.

(** The center of [X b] *)

Definition X_aux_type_center_of_contr (b : B)
    (anot : A)(hnot : z_iso (H anot) b) : X b.
Proof.
  set (cnot := F anot).
  set (g := fun (a : A)(h : z_iso (H a) b) =>
              (fH^-i (z_iso_comp h (z_iso_inv_from_z_iso hnot)))).
  set (knot := fun (a : A)(h : z_iso (H a) b) =>
                    functor_on_z_iso F (g a h)).
  simpl in *.
  exists (tpair _ (F anot) knot).
  simpl.
  apply X_aux_type_center_of_contr_proof.
Defined.

(** Any inhabitant of [X b] is equal to the center of [X b]. *)

Lemma X_aux_type_contr_eq (b : B) (anot : A) (hnot : z_iso (H anot) b) :
   ∏ t : X b, t = X_aux_type_center_of_contr b anot hnot.
Proof.
  intro t.
  assert (Hpr1 : pr1 (X_aux_type_center_of_contr b anot hnot) = pr1 t).
  { set (w := isotoid _ Ccat ((pr2 (pr1 t)) anot hnot) :
           pr1 (pr1 (X_aux_type_center_of_contr b anot hnot)) = pr1 (pr1 t)).
    apply (total2_paths_f w).
    simpl.
    destruct t as [[c1 k1] q1].
    simpl in *.
    apply funextsec; intro a.
    apply funextsec; intro h.
    set (gah := fH^-i (z_iso_comp h (z_iso_inv_from_z_iso hnot))).
    set (qhelp := q1 (tpair _ a h)(tpair _ anot hnot) gah).
    simpl in *.

    assert (feedtoqhelp :
             #H (fH^-1 (h· inv_from_z_iso hnot))· hnot = h).
    { inv_functor fH a anot.
      rewrite <- assoc.
      rewrite z_iso_after_z_iso_inv.
      apply id_right.
    }
    assert (quack := qhelp feedtoqhelp).
    simpl in *.
    intermediate_path (z_iso_comp  (functor_on_z_iso F
               (fH^-i (z_iso_comp h (z_iso_inv_from_z_iso hnot)))) (idtoiso w) ).
    { generalize w; intro w0.
      induction w0.
      simpl. apply z_iso_eq. simpl.
      simpl. rewrite id_right.
      apply idpath.
    }
    apply z_iso_eq.
    simpl.
    unfold w.
    rewrite idtoiso_isotoid.
    apply quack.
  }
  apply pathsinv0.
  apply (total2_paths_f Hpr1).
  apply proofirrelevance.
  repeat (apply impred; intro).
  apply C.
Qed.

(** Putting everything together: [X b] is contractible. *)

Definition iscontr_X : ∏ b : B, iscontr (X b).
Proof.
  intro b.
  assert (HH : isaprop (iscontr (X b))).
  apply isapropiscontr.
  apply (p b (tpair (λ x, isaprop x) (iscontr (X b)) HH)).
  intro t.
  exists (X_aux_type_center_of_contr b (pr1 t) (pr2 t)).
  apply (X_aux_type_contr_eq b (pr1 t) (pr2 t)).
Defined.

(** The object part of [G], [Go b], is defined as the first component of
    the center of [X b]. *)

(** *** [G] on objects *)

Definition Go : B -> C :=
   λ b : B, pr1 (pr1 (pr1 (iscontr_X b))).

Local Definition k (b : B) :
     ∏ a : A, z_iso (H a) b -> z_iso (F a) (Go b) :=
              pr2 (pr1 (pr1 (iscontr_X b))).

Local Definition q (b : B) := pr2 (pr1 (iscontr_X b)).

(** Given any inhabitant of [X b], its first component is equal to [Go b]. *)

Definition Xphi (b : B) (t : X b) : pr1 (pr1 t) = Go b.
Proof.
  set (p1 := pr2 (iscontr_X b) t).
  exact (base_paths _ _ (base_paths _ _ p1)).
Defined.

(** Given any inhabitant [t : X b], its second component is equal to [k b],
       modulo transport along [Xphi b t]. *)

Definition Xkphi_transp (b : B) (t : X b) :
     ∏ a : A, ∏ h : z_iso (H a) b,
  transportf _ (Xphi b t) (kX t) a h =  k b a h.
Proof.
  unfold k.
  rewrite <- (fiber_paths (base_paths _ _ (pr2 (iscontr_X b) t))).
  intros ? ?.
  apply maponpaths, idpath.
Qed.

(** Similarly to the lemma before, the second component of [t] is the same
    as [k b], modulo postcomposition with an isomorphism. *)

Definition Xkphi_idtoiso (b : B) (t : X b) :
    ∏ a : A, ∏ h : z_iso (H a) b,
   k b a h · idtoiso (!Xphi b t) = kX t a h.
Proof.
  intros a h.
  rewrite <- (Xkphi_transp _ t).
  generalize (Xphi b t).
  intro i; destruct i.
  apply id_right.
Qed.

(*
Lemma k_transport (b : ob B) (*t : X b*) (c : ob C)
   (p : pr1 (pr1 t) = c) (a : ob A) (h : iso (pr1 H a) b):
transportf (λ c' : ob C, ∏ a : ob A, iso (pr1 H a) b ->
                          iso ((pr1 F) a) c')
   p (k) a h = (k b) b a h · idtoiso p .
*)

(** *** Preparation for [G] on morphisms *)

(** [G f] will be defined as the first component of the center of
     contraction of [Y f]. *)

Local Definition Y {b b' : B} (f : b --> b') :=
  total2 (fun g : Go b --> Go b' =>
      ∏ a : A,
        ∏ h : z_iso (H a) b,
          ∏ a' : A,
            ∏ h' : z_iso (H a') b',
              ∏ l : a --> a',
                #H l · h' = h · f -> #F l · k b' a' h' = k b a h · g).

Lemma Y_inhab_proof (b b' : B) (f : b --> b') (a0 : A) (h0 : z_iso (H a0) b)
    (a0' : A) (h0' : z_iso (H a0') b') :
  ∏ (a : A) (h : z_iso (H a) b) (a' : A) (h' : z_iso (H a') b')
    (l : a --> a'),
  #H l· h' = h· f ->
  #F l· k b' a' h' =
    k b a h· ((inv_from_z_iso (k b a0 h0)·
  #F (fH^-1 ((h0· f)· inv_from_z_iso h0')))· k b' a0' h0').
Proof.
  intros a h a' h' l alpha.
  set (m := fH^-i (z_iso_comp h0 (z_iso_inv_from_z_iso h))).
  set (m' := fH^-i (z_iso_comp h0' (z_iso_inv_from_z_iso h'))).
  assert (sss : z_iso_comp (functor_on_z_iso F m) (k b a h) =
                  k b a0 h0).
  { apply z_iso_eq.
    apply (q b (tpair _ a0 h0) (tpair _ a h) m).
    simpl.
    inv_functor fH a0 a.
    rewrite <- assoc.
    rewrite z_iso_after_z_iso_inv.
    apply id_right.
  }
  assert (ssss : z_iso_comp (functor_on_z_iso F m') (k b' a' h') =
                   k b' a0' h0').
  { apply z_iso_eq.
    apply (q b' (tpair _ a0' h0') (tpair _ a' h') m').
    simpl;
    inv_functor fH a0' a'.
    rewrite <- assoc.
    rewrite z_iso_after_z_iso_inv.
    apply id_right.
  }
  set (hfh := h0 · f · inv_from_z_iso h0').
  set (l0 := fH^-1 hfh).
  set (g0 := inv_from_z_iso (k b a0 h0) · #F l0  · k b' a0' h0').
  assert (sssss : #H (l0 · m') = #H (m · l)).
  { rewrite functor_comp .
    unfold m'. simpl.
    inv_functor fH a0' a'.
    unfold l0.
    inv_functor fH a0 a0'.
    unfold hfh.
    intermediate_path (h0 · f · (inv_from_z_iso h0' · h0') · inv_from_z_iso h').
    { repeat rewrite assoc; apply idpath. }
    rewrite z_iso_after_z_iso_inv, id_right, functor_comp.
    inv_functor fH a0 a.
    repeat rewrite <- assoc.
    apply maponpaths, pathsinv0, z_iso_inv_on_right.
    rewrite assoc.
    apply z_iso_inv_on_left, pathsinv0, alpha.
  }
  assert (star5 : inv_from_z_iso m · l0 = l · inv_from_z_iso m').
  { apply z_iso_inv_on_right.
    rewrite assoc.
    apply z_iso_inv_on_left,
          (invmaponpathsweq (weq_from_fully_faithful fH a0 a' )),
          pathsinv0,
      sssss.
  }
  clear sssss.
  unfold g0.
  assert (sss'' : k b a h · inv_from_z_iso (k b a0 h0) =
                    inv_from_z_iso (functor_on_z_iso F m)).
  { apply pathsinv0, z_iso_inv_on_left, pathsinv0.
    apply z_iso_inv_on_right.
    unfold m; simpl.
    apply pathsinv0, (base_paths _ _ sss).
  }
  repeat rewrite assoc.
  rewrite sss''. clear sss'' sss.
  rewrite <- functor_on_inv_from_z_iso.
  rewrite <- functor_comp.
  rewrite star5; clear star5.
  rewrite functor_comp, functor_on_inv_from_z_iso.
  assert (star4 :
        inv_from_z_iso (functor_on_z_iso F m')· k b' a0' h0'
           = k b' a' h' ).
  { apply z_iso_inv_on_right.
    apply pathsinv0, (base_paths _ _ ssss). }
  rewrite <- assoc.
  rewrite star4.
  apply idpath.
Qed.

(** The center of [Y b b' f]. *)

Definition Y_inhab (b b' : B) (f : b --> b')
      (a0 : A) (h0 : z_iso (H a0) b) (a0' : A) (h0' : z_iso (H a0') b') : Y f.
Proof.
  set (hfh := h0 · f · inv_from_z_iso h0').
  set (l0 := fH^-1 hfh).
  set (g0 := inv_from_z_iso (k b a0 h0) · #F l0  · k b' a0' h0').
  exists g0.
  apply Y_inhab_proof.
Defined.

(** Any inhabitant of [Y b b' f] is equal to the center. *)

Lemma Y_contr_eq (b b' : B) (f : b --> b')
     (a0 : A) (h0 : z_iso (H a0) b)
     (a0' : A) (h0' : z_iso (H a0') b') :
  ∏ t : Y f, t = Y_inhab b b' f a0 h0 a0' h0'.
Proof.
  intro t.
  apply pathsinv0.
  assert (Hpr : pr1 (Y_inhab b b' f a0 h0 a0' h0') = pr1 t).
    destruct t as [g1 r1]; simpl in *.
    rewrite <- assoc.
    apply z_iso_inv_on_right.
    set (hfh := h0 · f · inv_from_z_iso h0').
    set (l0 := fH^-1 hfh).
    apply (r1 a0 h0 a0' h0' l0).
    unfold l0.
    inv_functor fH a0 a0' .
    unfold hfh.
    repeat rewrite <- assoc.
    rewrite z_iso_after_z_iso_inv, id_right.
    apply idpath.
  apply (total2_paths_f Hpr).
  apply proofirrelevance.
  repeat (apply impred; intro).
  apply C.
Qed.

(** The type [Y b b' f] is contractible. *)

Definition Y_iscontr  (b b' : B) (f : b --> b') :
   iscontr (Y f).
Proof.
  assert (HH : isaprop (iscontr (Y f))).
    apply isapropiscontr.
  apply (p b (tpair (λ x, isaprop x) (iscontr (Y f)) HH)).
  intros [a0 h0].
  apply (p b' (tpair (λ x, isaprop x) (iscontr (Y f)) HH)).
  intros [a0' h0'].
  exists (Y_inhab b b' f a0 h0 a0' h0').
  apply Y_contr_eq.
Defined.

(** *** [G] on morphisms *)

(** We now have the data necessary to define the functor [G]. *)

Definition preimage_functor_data : functor_data B C.
Proof.
  exists Go.
  intros b b' f.
  exact (pr1 (pr1 (Y_iscontr b b' f))).
Defined.

Local Notation "'G' f" := (pr1 (pr1 (Y_iscontr _ _ f))) (at level 3).

(** The above data is indeed functorial. *)

Lemma is_functor_preimage_functor_data : is_functor preimage_functor_data.
Proof.
  split.
  - unfold functor_idax. simpl.
    intro b.
    assert (PR2 : ∏ (a : A) (h : z_iso (H a) b) (a' : A)
                    (h' : z_iso (H a') b)
                    (l : a --> a'),
               #H l· h' = h· identity b ->
               #F l· k b a' h' = k b a h· identity (Go b)).
    { intros a h a' h' l LL.
      rewrite id_right.
      apply (q b (tpair _ a h) (tpair _ a' h') l).
      rewrite id_right in LL.
      apply LL.
    }
    set (Gbrtilde :=
           tpair _ (identity (Go b)) PR2 : Y (identity b)).
    set (H' := pr2 (Y_iscontr b b (identity b)) Gbrtilde).
    set (H'' := base_paths _ _ H').
    simpl in H'.
    rewrite <- H'.
    apply idpath.
  - (** composition *)
    intros b b' b'' f f'.
    assert (HHHH : isaprop (pr1 (pr1 (Y_iscontr b b'' (f· f'))) =
                              pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f')))).
    { apply C. }
    apply (p b (tpair (λ x, isaprop x) (pr1 (pr1 (Y_iscontr b b'' (f· f'))) =
          pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f'))) HHHH)).
    intros [a0 h0]; simpl.
    apply (p b' (tpair (λ x, isaprop x) (pr1 (pr1 (Y_iscontr b b'' (f· f'))) =
           pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f'))) HHHH)).
    intros [a0' h0']; simpl.
    apply (p b'' (tpair (λ x, isaprop x) (pr1 (pr1 (Y_iscontr b b'' (f· f'))) =
           pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f'))) HHHH)).
    intros [a0'' h0''].
    simpl; clear HHHH.
    set (l0 := fH^-1 (h0 · f · inv_from_z_iso h0')).
    set (l0' := fH^-1 (h0' · f' · inv_from_z_iso h0'')).
    set (l0'' := fH^-1 (h0 · (f· f') · inv_from_z_iso h0'')).
    assert (L : l0 · l0' = l0'').
    { apply (invmaponpathsweq (weq_from_fully_faithful fH a0 a0'')).
      simpl; rewrite functor_comp.
      unfold l0'.
      inv_functor fH a0' a0''.
      unfold l0.
      inv_functor fH a0 a0'.
      intermediate_path (h0 · f · (inv_from_z_iso h0' · h0') · f' · inv_from_z_iso h0'').
      { repeat rewrite assoc; apply idpath. }
      rewrite z_iso_after_z_iso_inv, id_right.
      unfold l0''.
      inv_functor fH a0 a0''.
      repeat rewrite assoc; apply idpath.
    }
    assert (PR2 : ∏ (a : A) (h : z_iso (H a) b)(a' : A)
          (h' : z_iso (H a') b') (l : a --> a'),
           #H l· h' = h· f ->
           #F l· k b' a' h' =
             k b a h· ((inv_from_z_iso (k b a0 h0)· #F l0)· k b' a0' h0') ).
    { intros a h a' h' l.
      intro alpha.
      set (m := fH^-i (z_iso_comp h0 (z_iso_inv_from_z_iso h))).
      set (m' := fH^-i (z_iso_comp h0' (z_iso_inv_from_z_iso h'))).
      assert (sss : z_iso_comp (functor_on_z_iso F m) (k b a h) =
                      k b a0 h0).
      { apply z_iso_eq; simpl.
        apply (q b (tpair _ a0 h0) (tpair _ a h) m).
        simpl.
        inv_functor fH a0 a.
        rewrite <- assoc.
        rewrite z_iso_after_z_iso_inv.
        apply id_right.
      }
      assert (ssss : z_iso_comp (functor_on_z_iso F m') (k b' a' h') =
                       k b' a0' h0').
      { apply z_iso_eq; simpl.
        apply (q b' (tpair _ a0' h0') (tpair _ a' h') m'); simpl.
        inv_functor fH a0' a'.
        rewrite <- assoc.
        rewrite z_iso_after_z_iso_inv.
        apply id_right.
      }
      assert (sssss : #H (l0 · m') = #H (m · l)).
      { rewrite functor_comp.
        unfold m'; simpl.
        inv_functor fH a0' a'.
        unfold l0.
        inv_functor fH a0 a0'.
        intermediate_path (h0 · f · (inv_from_z_iso h0' · h0') · inv_from_z_iso h').
        { repeat rewrite assoc; apply idpath. }
        rewrite z_iso_after_z_iso_inv, id_right, functor_comp.
        inv_functor fH a0 a.
        repeat rewrite <- assoc.
        apply maponpaths.
        apply pathsinv0.
        apply z_iso_inv_on_right.
        rewrite assoc.
        apply z_iso_inv_on_left.
        apply pathsinv0.
        apply alpha.
      }
      assert (star5 : inv_from_z_iso m · l0 = l · inv_from_z_iso m').
      { apply z_iso_inv_on_right.
        rewrite assoc.
        apply z_iso_inv_on_left.
        apply (invmaponpathsweq (weq_from_fully_faithful fH a0 a' )).
        apply pathsinv0.
        apply sssss.
      }
      clear sssss.
      set (sss':= base_paths _ _ sss); simpl in sss'.
      assert (sss'' : k b a h · inv_from_z_iso (k b a0 h0) =
                        inv_from_z_iso (functor_on_z_iso F m)).
      { apply pathsinv0.
        apply z_iso_inv_on_left.
        apply pathsinv0.
        apply z_iso_inv_on_right.
        unfold m; simpl.
        apply pathsinv0.
        apply sss'.
      }
      repeat rewrite assoc.
      rewrite sss''. clear sss'' sss' sss.
      rewrite <- functor_on_inv_from_z_iso.
      rewrite <- functor_comp.
      rewrite star5, functor_comp, functor_on_inv_from_z_iso.
      clear star5.
      assert (star4 :
               inv_from_z_iso (functor_on_z_iso F m')· k b' a0' h0'
               = k b' a' h' ).
      { apply z_iso_inv_on_right.
        set (ssss' := base_paths _ _ ssss).
        apply pathsinv0.
        simpl in ssss'. simpl.
        apply ssss'; clear ssss'.
      }
      rewrite <- assoc.
      rewrite star4.
      apply idpath.
    }
    assert (HGf : G f = inv_from_z_iso (k b a0 h0) · #F l0 · k b' a0' h0').
    { set (Gbrtilde :=
           tpair _ (inv_from_z_iso (k b a0 h0) · #F l0 · k b' a0' h0') PR2 : Y f).
      set (H' := pr2 (Y_iscontr b b' f) Gbrtilde).
      set (H'' := base_paths _ _ H').
      simpl in H'.
      rewrite <- H'.
      apply idpath.
    }
    clear PR2.
    assert (PR2 : ∏ (a : A) (h : z_iso (H a) b') (a' : A)
            (h' : z_iso (H a') b'') (l : a --> a'),
         #H l· h' = h· f' ->
           #F l· k b'' a' h' =
         k b' a h· ((inv_from_z_iso (k b' a0' h0')· #F l0')· k b'' a0'' h0'')).
    { intros a' h' a'' h'' l'.
      intro alpha.
      set (m := fH^-i (z_iso_comp h0' (z_iso_inv_from_z_iso h'))).
      set (m' := fH^-i (z_iso_comp h0'' (z_iso_inv_from_z_iso h''))).
      assert (sss : z_iso_comp (functor_on_z_iso F m) (k b' a' h') =
                      k b' a0' h0').
      { apply z_iso_eq; simpl.
        apply (q b' (tpair _ a0' h0') (tpair _ a' h') m); simpl.
        inv_functor fH a0' a'.
        rewrite <- assoc.
        rewrite z_iso_after_z_iso_inv.
        apply id_right.
      }
      assert (ssss : z_iso_comp (functor_on_z_iso F m') (k b'' a'' h'') =
                       k b'' a0'' h0'').
      { apply z_iso_eq; simpl.
        apply (q b'' (tpair _ a0'' h0'') (tpair _ a'' h'') m'); simpl.
        inv_functor fH a0'' a''.
        rewrite <- assoc.
        rewrite z_iso_after_z_iso_inv.
        apply id_right.
      }
      assert (sssss : #H (l0' · m') = #H (m · l')).
      { rewrite functor_comp.
        unfold m'. simpl.
        inv_functor fH a0'' a''.
        unfold l0'.
        inv_functor fH a0' a0''.
        intermediate_path (h0' · f' · (inv_from_z_iso h0'' · h0'') · inv_from_z_iso h'').
        { repeat rewrite assoc; apply idpath. }
        rewrite z_iso_after_z_iso_inv, id_right, functor_comp.
        inv_functor fH a0' a'.
        repeat rewrite <- assoc.
        apply maponpaths, pathsinv0, z_iso_inv_on_right.
        rewrite assoc.
        apply z_iso_inv_on_left, pathsinv0, alpha.
      }
      assert (star5 : inv_from_z_iso m · l0' = l' · inv_from_z_iso m').
      { apply z_iso_inv_on_right.
        rewrite assoc.
        apply z_iso_inv_on_left,
          (invmaponpathsweq (weq_from_fully_faithful fH a0' a'' )),
          pathsinv0,
          sssss.
      }
      set (sss':= base_paths _ _ sss); simpl in sss'.
      assert (sss'' : k b' a' h' · inv_from_z_iso (k b' a0' h0') =
                        inv_from_z_iso (functor_on_z_iso F m)).
      { apply pathsinv0, z_iso_inv_on_left, pathsinv0, z_iso_inv_on_right.
        unfold m; simpl;
          apply pathsinv0, sss'.
      }
      repeat rewrite assoc.
      rewrite sss''. clear sss'' sss' sss.
      rewrite <- functor_on_inv_from_z_iso.
      rewrite <- functor_comp.
      rewrite star5. clear star5 sssss.
      rewrite functor_comp, functor_on_inv_from_z_iso.
      assert (star4 :
               inv_from_z_iso (functor_on_z_iso F m')· k b'' a0'' h0''
               = k b'' a'' h'' ).
      { apply z_iso_inv_on_right.
        set (ssss' := base_paths _ _ ssss).
        apply pathsinv0.
        simpl in *; apply ssss'.
      }
      rewrite <- assoc.
      rewrite star4.
      apply idpath.
    }
    assert (HGf' : G f' = inv_from_z_iso (k b' a0' h0') · #F l0' · k b'' a0'' h0'').
    { set (Gbrtilde :=
             tpair _ (inv_from_z_iso (k b' a0' h0') · #F l0' · k b'' a0'' h0'') PR2 :
                     Y f').
      set (H' := pr2 (Y_iscontr b' b'' f') Gbrtilde).
      rewrite <- (base_paths _ _ H').
      apply idpath.
    }
    clear PR2.
    assert (PR2 : ∏ (a : A) (h : z_iso (H a) b) (a' : A)
             (h' : z_iso (H a') b'') (l : a --> a'),
          #H l· h' = h· (f· f') ->
          #F l· k b'' a' h' =
           k b a h· ((inv_from_z_iso (k b a0 h0)· #F l0'')· k b'' a0'' h0'')).
    { intros a h a'' h'' l.
      intro alpha.
      set (m := fH^-i (z_iso_comp h0 (z_iso_inv_from_z_iso h))).
      set (m' := fH^-i (z_iso_comp h0'' (z_iso_inv_from_z_iso h''))).
      assert (sss : z_iso_comp (functor_on_z_iso F m) (k b a h) = k b a0 h0).
      { apply z_iso_eq.
        apply (q b (tpair _ a0 h0) (tpair _ a h) m); simpl.
        inv_functor fH a0 a.
        rewrite <- assoc.
        rewrite z_iso_after_z_iso_inv.
        apply id_right.
      }
      assert (ssss : z_iso_comp (functor_on_z_iso F m') (k b'' a'' h'') =
                       k b'' a0'' h0'').
      { apply z_iso_eq.
        apply (q b'' (tpair _ a0'' h0'') (tpair _ a'' h'') m').
        simpl; inv_functor fH a0'' a''.
        rewrite <- assoc.
        rewrite z_iso_after_z_iso_inv.
        apply id_right.
      }
      assert (sssss : #H (l0'' · m') = #H (m · l)).
      { rewrite functor_comp.
        unfold m'. simpl.
        inv_functor fH a0'' a''.
        unfold l0''.
        inv_functor fH a0 a0''.
        intermediate_path (h0 · (f · f') · (inv_from_z_iso h0'' · h0'') · inv_from_z_iso h'').
        { repeat rewrite assoc; apply idpath. }
        rewrite z_iso_after_z_iso_inv, id_right, functor_comp.
        inv_functor fH a0 a.
        repeat rewrite <- assoc.
        apply maponpaths, pathsinv0, z_iso_inv_on_right.
        repeat rewrite assoc.
        apply z_iso_inv_on_left, pathsinv0.
        repeat rewrite <- assoc.
        apply alpha.
      }
      assert (star5 : inv_from_z_iso m · l0'' = l · inv_from_z_iso m').
      { apply z_iso_inv_on_right.
        rewrite assoc.
        apply z_iso_inv_on_left.
        apply (invmaponpathsweq (weq_from_fully_faithful fH a0 a'' )).
        apply pathsinv0, sssss.
      }
      set (sss':= base_paths _ _ sss); simpl in sss'.
      assert (sss'' : k b a h · inv_from_z_iso (k b a0 h0) =
                        inv_from_z_iso (functor_on_z_iso F m)).
      { apply pathsinv0, z_iso_inv_on_left, pathsinv0, z_iso_inv_on_right.
        unfold m; simpl.
        apply pathsinv0, sss'. }
      repeat rewrite assoc.
      rewrite sss''. clear sss'' sss' sss.
      rewrite <- functor_on_inv_from_z_iso.
      rewrite <- functor_comp.
      rewrite star5. clear star5 sssss.
      rewrite functor_comp, functor_on_inv_from_z_iso.
      assert (star4 :
               inv_from_z_iso (functor_on_z_iso F m')· k b'' a0'' h0''
               = k b'' a'' h'' ).
      { apply z_iso_inv_on_right, pathsinv0, (base_paths _ _ ssss). }
      rewrite <- assoc.
      rewrite star4.
      apply idpath.
    }
    assert (HGff' : G (f · f') =
                      inv_from_z_iso (k b a0 h0) · #F l0'' · k b'' a0'' h0'').
    { set (Gbrtilde :=
           tpair _ (inv_from_z_iso (k b a0 h0) · #F l0'' · k b'' a0'' h0'') PR2 :
               Y (f · f')).
      rewrite <- (pr2 (Y_iscontr b b'' (f · f')) Gbrtilde).
      apply idpath. }
    clear PR2.
    rewrite HGf, HGf'.
    intermediate_path (inv_from_z_iso (k b a0 h0)· #F l0· (k b' a0' h0'·
                       inv_from_z_iso (k b' a0' h0'))· #F l0'· k b'' a0'' h0'').
    { rewrite z_iso_inv_after_z_iso, id_right.
      rewrite HGff'.
      repeat rewrite <- assoc.
      apply maponpaths.
      rewrite <- L.
      rewrite functor_comp.
      repeat rewrite <- assoc.
      apply idpath.
    }
    repeat rewrite <- assoc.
    apply idpath.
Qed.

(** We call the functor [GG] ... *)

Definition GG : [B, C, C] := tpair _ preimage_functor_data
                    is_functor_preimage_functor_data.

(** ** [G] is the preimage of [F] under [ _ O H] *)

(** Given any [a : A], we produce an element in [X (H a)], whose
     first component is [F a].
   This allows to prove [G (H a) = F a]. *)

Lemma qF (a0 : A) :
  ∏ (t t' : total2 (λ a :  A, z_iso (H a) (H a0)))
    (f : pr1 t --> pr1 t'),
  #H f· pr2 t' = pr2 t ->
  #F f· #F (fH^-1 (pr2 t')) =
  #F (fH^-1  (pr2 t)).
Proof.
  simpl.
  intros [a h] [a' h'] f L.
  simpl in L; simpl.
  rewrite <- functor_comp.
  apply maponpaths.
  apply (invmaponpathsweq (weq_from_fully_faithful fH a a0)
                 (f· fH^-1 h') (fH^-1 h)  ).
  inv_functor fH a a0.
  rewrite functor_comp.
  inv_functor fH a' a0.
  apply L.
Qed.

Definition kFa (a0 : A) : ∏ a : A,
  z_iso (H a) (H a0) -> z_iso (F a) (F a0) :=
 fun (a : A) (h : z_iso (H a) (H a0)) =>
   functor_on_z_iso F
                  (iso_from_fully_faithful_reflection fH h).

Definition XtripleF (a0 : A) : X (H a0) :=
   tpair _ (tpair _ (F a0) (kFa a0)) (qF a0).

Lemma phi (a0 : A) : pr1 (pr1 (functor_composite H GG)) a0 = pr1 (pr1 F) a0.
Proof.
  exact (!Xphi _ (XtripleF a0)).
Defined.

Lemma extphi : pr1 (pr1 (functor_composite H GG)) = pr1 (pr1 F).
Proof.
  apply funextsec.
  unfold homot.
  apply phi.
Defined.

(** Now for the functor as a whole. It remains to prove
    equality on morphisms, modulo transport. *)

Lemma is_preimage_for_pre_composition : functor_composite H GG = F.
Proof.
  apply (functor_eq _ _  C (functor_composite H GG) F).
  apply (total2_paths_f extphi).
  apply funextsec; intro a0;
  apply funextsec; intro a0';
  apply funextsec; intro f.
  rewrite transport_of_functor_map_is_pointwise.
  unfold extphi.
  unfold double_transport.
  rewrite toforallpaths_funextsec.
  rewrite <- idtoiso_postcompose.
  rewrite <- idtoiso_precompose.
  rewrite idtoiso_inv.
  rewrite <- assoc.
  assert (PSIf : ∏ (a : A) (h : z_iso (H a) (H a0)) (a' : A)
     (h' : z_iso (H a') (H a0')) (l : a --> a'),
         #H l· h' = h· #H f ->
         #F l· k (H a0') a' h' =
         k (H a0) a h·
         ((idtoiso (phi a0)· #F f)· inv_from_z_iso (idtoiso (phi a0')))).
    { intros a h a' h' l alpha.
      rewrite assoc.
      apply z_iso_inv_on_left.
      unfold phi.
      repeat rewrite assoc.
      rewrite (Xkphi_idtoiso (H a0) (XtripleF a0)).
      repeat rewrite <- assoc.
      rewrite (Xkphi_idtoiso (H a0') (XtripleF a0')).
      simpl.
      assert (HH4 : fH^-1 h · f = l · fH^-1 h').
      { apply (invmaponpathsweq (weq_from_fully_faithful fH a a0')).
        simpl; repeat rewrite functor_comp.
        inv_functor fH a a0.
        inv_functor fH a' a0'.
        apply pathsinv0, alpha.
      }
      intermediate_path (#F (fH^-1 h· f)).
      { rewrite functor_comp.
        apply idpath. }
      rewrite HH4.
      rewrite functor_comp.
      apply idpath.
    }
    set (Ybla := tpair _ (idtoiso (phi a0) · #F f · inv_from_z_iso (idtoiso (phi a0')))
                    PSIf : Y (#H f)).
    set (Ycontr := pr2 (Y_iscontr _ _ (#(pr1 H) f)) Ybla).
    set (Ycontr2 := base_paths _ _ Ycontr); simpl in *.
    change (G (#H f)) with (G (#(pr1 H) f)).
    rewrite <- Ycontr2.
    repeat rewrite assoc.
    rewrite z_iso_after_z_iso_inv, id_left.
    repeat rewrite <- assoc.
    rewrite z_iso_after_z_iso_inv, id_right.
    apply idpath.
Qed.

End preimage.

End essentially_surjective.

(** * Precomposition with an ess. surj. and f. f. functor is ess. surj. *)
(** Abstracting from [F] by closing the previous section,
    we can prove essential surjectivity of [_ O H]. *)

Lemma pre_composition_essentially_surjective :
       essentially_surjective (pre_composition_functor A B C H).
Proof.
  intros F p' f.
  apply f.
  exists (GG F).
  apply idtoiso.
  apply is_preimage_for_pre_composition.
Qed.

End precomp_w_ess_surj_ff_is_ess_surj.


Require Import
  Program QArith ZArith Bignums.BigZ.BigZ Qpossec
  MetricMorphisms Qmetric Qdlog ARArith
  MathClasses.implementations.stdlib_rationals
  MathClasses.implementations.stdlib_binary_integers
  MathClasses.implementations.fast_integers
  MathClasses.implementations.dyadics.

Add Field Q : (dec_fields.stdlib_field_theory Q).

Notation bigD := (Dyadic bigZ).

Print Dyadic.

(* We want to avoid timing the printing mechanism *)

Definition test:bigD->True.
intro x;auto.
Defined.

Definition x:bigD:= (dyadic (10000000%bigZ) (100000%bigZ)).
Definition square:bigD-> bigD:=fun x:bigD => (dy_mult x x) .
Check dy_pow.

Check (Z⁺).
Check NonNeg.
Search NonNeg.
Check ((1 _):(Z⁺)).

(* Time Eval vm_compute in (test (dy_pow x (((40%Z) _)))).*)

Time Eval native_compute in (test (square x)).

Require Import ARbigD.
Time Eval vm_compute in (test (bigD_div (square x) x (10000%Z))).
Require Import ApproximateRationals.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e416m2e208m1_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import include_frm.
Require Import auxdef.
Require Import simulation.

Inductive evtrace:=
| evnil: evtrace
| evabort : evtrace
| evcons: val -> evtrace -> evtrace.

Inductive LETr : lworld -> evtrace -> Prop :=
  | LETr_emp : forall (p:lprog) (cst:clientst) (T:tasks) (t:tid) (S:osstate),
                 LETr  (p, T, cst, S , t) evnil
  | LETr_ne : forall p T T' t t' S S' cst cst' et,
               lpstep  p T cst S t T' cst' S' t' ->
               LETr (p, T', cst', S', t') et ->
               LETr (p, T, cst, S, t) et
  | LETr_e : forall p T T' t t' S S' cst cst' et' ev,
               lpstepev  p T cst S t T' cst' S' t' ev->
               LETr (p, T',  cst',  S',  t') et' ->
               LETr (p, T, cst, S , t) (evcons ev et')
  | LETr_abt : forall (p:lprog) (cst:clientst) (T:tasks) (t:tid) (S:osstate),
                 lpstepabt p T cst S t -> LETr (p, T, cst, S,  t) evabort.

Inductive HETr : hworld -> evtrace -> Prop :=
  | HETr_emp : forall (p:hprog) (cst:clientst) (T:tasks)  (O:osabst),
                 HETr (p, T, cst, O) evnil
  | HETr_ne : forall p T T' O O' cst cst' et,
               hpstep  p T cst O T' cst' O' ->
               HETr (p, T', cst', O') et ->
               HETr (p, T, cst, O) et
  | HETr_e : forall p T T' O O' cst cst' et' ev,
               hpstepev p T cst O T' cst' O' ev->
               HETr (p, T', cst', O') et' ->
               HETr (p, T, cst, O) (evcons ev et')
  | HETr_abt : forall (p:hprog) (cst:clientst) (T:tasks)  (O:osabst),
                 hpstepabt p T cst O -> HETr (p, T, cst, O) evabort.

Inductive ETrRef : lworld-> hworld -> Prop :=
  | etrref_subset : forall lw hw,
                    (forall et, LETr lw et -> HETr hw et) ->
                    ETrRef lw hw.

Notation abtcblsid := abstcblsid.

Definition eqdomTO:= fun (T:tasks) (O:osabst) =>
                       exists tls,
                         get O abtcblsid = Some (abstcblist tls) /\(
                           forall t, (exists a, get tls t = Some a ) ->  (exists C,get T t = Some C)  ).
Definition eqdomto:= fun (T:tasks) (O:osabst) =>
                       exists tls,
                         get O abtcblsid = Some (abstcblist tls) /\(
                           forall t, (exists a, get tls t = Some a ) <->  (exists C,get T t = Some C)  ).

(*
Definition eqdomTCst:= fun (T:tasks) (cst:clientst) =>
                         forall t, (exists C,TasksMod.get T t = Some C) <-> (exists a , EntryMod.get (snd cst) t = Some a ).

Definition eqdomcstO (cst:clientst) O:=
  exists tls,
  OSAbstMod.get O abtcblsid = Some (abstcblist tls) /\
  forall t, (exists x,TcbMod.get tls t = Some x) <->
            (exists a, EntryMod.get (snd cst) t = Some a ).
 *)

Definition InitTasks (T:tasks) (p:progunit) (cst:clientst) (O:osabst) :=
  eqdomto T O /\
  forall t C,TasksMod.get T t = Some C ->
  exists s f d1 d2 t, C = nilcont s /\
                      p f = Some (t, d1, d2, s).

Definition etrace_subset (lw: lworld)(hw: hworld)  := forall E, LETr lw E -> HETr hw E.

Fixpoint GoodStmt (s:stmts) (p:progunit) {struct s}:=
  match s with
    | sskip v  => True
    | sassign e e' => True
    | sif e s1 s2 => GoodStmt s1 p/\ GoodStmt s2 p
    | sifthen e s => GoodStmt s p
    | swhile e s' => GoodStmt s' p
    | sret => True
    | srete e => True
    | scall f el =>  p f = None
    | scalle e f el => p f = None
    | sseq s1 s2 => GoodStmt s1 p /\ GoodStmt s2 p
    | sprint e => True
    | _ => False
  end.

Definition GoodClient (p1 p2 p3:progunit):=
  (forall f a b c s, p1 f = Some (a,b,c,s) -> GoodStmt s p3) /\ (forall f, p1 f <> None -> p2 f = None) /\ forall f, (p2 f <> None -> p1 f = None).

Definition WellClient p1 p2 p3 := GoodClient p1 p2 p3 (*/\ good_ret_pu p1*).

Definition getSG  (Sl:osstate):= fst (fst (fst (fst Sl))).

Definition OSCorrect (Os:oscode) (A:osspec) (init:InitAsrt):=
  forall (t:tid) pc Wl Wh (T:tasks) S cst O,
    OSAbstMod.get O curtid = Some (oscurt t) ->
    InitTasks T pc cst O -> init S O -> (WellClient pc (fst (fst Os)) (snd (fst Os)))-> TasksMod.indom T t ->
    Wl = ((pc, Os), T , cst, S, t) ->
    Wh = ((pc, A), T, cst, O) ->
    etrace_subset Wl Wh.

Lemma Hstepstar_no_ev : forall  hp ht cs os  ht' cs' os' E,
               hpstepstar hp ht cs os ht' cs' os' ->
                 HETr (hp, ht', cs', os')  E ->
                       HETr (hp, ht, cs, os)  E.
Proof.
  introv H1 H2.
  gen H2.
  inductions H1.
  auto.
  constructors.
  eauto.
  applys IHhpstepstar.
  auto.
Qed.

Lemma Hstepstar_with_ev : forall  hp ht cs os ht' cs' os' E ev,
               hpstepevstar hp ht cs os ht' cs' os' ev ->
                 HETr (hp, ht', cs', os')  E ->
                       HETr (hp, ht, cs, os) (evcons ev  E).
Proof.
  introv H1 H2.
  gen H2.
  inductions H1.
  intros.
  eapply Hstepstar_no_ev.
  eauto.
  eapply HETr_e.
  eauto.
  applys Hstepstar_no_ev.
 eauto.
 eauto.
Qed.

Lemma progsim_imply_eref_aux : forall  (E : evtrace) (lp: lprog) (lt : tasks)
 (cs : clientst) (os : osstate) (t: tid), LETr (lp, lt, cs, os, t) E ->
  (forall
 (hp: hprog) (ht: tasks) (bs : osabst) , ProgSim lp lt os  hp ht bs cs t ->
   HETr (hp, ht, cs, bs) E).
Proof.
introv HLe.
inductions HLe.
introv Hsim.
constructors.
introv Hsim.
inverts keep Hsim.
lets Hk : H1 H.
destruct Hk as (Th' & O' &  Hstep & Hpsim).
eapply  Hstepstar_no_ev.
eauto.
eapply IHHLe.
eauto.
eauto.

introv Hsim.
inverts keep Hsim.
lets (Th' & O' & Hstep & Hpsim) : H2 H.
eapply  Hstepstar_with_ev.
eauto.
eapply IHHLe.
eauto.
eauto.
introv Hsim.
inverts keep Hsim.
lets Hk : H3 H.
inverts Hk.
destruct H4 as (T'& cst' & O' & Hp & Ha).
eapply  Hstepstar_no_ev.
eauto.
constructors.
eauto.
Qed.

Definition prog_sim (lw : lworld) (hw:hworld) :=
         match lw,  hw with
          | (P, T, CS, los, t) , (P', T', CS', HOS)
                     => OSAbstMod.get HOS curtid = Some (oscurt t) /\ CS = CS' /\ ProgSim P T los P' T' HOS  CS t
         end.

Ltac deslw lw :=
  let p := fresh "p" in
  let ts := fresh "ts" in
  let cs := fresh "cs" in
  let os := fresh "os" in
  let t := fresh "t" in
  destruct lw as [[[[p ts] cs] os ] t].

Ltac deshw hw :=
  let P := fresh "P" in
  let T := fresh "T" in
  let CS := fresh "CS" in
  let HOS := fresh "OS" in
  let t' := fresh "t'" in
  destruct hw as [[[[P T] CS] HOS ] t'].

Theorem progsim_imply_eref : forall lw hw, prog_sim lw hw ->  etrace_subset lw hw.
Proof.
introv Hpsim.
deslw lw.
deshw hw.
unfolds in Hpsim.
lets (Hp1 & Hp2 & Hp3) : Hpsim.
unfolds.
introv Hle.
simpls.
eapply  progsim_imply_eref_aux; eauto.

rewrite <- Hp2.
eauto.

rewrite <- Hp2.
eauto.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.Rfunctions.
Require BuiltIn.
Require real.Real.
Require real.RealInfix.
Require int.Int.
Require real.PowerInt.

Require Import Interval_tactic.

(* Why3 goal *)
Theorem pow_eps2_max_int : ((Reals.Rfunctions.powerRZ (1%R + ((7 / 1125899906842624)%R + (3 / 9007199254740992)%R)%R)%R 2147483647%Z) <= 2%R)%R.
Strategy 1000 [Rfunctions.powerRZ].
interval with (i_prec 34).
Qed.


(** * LogRel.Introductions.Var : Validity of variables. *)
From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening
  DeclarativeTyping DeclarativeInstance GenericTyping LogicalRelation Validity.
From LogRel.LogicalRelation Require Import Escape Irrelevance Reflexivity Transitivity Universe Weakening Neutral Induction NormalRed.
From LogRel.Substitution Require Import Irrelevance Properties Conversion Reflexivity SingleSubst Escape.

Set Universe Polymorphism.
Set Printing Primitive Projection Parameters.

Section Var.
  Context `{GenericTypingProperties}.

  Lemma var0Valid {Γ l A} (VΓ : [||-v Γ]) (VA : [Γ ||-v<l> A | VΓ]) :
    [Γ,, A ||-v<l> tRel 0 : _ | validSnoc VΓ VA | wk1ValidTy _ VA ].
  Proof.
    constructor; intros; cbn.
    + epose (validHead Vσ); irrelevance.
    + epose (eqHead Vσσ'); irrelevance.
  Qed.

End Var.


From isla Require Import opsem.

Definition a0 : isla_trace :=
  Smt (DeclareConst 37%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 37%Z)) Mk_annot :t:
  Smt (DefineConst 40%Z (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Symbolic 37%Z) Mk_annot; Val (Val_Bits (BV 64%N 0xfffffffffffff000%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R1" [] (RegVal_Base (Val_Symbolic 40%Z)) Mk_annot :t:
  Smt (DefineConst 41%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 37%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 41%Z)) Mk_annot :t:
  tnil
.


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

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

Fixpoint app (l : lst) (m : lst) : lst :=
match l with
  | Nil => m
  | Cons a l1 => Cons a (app l1 m)
end.

Fixpoint rev (l : lst) : lst :=
  match l with
  | Nil => Nil
  | Cons a l1 => app (rev l1) (Cons a Nil)
  end.

Lemma app_nil : forall x : lst, app x Nil = x.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Lemma app_assoc : forall x y z : lst, app x (app y z) = app (app x y) z.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Theorem rev_append: forall x y : lst,
  (eq (rev (app x y)) (app (rev y) (rev x))).
Proof.
  intros.
  induction x.
  - simpl. rewrite app_nil. reflexivity.
  - simpl. rewrite IHx. lfind. Admitted.


(*************************************************************************************

 Lax and oplax slice bicategories

 In this file, we define lax and oplax slice bicategories. When adapting the
 definition of slice categories to bicategories, there are three options for the
 morphisms depending on how the triangle

      c₁ ----------> c₂
      |              |
      |              |
      |              |
      V              V
      a ============ a

 commutes. If it commutes up to an invertible 2-cell, then we call it the slice
 bicategory (defined in Slice.v). If it commutes up to a (not necessarily invertible)
 2-cell, then we call it the lax or oplax slice depending on how the particular 2-cell
 is oriented.

 Contents
 1. Lax slice bicategories
 2. Properties of the lax slice bicategory
 3. Oplax slice bicategories
 4. Properties of the oplax slice bicategory

 *************************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Section LaxSlice.
  Variable (B : bicat)
           (a : B).

  (**
   1. Lax slice bicategories
   *)
  Definition lax_slice_disp_cat_ob_mor
    : disp_cat_ob_mor B.
  Proof.
    use tpair.
    - exact (λ c, c --> a).
    - exact (λ c₁ c₂ t₁ t₂ s, t₁ ==> s · t₂).
  Defined.

  Definition lax_slice_disp_cat_id_comp
    : disp_cat_id_comp B lax_slice_disp_cat_ob_mor.
  Proof.
    use tpair.
    - exact (λ c t, linvunitor _).
    - exact (λ c₁ c₂ c₃ s₁ s₂ t₁ t₂ t₃ α β, α • (s₁ ◃ β) • lassociator _ _ _).
  Defined.

  Definition lax_slice_disp_cat_data
    : disp_cat_data B.
  Proof.
    use tpair.
    - exact lax_slice_disp_cat_ob_mor.
    - exact lax_slice_disp_cat_id_comp.
  Defined.

  Definition lax_slice_disp_prebicat_1_id_comp_cells
    : disp_prebicat_1_id_comp_cells B.
  Proof.
    use tpair.
    - exact lax_slice_disp_cat_data.
    - exact (λ c₁ c₂ s₁ s₂ α t₁ t₂ ss₁ ss₂, ss₁ • (α ▹ t₂) = ss₂).
  Defined.

  Definition lax_slice_disp_prebicat_ops
    : disp_prebicat_ops lax_slice_disp_prebicat_1_id_comp_cells.
  Proof.
    repeat split ; cbn.
    - intros.
      rewrite id2_rwhisker.
      rewrite id2_right.
      apply idpath.
    - intros.
      rewrite !vassocl.
      use vcomp_move_R_pM ; [ is_iso | ] ;cbn.
      rewrite <- vcomp_lunitor.
      rewrite <- lunitor_triangle.
      apply idpath.
    - intros.
      rewrite !vassocl.
      refine (_ @ id2_right _).
      apply maponpaths.
      rewrite runitor_rwhisker.
      rewrite lwhisker_vcomp.
      rewrite linvunitor_lunitor.
      rewrite lwhisker_id2.
      apply idpath.
    - intros.
      rewrite !vassocl.
      use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      use vcomp_move_R_Mp ; [ is_iso | ] ; cbn.
      rewrite <- vcomp_lunitor.
      rewrite !vassocl.
      rewrite <- lunitor_triangle.
      apply idpath.
    - intros.
      rewrite !vassocl.
      use vcomp_move_R_Mp ; [ is_iso | ] ; cbn.
      rewrite !vassocl.
      rewrite runitor_rwhisker.
      rewrite lwhisker_vcomp.
      rewrite linvunitor_lunitor.
      rewrite lwhisker_id2.
      rewrite id2_right.
      apply idpath.
    - intros.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- lassociator_lassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite rwhisker_vcomp.
      rewrite lassociator_rassociator.
      rewrite id2_rwhisker.
      apply id2_right.
    - intros.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      apply lassociator_lassociator.
    - intros ? ? ? ? ? ? ? ? ? ? ? ? α β.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocr.
      rewrite α.
      rewrite β.
      apply idpath.
    - intros ? ? ? ? ? ? ? ? ? ? ? ? ? α.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- rwhisker_lwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite lwhisker_vcomp.
      rewrite α.
      apply idpath.
    - intros ? ? ? ? ? ? ? ? ? ? ? ? ? α.
      rewrite !vassocl.
      rewrite rwhisker_rwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite <- vcomp_whisker.
      rewrite !vassocr.
      rewrite α.
      apply idpath.
  Qed.

  Definition lax_slice_disp_prebicat_data
    : disp_prebicat_data B.
  Proof.
    use tpair.
    - exact lax_slice_disp_prebicat_1_id_comp_cells.
    - exact lax_slice_disp_prebicat_ops.
  Defined.

  Definition lax_slice_disp_prebicat_laws
    : disp_prebicat_laws lax_slice_disp_prebicat_data.
  Proof.
    repeat split ; intro ; intros ; apply B.
  Qed.

  Definition lax_slice_disp_prebicat
    : disp_prebicat B.
  Proof.
    use tpair.
    - exact lax_slice_disp_prebicat_data.
    - exact lax_slice_disp_prebicat_laws.
  Defined.

  Definition lax_slice_disp_bicat
    : disp_bicat B.
  Proof.
    use tpair.
    - exact lax_slice_disp_prebicat.
    - intro ; intros.
      apply isasetaprop.
      apply B.
  Defined.

  (**
   2. Properties of the lax slice bicategory
   *)
  Definition lax_slice_disp_2cells_isaprop
    : disp_2cells_isaprop lax_slice_disp_bicat.
  Proof.
    intro ; intros.
    apply B.
  Qed.

  Definition lax_slice_disp_locally_sym
    : disp_locally_sym lax_slice_disp_bicat.
  Proof.
    intros c₁ c₂ s₁ s₂ α t₁ t₂ φ₁ φ₂ p ; cbn in *.
    use vcomp_move_R_Mp ; [ is_iso | ] ; cbn.
    exact (!p).
  Qed.

  Definition lax_slice_disp_locally_groupoid
    : disp_locally_groupoid lax_slice_disp_bicat.
  Proof.
    use make_disp_locally_groupoid.
    - exact lax_slice_disp_locally_sym.
    - exact lax_slice_disp_2cells_isaprop.
  Defined.

  Definition lax_slice_disp_univalent_2_1
    : disp_univalent_2_1 lax_slice_disp_bicat.
  Proof.
    use fiberwise_local_univalent_is_univalent_2_1.
    intros c₁ c₂ s t₁ t₂ φ₁ φ₂.
    use isweqimplimpl.
    - intros α.
      pose (pr1 α) as p ; cbn in p.
      rewrite id2_rwhisker in p.
      rewrite id2_right in p.
      exact p.
    - apply B.
    - use isaproptotal2.
      + intro.
        apply isaprop_is_disp_invertible_2cell.
      + intros.
        apply B.
  Qed.

  Definition lax_slice_invertible_2cell_is_left_disp_adj_equiv
             {c : B}
             {t₁ t₂ : lax_slice_disp_bicat c}
             (f : t₁ -->[ id₁ _ ] t₂)
             (Hf : is_invertible_2cell f)
    : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity c) f.
  Proof.
    simple refine ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _))).
    - exact (linvunitor _ • Hf^-1 • linvunitor _).
    - abstract
        (cbn ;
         rewrite <- !lwhisker_vcomp ;
         rewrite !vassocl ;
         rewrite !lwhisker_hcomp ;
         rewrite triangle_l_inv ;
         rewrite <- !lwhisker_hcomp, <- rwhisker_hcomp ;
         rewrite lunitor_V_id_is_left_unit_V_id ;
         rewrite !vassocr ;
         apply maponpaths_2 ;
         use vcomp_move_L_Mp ; [ is_iso | ] ; cbn ;
         rewrite lwhisker_hcomp ;
         rewrite <- linvunitor_natural ;
         apply maponpaths ;
         rewrite linvunitor_assoc ;
         rewrite lunitor_V_id_is_left_unit_V_id ;
         rewrite rwhisker_hcomp ;
         rewrite <- triangle_l_inv ;
         rewrite <- lwhisker_hcomp ;
         rewrite !vassocl ;
         rewrite lassociator_rassociator ;
         apply id2_right).
    - abstract
        (cbn ;
         rewrite !vassocl ;
         refine (_ @ id2_right _) ;
         apply maponpaths ;
         do 2 (use vcomp_move_R_pM ; [ is_iso | ]) ; cbn ;
         rewrite id2_right ;
         rewrite <- vcomp_lunitor ;
         rewrite lunitor_triangle ;
         apply idpath).
    - apply lax_slice_disp_2cells_isaprop.
    - apply lax_slice_disp_2cells_isaprop.
    - apply lax_slice_disp_locally_groupoid.
    - apply lax_slice_disp_locally_groupoid.
  Defined.

  Definition lax_slice_invertible_2cell_to_disp_adj_equiv
             {c : B}
             {t₁ t₂ : lax_slice_disp_bicat c}
    : invertible_2cell t₁ t₂
      →
      disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂.
  Proof.
    intros α.
    simple refine (_ ,, ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _)))).
    - exact (α • linvunitor _).
    - exact (α^-1 • linvunitor _).
    - abstract
        (cbn ;
         rewrite linvunitor_natural ;
         rewrite <- lwhisker_hcomp ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite !vassocr ;
         rewrite lwhisker_vcomp ;
         rewrite !vassocr ;
         rewrite vcomp_rinv ;
         rewrite id2_left ;
         rewrite lwhisker_hcomp ;
         rewrite triangle_l_inv ;
         rewrite <- rwhisker_hcomp ;
         apply maponpaths ;
         apply lunitor_V_id_is_left_unit_V_id).
    - abstract
        (cbn ;
         rewrite linvunitor_natural ;
         rewrite <- lwhisker_hcomp ;
         rewrite !vassocl ;
         refine (_ @ id2_right _) ;
         apply maponpaths ;
         rewrite !vassocr ;
         rewrite lwhisker_vcomp ;
         rewrite !vassocr ;
         rewrite vcomp_linv ;
         rewrite id2_left ;
         rewrite lwhisker_hcomp ;
         rewrite triangle_l_inv ;
         rewrite <- rwhisker_hcomp ;
         rewrite rwhisker_vcomp ;
         rewrite lunitor_runitor_identity ;
         rewrite rinvunitor_runitor ;
         apply id2_rwhisker).
    - apply lax_slice_disp_2cells_isaprop.
    - apply lax_slice_disp_2cells_isaprop.
    - apply lax_slice_disp_locally_groupoid.
    - apply lax_slice_disp_locally_groupoid.
  Defined.

  Definition lax_slice_disp_adj_equiv_to_invertible_2cell
             {c : B}
             {t₁ t₂ : lax_slice_disp_bicat c}
    : disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂
      →
      invertible_2cell t₁ t₂.
  Proof.
    intros e.
    use make_invertible_2cell.
    - exact (pr1 e • lunitor _).
    - use make_is_invertible_2cell.
      + exact (pr112 e • lunitor _).
      + abstract
          (pose (pr1 (pr212 e)) as m ;
           cbn in m ;
           rewrite !vassocl in m ;
           rewrite !vassocr ;
           use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           rewrite id2_left ;
           rewrite !vassocl ;
           rewrite <- vcomp_lunitor ;
           rewrite <- lunitor_triangle ;
           rewrite !vassocr ;
           use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           rewrite !vassocl ;
           exact (!m)).
      + abstract
          (pose (pr2 (pr212 e)) as m ;
           cbn in m ;
           rewrite !vassocr ;
           use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           rewrite id2_left ;
           rewrite !vassocl ;
           rewrite <- vcomp_lunitor ;
           rewrite <- lunitor_triangle ;
           rewrite !vassocr ;
           exact m).
  Defined.

  Definition lax_slice_invertible_2cell_weq_disp_adj_equiv
             (HB_2_1 : is_univalent_2_1 B)
             {c : B}
             (t₁ t₂ : lax_slice_disp_bicat c)
    : invertible_2cell t₁ t₂
      ≃
      disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂.
  Proof.
    use make_weq.
    - exact lax_slice_invertible_2cell_to_disp_adj_equiv.
    - use isweq_iso.
      + exact lax_slice_disp_adj_equiv_to_invertible_2cell.
      + abstract
          (intros α ;
           use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
           cbn ;
           rewrite vassocl ;
           rewrite linvunitor_lunitor ;
           apply id2_right).
      + abstract
          (intros α ;
           use subtypePath ;
           [ intro ;
             use isaprop_disp_left_adjoint_equivalence ;
             [ exact HB_2_1
             |  apply lax_slice_disp_univalent_2_1 ]
           | ] ;
           cbn ;
           rewrite vassocl ;
           rewrite lunitor_linvunitor ;
           apply id2_right).
  Defined.

  Definition lax_slice_disp_univalent_2_0
             (HB_2_1 : is_univalent_2_1 B)
    : disp_univalent_2_0 lax_slice_disp_bicat.
  Proof.
    use fiberwise_univalent_2_0_to_disp_univalent_2_0.
    intros c t₁ t₂.
    use weqhomot.
    - exact (lax_slice_invertible_2cell_weq_disp_adj_equiv HB_2_1 t₁ t₂
             ∘ make_weq _ (HB_2_1 _ _ _ _))%weq.
    - abstract
        (intros p ;
         cbn in p ;
         induction p ;
         use subtypePath ;
           [ intro ;
             use isaprop_disp_left_adjoint_equivalence ;
             [ exact HB_2_1
             |  apply lax_slice_disp_univalent_2_1 ]
           | ] ;
           apply id2_left).
  Qed.
End LaxSlice.

Section OplaxSlice.
  Variable (B : bicat)
           (a : B).

  (**
   3. Oplax slice bicategories
   *)
  Definition oplax_slice_disp_cat_ob_mor
    : disp_cat_ob_mor B.
  Proof.
    use tpair.
    - exact (λ c, c --> a).
    - exact (λ c₁ c₂ t₁ t₂ s, s · t₂ ==> t₁).
  Defined.

  Definition oplax_slice_disp_cat_id_comp
    : disp_cat_id_comp B oplax_slice_disp_cat_ob_mor.
  Proof.
    use tpair.
    - exact (λ c t, lunitor _).
    - exact (λ c₁ c₂ c₃ s₁ s₂ t₁ t₂ t₃ α β, rassociator _ _ _ • (s₁ ◃ β) • α).
  Defined.

  Definition oplax_slice_disp_cat_data
    : disp_cat_data B.
  Proof.
    use tpair.
    - exact oplax_slice_disp_cat_ob_mor.
    - exact oplax_slice_disp_cat_id_comp.
  Defined.

  Definition oplax_slice_disp_prebicat_1_id_comp_cells
    : disp_prebicat_1_id_comp_cells B.
  Proof.
    use tpair.
    - exact oplax_slice_disp_cat_data.
    - exact (λ c₁ c₂ s₁ s₂ α t₁ t₂ ss₁ ss₂, (α ▹ t₂) • ss₂ = ss₁).
  Defined.

  Definition oplax_slice_disp_prebicat_ops
    : disp_prebicat_ops oplax_slice_disp_prebicat_1_id_comp_cells.
  Proof.
    repeat split ; cbn.
    - intros.
      rewrite id2_rwhisker.
      rewrite id2_left.
      apply idpath.
    - intros.
      rewrite !vassocl.
      rewrite vcomp_lunitor.
      rewrite !vassocr.
      rewrite <- lunitor_triangle.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      rewrite id2_left.
      apply idpath.
    - intros.
      rewrite !vassocl.
      rewrite <- runitor_rwhisker.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      rewrite id2_left.
      apply idpath.
    - intros.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocl.
      rewrite vcomp_lunitor.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- lunitor_triangle.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      rewrite id2_left.
      apply idpath.
    - intros.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      apply maponpaths_2.
      rewrite lunitor_lwhisker.
      apply idpath.
    - intros.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite rassociator_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite lwhisker_lwhisker_rassociator.
      apply idpath.
    - intros.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite !vassocl.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      rewrite rassociator_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite lwhisker_lwhisker_rassociator.
      apply idpath.
    - intros ? ? ? ? ? ? ? ? ? ? ? ? α β.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocl.
      rewrite β.
      rewrite α.
      apply idpath.
    - intros ? ? ? ? ? ? ? ? ? ? ? ? ? α.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite lwhisker_vcomp.
      apply maponpaths.
      exact α.
    - intros ? ? ? ? ? ? ? ? ? ? ? ? ? α.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      exact α.
  Qed.

  Definition oplax_slice_disp_prebicat_data
    : disp_prebicat_data B.
  Proof.
    use tpair.
    - exact oplax_slice_disp_prebicat_1_id_comp_cells.
    - exact oplax_slice_disp_prebicat_ops.
  Defined.

  Definition oplax_slice_disp_prebicat_laws
    : disp_prebicat_laws oplax_slice_disp_prebicat_data.
  Proof.
    repeat split ; intro ; intros ; apply B.
  Qed.

  Definition oplax_slice_disp_prebicat
    : disp_prebicat B.
  Proof.
    use tpair.
    - exact oplax_slice_disp_prebicat_data.
    - exact oplax_slice_disp_prebicat_laws.
  Defined.

  Definition oplax_slice_disp_bicat
    : disp_bicat B.
  Proof.
    use tpair.
    - exact oplax_slice_disp_prebicat.
    - intro ; intros.
      apply isasetaprop.
      apply B.
  Defined.

  (**
   4. Properties of the oplax slice bicategory
   *)
  Definition oplax_slice_disp_2cells_isaprop
    : disp_2cells_isaprop oplax_slice_disp_bicat.
  Proof.
    intro ; intros.
    apply B.
  Qed.

  Definition oplax_slice_disp_locally_sym
    : disp_locally_sym oplax_slice_disp_bicat.
  Proof.
    intros c₁ c₂ s₁ s₂ α t₁ t₂ φ₁ φ₂ p ; cbn in *.
    use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
    exact (!p).
  Qed.

  Definition oplax_slice_disp_locally_groupoid
    : disp_locally_groupoid oplax_slice_disp_bicat.
  Proof.
    use make_disp_locally_groupoid.
    - exact oplax_slice_disp_locally_sym.
    - exact oplax_slice_disp_2cells_isaprop.
  Defined.

  Definition oplax_slice_disp_univalent_2_1
    : disp_univalent_2_1 oplax_slice_disp_bicat.
  Proof.
    use fiberwise_local_univalent_is_univalent_2_1.
    intros c₁ c₂ s t₁ t₂ φ₁ φ₂.
    use isweqimplimpl.
    - intros α.
      pose (pr1 α) as p ; cbn in p.
      rewrite id2_rwhisker in p.
      rewrite id2_left in p.
      exact (!p).
    - apply B.
    - use isaproptotal2.
      + intro.
        apply isaprop_is_disp_invertible_2cell.
      + intros.
        apply B.
  Qed.

  Definition oplax_slice_invertible_2cell_is_left_disp_adj_equiv
             {c : B}
             {t₁ t₂ : oplax_slice_disp_bicat c}
             (f : t₁ -->[ id₁ _ ] t₂)
             (Hf : is_invertible_2cell f)
    : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity c) f.
  Proof.
    simple refine ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _))).
    - exact (lunitor _ • Hf^-1 • lunitor _).
    - abstract
        (cbn ;
         rewrite !vassocr ;
         rewrite <- linvunitor_assoc ;
         rewrite lwhisker_hcomp ;
         rewrite <- linvunitor_natural ;
         rewrite !vassocl ;
         refine (_ @ id2_right _) ;
         apply maponpaths ;
         rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
         rewrite lunitor_linvunitor ;
         rewrite id2_left ;
         apply vcomp_linv).
    - abstract
        (cbn ;
         rewrite !vassocr ;
         apply maponpaths_2 ;
         rewrite !vassocl ;
         rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
         rewrite vcomp_lunitor ;
         rewrite !vassocl ;
         rewrite vcomp_rinv ;
         rewrite id2_right ;
         rewrite <- lunitor_triangle ;
         rewrite !vassocr ;
         rewrite rassociator_lassociator ;
         rewrite id2_left ;
         apply idpath).
    - apply oplax_slice_disp_2cells_isaprop.
    - apply oplax_slice_disp_2cells_isaprop.
    - apply oplax_slice_disp_locally_groupoid.
    - apply oplax_slice_disp_locally_groupoid.
  Defined.

  Definition oplax_slice_invertible_2cell_to_disp_adj_equiv
             {c : B}
             {t₁ t₂ : oplax_slice_disp_bicat c}
    : invertible_2cell t₁ t₂
      →
      disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂.
  Proof.
    intros α.
    simple refine (_ ,, ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _)))).
    - exact (lunitor _ • α^-1).
    - exact (lunitor _ • α).
    - abstract
        (cbn ;
         rewrite !vassocr ;
         rewrite <- linvunitor_assoc ;
         rewrite lwhisker_hcomp ;
         rewrite <- linvunitor_natural ;
         rewrite !vassocl ;
         refine (_ @ id2_right _) ;
         apply maponpaths ;
         rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
         rewrite linvunitor_lunitor ;
         rewrite id2_left ;
         apply vcomp_rinv).
    - abstract
        (cbn ;
         rewrite <- !lwhisker_vcomp ;
         rewrite !vassocr ;
         rewrite lunitor_lwhisker ;
         rewrite runitor_lunitor_identity ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite !vassocr ;
         rewrite vcomp_lunitor ;
         rewrite !vassocl ;
         rewrite vcomp_linv ;
         rewrite id2_right ;
         apply idpath).
    - apply oplax_slice_disp_2cells_isaprop.
    - apply oplax_slice_disp_2cells_isaprop.
    - apply oplax_slice_disp_locally_groupoid.
    - apply oplax_slice_disp_locally_groupoid.
  Defined.

  Definition oplax_slice_disp_adj_equiv_to_invertible_2cell
             {c : B}
             {t₁ t₂ : oplax_slice_disp_bicat c}
    : disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂
      →
      invertible_2cell t₁ t₂.
  Proof.
    intros e.
    use make_invertible_2cell.
    - exact (linvunitor _ • pr112 e).
    - use make_is_invertible_2cell.
      + exact (linvunitor _ • pr1 e).
      + abstract
          (rewrite !vassocl ;
           use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
           rewrite id2_right ;
           refine (_ @ pr1 (pr212 e)) ;
           cbn ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           rewrite linvunitor_natural ;
           rewrite <- lwhisker_hcomp ;
           apply maponpaths_2 ;
           rewrite linvunitor_assoc ;
           apply idpath).
      + abstract
          (rewrite !vassocl ;
           use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
           rewrite id2_right ;
           rewrite !vassocr ;
           rewrite linvunitor_natural ;
           rewrite <- lwhisker_hcomp ;
           rewrite linvunitor_assoc ;
           rewrite !vassocl ;
           use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
           rewrite !vassocr ;
           exact (!(pr2 (pr212 e)))).
  Defined.

  Definition oplax_slice_invertible_2cell_weq_disp_adj_equiv
             (HB_2_1 : is_univalent_2_1 B)
             {c : B}
             (t₁ t₂ : oplax_slice_disp_bicat c)
    : invertible_2cell t₁ t₂
      ≃
      disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂.
  Proof.
    use make_weq.
    - exact oplax_slice_invertible_2cell_to_disp_adj_equiv.
    - use isweq_iso.
      + exact oplax_slice_disp_adj_equiv_to_invertible_2cell.
      + abstract
          (intros α ;
           use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
           cbn ;
           rewrite !vassocr ;
           rewrite linvunitor_lunitor ;
           apply id2_left).
      + abstract
          (intros α ;
           use subtypePath ;
           [ intro ;
             use isaprop_disp_left_adjoint_equivalence ;
             [ exact HB_2_1
             |  apply oplax_slice_disp_univalent_2_1 ]
           | ] ;
           cbn ;
           rewrite vassocr ;
           rewrite lunitor_linvunitor ;
           apply id2_left).
  Defined.

  Definition oplax_slice_disp_univalent_2_0
             (HB_2_1 : is_univalent_2_1 B)
    : disp_univalent_2_0 oplax_slice_disp_bicat.
  Proof.
    use fiberwise_univalent_2_0_to_disp_univalent_2_0.
    intros c t₁ t₂.
    use weqhomot.
    - exact (oplax_slice_invertible_2cell_weq_disp_adj_equiv HB_2_1 t₁ t₂
             ∘ make_weq _ (HB_2_1 _ _ _ _))%weq.
    - abstract
        (intros p ;
         cbn in p ;
         induction p ;
         use subtypePath ;
           [ intro ;
             use isaprop_disp_left_adjoint_equivalence ;
             [ exact HB_2_1
             |  apply oplax_slice_disp_univalent_2_1 ]
           | ] ;
           apply id2_right).
  Qed.
End OplaxSlice.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sha_sel_con_reduce :
  forall T1 x1 L1 ss1 T1', T1 = (t_sha_sel x1 L1 ss1 T1') ->
                      forall T2 T2' Ts2, T2 = t_con T2' Ts2 ->
                                    subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e382m105_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Rel.Definitions.
Require Import Rel.BasicFacts.
Require Import Util.Subset.
Require Import Lang.BindingsFacts.
Require Import Lang.Static.
Require Import Lang.StaticFacts.
Set Implicit Arguments.

Section section_compat_tm_let.

Context (EV HV V : Set).
Context (Ξ : XEnv EV HV).
Context (Γ : V → ty EV HV ∅).
Context (P : HV → F).
Context (S T : ty EV HV ∅).
Context (𝓔 : eff EV HV ∅).
Context (t₁ t₂ : tm EV HV (inc V) ∅).
Context (s₁ s₂ : tm EV HV V ∅).

Hint Resolve subset_trans postfix_refl postfix_is_subset.

Lemma compat_tm_let n :
n ⊨ ⟦ Ξ P (env_ext Γ S) ⊢ t₁ ≼ˡᵒᵍ t₂ : T # 𝓔 ⟧ →
n ⊨ ⟦ Ξ P Γ ⊢ s₁ ≼ˡᵒᵍ s₂ : S # 𝓔 ⟧ →
n ⊨ ⟦ Ξ P Γ ⊢ (tm_let s₁ t₁) ≼ˡᵒᵍ (tm_let s₂ t₂) : T # 𝓔 ⟧.
Proof.
intros Ht Hs.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hρ ; iintro Hγ.

iespecialize Hs.
repeat (ispecialize Hs ; [ eassumption | ]).
simpl.
generalize Hs.
generalize (subst_tm δ₁ ρ₁ γ₁ s₁), (subst_tm δ₂ ρ₂ γ₂ s₂).
clear Hs s₁ s₂ ; intros s₁ s₂ Hs.
bind_let.
eapply plug0 with (ξ₁ := ξ₁) (ξ₂ := ξ₂) ; [crush|crush| |auto|auto|exact Hs].
iintro ξ₁' ; iintro ξ₂' ; iintro v₁ ; iintro v₂ ;
iintro Hξ₁' ; iintro Hξ₂' ; iintro Hv.
ielim_prop Hξ₁' ; ielim_prop Hξ₂'.

ispecialize Ht ξ₁' ; ispecialize Ht ξ₂' ;
ispecialize Ht δ₁ ; ispecialize Ht δ₂ ; ispecialize Ht δ ;
ispecialize Ht ρ₁ ; ispecialize Ht ρ₂ ; ispecialize Ht ρ ;
ispecialize Ht (env_ext γ₁ v₁) ; ispecialize Ht (env_ext γ₂ v₂).
ielim_prop Hξ ; destruct Hξ as [Hξ₁ Hξ₂].
ielim_prop cl_ρ₁ρ₂.
ispecialize Ht.
{ clear - Hξ₁ Hξ₂ Hξ₁' Hξ₂'.
  iintro_prop ; split ; eauto.
}
ispecialize Ht.
{ clear - cl_δ Hξ₁' Hξ₂'.
  repeat iintro ; iespecialize cl_δ ; ispecialize cl_δ ; [ eassumption | ].
  ielim_prop cl_δ ; destruct cl_δ ; split ; eauto.
}
ispecialize Ht.
{ clear - cl_ρ₁ρ₂ Hξ₁' Hξ₂'.
  iintro_prop ; eapply closed_ρ_monotone ; eauto.
}
ispecialize Ht.
{ clear - Hρ Hξ₁' Hξ₂'.
  eapply 𝑷_monotone ; eauto.
}
ispecialize Ht.
{ clear - Hγ Hv Hξ₁' Hξ₂'.
  iintro x ; destruct x as [ | x ] ; simpl ; [ crush | ].
  iespecialize Hγ.
  eapply 𝓥_monotone ; eauto.
}
clear - Ht.

simpl.
eapply 𝓣_step_r ; [ apply step_let | ].
eapply 𝓣_step_l ; [ apply step_let | ].
iintro_later.
repeat erewrite V_bind_bind_tm.
rewrite HV_bind_tm_eq with
  (f := V_shift_hd ∘ (V_open_hd ∘ ρ₁))
  (g := V_open_hd ∘ ρ₁).
rewrite HV_bind_tm_eq with
  (f := V_shift_hd ∘ (V_open_hd ∘ ρ₂))
  (g := V_open_hd ∘ ρ₂).
exact Ht.

{ intro ; unfold compose ; erewrite V_map_map_hd ; crush. }
{ intro ; unfold compose ; erewrite V_map_map_hd ; crush. }
{ intro x ; destruct x as [ | x ] ; simpl ; [ crush | ].
  erewrite V_bind_map_val, V_bind_val_id, V_map_val_id ; crush.
}
{ intro x ; destruct x as [ | x ] ; simpl ; [ crush | ].
  erewrite V_bind_map_val, V_bind_val_id, V_map_val_id ; crush.
}

Qed.

End section_compat_tm_let.


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 Aprime Bprime L11 L12 L21 L22 : Universe, ((wd_ L11 L12 /\ (wd_ L21 L22 /\ (col_ L11 L12 Aprime /\ (col_ L11 L12 Bprime /\ (col_ L11 L21 L22 /\ col_ L12 L21 L22))))) -> col_ L21 L22 Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Raft.
Require Import RaftRefinementInterface.

Section LeadersHaveLeaderLogsStrong.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition leaders_have_leaderLogs_strong net :=
    forall h,
      type (snd (nwState net h)) = Leader ->
      exists ll es,
        In (currentTerm (snd (nwState net h)), ll) (leaderLogs (fst (nwState net h))) /\
        log (snd (nwState net h)) = es ++ ll /\
        (forall e : entry, In e es -> eTerm e = currentTerm (snd (nwState net h))).

  Class leaders_have_leaderLogs_strong_interface : Prop :=
    {
      leaders_have_leaderLogs_strong_invariant :
        forall (net : network),
          refined_raft_intermediate_reachable net ->
          leaders_have_leaderLogs_strong net
    }.
End LeadersHaveLeaderLogsStrong.


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

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac godel_coding pos vec sss compiler_correction.

From Undecidability.MinskyMachines.MMA
  Require Import mma_defs mma3_mma2_compiler.

From Undecidability.Synthetic
  Require Import Definitions ReducibilityFacts.

Local Notation "e #> x" := (vec_pos e x).

Theorem reduction n : @MMA_HALTING (3+n) ⪯ @MMA_HALTING (2+n).
Proof.
  apply reduces_dependent; exists.
  intros (P,v).
  set (w := 0##gc_enc godel_coding_235 (fst (vec_split _ _ v))##vec_tail (vec_tail (vec_tail v))).
  exists (gc_code (mma3_mma2_compiler n) (1, P) 1, w).
  apply (compiler_t_term_equiv (mma3_mma2_compiler _)); simpl.
  msplit 2; auto.
  intro; now rewrite !vec_pos_tail.
Qed.