(** Equalizer of algebras *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispDepProd.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Add2Cell.
Require Import UniMath.Bicategories.Colimits.Initial.

Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import displayed_algebras.globe_over_lem.
Require Import displayed_algebras.displayed_algebra.
Require Import displayed_algebras.total_algebra.

Local Open Scope cat.

Definition poly_dact_UU_on_eq
           {P : poly_code}
           {A B : UU}
           {f g : A → B}
           (x : poly_act P A)
           (Hx : poly_dact_UU P (λ z, f z = g z) x)
  : poly_map P f x = poly_map P g x.
Proof.
  induction P as [ T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - apply idpath.
  - exact Hx.
  - induction x as [x | x].
    + exact (maponpaths inl (IHP₁ x Hx)).
    + exact (maponpaths inr (IHP₂ x Hx)).
  - exact (pathsdirprod (IHP₁ _ (pr1 Hx)) (IHP₂ _ (pr2 Hx))).
Defined.

Definition poly_dact_UU_on_eq_lem
           {P : poly_code}
           {Z A B : one_type}
           {f g : A → B}
           (hpr1 : Z → A)
           (hpr2 : ∏ (z : Z), f(hpr1 z) = g(hpr1 z))
           (x : poly_act P Z)
           (HP : ∏ z, isofhlevel 3 (f z = g z))
  : @poly_dact_UU_on_eq
      P
      A B f g
      (poly_pr1 P (poly_map P _ x))
      (@poly_pr2
         P A (λ z, make_one_type (f z = g z) (HP z))
         (poly_map P (λ z, hpr1 z ,, hpr2 z) x))
    =
    maponpaths (poly_map P f) (poly_comp _ _ _ _)
    @ poly_comp _ _ _ _
    @ poly_homot P hpr2 _
    @ !(poly_comp _ _ _ _)
    @ maponpaths (poly_map P g) (!(poly_comp _ _ _ _)).
Proof.
  induction P as [ T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - apply idpath.
  - exact (!(pathscomp0rid _)).
  - induction x as [x | x].
    + simpl.
      refine (maponpaths (maponpaths inl) (IHP₁ x) @ _).
      refine (!_).
      etrans.
      {
        etrans.
        {
          apply maponpaths_2.
          refine (maponpathscomp inl (coprodf _ _) _ @ _).
          exact (!(maponpathscomp (poly_map P₁ f) inl _)).
        }
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            etrans.
            {
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                etrans.
                {
                  apply maponpaths.
                  exact (!(maponpathsinv0 _ _)).
                }
                refine (maponpathscomp inl (coprodf _ _) _ @ _).
                exact (!(maponpathscomp (poly_map P₁ g) inl _)).
              }
              etrans.
              {
                apply maponpaths_2.
                exact (!(maponpathsinv0 inl _)).
              }
              exact (!(maponpathscomp0 inl _ _)).
            }
            exact (!(maponpathscomp0 inl _ _)).
          }
          exact (!(maponpathscomp0 inl _ _)).
        }
        exact (!(maponpathscomp0 inl _ _)).
      }
      apply idpath.
    + simpl.
      refine (maponpaths (maponpaths inr) (IHP₂ x) @ _).
      refine (!_).
      etrans.
      {
        etrans.
        {
          apply maponpaths_2.
          refine (maponpathscomp inr (coprodf _ _) _ @ _).
          exact (!(maponpathscomp (poly_map P₂ f) inr _)).
        }
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            etrans.
            {
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                etrans.
                {
                  apply maponpaths.
                  exact (!(maponpathsinv0 _ _)).
                }
                refine (maponpathscomp inr (coprodf _ _) _ @ _).
                exact (!(maponpathscomp (poly_map P₂ g) inr _)).
              }
              etrans.
              {
                apply maponpaths_2.
                exact (!(maponpathsinv0 inr _)).
              }
              exact (!(maponpathscomp0 inr _ _)).
            }
            exact (!(maponpathscomp0 inr _ _)).
          }
          exact (!(maponpathscomp0 inr _ _)).
        }
        exact (!(maponpathscomp0 inr _ _)).
      }
      apply idpath.
  - simpl.
    refine (paths_pathsdirprod (IHP₁ _) (IHP₂ _) @ _).
    refine (!_).
    etrans.
    {
      etrans.
      {
        apply maponpaths_2.
        exact (!(maponpaths_pathsdirprod _ _ _ _)).
      }
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            etrans.
            {
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                apply pathsdirprod_inv.
              }
              exact (!(maponpaths_pathsdirprod _ _ _ _)).
            }
            etrans.
            {
              apply maponpaths_2.
              apply pathsdirprod_inv.
            }
            apply pathsdirprod_concat.
          }
          apply pathsdirprod_concat.
        }
        apply pathsdirprod_concat.
      }
      apply pathsdirprod_concat.
    }
    apply idpath.
Qed.

Definition maponpaths_poly_homot
           {P : poly_code}
           {X Y Z : UU}
           {f g : X → Y}
           (h : Y → Z)
           (p : f ~ g)
           (x : poly_act P X)
  : maponpaths
      (poly_map P h)
      (poly_homot P p x)
    =
    poly_comp _ _ _ _
    @ poly_homot P (λ z, maponpaths h (p z)) x
    @ !(poly_comp _ _ _ _).
