(* ------------------------------------------------------------------------- *)
(** Displayed transformation.
    Contents:
      - Definition of displayed transformation.
      - Identity and composition of displayed transformations.                *)
(* ------------------------------------------------------------------------- *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.Initial.
Require Import UniMath.Bicategories.Core.Examples.Final.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Whiskering.
Require Import UniMath.Bicategories.Transformations.Examples.Unitality.
Require Import UniMath.Bicategories.Transformations.Examples.Associativity.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.

Import PseudoFunctor.Notations.

Local Open Scope cat.

(** ** Definition of displayed transformation. *)

Section DispTransformation.

Context {B₁ : bicat} {D₁ : disp_bicat B₁}
        {B₂ : bicat} {D₂ : disp_bicat B₂}
        {F₁ F₂ : psfunctor B₁ B₂}
        (FF₁ : disp_psfunctor D₁ D₂ F₁)
        (FF₂ : disp_psfunctor D₁ D₂ F₂)
        (α : pstrans F₁ F₂).

(** *** Data *)

Definition disp_pstrans_data : UU
  := ∑ αα₁ : ∏ (x : B₁) (xx : D₁ x), FF₁ x xx -->[ α x] FF₂ x xx,
             ∏ (x y : B₁) (f : B₁ ⟦ x, y ⟧) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[ f] yy),
             disp_invertible_2cell (psnaturality_of α f)
                                   (αα₁ x xx;; disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff)
                                   (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff;; αα₁ y yy).

Definition make_disp_pstrans_data
           (αα₁ : ∏ (x : B₁) (xx : D₁ x), FF₁ x xx -->[ α x] FF₂ x xx)
           (αα₂ : ∏ (x y : B₁) (f : B₁ ⟦ x, y ⟧) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[ f] yy),
                  disp_invertible_2cell (psnaturality_of α f)
                                        (αα₁ x xx;; disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff)
                                        (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff;; αα₁ y yy))
  : disp_pstrans_data
  := (αα₁,, αα₂).

Definition disp_pscomponent_of (αα : disp_pstrans_data)
  : ∏ (x : B₁) (xx : D₁ x), FF₁ x xx -->[ α x] FF₂ x xx
  := pr1 αα.

Coercion disp_pscomponent_of : disp_pstrans_data >-> Funclass.

Definition disp_psnaturality_of (αα : disp_pstrans_data)
           {x y : B₁}
           {f : B₁ ⟦ x, y ⟧}
           {xx : D₁ x} {yy : D₁ y}
           (ff : xx -->[ f] yy)
  : disp_invertible_2cell (psnaturality_of α f)
                          (αα x xx;; disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff)
                          (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff;; αα y yy)
  := pr2 αα x y f xx yy ff.

Definition total_pstrans_data (ααdata : disp_pstrans_data)
  : pstrans_data (total_psfunctor _ _ _ FF₁) (total_psfunctor _ _ _ FF₂).
Proof.
  use make_pstrans_data.
  - exact (λ x, (α (pr1 x),, ααdata _ (pr2 x))).
  - exact (λ x y f, iso_in_E_weq _ _ (psnaturality_of α (pr1 f),,
                    disp_psnaturality_of ααdata (pr2 f))).
Defined.

(** *** Properties *)

Section DispPstransLaws.

Variable ααdata : disp_pstrans_data.

Definition disp_psnaturality_natural_law : UU
  := ∏ (x y : B₁) (f g : B₁ ⟦ x, y ⟧)
       (η : f ==> g)
       (xx : D₁ x) (yy : D₁ y)
       (ff : xx -->[ f] yy)
       (gg : xx -->[ g] yy)
       (ηη : ff ==>[ η] gg),
     (ααdata x xx ◃◃ disp_psfunctor_cell D₁ D₂ F₂ FF₂ ηη) •• disp_psnaturality_of ααdata gg
     =
     transportb
       (λ p, _ ==>[p] _)
       (psnaturality_natural α x y f g η)
       (disp_psnaturality_of ααdata ff •• (disp_psfunctor_cell D₁ D₂ F₁ FF₁ ηη ▹▹ ααdata y yy)).

Definition disp_pstrans_id_law : UU
  := ∏ (x : B₁) (xx : D₁ x),
     (ααdata x xx ◃◃ disp_psfunctor_id D₁ D₂ F₂ FF₂ xx)
       •• disp_psnaturality_of ααdata (id_disp xx)
     =
     transportb
       (λ p, _ ==>[p] _)
       (pstrans_id α x)
       ((disp_runitor (ααdata x xx) •• disp_linvunitor (ααdata x xx))
          •• (disp_psfunctor_id D₁ D₂ F₁ FF₁ xx ▹▹ ααdata x xx)).

Definition disp_pstrans_comp_law : UU
  := ∏ (x y z : B₁)
       (f : B₁ ⟦ x, y ⟧) (g : B₁ ⟦ y, z ⟧)
       (xx : D₁ x) (yy : D₁ y) (zz : D₁ z)
       (ff : xx -->[ f] yy) (gg : yy -->[ g] zz),
     (ααdata x xx ◃◃ disp_psfunctor_comp D₁ D₂ F₂ FF₂ ff gg)
       •• disp_psnaturality_of ααdata (ff;; gg) =
     transportb
       (λ p, _ ==>[p] _)
       (pstrans_comp α f g)
       (((((disp_lassociator
              (ααdata x xx)
              (disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff)
              (disp_psfunctor_mor D₁ D₂ F₂ FF₂ gg)
              •• (disp_psnaturality_of ααdata ff ▹▹ disp_psfunctor_mor D₁ D₂ F₂ FF₂ gg))
             •• disp_rassociator (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff) (ααdata y yy)
             (disp_psfunctor_mor D₁ D₂ F₂ FF₂ gg))
            •• (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff ◃◃ disp_psnaturality_of ααdata gg))
           •• disp_lassociator (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff)
           (disp_psfunctor_mor D₁ D₂ F₁ FF₁ gg) (ααdata z zz))
          •• (disp_psfunctor_comp D₁ D₂ F₁ FF₁ ff gg ▹▹ ααdata z zz)).

Definition is_disp_pstrans
  : UU
  := disp_psnaturality_natural_law
       × disp_pstrans_id_law
       × disp_pstrans_comp_law.

End DispPstransLaws.

(** *** Displayed transformation *)

Definition disp_pstrans : UU
  := ∑ αα : disp_pstrans_data, is_disp_pstrans αα.

Coercion disp_pstrans_to_disp_pstrans_data (αα : disp_pstrans)
  : disp_pstrans_data
  := pr1 αα.

Lemma total_pstrans_laws (αα : disp_pstrans)
  : is_pstrans (total_pstrans_data αα).
Proof.
  repeat apply make_dirprod; intro; intros.
  - use total2_paths_b; [apply (psnaturality_natural α) | apply αα].
  - use total2_paths_b; [apply (pstrans_id α) | apply αα].
  - use total2_paths_b. 2: apply αα.
Qed.

Definition total_pstrans (αα : disp_pstrans)
  : pstrans (total_psfunctor _ _ _ FF₁) (total_psfunctor _ _ _ FF₂).
Proof.
  use make_pstrans.
  - exact (total_pstrans_data αα).
  - exact (total_pstrans_laws αα).
Defined.

Definition is_disp_pstrans_from_total (αα : disp_pstrans_data)
  : is_pstrans (total_pstrans_data αα) → is_disp_pstrans αα.
Proof.
  intros Hαα.
  pose (Eα := make_pstrans _ Hαα).
  repeat split.
  - intros x y f g η xx yy ff gg ηη.
    pose (P := !fiber_paths (@psnaturality_natural _ _ _ _ Eα (x,,xx) (y,,yy) (f,,ff)
         (g,,gg) (η,,ηη))).
    symmetry.
    etrans. { apply maponpaths. exact P. }
    unfold transportb.
    rewrite transport_f_f.
    rewrite transportf_set.
    * apply idpath.
    * apply B₂.
  - intros x xx.
    pose (P := !fiber_paths (@pstrans_id _ _ _ _ Eα (x,,xx))).
    symmetry.
    etrans. { apply maponpaths. exact P. }
    unfold transportb.
    rewrite transport_f_f.
    rewrite transportf_set.
    * apply idpath.
    * apply B₂.
  - intros x y z f g xx yy zz ff gg.
    pose (P := !fiber_paths
                (@pstrans_comp _ _ _ _ Eα
                               (x,,xx) (y,,yy) (z,,zz) (f,,ff) (g,,gg)
         )).
    symmetry.
    etrans. { apply maponpaths. exact P. }
    unfold transportb.
    rewrite transport_f_f.
    rewrite transportf_set.
    * apply idpath.
    * apply B₂.
