Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e255m19_10limbs_donna.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e416m2e208m1_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


(** Definition of Fsub (System F with subtyping).

    Adapted from Metalib
*)

Require Export Metalib.Metatheory.

(* ********************************************************************** *)
(** * Syntax *)

Definition i := nat.

Inductive ftyp : Set :=
  | ftyp_top : ftyp
  | ftyp_nat : ftyp
  | ftyp_bvar : nat -> ftyp
  | ftyp_fvar : atom -> ftyp
  | ftyp_arrow : ftyp -> ftyp -> ftyp
  | ftyp_all : ftyp -> ftyp -> ftyp
  | ftyp_rcd_nil : ftyp
  | ftyp_rcd_cons : i -> ftyp -> ftyp -> ftyp
.

Inductive fexp : Set :=
  | fexp_top : fexp
  | fexp_lit : i -> fexp
  | fexp_bvar : nat -> fexp
  | fexp_fvar : atom -> fexp
  | fexp_abs : ftyp -> fexp -> fexp
  | fexp_app : fexp -> fexp -> fexp
  | fexp_tabs : ftyp -> fexp -> fexp
  | fexp_tapp : fexp -> ftyp -> fexp
  | fexp_rcd_nil : fexp
  | fexp_rcd_cons : i -> fexp -> fexp -> fexp
  | fexp_rcd_proj : fexp -> i -> fexp
.

Coercion ftyp_bvar : nat >-> ftyp.
Coercion ftyp_fvar : atom >-> ftyp.
Coercion fexp_bvar : nat >-> fexp.
Coercion fexp_fvar : atom >-> fexp.

(* ********************************************************************** *)
(** * Open *)

Fixpoint open_tt_rec (K : nat) (U : ftyp) (T : ftyp)  {struct T} : ftyp :=
  match T with
  | ftyp_top => ftyp_top
  | ftyp_rcd_nil => ftyp_rcd_nil
  | ftyp_rcd_cons i T1 T2  => ftyp_rcd_cons i (open_tt_rec K U T1) (open_tt_rec K U T2)
  | ftyp_nat => ftyp_nat
  | ftyp_bvar J => if K == J then U else (ftyp_bvar J)
  | ftyp_fvar X => ftyp_fvar X
  | ftyp_arrow T1 T2 => ftyp_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | ftyp_all T1 T2 => ftyp_all (open_tt_rec K U T1) (open_tt_rec (S K) U T2)
  end.

Fixpoint open_te_rec (K : nat) (U : ftyp) (e : fexp) {struct e} : fexp :=
  match e with
  | fexp_top => fexp_top
  | fexp_rcd_nil => fexp_rcd_nil
  | fexp_rcd_cons i e1 e2 => fexp_rcd_cons i (open_te_rec K U e1) (open_te_rec K U e2)
  | fexp_rcd_proj e1 i => fexp_rcd_proj (open_te_rec K U e1) i
  | fexp_lit i => fexp_lit i
  | fexp_bvar i => fexp_bvar i
  | fexp_fvar x => fexp_fvar x
  | fexp_abs V e1 => fexp_abs  (open_tt_rec K U V)  (open_te_rec K U e1)
  | fexp_app e1 e2 => fexp_app  (open_te_rec K U e1) (open_te_rec K U e2)
  | fexp_tabs V e1 => fexp_tabs (open_tt_rec K U V)  (open_te_rec (S K) U e1)
  | fexp_tapp e1 V => fexp_tapp (open_te_rec K U e1) (open_tt_rec K U V)
  end.

Fixpoint open_ee_rec (k : nat) (f : fexp) (e : fexp)  {struct e} : fexp :=
  match e with
  | fexp_top => fexp_top
  | fexp_rcd_nil => fexp_rcd_nil
  | fexp_rcd_cons i e1 e2 => fexp_rcd_cons i (open_ee_rec k f e1) (open_ee_rec k f e2)
  | fexp_rcd_proj e1 i => fexp_rcd_proj (open_ee_rec k f e1) i
  | fexp_lit i => fexp_lit i
  | fexp_bvar i => if k == i then f else (fexp_bvar i)
  | fexp_fvar x => fexp_fvar x
  | fexp_abs V e1 => fexp_abs V (open_ee_rec (S k) f e1)
  | fexp_app e1 e2 => fexp_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | fexp_tabs V e1 => fexp_tabs V (open_ee_rec k f e1)
  | fexp_tapp e1 V => fexp_tapp (open_ee_rec k f e1) V
  end.

Definition open_tt T U := open_tt_rec 0 U T.
Definition open_te e U := open_te_rec 0 U e.
Definition open_ee e1 e2 := open_ee_rec 0 e2 e1.

(* ********************************************************************** *)
(** * Closed Syntax *)

Inductive rt_type : ftyp -> Prop :=
  | rt_type_rcd_nil :
      rt_type ftyp_rcd_nil
  | rt_type_rcd_cons : forall i T1 T2,
      rt_type (ftyp_rcd_cons i T1 T2)
.

