(** * IEL and the knowability paradox *)
(** ** Church-Fitch *)
Section Church.
  Axiom K: Prop -> Prop.
  Axiom Diamond: Prop -> Prop.
  Axiom Box: Prop -> Prop.

  Axiom Nec: forall (P: Prop), P -> Box P.
  Axiom knowability: forall (P: Prop), P -> Diamond (K P).
  (* K is factive *)
  (* K is factive *)
  Hypothesis K_fact: forall A, K A -> A.
  (* K is distributes over conjucntion *)
  Hypothesis k_distr: forall A B, K(A /\ B) -> K A /\ K B.
  (* Interdef *)
  Hypothesis interdef: forall A,  Box (~A) -> ~Diamond A.
  Lemma interdefTransl (X: Type) (x: X) (P: X -> Prop): (~exists x, P x) <-> (forall x, ~(P x)).
  Proof.   firstorder eauto.
  Qed.

  Lemma CF: ~(exists A, A /\ ~(K A)).
  Proof.
    intro.
    destruct H as (A & HK). specialize (knowability  _ HK). intro.
    assert (~(K (A /\ ~ K A))).
    {
      intro. apply k_distr in H0.  destruct H0.  apply K_fact in H1.  congruence.
    }
    apply Nec in H0.
    apply interdef in H0.
    congruence.
  Qed.
End Church.

(** ** Percivals Criticism of intuitionistic reflection *)

Section Percival.
  (* Introduce K operator using axioms *)
  Definition factive (K: Prop -> Prop) := forall P, K P -> P.
  Axiom irefl: forall (P: Prop), P -> ~~(K P).

  Lemma pc1: forall P, ~(K P) -> ~P.
  Proof.
    intros. intro. assert (~~~K P). tauto. apply H1. apply irefl. auto.
  Qed.

  Lemma pc2: factive K ->forall P, (~(K P) <-> ~P).
  Proof.
    intros F P.
    split; auto using pc1, F.
    - intro. intro. apply F in H0. congruence.
  Qed.

  Lemma pc3:forall P, ~(~(K P) /\ ~(K (~P))).
  Proof.
    intros.
    intros [H1 H2]. apply pc1 in H1. apply pc1 in  H2.   tauto.
  Qed.
End Percival.

(** We can also proof all three in IEL *)


From iris.base_logic Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.heap_lang.lib Require Export nondet_bool.
From iris_examples.proph Require Import eager_coin_spec.

(* Simple implementation of the eager specification. *)