Proof.
  induction P as [ T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - apply idpath.
  - exact (!(pathscomp0rid _)).
  - induction x as [x | x] ; simpl.
    + refine (maponpathscomp inl (coprodf _ _) _ @ _).
      refine (!(maponpathscomp (poly_map _ _) inl _) @ _).
      refine (maponpaths (maponpaths inl) (IHP₁ x) @ _).
      refine (maponpathscomp0 _ _ _ @ _).
      apply maponpaths.
      refine (maponpathscomp0 _ _ _ @ _).
      apply maponpaths.
      apply (maponpathsinv0 inl).
    + refine (maponpathscomp inr (coprodf _ _) _ @ _).
      refine (!(maponpathscomp (poly_map _ _) inr _) @ _).
      refine (maponpaths (maponpaths inr) (IHP₂ x) @ _).
      refine (maponpathscomp0 _ _ _ @ _).
      apply maponpaths.
      refine (maponpathscomp0 _ _ _ @ _).
      apply maponpaths.
      apply (maponpathsinv0 inr).
  - simpl.
    refine (!(maponpaths_pathsdirprod _ _ _ _) @ _).
    refine (paths_pathsdirprod (IHP₁ _) (IHP₂ _) @ _).
    refine (!_).
    refine (maponpaths (λ z, _ @ (_ @ z)) (pathsdirprod_inv _ _) @ _).
    refine (maponpaths (λ z, _ @ z) (pathsdirprod_concat _ _ _ _) @ _).
    exact (pathsdirprod_concat _ _ _ _).
Qed.

Section Equalizer.
  Context {Σ : hit_signature}
          {A B : hit_algebra_one_types Σ}
          (f g : A --> B).

  Definition equalizer_disp_alg_constr
             (x : poly_act (point_constr Σ) (alg_carrier A))
             (Hx : poly_dact_UU
                     (point_constr Σ)
                     (λ z : alg_carrier A, alg_map_carrier f z = alg_map_carrier g z)
                     x)
    : alg_map_carrier f (alg_constr A x) = alg_map_carrier g (alg_constr A x).
  Proof.
    exact (alg_map_commute f x
           @ maponpaths (alg_constr B) (poly_dact_UU_on_eq x Hx)
           @ !(alg_map_commute g x)).
  Defined.

  Definition equalizer_endpoint
             {P Q : poly_code}
             (e : endpoint (point_constr Σ) P Q)
             (x : poly_act P (alg_carrier A))
             (y : poly_dact_UU
                    P
                    (λ z : alg_carrier A, alg_map_carrier f z = alg_map_carrier g z)
                    x)
    : poly_dact_UU_on_eq
        _
        (endpoint_dact_UU
           (alg_constr A)
           (λ z : alg_carrier A, alg_map_carrier f z = alg_map_carrier g z)
           e
           equalizer_disp_alg_constr
           y)
      =
      sem_endpoint_UU_natural
        e
        (alg_map_commute f)
        _
      @ maponpaths _ (poly_dact_UU_on_eq x y)
      @ !(sem_endpoint_UU_natural
            e
            (alg_map_commute g)
            _).
  Proof.
    induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                    | P Q | P Q | P Q | P Q
                    | P Q R e₁ IHe₁ e₂ IHe₂
                    | P T t | C₁ C₂ h | ].
    - simpl.
      refine (_ @ !(pathscomp0rid _)).
      exact (!(maponpathsidfun _)).
    - simpl ; unfold dep_comp_fun.
      refine (IHe₂ _ _ @ _) ; clear IHe₂.
      refine (_ @ path_assoc _ _ _).
      apply maponpaths.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths.
        apply pathscomp_inv.
      }
      do 2 refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      etrans.
      {
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths.
            refine (!_).
            apply maponpathscomp.
          }
          refine (!_).
          apply maponpathscomp0.
        }
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply maponpathsinv0.
        }
        refine (!_).
        apply maponpathscomp0.
      }
      apply maponpaths.
      refine (_ @ !(IHe₁ _ _)) ; clear IHe₁.
      exact (!(path_assoc _ _ _)).
    - exact (!(pathscomp0rid _)).
    - exact (!(pathscomp0rid _)).
    - simpl.
      refine (_ @ !(pathscomp0rid _)).
      exact (!(maponpaths_pr1_pathsdirprod _ _)).
    - simpl.
      refine (_ @ !(pathscomp0rid _)).
      exact (!(maponpaths_pr2_pathsdirprod _ _)).
    - simpl.
      refine (!_).
      etrans.
      {
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            apply pathsdirprod_inv.
          }
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths_prod_path.
          }
          apply pathsdirprod_concat.
        }
        apply pathsdirprod_concat.
      }
      exact (!(paths_pathsdirprod (IHe₁ _ _) (IHe₂ _ _))).
    - simpl.
      refine (_ @ !(pathscomp0rid _)).
      exact (!(maponpaths_for_constant_function _ _)).
    - apply idpath.
    - apply idpath.
  Qed.

  Definition equalizer_disp_alg_path
             (j : path_label Σ)
             (x : poly_act (path_source Σ j) (alg_carrier A))
             (y : poly_dact_UU
                    (path_source Σ j)
                    (λ z : alg_carrier A, alg_map_carrier f z = alg_map_carrier g z)
                    x)
    : PathOver
        (alg_path A j x)
        (endpoint_dact_UU
           (alg_constr A)
           (λ z : alg_carrier A, alg_map_carrier f z = alg_map_carrier g z)
           (path_left Σ j)
           equalizer_disp_alg_constr
           y)
        (endpoint_dact_UU
           (alg_constr A)
           (λ z : alg_carrier A, alg_map_carrier f z = alg_map_carrier g z)
           (path_right Σ j)
           equalizer_disp_alg_constr
           y).
  Proof.
    apply map_PathOver ; unfold square.
    etrans.
    {
      apply maponpaths.
      exact (equalizer_endpoint (path_right Σ j) x y).
    }
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      exact (equalizer_endpoint (path_left Σ j) x y).
    }
    refine (!_).
    refine (path_assoc _ _ _ @ _).
    etrans.
    {
      apply maponpaths_2.
      exact (alg_map_path f j x).
    }
    refine (!(path_assoc _ _ _) @ _ @ path_assoc _ _ _).
    apply maponpaths.
    refine (!_).
    refine (!(path_assoc _ _ _) @ _).
    refine (_ @ !(path_assoc _ _ _)).
    use path_inv_rotate_rr.
    refine (!(path_assoc _ _ _) @ _).
    etrans.
    {
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        exact (alg_map_path g j x).
      }
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      apply pathsinv0l.
    }
    simpl.
    apply homotsec_natural'.
  Qed.

  Definition equalizer_disp_alg
    : disp_algebra A.
  Proof.
    use set_disp_algebra.
    - exact (λ z, alg_map_carrier f z = alg_map_carrier g z).
    - abstract
        (intro x ;
         exact (one_type_isofhlevel (pr111 B) _ _)).
    - exact equalizer_disp_alg_constr.
    - exact equalizer_disp_alg_path.
  Defined.

  Definition equalizer
    : hit_algebra_one_types Σ
    := total_algebra equalizer_disp_alg.

  Definition equalizer_pr
    : equalizer --> A
    := projection _.

  Definition equalizer_path_component
    : alg_map_carrier (equalizer_pr · f) ~ alg_map_carrier (equalizer_pr · g)
    := λ a, pr2 a.

  Definition equalizer_path_is_alg_2cell_help
             {P : poly_code}
    : ∏ (x : poly_act P (alg_carrier equalizer)),
      poly_comp P pr1 (alg_map_carrier f) x
      @ poly_homot P (λ z, pr2 z) x
      =
      poly_dact_UU_on_eq (poly_pr1 P x) (poly_pr2 P x)
      @ poly_comp P pr1 (alg_map_carrier g) x.
  Proof.
    intro x.
    induction P as [ T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
    - apply idpath.
    - exact (!(pathscomp0rid _)).
    - induction x as [x | x].
      + simpl.
        etrans.
        {
          refine (!_).
          apply (maponpathscomp0 inl).
        }
        refine (!_).
        etrans.
        {
          refine (!_).
          apply (maponpathscomp0 inl).
        }
        apply maponpaths.
        exact (!(IHP₁ x)).
      + simpl.
        etrans.
        {
          refine (!_).
          apply (maponpathscomp0 inr).
        }
        refine (!_).
        etrans.
        {
          refine (!_).
          apply (maponpathscomp0 inr).
        }
        apply maponpaths.
        exact (!(IHP₂ x)).
    - simpl.
      refine (pathsdirprod_concat _ _ _ _ @ _ @ !(pathsdirprod_concat _ _ _ _)).
      exact (paths_pathsdirprod (IHP₁ _) (IHP₂ _)).
  Qed.

  Definition equalizer_path_is_alg_2cell
    : is_algebra_2cell equalizer_path_component.
  Proof.
    intro a.
    cbn ; unfold homotcomp, homotfun, funhomotsec ; cbn.
    rewrite !pathscomp0rid.
    unfold equalizer_disp_alg_constr.
    rewrite <- !path_assoc.
    apply maponpaths.
    etrans.
    {
      apply maponpaths.
      rewrite path_assoc.
      apply maponpaths_2.
      apply pathsinv0l.
    }
    cbn.
    etrans.
    {
      refine (!_).
      apply maponpathscomp0.
    }
    refine (!_).
    etrans.
    {
      refine (!_).
      apply maponpathscomp0.
    }
    apply maponpaths.
    apply equalizer_path_is_alg_2cell_help.
  Qed.

  Definition equalizer_path
    : equalizer_pr · f ==> equalizer_pr · g.
  Proof.
    use make_algebra_2cell.
    - exact equalizer_path_component.
    - exact equalizer_path_is_alg_2cell.
  Defined.

  Section EqualizerUMP1.
    Variable (C : hit_algebra_one_types Σ)
             (Cpr : C --> A)
             (Cpath : Cpr · f ==> Cpr · g).

    Definition equalizer_ump_1_comp
      : alg_carrier C → alg_carrier equalizer
      := λ c, alg_map_carrier Cpr c ,, pr111 Cpath c.

    Definition equalizer_ump_1_preserves_point_pr1
               (x : poly_act (point_constr Σ) (alg_carrier C))
      : pr1 (equalizer_ump_1_comp (alg_constr C x))
        =
        pr1 (prealg_constr (poly_map (point_constr Σ) equalizer_ump_1_comp x)).
    Proof.
      cbn ; unfold poly_pr1.
      refine (alg_map_commute Cpr x @ _).
      apply maponpaths.
      refine (!_).
      apply poly_comp.
    Defined.

    Definition equalizer_ump_1_preserves_point_pr2
               (x : poly_act (point_constr Σ) (alg_carrier C))
      : PathOver
          (equalizer_ump_1_preserves_point_pr1 x)
          (pr2 (equalizer_ump_1_comp (prealg_constr x)))
          (pr2 (prealg_constr (poly_map (point_constr Σ) equalizer_ump_1_comp x))).
    Proof.
      simpl.
      pose (eqtohomot (pr211 Cpath) x) as p.
      cbn in p.
      unfold homotcomp, homotfun, funhomotsec in p.
      cbn in p.
      rewrite !pathscomp0rid in p.
      apply map_PathOver ; unfold square.
      rewrite !path_assoc in p.
      pose (path_inv_rotate_rr _ _ _ p) as p'.
      pose (path_inv_rotate_rr _ _ _ p') as p''.
      unfold disp_alg_constr.
      simpl.
      unfold equalizer_disp_alg_constr, equalizer_ump_1_preserves_point_pr1.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply maponpathscomp0.
      }
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        exact p''.
      }
      clear p'' p' p.
      rewrite maponpathscomp0.
      rewrite <- !path_assoc.
      apply maponpaths.
      etrans.
      {
        do 4 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply maponpathscomp.
        }
        refine (!_).
        apply (homotsec_natural' (invhomot (alg_map_commute g))).
      }
      rewrite !path_assoc ; unfold invhomot.
      apply maponpaths_2.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply maponpathscomp.
        }
        apply (homotsec_natural' (alg_map_commute f)).
      }
      rewrite <- !path_assoc.
      apply maponpaths.
      rewrite <- !maponpathsinv0.
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply (maponpathscomp _ (alg_constr B)).
      }
      rewrite <- !maponpathscomp0.
      refine (!_).
      etrans.
      {
        do 3 apply maponpaths.
        refine (!_).
        apply (maponpathscomp _ (alg_constr B)).
      }
      rewrite <- !maponpathscomp0.
      apply maponpaths.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply maponpathsinv0.
      }
      use path_inv_rotate_ll.
      apply poly_dact_UU_on_eq_lem.
    Qed.

    Definition equalizer_ump_1_preserves_point
      : preserves_point equalizer_ump_1_comp.
    Proof.
      intro x.
      use PathOverToTotalPath'.
      - exact (equalizer_ump_1_preserves_point_pr1 x).
      - exact (equalizer_ump_1_preserves_point_pr2 x).
    Defined.

    Definition equalizer_ump_1_prealg
      : pr11 C --> pr11 equalizer.
    Proof.
      use make_hit_prealgebra_mor.
      - exact equalizer_ump_1_comp.
      - exact equalizer_ump_1_preserves_point.
    Defined.

    Definition equalizer_endpoint_natural
               {P Q : poly_code}
               (e : endpoint (point_constr Σ) P Q)
               (x : poly_act P (alg_carrier C))
      : maponpaths
          (poly_map Q pr1)
          (sem_endpoint_UU_natural
             e
             (prealg_map_commute equalizer_ump_1_prealg)
             x)
        @ !(total_algebra.pr1_endpoint equalizer_disp_alg e _)
        =
        poly_comp _ _ _ _
        @ sem_endpoint_UU_natural e (alg_map_commute Cpr) x
        @ !(maponpaths (sem_endpoint_UU e (alg_constr A)) (poly_comp _ _ _ _)).
    Proof.
      use path_inv_rotate_lr.
      induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                      | P Q | P Q | P Q | P Q
                      | P Q R e₁ IHe₁ e₂ IHe₂
                      | P T t | C₁ C₂ h | ] ; simpl.
      - refine (!_).
        refine (pathscomp0rid _ @ _ @ pathsinv0r (poly_comp P _ _ _)).
        do 2 apply maponpaths.
        apply maponpathsidfun.
      - refine (maponpathscomp0 _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply IHe₂.
        }
        clear IHe₂.
        do 2 refine (!(path_assoc _ _ _) @ _).
        refine (_ @ path_assoc _ _ _).
        apply maponpaths.
        refine (!(path_assoc _ _ _) @ _).
        do 2 refine (_ @ path_assoc _ _ _).
        apply maponpaths.
        do 2 refine (_ @ !(path_assoc _ _ _)).
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            apply maponpathscomp.
          }
          unfold funcomp.
          exact (!(homotsec_natural'
                     (total_algebra.pr1_endpoint equalizer_disp_alg e₂)
                     (sem_endpoint_UU_natural
                        e₁ (prealg_map_commute equalizer_ump_1_prealg) x))).
        }
        refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                refine (!_).
                apply maponpathscomp.
              }
              refine (!_).
              apply maponpathsinv0.
            }
            refine (!_).
            apply maponpathscomp0.
          }
          refine (!_).
          apply maponpathscomp0.
        }
        use path_inv_rotate_rl.
        refine (!(maponpathscomp0 _ _ _) @ _).
        etrans.
        {
          apply maponpaths.
          refine (path_assoc _ _ _ @ !_).
          apply IHe₁.
        }
        clear IHe₁.
        apply maponpathscomp.
      - exact (!(pathscomp0rid _ @ pathsinv0r _)).
      - exact (!(pathscomp0rid _ @ pathsinv0r _)).
      - refine (!(pathscomp0rid _ @ _)).
        etrans.
        {
          do 2 apply maponpaths.
          apply maponpaths_pr1_pathsdirprod.
        }
        apply pathsinv0r.
      - refine (!(pathscomp0rid _ @ _)).
        etrans.
        {
          do 2 apply maponpaths.
          apply maponpaths_pr2_pathsdirprod.
        }
        apply pathsinv0r.
      - refine (!(maponpaths_pathsdirprod _ _ _ _) @ _).
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                etrans.
                {
                  apply maponpaths.
                  apply maponpaths_prod_path.
                }
                apply pathsdirprod_inv.
              }
              apply pathsdirprod_concat.
            }
            apply pathsdirprod_concat.
          }
          apply pathsdirprod_concat.
        }
        refine (!_).
        exact (paths_pathsdirprod (IHe₁ _) (IHe₂ _)).
      - refine (!(pathscomp0rid _ @ _)).
        etrans.
        {
          apply maponpaths.
          apply maponpaths_for_constant_function.
        }
        apply idpath.
      - apply idpath.
      - refine (_ @ !(pathscomp0rid _)).
        etrans.
        {
          unfold prealg_map_commute ; simpl.
          unfold equalizer_ump_1_preserves_point.
          exact (maponpaths_pr1_PathOverToTotalPath'
                   (equalizer_ump_1_preserves_point_pr1 x)
                   (equalizer_ump_1_preserves_point_pr2 x)).
        }
        unfold equalizer_ump_1_preserves_point_pr1.
        apply maponpaths.
        exact (maponpathsinv0 _ _).
    Qed.

    Definition equalizer_ump_1_preserves_path
      : preserves_path _ (prealg_map_commute equalizer_ump_1_prealg).
    Proof.
      intros j x.
      refine (PathOverToTotalPath'_eta _ @ _ @ !(PathOverToTotalPath'_eta _)).
      use globe_over_to_homot.
      - unfold globe ; simpl.
        refine (maponpathscomp0
                  pr1
                  (maponpaths equalizer_ump_1_comp (alg_path C j x))
                  _
                @ _).
        refine (_ @ !(maponpathscomp0 _ _ _)).
        etrans.
        {
          apply maponpaths_2.
          apply maponpathscomp.
        }
        unfold funcomp ; simpl.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          unfold total_algebra.paths.
          apply maponpaths_pr1_PathOverToTotalPath'.
        }
        etrans.
        {
          refine (path_assoc _ _ _ @ _).
          apply maponpaths_2.
          exact (equalizer_endpoint_natural (path_left Σ j) x).
        }
        simpl.
        refine (path_assoc _ _ _ @ !_).
        use path_rotate_lr.
        refine (!(path_assoc _ _ _) @ _).
        etrans.
        {
          apply maponpaths.
          exact (equalizer_endpoint_natural (path_right Σ j) x).
        }
        simpl.
        refine (path_assoc _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          exact (alg_map_path Cpr j x).
        }
        refine (!(path_assoc _ _ _) @ _ @ path_assoc _ _ _).
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply maponpathsinv0.
        }
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply maponpathsinv0.
        }
        apply homotsec_natural'.
      - apply (pr111 B).
    Qed.

    Definition equalizer_ump_1
      : C --> equalizer.
    Proof.
      use make_algebra_map.
      use make_hit_path_alg_map.
      - exact equalizer_ump_1_prealg.
      - exact equalizer_ump_1_preserves_path.
    Defined.

    Definition equalizer_ump_pr1_component
      : alg_map_carrier (equalizer_ump_1 · equalizer_pr) ~ alg_map_carrier Cpr
      := λ _, idpath _.

    Definition equalizer_ump_1_is_algebra_2cell
      : is_algebra_2cell equalizer_ump_pr1_component.
    Proof.
      intro.
      cbn -[PathOverToTotalPath']
      ; unfold homotcomp, homotfun, funhomotsec
      ; cbn -[PathOverToTotalPath'].
      rewrite !pathscomp0rid.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths_2.
        unfold equalizer_ump_1_preserves_point, PathOverToTotalPath'
        ; apply maponpaths_pr1_PathOverToTotalPath.
      }
      unfold equalizer_ump_1_preserves_point_pr1.
      rewrite <- !path_assoc.
      refine (_ @ pathscomp0rid _).
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply maponpathscomp0.
      }
      etrans.
      {
        refine (!_).
        apply maponpathscomp0.
      }
      refine (_ @ maponpaths_idpath).
      apply maponpaths.
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        apply pathsinv0l.
      }
      simpl.
      exact (eqtohomot (psfunctor_id2 (⟦ point_constr Σ ⟧) _) _).
    Qed.

    Definition equalizer_ump_1_pr
      : equalizer_ump_1 · equalizer_pr ==> Cpr.
    Proof.
      use make_algebra_2cell.
      - exact equalizer_ump_pr1_component.
      - exact equalizer_ump_1_is_algebra_2cell.
    Defined.

    Definition equalizer_ump_1_path
      : rassociator _ _ _
        • (equalizer_ump_1 ◃ equalizer_path)
        • lassociator _ _ _
        • (equalizer_ump_1_pr ▹ g)
        =
        (equalizer_ump_1_pr ▹ f) • Cpath.
    Proof.
      use subtypePath.
      { intro ; apply isapropunit. }
      use subtypePath.
      { intro ; use impred ; intro ; apply isapropunit. }
      use subtypePath.
      { intro ; apply one_types. }
      use funextsec ; intro c.
      cbn ; unfold homotcomp, homotfun, funhomotsec ; cbn.
      exact (pathscomp0rid _ @ pathscomp0rid _).
    Qed.
  End EqualizerUMP1.

  Section EqualizerUMP2.
    Context {C : hit_algebra_one_types Σ}
            {Cpr : C --> A}
            {Cpath : Cpr · f ==> Cpr · g}
            (φ ψ : C --> equalizer)
            (φpr : φ · equalizer_pr ==> Cpr)
            (ψpr : ψ · equalizer_pr ==> Cpr)
            (φpath : rassociator _ _ _
                     • (φ ◃ equalizer_path)
                     • lassociator _ _ _
                     • (φpr ▹ g)
                     =
                     (φpr ▹ f) • Cpath)
            (ψpath : rassociator _ _ _
                     • (ψ ◃ equalizer_path)
                     • lassociator _ _ _
                     • (ψpr ▹ g)
                     =
                     (ψpr ▹ f) • Cpath).

    Definition equalizer_ump_2_on_pr1
               (c : alg_carrier C)
      : pr1 (alg_map_carrier φ c) = pr1 (alg_map_carrier ψ c)
      := pr111 φpr c @ !(pr111 ψpr c).

    Definition equalizer_ump_2_on_pr2
               (c : alg_carrier C)
      : PathOver
          (equalizer_ump_2_on_pr1 c)
          (pr2 (alg_map_carrier φ c))
          (pr2 (alg_map_carrier ψ c)).
    Proof.
      apply map_PathOver ; unfold square.
      assert (equalizer_path_component (alg_map_carrier φ c)
              @ maponpaths (alg_map_carrier g) (alg_2cell_carrier φpr c)
              =
              maponpaths (alg_map_carrier f) (alg_2cell_carrier φpr c)
              @ alg_2cell_carrier Cpath c)
        as X.
      {
        refine (_ @ alg_2cell_eq_component φpath c).
        cbn.
        unfold homotcomp, homotfun, funhomotsec.
        cbn.
        rewrite pathscomp0rid.
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        etrans.
        {
          apply maponpaths.
          apply maponpathscomp0.
        }
        refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        exact X.
      }
      clear X.
      refine (!(path_assoc _ _ _) @ _).
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply maponpathscomp0.
      }
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply maponpathsinv0.
      }
      use path_inv_rotate_ll.
      refine (_ @ !(path_assoc _ _ _)).
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply maponpathsinv0.
      }
      use path_inv_rotate_lr.
      assert (equalizer_path_component (alg_map_carrier ψ c)
              @ maponpaths (alg_map_carrier g) (alg_2cell_carrier ψpr c)
              =
              maponpaths (alg_map_carrier f) (alg_2cell_carrier ψpr c)
              @ alg_2cell_carrier Cpath c)
        as X.
      {
        refine (_ @ alg_2cell_eq_component ψpath c).
        cbn.
        unfold homotcomp, homotfun, funhomotsec.
        cbn.
        rewrite pathscomp0rid.
        apply idpath.
      }
      exact (!X).
    Qed.

    Definition equalizer_ump_2_component
      : alg_map_carrier φ ~ alg_map_carrier ψ.
    Proof.
      intro c.
      use PathOverToTotalPath'.
      - exact (equalizer_ump_2_on_pr1 c).
      - exact (equalizer_ump_2_on_pr2 c).
    Defined.

    Definition equalizer_ump_2_is_algebra_2cell
      : is_algebra_2cell equalizer_ump_2_component.
    Proof.
      intro z.
      etrans.
      {
        apply maponpaths.
        apply PathOverToTotalPath'_eta.
      }
      unfold equalizer_ump_2_component.
      etrans.
      {
        apply PathOverToTotalPath'_comp.
      }
      refine (_ @ !(PathOverToTotalPath'_eta _)).
      use globe_over_to_homot.
      - unfold globe ; simpl.
        refine (!_).
        etrans.
        {
          etrans.
          {
            exact (maponpathscomp0 pr1 (alg_map_commute φ z) (maponpaths _ _)).
          }
          etrans.
          {
            apply maponpaths.
            apply maponpathscomp.
          }
          unfold funcomp.
          simpl.
          apply idpath.
        }
        refine (!_).
        unfold  equalizer_ump_2_on_pr1.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              exact (!(pathscomp0rid _)).
            }
            apply maponpaths.
            exact (!(pathsinv0r (alg_map_commute Cpr z))).
          }
          etrans.
          {
            etrans.
            {
              apply maponpaths_2.
              exact (path_assoc _ _ _).
            }
            exact (!(path_assoc _ _ _)).
          }
          etrans.
          {
            apply maponpaths_2.
            pose (eqtohomot (pr211 φpr) z) as p.
            cbn in p.
            unfold homotcomp, funhomotsec, homotfun in p.
            cbn in p.
            rewrite !pathscomp0rid in p.
            exact p.
          }
          apply maponpaths.
          etrans.
          {
            refine (!_).
            apply pathscomp_inv.
          }
          pose (eqtohomot (pr211 ψpr) z) as p.
          cbn in p.
          unfold homotcomp, funhomotsec, homotfun in p.
          cbn in p.
          rewrite !pathscomp0rid in p.
          apply maponpaths.
          exact p.
        }
        rewrite !pathscomp_inv.
        rewrite <- !path_assoc.
        apply maponpaths.
        rewrite pathsinv0l, pathscomp0rid.
        rewrite <- !maponpathsinv0.
        rewrite <- !maponpathscomp0.
        refine (!_).
        etrans.
        {
          refine (!_).
          apply maponpathscomp.
        }
        apply maponpaths.
        unfold poly_pr1.
        etrans.
        {
          apply maponpaths_poly_homot.
        }
        apply maponpaths.
        refine (_ @ !(path_assoc _ _ _)).
        apply maponpaths_2.
        etrans.
        {
          refine (maponpaths (λ q, poly_homot _ q z) _).
          use funextsec.
          intro q.
          apply maponpaths_pr1_PathOverToTotalPath'.
        }
        etrans.
        {
          exact (eqtohomot
                   (psfunctor_vcomp
                      (⟦ point_constr Σ ⟧)
                      (alg_2cell_carrier φpr)
                      (invhomot (alg_2cell_carrier ψpr)))
                   z).
        }
        refine (maponpaths (λ q, _ @ q) _).
        apply poly_homot_inv.
      - apply (one_type_isofhlevel (pr111 B)).
    Qed.

    Definition equalizer_ump_2
      : φ ==> ψ.
    Proof.
      use make_algebra_2cell.
      - exact equalizer_ump_2_component.
      - exact equalizer_ump_2_is_algebra_2cell.
    Defined.

    Definition equalizer_ump_2_pr
      : equalizer_ump_2 ▹ equalizer_pr • ψpr = φpr.
    Proof.
      use algebra_2cell_eq.
      intro c.
      cbn.
      unfold homotcomp, homotfun, equalizer_ump_2_component.
      etrans.
      {
        apply maponpaths_2.
        unfold PathOverToTotalPath' ; apply maponpaths_pr1_PathOverToTotalPath.
      }
      unfold equalizer_ump_2_on_pr1.
      refine (!(path_assoc _ _ _) @ _ @ pathscomp0rid _).
      apply maponpaths.
      apply pathsinv0l.
    Qed.
  End EqualizerUMP2.

  Section EqualizerUMPEq.
    Context {C : hit_algebra_one_types Σ}
            {Cpr : C --> A}
            {Cpath : Cpr · f ==> Cpr · g}
            (φ ψ : C --> equalizer)
            (φpr : φ · equalizer_pr ==> Cpr)
            (ψpr : ψ · equalizer_pr ==> Cpr)
            (φpath : rassociator _ _ _
                     • (φ ◃ equalizer_path)
                     • lassociator _ _ _
                     • (φpr ▹ g)
                     =
                     (φpr ▹ f) • Cpath)
            (ψpath : rassociator _ _ _
                     • (ψ ◃ equalizer_path)
                     • lassociator _ _ _
                     • (ψpr ▹ g)
                     =
                     (ψpr ▹ f) • Cpath)
            (τ θ : φ ==> ψ)
            (τpr : τ ▹ equalizer_pr • ψpr = φpr)
            (θpr : θ ▹ equalizer_pr • ψpr = φpr).

    Definition equalizer_ump_eq
      : τ = θ.
    Proof.
      use algebra_2cell_eq.
      intro z.
      assert (maponpaths pr1 ((pr111 τ) z)
              =
              alg_2cell_carrier φpr z @ !(pr111 ψpr z)) as p.
      {
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          exact (!(alg_2cell_eq_component τpr z)).
        }
        refine (!(path_assoc _ _ _) @ _ @ pathscomp0rid _).
        apply maponpaths.
        apply pathsinv0r.
      }
      assert (maponpaths pr1 ((pr111 θ) z)
              =
              alg_2cell_carrier φpr z @ !(pr111 ψpr z)) as q.
      {
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          exact (!(alg_2cell_eq_component θpr z)).
        }
        refine (!(path_assoc _ _ _) @ _ @ pathscomp0rid _).
        apply maponpaths.
        apply pathsinv0r.
      }
      refine (PathOverToTotalPath'_eta _ @ _ @ !(PathOverToTotalPath'_eta _)).
      use globe_over_to_homot.
      - exact (p @ !q).
      - apply (one_type_isofhlevel (pr111 B)).
    Qed.
  End EqualizerUMPEq.