Inductive type : ftyp -> Prop :=
  | type_top :
      type ftyp_top
  | type_lit :
      type ftyp_nat
  | type_var : forall X,
      type (ftyp_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (ftyp_arrow T1 T2)
  | type_all : forall L T1 T2,
      type T1 ->
      (forall X : atom, X `notin` L -> type (open_tt T2 X)) ->
      type (ftyp_all T1 T2)
  | type_rcd_nil :
      type ftyp_rcd_nil
  | type_rcd_cons : forall i T1 T2,
      type T1 ->
      type T2 ->
      rt_type T2 ->
      type (ftyp_rcd_cons i T1 T2)
.

Inductive rt_expr : fexp -> Prop :=
  | rt_expr_rcd_nil :
      rt_expr fexp_rcd_nil
  | rt_expr_rcd_cons : forall i e1 e2,
      rt_expr (fexp_rcd_cons i e1 e2)
.

Inductive expr : fexp -> Prop :=
  | expr_top :
      expr fexp_top
  | expr_lit : forall i,
      expr (fexp_lit i)
  | expr_var : forall x,
      expr (fexp_fvar x)
  | expr_abs : forall L T e1,
      type T ->
      (forall x : atom, x `notin` L -> expr (open_ee e1 x)) ->
      expr (fexp_abs T e1)
  | expr_app : forall e1 e2,
      expr e1 ->
      expr e2 ->
      expr (fexp_app e1 e2)
  | expr_tabs : forall L T e1,
      type T ->
      (forall X : atom, X `notin` L -> expr (open_te e1 X)) ->
      expr (fexp_tabs T e1)
  | expr_tapp : forall e1 V,
      expr e1 ->
      type V ->
      expr (fexp_tapp e1 V)
  | expr_rcd_nil :
      expr fexp_rcd_nil
  | expr_rcd_cons : forall i e1 e2,
      expr e1 ->
      expr e2 ->
      rt_expr e2 ->
      expr (fexp_rcd_cons i e1 e2)
  | expr_rcd_proj : forall i e,
      expr e ->
      expr (fexp_rcd_proj e i)
.

Definition body_e (e : fexp) :=
  exists L, forall x : atom, x `notin` L -> expr (open_ee e x).

(* ********************************************************************** *)
(** * Environment *)

Inductive binding : Set :=
  | bind_sub : ftyp -> binding
  | bind_typ : ftyp -> binding.

Notation env := (list (atom * binding)).
Notation empty := (@nil (atom * binding)).

Inductive fmono : env -> ftyp -> Prop :=
| fmono_nat : forall E,
    fmono E ftyp_nat
| fmono_top : forall E,
    fmono E ftyp_top
| fmono_var_f : forall E X U,
    binds X (bind_sub U) E ->
    fmono E U ->
    (fmono E (ftyp_fvar X))
| fmono_arrow : forall E (A B:ftyp),
    (fmono E A) ->
    (fmono E B) ->
    (fmono E (ftyp_arrow A B))
.

(* ********************************************************************** *)
(** * Well-formedness *)

Inductive wf_typ : env -> ftyp -> Prop :=
  | wf_typ_top : forall E,
      wf_typ E ftyp_top
  | wf_typ_nat : forall E,
      wf_typ E ftyp_nat
  | wf_typ_var : forall U E (X : atom),
      binds X (bind_sub U) E ->
      wf_typ E (ftyp_fvar X)
  | wf_typ_arrow : forall E T1 T2,
      wf_typ E T1 ->
      wf_typ E T2 ->
      wf_typ E (ftyp_arrow T1 T2)
  | wf_typ_all : forall L E T1 T2,
      wf_typ E T1 ->
      (forall X : atom, X `notin` L ->
        wf_typ (X ~ bind_sub T1 ++ E) (open_tt T2 X)) ->
      wf_typ E (ftyp_all T1 T2)
  | wf_typ_rcd_nil : forall E,
      wf_typ E ftyp_rcd_nil
  | wf_typ_rcd_cons : forall E i T1 T2,
      wf_typ E T1 ->
      wf_typ E T2 ->
      rt_type T2 ->
      wf_typ E (ftyp_rcd_cons i T1 T2)
.

Inductive wf_env : env -> Prop :=
  | wf_env_empty :
      wf_env empty
  | wf_env_sub : forall (E : env) (X : atom) (T : ftyp),
      wf_env E ->
      wf_typ E T ->
      X `notin` dom E ->
      wf_env (X ~ bind_sub T ++ E)
  | wf_env_typ : forall (E : env) (x : atom) (T : ftyp),
      wf_env E ->
      wf_typ E T ->
      x `notin` dom E ->
      wf_env (x ~ bind_typ T ++ E).

(* ********************************************************************** *)
(** * Subtyping *)

Inductive fsub : env -> ftyp -> ftyp -> Prop :=
  | fsub_top : forall E S,
      wf_env E ->
      wf_typ E S ->
      fsub E S ftyp_top
  | fsub_nat : forall E,
      wf_env E ->
      fsub E ftyp_nat ftyp_nat
  | fsub_refl_tvar : forall E X,
      wf_env E ->
      wf_typ E (ftyp_fvar X) ->
      fsub E (ftyp_fvar X) (ftyp_fvar X)
  | fsub_trans_tvar : forall U E X,
      wf_env E ->
      binds X (bind_sub U) E ->
      fsub E (ftyp_fvar X) U
  | fsub_trans : forall E A B C,
      fsub E A B ->
      fsub E B C ->
      fsub E A C
  | fsub_arrow : forall E S1 S2 T1 T2,
      fsub E T1 S1 ->
      fsub E S2 T2 ->
      fsub E (ftyp_arrow S1 S2) (ftyp_arrow T1 T2)
  (* Note: we use the kernel version *)
  | fsub_all : forall L E A B1 B2,
      fsub E A A ->
      (forall X : atom, X `notin` L ->
          fsub (X ~ bind_sub A ++ E) (open_tt B1 X) (open_tt B2 X)) ->
      fsub E (ftyp_all A B1) (ftyp_all A B2)
  | fsub_rcd_nil : forall E,
      wf_env E ->
      fsub E ftyp_rcd_nil ftyp_rcd_nil
  | fsub_rcd_width : forall E A B i,
      wf_env E ->
      wf_typ E A ->
      wf_typ E B ->
      rt_type B ->
      fsub E (ftyp_rcd_cons i A B) (ftyp_rcd_nil)
  | fsub_rcd_depth : forall E A1 B1 i A2 B2,
      fsub E A1 A2 ->
      fsub E B1 B2 ->
      rt_type B1 ->
      rt_type B2 ->
      fsub E (ftyp_rcd_cons i A1 B1) (ftyp_rcd_cons i A2 B2)
  | fsub_rcd_perm : forall E i j A1 A2 A3,
      wf_env E ->
      wf_typ E A1 ->
      wf_typ E A2 ->
      wf_typ E A3 ->
      rt_type A3 ->
      fsub E (ftyp_rcd_cons i A1 (ftyp_rcd_cons j A2 A3))
             (ftyp_rcd_cons j A2 (ftyp_rcd_cons i A1 A3))
.

(* ********************************************************************** *)
(** * Automation *)

Hint Constructors rt_type type rt_expr expr wf_typ wf_env.
Hint Resolve fsub_top fsub_nat fsub_refl_tvar fsub_arrow fsub_rcd_nil fsub_rcd_width fsub_rcd_depth fsub_rcd_perm.


Require Import Nat Coq.Lists.List.

(* @TODO structure Require ? Section ? Module ? *)

Require Spreadable.

Eval compute in (Spreadable.Map list).
(* Le map des listes a le type Map list *)
Definition maplist : Spreadable.Map list := Coq.Lists.List.map.

Eval compute in (Spreadable.Fold list).

Eval compute in (Spreadable.TransPred list).

Eval compute in (Spreadable.DecEq list).

Require Tuple.

Eval compute in (Map (Tuple 3)).
(* forall A B : Type,
       (A -> B) ->
       A * (A * (A * A)) -> B * (B * (B * B))*)

Eval compute in (Fold (Tuple 2)).

Check (flatten (Tuple 4) (tuple_foldable 4)).


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Construction.Opposite.
Require Export Category.Instance.Roof.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Definition Span (C : Category) := Roof ⟶ C.

Definition Cospan (C : Category) := Roof^op ⟶ C.

Program Definition ASpan {C : Category} {S x y : C} (f : S ~> x) (g : S ~> y) :
  Roof ⟶ C := {|
  fobj := fun z => match z with
    | RNeg  => x
    | RZero => S
    | RPos  => y
    end;
  fmap := fun z w _ => match z, w with
    | RNeg,  RNeg  => id[x]
    | RZero, RNeg  => f
    | RZero, RZero => id[S]
    | RZero, RPos  => g
    | RPos,  RPos  => id[y]
    | _,      _      => _
    end
|}.
Next Obligation.
  destruct z, w; simpl; intuition idtac; auto with roof_laws.
Defined.
Next Obligation. intuition idtac; discriminate. Qed.
Next Obligation. intuition idtac; discriminate. Qed.
Next Obligation. intuition idtac; discriminate. Qed.
Next Obligation. intuition idtac; discriminate. Qed.
Next Obligation.
  proper.
  destruct x0, y0; simpl; auto with roof_laws; reflexivity.
Qed.
Next Obligation.
  destruct x0; reflexivity.
Qed.
Next Obligation.
  destruct x0, y0, z; simpl; auto with roof_laws;
  rewrite ?id_left, ?id_right;
  reflexivity.
Qed.


(** * Results about Topology *)
(** Author: Catherine LELAY. Jan 2016 - *)
(** Based on Bourbaky *)

Require Import UniMath.Foundations.Preamble.
Require Import UniMath.MoreFoundations.Tactics.
Require Export UniMath.Topology.Filters.
Require Import UniMath.Algebra.DivisionRig.
Require Import UniMath.Algebra.ConstructiveStructures.

Require Import UniMath.Topology.Topology.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.

(** * Displayed category of topological spaces *)

Definition top_disp_cat_ob_mor : disp_cat_ob_mor hset_category.
Proof.
  use make_disp_cat_ob_mor.
  - intro X. exact (isTopologicalSpace X).
  - intros X Y T U f.
    exact (@continuous (X,,T) (Y,,U) f).
Defined.

Definition top_disp_cat_data : disp_cat_data hset_category.
Proof.
  exists top_disp_cat_ob_mor.
  split.
  - do 5 intro. assumption.
  - intros *. apply continuous_funcomp.
Defined.

Definition top_disp_cat_axioms : disp_cat_axioms hset_category top_disp_cat_data.
Proof.
  do 3 (split ; intros ; try (apply proofirrelevance, isaprop_continuous)).
  apply isasetaprop, isaprop_continuous.
Defined.

Definition disp_top : disp_cat hset_category := _ ,, top_disp_cat_axioms.


From mathcomp Require Import ssreflect ssrbool ssrnat seq ssrfun.
From mf Require Import all_mf choice_mf.
Require Import baire cont iseg minm.
Require Import Classical ChoiceFacts.

Axiom choice_nat: forall T, FunctionalChoice_on T nat.
Arguments choice_nat {T} {R}.
Axiom choice: FunctionalChoice.
Arguments choice {A} {B} {R}.
Axiom countable_choice: FunctionalCountableChoice.
Axiom bool_choice: FunctionalCountableChoice_on bool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma well_order_nat (P : nat -> Prop):
  (exists n, P n) -> exists n, P n /\ forall m, P m -> n <= m.
Proof.
  pose R:= (fun n b => P n <-> is_true b).
  have [ | p prop]:= bool_choice R.
    by move => n; case: (classic (P n)) => pn; [exists true|exists false]; split.
  move => [m Pm].
  have ex: exists n, p n by exists m; apply prop.
  have [n [pn min]]:= (worder_nat ex).
  by exists n; split => [ | k Pk ]; [ | apply min]; apply prop.
Qed.

(*
Lemma minimal_section Q (cnt: nat -> Q):
	cnt \is_surjective_function -> exists sec, is_min_sec cnt sec.
Proof.
move => sur.
set R := make_mf (fun s n => cnt n = s /\ (forall m, cnt m = s -> n <= m)).
have Rtot: R \is_total by move => s; have [n]:= well_order_nat (sur s); exists n.
by have [sec]:= (choice _ Rtot); exists sec; split => s; have []:= p s.
Qed.
*)

Section classical_lemmas.
  Context (Q Q' A A': Type) (noq: Q).
  Notation B := (Q -> A).
  Notation B' := (Q' -> A').
  Local Open Scope baire_scope.
  Context (cnt: nat -> Q) (sec: Q -> nat) (ms: minimal_section cnt sec).
  Notation minimal_modulus := (minimal_modulus cnt sec).
  Notation init_seg := (iseg cnt).
  Notation max_elt := (max_elt sec).

  Lemma cont_choice (F: B ->> B'): F \is_continuous <->
    forall phi Fphi, F phi Fphi -> forall q', exists L, certificate F L phi q' (Fphi q').
  Proof.
    split => cont phi Fphi FphiFphi; first move => q'.
    - by have [Lf mod] := cont phi Fphi FphiFphi; exists (Lf q'); apply/mod.
    by have [Lf mod]:= choice (cont phi Fphi FphiFphi); exists Lf.
  Qed.

  Lemma F2MF_cont_choice (F: B -> B'): F \is_continuous_function <->
    forall phi q', exists L, forall psi, phi \and psi \coincide_on L -> F phi q' = F psi q'.
  Proof.
    split=> [cont phi q' | cont phi].
    - by have [Lf mod]:= cont phi; exists (Lf q') => psi; apply/mod.
    by have [Lf mod]:= choice (cont phi); exists Lf => q' psi; apply/mod.
  Qed.

  Lemma cert_cdom (F: B ->> B') phi q' a':
    ~ phi \from closure (dom F) -> exists L, certificate F L phi q' a'.
  Proof.
    move => neg.
    have [L Lprop]: exists L, forall psi, ~ (phi \and psi \coincide_on L /\ psi \from dom F).
    - apply NNPP => ex; apply neg => L; apply NNPP => negi.
      exfalso; apply ex; exists L => psi [] coin val.
      by apply negi; exists psi.
    exists L => psi coin Fpsi FpsiFpsi.
    exfalso; apply (Lprop psi).
    by split; last exists Fpsi.
  Qed.

  Lemma dom_minmod (F: B ->> B'):
    dom (minimal_modulus F) === dom (continuity_modulus F).
  Proof.
    move => phi; split => [[mf [mod min]] | [Lf mod]]; first by exists (fun q' => init_seg (mf q')).
    pose R q' n :=
      (exists a', certificate F (init_seg n) phi q' a')
      /\
      forall (Lf': Q' -> seq Q), continuity_modulus F phi Lf' -> n <= max_elt (Lf' q').
    have Rtot: forall q', exists n, R q' n.
    - move => q'; pose p n := exists a', certificate F (init_seg n) phi q' a'.
      have ex: exists n, p n.
      - exists (max_elt (Lf q')); have [a' crt]:= (mod q').
        by exists a'; apply/crt_exte/crt/iseg_melt.
      have [n [prp min]]:= well_order_nat ex.
      exists n; split => // Lf' mod'; apply/min; rewrite /p; have [a' crt]:= mod' q'.
      by exists a'; apply/crt_exte/crt/iseg_melt.
    have [mf mfprop] := choice_nat Rtot; exists mf.
    by split => [q' | Lf' mod' q']; [exact/(mfprop q').1 | exact/(mfprop q').2].
  Qed.

  Lemma exists_minmod (F: B ->> B'): F \is_continuous ->
    exists mf, forall phi, phi \from dom F -> minimal_modulus F phi (mf phi).
  Proof.
    have [mf icf]:= exists_choice (minimal_modulus F) (fun _ => 0) => /cont_spec cont.
    exists mf => phi [Fphi val].
    have [ | mf' mod']:= (dom_minmod F phi).2; first by apply/cont; exists Fphi.
    by split => [q' | Lf mod q']; have [cont' prp]:= icf phi mf' mod'; last have:= prp Lf mod q'.
  Qed.
End classical_lemmas.


From Coq Require Import List  ssreflect ssrfun.
From Mon Require Import Base.
From Mon.sprop Require Import SPropBase SPropMonadicStructures.
From Mon.SRelation Require Import SRelationClasses SMorphisms.
From Mon.SM Require Import SMSyntax SMDenotationsMonotonic.
From Equations Require Import Equations.

(** From a monad in SM (icmonad) we define :   *)
(** - a mapping (CMonad) from monads to monads *)
(** - a lift from the source monad to CMonad   *)
(** - under the hypothesis that the resulting
      bind is a homomorphism (HBindHomo), the
      lift is a monad morphism                 *)
(** - under the hypothesis that the SM monad is
      covariant, there is a functorial action
      on monad morphism CMonadMorph, and the
      lift defines a natural transformation
      from the identity to CMonad              *)

Set Universe Polymorphism.
Set Primitive Projections.

Section ToOrderedMonad.
  Context (M : OrderedMonad) (C : icmonad).
  Let CM := icM C.

  Definition carrier (X:Type) : Type := ⦑CM X|M⦒.
  Definition ret' A :=
    icterm_to_term M (icRet C A) Substitution.dNil.
  Definition bind' A B m f :=
      Spr1 (Spr1 (icterm_to_term M (icBind C A B) Substitution.dNil) m) f.

  Definition MonadFromEqns pf1 pf2 pf3 : Monad :=
    @mkMonad carrier ret' bind' pf1 pf2 pf3.

  Program Definition OrderedMonadFromEqns pf1 pf2 pf3 : OrderedMonad :=
    @mkOrderedMonad (MonadFromEqns pf1 pf2 pf3) (fun X => to_ord M (CM X)) _ _.
  Next Obligation.
    rewrite /bind'.
    estransitivity.
    move: (Spr2 (icterm_to_term M (icBind C A B) Substitution.dNil) x y H x0) => /= w1 ; exact w1.
    apply (Spr2 (Spr1 (icterm_to_term M (icBind C A B) Substitution.dNil) y) x0 y0 H0).
  Qed.

  Import Substitution.

  Program Definition CMonad : OrderedMonad := OrderedMonadFromEqns _ _ _.
  Next Obligation.
    pose (fun f => iceq_to_eq M (icRetBind C A B a) (dCons f dNil)).
    specialize (e (dpair _ ⟨f, f⟩ eq_refl)).

    simpl in e.
    rewrite (dlookup_equation_2 _ _ _ _ _ _) in e.
    rewrite !to_term_weaken in e.
    exact e.
  Qed.

  Next Obligation.
    pose (fun c => iceq_to_eq M (icBindRet C A) (dCons c dNil)).
    specialize (e (dpair _ ⟨c, c⟩ eq_refl)).
    simpl in e.
    rewrite !to_term_weaken in e.
    rewrite (dlookup_equation_2 _ _ _ _ _ _) in e.
    exact e.
  Qed.

  Next Obligation.
    pose (fun c f g => iceq_to_eq M (icAssoc C A B C0) (dCons c (dCons f (dCons g dNil)))).
    specialize (e (dpair _ ⟨c, c⟩ eq_refl)).
    specialize (e (dpair _ ⟨f, f⟩ eq_refl)).
    specialize (e (dpair _ ⟨g, g⟩ eq_refl)).
    simpl in e.
    rewrite !to_term_weaken in e.
    rewrite (dlookup_equation_2 _ _ _ _ _ _) in e.
    exact e.
  Qed.

  Definition homomorphism c1 c2 (f : ⦑c1|M⦒ -> ⦑c2|M⦒) :=
      let α1 := wit (ctype_alg M c1) in
      let α2 := wit (ctype_alg M c2) in
      forall m, f (α1 m) = α2 (f <$> m).

  (* Should be obtained as a consequence of the syntactic linearity condition on bind *)
  Context (HBindHomo : forall A B, homomorphism _ ((_ ~> _) ~~> _)
                        (Spr1 (icterm_to_term M (icBind C A B) dNil))).

  Definition lift_carrier {pf1 pf2 pf3} A (m : M A) :
    OrderedMonadFromEqns pf1 pf2 pf3 A :=
    wit (ctype_alg M (icM C A)) (bind m (fun a => ret (ret' A a))).

  Lemma lift_carrier_monotonic {pf1 pf2 pf3} A
        (lift:=@lift_carrier pf1 pf2 pf3 A) :
    SProper (@omon_rel M A s==> @omon_rel (OrderedMonadFromEqns pf1 pf2 pf3) A)
            (lift_carrier A).
  Proof.
    move=> ? ? ?.
    simpl.
    unfold lift_carrier.
    rewrite /CM -(pf (ctype_alg M (icM C A))).
    apply oalgstr_mon.
    red. move=> R Hret Hmon Hbind.
    apply Hmon.
    apply omon_bind.
    assumption.
    sreflexivity.
  Qed.

  Program Definition OrderedMonadUnderFromEqns {pf1 pf2 pf3 pf4 pf5} :=
    @mkMonadUnder M (OrderedMonadFromEqns pf1 pf2 pf3)
                  (@mkMonMorphism _ _
                                  (@mkMorphism M _ lift_carrier pf4 pf5)
                                  lift_carrier_monotonic).

  Import FunctionalExtensionality.

  Program Definition lift_monad_morph : MonadMorphism M CMonad :=
    @mkMorphism M CMonad lift_carrier _ _.
  Next Obligation.
    unfold lift_carrier.
    unfold bind.
    unfold ret.
    rewrite monad_law1.
    rewrite algstr_ret.
    reflexivity.
  Qed.
  Next Obligation.
    unfold lift_carrier ; rewrite /bind' HBindHomo /=.
    intro_map.
    rewrite !map_functorial.
    match goal with
    | [|- _ = _ ((fun x => ?f ?arg) <$> _)] =>
      replace (fun x => f arg) with (fun x => arg x)
    end.
    (* replace (fun x : A => ⦑ icBind C A B | dNil | M ⦒ (ret' A x)) with *)
    (*     (fun (x:A) (f : A -> carrier B) => f x). *)
    2:{ extensionality a.
        move: (@monad_law1 CMonad) ; rewrite /= /bind' ; move=> -> //.
    }
    rewrite map_bind algstr_bind //.
  Qed.

  Definition lift_monmon : MonotonicMonadMorphism M CMonad :=
    @mkMonMorphism _ _ lift_monad_morph lift_carrier_monotonic.

  Definition CMonadUnder : OrderedMonadUnder M :=
    @mkMonadUnder _ CMonad lift_monmon.

End ToOrderedMonad.

Section ToMonadMorphism.
  Context (C:icmonad) (Hcov : forall A, covariant (icM C A))
          (M1 M2 : OrderedMonad) (θ : MonotonicMonadMorphism M1 M2).

  Definition mmorph_carrier A := to_function _ _ θ (icM C A) (Hcov A).

  Context pf1 pf2 pf3 (CM1 := OrderedMonadFromEqns M1 C pf1 pf2 pf3).
  Context pf1' pf2' pf3' (CM2 := OrderedMonadFromEqns M2 C pf1' pf2' pf3').

  Lemma mmorph_carrier_mon A
    : SProper (@omon_rel CM1 A s==> @omon_rel CM2 A) (mmorph_carrier A).
  Proof.
    move=> /= ? ? ?; apply to_function_monotonic ; intuition ; apply monmon_monotonic.
  Qed.

  Import Substitution.
  Definition val_cov M (c:ctype) := ⦑ c | M ⦒ × covariant c.

  Program Definition CMonadMorph : MonotonicMonadMorphism CM1 CM2 :=
    @mkMonMorphism _ _ (@mkMorphism _ _ mmorph_carrier _ _) mmorph_carrier_mon.
  Next Obligation.
    simple refine (icterm_to_fun_witness _ _ θ
                                         (mon_morph_ret θ)
                                         (mon_morph_bind θ)
                                         (icRet C A @ a) _ dNil).
  Qed.
  Next Obligation.
    unshelve epose (σ := @dCons (val_cov M1) (A ~> icM C B) _ ⟨f, fun _ => Hcov B⟩
                       (@dCons (val_cov M1) (icM C A) _ ⟨m, Hcov A⟩ dNil)).
    pose (Hbind := (↑↑ icBind C A B ) @c ↑vz @c vz).
    move: (icterm_to_fun_witness _ _
                                θ (mon_morph_ret θ)
                                (mon_morph_bind θ)
                                Hbind
                                (Hcov B) σ) => /=.
    rewrite !(to_term_weaken _).
    do 4 (simpl ; simp_dlookup) => //.
  Qed.

End ToMonadMorphism.

Section ToMonadMorphismMonotonic.
  Context (C:icmonad) (Hcov : forall A, covariant (icM C A))
          (M1 M2 : OrderedMonad) (θ θ' : MonotonicMonadMorphism M1 M2)
          (refineθ : monad_morph_refines θ θ')
          (θmon : forall A, SProper (@omon_rel M1 A s==> @omon_rel M2 A) (θ A)).
          (* (θmon : forall A, SProper (@omon_rel M1 A s==> @omon_rel M2 A) (θ A)). *)

  Context pf1 pf2 pf3 pf1' pf2' pf3'
          (ϕ := CMonadMorph C Hcov M1 M2 θ pf1 pf2 pf3 pf1' pf2' pf3')
          (ϕ' := CMonadMorph C Hcov M1 M2 θ' pf1 pf2 pf3 pf1' pf2' pf3').

  Lemma mmorph_refines : monad_morph_refines ϕ ϕ'.
  Proof.
    move=> ? ?. rewrite /ϕ /ϕ'. unfold CMonadMorph.
    unfold mmorph_carrier. simpl.
    apply to_function_monotonic.
    intros. stransitivity (θ A x1').
    apply θmon. assumption.
    apply refineθ. sreflexivity.
  Qed.
End ToMonadMorphismMonotonic.

Section ToMonadMorphismIdentity.
  Context (C:icmonad) (Hcov : forall A, covariant (icM C A)) (M1 : OrderedMonad).

  Context  pf1 pf2 pf3 (ϕ := CMonadMorph C Hcov M1 M1 (identity_monmon M1) pf1 pf2 pf3 pf1 pf2 pf3).

  Lemma mmorph_preserves_id : forall A m, ϕ A m = m.
  Proof.
    intros. unfold CMonadMorph. simpl. unfold mmorph_carrier.
    apply to_function_id.
  Qed.

  Context (M2 M3 : OrderedMonad)
          (f12 : MonotonicMonadMorphism M1 M2) (f23 : MonotonicMonadMorphism M2 M3).

  Context  pf1' pf2' pf3' (ϕ12 := CMonadMorph C Hcov M1 M2 f12 pf1 pf2 pf3 pf1' pf2' pf3').
  Context  pf1'' pf2'' pf3'' (ϕ23 := CMonadMorph C Hcov M2 M3 f23 pf1' pf2' pf3' pf1'' pf2'' pf3'').
  Let ϕ13 := CMonadMorph C Hcov M1 M3 (comp_monmon f12 f23) pf1 pf2 pf3 pf1'' pf2'' pf3''.

  Lemma mmorph_preserves_comp :
    forall A m, ϕ23 A (ϕ12 A m) = ϕ13 A m.
  Proof.
    intros. unfold CMonadMorph. simpl. unfold mmorph_carrier.
    apply to_function_comp.
  Qed.

End ToMonadMorphismIdentity.

Section LiftNatural.
  Context (C:icmonad) (Hcov:forall A, covariant (icM C A))
          (M1 M2:OrderedMonad) (θ : MonotonicMonadMorphism M1 M2).

  Import FunctionalExtensionality.
  Lemma mon_morph_alg (c:ctype) c_cov :
    let θ' := to_function M1 M2 θ c c_cov in
    forall m, θ' (wit (ctype_alg M1 c) m) = wit (ctype_alg M2 c) (θ' <$> θ _ m).
  Proof.
    induction c ; simpl.
    - intros ; rewrite mon_morph_bind. cbv.
      rewrite monad_law3. f_equal. extensionality a.
      rewrite monad_law1. reflexivity.
    - intros m ; destruct c_cov ; f_equal;
      rewrite map_functorial ; simpl;
      rewrite monad_morphism_natural;
      [rewrite <- (map_functorial nfst); rewrite (IHc1 c (nfst <$> _))
      |rewrite <- (map_functorial nsnd); rewrite (IHc2 _ (nsnd <$> _))];
      rewrite monad_morphism_natural;
      reflexivity.
    -  intros m ; extensionality x.
       rewrite (H x).
       f_equal.
       (* rewrite monad_morphism_natural. *)
       rewrite bind_map.
       rewrite mon_morph_bind.
       rewrite map_bind.
       f_equal.
       extensionality f.
       rewrite monad_morphism_natural /map /bind
               /ret monad_law1 mon_morph_ret //.
     - inversion c_cov.
   Qed.

  Context  pf1 pf2 pf3 pf1' pf2' pf3' (ϕ := CMonadMorph C Hcov M1 M2 θ
                                                        pf1 pf2 pf3
                                                        pf1' pf2' pf3').
  Lemma lift_natural :
    forall A m, lift_carrier M2 C A (θ A m) = ϕ A (lift_carrier M1 C A m).
  Proof.
    unfold lift_carrier.
    intro_map.
    intros. rewrite monad_morphism_natural.
    replace (ret' M2 C A) with (fun a => ϕ A (ret' M1 C A a)).
    2:{ extensionality a.
        move: (mon_morph_ret ϕ) => /= Hret ; apply Hret.
    }
    unfold CMonadMorph. simpl. unfold mmorph_carrier.
    rewrite mon_morph_alg. f_equal.
    rewrite monad_morphism_natural.
    rewrite map_functorial.
    reflexivity.
  Qed.
End LiftNatural.

Definition CMonadTransformer C Hbind Hcov : OrderedMonadTransformer :=
  @mkOrderedMonadTransformer
    (fun M => CMonadUnder M C (Hbind M))
    (fun M1 M2 θ => CMonadMorph C Hcov M1 M2 θ _ _ _ _ _ _)
    (fun M => mmorph_preserves_id C Hcov M _ _ _)
    (fun M1 M2 M3 θ12 θ23 => mmorph_preserves_comp C Hcov M1 _ _ _ M2 M3 θ12 θ23 _ _ _ _ _ _)
    (fun M1 M2 θ A m => eq_sym (lift_natural C Hcov M1 M2 θ _ _ _ _ _ _ A m)).

Section ToMonadicRelation.
  Context (C:icmonad) (M0:Monad) (M1:=DiscreteMonad M0) (M2 : OrderedMonad)
          (R : MonadIdeal M1 M2).

  Definition mrel_carrier A := to_srel M1 M2 R (icM C A).

  Context pf1 pf2 pf3 (CM1 := OrderedMonadFromEqns M1 C pf1 pf2 pf3).
  Context pf1' pf2' pf3' (CM2 := OrderedMonadFromEqns M2 C pf1' pf2' pf3').

  Import Substitution.

  Program Definition CMonadRel : MonadRelation CM1 CM2 :=
    @mkMonadRelation CM1 CM2 mrel_carrier _ _.
  Next Obligation.
    simple refine (icterm_to_srel_witness M1 M2 R (icRet C A @ a) dNil).
  Qed.
  Next Obligation.
    unshelve epose (σ := dCons (MkSRelVal M1 M2 R (A ~> icM C B) f g H0)
                         (dCons (MkSRelVal _ _ _ (icM C A) m w H) dNil)).
    pose (Hbind := (↑↑ icBind C A B ) @c ↑vz @c vz).
    move: (icterm_to_srel_witness M1 M2 R Hbind σ) => /=.
    rewrite !(to_term_weaken _).
    do 4 (simpl ; simp_dlookup) => //.
  Qed.

  Program Definition CMonadIdeal : MonadIdeal CM1 CM2 :=
    @mkMonadIdeal _ _ CMonadRel _.
  Next Obligation.
    move: H0 ; apply to_srel_mon.
    cbv ; intros ; subst_sEq ; move : H2. apply mid_upper_closed ; assumption.
    sreflexivity.
    assumption.
  Qed.
End ToMonadicRelation.


(*Congruence is weaker than reflexivity when it comes to higher level than necessary equalities:*)

Goal @eq Set nat nat.
congruence.
Qed.

Goal @eq Type nat nat.
congruence. (*bug*)
Qed.

Variable T : Type.

Goal @eq Type T T.
congruence.
Qed.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Eqdep.

Require Export CatSem.COMP.PCF_rep_hom_quant.
(*Require Import CatSem.CAT.rmonad_gen_comp.*)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Inductive eq_Rep (P R : PCF_rep) : relation (PCF_rep_Hom P R) :=
 | eq_rep : forall (a c : PCF_rep_Hom P R),
            forall H : (forall t, tcomp c t = tcomp a t),
            (forall V, rep_Hom_monad a V ;; lift (M:=R) (Transp H V)
                                    ==
                       Transp H (P V) ;; rep_Hom_monad c V ) ->

             eq_Rep a c.

(** the defined relation is an equivalence and
    may hence serve as equality
*)

Lemma eq_Rep_equiv (P R: PCF_rep) :
   @Equivalence (PCF_rep_Hom P R)
     (@eq_Rep P R).
Proof.
 intros P R.
 split.

 unfold Reflexive.
 intro M.
 assert (H': forall t, tcomp M t = tcomp M t) by
       (intros; reflexivity).

 apply (eq_rep (H:=H')).

 simpl.
 intros V t y.
 destruct y as [t y].

 simpl.
 rewrite (UIP_refl _ _ (H' t)).
 simpl.
 assert (H:= lift_transp_id).
 simpl in *.
 rewrite H.
 auto.

  (* now symmetric *)

 unfold Symmetric.
 intros M N H.
 destruct H.
  assert (H': forall t, tcomp a t = tcomp c t) by auto.
 apply (eq_rep (H:=H')).
 simpl; intros V t y.
 destruct a.
 destruct c.
 simpl in *.
 assert (H3 : tcomp = tcomp0).
 apply (functional_extensionality).
 auto.

 generalize dependent y.
 generalize dependent H'.
 generalize dependent rep_Hom_monad0.
 generalize dependent rep_Hom_monad.
 generalize dependent ttriag.
 generalize dependent ttriag0.
 generalize dependent H.
 generalize dependent tcomp_arrow0.
 generalize dependent tcomp_arrow.
 rewrite  H3.
 intros; simpl in *.
 rewrite transp_id.
 assert (H2:= lift_transp_id).
 simpl in H2.
 rewrite H2.
 assert (H4 := H0 V t y).
 rewrite transp_id in H4.
 rewrite H2 in H4.
 simpl in *; auto.

  (* finally transitive *)

  unfold Transitive.
  intros a b c H H'.
  destruct H;
  destruct H'.
  assert (Ht : forall t, tcomp c t = tcomp a t).
    intro t. transitivity (tcomp a0 t); auto.

  apply (eq_rep (H:=Ht)).
  simpl; intros V t y.
  destruct a;
  destruct a0;
  destruct c.
  simpl in *.
  assert (H5 : tcomp0 = tcomp1) by
    (apply functional_extensionality; intro; auto).

  assert (H6 : tcomp1 = tcomp) by
    (apply functional_extensionality; intro; auto).

  generalize dependent H2.
  generalize dependent H1.
  generalize dependent rep_Hom_monad.
  generalize dependent rep_Hom_monad1.
  generalize dependent rep_Hom_monad0.
  generalize dependent ttriag.
  generalize dependent ttriag1.
  generalize dependent ttriag0.
  generalize dependent H.
  generalize dependent Ht.
  generalize dependent tcomp_arrow0.
  generalize dependent tcomp_arrow.
  generalize dependent tcomp_arrow1.
  rewrite  H5.
  rewrite  H6.

  clear H6 H5.
  clear tcomp0.
  clear tcomp1.

  intros.
  assert (H7:=H0 V t y).
  assert (H9:=H2 V t y).
  rewrite transp_id in *.
  simpl in *.
  assert (H8 := lift_transp_id).
  simpl in H8.
  rewrite H8 in *.
  transitivity (rep_Hom_monad0 V t y);
  auto.
Qed.

Definition eq_Rep_oid (P R : PCF_rep) := Build_Setoid (eq_Rep_equiv P R).

Section id_rep.

Variable P : PCF_rep.

Definition id_rep_car:
(forall c : ITYPE (type_type P),
  (RETYPE (fun t : type_type P => t)) (P c) --->
  P ((RETYPE (fun t : type_type P => t)) c)) :=

 fun V t y =>
   match y with ctype _ z =>
     lift (M:=P) (@id_retype _ V) _ z end.

Obligation Tactic := idtac.

Program Instance blalala :
       colax_Monad_Hom_struct (P:=P) (Q:=P) (F0:=RETYPE (fun t => t))
       id_rep_car.
Next Obligation.
Proof.
  simpl.
  intros V W f t y.
  destruct y.
  simpl.
  assert (H:=lift_kleisli (M:= P)).
  simpl in *.
  rewrite H. simpl.
  assert (H':=kleisli_lift (M:=P)).
  simpl in H'.
  rewrite H'.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V t y.
  destruct y.
  simpl.
  assert (H:=lift_weta P).
  simpl in H.
  rewrite H.
  auto.
Qed.

Definition id_Rep_monad := Build_colax_Monad_Hom blalala.

Program Instance Rep_id_struct :
         PCF_rep_Hom_struct (f := fun t => t)
         (fun t => eq_refl) (fun u v => eq_refl) id_Rep_monad.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(Succ (PCF_rep_struct:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(Zero(PCF_rep_struct:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(CondB(PCF_rep_struct:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(CondN(PCF_rep_struct:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(tttt(PCF_rep_struct:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(ffff(PCF_rep_struct:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros m V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(nats m(PCF_rep_struct:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros t V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(bottom t(PCF_rep_struct:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros t V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(rec t(PCF_rep_struct:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros r s V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(app(PCF_rep_struct:=P) r s ))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros r s V y.
  assert (H := mod_hom_mkl
     (Module_Hom_struct :=(abs(PCF_rep_struct:=P) r s))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  apply f_equal.
  assert (H' := klkl P).
  simpl in H'.
  rewrite H'.
  assert (H'':= kl_eq P).
  simpl in *.
  apply H''.
  clear y.

  intros t y.
  assert (H4 := etakl P).
  simpl in H4.
  rewrite H4.
  simpl.
  destruct y as [t y | ].
  simpl.
  unfold lift.
  rewrite H4.
  simpl.
  auto.
  simpl.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(Pred(PCF_rep_struct:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.

Definition Rep_id := Build_PCF_rep_Hom (Rep_id_struct).

End id_rep.

Existing Instance eq_Rep_oid.
Existing Instance pcf_rep_struct.
Existing Instance rep_gen_Hom_monad_struct.


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.