Qed.

End DispTransformation.

(** ** Identity *)

Section DispTrans_identity.

Context {B₁ B₂ : bicat}
        {D₁ : disp_bicat B₁}
        {D₂ : disp_bicat B₂}
        {F : psfunctor B₁ B₂}
        (FF : disp_psfunctor D₁ D₂ F).

Definition disp_id_pstrans_data
  : disp_pstrans_data FF FF (id_pstrans F).
Proof.
  use make_disp_pstrans_data; cbn.
  - exact (λ x xx, id_disp (FF x xx)).
  - intros.
    apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _)
                                 (disp_invertible_2cell_rinvunitor _)).
Defined.

Lemma disp_id_pstrans_laws : is_disp_pstrans _ _ _ disp_id_pstrans_data.
Proof.
  apply is_disp_pstrans_from_total.
  pose (PP := id_pstrans (total_psfunctor _ _ _ FF)).
  pose (PP2 := pstrans_to_is_pstrans PP).
  assert (pr11 PP = total_pstrans_data FF FF (id_pstrans F) disp_id_pstrans_data).
  - use total2_paths_f.
    + apply idpath.
    + apply funextsec. intro x.
      apply funextsec. intro y.
      apply funextsec. intro f.
      use subtypePath.
      { intro. apply isaprop_is_invertible_2cell. }
      apply idpath.
  - exact (transportf _ X PP2).
Qed.

Definition disp_id_pstrans : disp_pstrans FF FF (id_pstrans F)
  := disp_id_pstrans_data,, disp_id_pstrans_laws.

End DispTrans_identity.

(** ** Composition *)

Section DispTrans_comp.

Context {B₁ B₂ : bicat}
        {F₁ : psfunctor B₁ B₂}
        {F₂ : psfunctor B₁ B₂}
        {F₃ : psfunctor B₁ B₂}
        {η₁ : pstrans F₁ F₂}
        {η₂ : pstrans F₂ F₃}
        {D₁ : disp_bicat B₁}
        {D₂ : disp_bicat B₂}
        {FF₁ : disp_psfunctor D₁ D₂ F₁}
        {FF₂ : disp_psfunctor D₁ D₂ F₂}
        {FF₃ : disp_psfunctor D₁ D₂ F₃}
        (ηη₁ : disp_pstrans FF₁ FF₂ η₁)
        (ηη₂ : disp_pstrans FF₂ FF₃ η₂).

Local Notation "αα '••' ββ" := (vcomp_disp_invertible αα ββ).
Local Notation "ff '◃◃' αα" := (disp_invertible_2cell_lwhisker ff αα).
Local Notation "αα '▹▹' ff" := (disp_invertible_2cell_rwhisker ff αα).

Definition disp_comp_pstrans_data : disp_pstrans_data FF₁ FF₃ (comp_pstrans η₁ η₂).
Proof.
  use make_disp_pstrans_data; cbn.
  - exact (λ x xx, comp_disp (ηη₁ x xx) (ηη₂ x xx)).
  - exact (λ x y f xx yy ff,
           (disp_invertible_2cell_rassociator _ _ _)
             •• (_ ◃◃ disp_psnaturality_of _ _ _ ηη₂ ff)
             •• disp_invertible_2cell_lassociator _ _ _
             •• (disp_psnaturality_of _ _ _ ηη₁ ff ▹▹ _)
             •• disp_invertible_2cell_rassociator _ _ _).
Defined.

Lemma disp_comp_pstrans_laws : is_disp_pstrans _ _ _ disp_comp_pstrans_data.
Proof.
  apply is_disp_pstrans_from_total.
  pose (PP := comp_pstrans (total_pstrans _ _ _ ηη₁) (total_pstrans _ _ _ ηη₂)).
  pose (PP2 := pstrans_to_is_pstrans PP).
  assert (pr11 PP = total_pstrans_data _ _ _ disp_comp_pstrans_data).
  - use total2_paths_f.
    + apply idpath.
    + apply funextsec. intro x.
      apply funextsec. intro y.
      apply funextsec. intro f.
      use subtypePath.
      { intro. apply isaprop_is_invertible_2cell. }
      apply idpath.
  - exact (transportf _ X PP2).
Qed.

Definition disp_comp_pstrans : disp_pstrans _ _ (comp_pstrans η₁ η₂)
  := disp_comp_pstrans_data,, disp_comp_pstrans_laws.

End DispTrans_comp.

Definition disp_inv_invertible
           {B : bicat}
           {D : disp_bicat B}
           {x y : B}
           {f g : x --> y}
           {α : invertible_2cell f g}
           {xx : D x} {yy : D y}
           {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy}
           (αα : disp_invertible_2cell α ff gg)
  : disp_invertible_2cell (inv_of_invertible_2cell α) gg ff.
Proof.
  use tpair.
  - exact (disp_inv_cell αα).
  - use tpair.
    + apply αα.
    + split ; cbn.
      * apply disp_vcomp_linv.
      * apply disp_vcomp_rinv.
Defined.

Section DispTrans_lwhisker.

Context {B₁ B₂ B₃ : bicat}
        {F₁ F₂ : psfunctor B₁ B₂}
        {G : psfunctor B₂ B₃}
        {η : pstrans F₁ F₂}
        {D₁ : disp_bicat B₁}
        {D₂ : disp_bicat B₂}
        {D₃ : disp_bicat B₃}
        {FF₁ : disp_psfunctor D₁ D₂ F₁}
        {FF₂ : disp_psfunctor D₁ D₂ F₂}
        (GG : disp_psfunctor D₂ D₃ G)
        (ηη : disp_pstrans FF₁ FF₂ η).

Local Notation "αα '••' ββ" := (vcomp_disp_invertible αα ββ).

Definition disp_left_whisker_data
  : disp_pstrans_data
      (disp_pseudo_comp _ _ _ _ _ FF₁ GG)
      (disp_pseudo_comp _ _ _ _ _ FF₂ GG)
      (G ◅ η).
Proof.
  use make_disp_pstrans_data; cbn.
  - exact (λ x xx, pr121 GG _ _ _ _ _ (pr11 ηη x xx)).
  - exact (λ x y f xx yy ff,
           (disp_psfunctor_comp _ _ _ GG _ _)
             •• disp_psfunctor_invertible_2cell GG (disp_psnaturality_of _ _ _ ηη ff)
             •• (disp_inv_invertible (disp_psfunctor_comp _ _ _ GG _ _))).
Defined.

Lemma disp_left_whisker_laws : is_disp_pstrans _ _ _ disp_left_whisker_data.
Proof.
  apply is_disp_pstrans_from_total.
  pose (PP := (total_psfunctor _ _ _ GG) ◅ total_pstrans _ _ _ ηη).
  pose (PP2 := pstrans_to_is_pstrans PP).
  assert (pstrans_to_pstrans_data PP = total_pstrans_data _ _ _ disp_left_whisker_data).
  - use total2_paths_f.
    + apply idpath.
    + apply funextsec. intro x.
      apply funextsec. intro y.
      apply funextsec. intro f.
      use subtypePath.
      { intro. apply isaprop_is_invertible_2cell. }
      apply idpath.
  - exact (transportf is_pstrans X PP2). (* Slow, dunno why *)
Qed.

Definition disp_left_whisker
  : disp_pstrans
      (disp_pseudo_comp _ _ _ _ _ FF₁ GG)
      (disp_pseudo_comp _ _ _ _ _ FF₂ GG)
      (G ◅ η)
  := disp_left_whisker_data,, disp_left_whisker_laws.

End DispTrans_lwhisker.

Section DispTrans_rwhisker.

Context {B₁ B₂ B₃ : bicat}
        {F : psfunctor B₁ B₂}
        {G₁ G₂ : psfunctor B₂ B₃}
        {η : pstrans G₁ G₂}
        {D₁ : disp_bicat B₁}
        {D₂ : disp_bicat B₂}
        {D₃ : disp_bicat B₃}
        (FF : disp_psfunctor D₁ D₂ F)
        {GG₁ : disp_psfunctor D₂ D₃ G₁}
        {GG₂ : disp_psfunctor D₂ D₃ G₂}
        (ηη : disp_pstrans GG₁ GG₂ η).