End Equalizer.


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

(***
Modulus : 2^416 - 2^208 - 1
Base: 23 + 1/9
***)

Definition curve : CurveParameters :=
  {|
    sz := 18%nat;
    base := 23 + 1/9;
    bitwidth := 32;
    s := 2^416;
    c := [(1, 1); (2^208, 1)];
    carry_chains := Some [[8; 17]; [9; 0; 10; 1; 11; 2; 12; 3; 13; 4; 14; 5; 15; 6; 16; 7; 17; 8]; [9; 0]]%nat;

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

    goldilocks := Some true;
    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.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import  Coq.Lists.List.

Import ListNotations.

Module Vec1.
  Section Vector.
    Context (A: Type).
    Inductive Vector : nat -> Type :=
    | vec : forall (xs : list A), Vector (length xs).

    Definition nil : Vector 0 := vec [].

    Definition cons {n : nat} (x:A) (xs: Vector n): Vector (1 + n) :=
      match xs with
      | vec xs' => vec (x::xs')
      end.
  End Vector.

  Compute (cons nat 0 (cons nat 1 (cons nat 2 (nil nat)))).
End Vec1.

Module Vec2.
  Section Vector.
    Context (A: Type).
    Inductive Vector : nat -> Type :=
    | vec : forall (xs : list A) (len: nat), len = length xs -> Vector len.

    Definition nil : Vector 0 := vec [] _ eq_refl.

    Definition cons {n : nat} (x:A) (xs: Vector n): Vector (S n).
      refine (
      match xs with
      | vec xs' len h => vec (x::xs') _ _
      end).
      abstract (rewrite h; reflexivity).
    Defined.
  End Vector.

  Compute (cons nat 0 (cons nat 1 (cons nat 2 (nil nat)))).
