(* ------------------------------------------------------------------------- *)
(** 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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15synthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus (mult lv0 lv1) lv0) (plus (mult lv1 lv0) lv0)).
Admitted.
QuickChick conj15synthconj2.


(*********************************************************************************************************************************)
(* 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.