Definition disp_right_whisker_data
  : disp_pstrans_data
      (disp_pseudo_comp _ _ _ _ _ FF GG₁)
      (disp_pseudo_comp _ _ _ _ _ FF GG₂)
      (η ▻ F).
Proof.
  use make_disp_pstrans_data; cbn.
  - exact (λ x xx, (pr11 ηη _ (FF _ xx))).
  - exact (λ x y f xx yy ff, disp_psnaturality_of _ _ _ ηη (pr121 FF _ _ _ _ _ ff)).
Defined.

Lemma disp_right_whisker_laws : is_disp_pstrans _ _ _ disp_right_whisker_data.
Proof.
  apply is_disp_pstrans_from_total.
  pose (PP := (total_pstrans _ _ _ ηη) ▻ (total_psfunctor _ _ _ FF)).
  pose (PP2 := pstrans_to_is_pstrans PP).
  assert (X : pstrans_to_pstrans_data PP
              =
              total_pstrans_data _ _ _ disp_right_whisker_data).
  - use total2_paths_f.
    + apply idpath.
    + apply funextsec. intro x.
      apply funextsec. intro y.
      apply funextsec. intro f.
      use subtypePath.
      { intro. apply isaprop_is_invertible_2cell. }
      lazy.
      apply idpath.
  - exact (transportf is_pstrans X PP2). (* Also slow, dunno why *)
Qed.

Definition disp_right_whisker
  : disp_pstrans
      (disp_pseudo_comp _ _ _ _ _ FF GG₁)
      (disp_pseudo_comp _ _ _ _ _ FF GG₂)
      (η ▻ F)
  := disp_right_whisker_data,, disp_right_whisker_laws.

End DispTrans_rwhisker.

Section DispTransUnitality.
Context {B₁ B₂ : bicat}
        {F : psfunctor B₁ B₂}
        {D₁ : disp_bicat B₁}
        {D₂ : disp_bicat B₂}
        (FF : disp_psfunctor D₁ D₂ F).

Definition disp_lunitor_pstrans_data
  : disp_pstrans_data
      (disp_pseudo_comp _ _ _ _ _ FF (disp_pseudo_id D₂))
      FF
      (lunitor_pstrans F).
Proof.
  use make_disp_pstrans_data.
  - exact (λ x xx, id_disp (FF x xx)).
  - cbn.
    refine (λ x y f xx yy ff, _).
    apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _)
                                 (disp_invertible_2cell_rinvunitor _)).
Defined.

Lemma disp_lunitor_pstrans_laws : is_disp_pstrans _ _ _ disp_lunitor_pstrans_data.
Proof.
  apply is_disp_pstrans_from_total.
  pose (PP := lunitor_pstrans (total_psfunctor _ _ _ FF)).
  pose (PP2 := pstrans_to_is_pstrans PP).
  assert (X : pstrans_to_pstrans_data PP
              =
              total_pstrans_data _ _ _ disp_lunitor_pstrans_data).
  - use total2_paths_f.
    + apply idpath.
    + apply funextsec. intro x.
      apply funextsec. intro y.
      apply funextsec. intro f.
      use subtypePath.
      { intro. apply isaprop_is_invertible_2cell. }
      apply idpath.
  - exact (transportf is_pstrans X PP2).
Qed.

Definition disp_lunitor_pstrans
  : disp_pstrans
      (disp_pseudo_comp _ _ _ _ _ FF (disp_pseudo_id D₂))
      FF
      (lunitor_pstrans F)
  := disp_lunitor_pstrans_data,, disp_lunitor_pstrans_laws.

Definition disp_pstrans_linvunitor_data
  : disp_pstrans_data
      FF
      (disp_pseudo_comp _ _ _ _ _ FF (disp_pseudo_id D₂))
      (linvunitor_pstrans F).
Proof.
  use make_disp_pstrans_data.
  - exact (λ x xx, id_disp (FF x xx)).
  - cbn.
    refine (λ x y f xx yy ff, _).
    apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _)
                                 (disp_invertible_2cell_rinvunitor _)).
Defined.

Lemma disp_pstrans_linvunitor_laws : is_disp_pstrans _ _ _ disp_pstrans_linvunitor_data.
Proof.
  apply is_disp_pstrans_from_total.
  pose (PP := linvunitor_pstrans (total_psfunctor _ _ _ FF)).
  pose (PP2 := pstrans_to_is_pstrans PP).
  assert (X : pstrans_to_pstrans_data PP
              =
              total_pstrans_data _ _ _ disp_pstrans_linvunitor_data).
  - use total2_paths_f.
    + apply idpath.
    + apply funextsec. intro x.
      apply funextsec. intro y.
      apply funextsec. intro f.
      use subtypePath.
      { intro. apply isaprop_is_invertible_2cell. }
      apply idpath.
  - exact (transportf is_pstrans X PP2).
Qed.

Definition disp_pstrans_linvunitor
  : disp_pstrans
      FF
      (disp_pseudo_comp _ _ _ _ _ FF (disp_pseudo_id D₂))
      (linvunitor_pstrans F)
  := disp_pstrans_linvunitor_data,, disp_pstrans_linvunitor_laws.

Definition disp_runitor_pstrans_data
  : disp_pstrans_data
      (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_id D₁) FF)
      FF
      (runitor_pstrans F).
Proof.
  use make_disp_pstrans_data.
  - exact (λ x xx, id_disp (FF x xx)).
  - cbn.
    refine (λ x y f xx yy ff, _).
    apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _)
                                 (disp_invertible_2cell_rinvunitor _)).
Defined.

Lemma disp_runitor_pstrans_laws : is_disp_pstrans _ _ _ disp_runitor_pstrans_data.
Proof.
  apply is_disp_pstrans_from_total.
  pose (PP := runitor_pstrans (total_psfunctor _ _ _ FF)).
  pose (PP2 := pstrans_to_is_pstrans PP).
  assert (X : pstrans_to_pstrans_data PP
              =
              total_pstrans_data _ _ _ disp_runitor_pstrans_data).
  - use total2_paths_f.
    + apply idpath.
    + apply funextsec. intro x.
      apply funextsec. intro y.
      apply funextsec. intro f.
      use subtypePath.
      { intro. apply isaprop_is_invertible_2cell. }
      apply idpath.
  - exact (transportf is_pstrans X PP2).
Qed.

Definition disp_runitor_pstrans
  : disp_pstrans
      (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_id D₁) FF)
      FF
      (runitor_pstrans F)
  := disp_runitor_pstrans_data,, disp_runitor_pstrans_laws.

Definition disp_rinvunitor_pstrans_data
  : disp_pstrans_data
      FF
      (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_id D₁) FF)
      (rinvunitor_pstrans F).
Proof.
  use make_disp_pstrans_data.
  - exact (λ x xx, id_disp (FF x xx)).
  - cbn.
    refine (λ x y f xx yy ff, _).
    apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _)
                                 (disp_invertible_2cell_rinvunitor _)).
Defined.

Lemma disp_rinvunitor_pstrans_laws : is_disp_pstrans _ _ _ disp_rinvunitor_pstrans_data.
Proof.
  apply is_disp_pstrans_from_total.
  pose (PP := rinvunitor_pstrans (total_psfunctor _ _ _ FF)).
  pose (PP2 := pstrans_to_is_pstrans PP).
  assert (X : pstrans_to_pstrans_data PP
              =
              total_pstrans_data _ _ _ disp_rinvunitor_pstrans_data).
  - use total2_paths_f.
    + apply idpath.
    + apply funextsec. intro x.
      apply funextsec. intro y.
      apply funextsec. intro f.
      use subtypePath.
      { intro. apply isaprop_is_invertible_2cell. }
      apply idpath.
  - exact (transportf is_pstrans X PP2).
Qed.

Definition disp_rinvunitor_pstrans
  : disp_pstrans
      FF
      (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_id D₁) FF)
      (rinvunitor_pstrans F)
  := disp_rinvunitor_pstrans_data,, disp_rinvunitor_pstrans_laws.
End DispTransUnitality.