End Vec2.


Set Implicit Arguments.
Require Import List Lia.
Import ListNotations.
From Undecidability.HOU Require Import calculus.terms calculus.prelim std.std.

(* * Syntax *)
Definition isVar X (e: exp X) :=
  match e with var _ => True | _ => False end.

Definition isLam X (e: exp X) :=
  match e with lambda _ => True | _ => False end.

Definition isApp X (e: exp X) :=
  match e with app _ _ => True | _ => False end.

Definition isAtom X (e: exp X) :=
  match e with lambda _ => False | app _ _ => False | _ => True end.

Ltac syn :=
  match goal with
  | [H1: isVar ?X, H2: isLam ?X |- _] => solve [destruct X; cbn in *; intuition]
  | [H1: isVar ?X, H2: isApp ?X |- _] => solve [destruct X; cbn in *; intuition]
  | [H1: isApp ?X, H2: isLam ?X |- _] => solve [destruct X; cbn in *; intuition]
  | [H1: isApp ?X, H2: isAtom ?X |- _] => solve [destruct X; cbn in *; intuition]
  | [H1: isLam ?X, H2: isAtom ?X |- _] => solve [destruct X; cbn in *; intuition]
  | [ |- isLam (lambda _)] => constructor
  | [ |- isApp (app _ _)] => constructor
  | [ |- isAtom (var _)] => constructor
  | [ |- isAtom (const _)] => constructor
  | [ |- isVar (var _)] => constructor
  end.

(* ** Atoms *)
Section Atoms.

  Variable (X: Const).

  Lemma atom_lifting (s: exp X) (sigma: fin -> exp X):
    (forall x, isAtom (sigma x)) -> isAtom s -> isAtom (sigma • s).
  Proof.
    induction s in sigma |-*; cbn; intuition.
  Qed.

  Lemma atom_var (s: exp X):
    isVar s -> isAtom s.
  Proof.
    destruct s; cbn in *; intuition.
  Qed.

End Atoms.

Ltac atom :=
  match goal with
  | [ |- isAtom _] => cbn in *; intuition
  end.

#[export] Hint Extern 4 => syn : core.

Section DiscreteTypes.

  #[export] Instance Const_dis (C: Const) : Dis C.
  Proof.
    eapply const_dis.
  Qed.

  #[export] Instance exp_dis X: Dis (exp X).
  Proof.
    intros ??; unfold Dec; decide equality. decide equality. eapply const_dis.
  Qed.

  #[export] Instance type_dis: Dis type.
  Proof.
    intros ??; unfold Dec; decide equality; decide equality.
  Qed.

End DiscreteTypes.

(* ** Applicative Head *)
Section ApplicativeHead.

  Variable (X: Const).

  Fixpoint head (e: exp X) :=
    match e with
    | const b => const b
    | var x => var x
    | lambda s => lambda s
    | app e1 e2 => head e1
    end.

  Lemma var_head (s: exp X):
    isVar s -> isVar (head s).
  Proof.
    destruct s; cbn; intuition.
  Qed.

  Lemma atom_head (s: exp X):
    isAtom s -> isAtom (head s).
  Proof.
    destruct s; cbn; intuition.
  Qed.

  Lemma atom_head_lifting (s: exp X) (sigma: fin -> exp X):
    (forall x, isAtom (head (sigma x))) -> isAtom (head s) -> isAtom (head (sigma • s)).
  Proof.
    induction s; cbn; intuition.
  Qed.

  Lemma head_subst (s: exp X) sigma:
   (forall x, ~ isApp (sigma x))  -> sigma • (head s) = head (sigma • s).
  Proof.
    intros H; induction s.
    - cbn; specialize (H f).
      destruct (sigma f); cbn in *; intuition.
    - reflexivity.
    - reflexivity.
    - cbn; congruence.
  Qed.

End ApplicativeHead.

#[export] Hint Resolve atom_var var_head atom_head : core.

(* ** Type Functions *)
Section TypeFunctions.

  Fixpoint target (A: type) :=
    match A with
    | typevar beta => typevar beta
    | A → B => target B
    end.

  Definition target' (Gamma: list type) :=  map target Gamma.

  Fixpoint arity (A: type) :=
    match A with
    | typevar _ => 0
    | A → B => S (arity B)
    end.

End TypeFunctions.

(* ** Free Variables *)
Section FreeVariables.
  Context {X: Const}.

  Fixpoint vars (s: exp X) :=
    match s with
    | var x => [x]
    | const x => nil
    | lambda s => map pred (remove eq_dec 0 (vars s))
    | app s1 s2 => vars s1 ++ vars s2
    end.

  Inductive varof (x: nat) : exp X -> Prop :=
  | varofVar: varof x (var x)
  | varofAppL (s t: exp X): varof x s -> varof x (s t)
  | varofAppR (s t: exp X): varof x t -> varof x (s t)
  | varofLambda s: varof (S x) s -> varof x (lambda s).

  Hint Constructors varof : core.

  Lemma varof_vars x s:
    varof x s -> x ∈ vars s.
  Proof.
    induction 1; cbn; eauto.
    1 - 2: eapply in_app_iff; intuition.
    eapply in_map_iff. exists (S x). intuition.
    eapply remove_remain; eauto.
  Qed.

  Lemma vars_varof x s:
    x ∈ vars s -> varof x s.
  Proof.
    induction s in x |-*; cbn; intuition.
    - subst; eauto.
    - econstructor. eapply IHs.
      mapinj. destruct x0.
      + eapply remove_In in H1; intuition.
      + cbn. now eapply remove_prev in H1.
    - simplify in H; intuition.
  Qed.

  Hint Resolve varof_vars vars_varof : core.

  #[export] Instance dec_varof: Dec2 (varof).
  Proof.
    intros x s; eapply iff_dec with (P := x ∈ vars s);
      intuition idtac; auto with typeclass_instances.
  Qed.

  Lemma subst_extensional sigma tau s:
    (forall x, x ∈ vars s -> sigma x = tau x) -> sigma • s = tau • s.
  Proof.
    induction s in sigma, tau |-*; eauto.
    - intros H; cbn; f_equal; eapply IHs.
      intros [] ?; cbn; eauto.
      unfold funcomp; rewrite H; eauto.
    - intros; cbn; erewrite IHs1, IHs2; eauto.
  Qed.

  Lemma varof_ren f x (s: exp X):
    varof x (ren f s) -> exists y, x = f y /\ varof y s.
  Proof.
    induction s in x, f |-*; cbn; intuition.
    - exists f0; intuition. now inv H.
    - inv H.
    - inv H. eapply IHs in H1 as [].
      intuition. destruct x0; try discriminate.
      exists x0. intuition.
    - inv H; [edestruct IHs1 | edestruct IHs2]; eauto; eexists; intuition; eauto.
  Qed.

  Lemma vars_ren f x s:
    x ∈ vars (ren f s) -> exists y, x = f y /\ y ∈ vars s.
  Proof.
    intros; edestruct varof_ren as [y]; [|exists y]; intuition; eauto.
  Qed.

  Lemma varof_subst x sigma (s: exp X):
    varof x (sigma • s) -> exists y, varof y s /\ varof x (sigma y).
  Proof.
    induction s in sigma, x |-*; cbn.
    - intros; exists f; intuition.
    - inversion 1.
    - intros H; inv H. eapply IHs in H1 as []; intuition.
      destruct x0; cbn in *. inv H1.
      exists (x0); intuition. unfold funcomp in H1.
      now eapply varof_ren in H1 as [y [[= ->] ?]].
    - intros H; inv H; [edestruct IHs1 | edestruct IHs2]; eauto; eexists; intuition; eauto.
  Qed.

    Lemma vars_subst sigma x s:
    x ∈ vars (sigma • s) -> exists y, y ∈ vars s /\ x ∈ vars (sigma y).
  Proof.
    intros; edestruct varof_subst as [y]; [|exists y]; intuition; eauto.
  Qed.

  Lemma ren_varof x f (s: exp X):
    varof x s -> varof (f x) (ren f s).
  Proof.
    enough (varof x s -> forall y, y = f x -> varof y (ren f s)) by eauto.
    induction 1 in f |-*; cbn; eauto.
    - intros ? ->; eauto.
    - intros ? ->; econstructor; now eapply IHvarof.
  Qed.

  Lemma ren_vars x f (s: exp X):
    x ∈ vars s -> f x ∈ vars (ren f s).
  Proof.
    eauto using ren_varof.
  Qed.

  Lemma subst_varof x sigma y (s: exp X):
    varof y s -> varof x (sigma y) -> varof x (sigma • s).
  Proof.
    induction 1 in sigma, x |-*; cbn; eauto.
    intros H'; econstructor; eapply IHvarof; cbn; unfold funcomp.
    now eapply ren_varof.
  Qed.

  Lemma subst_vars x sigma y (s: exp X):
    y ∈ vars s -> x ∈ vars (sigma y) -> x ∈ vars (sigma • s).
  Proof.
    eauto using subst_varof.
  Qed.

End FreeVariables.

#[export] Hint Constructors varof : core.
#[export] Hint Resolve varof_vars vars_varof : core.


Inductive prodTactic (A : Type) (B : Type) : Type :=  pairTactic : A -> B -> prodTactic A B.
Implicit Arguments pairTactic [A B].
Inductive unitTactic : Type := ttTactic : unitTactic.

Notation "[ x , y , .. , z ]" := (pairTactic .. (pairTactic x y) .. z) (at level 1) : tactic_scope.

