Require Import HoTT.

(* 1,2,3-semi cubical types *)
Section BasicDefs.

  (* boundaries of 1-squares (aka: arrows) *)
  Definition s1_bound (C0 : Type) : Type :=
    C0 * C0.

  (* 1-squares over a type *)
  Definition s1 (C0 : Type) : Type :=
    s1_bound C0 -> Type.

  (* a 1-cubical type is a type together with 1-squares. it is a graph *)
  Definition CT1 : Type :=
    { C0 : Type & s1 C0}.

  Coercion CT1toCT0 (C : CT1) : Type := C.1.
  (* Coercion CT1tos1 (C : CT1) : s1 C.1 := C.2. *)

  (* boundaries of 2-squares *)
  Record s2_bound (C : CT1) : Type :=
   S2b
    { v00 : C.1
    ; v01 : C.1
    ; v10 : C.1
    ; v11 : C.1
    ; a0x : C.2 (v00 , v01)
    ; a1x : C.2 (v10 , v11)
    ; ax0 : C.2 (v00 , v10)
    ; ax1 : C.2 (v01 , v11)
  }.

    (* we don't want to write the underlying type each time *)
  Global Arguments S2b {C} v00 v01 v10 v11 a0x a1x ax0 ax1.
  Global Arguments v00 {C} s.
  Global Arguments v01 {C} s.
  Global Arguments v10 {C} s.
  Global Arguments v11 {C} s.
  Global Arguments a0x {C} s.
  Global Arguments a1x {C} s.
  Global Arguments ax0 {C} s.
  Global Arguments ax1 {C} s.

  (* 2-squares over a 1-cubical type *)
  Definition s2 (C : CT1) :=
    s2_bound C -> Type.

  (* a 2-cubical type is a 1-cubical type together with 2-squares *)
  Definition CT2 : Type :=
    { C : CT1 & s2 C}.

  Coercion CT2toCT1 (C : CT2) : CT1 := C.1.
  (* Coercion CT2tos2 (C : CT2) : s2 C.1 := C.2. *)

  (* boundaries of 3-squares (aka: cubes) *)
  Record s3_bound (C : CT2) : Type :=
   S3b
    { v000 : C.1.1
    ; v001 : C.1.1
    ; v010 : C.1.1
    ; v011 : C.1.1
    ; v100 : C.1.1
    ; v101 : C.1.1
    ; v110 : C.1.1
    ; v111 : C.1.1
    ; a00x : C.1.2 (v000 , v001)
    ; a01x : C.1.2 (v010 , v011)
    ; a10x : C.1.2 (v100 , v101)
    ; a11x : C.1.2 (v110 , v111)
    ; a0x0 : C.1.2 (v000 , v010)
    ; a0x1 : C.1.2 (v001 , v011)
    ; a1x0 : C.1.2 (v100 , v110)
    ; a1x1 : C.1.2 (v101 , v111)
    ; ax00 : C.1.2 (v000 , v100)
    ; ax01 : C.1.2 (v001 , v101)
    ; ax10 : C.1.2 (v010 , v110)
    ; ax11 : C.1.2 (v011 , v111)
    ; f0xx : C.2 (S2b _ _ _ _ a00x a01x a0x0 a0x1)
    ; f1xx : C.2 (S2b _ _ _ _ a10x a11x a1x0 a1x1)
    ; fx0x : C.2 (S2b _ _ _ _ a00x a10x ax00 ax01)
    ; fx1x : C.2 (S2b _ _ _ _ a01x a11x ax10 ax11)
    ; fxx0 : C.2 (S2b _ _ _ _ a0x0 a1x0 ax00 ax10)
    ; fxx1 : C.2 (S2b _ _ _ _ a0x1 a1x1 ax01 ax11) }.

  Global Arguments S3b {C} v000 v001 v010 v011 v100 v101 v110 v111
                    a00x a01x a10x a11x a0x0 a0x1 a1x0 a1x1 ax00 ax01 ax10 ax11
                    f0xx f1xx fx0x fx1x fxx0 fxx1.

  Global Arguments v000 {C} s.
  Global Arguments v001 {C} s.
  Global Arguments v010 {C} s.
  Global Arguments v011 {C} s.
  Global Arguments v100 {C} s.
  Global Arguments v101 {C} s.
  Global Arguments v110 {C} s.
  Global Arguments v111 {C} s.
  Global Arguments a00x {C} s.
  Global Arguments a01x {C} s.
  Global Arguments a10x {C} s.
  Global Arguments a11x {C} s.
  Global Arguments a0x0 {C} s.
  Global Arguments a0x1 {C} s.
  Global Arguments a1x0 {C} s.
  Global Arguments a1x1 {C} s.
  Global Arguments ax00 {C} s.
  Global Arguments ax01 {C} s.
  Global Arguments ax10 {C} s.
  Global Arguments ax11 {C} s.
  Global Arguments f0xx {C} s.
  Global Arguments f1xx {C} s.
  Global Arguments fx0x {C} s.
  Global Arguments fx1x {C} s.
  Global Arguments fxx0 {C} s.
  Global Arguments fxx1 {C} s.

  (* 3-squares over a 2-cubical type *)
  Definition s3 (C : CT2) : Type :=
     s3_bound C -> Type.

  (* a 3-cubical type is a 2-cubical type together with 3-squares *)
  Definition CT3 : Type :=
    { C : CT2 & s3 C }.

  Coercion CT3toCT2 (C : CT3) : CT2 := C.1.
  Coercion CT3tos3 (C : CT3) : s3 C.1 := C.2.

End BasicDefs.

(* morphisms between 1,2,3-cubical types *)
Section Morphisms.

    (* CT1 *)
  (* functoriality of 1-boundaries (map should be understood as
     the map function in Haskell) *)
  Definition s1b_map {C0 D0 : Type} (M0 : C0 -> D0)
               (v : s1_bound C0) : s1_bound D0 :=
    let (v0 , v1) := v in (M0 v0 , M0 v1).

  Definition s1b_map_funct_comp {C0 D0 E0 : Type}
               (M0 : C0 -> D0) (N0 : D0 -> E0) :
               (s1b_map N0) o (s1b_map M0) == (s1b_map (N0 o M0)) :=
    fun v => match v with
               | _ => idpath _
             end.

  (* homotopy invariance of 1-boundaries *)
  Definition s1b_map_htpy_invariant {C0 D0 : Type}
               {M0 N0 : C0 -> D0} (h : M0 == N0) :
                 s1b_map M0 == s1b_map N0 :=
    fun v => let (v0, v1) := v in
                 (path_prod (M0 v0, M0 v1) (N0 v0, N0 v1) (h v0) (h v1)).

  Definition s1_morph {C0 D0 : Type}
               (C1 : s1 C0) (D1 : s1 D0)
               (M0 : C0 -> D0) : Type :=
    forall v : s1_bound C0, C1 v -> D1 (s1b_map M0 v).

  Definition CT1_morph (C D : CT1) : Type :=
    {p0 : C.1 -> D.1 & s1_morph C.2 D.2 p0}.

  Definition CT1_morph_comp {C D E : CT1}
               (M : CT1_morph C D) (N : CT1_morph D E) :
                 CT1_morph C E.
  Proof.
    exists (N.1 o M.1).
    intro b.
    exact (N.2 _ o M.2 b).
  Defined.
    (* if we try to define this directly it does not type check *)

  (* pointwise homotopy between CT1_morph *)
  Definition CT1_morph_homotopy {C D : CT1} (M N : CT1_morph C D) : Type :=
    {h0 : M.1 == N.1 &
     forall b,
       M.2 b == (fun v => ((s1b_map_htpy_invariant h0 b)^ # (N.2 b v)))}.

    (* CT2 *)
  Definition s2b_map {C D : CT1} (M : CT1_morph C D)
               (a : s2_bound C) : s2_bound D :=
    S2b (M.1 a.(v00)) (M.1 a.(v01)) (M.1 a.(v10)) (M.1 a.(v11))
        (M.2 _ a.(a0x)) (M.2 _ a.(a1x)) (M.2 _ a.(ax0)) (M.2 _ a.(ax1)).

  Definition s2b_map_funct_comp {C D E : CT1}
               (M : CT1_morph C D) (N : CT1_morph D E) :
               (s2b_map N) o (s2b_map M) == (s2b_map (CT1_morph_comp M N)) :=
    fun b => match b with
               | _ => idpath _
             end.

  (*
  Definition s2b_map_htpy_invariant `{Funext} {C D : CT1}
               {M N : CT1_morph C D} (h : CT1_morph_homotopy M N) :
                 s2b_map M == s2b_map N.
  Proof.
    destruct M as (M0 , M1). destruct N as (N0 , N1).
    destruct h as (h0 , h1). simpl in h1.
    pose (h0p := path_arrow _ _ h0).
    simpl in h0p.
    intro b.
    induction (s1b_map_htpy_invariant h0 b)^.
    unfold s1b_map_htpy_invariant in h1.
    induction h0p.
    pose (h1p' := fun v => path_arrow _ _ (h1 v)).
    pose (h1p := path_forall _ _ h1p').
    intro b.
    destruct b.
    unfold s2b_map.
    simpl.
    induction h1p.
    induction h0.
    rewrite (h0 v02).
    fun v => let (v0, v1) := v in
                 (path_prod (M0 v0, M0 v1) (N0 v0, N0 v1) (h v0) (h v1)).
  *)

  Definition s2_morph (C D : CT2) (p1 : CT1_morph C.1 D.1) : Type :=
    forall a : s2_bound C,
      C.2 a -> D.2 ((s2b_map p1) a).

  Definition CT2_morph (C D : CT2) : Type :=
    { p1 : CT1_morph C D & s2_morph C D p1}.

  Definition s3b_map {C D : CT2} (M : CT2_morph C D)
               (a : s3_bound C) : s3_bound D :=
    S3b (M.1.1 a.(v000)) (M.1.1 a.(v001)) (M.1.1 a.(v010)) (M.1.1 a.(v011))
        (M.1.1 a.(v100)) (M.1.1 a.(v101)) (M.1.1 a.(v110)) (M.1.1 a.(v111))
        (M.1.2 _ a.(a00x)) (M.1.2 _ a.(a01x)) (M.1.2 _ a.(a10x)) (M.1.2 _ a.(a11x))
        (M.1.2 _ a.(a0x0)) (M.1.2 _ a.(a0x1)) (M.1.2 _ a.(a1x0)) (M.1.2 _ a.(a1x1))
        (M.1.2 _ a.(ax00)) (M.1.2 _ a.(ax01)) (M.1.2 _ a.(ax10)) (M.1.2 _ a.(ax11))
        (M.2 _ a.(f0xx)) (M.2 _ a.(f1xx)) (M.2 _ a.(fx0x))
        (M.2 _ a.(fx1x)) (M.2 _ a.(fxx0)) (M.2 _ a.(fxx1)).

  Definition s3_morph (C D : CT3) (p2 : CT2_morph C.1 D.1) : Type :=
    forall a : s3_bound C,
      C.2 a -> D.2 ((s3b_map p2) a).

  Definition CT3_morph (C D : CT3) : Type :=
    { p2 : CT2_morph C D & s3_morph C D p2}.

End Morphisms.

(** identity types of [CT1] and [CT2] *)
Section IdentityTypes.

    (* definitions *)
  Definition s1_equiv {C0 D0 : Type}
               (C1 : s1 C0) (D1 : s1 D0)
               (M0 : C0 -> D0) : Type :=
    forall v : s1_bound C0, C1 v <~> D1 (s1b_map M0 v).

  Definition CT1_equiv (C D : CT1) :=
    { p0 : C.1 <~> D.1 & s1_equiv C.2 D.2 p0 }.

  Coercion CT1_equiv_to_morph {C D : CT1} :
            CT1_equiv C D -> CT1_morph C D.
  Proof.
    intro e. exists e.1. exact e.2.
  Defined.

  Definition s2_equiv (C D : CT2) (p1 : CT1_equiv C.1 D.1) : Type :=
    forall a : s2_bound C,
      C.2 a <~> D.2 ((s2b_map (CT1_equiv_to_morph p1)) a).
    (* for some reason we have to coerce manually there *)

  Definition CT2_equiv (C D : CT2) : Type :=
    { p1 : CT1_equiv C D & s2_equiv C D p1}.

  Definition transport_s1_actiononpath
               (C : Type) (D : CT1) (p0 : D.1 = C) (v : s1_bound C) :
                 transport s1 p0 D.2 v =
                 D.2 (s1b_map (equiv_path _ _ p0^) v).
  Proof.
    by induction p0.
  Defined.

    (* proofs *)
  Definition transport_s1_actiononequiv `{Univalence}
               (C : Type) (D : CT1) (p0 : C <~> D.1) (v : s1_bound C) :
                 transport s1 (path_universe_uncurried p0)^ D.2 v =
                 D.2 (s1b_map p0 v).
  Proof.
    pose (t0 := transport_s1_actiononpath C D (path_universe_uncurried p0)^ v).
    refine (t0 @ _) ; clear t0.
    refine (ap D.2 _).
    refine (ap (fun e => (s1b_map (transport idmap e) v)) (inv_V _) @ _ ).
    revert v.
    refine (s1b_map_htpy_invariant _).
    intro v.
    refine (apD10 _ v).
    exact (transport_idmap_path_universe_uncurried p0).
  Defined.

  Definition cancel__ (C : CT1) (v : s1_bound C)
               (p : C.1 = C.1) (pp : p = idpath) :
     transport_s1_actiononpath C C p^ v @
     ap C.2 (ap (fun e : C.1 = C.1 => s1b_map (transport idmap e) v) (inv_V p) @
        s1b_map_htpy_invariant (fun v0 : C =>
           apD10 (ap equiv_fun (ap (equiv_path C.1 C.1) pp)) v0) v) =
     ap (fun e : C.1 = C.1 => transport s1 e^ C.2 v) pp.
  Proof.
    destruct C as (C0 , C1). rewrite <- (inv_V pp). induction pp^. simpl.
    reflexivity.
  Qed.

  Definition transport_s1_actiononequiv_on_id `{Univalence}
               (C : CT1) (v : s1_bound C) :
                 transport_s1_actiononequiv C C (equiv_path C.1 C.1 1) v =
                   ap (fun e => transport s1 e^ C.2 v)
                     (eta_path_universe_uncurried (idmap _)).
  Proof.
    unfold transport_s1_actiononequiv.
    unfold transport_idmap_path_universe_uncurried.
    unfold eta_path_universe_uncurried.
    simpl.
    rewrite eisadj.
    rewrite cancel__.
    reflexivity.
  Qed.

  Definition s1_equiv_is_path `{Univalence}
               (C D : CT1) (p0 : C.1 <~> D.1) :
                 s1_equiv C.2 D.2 p0 <~>
                 (C.2 = transport s1 (path_universe_uncurried p0)^ D.2).
  Proof.
      (* we have to prove an equiv [S <~> T], where [T] is an equality
         between dependent functions. We know this is equivalent to a pointwise
         equiv *)
    simple refine ((equiv_path_arrow _ _) oE _).

      (* now, the [transport ...] can actually be computed, since it
         is a transport over an explicit equivalence. *)
    pose (t0 := transport_s1_actiononequiv C D p0).

      (* [equiv_functor_forall_id] says that a two equivalent fibrations
         induce equivalent Π-types. *)
    pose (t1 :=
      equiv_functor_forall_id (fun v =>
        equiv_path _ _ (ap (fun e => C.2 v = e) (t0 v)))).
    simple refine (t1^-1 oE _).

    exact (equiv_functor_forall_id (fun v => equiv_path_universe _ _)).
  Defined.

  (* characterization of identity types of [CT1] *)
  Definition CT1_equiv_is_path `{Univalence} (C D : CT1) :
               CT1_equiv C D <~> (C = D).
  Proof.
      (* [CT1] is a sigma type, so its pathspace can be described as a sigma *)
    simple refine ((equiv_path_sigma_contra _ C D) oE _).
      (* an equivalence between sigma types [sigT A P <~> sigT B Q] can be given by
         an equivalence [e : A <~> B] and a fiberwise equivalence [Q <~> P] *)
    simple refine (equiv_functor_sigma' (equiv_path_universe C.1 D.1) _).

    exact (s1_equiv_is_path C D).
  Defined.

  (* the trivial equivalence *)
  Definition CT1_idequiv (C : CT1) : CT1_equiv C C :=
    ( equiv_idmap C.1 ; fun v => match v with
                                   | _ => equiv_idmap
                                 end ).

  (* find a better name or just put this inside the proof below *)
  Lemma cancel_ `{Univalence} (C : CT1) (v : s1_bound C.1)
                   (T : (equiv_path C.1 C.1)^-1 (equiv_path C.1 C.1 1) = idpath _) :
    transport idmap
      (ap (fun e : Type => C.2 v = e) (ap (fun e : C.1 = C.1 => transport s1 e^ C.2 v) T))
          (apD10 (transport (fun p : C.1 = C.1 => C.2 = transport s1 p^ C.2)
                            T^ (idpath _)) v) = idpath.
  Proof.
    rewrite <- (inv_V T).
    induction T^.
    reflexivity.
  Qed.

  Definition test (C : Type) : equiv_path C C idpath = 1%equiv := idpath.

  Definition CT1_equiv_is_path_actiononid `{Univalence} (C : CT1) :
               ((CT1_equiv_is_path C C)^-1 (idpath _)) = CT1_idequiv C.
  Proof.
    simple refine (path_sigma _ _ _ _ _).
      - reflexivity.
      - unfold transport.
        refine (path_forall _ _ _).
        intro v. simpl.
        unfold functor_forall.

        (* how to rewrite as? something like:
          rewrite (1%equiv) as (equiv_path (C v) (C v) 1). *)
        rewrite (test _)^.
        refine (ap (equiv_path _ _) _).
        rewrite concat_1p.
        rewrite transport_s1_actiononequiv_on_id.
        unfold eta_path_universe_uncurried.
        apply cancel_.
  Qed.

  Definition transport_s2_actiononequiv `{Univalence}
               (C : CT1) (D : CT2)
               (p1 : CT1_equiv C D) (a : s2_bound C) :
      transport s2 (CT1_equiv_is_path C D p1)^ D.2 a =
      D.2 (s2b_map (CT1_equiv_to_morph p1) a).
  Proof.
    destruct D as (D , D2).
    revert p1. equiv_intro (CT1_equiv_is_path C D)^-1 p. induction p.
    rewrite eisretr.
    rewrite CT1_equiv_is_path_actiononid.
    reflexivity.
  Qed.

  Definition s2_equiv_is_path `{Univalence}
    (C D : CT2) (p1 : CT1_equiv C D) :
     s2_equiv C D p1 <~>
     (C.2 = transport s2 (CT1_equiv_is_path C.1 D.1 p1)^ D.2).
  Proof.
    simple refine ((equiv_path_forall _ _) oE _).

    pose (t0 := transport_s2_actiononequiv C D p1).
    pose (t1 :=
      equiv_functor_forall_id (fun a =>
        equiv_path _ _ (ap (fun e => C.2 a = e) (t0 a)))).
    simple refine (t1^-1 oE _).

    exact (equiv_functor_forall_id (fun v => equiv_path_universe _ _)).
  Defined.

  Definition CT2_equiv_is_path `{Univalence} (C D : CT2) :
               CT2_equiv C D <~> (C = D).
  Proof.
    simple refine ((equiv_path_sigma_contra _ C D) oE _).
    simple refine (equiv_functor_sigma' (CT1_equiv_is_path C.1 D.1) _).
    intro p1.
    apply s2_equiv_is_path.
  Defined.

End IdentityTypes.

(*** opposites:
       - given a 1-CT (graph) we can consider its opposite
       - given a 2-CT we can consider its 1-opposite or its 2-opposite.
         the former flips all the arrows (and the squares accordingly),
         while the latter flips only the squares
 *)
Section Opposites.

  Definition flip {A B : Type} : A * B -> B * A :=
    fun ab => (snd ab , fst ab).

  Definition s1b_flip {C : Type} : s1_bound C -> s1_bound C := flip.

  Definition CT1_opposite (C : CT1) : CT1 :=
    (C.1 ; C.2 o s1b_flip).

  Definition s2b_flip {C : CT1} (b : s2_bound C) : s2_bound C :=
    S2b b.(v00) b.(v10) b.(v01) b.(v11) (* middle points are interchanged *)
        b.(ax0) b.(ax1) b.(a0x) b.(a1x).

  Definition CT2_opposite_2 (C : CT2) : CT2 :=
    (C.1 ; C.2 o s2b_flip).

End Opposites.

(* EXTRAS *)
Definition s1b_Dmap {C0 : Type} {D0 : C0 -> Type}
             (M0 : forall c : C0, D0 c)
             (v : s1_bound C0) : s1_bound (sigT D0) :=
  ((fst v ; M0 (fst v)),
   (snd v ; M0 (snd v))).

Definition s1b_equiv `{Univalence}
             {C0 D0 : Type} (M0 : C0 <~> D0) :
             IsEquiv (s1b_map M0).
Proof.
  destruct M0 as (M0,eM0).
  destruct eM0 as (inv,retr,sect,adj).
  refine (isequiv_biinv _ _).
    - refine ((s1b_map inv ; _), (s1b_map inv ; _) ).
      * intro. refine (s1b_map_funct_comp _ _ _ @ _).
        exact (s1b_map_htpy_invariant sect x).
      * intro. refine (s1b_map_funct_comp _ _ _ @ _).
        exact (s1b_map_htpy_invariant retr x).
Defined.

Definition s1_morph' {C0 : Type} (C1 D1 : s1 C0) : Type :=
  forall v : s1_bound C0, C1 v -> D1 v.

Definition s1_equiv' {C0 : Type} (C1 D1 : s1 C0) : Type :=
  forall v : s1_bound C0, C1 v <~> D1 v.

(* END EXTRAS *)


From stdpp Require Import prelude.
From AML Require Import Signature.
From AML.Syntax Require Import Pattern.

Section sec_pattern_translation.

Context
  `{sign1 : signature EVar SVar Sigma1 EVarSet SVarSet}
  `{EqDecision Sigma2}
  `{sign2 : !signature EVar SVar Sigma2 EVarSet SVarSet}
  (h : Sigma1 -> Sigma2)
  `{!SignatureMorphism sign1 sign2 h}.

Fixpoint pattern_translation (p : Pattern (Sigma := Sigma1))
  : Pattern (Sigma := Sigma2) :=
  match p with
  | PEVar e => PEVar e
  | PSVar s => PSVar s
  | p1 →ₚ p2 => pattern_translation p1 →ₚ pattern_translation p2
  | PEx e p => PEx e (pattern_translation p)
  | μₚ s p => μₚ s (pattern_translation p)
  | PApp p1 p2 => PApp (pattern_translation p1) (pattern_translation p2)
  | POp s => POp (h s)
  end.

Definition pattern_set_translation
  `{FinSet (Pattern (Sigma := Sigma1)) PatternSet1}
  `{FinSet (Pattern (Sigma := Sigma2)) PatternSet2}
    (Γ : PatternSet1)
  : PatternSet2 :=
  set_map pattern_translation Γ.

End sec_pattern_translation.


Require Import Coq.Classes.Morphisms.

Require Import Crypto.Spec.CompleteEdwardsCurve Crypto.Curves.Edwards.AffineProofs.

Require Import Crypto.Util.Notations Crypto.Util.GlobalSettings.
Require Export Crypto.Util.FixCoqMistakes.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.UniquePose.

Section ExtendedCoordinates.
  Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
          {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
          {char_ge_3 : @Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul (BinNat.N.succ_pos BinNat.N.two)}
          {Feq_dec:DecidableRel Feq}.
  Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Notation "0" := Fzero.  Local Notation "1" := Fone.
  Local Infix "+" := Fadd. Local Infix "*" := Fmul.
  Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
  Local Notation "x ^ 2" := (x*x).

  Context {a d: F}
          {nonzero_a : a <> 0}
          {square_a : exists sqrt_a, sqrt_a^2 = a}
          {nonsquare_d : forall x, x^2 <> d}.
  Local Notation Epoint := (@E.point F Feq Fone Fadd Fmul a d).

  Local Notation onCurve x y := (a*x^2 + y^2 = 1 + d*x^2*y^2) (only parsing).
  (** [Extended.point] represents a point on an elliptic curve using extended projective
   * Edwards coordinates 1 (see <https://eprint.iacr.org/2008/522.pdf>). *)
  Definition point := { P | let '(X,Y,Z,T) := P in
                            a * X^2*Z^2 + Y^2*Z^2 = (Z^2)^2 + d * X^2 * Y^2
                            /\ X * Y = Z * T
                            /\ Z <> 0 }.
  Definition coordinates (P:point) : F*F*F*F := proj1_sig P.
  Definition eq (P1 P2:point) :=
    let '(X1, Y1, Z1, _) := coordinates P1 in
    let '(X2, Y2, Z2, _) := coordinates P2 in
    Z2*X1 = Z1*X2 /\ Z2*Y1 = Z1*Y2.

  Ltac t_step :=
    match goal with
    | |- Proper _ _ => intro
    | _ => progress intros
    | _ => progress destruct_head' prod
    | _ => progress destruct_head' @E.point
    | _ => progress destruct_head' point
    | _ => progress destruct_head' and
    | _ => progress cbv [eq CompleteEdwardsCurve.E.eq E.eq E.zero E.add E.opp fst snd coordinates E.coordinates proj1_sig] in *
    | |- _ /\ _ => split | |- _ <-> _ => split
    end.
  Ltac t := repeat t_step; Field.fsatz.

  Global Instance Equivalence_eq : Equivalence eq.
  Proof using Feq_dec field nonzero_a. split; repeat intro; t. Qed.
  Global Instance DecidableRel_eq : Decidable.DecidableRel eq.
  Proof. intros P Q; destruct P as [ [ [ [ ] ? ] ? ] ?], Q as [ [ [ [ ] ? ] ? ] ? ]; exact _. Defined.

  Program Definition from_twisted (P:Epoint) : point :=
    let xy := E.coordinates P in (fst xy, snd xy, 1, fst xy * snd xy).
  Next Obligation. t. Qed.
  Global Instance Proper_from_twisted : Proper (E.eq==>eq) from_twisted.
  Proof using Type. cbv [from_twisted]; t. Qed.

  Program Definition to_twisted (P:point) : Epoint :=
    let XYZT := coordinates P in let T := snd XYZT in
                                 let XYZ  := fst XYZT in      let Z := snd XYZ in
                                                              let XY   := fst XYZ in       let Y := snd XY in
                                                                                let X    := fst XY in
                                                                                let iZ := Finv Z in ((X*iZ), (Y*iZ)).
  Next Obligation. t. Qed.
  Global Instance Proper_to_twisted : Proper (eq==>E.eq) to_twisted.
  Proof using Type. cbv [to_twisted]; t. Qed.

  Lemma to_twisted_from_twisted P : E.eq (to_twisted (from_twisted P)) P.
  Proof using Type. cbv [to_twisted from_twisted]; t. Qed.
  Lemma from_twisted_to_twisted P : eq (from_twisted (to_twisted P)) P.
  Proof using Type. cbv [to_twisted from_twisted]; t. Qed.

  Program Definition zero : point := (0, 1, 1, 0).
  Next Obligation. t. Qed.

  Program Definition opp P : point :=
    match coordinates P return F*F*F*F with (X,Y,Z,T) => (Fopp X, Y, Z, Fopp T) end.
  Next Obligation. t. Qed.

  Section TwistMinusOne.
    Context {a_eq_minus1:a = Fopp 1} {twice_d} {k_eq_2d:twice_d = d+d}.
    Program Definition m1add
            (P1 P2:point) : point :=
      match coordinates P1, coordinates P2 return F*F*F*F with
        (X1, Y1, Z1, T1), (X2, Y2, Z2, T2) =>
        let A := (Y1-X1)*(Y2-X2) in
        let B := (Y1+X1)*(Y2+X2) in
        let C := T1*twice_d*T2 in
        let D := Z1*(Z2+Z2) in
        let E := B-A in
        let F := D-C in
        let G := D+C in
        let H := B+A in
        let X3 := E*F in
        let Y3 := G*H in
        let T3 := E*H in
        let Z3 := F*G in
        (X3, Y3, Z3, T3)
      end.
    Next Obligation.
      match goal with
      | [ |- match (let (_, _) := coordinates ?P1 in let (_, _) := _ in let (_, _) := _ in let (_, _) := coordinates ?P2 in _) with _ => _ end ]
        => pose proof (E.denominator_nonzero _ nonzero_a square_a _ nonsquare_d _ _ (proj2_sig (to_twisted P1))  _ _  (proj2_sig (to_twisted P2)))
      end; t.
    Qed.

    Global Instance isomorphic_commutative_group_m1 :
      @Group.isomorphic_commutative_groups
        Epoint E.eq
        (E.add(nonzero_a:=nonzero_a)(square_a:=square_a)(nonsquare_d:=nonsquare_d))
        (E.zero(nonzero_a:=nonzero_a))
        (E.opp(nonzero_a:=nonzero_a))
        point eq m1add zero opp
        from_twisted to_twisted.
    Proof.
      eapply Group.commutative_group_by_isomorphism; try exact _.
      par: abstract
             (cbv [to_twisted from_twisted zero opp m1add]; intros;
              repeat match goal with
                     | |- context[E.add ?P ?Q] =>
                       unique pose proof (E.denominator_nonzero _ nonzero_a square_a _ nonsquare_d _ _  (proj2_sig P)  _ _  (proj2_sig Q)) end;
              t).
    Qed.
  End TwistMinusOne.
End ExtendedCoordinates.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac auth gmap csum.
From iris.base_logic.lib Require Import invariants.
From iris_examples.logatom Require Export treiber.

(** The flat combiner uses a bag, this is where we prove the spec for that.
    We re-use the code but not the spec of the treiber stack. *)

Section defs.
  Context `{heapG Σ} (N: namespace).
  Context (R: val → iProp Σ) `{∀ x, TimelessP (R x)}.

  Fixpoint is_list_R (hd: loc) (xs: list val) : iProp Σ :=
    match xs with
    | [] => (∃ q, hd ↦{ q } NONEV)%I
    | x :: xs => (∃ (hd': loc) q, hd ↦{q} SOMEV (x, #hd') ∗ inv N (R x) ∗ is_list_R hd' xs)%I
    end.

  Definition is_bag_R xs s := (∃ hd: loc, s ↦ #hd ∗ is_list_R hd xs)%I.

  Lemma dup_is_list_R : ∀ xs hd,
    is_list_R hd xs ⊢ |==> is_list_R hd xs ∗ is_list_R hd xs.
  Proof.
    induction xs as [|y xs' IHxs'].
    - iIntros (hd) "Hs".
      simpl. iDestruct "Hs" as (q) "[Hhd Hhd']". iSplitL "Hhd"; eauto.
    - iIntros (hd) "Hs". simpl.
      iDestruct "Hs" as (hd' q) "([Hhd Hhd'] & #Hinv & Hs')".
      iDestruct (IHxs' with "[Hs']") as ">[Hs1 Hs2]"; first by iFrame.
      iModIntro. iSplitL "Hhd Hs1"; iExists hd', (q / 2)%Qp; by iFrame.
  Qed.

  Definition f_spec (R: iProp Σ) (f: val) (Rf: iProp Σ) x :=
    {{{ inv N R ∗ Rf }}}
      f x
    {{{ RET #(); Rf }}}.

End defs.

Section proofs.
  Context `{heapG Σ} (N: namespace).
  Context (R: val → iProp Σ).

  Definition bag_inv s: iProp Σ := inv N (∃ xs, is_bag_R N R xs s)%I.

  Lemma new_bag_spec:
    {{{ True }}} new_stack #() {{{ s, RET #s; bag_inv s }}}.
  Proof.
    iIntros (Φ) "_ HΦ". iApply wp_fupd.
    wp_lam. wp_bind (ref NONE)%E. wp_alloc l as "Hl".
    wp_alloc s as "Hs".
    iAssert ((∃ xs, is_bag_R N R xs s))%I with "[-HΦ]" as "Hxs".
    { iFrame. iExists [], l.
      iFrame. simpl. eauto. }
    iMod (inv_alloc N _ (∃ xs : list val, is_bag_R N R xs s)%I with "[-HΦ]") as "#?"; first eauto.
    iApply "HΦ". iFrame "#". done.
  Qed.

  Lemma push_spec (s: loc) (x: val):
    {{{ R x ∗ bag_inv s }}} push #s x {{{ RET #() ; inv N (R x) }}}.
  Proof.
    iIntros (Φ) "(HRx & #?) HΦ".
    iLöb as "IH". wp_rec. wp_let.
    wp_bind (! _)%E.
    iInv N as "H1" "Hclose".
    iDestruct "H1" as (xs hd) "[>Hs H1]".
    wp_load. iMod ("Hclose" with "[Hs H1]").
    { iNext. iFrame. iExists xs, hd. iFrame. }
    iModIntro. wp_let. wp_alloc l as "Hl".
    wp_let. wp_bind (CmpXchg _ _ _)%E.
    iInv N as "H1" "Hclose".
    iDestruct "H1" as (xs' hd') "[>Hs H1]".
    destruct (decide (hd = hd')) as [->|Hneq].
    - wp_cmpxchg_suc.
      iMod (inv_alloc N _ (R x) with "[HRx]") as "#HRx"; first eauto.
      iMod ("Hclose" with "[Hs Hl H1]").
      { iNext. iFrame. iExists (x::xs'), l.
        iFrame. simpl. iExists hd', 1%Qp. iFrame.
        by iFrame "#". }
      iModIntro. wp_pures. by iApply "HΦ".
    - wp_cmpxchg_fail.
      iMod ("Hclose" with "[Hs H1]").
      { iNext. iFrame. iExists (xs'), hd'. iFrame. }
      iModIntro. wp_pures. iApply ("IH" with "HRx").
      by iNext.
  Qed.

End proofs.


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

(***
Modulus : 2^255 - 19
Base: 51
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 51;
    bitwidth := 64;
    s := 2^255;
    c := [(1, 19)];
    carry_chains := Some [seq 0 (pred 5); [0; 1]]%nat;

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

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

    mul_code := Some (fun a b =>
      (* Micro-optimized form from curve25519-donna-c64 by Adam Langley (Google) and Daniel Bernstein. See <https://github.com/agl/curve25519-donna/blob/master/LICENSE.md>. *)
      let '(r4, r3, r2, r1, r0) := a in
      let '(s4, s3, s2, s1, s0) := b in
      dlet t0  :=  r0 * s0 in
      dlet t1  :=  r0 * s1 + r1 * s0 in
      dlet t2  :=  r0 * s2 + r2 * s0 + r1 * s1 in
      dlet t3  :=  r0 * s3 + r3 * s0 + r1 * s2 + r2 * s1 in
      dlet t4  :=  r0 * s4 + r4 * s0 + r3 * s1 + r1 * s3 + r2 * s2 in

      dlet r4 := r4 * 19 in
      dlet r1 := r1 * 19 in
      dlet r2 := r2 * 19 in
      dlet r3 := r3 * 19 in

      dlet t0 := t0 + r4 * s1 + r1 * s4 + r2 * s3 + r3 * s2 in
      dlet t1 := t1 + r4 * s2 + r2 * s4 + r3 * s3 in
      dlet t2 := t2 + r4 * s3 + r3 * s4 in
      dlet t3 := t3 + r4 * s4 in
      (t4, t3, t2, t1, t0)
            );

    square_code := Some (fun a =>
      (* Micro-optimized form from curve25519-donna-c64 by Adam Langley (Google) and Daniel Bernstein. See <https://github.com/agl/curve25519-donna/blob/master/LICENSE.md>. *)
      let '(r4, r3, r2, r1, r0) := a in
      dlet d0 := r0 * 2 in
      dlet d1 := r1 * 2 in
      dlet d2 := r2 * 2 * 19 in
      dlet d419 := r4 * 19 in
      dlet d4 := d419 * 2 in

      dlet t0 := r0 * r0 + d4 * r1 + (d2 * (r3     )) in
      dlet t1 := d0 * r1 + d4 * r2 + (r3 * (r3 * 19)) in
      dlet t2 := d0 * r2 + r1 * r1 + (d4 * (r3     )) in
      dlet t3 := d0 * r3 + d1 * r2 + (r4 * (d419   )) in
      dlet t4 := d0 * r4 + d1 * r3 + (r2 * (r2     )) in
      (t4, t3, t2, t1, t0)
            );

    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.