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


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e191m19_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


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


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj13synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus lv0 (plus lv1 lv2)) (plus lv3 Zero)).
Admitted.
QuickChick conj13synthconj4.


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.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj6synthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 (Succ lv1)) (plus lv1 (Succ lv0))).
Admitted.
QuickChick conj6synthconj6.


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))
                            )

          )))))).


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj34eqsynthconj4 : forall  (lv0 : natural), (@eq natural (Succ lv0) (plus (Succ Zero) lv0)).
Admitted.
QuickChick conj34eqsynthconj4.


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.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e384m317_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e384m317_7limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.