Open Scope tactic_scope.

Ltac taclistFwd tac l :=
match type of l with
|(prodTactic _ _) =>
 match l with
 |(pairTactic ?y ?a) => taclistFwd tac y; taclistFwd tac a
 end
|_=>tac l
end.

Ltac taclistRev tac l :=
match type of l with
|(prodTactic _ _) =>
 match l with
 |(pairTactic ?y ?a) => taclistRev tac a; taclistRev tac y
 end
|_=>tac l
end.

Ltac discharge x :=
 let dischargeOne a := generalize a; clear a in
  taclistRev dischargeOne x.

Ltac gen expr lst :=
match type of lst with
|(prodTactic _ _) =>
 match lst with
 |(pairTactic ?p ?q) => let first := gen expr q in gen first p
 end
|_ =>
  match (eval pattern lst in expr) with
    (?f ?z) =>
     let Z := type of lst
     in  constr:(forall n:Z, f n)
  end
end.

Ltac introNames :=
match goal with
H : unitTactic |- _ => clear H; intro H; introNames
|_ => idtac
end.

Ltac wlog nn expr lst :=
match goal with
| |- ?g =>
 let full := gen (expr -> g) lst in
 cut full;
 [intro | let c x := clear x; pose (x:=ttTactic) in taclistRev c lst; introNames; intro nn]
end.

(*
Goal forall a b c:nat, a + b = c.
intros.
wlog (0<a/\0<b) [a,b].
Show 2.
discharge [c,b,a].

Goal forall a b c:nat, {a<b}+{b< a} ->{c : nat | a + b = c}.
intros.
discharge c.
discharge {b,a, H}.
*)


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 P Q R S T U V W X Y I : Universe, ((wd_ P T /\ (wd_ T Q /\ (wd_ R T /\ (wd_ T S /\ (wd_ Q U /\ (wd_ U R /\ (wd_ P W /\ (wd_ P U /\ (wd_ U I /\ (wd_ Q S /\ (wd_ S R /\ (wd_ Q R /\ (wd_ P Q /\ (wd_ P S /\ (wd_ P I /\ (wd_ P Y /\ (col_ I Q S /\ (col_ I Q R /\ (col_ P U I /\ (col_ P I Y /\ (col_ X Q Y /\ (col_ P U Y /\ (col_ P V X /\ (col_ U W V /\ (col_ P W Q /\ (col_ Q U R /\ (col_ R T S /\ (col_ P T Q /\ col_ P R V)))))))))))))))))))))))))))) -> col_ Q S R)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 A C G H P Q R D : Universe, ((wd_ G H /\ (wd_ G A /\ (wd_ G C /\ (wd_ H A /\ (wd_ H C /\ (wd_ C D /\ (wd_ H D /\ (wd_ P Q /\ (wd_ Q R /\ (wd_ P R /\ (col_ D G H /\ (col_ C H D /\ col_ P Q R)))))))))))) -> col_ G H C)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