Definition new_eager_coin : val :=
  λ: <>, ref (nondet_bool #()).

Definition read_eager_coin : val :=
  λ: "c", !"c".

Section proof.
  Context `{!heapG Σ}.

  Definition eager_coin (c : val) (b : bool) : iProp Σ :=
    (∃ (l : loc), ⌜c = #l⌝ ∗ l ↦ #b).

  Lemma eager_coin_exclusive (c : val) (b1 b2 : bool) :
    eager_coin c b1 -∗ eager_coin c b2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct "H1" as (l1) "[% Hl1]".
    iDestruct "H2" as (l2) "[% Hl2]".
    simplify_eq.
    by iDestruct (mapsto_valid_2 with "Hl1 Hl2") as %?.
  Qed.

  Lemma new_eager_coin_spec :
    {{{ True }}}
      new_eager_coin #()
    {{{ c b, RET c; eager_coin c b }}}.
  Proof.
    iIntros (Φ) "_ HΦ". wp_lam. wp_apply nondet_bool_spec; first done.
    iIntros (r) "_". wp_alloc l as "Hl". iApply "HΦ". iExists l. by iFrame.
  Qed.

  Lemma read_eager_coin_spec c b :
    {{{ eager_coin c b }}}
      read_eager_coin c
    {{{ RET #b; eager_coin c b }}}.
  Proof.
    iIntros (Φ) "Hc HΦ". iDestruct "Hc" as (l) "[-> Hl]".
    wp_lam. wp_load. iApply "HΦ". iExists l. by iFrame.
  Qed.
End proof.

Definition eager_coin_spec_instance `{!heapG Σ} :
  eager_coin_spec.eager_coin_spec Σ :=
  {| eager_coin_spec.new_coin_spec := new_eager_coin_spec;
     eager_coin_spec.read_coin_spec := read_eager_coin_spec;
     eager_coin_spec.coin_exclusive := eager_coin_exclusive |}.

Typeclasses Opaque eager_coin.


Require Import Contracts.
Require Import Sets.
Require Import Simple_Logic.
Require Import Classical.
Include CoqSet.

Section domain_defined.

Variable d : domain.

Definition formula_to_assert (formula : expr) : assertion d :=
  fun e => sat e formula.
Definition mkContractF (a g : @expr d): contract d :=
  mkContract d (formula_to_assert a) (formula_to_assert g).

Record contractF := ContractF {A : @expr d ; G : @expr d}.

Definition sat_contract (s : state d) (cf : contractF) :=
  sat s (cf.(A)) -> sat s (cf.(G)).

Definition provides_contract (s : state d) (cf : contractF) :=
  sat s (cf.(A)).

Definition f_or (e1 e2 : expr): @expr d := f_not (f_and (f_not e1) (f_not e2)).

Definition saturateF (cf1 : contractF) : contractF :=
  ContractF (cf1.(A)) (f_or (cf1.(G)) (f_not (cf1.(A)))).

(* Ici on a besoin d'environment *)
Definition refinesF (cf1 cf2 : contractF) :=
  let cf1' := saturateF cf1 in
  let cf2' := saturateF cf2 in
  forall (s : state d), (sat s cf2'.(A) -> sat s cf1'.(A)) /\ (sat s cf1'.(G) -> sat s cf2'.(G)).
  (* (forall (s : state d), sat_contract s cf1 -> sat_contract s cf2) *)
  (* /\ (forall (s : state d), provides_contract s cf2 -> provides_contract s cf1). *)

Definition composeF (cf1 cf2 : contractF) : contractF :=
  let cf1' := saturateF cf1 in
  let cf2' := saturateF cf2 in
  let g := f_and (cf1'.(G)) (cf2'.(G)) in
  let a := f_or (f_and (cf1'.(A)) (cf2'.(A))) (f_not g) in
  ContractF a g.

Definition glbF (cf1 cf2 : contractF) : contractF :=
  let cf1' := saturateF cf1 in
  let cf2' := saturateF cf2 in
  let a := f_or cf1'.(A) cf2'.(A) in
  let g := f_and cf1'.(G) cf2'.(G) in
  ContractF a g.

Definition c2c (cf : contractF) : contract d :=
  mkContractF cf.(A) cf.(G).

Lemma f2a_sat : forall (f : expr) (s : state d), formula_to_assert f s <-> sat s f.
Proof.
  firstorder.
Qed.
Lemma f2a_neg : forall (f : expr) (s : state d),
  (formula_to_assert (f_not f)) s <-> ( ¬ (formula_to_assert f)) s.
Proof.
  split ; rewrite f2a_sat ; apply not_sat_not.
Qed.

Lemma f2a_and : forall (f1 f2 : expr) (s : state d),
  (formula_to_assert (f_and f1 f2)) s <-> ((formula_to_assert f1) s /\ (formula_to_assert f2) s).
Proof.
  split ; repeat rewrite f2a_sat ; apply and_sat_and.
Qed.

Notation "c1 == c2" := (equiv _ c1 c2).

Lemma Morgan2 : forall P Q, ~ (P /\ Q) <-> ~ P \/ ~ Q.
Proof.
  firstorder.
  case classic with (P) ; case classic with (Q) ; tauto.
Qed.

Theorem saturateF_correct : forall (cf : contractF) (s : state d),
  satisfies d s (c2c (saturateF cf))  <-> satisfies d s (saturate d (c2c cf)).
Proof.
  split.
  unfold c2c, saturateF, f_or, saturate, satisfies.
  unfold union, inter, compl, In.
  simpl.
  rewrite f2a_neg ; unfold compl, In ; rewrite f2a_and ; simpl.
  firstorder.
  case classic with (formula_to_assert (G cf) s).
  intro.
  right.
  right.
  assumption.
  intro.
  left.
  intro.
  apply H.
  rewrite f2a_neg.
  assumption.
  rewrite f2a_neg.
  unfold compl, In.
  rewrite f2a_neg.
  unfold compl, In.
  tauto.
  unfold c2c, saturateF, f_or, saturate, satisfies.
  unfold union, inter, compl, In.
  simpl.
  rewrite f2a_neg ; unfold compl, In ; rewrite f2a_and ; simpl.
  rewrite Morgan2.
  repeat rewrite f2a_neg ; unfold compl, In.
  firstorder.
Qed.

Lemma sat_contract_c2c : forall (s : state d) (cf : contractF),
  sat_contract s cf <-> s ∈ ¬ formula_to_assert (cf.(A)) ∪ formula_to_assert (cf.(G)).
Proof.
  unfold formula_to_assert, sat_contract, union, compl, In.
  intros s [af gf].
  simpl.
  split.
  intro H.
  case (sat_dec s af) ; tauto.
  tauto.
Qed.

Lemma providesF_c2c : forall (s : state d) (cf : contractF),
 provides_contract s cf <-> s ∈ formula_to_assert (cf.(A)).
Proof.
 firstorder.
Qed.

Theorem refinesF_correct : forall (cf1 cf2 : contractF),
  refines d (c2c cf1) (c2c cf2) <-> refinesF cf1 cf2.
Proof.
  split.
  unfold c2c, refines, refinesF, saturateF.
  simpl.
  intros [Ha Hg] s.
  split.
  intros.
  rewrite <- f2a_sat.
  apply Ha.
  assumption.
  unfold f_or.
  repeat rewrite <- f2a_sat.
  repeat rewrite  f2a_neg.
  unfold union, inter, compl, In.
  repeat rewrite  f2a_and.
  repeat rewrite  f2a_neg.
  unfold union, inter, compl, In.
  repeat rewrite  f2a_neg.
  unfold union, inter, compl, In.
  repeat rewrite Morgan2.
  intro.
  cut (s ∈ ¬ formula_to_assert (A cf2) ∪ formula_to_assert (G cf2)).
  unfold union, inter, compl, In.
  tauto.
  apply Hg.
  unfold union, inter, compl, In.
  tauto.
  unfold c2c, refines, refinesF, saturateF.
  simpl.
  unfold f_or.
  intros H.
  split.
  intros s.
  destruct (H s).
  unfold In.
  repeat rewrite f2a_sat.
  assumption.
  intros s.
  destruct (H s).
  unfold union, inter, compl, In.
  repeat rewrite f2a_sat.
  generalize H1.
  repeat rewrite <- not_sat_not.
  repeat rewrite <- and_sat_and.
  repeat rewrite <- not_sat_not.
  repeat rewrite Morgan2.
  tauto.
Qed.

Theorem composeF_correct : forall (cf1 cf2 : contractF),
  c2c (composeF cf1 cf2) == compose d (c2c cf1) (c2c cf2).
Proof.
  intros [a1 g1] [a2 g2].
  unfold composeF, compose, c2c, f_or.
  simpl.
  apply refines_antisym.
    - unfold refines.
      simpl.
      split.
        + intro s.
          unfold f_or.
          unfold inter, union, SubsetEq, compl, In.
          repeat (try rewrite f2a_neg ; try rewrite f2a_and ;
          unfold inter, union, SubsetEq, compl, In).
          tauto.
        + intro s.
          unfold f_or.
          unfold inter, union, SubsetEq, compl, In.
          repeat (try rewrite f2a_neg ; try rewrite f2a_and ;
          unfold inter, union, SubsetEq, compl, In).
          tauto.
    - unfold refines.
      simpl.
      split.
        + intro s.
          unfold f_or.
          unfold inter, union, SubsetEq, compl, In.
          repeat (try rewrite f2a_neg ; try rewrite f2a_and ;
          unfold inter, union, SubsetEq, compl, In).
          tauto.
        + intro s.
          unfold f_or.
          unfold inter, union, SubsetEq, compl, In.
          repeat (try rewrite f2a_neg ; try rewrite f2a_and ;
          unfold inter, union, SubsetEq, compl, In).
          tauto.
Qed.

Theorem glbF_correct : forall (cf1 cf2 : contractF),
  c2c (glbF cf1 cf2) == glb _ (c2c cf1) (c2c cf2).
Proof.
  intros [a1 g1] [a2 g2].
  unfold glbF, glb, c2c, f_or.
  simpl.
  apply refines_antisym.
    - unfold refines.
      simpl.
      split.
        + intro s.
          unfold f_or.
          unfold inter, union, SubsetEq, compl, In.
          repeat (try rewrite f2a_neg ; try rewrite f2a_and ;
          unfold inter, union, SubsetEq, compl, In).
          tauto.
        + intro s.
          unfold f_or.
          unfold inter, union, SubsetEq, compl, In.
          repeat (try rewrite f2a_neg ; try rewrite f2a_and ;
          unfold inter, union, SubsetEq, compl, In).
          tauto.
    - unfold refines.
      simpl.
      split.
        + intro s.
          unfold f_or.
          unfold inter, union, SubsetEq, compl, In.
          repeat (try rewrite f2a_neg ; try rewrite f2a_and ;
          unfold inter, union, SubsetEq, compl, In).
          tauto.
        + intro s.
          unfold f_or.
          unfold inter, union, SubsetEq, compl, In.
          repeat (try rewrite f2a_neg ; try rewrite f2a_and ;
          unfold inter, union, SubsetEq, compl, In).
          tauto.
Qed.

End domain_defined.


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

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

Print Assumptions square.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func.
From Categories Require Import Functor.Functor_Extender.
From Categories Require Import NatTrans.Main.
From Categories Require Import Ext_Cons.Prod_Cat.Main.
From Categories.Adjunction Require Import Adjunction Duality Adj_Facts.
From Categories Require Import KanExt.Local KanExt.LocalFacts.Main.

Local Notation NID := NatTrans_id (only parsing).
Local Notation FCAT := Func_Cat (only parsing).

Local Open Scope functor_scope.

(** Local right kan extensions are preserved by right adjoints and local left
    kan extensions are preserved by left adjoints. *)
Section Right_Adjoint_Preserves_Hom_Local_Right_KanExt.
  Context
    {C C' : Category}
    (p : C --> C')
    {D : Category}
    (F : C --> D)
    (hlrke : Hom_Local_Right_KanExt p F)
    {E : Category}
    {L : E --> D}
    {R : D --> E}
    (adj : UCU_Adjunct L R).

  (** Hom_Func_{Func_Cat C E}(- ∘ p, R ∘ F)
        ≃ Hom_Func_{Func_Cat C D}(L ∘ - ∘ p, F) *)
  Local Definition Ext_p_F_Hom_Adjunct_Lifted :=
    ((
        ((Fix_Bi_Func_2_NatIso (Hom_Adjunct_Lifted adj C) F)
           ∘ (Fix_Bi_Func_2_Functor_id_swap_NatIso _ _ F)⁻¹
        )
          ∘_h
          (NatTrans_id_Iso (Left_Functor_Extender p E)^op)
       )⁻¹
    )%isomorphism%natiso.

  Local Definition Conv_1 :=
    (
      NatIso_Functor_assoc
       ((Left_Functor_Extender p E)^op)
       ((Right_Functor_Extender L C)^op)
       (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ F (Hom_Func (Func_Cat C D)))
    ).

  Local Definition Conv_2 :=
    (
      (
        (NatTrans_id_Iso (@Fix_Bi_Func_2
                            _ (Func_Cat _ _) _ F (Hom_Func (Func_Cat C D))))
          ∘_h ((Right_Left_Functor_Extension_Iso p L)⁻¹)^op
      )⁻¹
    )%isomorphism%natiso.

  Local Definition Conv_3 :=
    (
      (
        NatIso_Functor_assoc
          ((Right_Functor_Extender L C')^op)
          ((Left_Functor_Extender p D)^op)
          (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ F (Hom_Func (Func_Cat C D)))
      )⁻¹
    )%isomorphism.

  Local Definition Conv := ((Conv_3 ∘ Conv_2) ∘ Conv_1)%isomorphism.

  Local Definition Ext_L_HLRKE_Iso :=
    (
      (HLRKE_Iso hlrke)
        ∘_h (NatTrans_id_Iso (Right_Functor_Extender L C')^op)
    )%natiso.

  Local Definition Fix2_hlrke_Hom_Adjunct_Lifted :=
    (
      (Fix_Bi_Func_2_NatIso (Hom_Adjunct_Lifted adj C') (hlrke))
        ∘ (Fix_Bi_Func_2_Functor_id_swap_NatIso _ _ (hlrke))⁻¹
    )%isomorphism.

  Local Definition Local_Preservation_Iso_underlying :=
    (
      (
        (Fix2_hlrke_Hom_Adjunct_Lifted ∘ Ext_L_HLRKE_Iso)
          ∘Conv
      )
        ∘ Ext_p_F_Hom_Adjunct_Lifted
    )%isomorphism.

  Local Definition Left_simplifier :=
    (
      (
        (
          (Fix_Bi_Func_2_NatIso
             (Func_Prod_of_ids_NatIso (Hom_Func (Func_Cat C E))) (R ∘ F))
            ∘ (Fix_Bi_2_Func_Prod_Func_NatIso
                 (Functor_id (Func_Cat C E) ^op)
                 (Right_Functor_Extender R C)
                 (Hom_Func (Func_Cat C E))
                 F
              )
        )⁻¹
      )
        ∘_h (NatTrans_id_Iso (Left_Functor_Extender p E)^op)
    )%isomorphism%natiso.

  Local Definition Right_simplifier :=
    (
      (
        Fix_Bi_Func_2_NatIso
          (Func_Prod_of_ids_NatIso (Hom_Func (Func_Cat C' E)))
          (R ∘ hlrke)
      )
        ∘
        (
          Fix_Bi_2_Func_Prod_Func_NatIso
            (Functor_id (Func_Cat C' E) ^op)
            (Right_Functor_Extender R C')
            (Hom_Func (Func_Cat C' E))
            (hlrke)
        )
      )%isomorphism.

  Definition Local_Preservation_Iso :=
    (Right_simplifier ∘ (Local_Preservation_Iso_underlying
                           ∘ Left_simplifier))%isomorphism.

  Definition Right_Adjoint_Preserves_Hom_Local_Right_KanExt :
    Hom_Local_Right_KanExt p (R ∘ F) :=
    {|
      HLRKE := (R ∘ (HLRKE hlrke));
      HLRKE_Iso := Local_Preservation_Iso
    |}.

End Right_Adjoint_Preserves_Hom_Local_Right_KanExt.

Section Right_Adjoint_Preserves_Local_Right_KanExt.
  Context {C C' : Category}
          (p : C --> C')
          {D : Category}
          (F : C --> D)
          (lrke : Local_Right_KanExt p F)
          {E : Category}
          {L : E --> D}
          {R : D --> E}
          (adj : UCU_Adjunct L R).

  Definition Right_Adjoint_Preserves_Local_Right_KanExt :
    Local_Right_KanExt p (R ∘ F) :=
    Hom_Local_Right_KanExt_to_Local_Right_KanExt
      (
        Right_Adjoint_Preserves_Hom_Local_Right_KanExt
          _
          _
          (Local_Right_KanExt_to_Hom_Local_Right_KanExt lrke)
          adj
      ).

End Right_Adjoint_Preserves_Local_Right_KanExt.

Section Left_Adjoint_Preserves_Hom_Local_Left_KanExt.
  Context {C C' : Category}
          (p : C --> C')
          {D : Category}
          (F : C --> D)
          (hllke : Hom_Local_Left_KanExt p F)
          {E : Category}
          {L : D --> E}
          {R : E --> D}
          (adj : UCU_Adjunct L R).

  Definition Left_Adjoint_Preserves_Hom_Local_Left_KanExt :
    Hom_Local_Left_KanExt p (L ∘ F) :=
    Right_Adjoint_Preserves_Hom_Local_Right_KanExt
      _
      _
      hllke
      (Adj_to_UCU_Adj _ _ (Adjunct_Duality (UCU_Adj_to_Adj _ _ adj))).

End Left_Adjoint_Preserves_Hom_Local_Left_KanExt.

Section Left_Adjoint_Preserves_Local_Left_KanExt.
  Context {C C' : Category}
          (p : C --> C')
          {D : Category}
          (F : C --> D)
          (hllke : Local_Left_KanExt p F)
          {E : Category}
          {L : D --> E}
          {R : E --> D}
          (adj : UCU_Adjunct L R).

  Definition Left_Adjoint_Preserves_Local_Left_KanExt :
    Local_Left_KanExt p (L ∘ F) :=
    Right_Adjoint_Preserves_Local_Right_KanExt
      _
      _
      hllke
      (Adj_to_UCU_Adj _ _ (Adjunct_Duality (UCU_Adj_to_Adj _ _ adj))).

End Left_Adjoint_Preserves_Local_Left_KanExt.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


Require Import HoTT.

Definition tarwe
           {A : Type}
           {B : A -> A -> Type}
           (f : forall (a : A), B a a)
           (h : forall (a₁ a₂ : A), B a₁ a₂ -> a₁ = a₂)
           {a₁ a₂ : A}
           (p : a₁ = a₂)
  : p^ @ h a₁ a₁ (f a₁) @ p = h a₂ a₂ (transport (fun a => B a a) p (f a₁)).
Proof.
  induction p ; cbn.
  exact (concat_p1 _ @ concat_1p _).
Defined.

Definition wat
           {A : Type}
           {B : A -> A -> Type}
           (f : forall (a : A), B a a)
           (h : forall (a₁ a₂ : A), B a₁ a₂ -> a₁ = a₂)
           {a₁ a₂ : A}
           (p : a₁ = a₂)
  : apD (fun a => h a a (f a)) p
    =
    (transport_paths_FlFr p (h a₁ a₁ (f a₁)))
      @ (ap (fun z => (z^ @ h a₁ a₁ (f a₁)) @ z) (ap_idmap p))
      @ (tarwe f h p)
      @ (ap (h a₂ a₂) (apD f p)).
Proof.
  induction p ; cbn.
  rewrite !concat_p1.
  rewrite <- inv_pp.
  rewrite (concat_p1 (concat_p1 (1 @ h a₁ a₁ (f a₁)) @ concat_1p (h a₁ a₁ (f a₁)))^).
  hott_simpl.
Defined.

Definition apd_idpath
           {B : Type}
           {b₁ b₂ : B}
           (p : b₁ = b₂)
  : apD (@idpath B) p
    =
    (transport_paths_FlFr p idpath)
      @ (ap (fun z => (z^ @ idpath) @ z) (ap_idmap p))
      @ (ap (fun z => z @ p) (concat_p1 p^))
      @ (concat_Vp p)
  := match p with
     | idpath => idpath
     end.

Definition transport_paths_FlFr_fun
      {A B : Type}
      {f g : A -> B}
      {a₁ a₂ : A}
      (p : a₁ = a₂)
  : transport (fun a : A => f a = g a) p == fun r => (ap f p)^ @ r @ ap g p
  := transport_paths_FlFr p.

Definition transport_paths_id_id_fun
      {A : Type}
      {a₁ a₂ : A}
      (p : a₁ = a₂)
  : transport (fun a : A => a = a) p == fun r => p^ @ r @ p
  := fun r =>
       transport_paths_FlFr_fun p r @ ap (fun z => (z^ @ r) @ z) (ap_idmap p).

Definition ap_fun_eq
      {A B : Type}
      {f g : A -> B}
      (e : f == g)
      {a₁ a₂ : A}
      (p : a₁ = a₂)
  : ap f p = e a₁ @ ap g p @ (e a₂)^
  := match p with
     | idpath => (ap (fun z => z @ (e a₁)^) (concat_p1 (e a₁)) @ concat_pV (e a₁))^
     end.

Definition ap_transport_apD_idpath
           {A B : Type}
           (f : A -> B)
           {a₁ a₂ : A}
           (p : f a₁ = f a₂)
           {q : forall (a : A), f a = f a}
           (s : forall (a : A), q a = idpath)
  : (ap (transport (fun b : B => b = b) p) (s a₁))
      @ apD (@idpath B) p
    = ((transport_paths_FlFr p (q a₁))
        @ (ap (fun z => (z^ @ _) @ z) (ap_idmap p))
        @ (ap (fun z => (p^ @ z) @ p) (s a₁))
        @ (ap (fun z => z @ p) (concat_p1 p^) @ concat_Vp p)
        @ ((s a₂)^))
        @ s a₂.
Proof.
  rewrite apd_idpath.
  rewrite (ap_fun_eq (transport_paths_id_id_fun p) (s a₁)).
  rewrite inv_pp.
  hott_simpl.
Defined.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import core.Semantics.
Require Import core.Syntax.
Require Import core.Model.
Require Import core.TransformationConfiguration.
Require Import String.
Require Import EqNat.
Require Import List.
Require Import Expressions.
Require Import core.utils.Utils.
Require Import PeanoNat.
Require Import Lia.
Require Import FunctionalExtensionality.

(*************************************************************)
(** * Confluence                                             *)
(*************************************************************)

Definition well_form  {tc: TransformationConfiguration} tr :=
  forall r1 r2 sm sp,
    In r1 tr /\ In r2 tr/\
    matchRuleOnPattern r1 sm sp = true /\
    matchRuleOnPattern r2 sm sp = true ->
      r1 = r2.

(* Multiset semantics: we think that the list of rules represents a multiset/bag*)
(* Definition Transformation_equiv {tc: TransformationConfiguration} (t1 t2: Transformation) :=
  forall (r:Rule),
  count_occ' Rule_eqdec (Transformation_getRules t1) r = count_occ' Rule_eqdec (Transformation_getRules t2) r. *)

(* another way to represent multiset semantics*)
(* Definition Transformation_equiv {tc: TransformationConfiguration} (t1 t2: Transformation) :=
  sub_set (Transformation_getRules t1) (Transformation_getRules t2) /\
  sub_set (Transformation_getRules t1) (Transformation_getRules t2).*)

(* Set semantics: we think that the list of rules represents a set (we don't allow two rules to have the same name)*)
Definition Transformation_equiv {tc: TransformationConfiguration} (t1 t2: Transformation) :=
  (Transformation_getArity t1 = Transformation_getArity t2) /\
  set_eq (Transformation_getRules t1) (Transformation_getRules t2) /\
  well_form (Transformation_getRules t1) /\
  well_form (Transformation_getRules t2).

Lemma trace_eq {tc: TransformationConfiguration} :
  forall  t1 t2 sm,
   Transformation_equiv t1 t2 ->
   (trace t1 sm) = (trace t2 sm).
Proof.
  intros.
  destruct t1.
  destruct t2.
  induction l.
  - unfold Transformation_equiv in H.
    admit.
Admitted.

Definition TargetModel_equiv {tc: TransformationConfiguration} (m1 m2: TargetModel) :=
  forall (e: TargetModelElement) (l: TargetModelLink),
   (In e (allModelElements m1) <-> In e (allModelElements m2)) /\
    (In l (allModelLinks m1) <-> In l (allModelLinks m2)).

Theorem confluence :
forall (tc: TransformationConfiguration) (t1 t2: Transformation) (sm: SourceModel),
  Transformation_equiv t1 t2 -> TargetModel_equiv (execute t1 sm) (execute t2 sm).
Proof.
  unfold TargetModel_equiv.
  unfold Transformation_equiv.
  simpl.
  intros.
  destruct H.
  split.
  - split.
    + unfold instantiatePattern.
      unfold matchPattern.
      intros.
      apply in_flat_map in H1. repeat destruct H1.
      apply in_flat_map in H2. repeat destruct H2.
      apply filter_In in H2. destruct H2.
      apply in_flat_map. exists x. split.
      * unfold allTuples.
        unfold maxArity.
        rewrite <- H.
        assumption.
      * apply in_flat_map.
        exists x0.
        split.
        -- apply filter_In.
           split.
           apply H0. assumption.
           assumption.
        -- assumption.
    +  unfold instantiatePattern.
      unfold matchPattern.
      intros.
      apply in_flat_map in H1. repeat destruct H1.
      apply in_flat_map in H2. repeat destruct H2.
      apply filter_In in H2. destruct H2.
      apply in_flat_map. exists x. split.
      * unfold allTuples.
        unfold maxArity.
        rewrite H.
        assumption.
      * apply in_flat_map.
        exists x0.
        split.
        -- apply filter_In.
           split.
           apply H0. assumption.
           assumption.
        -- assumption.
  - split.
    + unfold applyPattern.
      unfold matchPattern.
      intros.
      apply in_flat_map in H1. repeat destruct H1.
      apply in_flat_map in H2. repeat destruct H2.
      apply filter_In in H2. destruct H2.
      apply in_flat_map. exists x. split.
      * unfold allTuples.
        unfold maxArity.
        rewrite <- H.
        assumption.
      * apply in_flat_map.
        exists x0.
        split.
        -- apply filter_In.
           split.
           apply H0. assumption.
           assumption.
        -- unfold applyRuleOnPattern, applyIterationOnPattern in *.
           apply in_flat_map in H3. repeat destruct H3.
           apply in_flat_map.
           exists x1.
           split.
           ++ assumption.
           ++ apply in_flat_map in H5. repeat destruct H5.
              apply in_flat_map.
              exists x2.
              split.
              ** assumption.
              ** unfold applyElementOnPattern in *.
                 assert (trace t1 sm = trace t2 sm). {
                   unfold trace, tracePattern.
                   admit. (* requires reordering for rules *)
                 }
Admitted.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


(* In practice, not much can be done without decidable equality *)
(* Many functions require an argument p of type Eq v            *)

Definition Eq (v:Type) := forall (x y:v), {x = y} + {x <> y}.