Section DispTransAssociativiy.
Context {B₁ B₂ B₃ B₄ : bicat}
        {F₁ : psfunctor B₁ B₂}
        {F₂ : psfunctor B₂ B₃}
        {F₃ : psfunctor B₃ B₄}
        {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂}
        {D₃ : disp_bicat B₃} {D₄ : disp_bicat B₄}
        (FF₁ : disp_psfunctor D₁ D₂ F₁)
        (FF₂ : disp_psfunctor D₂ D₃ F₂)
        (FF₃ : disp_psfunctor D₃ D₄ F₃).

Definition disp_lassociator_pstrans_data
  : disp_pstrans_data
      (disp_pseudo_comp
         _ _ _ _ _
         (disp_pseudo_comp
            _ _ _ _ _
            FF₁
            FF₂)
         FF₃
      )
      (disp_pseudo_comp
         _ _ _ _ _
         FF₁
         (disp_pseudo_comp
            _ _ _ _ _
            FF₂
            FF₃)
      )
      (lassociator_pstrans F₁ F₂ F₃).
Proof.
  use make_disp_pstrans_data.
  - exact (λ x xx, id_disp (_ x xx)).
  - cbn.
    refine (λ x y f xx yy ff, _).
    apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _)
                                 (disp_invertible_2cell_rinvunitor _)).
Defined.

Lemma disp_lassociator_pstrans_laws : is_disp_pstrans _ _ _ disp_lassociator_pstrans_data.
Proof.
  apply is_disp_pstrans_from_total.
  pose (PP := lassociator_pstrans
                (total_psfunctor _ _ _ FF₁)
                (total_psfunctor _ _ _ FF₂)
                (total_psfunctor _ _ _ FF₃)).
  pose (PP2 := pstrans_to_is_pstrans PP).
  assert (X : pstrans_to_pstrans_data PP
              =
              total_pstrans_data _ _ _ disp_lassociator_pstrans_data).
  - use total2_paths_f.
    + apply idpath.
    + apply funextsec. intro x.
      apply funextsec. intro y.
      apply funextsec. intro f.
      use subtypePath.
      { intro. apply isaprop_is_invertible_2cell. }
      apply idpath.
  - exact (transportf is_pstrans X PP2).
Qed.

Definition disp_lassociator_pstrans
  : disp_pstrans
      (disp_pseudo_comp
         _ _ _ _ _
         (disp_pseudo_comp
            _ _ _ _ _
            FF₁
            FF₂)
         FF₃
      )
      (disp_pseudo_comp
         _ _ _ _ _
         FF₁
         (disp_pseudo_comp
            _ _ _ _ _
            FF₂
            FF₃)
      )
      (lassociator_pstrans F₁ F₂ F₃)
  := disp_lassociator_pstrans_data,, disp_lassociator_pstrans_laws.

Definition disp_pstrans_rassociator_data
  : disp_pstrans_data
      (disp_pseudo_comp
         _ _ _ _ _
         FF₁
         (disp_pseudo_comp
            _ _ _ _ _
            FF₂
            FF₃)
      )
      (disp_pseudo_comp
         _ _ _ _ _
         (disp_pseudo_comp
            _ _ _ _ _
            FF₁
            FF₂)
         FF₃
      )
      (rassociator_pstrans F₁ F₂ F₃).
Proof.
  use make_disp_pstrans_data.
  - exact (λ x xx, id_disp (_ x xx)).
  - cbn.
    refine (λ x y f xx yy ff, _).
    apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _)
                                 (disp_invertible_2cell_rinvunitor _)).
Defined.

Lemma disp_pstrans_rassociator_laws : is_disp_pstrans _ _ _ disp_pstrans_rassociator_data.
Proof.
  apply is_disp_pstrans_from_total.
  pose (PP := rassociator_pstrans
                (total_psfunctor _ _ _ FF₁)
                (total_psfunctor _ _ _ FF₂)
                (total_psfunctor _ _ _ FF₃)).
  pose (PP2 := pstrans_to_is_pstrans PP).
  assert (X : pstrans_to_pstrans_data PP
              =
              total_pstrans_data _ _ _ disp_lassociator_pstrans_data).
  - use total2_paths_f.
    + apply idpath.
    + apply funextsec. intro x.
      apply funextsec. intro y.
      apply funextsec. intro f.
      use subtypePath.
      { intro. apply isaprop_is_invertible_2cell. }
      apply idpath.
  - exact (transportf is_pstrans X PP2).
Qed.

Definition disp_pstrans_rassociator
  : disp_pstrans
      (disp_pseudo_comp
         _ _ _ _ _
         FF₁
         (disp_pseudo_comp
            _ _ _ _ _
            FF₂
            FF₃)
      )
      (disp_pseudo_comp
         _ _ _ _ _
         (disp_pseudo_comp
            _ _ _ _ _
            FF₁
            FF₂)
         FF₃
      )
      (rassociator_pstrans F₁ F₂ F₃)
  := disp_pstrans_rassociator_data,, disp_pstrans_rassociator_laws.
End DispTransAssociativiy.


Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.AsciiOpt.
Require Import
        Bedrock.Word
        Coq.Strings.Ascii
        Coq.Strings.String.