(***
Modulus : 2^174 - 17
Base: 21.75
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 21 + 3/4;
    bitwidth := 32;
    s := 2^174;
    c := [(1, 17)];
    carry_chains := Some [seq 0 (pred 8); [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.


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

End FOFProblem.


Require Import Coq.Logic.Classical Rules DataTypes MsiState L1 Omega Coq.Relations.Relation_Operators Coq.Lists.Streams DataTypes.

Module mkL1Axioms : L1Axioms mkDataTypes.
  Import mkDataTypes.

  Theorem deqOrNot: forall t, {x| deqR (fst (fst x)) (snd (fst x)) (snd x) t} + {forall a c i, ~ deqR a c i t}.
  Proof.
    intros t.
    unfold deqR.
    destruct (trans oneBeh t).
    (left; apply (exist _ (a, c, (req (sys oneBeh t) a c)))); intuition.
    (left; apply (exist _ (a, c, (req (sys oneBeh t) a c)))); intuition.
    right; intuition.
    right; intuition.
    right; intuition.
    right; intuition.
    right; intuition.
    right; intuition.
    right; intuition.
    right; intuition.
  Qed.

  Theorem deqLeaf: forall {c a i t}, deqR a c i t -> leaf c.
  Proof.
    intros c a i t deqr.
    unfold deqR in deqr.
    destruct (trans oneBeh t);
      (simpl in *; destruct (decTree c c0) as [eq|notEq];
       [rewrite eq in *; intuition| intuition]);
      assert (c = c0) by auto; intuition.
  Qed.

  Theorem deqDef: forall {c a i t}, deqR a c i t -> defined c.
  Proof.
    intros c a i t deqr.
    unfold deqR in deqr.
    destruct (trans oneBeh t);
    (simpl in *; destruct (decTree c c0) as [eq|notEq]; [rewrite eq in *; firstorder| firstorder]);
    assert (c = c0) by auto; firstorder.
  Qed.

  Theorem uniqDeqProc: forall {c a i1 t i2},
                       deqR a c i1 t -> deqR a c i2 t ->
                       i1 = i2.
  Proof.
    intros c a i1 t i2 deq1 deq2.
    unfold deqR in *.
    destruct (trans oneBeh t); intuition.
  Qed.

  Theorem processDeq: forall {c a i t}, deqR a c i t ->
                                      let q := reqFn a c i in
                                      match desc q with
                                        | Ld => sle Sh (state c a t)
                                        | St => state c a t = Mo
                                      end.
  Proof.
    intros c a i t deqr.
    unfold state.
    unfold deqR in *.
    destruct (trans oneBeh t).

    destruct deqr as [e1 [eq u1]].
    rewrite e1 in *.
    rewrite eq in *.
    rewrite u1 in *.
    rewrite e in *.
    assumption.

    destruct deqr as [e1 [eq u1]].
    rewrite e1 in *.
    rewrite eq in *.
    rewrite u1 in *.
    rewrite e in *.
    assumption.

    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
    simpl in *; firstorder.
  Qed.

  Theorem reqGe: forall {c a t1 t2}, t1 <= t2 -> req (sys oneBeh t2) a c >= req (sys oneBeh t1) a c.
  Proof.
    intros c a t1 t2 le.
    remember (t2 - t1) as td.
    assert (t2 = t1 + td) by omega.
    rewrite H in *; clear le Heqtd H.
    induction td.
    assert (t1 + 0 = t1) by omega.
    rewrite H.
    omega.
    assert (t1 + S td = S (t1 + td)) by omega.
    rewrite H; clear H.
    assert (req (sys oneBeh (S (t1 + td))) a c >= req (sys oneBeh (t1 + td)) a c).
    destruct (trans oneBeh (t1 + td)).

    simpl.
    destruct (decAddr a a0); destruct (decTree c c0); omega.
    simpl.
    destruct (decAddr a a0); destruct (decTree c c0); omega.
    simpl.
    omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
    simpl; omega.
  Qed.

  Theorem reqGeConv: forall {c a t1 t2}, req (sys oneBeh t1) a c < req (sys oneBeh t2) a c -> t1 < t2.
  Proof.
    intros c a t1 t2 reqEq.
    assert (t1 >= t2 \/ t1 < t2) by omega.
    destruct H.
    pose proof (@reqGe c a _ _ H) as contra; omega.
    assumption.
  Qed.

  Theorem reqGt: forall {c a i t1 t2}, t1 < t2 -> deqR a c i t1 ->
                                     req (sys oneBeh t2) a c > i.
  Proof.
    intros c a i t1 t2 cond deqr.
    assert (S t1 <= t2) by omega.
    assert (req (sys oneBeh (S t1)) a c > i).
    unfold deqR in *.
    destruct (trans oneBeh t1).
    simpl.
    destruct deqr as [eq1 [eq sth]].
    rewrite eq1, eq in *.
    destruct (decAddr a a); destruct (decTree c c).
    rewrite sth; omega.
    firstorder.
    firstorder.
    firstorder.
    simpl.
    destruct deqr as [eq1 [eq sth]].
    rewrite eq1, eq in *.
    destruct (decAddr a a); destruct (decTree c c).
    rewrite sth; omega.
    firstorder.
    firstorder.
    firstorder.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    pose proof (@reqGe c a _ _ H).
    omega.
  Qed.

  Theorem uniqDeqProc2: forall {c a i t1 t2},
                        deqR a c i t1 -> deqR a c i t2 -> t1 = t2.
  Proof.
    intros c a i t1 t2 deq1 deq2.
    unfold Time in *.
    assert (t1 = t2 \/ t1 < t2 \/ t2 < t1) by omega.
    destruct H as [e1 | [e2 | e3]].
    assumption.
    pose proof (reqGt e2 deq1).
    unfold deqR in deq2.
    destruct (trans oneBeh t2).
    destruct deq2 as [_ u2].
    omega.
    destruct deq2 as [_ u2].
    omega.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    pose proof (reqGt e3 deq2).
    unfold deqR in deq1.
    destruct (trans oneBeh t1).
    destruct deq1 as [_ u2].
    omega.
    destruct deq1 as [_ u2].
    omega.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
  Qed.

  Theorem uniqDeqProc3: forall {c1 a1 i1 t c2 a2 i2},
                          deqR a1 c1 i1 t -> deqR a2 c2 i2 t ->
                          a1 = a2 /\ c1 = c2 /\ i1 = i2.
  Proof.
    intros c1 a1 i1 t c2 a2 i2 deq1 deq2.
    unfold deqR in *.
    destruct (trans oneBeh t).
    destruct deq2 as [x [y z]].
    destruct deq1 as [x1 [y1 z1]].
    rewrite <- x, <- y, <- x1, <- y1 in *.
    intuition.
    destruct deq2 as [x [y z]].
    destruct deq1 as [x1 [y1 z1]].
    rewrite <- x, <- y, <- x1, <- y1 in *.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
  Qed.

  Theorem incReqImpDeq: forall {c a t i},
                           req (sys oneBeh t) a c > i ->
                           exists t', t' < t /\ deqR a c i t'.
  Proof.
    intros c a t i reqEq.
    induction t.
    pose proof (init oneBeh) as sth.
    rewrite sth in reqEq; clear sth.
    unfold initGlobalState in *; simpl in *.
    omega.
    assert (inc:req (sys oneBeh (S t)) a c = req (sys oneBeh t) a c \/
                req (sys oneBeh (S t)) a c = S (req (sys oneBeh t) a c)).
    destruct (trans oneBeh t).
    simpl in *.
    destruct (decAddr a a0); destruct (decTree c c0).
    right.
    intuition.
    intuition.
    intuition.
    intuition.
    simpl in *.
    destruct (decAddr a a0); destruct (decTree c c0).
    right.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.
    simpl in *; left; intuition.

    destruct inc.
    rewrite H in reqEq.
    specialize (IHt reqEq).
    destruct IHt as [t' [t'_lt_t deq]].
    exists t'.
    assert (t' < S t) by omega; intuition.
    rewrite H in reqEq.
    assert (opts: req (sys oneBeh t) a c > i \/ req (sys oneBeh t) a c = i) by omega.
    destruct H.
    destruct opts.
    specialize (IHt H).
    destruct IHt as [t' [t'_lt_t deq]].
    exists t'.
    constructor.
    omega.
    assumption.

    rewrite <- H in *; clear H.
    exists t.
    constructor.
    omega.

    unfold deqR.
    destruct (trans oneBeh t).
    simpl in *.
    destruct (decAddr a a0); destruct (decTree c c0).
    constructor; auto.
    omega.
    omega.
    omega.
    simpl in *.
    destruct (decAddr a a0); destruct (decTree c c0).
    constructor; auto.
    omega.
    omega.
    omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
    simpl in *; omega.
  Qed.

  Theorem deqImpDeqBefore: forall {c a i1 i2 t},
                             deqR a c i1 t -> i2 < i1 -> exists t', t' < t /\ deqR a c i2 t'.
  Proof.
    intros c a i1 i2 t deq i2_lt_i1.
    unfold deqR in deq.
    destruct (trans oneBeh t).
    destruct deq as [e1 [eq sth]].
    rewrite e1, eq in *.
    rewrite <- sth in *.
    pose proof (incReqImpDeq i2_lt_i1) as [x [z y]]; exists x; intuition.
    destruct deq as [e1 [eq sth]].
    rewrite e1,eq in *.
    rewrite <- sth in *.
    pose proof (incReqImpDeq i2_lt_i1) as [x [z y]]; exists x; intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
  Qed.

  Theorem deqOrder: forall {c a i1 t1 i2 t2},
                      deqR a c i1 t1 -> deqR a c i2 t2 ->
                      i1 < i2 -> ~ t1 > t2.
  Proof.
    unfold not; intros c a i1 t1 i2 t2 deq1 deq2 iLess t2Less.
    pose proof (reqGt t2Less deq2).
    unfold deqR in deq1.
    destruct (trans oneBeh t1).
    destruct deq1 as [_ u]; omega.
    destruct deq1 as [_ u]; omega.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
  Qed.
End mkL1Axioms.


From Coq.Lists Require Import List.
From mathcomp Require Import ssreflect ssrfun ssrbool seq eqtype ssrnat.
From istari Require Import basic_types basic_types0 source subst_src rules_src
     derived_rules help subst_help0 subst_help.
From istari Require Import Sigma Tactics
     Syntax Subst SimpSub Promote Hygiene
     ContextHygiene Equivalence Rules Defined.

(*moveGamma almost definitely wrong because it assumes Gamma starts from beginning of
 context (var 0) where as there's probably more stuff at the end
 probably need to pass in a starting index to move Gamma
 best to work this out when you can test in real time whether its working when you're
 at there in a proof*)

(*functions which take in the world and give you the type*)
(*make_ref: tau in source -> (translation of ref tau into target)*)

Fixpoint  trans_type (w1 l1: Syntax.term obj) (tau : source.term) {struct tau}: (Syntax.term obj)
  :=
    match tau with
        nattp_m => nattp
      | unittp_m => unittp
      | arrow_m A B => all nzero preworld (pi nattp (*u := 1, l := 0*)
                                        (let u := var 1 in
                                        let l := var 0 in
                                        arrow (subseq (shift 2 w1) (shift 2 l1) u l) (arrow (trans_type u l A) (trans_type u l B))
                                    ))
                          (*does NOT send the refs to comp ref*)
      | reftp_m tau' => sigma nattp ( (* i := 0*)
           let i := (var 0) in
            prod (lt_t i (subst sh1 l1))
                 (all nzero preworld (*wl1:= 2, i := 1, v := 0*)
                      (pi nattp (*wl1:= 3, i := 2, v := 1, lv := 0*)
                      (
            let w := (shift 3 w1) in
            let l1 := (shift 3 l1) in
            let i := (var 2) in
            let v := (var 1) in
            let lv := (var 0) in
          eqtype (app (app (app w i) (next v)) (next lv))
                 (fut (trans_type v lv tau' ))
                      )
                 ))
            )

      | comp_m tau' => subst1 l1 (all nzero preworld((* l1 = 1, u  := var 0. this substitution must go under.*)
                      pi nattp  (*l1 := 2, u = 1, l := 0*)   (
                                                       let l1 := Syntax.var 2 in
                                                       let u := Syntax.var 1 in
                                                       let l := Syntax.var 0 in
                                                       let U := (ppair u l) in
                                                       arrow (subseq (shift 3 w1) l1 u l)
 (*compm1_Type starts here*)                        (arrow (store u l)
                         (laters (exist nzero preworld ((* l1 = 3, u := 2, l:= 1, v = 0*)
                                          sigma nattp (*l1 = 4 u := 3, l := 2, v= 1, lv := 0*)
                                          (let u := Syntax.var 3 in
                                              let l := Syntax.var 2 in
                                              let v := Syntax.var 1 in
                                              let lv := Syntax.var 0 in
                                              (*u = 4, l = 3, subseq = 2, v = 1, lv = 0*)
                                                    prod (prod (subseq u l v lv) (store v lv))
                                                     (trans_type v lv tau'))))
                                    )
                       ))
                      ))
      | _ => unittp end.

(*no free variables in translation of types*)
Lemma subst_trans_type :forall A w l s,
    subst s w = w ->
    subst s l = l ->
    (subst s (trans_type w l A)) = (trans_type w l A).
   induction A; intros; simpl; auto; simpsub_big; simpl;  try rewrite ! subst_compose ! H ! H0.
  - (*arrow*)
    suffices:  ((subst
                (dot (var 0) (dot (var 1) (compose s (sh 2))))
                (trans_type (var 1) (var 0) A1)) = (trans_type (var 1) (var 0) A1)) /\ ((subst
                (dot (var 0) (dot (var 1) (compose s (sh 2))))
                (trans_type (var 1) (var 0) A2)) = (trans_type (var 1) (var 0) A2)). move => [Heq1 Heq2].
    rewrite Heq1 Heq2. auto. simpsub_big.
     split; [eapply IHA1 | eapply IHA2]; simpsub; auto.
  - (*comp*)
 suffices: (
            (subst
                            (dot (var 0)
                               (dot (var 1)
                                  (dot (var 2)
                                     (dot (var 3)
                                        (dot
                                           (subst (sh 4) l)
                                           (compose s (sh 4)))))))
                            (trans_type (var 1) (var 0) A)
            ) = subst
                            (dot (var 0)
                               (dot
                                 (var 1)
                                 (dot
                                 (var 2)
                                 (dot
                                 (var 3)
                                 (dot
                                 (subst (sh 4) l)
                                 (sh 4))))))
                            (trans_type
                               (var 1)
                               (var 0) A)

          ).
move => Heq.
rewrite Heq. unfold subst1. auto. repeat rewrite IHA; simpsub; auto.
  - (*ref*)
    suffices: (subst
                      (dot (var 0)
                         (dot (var 1)
                            (dot (var 2) (compose s (sh 3)))))
                      (trans_type (var 1) (var 0) A)) =
              (trans_type (var 1) (var 0) A).
    move => Heq. rewrite Heq. auto. simpsub_big.
eapply IHA. simpsub. auto. simpsub. auto.
Qed.
Ltac simpsub_type := simpl; simpsub_big; simpl; rewrite subst_trans_type; simpl.

  (*start here automate these ugly cases*)
Lemma sh_trans_type : forall w l A s,
    (subst (sh s) (trans_type w l A)) = (trans_type
                                           (subst (sh s) w)
                                           (subst (sh s) l) A).
  induction A; intros; simpl; auto; simpsub_big; repeat rewrite plusE;
repeat rewrite - addnA;
    simpl; change (1 + 1) with 2;
      replace (1 + 0) with 1; auto; repeat rewrite subst_trans_type; auto.
Qed.

(*start here write ltac for these two*)
 Lemma subst1_trans_type : forall w l A s,
    (subst1 s (trans_type w l A)) = (trans_type
                                            (subst1 s w)
                                         (subst1 s l) A).
  induction A; intros; simpl; auto; simpsub_big; auto; try
                   (simpl; rewrite ! subst_trans_type; auto).
 Qed.

 Lemma subst1_under_trans_type : forall w l A s n ,
    (subst (under n (dot s id)) (trans_type w l A)) = (trans_type
                                            (subst (under n (dot s id)) w)
                                         (subst (under n (dot s id)) l) A).
  induction A; intros; simpl; auto; simpsub_big; auto; try
                   (simpl; rewrite ! subst_trans_type; auto).
 Qed.

Lemma sh_under_trans_type : forall w l A s n ,
    (subst (under n (sh s)) (trans_type w l A)) = (trans_type
                                            (subst (under n (sh s)) w)
                                         (subst (under n (sh s)) l) A).
  induction A; intros; simpl; auto; simpsub_big; auto; try
                   (simpl; rewrite ! subst_trans_type; auto).
 Qed.

 (*making a pair of type (a big product at U) out of a pair of (a big product at W)
  iterating over the pair
 but how far to go? use the list because it should be the same size as the pair*)

 Fixpoint Gamma_at (G: source.context) (w l: Syntax.term obj) :=
   match G with
     nil => unittp
   | A::xs => (prod (trans_type w l A) (Gamma_at xs w l)) end
 .

 (*making a pair of type (a big product at U) out of a pair of (a big product at W)
  iterating over the pair
 but how far to go? use the list because it should be the same size as the pair*)
Fixpoint move_gamma (G: source.context) l1 l2 (m: Syntax.term obj) (gamma: Syntax.term obj) :=
   match G with
     nil => gamma
   | A::xs => ppair (move_app A l1 l2 m (ppi1 gamma)) (move_gamma xs l1 l2 m (ppi2 gamma)) end.

(*making a product value out of the variables in a source context
 assume vars to start at 0*)
Fixpoint gamma_at (G: source.context ):= match G with
                                             [::] => triv
                                         | g::gs => @ppair obj (var 0) (shift 1 (gamma_at gs)) end.

Lemma subst_Gamma_at :forall w l s G,
    subst s w = w ->
    subst s l = l ->
    (subst s (Gamma_at G w l)) = (Gamma_at G w l).
   intros. induction G; auto. simpl. move: IHG. simpsub. move => IHG.
   rewrite IHG subst_trans_type; auto. Qed.

Lemma subst_move_gamma :forall g l1 l2 m s G,
    (subst s (move_gamma G l1 l2 m g)) = move_gamma G (subst s l1) (subst s l2) (subst s m) (subst s g).
  intros. move: g m s. induction G; intros; auto. simpl. simpsub.
  rewrite (IHG (ppi2 g) m s); auto. unfold move_app. simpsub. rewrite subst_move.
  auto. Qed.

Lemma sh_under_Gamma_at: forall G w l s n,
    (subst (under n (sh s)) (Gamma_at G w l)) = (Gamma_at G (subst (under n (sh s)) w)
                                                (subst (under n (sh s)) l)).
   intros. induction G; auto. simpl. move: IHG. simpsub. move => IHG.
   rewrite sh_under_trans_type IHG. auto. Qed.

Lemma sh_Gamma_at: forall G w l s,
    (subst (sh s) (Gamma_at G w l)) = (Gamma_at G (subst (sh s) w)
                                                (subst (sh s) l)). intros.
  change (sh s) with (@ under obj 0 (sh s)). apply sh_under_Gamma_at.
Qed.

Hint Rewrite sh_Gamma_at subst_move_gamma: subst1.

 Lemma subst1_Gamma_at: forall G w l s,
    (subst (dot s id) (Gamma_at G w l)) = (Gamma_at G (subst1 s w)
                                                                (subst1 s l)).
   intros. induction G; auto. simpl. move: IHG. simpsub. move => IHG.
   rewrite subst1_trans_type IHG. auto. Qed.

Lemma subst1_under_Gamma_at: forall G w l s n,
     (subst (under n (dot s id)) (Gamma_at G w l)) =
     (Gamma_at G (subst (under n (dot s id) ) w)
               (subst (under n (dot s id) ) l)).
  intros. induction G. simpl; auto.
  simpl. simpsub. rewrite subst1_under_trans_type IHG. auto.
Qed.

Definition make_consb_subseq n := ppair (app nsucc_leq_fn n) (lam (lam (lam triv))).

Lemma subst_make_consb_subseq n s : (subst s (make_consb_subseq n)) =
                                    make_consb_subseq (subst s n).
  intros. unfold make_consb_subseq. simpsub_bigs. auto. Qed.
Hint Rewrite subst_make_consb_subseq: core subst1.
Hint Rewrite <- subst_make_consb_subseq : inv_subst.

Fixpoint gamma_nth (bundle: Syntax.term obj) i :=
  match i with 0 => (ppi1 bundle)
          | S i' => gamma_nth (ppi2 bundle) i' end.

Lemma typed_gamma_nth w l G D g A i:
  tr D (oof w preworld) ->
  tr D (oof l nattp) ->
  Sequence.index i G A ->
  tr D (oof g (Gamma_at G w l)) ->
  tr D (oof (gamma_nth g i) (trans_type w l A)).
  intros Hw Hl. move : g G.
  induction i; intros g G Hindex Hg.
  { simpl. inversion Hindex. subst. simpl in Hg.
    apply (tr_prod_elim1 _ _ (Gamma_at l0 w l)).
    assumption.
  }
  {
    simpl. inversion Hindex. subst.
    suffices: (tr D (oof (ppi2 g)
                         (Gamma_at l0 w l))).
    intros Hg2.
    apply (IHi _ _ H0 Hg2).
    simpl in Hg.
    apply (tr_prod_elim2 _ (trans_type w l x)).
    assumption.
  }
  Qed.

Inductive trans: source.context -> source.term -> source.term -> (Syntax.term obj) -> Prop :=
  t_z : forall G,
    trans G z_m nattp_m (lam (lam nzero))
| t_succ : forall G e ebar,
    trans G e nattp_m ebar ->
    trans G (succ_m e) nattp_m (lam (lam (nsucc (app (app (subst (sh 2) ebar) (var 1)) (var 0)))))
| t_triv : forall G,
    trans G triv_m unittp_m (lam (lam triv))
| t_var: forall G i A,
    Sequence.index i G A ->
    trans G (source.var i) A
          (lam (lam
                  (gamma_nth (var 0) i)
          ))
|  t_bind: forall G E1 Et1 E2 Et2 A B, (*of_m G (bind_m E1 E2) (comp_m B) -> require typing of E1 and E2 instead*)
                                   trans G E1 (comp_m A) Et1 ->
                                   trans (A::G) E2 (comp_m B) Et2 ->
                                   trans G (bind_m E1 E2) (comp_m B) (
 lam (lam ( lam ( (*l1 : = 2, g: Gamma_at G = 1 l :=0 *) lam ( (*l1 := 3, l := 1, m := 0*)
                           lam ( (*l1 := 4, l := 2, m := 1, s := 0*)
                               let l1 := (var 4) in
                               let g := (var 3) in
                               let l := (var 2) in
                               let m := (var 1) in
                               let s := (var 0) in
let btarg := app (app (app (app (app (shift 5 Et1) l1) g) l) m) s in
make_bind btarg ( lam (*l1 := 5, l := 3, m := 2, s := 1, z1 := 0*)
              (
                               let z1 := (var 0) in (*basically added 6 vars to my context*)
                               let lv := (picomp1 z1) in
                               let mv := (picomp2 z1) in
                               let sv := (picomp3 z1) in
                               let x' := (picomp4 z1) in
                               let l := (shift 1 l) in (*l = 3*)
                                                                        (*
in the context (A :: G) Et2 is a function which wants a length
in the context G, Et2 has var 0 free. In context G, (lam Et2) is a function which wants an
x, then a length
make the lambda first before you introduce other variables and it's still the first var
that. you want to bind
                                                                         *)
                               (*x' lam, floating around in the context as var 0*)
(*et2's var 0 is the x.
 maybe plan is bring the subst outside the lamda so that you type check the lamda in the
 weakened context*)

                               let btarg :=
                                   (*Et2 Gamma@V lv*)
                                   app (app (shift 6 Et2)
                                           lv
                                            )
                                            (*5: Gamma_at G w
                                              move 5: Gamma_at G v
                                          <x, 5> : Gamma_at A::G v*)
                       (ppair x' (move_gamma G
                                             (var 5) lv
                       (make_subseq_trans (var 5) (var 3) lv (var 2) mv)
                       (var 4)))                                                 in
                               let e2bar' := app (app (app btarg lv) (make_subseq_refl lv) )
                                                 (*v, z1 <= v, z1*)
                                                 sv in
                               make_bind e2bar' (lam ( (*l = var 4*)
                                                    let z2 := (var 0) in
                                                    ret_a (ppair (picomp1 z2)
                                                                 (ppair (ppair
             (make_subseq_trans (shift 1 l) (shift 1 lv) (picomp1 z2) (picomp2 (shift 1 z1)) (picomp2 z2))
                                                                           (*z2 \circ z1*)
                                                      (picomp3 z2)) (picomp4 z2))
                                                        )
                                               ))
              )

          )

    ))
                                         ))))
  | t_ref: forall G E Et A,
      (*   of_m G (ref_m E) (comp_m (reftp_m A)) -> *)
 trans G E A Et ->
         trans G (ref_m E) (comp_m (reftp_m A)) (lam (lam (lam (lam ( lam ( (*l1, g, l, m, s*)
         let l := var 2 in
         let m1 := (make_consb_subseq l) in (*u <= u1, consb subseq*)
         let p1 := (ppair m1
                         (lam (lam ( lam ( (*making a value of type store U1, lambdas go l2, m2, i*)
                                         let l1 := var 7 in
                                         let g := var 6 in
                                         let l := var 5 in
                                         let m := var 4 in
                                         let s := var 3 in
                                         let l2 := var 2 in
                                         let m2 := var 1 in
                                         let i := var 0 in
                                         let x := app (app (shift 8 Et) l1) g in
                                         let m12 := (make_subseq_trans l (nsucc l)
                                                                      l2 (subst (sh 3) m1) m2) (*U <=  U1 <= U2*)
                                         in
                                         let m02 := make_subseq_trans l1 l l2 m m12 in (*W <= U + U <= U2 = W <= U2*)

                                         (*m12 o m : W <= U2*)
                                         bite (ltb_app i l)
                                              (app (app (app s l2) m12) i) (*move value in s:store(U) to U2*)
                                              (next (move_app A
                                                              l1 l2
                                                              m02 x)) (*move x to be : |> A @ U2*)
                                               ))
                         ))
         ) in
             ret_a (ppair (nsucc l) (*length of new world*)
                          (ppair p1 (*new word is accessible from current world, *)
                                 (ppair l (ppair (app leq_refl_fn (nsucc l)) (lam triv)) (*ref A @ new world*)
                                 )
                          )
                   )))))))
  | t_assign: forall G R Rt E Et A,
    (*  of_m G R (reftp_m A) ->
      of_m G E A -> *)
      trans G R (reftp_m A) Rt ->
      trans G E A Et ->
      trans G (asgn_m R E) (comp_m unittp_m)
            (lam (lam (lam (lam ( lam ( (*l = 4, g = 3, l1 = 2, m = 1, s1 = 0*)
                                      let l := var 4 in
                                      let m := var 1 in
                                      let l1 := var 2 in
                                      let g := var 3 in
                                      let s1 := var 0 in
                                      let ref := move_app (reftp_m A)
                                                          (var 4) (var 2)
                                                          m (app (app (shift 5 Rt) l) g) in
                                      let i := ppi1 ref in
                                      let p := ppi2 ref in
                                      let store_u1  := lam (lam (lam (*l2 = 2, m1 = 1,j = 0*)
                                                                  (
                                                                    let j := (var 0) in
                                                                    let l2 := var 2 in
                                                                    let m1 := var 1 in
                                                                    let i := shift 3 i in
                                                                    let l := shift 3 l in
                                                                    let l1 := shift 3 l1 in
                                                                    let g := shift 3 g in
                                                                    let m := shift 3 m in
                                                                    bite
                                                                      (app (eq_b j) i)
                                                                      (next (move_app A
                                                                                l
                                                                                l2
   (make_subseq_trans l l1 l2 m m1)
                                                                    (app (app (shift 8 Et) l) g)))
                                                                      (app (app (app (shift 3 s1) l2) m1) j)
                                                                 ))) in
                                      ret_a (ppair l1
                                                   (ppair
                                                      (ppair (make_subseq_refl l1) (*refl u1*)
                                                             store_u1)
                                                      triv))
            ))))))
  | t_deref: forall G R Rt A,
      (* of_m G R (reftp_m A) -> *)
      trans G R (reftp_m A) Rt ->
      trans G (deref_m R) (comp_m A)
            (lam (lam (lam (lam ( lam ( (*l = 4, g = 3, l1 = 2, m = 1, s = 0*)
                                      let l := var 4 in
                                      let g := var 3 in
                                      let l1 := var 2 in
                                      let m := var 1 in
                                      let s := var 0 in
                                      let ref := move_app (reftp_m A) l l1
                                                          m (app (app (shift 5 Rt) l) g) in
                                      let i := ppi1 ref in
                                      let e := prev (app (app (app s l1)
                                                (make_subseq_refl l1)) i) in
                                     (inr (next (inl (ppair
                                                                            l1
                                                                            (ppair (
                                                                                ppair (make_subseq_refl l1)
                                                                                s)
                                                                                e)
                                                                               )
                                    ))))
            )))))
| t_ap : forall G E1 Et1 E2 Et2 Targ T2,
    (*  of_m G E1 (arrow_m Targ T2) -> (*take this out*)
      of_m G E2 Targ -> (*take this out*) *)
      trans G E1 (arrow_m Targ T2) Et1 ->
      trans G E2 Targ Et2 ->
      trans G (app_m E1 E2) T2
           ( lam (lam  (*l = 1, g = 0*)
                   (let Et1 := shift 2 Et1 in
                   let Et2 := shift 2 Et2 in
                   let l := (var 1) in
                   let g := (var 0) in
                   let arg := (app (app Et2 l) g) in
                   (app (app (app (app (app Et1 l) g) l) (make_subseq_refl l)) arg)
                )))
| t_lam : forall G E Et Targ T2,
     (* of_m (Targ::G) E T2 ->*)
      trans (Targ::G) E T2 Et ->
      trans G (lam_m E) (arrow_m Targ T2)
            (lam (lam (lam (lam (lam (*l1 =4, g = 3, l = 2
                                      m = 1, x = 0*)
                                   (app (app (shift 5 Et) (var 2))
                                        (ppair (var 0) (move_gamma G (var 4) (var 2)
                                                                   (var 1) (var 3)))

            ))))))
| t_ret : forall G E Et A,
   (* of_m G E A -> *)
    trans G E A Et ->
    trans G (ret_m E) (comp_m A)
          (lam (lam (lam (lam (lam (*l1 = 4, g = 3, l =2, m = 1, s = 0*)
                                 (let l1 := var 4 in
                                  let g := var 3 in
                                  let l := var 2 in
                            let m := var 1 in
                            let s := var 0 in
                            let e := move_app A l1 l m (app (app (shift 5 Et) l1) g) in
                            inl (
                                (ppair
                                   l
                                   (ppair (ppair (make_subseq_refl l) s) e))
                            )

          )))))).


From trace_program_logic.traces Require Export trace.
From iris.algebra Require Export ofe cmra local_updates.

Inductive trace_alg (A L : Type) : Type :=
| trace_alg_trace (ft : finite_trace A L)
| trace_alg_bot.

Global Arguments trace_alg_trace {_ _} _.
Global Arguments trace_alg_bot {_ _}, _.

Canonical Structure traceO (A L : Type) := leibnizO (finite_trace A L).
Canonical Structure trace_algO (A  L: Type) := leibnizO (trace_alg A L).

Section trace_alg_cmra.
  Context `{!EqDecision A, !EqDecision L}.

  Implicit Types a b : A.
  Implicit Types ℓ : L.
  Implicit Types ft : finite_trace A L.
  Implicit Types fa : trace_alg A L.

  Local Instance trace_alg_pcore_instance : PCore (trace_alg A L) := λ fa, Some fa.

  Local Instance trace_alg_op : Op (trace_alg A L) :=
    λ fa fa',
    match fa with
    | trace_alg_trace ft =>
      match fa' with
      | trace_alg_trace ft' =>
        if (bool_decide (ft `trace_prefix_of` ft')) then
          trace_alg_trace ft'
        else
          if (bool_decide (ft' `trace_prefix_of` ft)) then
            trace_alg_trace ft
          else
            trace_alg_bot
      | trace_alg_bot => trace_alg_bot
      end
    | trace_alg_bot => trace_alg_bot
    end.

  Arguments trace_alg_op _ _ : simpl never.

  Lemma trace_alg_op_traces ft ft' :
    (trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') = trace_alg_bot ∧
     (¬ ft `trace_prefix_of` ft' ∧
      ¬ ft' `trace_prefix_of` ft)) ∨
    ((trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') =
      trace_alg_trace ft' ∧ ft `trace_prefix_of` ft') ∨
     (trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') =
      trace_alg_trace ft ∧ ft' `trace_prefix_of` ft)).
  Proof.
    rewrite /trace_alg_op.
    rewrite -!decide_bool_decide.
    repeat destruct decide; eauto.
  Qed.

  Lemma trace_alg_op_eq_right' ft ft' :
    ft `trace_prefix_of` ft' →
    trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') = trace_alg_trace ft'.
  Proof.
    intros ?.
    rewrite /trace_alg_op -!decide_bool_decide.
    repeat destruct decide; done.
  Qed.

  Lemma trace_alg_op_eq_left' ft ft' :
    ft' `trace_prefix_of` ft →
    trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') = trace_alg_trace ft.
  Proof.
    intros ?.
    rewrite /trace_alg_op -!decide_bool_decide.
    repeat destruct decide; [|done|done].
    f_equal; apply trace_prefix_antisym; done.
  Qed.

  Lemma trace_alg_op_eq_neither' ft ft' :
    ¬ ft `trace_prefix_of` ft' →
    ¬ ft' `trace_prefix_of` ft →
    trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') = trace_alg_bot.
  Proof.
    intros ??.
    rewrite /trace_alg_op -!decide_bool_decide.
    repeat destruct decide; done.
  Qed.

  Lemma trace_alg_op_right_bot' fa :
    trace_alg_op fa trace_alg_bot = trace_alg_bot.
  Proof. destruct fa; done. Qed.

  Lemma trace_alg_op_left_bot' fa :
    trace_alg_op trace_alg_bot fa = trace_alg_bot.
  Proof. destruct fa; done. Qed.

  Lemma trace_alg_op_com fa fa' :
    trace_alg_op fa fa' = trace_alg_op fa' fa.
  Proof.
    destruct fa as [ft|]; destruct fa' as [ft'|]; [|done|done|done].
    destruct (decide (ft `trace_prefix_of` ft')).
    { rewrite (trace_alg_op_eq_right' ft ft'); last done.
      rewrite (trace_alg_op_eq_left' ft' ft); done. }
    destruct (decide (ft' `trace_prefix_of` ft)).
    { rewrite (trace_alg_op_eq_left' ft ft'); last done.
      rewrite (trace_alg_op_eq_right' ft' ft); done. }
    rewrite !trace_alg_op_eq_neither'; done.
  Qed.

  Lemma trace_alg_op_assoc fa fa' fa'' :
    trace_alg_op fa (trace_alg_op fa' fa'') =
    trace_alg_op (trace_alg_op fa fa') fa''.
  Proof.
    destruct fa as [ft|]; last done.
    destruct fa' as [ft'|]; last done.
    destruct fa'' as [ft''|]; last first.
    { by rewrite !trace_alg_op_right_bot'. }
    destruct (trace_alg_op_traces ft ft') as
        [[-> [Hf1 Hf2]]|[[-> Hf]|[-> Hf]]].
    - destruct (trace_alg_op_traces ft' ft'')
        as [[-> [Hg1 Hg2]]|[[-> Hg]|[-> Hg]]]; first done.
      + destruct (decide (ft `trace_prefix_of` ft'')).
        { edestruct (trace_prefixes_related ft ft'); done. }
        destruct (decide (ft' `trace_prefix_of` ft)); first done.
        rewrite (trace_alg_op_eq_neither' ft ft''); [done|done|].
        intros ?; apply Hf2; etrans; done.
      + rewrite (trace_alg_op_eq_neither' ft ft'); [done|done|].
        intros ?; apply Hf2; etrans; done.
    - destruct (trace_alg_op_traces ft' ft'')
        as [[-> [Hg1 Hg2]]|[[-> Hg]|[-> Hg]]]; first done.
      + apply trace_alg_op_eq_right'; etrans; done.
      + apply trace_alg_op_eq_right'; etrans; done.
    - destruct (trace_alg_op_traces ft' ft'')
        as [[-> [Hg1 Hg2]]|[[-> Hg]|[-> Hg]]]; [|done|].
      + rewrite (trace_alg_op_eq_neither' ft ft''); first done.
        * intros ?; apply Hg1; etrans; done.
        * intros ?.
            edestruct (trace_prefixes_related ft'' ft'); done.
      + rewrite !trace_alg_op_eq_left'; [done|etrans; done|done].
  Qed.

  Lemma trace_alg_op_idemp' fa : trace_alg_op fa fa = fa.
  Proof.
    destruct fa; last done.
    rewrite trace_alg_op_eq_left'; done.
  Qed.

  Local Instance trace_alg_valid_instance : Valid (trace_alg A L) :=
    λ fa, match fa with
          | trace_alg_trace _ => True
          | _ => False
          end.

  Lemma trace_alg_RAMixin : RAMixin (trace_alg A L).
  Proof.
    apply ra_total_mixin.
    - eauto.
    - intros fa fa' fa'' ->%leibniz_equiv; done.
    - by intros ?? ->%leibniz_equiv.
    - by intros ?? ->%leibniz_equiv.
    - intros ???; apply trace_alg_op_assoc.
    - intros ??; apply trace_alg_op_com.
    - intros ?; apply trace_alg_op_idemp'.
    - done.
    - done.
    - intros [] []; done.
  Qed.

  Canonical Structure trace_algR := discreteR (trace_alg A L) trace_alg_RAMixin.

  Global Instance trace_alg_cmra_total : CmraTotal trace_algR.
  Proof. econstructor; done. Qed.

  Global Instance trace_alg_cmra_discrete : CmraDiscrete trace_algR.
  Proof. econstructor; [apply _|done]. Qed.

  Global Instance trace_alg_core_id fa : CoreId fa.
  Proof. by constructor. Qed.

  Lemma trace_alg_included ft ft' :
    trace_alg_trace ft ≼ trace_alg_trace ft' ↔ ft `trace_prefix_of` ft'.
  Proof.
    split.
    - intros [fa'' Heq%leibniz_equiv].
      rewrite /op in Heq.
      destruct fa'' as [ft''|]; last by rewrite trace_alg_op_right_bot' in Heq.
      destruct (trace_alg_op_traces ft ft'') as [[Hop Hf]|[[Hop Hf]|[Hop Hf]]].
      + rewrite Hop in Heq; done.
      + rewrite Hop in Heq; simplify_eq; done.
      + rewrite Hop in Heq; simplify_eq; done.
    - intros Hincl; exists (trace_alg_trace ft').
      rewrite /op trace_alg_op_eq_right'; done.
  Qed.

  Lemma trace_alg_includedN ft ft' n :
    trace_alg_trace ft ≼{n} trace_alg_trace ft' ↔ ft `trace_prefix_of` ft'.
  Proof. apply trace_alg_included. Qed.

  Lemma trace_alg_op_idemp'' : IdemP eq (@op (trace_alg A L) _).
  Proof. intros ?; apply trace_alg_op_idemp'. Qed.

  Lemma trace_alg_op_idemp fa : fa ⋅ fa = fa.
  Proof. apply trace_alg_op_idemp'. Qed.

  Lemma trace_alg_op_eq_right ft ft' :
    ft `trace_prefix_of` ft' →
    trace_alg_trace ft ⋅ trace_alg_trace ft' = trace_alg_trace ft'.
  Proof. apply trace_alg_op_eq_right'. Qed.

  Lemma trace_alg_op_eq_left ft ft' :
    ft' `trace_prefix_of` ft →
    trace_alg_trace ft ⋅ trace_alg_trace ft' = trace_alg_trace ft.
  Proof. apply trace_alg_op_eq_left'. Qed.

  Lemma trace_alg_op_eq_neither ft ft' :
    ¬ ft `trace_prefix_of` ft' →
    ¬ ft' `trace_prefix_of` ft →
    trace_alg_trace ft ⋅ trace_alg_trace ft' = trace_alg_bot.
  Proof. apply trace_alg_op_eq_neither'. Qed.

  Lemma trace_alg_op_right_bot fa :
    fa ⋅ trace_alg_bot = trace_alg_bot.
  Proof. apply trace_alg_op_right_bot'. Qed.

  Lemma trace_alg_op_left_bot fa :
    trace_alg_op trace_alg_bot fa = trace_alg_bot.
  Proof. apply trace_alg_op_left_bot'. Qed.

  Lemma trace_alg_validN fa n : ✓{n} fa → ∃ ft, fa = trace_alg_trace ft.
  Proof. destruct fa; by eauto. Qed.

  Lemma trace_alg_valid fa : ✓ fa → ∃ ft, fa = trace_alg_trace ft.
  Proof. destruct fa; by eauto. Qed.

  Lemma trace_alg_pcore fa : pcore fa = Some fa.
  Proof. done. Qed.

  Lemma trace_alg_core fa : core fa = fa.
  Proof. done. Qed.

  Lemma trace_alg_local_update ft fa ft' :
    ft `trace_prefix_of` ft' →
    (trace_alg_trace ft, fa) ~l~> (trace_alg_trace ft', trace_alg_trace ft').
  Proof.
    intros Hpf.
    apply local_update_total_valid.
    intros _ [ft'' ->]%trace_alg_valid Hfts%trace_alg_included.
    setoid_replace (trace_alg_trace ft') with
        (trace_alg_trace ft' ⋅ trace_alg_trace ft) at 1; last first.
    { rewrite trace_alg_op_eq_left; done. }
    setoid_replace (trace_alg_trace ft') with
        (trace_alg_trace ft' ⋅ trace_alg_trace ft'') at 2; last first.
    { rewrite trace_alg_op_eq_left; etrans; done. }
    apply op_local_update.
    intros ??.
    rewrite trace_alg_op_eq_left; done.
  Qed.

End trace_alg_cmra.


Require Export LimitFunctors Pullback.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section Equalizer.
  Context `(C : @SpecializedCategory objC).

  Variable HasLimits : forall F : SpecializedFunctor PullbackIndex C, Limit F.
  Variable HasColimits : forall F : SpecializedFunctor PushoutIndex C, Colimit F.

  Definition PullbackFunctor := LimitFunctor HasLimits.
  Definition PushoutFunctor := ColimitFunctor HasColimits.
End Equalizer.


Module Short.
  Set Universe Polymorphism.
  Inductive relevant (A : Type) (B : Type) : Prop := .
  Section foo.
    Variables A B : Type.
    Definition foo := prod (relevant A B) A.
  End foo.

  Section bar.
    Variable A : Type.
    Variable B : Type.
    Definition bar := prod (relevant A B) A.
  End bar.

  Set Printing Universes.
  Check bar nat Set : Set. (* success *)
  Check foo nat Set : Set. (* Toplevel input, characters 6-17:
Error:
The term "foo (* Top.303 Top.304 *) nat Set" has type
"Type (* Top.304 *)" while it is expected to have type
"Set" (Universe inconsistency: Cannot enforce Top.304 = Set because Set
< Top.304)). *)
End Short.