Section String.
  (* this has an exact idential structure to _FixList_ *)
  Context {A : Type}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Fixpoint format_string (xs : string) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    match xs with
    | EmptyString => ret (mempty, ce)
    | String x xs' => `(b1, env1) <- format_ascii x ce;
                      `(b2, env2) <- format_string xs' env1;
                      ret (mappend b1 b2, env2)
    end%comp.

    Fixpoint encode_string (xs : string) (ce : CacheFormat) : B * CacheFormat :=
    match xs with
    | EmptyString => (mempty, ce)
    | String x xs' => let (b1, env1) := encode_ascii x ce in
                      let (b2, env2) := encode_string xs' env1 in
                          (mappend b1 b2, env2)
    end.

  Fixpoint decode_string (s : nat) (b : B) (cd : CacheDecode) : option (string * B * CacheDecode) :=
    match s with
    | O => Some (EmptyString, b, cd)
    | S s' => `(x, b1, e1) <- decode_ascii b cd;
              `(xs, b2, e2) <- decode_string s' b1 e1;
              Some (String x xs, b2, e2)
    end.

  Local Opaque format_ascii.
  Local Opaque encode_ascii.

  Theorem String_decode_correct
          {P : CacheDecode -> Prop}
    : forall sz
             (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b))),
      CorrectDecoder
        monoid
        (fun ls => length ls = sz)
        (fun ls => length ls = sz)
        eq
        format_string (decode_string sz) P
        format_string.
  Proof.
    split.
    { intros env env' xenv l l' ext ? Eeq Ppred Penc.
      subst.
      generalize dependent env.
      revert env' xenv l' env_OK.
      induction l.
      { intros.
        inversion Penc; subst; clear Penc.
        rewrite mempty_left; eexists _, _; intuition eauto.
        simpl; eauto.
      }
      { intros.
        simpl in *.
        unfold Bind2 in *; computes_to_inv; subst.
        injection Penc''; intros; subst.
        destruct v; destruct v0.
        destruct (proj1 (Ascii_decode_correct P_OK) _ _ _ _ _ (mappend b0 ext) env_OK Eeq I Penc) as [? [? [? xenv_OK] ] ].
      simpl. rewrite <- mappend_assoc, H; simpl.
      split_and; subst.
      destruct (IHl _ _ _ H4 _ H1 Penc') as [? [? ?] ].
      split_and; unfold id in *.
      rewrite H3; simpl; eexists _, _;
        subst; intuition eauto.
      simpl; unfold Bind2; eauto.
      }
    }
    { induction sz; simpl; intros.
      { simpl; injections; repeat eexists; simpl; eauto using mempty_left. }
      { destruct (decode_ascii t env') as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate.
        destruct (decode_string sz b c) as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate; injections.
        eapply (proj2 (Ascii_decode_correct P_OK)) in Heqo; eauto;
          destruct Heqo as [? [? ?] ]; destruct_ex; intuition; subst;
            eapply IHsz in Heqo0; eauto; destruct Heqo0 as [? [? ?] ];
              destruct_ex; intuition; subst.
        unfold id in *; simpl.
        eexists _, _; simpl; intuition eauto.
        simpl; computes_to_econstructor; eauto.
        computes_to_econstructor; eauto.
        rewrite mappend_assoc; reflexivity.
      }
    }
  Qed.

  Definition decode_string_with_term_char
           (term_char : Ascii.ascii)
           (b : B) (cd : CacheDecode)
    : option (string * B * CacheDecode).
    refine (Fix well_founded_lt_b
           (fun _ => CacheDecode -> option (string * B * CacheDecode))
      (fun b rec cd =>
         (`(a, b1, e1) <- Decode_w_Measure_lt decode_ascii b cd _;
      If ascii_dec a term_char Then
        Some (EmptyString, proj1_sig b1, e1)
      Else
      (`(xs, b2, e2) <- rec _ (proj2_sig b1) e1;
      Some (String a xs, b2, e2)))) b cd).
    exact ascii_decode_lt.
  Defined.

  Definition format_string_with_term_char
             (term_char : Ascii.ascii)
             (xs : string) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    format_string (xs ++ (String term_char EmptyString)) ce.

  Theorem String_decode_with_term_char_correct
          {P : CacheDecode -> Prop}
    : forall term_char (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b))),
      CorrectDecoder
        monoid
        (fun s => forall s1 s2, s <> s1 ++ String term_char s2)%string
        (fun s => forall s1 s2, s <> s1 ++ String term_char s2)%string
        eq
        (format_string_with_term_char term_char)
        (decode_string_with_term_char term_char) P
        (format_string_with_term_char term_char).
  Proof.
    split.
    { intros env env' xenv s s' ext ? Eeq Ppred Penc.
      subst.
      generalize dependent env.
      revert env' xenv s' env_OK.
      induction s.
      { unfold id in *; intros.
        unfold format_string_with_term_char in Penc.
        unfold decode_string_with_term_char.
        simpl in Penc; unfold Bind2 in *; computes_to_inv; subst; simpl in *.
        rewrite mempty_right in Penc''; inversion Penc''; subst.
        destruct v; simpl in *.
        eapply Ascii_decode_correct in Penc; eauto.
        unfold id in *.
        destruct_ex; split_and.
        eexists _, _; rewrite Init.Wf.Fix_eq.
        eapply Decode_w_Measure_lt_eq in H0; destruct_ex.
        rewrite H0; simpl.
        subst; destruct (ascii_dec x x); simpl; try congruence.
        intuition eauto.
        unfold format_string_with_term_char; simpl; unfold Bind2;
          repeat computes_to_econstructor; eauto.
        simpl;rewrite mempty_right; eauto.
        simpl.
        intros.
        repeat (apply functional_extensionality; intros; f_equal).
        rewrite H3.
        eauto.
      }
      { intros.
        unfold format_string_with_term_char in Penc;
          unfold decode_string_with_term_char.
        simpl in *.
        unfold Bind2 in *; computes_to_inv; subst.
        injection Penc''; intros; subst.
        destruct v; destruct v0.
        destruct (proj1 (Ascii_decode_correct P_OK) _ _ _ _ _ (mappend b0 ext) env_OK Eeq I Penc) as [? [? [? xenv_OK] ] ].
      simpl.
      unfold format_string_with_term_char in IHs.
      simpl in Penc'; eapply IHs in Penc'.
      destruct Penc'; intuition.
      subst.
      destruct_ex; split_and.
      eexists _, _; rewrite Init.Wf.Fix_eq.
      eapply Decode_w_Measure_lt_eq in H; destruct_ex.
      rewrite <- mappend_assoc, H; simpl.
      destruct (ascii_dec x term_char); simpl.
      - exfalso.
        subst; eapply (Ppred "")%string; simpl; reflexivity.
      - intuition.
        unfold decode_string_with_term_char in H1.
        rewrite H1; simpl; subst; eauto.
        unfold format_string_with_term_char; simpl; unfold Bind2;
          computes_to_econstructor; eauto.
        subst; computes_to_econstructor; eauto.
        subst; eauto.
        eauto.
      - intros; repeat (apply functional_extensionality; intros; f_equal).
        rewrite H7; reflexivity.
      - unfold id in *; unfold not; intros; eapply (Ppred (String a s1) s2); simpl; congruence.
      - intuition eauto.
      - intuition eauto.
      }
    }
    { unfold decode_string_with_term_char, format_string_with_term_char;
        intros env env' xenv' data bin;
        revert env env' xenv' data.
      eapply (@well_founded_induction _ _ well_founded_lt_b) with
      (a := bin); intros.
      rewrite Coq.Init.Wf.Fix_eq in H2; auto; simpl.
      apply DecodeBindOpt2_inv in H2;
        destruct H2 as [? [? [? [? ?] ] ] ]; injections; subst.
      destruct (decode_ascii x env') as [ [ [? ?] ?] | ] eqn: ? .
      - destruct (Decode_w_Measure_lt_eq _ _ _ ascii_decode_lt Heqo).
        rewrite H4 in H2; injections.
        destruct (ascii_dec x0 term_char) eqn: ?; simpl in H3.
        + injections.
          eapply (proj2 (Ascii_decode_correct P_OK)) in Heqo; eauto;
            destruct Heqo as [? [? ?] ]; destruct_ex; intuition; subst.
          simpl.
          eexists _, _; intuition.
          computes_to_econstructor; eauto.
          computes_to_econstructor; eauto.
          simpl; rewrite mempty_right; eauto.
          destruct s1; simpl in *; discriminate.
          eauto.
        + eapply (proj2 (Ascii_decode_correct P_OK)) in Heqo; eauto;
            destruct Heqo as [? [? ?] ]; destruct_ex.
          symmetry in H3; apply DecodeBindOpt2_inv in H3;
            destruct H3 as [? [? [? [? ?] ] ] ]; injections; subst.
          eapply H in H3; intuition.
          destruct_ex; intuition; subst; eauto.
          eexists _, _; intuition.
          simpl.
          computes_to_econstructor; eauto.
          computes_to_econstructor; eauto.
          simpl; rewrite mappend_assoc; eauto.
          unfold id in *; destruct s1; simpl in *; injections; intros; congruence.
          simpl; eauto.
          simpl; eauto.
      - eapply Decode_w_Measure_lt_eq' in Heqo; rewrite Heqo in H2;
          discriminate.
      - intros; repeat (apply functional_extensionality; intros; f_equal).
        rewrite H3; reflexivity.
    }
  Qed.

End String.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^150 - 3
Base: 21 + 3/7
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 21 + 3/7;
    bitwidth := 32;
    s := 2^150;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 7); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibProd LibContainer LibSet
     LibRelation LibPer LibMonoid.
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import LibNatExtra LibIter
     InverseNatNat Ackermann InverseAckermann MiscArith TLCBuffer
     UnionFind01Data UnionFind03Link UnionFind04Compress UnionFind11Rank
     UnionFind21Parent.

Section ParentEvolution.

Variable V : Type.
Variable D : set V.
Variable F : binary V.
Variable K : V -> nat.
Hypothesis is_rdsf_F : is_rdsf D F K.

(* -------------------------------------------------------------------------- *)

(* During a link, a vertex [v] which already has a parent keeps this parent. *)

Lemma link_preserves_parent:
  forall x y v,
  is_root F x ->
  ~ is_root F v ->
  p F v = p (link F x y) v.
Proof using is_rdsf_F.
  intros.
  (* Let [parent] be the new parent of [v]. *)
  intro_parent (link F x y) v.
  (* Now, two cases arise: *)
  by_cases_on_link.
  { (* If [v] is not [x], then this edge existed before the link,
       so the [parent] is in fact the previous parent of [v]. *)
    eauto using parent_unique. }
  { (* If [v] is [x], we have a clear contradiction. *)
    tauto. }
Qed.

(* After a link, the parent of [x] is [y]. *)

Lemma link_sets_parent:
  forall x y,
  is_root F x ->
  p (link F x y) x = y.
Proof using is_rdsf_F.
  intros.
  (* Let [parent] be the new parent of [x]. *)
  intro_parent (link F x y) x.
  { eapply x_no_longer_a_root. }
  (* Now, two cases arise: *)
  by_cases_on_link.
  { (* [x] is a root and has an outgoing edge. Contradiction. *)
    false. eauto using a_root_has_no_parent. }
  { (* Obvious. *)
    tauto. }
Qed.

(* -------------------------------------------------------------------------- *)

(* During a compression, the only vertex whose parent changes is [x],
   and its new parent is [z]. *)

Lemma compress_changes_parent_of_x_only:
  forall x z v,
  ~ is_root F v ->
  p F v <> p (compress F x z) v ->
  v = x /\ p (compress F x z) v = z.
Proof using is_rdsf_F.
  intros.
  (* Let [parent] be the new parent of [v]. *)
  intro_parent (compress F x z) v.
  (* Now, two cases arise: *)
  by_cases_on_compress.
  { (* If [v] is not [x], then this edge existed before the compression,
       so [parent] is in fact the previous parent of [v]. This
       contradicts the hypothesis that the parent of [v] has changed. *)
    false. unfold not in *. eauto using parent_unique. }
  { (* If [v] is [x], we are done. *)
    eauto. }
Qed.

Lemma compress_changes_parent_of_x_to_z:
  forall x z,
  ~ is_root F x ->
  p (compress F x z) x = z.
Proof using is_rdsf_F.
  intros.
  intro_parent (compress F x z) x.
  by_cases_on_compress; tauto.
Qed.

Lemma compress_does_not_change_parent_of_v:
  forall x z v,
  ~ is_root F v ->
  v <> x ->
  p (compress F x z) v = p F v.
Proof using is_rdsf_F.
  intros.
  intro_parent (compress F x z) v.
  by_cases_on_compress.
  { symmetry. eauto using parent_unique. }
  { tauto. }
Qed.

End ParentEvolution.


From Undecidability.Shared.Libs.PSL Require Import FinTypes Vectors.
From Undecidability.L Require Import TM.TMinL.TMinL_extract L_facts.
From Undecidability.TM Require Import Compiler_facts Compiler_spec.
From Undecidability.L.Datatypes Require Import LNat Lists LProd LFinType LVector Lists.
From Undecidability.TM Require Import TM_facts NaryApp.
From Undecidability.L Require Import Functions.FinTypeLookup TimeInvarianceTermination Functions.EqBool .

Import L_Notations.

Lemma many_app_eq {k} (v : Vector.t (list bool) k) s :  many_app s (Vector.map enc v) = Vector.fold_left (fun (s : term) n => s (encBoolsL n)) s v.
Proof.
   induction v in s |- *.
   * cbn. reflexivity.
   * cbn. now rewrite IHv.
Qed.

Import HOAS_Notations.

Lemma equiv_many_app_L k (v : Vector.t term k) s t n :
  s >(<= n) t -> many_app s v >(<= n) many_app t v.
Proof.
  induction v in s, t |- *; intros H; cbn.
  - eassumption.
  - eapply IHv. replace n with (n + 0) by lia. eapply redLe_app_helperL. eauto.
    reflexivity.
Qed.

Lemma beta_red s t t' : lambda t -> t' = subst s 0 t -> (lam s) t ≻ t'.
Proof.
  intros [u ->] ->. repeat econstructor.
Qed.

Lemma many_beta k (v : Vector.t term k) s :
  (forall x, Vector.In x v -> proc x) ->
  many_app (many_lam k s) v >(<= k) many_subst s 0 v.
Proof.
  induction v in s |- *; cbn; intros Hv.
  - reflexivity.
  - eapply redLe_trans with (i := 1) (j := n).
    eapply equiv_many_app_L.
    { assert (proc h).
      {eapply Hv. econstructor. } exists 1. split. lia. econstructor. split. 2:reflexivity. eapply beta_red. Lproc. reflexivity. }
    rewrite subst_many_lam. replace (n + 0) with n by lia.
    eapply IHv. intros. eapply Hv. now econstructor.
Qed.

Definition cont_vec (k : nat) : term := lam (many_lam k (k (Vector.fold_right (fun n s => (extT (@cons (list bool)) (var n)) s) (many_vars k)  (ext (@nil bool))))).

Lemma helper_closed k :
  bound k (Vector.fold_right (fun (n : nat) (s0 : term) => extT (@cons (list bool)) n s0) (many_vars k) (ext (@nil bool))).
Proof.
  induction k.
  - cbn. cbv. repeat econstructor.
  - rewrite many_vars_S. cbn. econstructor. econstructor. eapply closed_dcl_x. Lproc.
    econstructor. lia.
    eapply bound_ge. eauto. lia.
Qed.

Lemma subst_closed s n u :
  closed s -> subst s n u = s.
Proof.
  now intros ->.
Qed.

Lemma vector_closed:
  forall (k : nat) (v : Vector.t (list bool) k) (x : term), Vector.In x (Vector.map enc v) -> proc x.
Proof.
  intros k v.
  induction v; cbn; intros ? Hi. inversion Hi. inv Hi. Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. subst. eauto. eapply nat_eq_dec.
Qed.

Lemma cont_vec_correct k s (v : Vector.t (list bool) k) :
  proc s ->
  many_app (cont_vec k s) (Vector.map enc v) >(<= 1 + 3 * k) s (enc v).
Proof.
  intros Hs.
  unfold cont_vec.
  eapply redLe_trans with (i := 1) (j := 3 * k).
  eapply equiv_many_app_L. exists 1. split. lia. econstructor. split. 2:reflexivity.
  eapply beta_red. Lproc. rewrite subst_many_lam. replace (k + 0) with k by lia. reflexivity.
  cbn -[plus mult]. rewrite Nat.eqb_refl.
  rewrite bound_closed_k. 2:eapply helper_closed.
  replace (3 * k) with (k + 2 * k) by lia.
  eapply redLe_trans.
  eapply many_beta. eapply vector_closed.
  rewrite many_subst_app.
  rewrite many_subst_closed. 2:Lproc.
  replace (2 * k) with (2 * k + 0) by lia.
  eapply redLe_app_helperR. 2:reflexivity.
  induction v.
  - cbn. reflexivity.
  - rewrite many_vars_S. cbn -[mult]. rewrite subst_closed; [ | now Lproc].
    rewrite Nat.eqb_refl.
    rewrite !many_subst_app.
    repeat (rewrite many_subst_closed; [ | now Lproc]).
    eapply redLe_mono.
    eapply redLe_app_helperR.
    rewrite bound_closed_k. 2:eapply helper_closed. eapply IHv.
    rewrite !enc_vector_eq. Lsimpl. Lreflexivity. cbn.
    lia.
Qed.

Definition TM_bool_computable {k} (R : Vector.t (list bool) k -> (list bool) -> Prop) (τ : nat -> Vector.t nat k -> nat -> Prop) :=
  exists n : nat, exists Σ : finType, exists s b : Σ, s <> b /\
  exists M : TM Σ (1 + k + n),
  forall v : Vector.t (list bool) k,
  (forall l, R v l -> exists q t i, loopM (mk_mconfig (start M) (Vector.append (niltape ::: Vector.map (encBoolsTM s b) v) (Vector.const niltape n))) i = Some (mk_mconfig q t) /\ (τ (length l) (Vector.map (@length bool) v)) i /\ Vector.hd t = encBoolsTM s b l) /\
  (forall q t, TM.eval M (start M) (Vector.append (niltape ::: Vector.map (encBoolsTM s b) v) (Vector.const niltape n)) q t ->
          exists l, R v l).

Definition L_bool_computable {k} (R : Vector.t (list bool) k -> (list bool) -> Prop) (τ : nat -> Vector.t nat k -> nat -> Prop) :=
  exists s, closed s /\  forall v : Vector.t (list bool) k,
      (forall l, R v l -> exists i, (Vector.fold_left (fun s n => L.app s (encBoolsL n)) s v) ⇓(<= i) (encBoolsL l) /\ τ (length l) (Vector.map (@length bool) v) i) /\
      (forall o, L.eval (Vector.fold_left (fun s n => L.app s (encBoolsL n)) s v) o -> exists l, R v l).

From Undecidability Require TM.L.CompilerBoolFuns.Compiler.

Lemma help_L_bool_computable {k} (R : Vector.t (list bool) k -> (list bool) -> Prop) τ :
  L_bool_computable R τ -> ClosedLAdmissible.L_bool_computable_closed R.
Proof.
  intros (s & Hcl & H).
  exists s. split. eauto. intros v. split. intros l. split.
    + intros [i Hi] % H. eapply L_facts.eval_iff. now eapply evalLe_eval_subrelation.
    + intros H0. pose proof (H1 := H0). eapply H in H1 as [l'].
      enough (l = l') as -> by eassumption.
      eapply H in H1 as [i [H1 _]].
      eapply evalLe_eval_subrelation in H1.
      eapply Compiler_facts.encBoolsL_inj.
      rewrite eval_iff in H0. destruct H0 as [H0 H0'], H1 as [H1 H1'].
      eapply unique_normal_forms; eauto.
      now rewrite <- H0, H1.
    + intros o Ho. pose proof Ho as  [l [i [Hi _]] % H] % H. exists l. eapply evalLe_eval_subrelation in Hi.
      rewrite eval_iff in Ho. destruct Ho, Hi.
      eapply unique_normal_forms; eauto.
      now rewrite <- H0, H2.
Qed.
+
Section loopM.
  Context (sig : finType).
  Let reg_sig := @encodable_finType sig.
  Existing Instance reg_sig.

  Variable s b : sig.

  Definition f (x : bool) := if x then s else b.

  Instance f_comp : computableTime' f (fun _ _ => (4,tt)).
  Proof.
    extract. solverec.
  Qed.

  Definition c__encBoolsList := 4 + c__map.

  Instance encBoolsListTM_comp : computableTime' (@encBoolsListTM sig s b) (fun l _ => (S (length l) * c__encBoolsList,tt)).
  Proof.
    change (@encBoolsListTM sig s b) with (fun l => map f l).
    extract. solverec.  unfold c__encBoolsList. rewrite map_time_const. solverec.
  Qed.

  Definition c__encBools := c__encBoolsList + 6.

  Instance encBoolsTM_comp : computableTime' (@encBoolsTM sig s b) (fun l _ => (S (length l) * c__encBools,tt)).
  Proof.
    extract. solverec. unfold c__encBools. solverec.
  Qed.

  Local Instance eqb_sig : eqbClass _ := @eqbFinType_inst sig.

  Local Instance eqbT_sig : eqbCompT sig := @eqbFinType sig.

  Fixpoint unencListTM l :=
    match l with
    | x :: l =>
      match unencListTM l with None => None | Some l =>
      if eqb s x then Some (true :: l) else if eqb b x then Some (false :: l) else None end
    | nil => Some nil
    end.

  Definition c__unencListTM := 12 * c__eqbComp sig * length (elem sig) + 36.

  Instance unencListTM_comp : computableTime' (unencListTM) (fun l _ => (S (length l) * c__unencListTM, tt)).
  Proof.
    extract. solverec. all: unfold c__unencListTM. lia.
    all: try rewrite !eqbTime_le_r.
    all: unfold reg_sig, finType_eqb, eqb.
    all: try rewrite !size_finType_le.
    all: solverec.
  Qed.

  Definition unencTM t :=
    match t with
    | midtape ls m rs => unencListTM rs
    | _ => None
    end.

  Instance unencTM_comp : computableTime' unencTM (fun l _ => (S (length (right l)) * c__unencListTM + 15, tt)).
  Proof.
    extract. solverec.
  Qed.

  Variable n : nat.

  Variable k : nat.

  Variable M : TM sig (1 + k + n).

  Definition prepare v : list (tape sig) := (app (niltape :: map (encBoolsTM s b) v) (repeat niltape n)).

  Fixpoint prepare_time (l : list (list bool)) :=
    match l with
    | [] => 18
    | l :: L => c__map * length l + prepare_time L
    end.

  Definition list_size {X} (l : list (list X)) := sumn (map (@length X) l) + length l.

  Lemma list_size_length {X} (l : list (list X)) : length l <= list_size l. Proof. clear. unfold list_size. lia. Qed.
  Lemma list_size_sum {X} (l : list (list X)) : sumn (map (@length X) l) <= list_size l. Proof. clear. unfold list_size. lia. Qed.

  Let C :=  c__leUpToC (mapTime_upTo (fun x0 : list bool => S (| x0 |) * c__encBools)).

  Definition c__prepare :=  (S c__app * S C * S c__encBools * S c__map  + 18).

  Lemma lemma_map_time:
    forall x : list (list bool), map_time (fun x0 : list bool => S (| x0 |) * c__encBools) x <= S (list_size x) * S c__encBools * c__map.
  Proof.
    intros x.
    generalize c__encBools. clear. intros.
    induction x.
    - cbn. unfold c__map. lia.
    - cbn [map_time]. rewrite IHx. unfold list_size. cbn -[plus mult]. unfold c__map. ring_simplify. lia.
  Qed.

  Instance prepare_comp : computableTime' prepare (fun l _ => (12 * n + c__prepare * (1 + list_size l), tt)).
  Proof.
    extract. solverec.
    rewrite map_length, list_size_length.
    rewrite lemma_map_time.
    unfold c__prepare, c__app, c__encBools, c__encBoolsList, c__map. ring_simplify. lia.
  Qed.

  Definition the_term :=
    cont_vec k (lam ((s_sim (encTM M) (extT prepare 0)) I (lam (lam (extT unencTM 1 I I))))).

  Require Import Equations.Prop.DepElim.

  Variable Heq : s <> b.

  Lemma unenc_enc' l :
    unencListTM (map (fun x : bool => if x then s else b) l) = Some l.
  Proof using Heq.
    induction l as [ | [] l IH]; cbn.
    - congruence.
    - rewrite IH. destruct (eqb_spec s s); try congruence.
    - rewrite IH. destruct (eqb_spec s b); try congruence. destruct (eqb_spec b b); try congruence.
  Qed.

  Lemma unenc_enc l :
    unencTM (encBoolsTM s b l) = Some l.
  Proof using Heq.
    induction l; cbn.
    - reflexivity.
    - rewrite unenc_enc'. destruct a.
      destruct (eqb_spec s s); try congruence.
      destruct (eqb_spec s b); try congruence.
      destruct (eqb_spec b b); try congruence.
  Qed.

  Lemma enc_prepare_eq:
    forall v : Vector.t (list bool) k, enc (prepare (Vector.to_list v)) = enc (Vector.append (niltape ::: Vector.map (encBoolsTM s b) v) (Vector.const niltape n)).
  Proof.
    intros v.

    rewrite enc_vector_eq. unfold prepare.
    rewrite <- !VectorPrelim.vector_to_list_correct.
    rewrite VectorPrelim.vector_app_to_list. cbn.
    rewrite VectorPrelim.vector_to_list_map.
    assert ( VectorPrelim.vector_to_list (Vector.const niltape n) = repeat (niltape sig) n) as ->.
    { clear. induction n; cbn; congruence. }
    reflexivity.
  Qed.

  Lemma the_term_forward (v : Vector.t (list bool) k) i q t l :
    loopM (mk_mconfig (start M) (Vector.append (niltape ::: Vector.map (encBoolsTM s b) v) (Vector.const niltape n))) i = Some (mk_mconfig q t) ->
    Vector.hd t = encBoolsTM s b l ->
    (Vector.fold_left (fun s n => L.app s (encBoolsL n)) the_term v) >(<= (1 + 3 * k) + (1 + ((10 * (S i) * sizeTM M + 10) + 12 * n + (c__prepare * (1 + list_size (Vector.to_list v)) + ((| encBoolsListTM s b l |) * c__unencListTM + c__unencListTM + 25))))) enc l.
  Proof using Heq.
    assert (Hs_sim : proc s_sim). unfold s_sim. Lproc.
    assert (HencTM : closed (encTM M)). unfold encTM. Lproc.
    intros H Ht.
    rewrite <- many_app_eq.
    unfold the_term.
    eapply redLe_trans.
    eapply cont_vec_correct. Lproc.
    Lsimpl.
    rewrite !enc_vector_eq.
    eapply redLe_mono.
    Lsimpl.
    eapply TimeInvarianceThesis_wrt_Termination_TM_to_L in H.
    unfold encTps in H.
    rewrite enc_prepare_eq.
    eapply redLe_app_helperL. eapply redLe_app_helperL.  eapply H. reflexivity.
    eapply redLe_mono. depelim t. cbn in Ht. subst.
    rewrite (enc_vector_eq (encBoolsTM s b l ::: t)).
    rewrite <- !VectorPrelim.vector_to_list_correct. cbn.
    rewrite !VectorPrelim.vector_to_list_correct. Lsimpl.
    rewrite unenc_enc. Lsimpl. reflexivity. reflexivity.

    cbn -[plus mult]. solverec.
  Qed.

  Lemma converges_eval S : converges S -> exists v, S ⇓ v.
  Proof.
    intros (v & H1 & H2). exists v. rewrite H1. econstructor. reflexivity. eauto.
  Qed.

  From Undecidability.L Require Import Seval.

  Lemma the_term_backward (v : Vector.t (list bool) k) t :
    L.eval ((Vector.fold_left (fun s n => L.app s (encBoolsL n)) the_term v)) t ->
    exists q t, TM.eval M (start M) (Vector.append (niltape ::: Vector.map (encBoolsTM s b) v) (Vector.const niltape n)) q t.
  Proof using Heq.
    intros H % L_facts.eval_iff.
    assert (Hs_sim : proc s_sim). unfold s_sim. Lproc.
    assert (HencTM : closed (encTM M)). unfold encTM. Lproc.
    setoid_rewrite TM_eval_iff.
    assert (Vector.fold_left (fun (s : term) (n : list bool) => s (encBoolsL n)) the_term v >*
            ((s_sim (encTM M) (enc (prepare (Vector.to_list v)))) I (lam (lam (extT unencTM 1 I I))))).
    { eapply redLe_star_subrelation.
      rewrite <- many_app_eq.
      unfold the_term.
      eapply redLe_trans.
      eapply cont_vec_correct. Lproc.
      rewrite !enc_vector_eq.
      eapply redLe_mono.
      Lsimpl. reflexivity. reflexivity. }

    rewrite H0 in H.
    rewrite enc_prepare_eq in H.

    eapply eval_converges in H.
    eapply app_converges in H as [H _].
    eapply app_converges in H as [H _].
    eapply converges_eval in H as [vv H].

    edestruct (TimeInvarianceNF_backward) as (q & t' & i & HH).
    2:{ destruct i. inv HH.
        setoid_rewrite TM_alt.loopSumM_loopM_iff. eauto. }

    eauto.
  Qed.

  Lemma the_term_closed : closed (the_term).
  Proof.
    unfold the_term. eapply closed_dcl. econstructor.
    2:{ eapply closed_dcl.
        assert (Hs_sim : proc s_sim). unfold s_sim. Lproc.
        assert (HencTM : closed (encTM M)). unfold encTM. Lproc. Lproc. }
    eapply closed_dcl.
    unfold cont_vec. intros m u. cbn.
    rewrite subst_many_lam. cbn.
    destruct (Nat.eqb_spec k (k + S m)); try lia. repeat f_equal.
    clear. induction k as [ | k'] in m |- * . cbn.
    - rewrite subst_closed; try Lproc. reflexivity.
    - rewrite many_vars_S. cbn. rewrite subst_closed; try Lproc.
      destruct (Nat.eqb_spec k' (S (k' + S m))); try lia. repeat f_equal.
      erewrite <- IHk' with (m := S m) at 2. repeat f_equal. lia.
  Qed.

End loopM.

Lemma TM_size_diff {Σ k} (M : TM Σ k) cfg cfg' i j :
  loopM (cfg : mconfig Σ (state M) k) i = Some cfg' ->
  sizeOfTape ((ctapes cfg')[@j]) <= i + sizeOfTape ((ctapes cfg)[@j]).
Proof.
  induction i in cfg |- *; cbn; intros H; destruct haltConf; inv H; cbn.
  - lia.
  - lia.
  - eapply IHi in H1. rewrite H1.
    enough (sizeOfTape (ctapes (TM_facts.step cfg))[@j] <= S (sizeOfTape (ctapes cfg)[@j])) by lia.
    destruct cfg as (q, t); cbn.
    unfold TM_facts.step. cbn. destruct trans. cbn. clear.
    induction t0; depelim j; depelim t; cbn; eauto.
    destruct h0 as [[] []], h as [ | | | [] ? [] ]; cbn; try rewrite !app_length, !rev_length; cbn; lia.
Qed.

Theorem TimeInvarianceThesis_wrt_Computability_TM_to_L {k} (R : Vector.t (list bool) k -> (list bool) -> Prop) (τ : nat -> Vector.t nat k -> nat -> Prop) :
  TM_bool_computable R τ -> exists p1, L_bool_computable R (fun m v i => exists j, τ m v j /\ p1 v j = i).
Proof.
  intros (n & Σ & s & b & Heq & M & H).
  pose (p := fun (v : Vector.t nat k) N =>
       1 + 3 * k +
       (1 +
        (10 * S N * sizeTM M + 10 + 12 * n +
         (c__prepare * (1 + sumn (Vector.to_list v) + k) + (N * c__unencListTM Σ + c__unencListTM Σ + 25))))
       ).
  exists p, (the_term s b M).
  split. eapply the_term_closed.
  intros v. specialize (H v) as [H1 H2]. split.
  - intros l (q & t & i & H & He & Hi) % H1.
    exists (p (Vector.map (length (A :=bool)) v) i).
    split. 2: eauto.
    eapply evalIn_mono.
    econstructor. 2:{ change (lambda (enc l)). Lproc. }
    eapply the_term_forward; eauto. unfold list_size. unfold p.
    assert (Hleq : (| encBoolsListTM s b l |) <= i). {
      transitivity (sizeOfTape (Vector.hd t)). rewrite Hi.
      cbn. lia.
      assert (Vector.hd t = t[@Fin0]) as -> by now depelim t.
      eapply TM_size_diff in H. cbn in H. rewrite H. cbn. lia.
    }
    rewrite Hleq, vector_map_to_list, vector_to_list_length. solverec.
  - intros o (? & ? & ?) % the_term_backward. now eapply H2. eauto.
Qed.


(*********************************************************************************************************************************)
(* ProgrammingLanguageArrow                                                                                *)
(*                                                                                *)
(*   Arrows in ProgrammingLanguages.                                                                                *)
(*                                                                                *)
(*********************************************************************************************************************************)

Generalizable All Variables.
Require Import Preamble.
Require Import General.
Require Import Categories_ch1_3.
Require Import InitialTerminal_ch2_2.
Require Import Functors_ch1_4.
Require Import Isomorphisms_ch1_5.
Require Import ProductCategories_ch1_6_1.
Require Import OppositeCategories_ch1_6_2.
Require Import Enrichment_ch2_8.
Require Import Subcategories_ch7_1.
Require Import NaturalTransformations_ch7_4.
Require Import NaturalIsomorphisms_ch7_5.
Require Import BinoidalCategories.
Require Import PreMonoidalCategories.
Require Import PreMonoidalCenter.
Require Import MonoidalCategories_ch7_8.
Require Import Coherence_ch7_8.
Require Import Enrichment_ch2_8.
Require Import RepresentableStructure_ch7_2.
Require Import FunctorCategories_ch7_7.

Require Import NaturalDeduction.
Require Import NaturalDeductionCategory.

Require Import ProgrammingLanguageCategory.
Require Import FreydCategories.
Require Import Enrichments.
Require Import GeneralizedArrow.

Section ArrowInLanguage.

  (* an Arrow In A Programming Language consists of... *)

  (* a host language: *)
  Context `(Host         : ProgrammingLanguage).

  Context  (Host_Monoidal  : MonoidalCat  (TypesL_PreMonoidal Host)).
  Context  (Host_Cartesian : CartesianCat Host_Monoidal).

  Context
    {P}
    (Pobj_unit   : P [])
    (Pobj_closed : forall a b, P a → P b → P (bin_obj(BinoidalCat:=Center_is_PreMonoidal (TypesL_PreMonoidal Host)) a b)).

  Context (VK : FullSubcategory Host_Cartesian P).

  Context  ehom KE (K_bin:@EBinoidalCat _ _ VK _ _ _
          (PreMonoidalFullSubcategory_PreMonoidal Host_Cartesian VK Pobj_unit Pobj_closed)
          (TypesL Host) ehom KE (bin_obj(BinoidalCat:=Host_Monoidal))).

  Context (K_premonoidal:PreMonoidalCat K_bin (one(TerminalObject:=Host_Cartesian))).

  Definition ArrowInProgrammingLanguage :=
    @FreydCategory _ _ _ _ _ _ _ _ Host_Cartesian _ _ K_bin K_premonoidal.

  Definition K_enrichment : Enrichment.
    refine
      {| enr_c_pm  := K_premonoidal
       ; enr_v_mon := MonoidalFullSubcategory_Monoidal Host_Cartesian _ _ VK
      |}.
      Defined.

  Instance ArrowsAreGeneralizedArrows : GeneralizedArrow K_enrichment (TypesEnrichedInJudgments Host) :=
    { ga_functor_monoidal :=
        PreMonoidalFullSubcategoryInclusionFunctor_PreMonoidal Host_Cartesian VK Pobj_unit Pobj_closed Host_Cartesian }.

End ArrowInLanguage.


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 B D U : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (col_ O E O /\ (col_ O E B /\ (col_ O E O /\ (col_ O E D /\ (col_ O E U /\ col_ O U Eprime))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.