Require Import List.
Export ListNotations.

Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import K_Syntax.
Require Import K_GHC.
Require Import K_logics.
Require Import K_extens_interactions.
Require Import K_wKH_meta_interactions.

Lemma sThm_irrel : forall A B Γ, sKH_prv (Γ, A --> (B --> A)).
Proof.
intros. apply sKH_extens_wKH. apply wThm_irrel.
Qed.

Lemma simp_Id_gen : forall A Γ, sKH_prv (Γ, A --> A).
Proof.
intros. apply sKH_extens_wKH. apply wimp_Id_gen.
Qed.

Lemma sImp_Box_power_le : forall (m n : nat) (A B : MPropF) Γ, (n <= m) ->
  sKH_prv (Γ, (Imp_Box_power n A B) --> (Imp_Box_power m A B)).
Proof.
intros.
pose (sKH_monot (Empty_set _, Imp_Box_power n A B --> Imp_Box_power m A B)).
apply s. apply sKH_extens_wKH. apply Imp_Box_power_le ; auto.
intro. intros. simpl in H0. inversion H0.
Qed.

Lemma sImp_Box_power_MP_deep : forall (n : nat) (A B C : MPropF) Γ,
  sKH_prv (Γ, (Imp_Box_power n A B) --> (Imp_Box_power n A (B --> C)) --> (Imp_Box_power n A C)).
Proof.
intros.
pose (sKH_monot (Empty_set _, (Imp_Box_power n A B) --> (Imp_Box_power n A (B --> C)) --> (Imp_Box_power n A C))).
apply s. apply sKH_extens_wKH. apply Imp_Box_power_MP_deep.
intro. intros. simpl in H. inversion H.
Qed.

Lemma sDistrib_Box_Imp_Box_power : forall (n : nat) (A B : MPropF) Γ,
  sKH_prv (Γ, (Box (Imp_Box_power n A B)) --> (Imp_Box_power n (Box A) (Box B))).
Proof.
intros.
pose (sKH_monot (Empty_set _, Box (Imp_Box_power n A B) --> Imp_Box_power n (Box A) (Box B))).
apply s. apply sKH_extens_wKH. apply Distrib_Box_Imp_Box_power.
intro. intros. simpl in H. inversion H.
Qed.

Theorem sKH_Detachment_Theorem : forall s,
           (sKH_prv s) ->
           (forall A B Γ, (fst s = Γ) ->
                          (snd s = A --> B) ->
                          sKH_prv (Union _ Γ (Singleton _ (A)), B)).
Proof.
intros s D. induction D.
(* Ids *)
* intros A B Γ id1 id2. inversion H. subst. simpl in id2. subst.
  simpl. apply MPs with (ps:=[(Union _ Γ0 (Singleton _ A), Imp A B);(Union _ Γ0 (Singleton _ A), A)]).
  2: apply MPRule_I. intros. inversion H1. subst. apply Ids.
  apply IdRule_I. apply Union_introl. assumption. inversion H2. subst.
  apply Ids. apply IdRule_I. apply Union_intror. apply In_singleton. inversion H3.
(* Axs *)
* intros A B Γ id1 id2. inversion H. subst. simpl in id2. subst. simpl.
  apply MPs with (ps:=[(Union _ Γ0 (Singleton _ A), Imp A B);(Union _ Γ0 (Singleton _ A), A)]).
  2: apply MPRule_I. intros. inversion H1. subst. apply Axs.
  apply AxRule_I. assumption. inversion H2. subst. apply Ids. apply IdRule_I.
  apply Union_intror. apply In_singleton. inversion H3.
(* MPs *)
* intros A B Γ id1 id2. inversion H1. subst. simpl in id2. subst. simpl.
  assert (J01: List.In (Γ0, A0 --> A --> B) [(Γ0, A0 --> A --> B); (Γ0, A0)]). apply in_eq.
  assert (J02: List.In (Γ0, A0) [(Γ0, A0 --> A --> B); (Γ0, A0)]). apply in_cons. apply in_eq.
  assert (J1: Γ0 = Γ0). reflexivity.
  assert (J2: A0 --> A --> B = A0 --> A --> B). reflexivity.
  pose (H0 (Γ0, A0 --> A --> B) J01 A0 (Imp A B) Γ0 J1 J2).
  assert (sKH_prv (Γ0, A --> B)).
  assert (J3: (forall A1 : MPropF, fst (Union _ Γ0 (Singleton _ A0), A --> B) A1 ->
  sKH_prv (Γ0, A1))).
  intro. simpl. intro. inversion H2. subst. apply Ids.
  apply IdRule_I. assumption. subst. inversion H3. subst.
  apply H. apply in_cons. apply in_eq.
  pose (sKH_comp (Union _ Γ0 (Singleton _ A0), A --> B) s Γ0 J3). simpl in s0. assumption.
  apply MPs with (ps:=[(Union _ Γ0 (Singleton _ A), (Imp A B));(Union _ Γ0 (Singleton _ A), A)]).
  2: apply MPRule_I. intros. inversion H3. subst.
  apply MPs with (ps:=[(Union _ Γ0 (Singleton _ A), Imp A0 (Imp A B));(Union _ Γ0 (Singleton _ A), A0)]).
  2: apply MPRule_I. intros. inversion H4. subst.
  assert (J4: Included _ (fst (Γ0, A0 --> A --> B)) (Union _ Γ0 (Singleton _ A))).
  simpl. intro. intro. apply Union_introl. assumption.
  pose (H _ J01).
  pose (sKH_monot (Γ0, A0 --> A --> B) s0 (Union _ Γ0 (Singleton _ A)) J4). assumption.
  inversion H5. subst. pose (H _ J02).
  assert (J4: Included _ (fst (Γ0, A0 --> A --> B)) (Union _ Γ0 (Singleton _ A))).
  simpl. intro. intro. apply Union_introl. assumption.
  pose (sKH_monot (Γ0, A0) s0 (Union _ Γ0 (Singleton _ A)) J4). simpl in s1.
  assumption. inversion H6. inversion H4. subst. apply Ids. apply IdRule_I. apply Union_intror. apply In_singleton.
  inversion H5.
(* sNec *)
* intros A B Γ id1 id2. inversion H1. subst. simpl in id2. subst. inversion id2.
Qed.

Theorem sKH_Deduction_Theorem : forall s,
           (sKH_prv s) ->
           (forall A B Γ, (fst s = Union _ Γ (Singleton _ (A))) ->
                          (snd s = B) ->
                          (exists n, sKH_prv (Γ, (Imp_Box_power n A B)))).
Proof.
intros s D. induction D.
(* Ids *)
- intros A B Γ id1 id2. inversion H. subst. simpl in id1. subst. simpl. exists 0. inversion H0.
  + subst. apply MPs with (ps:=[(Γ, A0 --> A --> A0);(Γ, A0)]). 2: apply MPRule_I. intros. inversion H2. subst.
    apply sThm_irrel. inversion H3. subst.
    apply Ids. apply IdRule_I. assumption. inversion H4.
  + subst. inversion H1. subst. apply simp_Id_gen.
(* Axs *)
- intros A B Γ id1 id2. inversion H. subst. simpl in id1. subst. simpl. exists 0.
  apply MPs with (ps:=[(Γ, A0 --> A --> A0);(Γ, A0)]). 2: apply MPRule_I. intros. inversion H1. subst.
  apply sThm_irrel. inversion H2. subst.
  apply Axs. apply AxRule_I. assumption. inversion H3.
(* MPs *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id1. subst. simpl.
  assert (J01: List.In (Union (MPropF) Γ (Singleton (MPropF) A), A0 --> B0) [(Union (MPropF) Γ (Singleton (MPropF) A), A0 --> B0); (Union (MPropF) Γ (Singleton (MPropF) A), A0)]).
  apply in_eq.
  assert (J02: List.In (Union (MPropF) Γ (Singleton (MPropF) A), A0) [(Union (MPropF) Γ (Singleton (MPropF) A), A0 --> B0); (Union (MPropF) Γ (Singleton (MPropF) A), A0)]).
  apply in_cons. apply in_eq.
  assert (J1: Union _ Γ (Singleton _ A) = Union _ Γ (Singleton _ A)). reflexivity.
  assert (J2: A0 --> B0 = A0 --> B0). reflexivity.
  pose (H0 (Union (MPropF) Γ (Singleton (MPropF) A), A0 --> B0) J01 A (Imp A0 B0) Γ J1 J2).
  destruct e. subst.
  assert (J3: A0 = A0). reflexivity.
  pose (H0 (Union (MPropF) Γ (Singleton (MPropF) A), A0) J02 A A0 Γ J1 J3). destruct e.
  exists (max x x0).
  apply MPs with (ps:=[(Γ, (Imp_Box_power (Init.Nat.max x x0) A (A0 --> B0)) --> (Imp_Box_power (Init.Nat.max x x0) A B0));
  (Γ, (Imp_Box_power (Init.Nat.max x x0) A (A0 --> B0)))]). 2: apply MPRule_I.
  intros. inversion H4. subst.
  apply MPs with (ps:=[(Γ, (Imp_Box_power (Init.Nat.max x x0) A A0) --> (Imp_Box_power (Init.Nat.max x x0) A (A0 --> B0)) --> (Imp_Box_power (Init.Nat.max x x0) A B0));
  (Γ, (Imp_Box_power (Init.Nat.max x x0) A A0))]). 2: apply MPRule_I.
  intros. inversion H5. subst. apply sImp_Box_power_MP_deep. inversion H6.
  subst.
  apply MPs with (ps:=[(Γ, (Imp_Box_power x0 A A0) --> (Imp_Box_power (Init.Nat.max x x0) A A0));
  (Γ, Imp_Box_power x0 A A0)]). 2: apply MPRule_I.
  intros. inversion H7. subst. apply sImp_Box_power_le ; lia.
  inversion H8. subst. auto. inversion H9. inversion H7.
  inversion H5. subst.
  apply MPs with (ps:=[(Γ, (Imp_Box_power x A (A0 --> B0)) --> (Imp_Box_power (Init.Nat.max x x0) A (A0 --> B0)));
  (Γ, Imp_Box_power x A (A0 --> B0))]). 2: apply MPRule_I.
  intros. inversion H6. subst. apply sImp_Box_power_le ; lia.
  inversion H7. subst. auto. inversion H8. inversion H6.
(* sNec *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id1. subst. simpl.
  assert (J01: List.In (Union (MPropF) Γ (Singleton (MPropF) A), A0) [(Union (MPropF) Γ (Singleton (MPropF) A), A0)]).
  apply in_eq.
  assert (J1: Union _ Γ (Singleton _ A) = Union _ Γ (Singleton _ A)). reflexivity.
  assert (J2: A0 = A0). reflexivity.
  pose (H0 (Union (MPropF) Γ (Singleton (MPropF) A), A0) J01 A A0 Γ J1 J2). destruct e.
  exists (S x). simpl.
  apply MPs with (ps:=[(Γ, (Imp_Box_power x (Box A) (Box A0)) --> A --> (Imp_Box_power x (Box A) (Box A0)));
  (Γ, Imp_Box_power x (Box A) (Box A0))]). 2: apply MPRule_I.
  intros. inversion H3. subst. apply Axs. apply AxRule_I. apply MA2_I.
  exists ((Imp_Box_power x (Box A) (Box A0))). exists A. auto. inversion H4 ; subst.
  2: inversion H5.
  apply MPs with (ps:=[(Γ, (Box (Imp_Box_power x A A0)) --> (Imp_Box_power x (Box A) (Box A0)));
  (Γ, Box (Imp_Box_power x A A0))]). 2: apply MPRule_I.
  intros. inversion H5. subst. apply sDistrib_Box_Imp_Box_power.
  inversion H6 ; subst. 2: inversion H7.
  apply sNec with (ps:=[(Γ, Imp_Box_power x A A0)]).
  2: apply sNecRule_I. intros. inversion H7. 2: inversion H8.
  subst. auto.
Qed.

Theorem sKH_Boxed_Detachment_Theorem : forall n A B Γ,
      (sKH_prv (Γ, (Imp_Box_power n A B))) ->
      (sKH_prv (Union _ Γ (Singleton _ (A)), B)).
Proof.
induction n.
- intros. simpl in H.
  apply sKH_Detachment_Theorem with (s:=(Γ, A --> B)) ; auto.
- intros. simpl in H.
  assert (J1: sKH_prv (Union MPropF Γ (Singleton MPropF A), Imp_Box_power n (Box A) B)).
  apply MPs with (ps:=[(Union MPropF Γ (Singleton MPropF A), A --> Imp_Box_power n (Box A) B);
  (Union MPropF Γ (Singleton MPropF A), A)]). 2: apply MPRule_I.
  intros. inversion H0. subst.
  apply sKH_monot with (Γ1:=Union MPropF Γ (Singleton MPropF A)) in H.
  apply H ; auto. simpl ; intro ; intro. apply Union_introl ; auto. inversion H1.
  2: inversion H2. subst. apply Ids. apply IdRule_I. apply Union_intror. apply In_singleton.
  pose (IHn (Box A) B (Union MPropF Γ (Singleton MPropF A)) J1).
  pose (sKH_comp (Union MPropF (Union MPropF Γ (Singleton MPropF A)) (Singleton MPropF (Box A)), B)
  s (Union MPropF Γ (Singleton MPropF A))). apply s0.
  simpl. intros. clear s0. inversion H0. subst. inversion H1.
  subst. apply Ids. apply IdRule_I. apply Union_introl ; auto.
  subst. inversion H2. subst.
  apply Ids. apply IdRule_I. apply Union_intror ; auto.
  subst. inversion H1. subst.
  apply sNec with (ps:=[(Union MPropF Γ (Singleton MPropF A), A)]).
  2: apply sNecRule_I. intros. inversion H2. 2: inversion H3. subst.
  apply Ids. apply IdRule_I. apply Union_intror. apply In_singleton.
Qed.

Theorem sKH_Boxed_Detachment_Deduction_Theorem : forall A B Γ,
      (sKH_prv (Union _ Γ (Singleton _ (A)), B)) <->
      (exists n, sKH_prv (Γ, (Imp_Box_power n A B))).
Proof.
intros. split ; intro.
apply sKH_Deduction_Theorem with (s:=(Union MPropF Γ (Singleton MPropF A), B)) ; auto.
destruct H. apply sKH_Boxed_Detachment_Theorem with (n:=x). auto.
Qed.


Require Import msl.Extensionality.
Require Import msl.sepalg.
Require Import msl.ageable.
Require Import msl.age_sepalg.
Require Import msl.base.
Require Import msl.predicates_hered.
Require Import msl.predicates_sl.
Require Import msl.subtypes.
Require Import msl.subtypes_sl.
Require Import msl.predicates_rec.

(* Given a separation algebra on type [A], we can make a separation logic
   with predicates of type  [pred A].  But the type   [B -> pred A] is also
   a natural separation logic.  These typeclasses automagically extend
   the separation-logic operators to the pointwise-function case.
   At present, this is just the beginnings of an experiment with this idea;
   don't expect it to work well enough to be useful.
   Andrew Appel, August 2012, following an approach suggested by Rob Dockins
*)

Class StarOp A := {  starOp : A -> A -> A }.

Instance baseStarOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{AgeA: Age_alg A}
 : StarOp (pred A) := {| starOp := sepcon |}.

Instance funStarOp (B: Type)(A: Type)(StarA: StarOp A) : StarOp (B -> A) :=
   {| starOp := fun (P Q : B -> A) (b : B) =>  starOp (P b) (Q b) |}.

Notation "P '*' Q" := (starOp P Q) : pred.
(* Opaque baseStarOp *)

Class DerivesOp A := {  derivesOp : A -> A -> Prop }.

Instance baseDerivesOp {A}{agA: ageable A}
 : DerivesOp (pred A) := {| derivesOp := @derives A agA|}.

Instance funDerivesOp (B: Type)(A: Type)(DerivesA: DerivesOp A) : DerivesOp (B -> A)
 := {| derivesOp := fun (P Q : B -> A)  => forall b, derivesOp (P b) (Q b) |}.
Notation "P '|--' Q" := (derivesOp P%pred Q%pred).
(* Opaque baseDerivesOp. *)

Class WandOp A := {  wandOp : A -> A -> A }.

Instance baseWandOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{AgeA: Age_alg A}
 : WandOp (pred A) := {| wandOp := wand |}.

Instance funWandOp (B: Type)(A: Type)(WandA: WandOp A) : WandOp (B -> A) :=
   {| wandOp := fun (P Q : B -> A) (b : B) =>  wandOp (P b) (Q b) |}.

Notation "P '-*' Q" := (wandOp P Q) : pred.
(* Opaque baseWandOp *)

Class EmpOp A := { Emp: A}.

Instance baseEmpOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AgeA: Age_alg A}
  : EmpOp (pred A) := {| Emp := @emp A JA PA SA agA AgeA |}.

Instance funEmpOp  (B: Type)(A: Type)(EmpA: EmpOp A) : EmpOp (B -> A) :=
   {| Emp := fun (b : B) =>  Emp  |}.

Section Test.
Variable environ: Type.
Variables (rmap : Type)
      (Join_rmap: Join rmap) (Perm_rmap: @Perm_alg rmap Join_rmap)
      (Sep_rmap: @Sep_alg rmap Join_rmap)
      (Canc_rmap: @Canc_alg rmap Join_rmap)
      (Disj_rmap: @Disj_alg rmap Join_rmap)
      (ag_rmap: ageable rmap)
      (Age_rmap: @Age_alg rmap Join_rmap ag_rmap).
Existing Instance  Join_rmap.
Existing Instance  Perm_rmap.
Existing Instance  Sep_rmap.
Existing Instance  Canc_rmap.
Existing Instance  Disj_rmap.
Existing Instance  ag_rmap.
Existing Instance  Age_rmap.

Lemma test1: forall (P : environ -> pred rmap) (Q: pred rmap),
   P * Emp |-- P.
Proof.
 intros.
  intro. simpl; rewrite sepcon_emp.
auto.
Qed.

End Test.


(** * Characterizations of monos, epis, and isos in [type_precat] *)

(** ** Contents

  - Injective functions are monic [InjectivesAreMonic_type]
  - Isomorphisms and weak equivalences
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.Epis.

Require Import UniMath.CategoryTheory.categories.Type.Core.

Local Open Scope cat.

(** ** Injective functions are monic [InjectivesAreMonic_type] *)
(*
Lemma InjectivesAreMonic_type {A B : UU} (f: type_precat⟦ A, B ⟧) :
      isInjective f -> isMonic f.
Proof.
  intro isI.
  unfold isMonic.
  intros ? ? ? eq.
  apply funextfun; intro.
  apply (invweq (Injectivity _ isI _ _)).
  apply toforallpaths in eq.
  apply eq.
Qed.

(** ** Isomorphisms and weak equivalences *)

(** The following are mostly copied verbatim from
    [CategoryTheory.categories.TYPE.MonoEpiIso]. *)

Lemma type_iso_is_equiv (A B : ob type_precat) (f : iso A B) : isweq (pr1 f).
Proof.
  apply (isweq_iso _ (inv_from_iso f)).
  - intro x.
    set (T:=iso_inv_after_iso f).
    set (T':=toforallpaths _ _ _ T). apply T'.
  - intro x.
    apply (toforallpaths _ _ _ (iso_after_iso_inv f)).
Defined.

Lemma type_iso_equiv (A B : ob type_precat) : iso A B -> A ≃ B.
Proof.
  intro f; use make_weq; [exact (pr1 f)|apply type_iso_is_equiv].
Defined.

(** Given a weak equivalence, we construct an iso. Again mostly unwrapping and
    packing. *)

Lemma type_equiv_is_iso (A B : ob type_precat) (f : A ≃ B) :
           is_iso (C := type_precat) (pr1 f).
Proof.
  apply (is_iso_qinv (C := type_precat) _ (invmap f)).
  split; simpl.
  - apply funextfun; intro; simpl in *.
    unfold compose, identity; simpl.
    apply homotinvweqweq.
  - apply funextfun; intro; simpl in *.
    unfold compose, identity; simpl.
    apply homotweqinvweq.
Defined.

Lemma type_precat_equiv_iso (A B : ob type_precat) : A ≃ B -> iso A B.
Proof.
  intro f.
  use make_iso.
  - exact (pr1 f).
  - apply type_equiv_is_iso.
Defined.

(** Both maps defined above are weak equivalences. *)

Lemma type_iso_equiv_is_equiv (A B : ob type_precat) : isweq (type_iso_equiv A B).
Proof.
  apply (isweq_iso _ (type_precat_equiv_iso A B)).
  intro; apply eq_iso.
  - reflexivity.
  - intro; apply subtypePath.
    + intro; apply isapropisweq.
    + reflexivity.
Qed.

Definition type_iso_equiv_weq (A B : ob type_precat) : (iso A B) ≃ (A ≃ B).
Proof.
  exists (type_iso_equiv A B).
  apply type_iso_equiv_is_equiv.
Defined.

Lemma type_equiv_iso_is_equiv (A B : ob type_precat) :
  isweq (type_precat_equiv_iso A B).
Proof.
  apply (isweq_iso _ (type_iso_equiv A B)).
  { intro f.
    apply subtypePath.
    { intro; apply isapropisweq. }
    reflexivity. }
  intro; apply eq_iso.
  reflexivity.
Qed.

Definition type_equiv_weq_iso (A B : ob type_precat) :
  (A ≃ B) ≃ iso A B.
Proof.
  exists (type_precat_equiv_iso A B).
  apply type_equiv_iso_is_equiv.
Defined.
*)


Require Import stdpp.list.
Require Import ssreflect.
From Tweetnacl Require Import Libs.Export.
Require Import Recdef.

Local Open Scope Z.
Definition local_update_M (j:nat) (a:Z) (b : list Z) (x:Z) := a * ( from_option id 0 (b !! j)) + x.
Definition update_M_i_j (i j a:Z) (b:list Z) (o:list Z) := alter (local_update_M (Z.to_nat j) a b) (Z.to_nat (i + j)) o.
Definition update_M_i_j' (i j:nat) (a:Z) (b:list Z) (o:list Z) : (list Z) := alter (local_update_M j a b) (i + j)%nat o.

Function inner_M_fix (i j a:Z) (b o : list Z) {measure Z.to_nat j} : list Z :=
  if (j <=? 0) then o else inner_M_fix i (j - 1) a b (update_M_i_j i (j - 1) a b o).
Proof. intros. apply Z2Nat.inj_lt ; move: teq; rewrite Z.leb_gt => teq; omega. Defined.

Fixpoint inner_M_fix' (i j : nat) (a:Z) (b o : list Z) := match j with
  | 0%nat => o
  | S p => inner_M_fix' i p a b (update_M_i_j' i p a b o)
end.

Function inner_M_fix'' (i j a:Z) (b o : list Z) {measure Z.to_nat j} : list Z :=
  if (j <=? 0) then o else update_M_i_j i (j - 1) a b (inner_M_fix'' i (j - 1) a b o).
Proof. intros. apply Z2Nat.inj_lt ; move: teq; rewrite Z.leb_gt => teq; omega. Qed.

Lemma update_M_i_j_eq : forall (i j a:Z) (b o: list Z),
  0 <= i ->
  0 <= j ->
    update_M_i_j i j a b o = update_M_i_j' (Z.to_nat i) (Z.to_nat j) a b o.
Proof.
  intros ; unfold update_M_i_j, update_M_i_j', alter; f_equal ; rewrite Z2Nat.inj_add; omega.
Qed.

Lemma update_M_i_j_comm_j: forall (i j k:nat) (a:Z) (b o: list Z),
  0 <= i ->
  0 <= j ->
  0 <= k ->
  j <> k ->
    update_M_i_j' i j a b (update_M_i_j' i k a b o) = update_M_i_j' i k a b (update_M_i_j' i j a b o).
Proof.
repeat match goal with
  | _ => omega
  | _ => progress intro
  | _ => progress unfold update_M_i_j'
  | _ => apply list_alter_commute ; intro
end.
Qed.

Lemma inner_M_i_j_eq : forall (i j a:Z) (b o: list Z),
  0 <= i ->
  0 <= j ->
    inner_M_fix i j a b o = inner_M_fix' (Z.to_nat i) (Z.to_nat j) a b o.
Proof.
  intros i j a b o Hi Hj ; gen b o.
  apply (natlike_ind (fun j => ∀ b o : list ℤ, inner_M_fix i j a b o = inner_M_fix' (Z.to_nat i) (Z.to_nat j) a b o)) ; try omega.
  intros ; rewrite inner_M_fix_equation ; auto.
  clear Hj j ; intros j Hj iHj b o.
  change (Z.succ j) with (j + 1); replace (Z.to_nat (j + 1)) with (S (Z.to_nat j)).
  2: rewrite Z2Nat.inj_add ; change (Z.to_nat 1) with 1%nat ; omega.
  rewrite inner_M_fix_equation.
  flatten.
  apply Zle_bool_imp_le in Eq ; omega. (* silly case *)
  replace (j + 1 - 1) with j by omega.
  rewrite iHj ; rewrite update_M_i_j_eq ; go.
Qed.

Lemma inner_M_fix''_com: forall (i j k a:Z) (b o: list Z),
  0 <= i ->
  0 <= j ->
  j <= k ->
    update_M_i_j i k a b (inner_M_fix'' i j a b o) = inner_M_fix'' i j a b (update_M_i_j i k a b o).
Proof.
  intros i j k a b o Hi Hj Hk.
  gen k b o.
  apply (natlike_ind (fun j => ∀ k : ℤ, j <= k -> ∀ b o : list ℤ, update_M_i_j i k a b (inner_M_fix'' i j a b o) =
      inner_M_fix'' i j a b (update_M_i_j i k a b o))) ; try omega.
  - intros ; rewrite inner_M_fix''_equation ; symmetry ; rewrite inner_M_fix''_equation ; auto.
  - clear Hj j ; intros j Hj iHj k Hk b o ; sort.
    change (Z.succ j) with (j + 1) in *.
    rewrite inner_M_fix''_equation ; symmetry ; rewrite inner_M_fix''_equation.
    flatten.
    replace (j + 1 - 1) with (j) by omega.
    rewrite <- iHj by omega.
    rewrite ?update_M_i_j_eq ; try omega.
    rewrite update_M_i_j_comm_j ; go.
    intro ; apply Z2Nat.inj_iff in H ; omega.
Qed.

Lemma inner_M_i_j_eq'' : forall (i j a:Z) (b o: list Z),
  0 <= i ->
  0 <= j ->
    inner_M_fix i j a b o = inner_M_fix'' i j a b o.
Proof.
  intros i j a b o Hi Hj.
  gen b o.
  apply (natlike_ind (fun j => ∀ b o : list ℤ, inner_M_fix i j a b o = inner_M_fix'' i j a b o)) ; try omega.
  - intros ; rewrite inner_M_fix_equation ; rewrite inner_M_fix''_equation ; auto.
  - clear Hj j => j Hj iHj b o ; sort.
    change (Z.succ j) with (j + 1).
    rewrite inner_M_fix_equation ; rewrite inner_M_fix''_equation.
    flatten.
    oreplace (j + 1 - 1) (j).
    rewrite iHj.
    rewrite inner_M_fix''_equation ; symmetry ; rewrite inner_M_fix''_equation.
    flatten.
    apply Z.leb_gt in Eq0.
    rewrite <- inner_M_fix''_com by omega.
    rewrite ?update_M_i_j_eq ; try omega.
    rewrite update_M_i_j_comm_j ; go.
    intro ; apply Z2Nat.inj_iff in H ; omega.
Qed.

Lemma inner_M_fix_0 : forall i a b o, 0 <= i -> inner_M_fix i 0 a b o = o.
Proof. intros ; rewrite inner_M_fix_equation ; flatten ; compute in Eq ; tryfalse. Qed.

Lemma inner_M_fix_step j : 0 <= j -> forall i a b o, 0 <= i -> inner_M_fix i (j + 1) a b o = update_M_i_j i j a b (inner_M_fix i j a b o).
Proof.
  intros.
  rewrite inner_M_i_j_eq'' ; try omega.
  rewrite inner_M_fix''_equation.
  flatten.
  apply Zle_bool_imp_le in Eq ; omega. (* silly case *)
  apply Z.leb_gt in Eq.
  oreplace (j + 1 - 1)  (j).
  rewrite inner_M_i_j_eq''; go.
Qed.

Lemma inner_M_fix_length : forall i j a b o, 0 <= j -> length (inner_M_fix i j a b o) = length o.
Proof.
  intros i j a b o Hj; gen i a b o .
  apply (natlike_ind (fun j => ∀ (i a : ℤ) (b o : list ℤ), length (inner_M_fix i j a b o) = length o)) ; try omega.
  intros ; rewrite inner_M_fix_equation ; go.
  clear j Hj; intros j Hj iHj i a b o.
  change (Z.succ j) with (j + 1).
  rewrite inner_M_fix_equation.
  destruct (j + 1 <=? 0) ; auto.
  replace (j + 1 - 1) with (j) by omega.
  rewrite iHj.
  unfold update_M_i_j.
  rewrite alter_length.
  reflexivity.
Qed.

Lemma inner_M_fix_Zlength : forall i j a b o, 0 <= j -> Zlength (inner_M_fix i j a b o) = Zlength o.
Proof. convert_length_to_Zlength inner_M_fix_length. Qed.

Lemma inner_M_fix_app_take : forall i j a b o, 0 <= j -> 0 <= i -> i <= length o -> inner_M_fix i j a b o = take (Z.to_nat i) o ++ drop (Z.to_nat i) (inner_M_fix i j a b o).
Proof.
intros i j a b o Hj Hi. gen i a b o.
eapply (natlike_ind (fun j => ∀ i : ℤ, 0 ≤ i → ∀ (a : ℤ) (b o : list ℤ),
  i ≤ length o → inner_M_fix i j a b o = take (Z.to_nat i) o ++ drop (Z.to_nat i) (inner_M_fix i j a b o))) ; try omega.
intros; rewrite inner_M_fix_0 ; try omega; rewrite take_drop; reflexivity.
clear j Hj => j Hj iHj i Hi a b o Ho.
change (Z.succ j) with (j + 1).
rewrite inner_M_i_j_eq''; try omega.
rewrite inner_M_fix''_equation.
flatten.
rewrite take_drop; reflexivity.
oreplace (j + 1 - 1) j.
rewrite <- inner_M_i_j_eq'' ; try omega.
rewrite iHj ; try omega.
unfold update_M_i_j.
rewrite alter_app_r_alt.
f_equal.

2: {
rewrite take_length ; rewrite Z2Nat.inj_add ; try omega.
apply (NPeano.Nat.le_trans _ (Z.to_nat i)) ; try omega.
apply Min.le_min_l.
}

rewrite drop_app_ge. 2: (rewrite take_length ; apply Min.le_min_l).
replace ((Z.to_nat i - length (take (Z.to_nat i) o)))%nat with 0%nat.
reflexivity.
rewrite take_length min_l ; go.
rewrite <- Nat2Z.id ; apply Z2Nat.inj_le ; go.
Qed.

Lemma inner_M_fix_app : forall i j a b o o', 0 <= j -> 0 <= i -> i + j <= length o -> inner_M_fix i j a b (o ++ o') = (inner_M_fix i j a b o) ++ o'.
Proof.
intros i j a b o o'; gen i j a b o'; induction o as [ | h o iHo] using rev_ind.
- intros. simpl in *.
replace i with 0 ; replace j with 0 ; subst ; repeat rewrite inner_M_fix_0 ; go.
- intros i j a b o' Hj Hi. gen i a b o'.
  apply (natlike_ind (fun j => ∀ i : ℤ, 0 ≤ i → ∀ (a : ℤ) (b o' : list ℤ),
  i + j <= length (o ++ [h]) → inner_M_fix i j a b ((o ++ [h]) ++ o') = inner_M_fix i j a b (o ++ [h]) ++ o')) ; try omega.
  intros.
  repeat (rewrite inner_M_fix_0 ; try omega) ; reflexivity.
  clear j Hj; intros j Hj iHj i Hi a b o' Hijo.
  change (Z.succ j) with (j + 1).
  repeat (rewrite inner_M_i_j_eq'' ; try omega).
  rewrite inner_M_fix''_equation ; symmetry ; rewrite inner_M_fix''_equation.
  flatten.
  replace (j + 1 - 1) with j by omega.
  repeat (rewrite <- inner_M_i_j_eq'' ; try omega).
  change (Z.succ j) with (j + 1) in *.
  assert(Hijo': i + j <= length o) by (rewrite app_length in Hijo ; simpl in Hijo ; lia).
  clear Hijo.
  unfold update_M_i_j.
  rewrite <- alter_app_l.
  f_equal.
  rewrite -app_assoc -cons_middle iHo ; try omega.
  rewrite iHo ; try omega.
  rewrite app_assoc_reverse cons_middle.
  reflexivity.
  rewrite inner_M_fix_length ; try omega.
  rewrite app_length.
  rewrite <- Nat2Z.id.
  simpl.
  apply Z2Nat.inj_lt ; lia.
Qed.

Lemma inner_M_fix_take : forall i j a b o, 0 <= j -> 0 <= i -> i + j <= length o -> (inner_M_fix i j a b (take (Z.to_nat (i + j))  o)) = take (Z.to_nat (i + j)) (inner_M_fix i j a b o).
Proof.
  intros.
  symmetry.
  rewrite <- (take_drop (Z.to_nat (i + j)) o).
  rewrite inner_M_fix_app ; try omega.
  rewrite (take_drop (Z.to_nat (i + j)) o).
  2: rewrite take_length Nat2Z.inj_min Z.min_l Z2Nat.id ; omega.
  rewrite take_app_ge.
  2: rewrite inner_M_fix_length ; try omega ; rewrite take_length ; apply Min.le_min_l.
  rewrite inner_M_fix_length ; try omega.
  rewrite take_length min_l.
  2: rewrite <- Nat2Z.id; apply Z2Nat.inj_le; omega.
  replace ((Z.to_nat (i + j) - Z.to_nat (i + j))%nat) with 0%nat by omega.
  replace (take 0 (drop (Z.to_nat (i + j)) o)) with (nil:list Z) by reflexivity.
  rewrite app_nil_r ; auto.
Qed.

Lemma inner_M_fix_app_drop : forall i j a b o, 0 <= j -> 0 <= i -> inner_M_fix i j a b o = take (Z.to_nat (i + j)) (inner_M_fix i j a b o) ++ drop (Z.to_nat (i + j)) o.
Proof.
  intros i j a b o Hj Hi.
  rewrite <- (take_drop (Z.to_nat (i + j)) o) at 1.
  assert(i + j <= length o \/ i + j > length o) by omega.
  destruct H.
  - rewrite inner_M_fix_app ; try omega.
    2: rewrite take_length; rewrite min_l.
    2: rewrite Z2Nat.id ; omega.
    2: move : H ; rewrite Z2Nat.inj_le ; try omega ; rewrite (Nat2Z.id (length o)) => H ; omega.
    rewrite inner_M_fix_take ; try omega ; reflexivity.
  -
  repeat match goal with
    | _ => reflexivity
    | _ => rewrite drop_ge
    | _ => rewrite take_ge
    | _ => rewrite app_nil_r
    | _ => rewrite inner_M_fix_length ; try omega
  end ;
  apply Z.gt_lt_iff in H ; move: H ; rewrite Z2Nat.inj_lt ; try omega ; rewrite (Nat2Z.id (length o)) => H ; omega.
Qed.

Lemma inner_M_fix'_app_drop : forall i j a b o, inner_M_fix' i j a b o = take (i + j)%nat (inner_M_fix' i j a b o) ++ drop (i + j)%nat o.
Proof.
  intros.
  assert(exists i', (Z.to_nat i' = i /\ i' = Z.of_nat i)%nat) by (exists (Z.of_nat i) ; split ; [apply Nat2Z.id|reflexivity]).
  destruct H as [i' [Hi' Hi'']].
  assert(exists j', (Z.to_nat j' = j /\ j' = Z.of_nat j)%nat) by (exists (Z.of_nat j) ; split ; [apply Nat2Z.id|reflexivity]).
  destruct H as [j' [Hj' Hj'']].
  repeat match goal with
    | _ => omega
    | _ => rewrite <- Hi'
    | _ => rewrite <- Hj'
    | _ => rewrite <- Z2Nat.inj_add
    | _ => rewrite <- inner_M_i_j_eq
    | _ => apply inner_M_fix_app_drop
   end.
Qed.

Lemma inner_M_fix_bounds : forall m1 m2 m3 n1 n2 n3 i j a b o p q,
  0 <= j ->
  0 <= i ->
  m1 <= a <= n1 ->
  (fun x => m1 <= x <= n1) 0 ->
  (fun x => m2 <= x <= n2) 0 ->
  Forall (fun x => m2 <= x <= n2) b ->
  Forall (fun x => m3 <= x <= n3) o ->
  length b = 16%nat ->
  length o = 31%nat ->
  p = m3 + min_prod m1 n1 m2 n2 ->
  q = n3 + max_prod m1 n1 m2 n2 ->
  Forall (fun x => p <= x <= q) (inner_M_fix i j a b o).
Proof.
  intros m1 m2 m3 n1 n2 n3 i j    a b o p q Hj Hi.
  gen a b o p q.
  apply (natlike_ind (fun j => ∀ (a : ℤ) (b o : list ℤ) (p q : ℤ),
m1 ≤ a ∧ a ≤ n1 → m1 ≤ 0 ∧ 0 ≤ n1 → m2 ≤ 0 ∧ 0 ≤ n2 → Forall (λ x : ℤ, m2 ≤ x ∧ x ≤ n2) b
→ Forall (λ x : ℤ, m3 ≤ x ∧ x ≤ n3) o → length b = 16%nat → length o = 31%nat
            → p = m3 + min_prod m1 n1 m2 n2 → q = n3 + max_prod m1 n1 m2 n2
                → Forall (λ x : ℤ, p ≤ x ∧ x ≤ q) (inner_M_fix i j a b o)
)) ; try omega.
   - intros a b o p q Ha Hm1n1 Hm2n2 Hb Ho Hlb Hlo Hp Hq.
    rewrite inner_M_fix_0 ; try omega.
    assert(Hpmin:= min_prod_neg_le m1 n1 m2 n2 Hm1n1 Hm2n2).
    assert(Hqmax:= max_prod_pos_le m1 n1 m2 n2 Hm1n1 Hm2n2).
    eapply Forall_impl.
    eauto.
    intros x H; simpl in H.
    omega.
  - clear j Hj.
    intros j Hj iHj.
    intros a b o p q Ha Hm1n1 Hm2n2 Hb Ho Hlb Hlo Hp Hq.
    assert(Hpmin:= min_prod_neg_le m1 n1 m2 n2 Hm1n1 Hm2n2).
    assert(Hqmax:= max_prod_pos_le m1 n1 m2 n2 Hm1n1 Hm2n2).
    change (Z.succ j) with (j + 1).
    rewrite inner_M_fix_step ; try omega.
    rewrite inner_M_fix_app_drop ; try omega.
    unfold update_M_i_j.
    rewrite alter_app_r_alt.
    + apply Forall_app_2.
      apply Forall_take ; apply iHj ; go.
      assert((Z.to_nat (i + j) <= 31)%nat \/ (31 < Z.to_nat (i + j))%nat) by omega.
      destruct H.
      * rewrite take_length inner_M_fix_length ; try omega.
        rewrite min_l ; try omega.
        replace ((Z.to_nat (i + j) - Z.to_nat (i + j))%nat) with 0%nat by omega.
        apply le_lt_eq_dec in H.
        destruct H.
        (* get rid of second case: list is empty *)
        2: rewrite e  drop_ge ; go.
        remember (drop (Z.to_nat (i + j)) o) as t.
        destruct t.
        apply (f_equal (λ x, length x)) in Heqt.
        move: Heqt ; rewrite drop_length Hlo //=.
        (* first case where the list is empty is not possible *)
        assert(Hzw: Forall (λ x : ℤ, m3 ≤ x ∧ x ≤ n3) (z::t)).
          rewrite Heqt.
          apply Forall_drop.
          apply Ho.
        simpl.
        apply Forall_cons in Hzw ; destruct Hzw.
        apply Forall_cons_2.
        2: eapply Forall_impl ; eauto ; intros; simpl in *; omega.
        unfold local_update_M.
        assert(m2 <= from_option id 0 (b !! Z.to_nat j) <= n2).
          rewrite <- nth_lookup.
          apply Forall_nth_d ; eauto.
        assert( min_prod m1 n1 m2 n2 <= a * from_option id 0 (b !! Z.to_nat j) <= max_prod m1 n1 m2 n2).
          apply Mult_interval_correct_min_max_le ; omega.
        omega.
      * rewrite drop_ge.
        2: rewrite Hlo ; omega.
        rewrite take_ge.
        2: rewrite inner_M_fix_length ; [rewrite Hlo|] ; omega.
        replace ((alter (local_update_M (Z.to_nat j) a b)
     (Z.to_nat (i + j) - length (inner_M_fix i j a b o))%nat [])) with ([]:list Z) by (apply length_zero_iff_nil ; go).
         go.
    + rewrite take_length.
      apply Min.le_min_l.
Qed.

Close Scope Z.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e416m2e208m1_18limbs.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.


Require Import Terms.

(* unused *)
Definition tCaseNav t xv tv te :=
  let x := fresh (xv :: fv_tm tv ++ fv_tm te) in
  TLet x (tToSum t)
    (TMatch x xv tv te).

Definition tSumToNav t :=
  let x := 0 in
  tMatch t
    x (TVar x)
      (TMkNav x).

(* A different encoding from LThrow into LNaV, which is a bit closer
   to the standard 'error monad' *)

(* If t evaluates to res in LambdaThrow,
   the result of evaluating (encode t) in LambdaNaV is:
   if res = Suc (v@l) then V (Inl ((V v)@l))@bot
   if res = Throw e then (V (Inr (e@bot))@bot
   Invariant1: the sum always stores real values (not NaVs)
   Invariant2: even if the evaluation of (encode t) will always
   produce a sum variables from the original program are always real
   atoms (not NaVs) and are stored unboxed (without the useless
   Inl). *)

(* Instead of using defensive HasTag could also patch-it-all up after
   the fact by turning NaVs into Inrs (similarly to what we do for
   TBOp) -- but in the current shape things look closer to the
   exception monad. *)

Fixpoint encode (t : Tm) : Tm :=
  match t with
  | TVar x => tInl (TVar x)
  | TConst k => tInl (TConst k)
  | TLet x t1 t2 =>
      let y := fresh (x :: fv_tm t2) in
      tSBind (encode t1) x (encode t2)
  | TAbs x t => tInl (TAbs x (encode t))
  | TApp x y =>
      tHasTag TagFun (TVar x) (TApp x y)
  | TInx d x => tInl (TInx d x)
  | TMatch x x1 t1 t2 =>
      tHasTag TagSum (TVar x)
        (TMatch x x1 (encode t1) (encode t2))
  | TTag x => tInl (TTag x)
  | TBOp b x y =>
      let z := 0 in
      (* similar to ToSum, but it leaves things pc-labeled *)
      tCaseNav (TBOp b x y)
        z (TInx DLeft z)
          (TInx DRight z)
  | TBracket x t =>
      tHasTag TagLab (TVar x)
        (tInl (tToSum (TBracket x (tSumToNav (encode t)))))
  | TLabelOf x => tInl (TLabelOf x)
  | TGetPc => tInl TGetPc
  | TThrow x =>
      tHasTag TagExcp (TVar x) (TInx DRight x)
  | TCatch t1 x t2 =>
      tMatch (encode t1)
        x (TInx DLeft x)
          (encode t2)
  | TMkNav _ => tCUnit (* not part of LambdaThrow *)
  | TToSum _ => tCUnit (* not part of LambdaThrow *)
  end.


Require Import Init.

Inductive skeleta (t : Type -> Type) (a : Type) : Type :=
| returns : a -> skeleta t a
| binds : forall x, t x -> (x -> skeleta t a) -> skeleta t a.

Fixpoint fmap t a b (f : a -> b) (x : skeleta t a) : skeleta t b :=
 match x with
 | returns _ _ xr => returns _ _ (f xr)
 | binds _ _ xt xv xf => binds _ _ xt xv (fun x => fmap _ _ _ f (xf x))
 end
.

Definition retn t a (x : a) : skeleta t a := returns _ _ x.

Fixpoint join t a (x : skeleta t (skeleta t a)) : skeleta t a :=
 match x with
 | returns _ _ xr => xr
 | binds _ _ xt xv xf => binds _ _ xt xv (fun x => join _ _ (xf x))
 end
.

Fixpoint run t a (rt : forall x, x -> t x) (bi : forall x y, t x -> (x -> t y) -> t y)
    (x : skeleta t a) : t a :=
 match x with
 | returns _ _ xr => rt _ xr
 | binds _ _ xt xv xf => bi _ _ xv (fun x => run _ _ rt bi (xf x))
 end
.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_low_other_reduce :
  forall T1 L T1', T1 = (t_low L T1') ->
              forall T2, (forall T2', T2 <> (t_low L T2')) ->
                    subtype T1 T2 = false.

Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

  destruct T2; auto.

  destruct (eq_label_dec L l) as [Heq|Heq];
    rewrite Heq in Heqsub_fn;
    [rewrite andb_true_l in Heqsub_fn
    |rewrite andb_false_l in Heqsub_fn; auto].

  apply beq_label_eq in Heq; subst L;
    contradiction (H0 T2); auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable sumA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable rT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable deftriangle_1 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_2 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable lemma_NCdistinct_3 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable lemma_inequalitysymmetric_4 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_extension_5 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable defcollinear_6 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_7 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_8 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_9 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_10 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_11 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_12 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_13 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_betweennotequal_14 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_NChelper_15 : (forall A B C P Q : Universe, ((~(col_ A B C) /\ (col_ A B P /\ (col_ A B Q /\ P <> Q))) -> ~(col_ P Q C))).
Variable axiom_betweennesssymmetry_16 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable proposition_31short_17 : (forall A B C D : Universe, (exists X Y Z : Universe, ((betS_ B D C /\ ~(col_ B C A)) -> (betS_ X A Y /\ (congA_ X A D A D C /\ (par_ X Y B C /\ (betS_ X Z C /\ betS_ A Z D))))))).
Variable lemma_collinearparallel_18 : (forall A B C Xc Xd : Universe, ((par_ A B Xc Xd /\ (col_ Xc Xd C /\ C <> Xd)) -> par_ A B C Xd)).
Variable lemma_NCorder_19 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable lemma_parallelflip_20 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).
Variable postulate_Pasch_outer_21 : (forall A B C P Q : Universe, (exists X : Universe, ((betS_ A P C /\ (betS_ B C Q /\ ~(col_ B Q A))) -> (betS_ A X Q /\ betS_ B P X)))).
Variable lemma_collinear4_22 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable defmeet_23 : (forall A B C D : Universe, (exists X : Universe, (meet_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X)))))).
Variable defmeet2_24 : (forall A B C D X : Universe, ((A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X))) -> meet_ A B C D)).
Variable defparallel_25 : (forall A B C D : Universe, (exists U V Su Sv X : Universe, (par_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V))))))))))))).
Variable defparallel2_26 : (forall A B C D U V Su Sv X : Universe, ((A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V)))))))))) -> par_ A B C D)).
Variable lemma_collinearbetween_27 : (forall A B C D E F H : Universe, ((col_ A E B /\ (col_ C F D /\ (A <> B /\ (C <> D /\ (A <> E /\ (F <> D /\ (~(meet_ A B C D) /\ (betS_ A H D /\ col_ E F H)))))))) -> betS_ E H F)).
Variable postulate_Pasch_inner_28 : (forall A B C P Q : Universe, (exists X : Universe, ((betS_ A P C /\ (betS_ B Q C /\ ~(col_ A C B))) -> (betS_ A X Q /\ betS_ B X P)))).
Variable lemma_3_5b_29 : (forall A B C D : Universe, ((betS_ A B D /\ betS_ B C D) -> betS_ A C D)).
Variable defoppositeside_30 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_31 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable lemma_oppositesidesymmetric_32 : (forall A B P Q : Universe, (tS_ P A B Q -> tS_ Q A B P)).
Variable lemma_equalanglesflip_33 : (forall A B C D E F : Universe, (congA_ A B C D E F -> congA_ C B A F E D)).
Variable proposition_29_34 : (forall A B C D E G H : Universe, ((par_ A B C D /\ (betS_ A G B /\ (betS_ C H D /\ (betS_ E G H /\ tS_ A G H D)))) -> (congA_ A G H G H D /\ (congA_ E G B G H D /\ rT_ B G H G H D)))).
Variable lemma_ABCequalsCBA_35 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_equalanglestransitive_36 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_3_6a_37 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ A C D) -> betS_ B C D)).
Variable defray_38 : (forall A B C : Universe, (exists X : Universe, (out_ A B C -> (betS_ X A C /\ betS_ X A B)))).
Variable defray2_39 : (forall A B C X : Universe, ((betS_ X A C /\ betS_ X A B) -> out_ A B C)).
Variable lemma_ray4_1_40 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_41 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_42 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_equalanglessymmetric_43 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_equalangleshelper_44 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable defanglesum_45 : (forall A B C D E F P Q R : Universe, (exists X : Universe, (sumA_ A B C D E F P Q R -> (congA_ A B C P Q X /\ (congA_ D E F X Q R /\ betS_ P X R))))).
Variable defanglesum2_46 : (forall A B C D E F P Q R X : Universe, ((congA_ A B C P Q X /\ (congA_ D E F X Q R /\ betS_ P X R)) -> sumA_ A B C D E F P Q R)).

Theorem proposition_32_47 : (forall A B C D : Universe, ((triangle_ A B C /\ betS_ B C D) -> sumA_ C A B A B C A C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import List.
Import ListNotations.

(* Borrow from CompCert *)
Require Import Cryptol.Coqlib.
Require Import Cryptol.Bitvectors.

Require Import Cryptol.AST.
Require Import Cryptol.Semantics.
Require Import Cryptol.Utils.
Require Import Cryptol.Builtins.
Require Import Cryptol.BuiltinSem.
Require Import Cryptol.BuiltinSyntax.
Require Import Cryptol.Values.
Require Import Cryptol.Bitstream.
Require Import Cryptol.Lib.
Require Import Cryptol.GlobalExtends.
Require Import Cryptol.GetEachN.

Require Import Cryptol.EvalTac.
Require Import Cryptol.Eager.

Require Import Cryptol.Prims.
Require Import SHA256.SHA256.

Definition w32 := tseq 32 tbit.

Definition Ch_spec (x y z : ext_val) : ext_val :=
  match x,y,z with
  | eseq x, eseq y, eseq z =>
    eseq (xor_ev (and_ev x y) (and_ev (not_ev x) z))
  | _,_,_ => eseq []
  end.

Lemma Ch_eval :
  forall x y z,
    has_type x w32 ->
    has_type y w32 ->
    has_type z w32 ->
    forall GE TE SE,
      wf_env ge GE TE SE ->
      forall ex ey ez res,
        eager_eval_expr GE TE SE ex (to_sval x) ->
        eager_eval_expr GE TE SE ey (to_sval y) ->
        eager_eval_expr GE TE SE ez (to_sval z) ->
        res = (to_sval (Ch_spec x y z)) ->
        eager_eval_expr GE TE SE (EApp (EApp (EApp (EVar Ch) ex) ey) ez) res.
Proof.
  intros. subst res.
  gen_global Ch.
  gen_global (28,"^").
  gen_global (26,"&&").
  gen_global (12,"complement").
  e. e. e. ag.
  e. e. e.
  unfold w32 in *.
  inversion H. inversion H0. inversion H1. subst.
  use xor_eval.
  use and_eval; try lv; try reflexivity.
  eassumption.
  eassumption.
  use and_eval.
  use complement_eval; try lv; try reflexivity.
  eassumption.
  lv. reflexivity.
  eapply has_type_not; eauto.
  eassumption.
  reflexivity.

  eapply has_type_and; eauto.
  eapply has_type_and; try eapply has_type_not; eauto.

Qed.


From mathcomp Require Import all_ssreflect.
Require Import all_core all_rs_base rs_one.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section OPTIONSPACES.
Definition rep_opt X phi x := match x with
	| some x => (phi (inl star)).1 = some star
		/\
		 @delta X (fun q => (phi (inr q)).2) x
	| None => (phi (inl star)).1 = None
end.

Lemma rep_opt_sing X:
	(@rep_opt X) \is_single_valued.
Proof.
move => phi x y phinx phiny.
case: x phinx.
	case: y phiny; last by move => /= Nope a [eq phina]; rewrite eq in Nope.
	move => a/= [eq phina] b [eq' phinb].
	by rewrite (rep_sing X (fun q => (phi (inr q)).2) a b).
case: y phiny => //.
move => /= a [eq phina] Nope.
by rewrite eq in Nope.
Qed.

Lemma rep_opt_rep X:
	(@rep_opt X) \is_representation.
Proof.
split; first exact: rep_opt_sing.
move => x.
case x => [a | ].
	have [phi phinx]:= (rep_sur X a).
	by exists (fun q => (Some star, if q is inr q' then phi q' else some_answer X)).
by exists (fun q => (None, some_answer X)).
Qed.

Canonical rep_space_opt (X: rep_space) := @make_rep_space
	(option X)
	(one + questions X)
	(option one * answers X)
	(@rep_opt X)
	(inl star)
	((None, some_answer X))
	(sum_count one_count (countable_questions X))
	(prod_count (option_count one_count) (countable_answers X))
	(@rep_opt_rep X).

Lemma Some_rec_fun (X: rep_space):
	(@Some X) \is_recursive_function.
Proof.
by exists (fun phi q => if q is inr q' then (Some star, phi q') else (Some star, some_answer X)).
Defined.

Lemma Some_rec (X: rep_space):
	(F2MF (@Some X)) \is_recursive.
Proof.
exact/rec_fun_rec/Some_rec_fun.
Defined.

Lemma None_rec_elt (X: rep_space):
	(@None X) \is_recursive_element.
Proof.
by exists (fun _ => (None, some_answer _)).
Defined.

Notation unsm phi:= (fun q => (phi (inr q)).2).

Definition Some_inv (X: rep_space) ox (x: X) := ox = some x.

Definition Some_inv_frlzr (X: rep_space) := fun (phi: names (rep_space_opt X)) (q: questions X) => unsm phi q.

Lemma Some_inv_frlzr_Some_inv (X: rep_space):
	(@Some_inv_frlzr X) \is_rec_realizer_of (@Some_inv X).
Proof.
rewrite rrlzr_rlzr.
move => phi [x [[ox [phinox eq]] _]].
rewrite eq in phinox. move: phinox => [/= stuff name].
split.
	exists x; split; first by exists (unsm phi).
	by move => psi <-; exists x.
move => t [[psi [<- phint]]].
rewrite (rep_sing _ (unsm phi) t x) => //.
split.
	exists ox; split => //; rewrite /rep_opt eq; first done.
move => s a; exists x.
rewrite (rep_sing _ phi s ox) => //.
by rewrite eq.
Qed.

Lemma Some_inv_rec (X: rep_space):
	(@Some_inv X) \is_recursive.
Proof.
exists (@Some_inv_frlzr X).
exact: Some_inv_frlzr_Some_inv.
Defined.

Lemma option_rs_rec_inv (X: rep_space) (Y: rep_space) (f: option X -> Y):
	f \is_recursive_function
	->
	(fun a => f (some a)) \is_recursive_function * (f None) \is_recursive_element.
Proof.
move => [M Mcmpt].
split.
	exists (fun phi => (M (fun q => match q with
		| inl str => (some star, some_answer X)
		| inr q => (some star, phi q)
		end))).
	by move => phi x phinx; apply Mcmpt.
by exists (M (fun _ => (None, some_answer X))); apply Mcmpt.
Defined.

Lemma option_rs_rec_ind (X: rep_space) (Y: rep_space) (f: option X -> Y):
	(fun a => f (some a)) \is_recursive_function -> (f None) \is_recursive_element
	-> f \is_recursive_function.
Proof.
move => [M Mcmpt] [N Ncmpt].
exists (fun phi => match (phi (inl star)).1 with
	| None => N
	| Some str => M (fun q => (phi (inr q)).2)
end).
abstract by move => phi x phinx; case: x phinx => [/=a [eq phina] |/= Nope];
	[rewrite eq; apply Mcmpt | rewrite Nope; apply Ncmpt].
Defined.

Lemma opt_sum (X: rep_space):
	wisomorphic (rep_space_opt X) (rep_space_sum X rep_space_one).
Proof.
exists (F2MF (fun ox => match ox with
	| some x => inl x
	| None => inr star
end)).
exists (F2MF (fun xs => match xs with
	| inl x => Some x
	| inr str => None
end)).
split.
	apply /rec_fun_cmpt /option_rs_rec_ind; first by apply inl_rec_fun.
	by apply rec_fun_rec_elt; [exists (fun _ => star) | apply inr_rec_fun].
split; last by rewrite !F2MF_comp/F2MF/=; split => s t; case: s => //; elim.
apply/rec_fun_cmpt/rec_fun_comp; [ | apply paib_rec_fun | ] => /=.
	apply/ sum_rec_fun; first exact: Some_rec_fun.
	by apply /cnst_rec_fun; first apply None_rec_elt.
by case.
Qed.
End OPTIONSPACES.
Notation unsm phi:= (fun q => (phi (inr q)).2).


Require Import Framework.
Import ListNotations.

Set Implicit Arguments.

  Inductive token' :=
  | Crash : token'
  | Cont : token'.

  Definition state' := unit.

  Inductive authentication_prog : Type -> Type :=
  | Auth : user -> authentication_prog (option unit).

  Inductive exec' :
    forall T, user -> token' ->  state' -> authentication_prog T -> @Result state' T -> Prop :=
  | ExecAuthSuccess :
      forall s u curr,
        u = curr ->
        exec' curr Cont s (Auth u) (Finished s (Some tt))

  | ExecAuthFail :
      forall s u curr,
        u <> curr ->
        exec' curr Cont s (Auth u) (Finished s None)

  | ExecCrash :
      forall T curr d (p: authentication_prog T),
        exec' curr Crash d p (Crashed d).

  Hint Constructors exec' : core.

  Theorem exec_deterministic_wrt_token' :
    forall u o s T (p: authentication_prog T) ret1 ret2,
      exec' u o s p ret1 ->
      exec' u o s p ret2 ->
      ret1 = ret2.
  Proof.
    intros; destruct p; simpl in *; cleanup;
    repeat
      match goal with
      | [H: exec' _ _ _ _ _ |- _] =>
        inversion H; clear H; cleanup
      end; eauto; congruence.
  Qed.

  Definition AuthenticationOperation :=
    Build_Core
      authentication_prog
      exec'
      exec_deterministic_wrt_token'.

  Definition AuthenticationLang := Build_Layer AuthenticationOperation.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e382m105_7limbs.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.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B Bprime P : Universe, ((wd_ A B /\ (wd_ A Bprime /\ (wd_ B P /\ (wd_ A P /\ (col_ A B Bprime /\ col_ A Bprime P))))) -> col_ A B P)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

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

Print Assumptions sub.


(* generated by Ott 0.31, locally-nameless lngen from: ../spec/rules.ott ../spec/dunfield.ott ../spec/icfp.ott *)
Require Import Metalib.Metatheory.
(** syntax *)
Definition i : Set := nat.

Inductive typ : Set :=  (*r types *)
 | t_int : typ (*r int *)
 | t_top : typ (*r top *)
 | t_arrow (A:typ) (B:typ) (*r function types *)
 | t_and (A:typ) (B:typ) (*r intersection *).

Definition ctx : Set := list ( atom * typ ).

Inductive dirflag : Set :=  (*r checking direction *)
 | Inf : dirflag
 | Chk : dirflag.

Inductive exp : Set :=  (*r expressions *)
 | e_var_b (_:nat) (*r variables *)
 | e_var_f (x:var) (*r variables *)
 | e_top : exp (*r top *)
 | e_lit (i5:i) (*r lit *)
 | e_abs (A:typ) (e:exp) (B:typ) (*r abstractions *)
 | e_fixpoint (A:typ) (e:exp) (*r fixpoint *)
 | e_app (e1:exp) (e2:exp) (*r applications *)
 | e_merge (e1:exp) (e2:exp) (*r merge *)
 | e_anno (e:exp) (A:typ) (*r annotation *).

Inductive dexp : Set :=  (*r expressions *)
 | de_var_b (_:nat) (*r variables *)
 | de_var_f (x:var) (*r variables *)
 | de_top : dexp (*r top *)
 | de_lit (i5:i) (*r lit *)
 | de_abs (ee:dexp) (*r abstractions *)
 | de_app (ee1:dexp) (ee2:dexp) (*r applications *)
 | de_merge (ee1:dexp) (ee2:dexp) (*r merge *)
 | de_ann (ee:dexp) (A:typ) (*r only used in lambdai (icfp2016) *)
 | de_fixpoint (ee:dexp) (*r fixpoint *).

Inductive st : Set :=  (*r input type or projection label *)
 | st_ty (A:typ).

Definition ls : Set := list st.

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_dexp_wrt_dexp_rec (k:nat) (ee_5:dexp) (ee__6:dexp) {struct ee__6}: dexp :=
  match ee__6 with
  | (de_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => de_var_b nat
        | inleft (right _) => ee_5
        | inright _ => de_var_b (nat - 1)
      end
  | (de_var_f x) => de_var_f x
  | de_top => de_top
  | (de_lit i5) => de_lit i5
  | (de_abs ee) => de_abs (open_dexp_wrt_dexp_rec (S k) ee_5 ee)
  | (de_app ee1 ee2) => de_app (open_dexp_wrt_dexp_rec k ee_5 ee1) (open_dexp_wrt_dexp_rec k ee_5 ee2)
  | (de_merge ee1 ee2) => de_merge (open_dexp_wrt_dexp_rec k ee_5 ee1) (open_dexp_wrt_dexp_rec k ee_5 ee2)
  | (de_ann ee A) => de_ann (open_dexp_wrt_dexp_rec k ee_5 ee) A
  | (de_fixpoint ee) => de_fixpoint (open_dexp_wrt_dexp_rec (S k) ee_5 ee)
end.

Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (e_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => e_var_b nat
        | inleft (right _) => e_5
        | inright _ => e_var_b (nat - 1)
      end
  | (e_var_f x) => e_var_f x
  | e_top => e_top
  | (e_lit i5) => e_lit i5
  | (e_abs A e B) => e_abs A (open_exp_wrt_exp_rec (S k) e_5 e) B
  | (e_fixpoint A e) => e_fixpoint A (open_exp_wrt_exp_rec (S k) e_5 e)
  | (e_app e1 e2) => e_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_merge e1 e2) => e_merge (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_anno e A) => e_anno (open_exp_wrt_exp_rec k e_5 e) A
end.

Definition open_dexp_wrt_dexp ee_5 ee__6 := open_dexp_wrt_dexp_rec 0 ee__6 ee_5.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:var),
     (lc_exp (e_var_f x))
 | lc_e_top :
     (lc_exp e_top)
 | lc_e_lit : forall (i5:i),
     (lc_exp (e_lit i5))
 | lc_e_abs : forall (A:typ) (e:exp) (B:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_abs A e B))
 | lc_e_fixpoint : forall (A:typ) (e:exp),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_fixpoint A e))
 | lc_e_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_app e1 e2))
 | lc_e_merge : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_merge e1 e2))
 | lc_e_anno : forall (e:exp) (A:typ),
     (lc_exp e) ->
     (lc_exp (e_anno e A)).

(* defns LC_dexp *)
Inductive lc_dexp : dexp -> Prop :=    (* defn lc_dexp *)
 | lc_de_var_f : forall (x:var),
     (lc_dexp (de_var_f x))
 | lc_de_top :
     (lc_dexp de_top)
 | lc_de_lit : forall (i5:i),
     (lc_dexp (de_lit i5))
 | lc_de_abs : forall (ee:dexp),
      ( forall x , lc_dexp  ( open_dexp_wrt_dexp ee (de_var_f x) )  )  ->
     (lc_dexp (de_abs ee))
 | lc_de_app : forall (ee1 ee2:dexp),
     (lc_dexp ee1) ->
     (lc_dexp ee2) ->
     (lc_dexp (de_app ee1 ee2))
 | lc_de_merge : forall (ee1 ee2:dexp),
     (lc_dexp ee1) ->
     (lc_dexp ee2) ->
     (lc_dexp (de_merge ee1 ee2))
 | lc_de_ann : forall (ee:dexp) (A:typ),
     (lc_dexp ee) ->
     (lc_dexp (de_ann ee A))
 | lc_de_fixpoint : forall (ee:dexp),
      ( forall x , lc_dexp  ( open_dexp_wrt_dexp ee (de_var_f x) )  )  ->
     (lc_dexp (de_fixpoint ee)).
(** free variables *)
Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x) => {{x}}
  | e_top => {}
  | (e_lit i5) => {}
  | (e_abs A e B) => (fv_exp e)
  | (e_fixpoint A e) => (fv_exp e)
  | (e_app e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_merge e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_anno e A) => (fv_exp e)
end.

Fixpoint fv_dexp (ee_5:dexp) : vars :=
  match ee_5 with
  | (de_var_b nat) => {}
  | (de_var_f x) => {{x}}
  | de_top => {}
  | (de_lit i5) => {}
  | (de_abs ee) => (fv_dexp ee)
  | (de_app ee1 ee2) => (fv_dexp ee1) \u (fv_dexp ee2)
  | (de_merge ee1 ee2) => (fv_dexp ee1) \u (fv_dexp ee2)
  | (de_ann ee A) => (fv_dexp ee)
  | (de_fixpoint ee) => (fv_dexp ee)
end.

(** substitutions *)
Fixpoint subst_exp (e_5:exp) (x5:var) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => (if eq_var x x5 then e_5 else (e_var_f x))
  | e_top => e_top
  | (e_lit i5) => e_lit i5
  | (e_abs A e B) => e_abs A (subst_exp e_5 x5 e) B
  | (e_fixpoint A e) => e_fixpoint A (subst_exp e_5 x5 e)
  | (e_app e1 e2) => e_app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_merge e1 e2) => e_merge (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_anno e A) => e_anno (subst_exp e_5 x5 e) A
end.

Fixpoint subst_dexp (ee_5:dexp) (x5:var) (ee__6:dexp) {struct ee__6} : dexp :=
  match ee__6 with
  | (de_var_b nat) => de_var_b nat
  | (de_var_f x) => (if eq_var x x5 then ee_5 else (de_var_f x))
  | de_top => de_top
  | (de_lit i5) => de_lit i5
  | (de_abs ee) => de_abs (subst_dexp ee_5 x5 ee)
  | (de_app ee1 ee2) => de_app (subst_dexp ee_5 x5 ee1) (subst_dexp ee_5 x5 ee2)
  | (de_merge ee1 ee2) => de_merge (subst_dexp ee_5 x5 ee1) (subst_dexp ee_5 x5 ee2)
  | (de_ann ee A) => de_ann (subst_dexp ee_5 x5 ee) A
  | (de_fixpoint ee) => de_fixpoint (subst_dexp ee_5 x5 ee)
end.

(** definitions *)

(* defns Values *)
Inductive value : exp -> Prop :=    (* defn value *)
 | value_unit :
     value e_top
 | value_lit : forall (i5:i),
     value (e_lit i5)
 | value_anno : forall (A:typ) (e:exp) (B:typ),
     lc_exp (e_abs A e B) ->
     value (e_abs A e B)
 | value_merge : forall (v1 v2:exp),
     value v1 ->
     value v2 ->
     value (e_merge v1 v2).

(* defns TopLikeType *)
Inductive topLike : typ -> Prop :=    (* defn topLike *)
 | TL_top :
     topLike t_top
 | TL_and : forall (A B:typ),
     topLike A ->
     topLike B ->
     topLike (t_and A B)
 | TL_arr : forall (A B:typ),
     topLike B ->
     topLike (t_arrow A B).

(* defns OrdinaryType *)
Inductive ord : typ -> Prop :=    (* defn ord *)
 | O_top :
     ord t_top
 | O_int :
     ord t_int
 | O_arrow : forall (A B:typ),
     ord (t_arrow A B).

(* defns Disjoint *)
Inductive disjoint : typ -> typ -> Prop :=    (* defn disjoint *)
 | D_topL : forall (A:typ),
     disjoint t_top A
 | D_topR : forall (A:typ),
     disjoint A t_top
 | D_andL : forall (A1 A2 B:typ),
     disjoint A1 B ->
     disjoint A2 B ->
     disjoint (t_and A1 A2) B
 | D_andR : forall (A B1 B2:typ),
     disjoint A B1 ->
     disjoint A B2 ->
     disjoint A (t_and B1 B2)
 | D_IntArr : forall (A1 A2:typ),
     disjoint t_int (t_arrow A1 A2)
 | D_ArrInt : forall (A1 A2:typ),
     disjoint (t_arrow A1 A2) t_int
 | D_ArrArr : forall (A1 A2 B1 B2:typ),
     disjoint A2 B2 ->
     disjoint (t_arrow A1 A2) (t_arrow B1 B2).

(* defns Subtyping *)
Inductive sub : typ -> typ -> Prop :=    (* defn sub *)
 | S_z :
     sub t_int t_int
 | S_top : forall (A B:typ),
     topLike B ->
     sub A B
 | S_arr : forall (A1 A2 B1 B2:typ),
     sub B1 A1 ->
     sub A2 B2 ->
     sub (t_arrow A1 A2) (t_arrow B1 B2)
 | S_andl1 : forall (A1 A2 A3:typ),
     sub A1 A3 ->
     sub (t_and A1 A2) A3
 | S_andl2 : forall (A1 A2 A3:typ),
     sub A2 A3 ->
     sub (t_and A1 A2) A3
 | S_andr : forall (A1 A2 A3:typ),
     sub A1 A2 ->
     sub A1 A3 ->
     sub A1 (t_and A2 A3).

(* defns SubSubtyping *)
Inductive subsub : typ -> typ -> Prop :=    (* defn subsub *)
 | SubSub_z : forall (A:typ),
     subsub A A
 | SubSub_arr : forall (A1 A2 B1 B2:typ),
     sub B1 A1 ->
     subsub A2 B2 ->
     subsub (t_arrow A1 A2) (t_arrow B1 B2)
 | SubSub_and : forall (A1 A2 B1 B2:typ),
     subsub A1 B1 ->
     subsub A2 B2 ->
     subsub (t_and A1 A2) (t_and B1 B2)
 | SubSub_top : forall (A:typ),
     topLike A ->
     subsub t_top A.

(* defns ConvertToArrowType *)
Inductive arrTyp : typ -> typ -> Prop :=    (* defn arrTyp *)
 | AT_arr : forall (A B:typ),
     arrTyp (t_arrow A B) (t_arrow A B)
 | AT_top :
     arrTyp t_top (t_arrow t_top t_top).

(* defns Semantics *)
Inductive TypedReduce : exp -> typ -> exp -> Prop :=    (* defn TypedReduce *)
 | TReduce_lit : forall (i5:i),
     TypedReduce (e_lit i5) t_int (e_lit i5)
 | TReduce_top : forall (v:exp) (A:typ),
     lc_exp v ->
     ord A ->
     topLike A ->
     TypedReduce v A e_top
 | TReduce_arrow : forall (B1:typ) (e:exp) (B2 A1 A2:typ),
     lc_exp (e_abs B1 e B2) ->
      not ( topLike A2 )  ->
     sub A1 B1 ->
     sub B2 A2 ->
     TypedReduce (e_abs B1 e B2)  (t_arrow A1 A2)  (e_abs B1 e A2)
 | TReduce_mergevl : forall (v1 v2:exp) (A:typ) (v1':exp),
     lc_exp v2 ->
     TypedReduce v1 A v1' ->
     ord A ->
     TypedReduce (e_merge v1 v2) A v1'
 | TReduce_mergevr : forall (v1 v2:exp) (A:typ) (v2':exp),
     lc_exp v1 ->
     TypedReduce v2 A v2' ->
     ord A ->
     TypedReduce (e_merge v1 v2) A v2'
 | TReduce_and : forall (v:exp) (A B:typ) (v1 v2:exp),
     TypedReduce v A v1 ->
     TypedReduce v B v2 ->
     TypedReduce v (t_and A B) (e_merge v1 v2)
with step : exp -> exp -> Prop :=    (* defn step *)
 | Step_top : forall (v:exp),
     value v ->
     step (e_app e_top v) e_top
 | Step_beta : forall (A:typ) (e:exp) (B:typ) (v v':exp),
     lc_exp (e_abs A e B) ->
     value v ->
     TypedReduce v A v' ->
     step (e_app  ( (e_abs A e B) )  v) (e_anno  (  (open_exp_wrt_exp  e v' )  )  B)
 | Step_annov : forall (v:exp) (A:typ) (v':exp),
     value v ->
     TypedReduce v A v' ->
     step (e_anno v A) v'
 | Step_appl : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (e_app e1 e2) (e_app e1' e2)
 | Step_appr : forall (v1 e2 e2':exp),
     value v1 ->
     step e2 e2' ->
     step (e_app v1 e2) (e_app v1 e2')
 | Step_mergel : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (e_merge e1 e2) (e_merge e1' e2)
 | Step_merger : forall (v1 e2 e2':exp),
     value v1 ->
     step e2 e2' ->
     step (e_merge v1 e2) (e_merge v1 e2')
 | Step_anno : forall (e:exp) (A:typ) (e':exp),
     step e e' ->
     step (e_anno e A) (e_anno e' A)
 | Step_fix : forall (A:typ) (e:exp),
     lc_exp (e_fixpoint A e) ->
     step  ( (e_fixpoint A e) )  (e_anno  (  (open_exp_wrt_exp  e  ( (e_fixpoint A e) )  )  )  A).

(* defns BidirectionalTyping *)
Definition disjointSpec A B :=
  forall C, sub A C -> sub B C -> topLike C.

Definition consistencySpec v1 v2 :=
  forall A v1' v2', TypedReduce v1 A v1' -> TypedReduce v2 A v2' -> v1' = v2'.
Inductive Typing : ctx -> exp -> dirflag -> typ -> Prop :=    (* defn Typing *)
 | Typ_top : forall (G:ctx),
      uniq  G  ->
     Typing G e_top Inf t_top
 | Typ_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     Typing G (e_lit i5) Inf t_int
 | Typ_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     Typing G (e_var_f x) Inf A
 | Typ_abs : forall (L:vars) (G:ctx) (A:typ) (e:exp) (B:typ),
      ( forall x , x \notin  L  -> Typing  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk B )  ->
     Typing G (e_abs A e B) Inf (t_arrow A B)
 | Typ_app : forall (G:ctx) (e1 e2:exp) (B C A:typ),
     Typing G e1 Inf C ->
     arrTyp C (t_arrow A B) ->
     Typing G e2 Chk A ->
     Typing G (e_app e1 e2) Inf B
 | Typ_merge : forall (G:ctx) (e1 e2:exp) (A B:typ),
     Typing G e1 Inf A ->
     Typing G e2 Inf B ->
      disjointSpec  A   B  ->
     Typing G (e_merge e1 e2) Inf (t_and A B)
 | Typ_anno : forall (G:ctx) (e:exp) (A:typ),
     Typing G e Chk A ->
     Typing G  ( (e_anno e A) )  Inf A
 | Typ_fix : forall (L:vars) (G:ctx) (A:typ) (e:exp),
      ( forall x , x \notin  L  -> Typing  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk A )  ->
     Typing G (e_fixpoint A e) Inf A
 | Typ_mergev : forall (G:ctx) (v1 v2:exp) (A B:typ),
      uniq  G  ->
     value (e_merge v1 v2) ->
     Typing  nil  v1 Inf A ->
     Typing  nil  v2 Inf B ->
      consistencySpec  v1   v2  ->
     Typing G (e_merge v1 v2) Inf (t_and A B)
 | Typ_sub : forall (G:ctx) (e:exp) (B A:typ),
     Typing G e Inf A ->
     sub A B ->
     Typing G e Chk B.

(* defns DValue *)
Inductive DValue : dexp -> Prop :=    (* defn DValue *)
 | DVal_var : forall (x:var),
     DValue (de_var_f x)
 | DVal_top :
     DValue de_top
 | DVal_nat : forall (i5:i),
     DValue (de_lit i5)
 | DVal_abs : forall (ee:dexp),
     lc_dexp (de_abs ee) ->
     DValue (de_abs ee)
 | DVal_merge : forall (vv1 vv2:dexp),
     DValue vv1 ->
     DValue vv2 ->
     DValue (de_merge vv1 vv2).

(* defns DSemantics *)
Inductive DunfieldStep : dexp -> dexp -> Prop :=    (* defn DunfieldStep *)
 | DStep_appl : forall (ee1 ee2 ee1':dexp),
     lc_dexp ee2 ->
     DunfieldStep ee1 ee1' ->
     DunfieldStep (de_app ee1 ee2) (de_app ee1' ee2)
 | DStep_appr : forall (vv1 ee2 ee2':dexp),
     DunfieldStep ee2 ee2' ->
     DValue vv1 ->
     DunfieldStep (de_app vv1 ee2) (de_app vv1 ee2')
 | DStep_beta : forall (ee vv:dexp),
     lc_dexp (de_abs ee) ->
     DValue vv ->
     DunfieldStep (de_app  ( (de_abs ee) )  vv)  (open_dexp_wrt_dexp  ee vv )
 | DStep_fix : forall (ee:dexp),
     lc_dexp (de_fixpoint ee) ->
     DunfieldStep (de_fixpoint ee)  (open_dexp_wrt_dexp  ee (de_fixpoint ee) )
 | DStep_unmergel : forall (ee1 ee2:dexp),
     lc_dexp ee2 ->
     lc_dexp ee1 ->
     DunfieldStep (de_merge ee1 ee2) ee1
 | DStep_unmerger : forall (ee1 ee2:dexp),
     lc_dexp ee1 ->
     lc_dexp ee2 ->
     DunfieldStep (de_merge ee1 ee2) ee2
 | DStep_mergel : forall (ee1 ee2 ee1':dexp),
     lc_dexp ee2 ->
     DunfieldStep ee1 ee1' ->
     DunfieldStep (de_merge ee1 ee2) (de_merge ee1' ee2)
 | DStep_merger : forall (vv1 ee2 ee2':dexp),
     DunfieldStep ee2 ee2' ->
     DValue vv1 ->
     DunfieldStep (de_merge vv1 ee2) (de_merge vv1 ee2')
 | DStep_split : forall (ee:dexp),
     lc_dexp ee ->
     DunfieldStep ee (de_merge ee ee)
 | DStep_top : forall (vv:dexp),
     DValue vv ->
     DunfieldStep vv de_top
 | DStep_toparr : forall (vv:dexp),
     DValue vv ->
     DunfieldStep (de_app de_top vv) de_top.

(* defns IDisjoint *)
Inductive icfpDisjoint : typ -> typ -> Prop :=    (* defn icfpDisjoint *)
 | ID_andL : forall (A1 A2 B:typ),
     icfpDisjoint A1 B ->
     icfpDisjoint A2 B ->
     icfpDisjoint (t_and A1 A2) B
 | ID_andR : forall (A B1 B2:typ),
     icfpDisjoint A B1 ->
     icfpDisjoint A B2 ->
     icfpDisjoint A (t_and B1 B2)
 | ID_ArrArr : forall (A1 A2 B1 B2:typ),
     icfpDisjoint A2 B2 ->
     icfpDisjoint (t_arrow A1 A2) (t_arrow B1 B2)
 | ID_Ax : forall (A B:typ),
     icfpDisjointAx A B ->
     icfpDisjoint A B
with icfpDisjointAx : typ -> typ -> Prop :=    (* defn icfpDisjointAx *)
 | IDax_IntArr : forall (A B:typ),
      not ( topLike B )  ->
     icfpDisjointAx t_int (t_arrow A B)
 | IDax_symm : forall (B A:typ),
     icfpDisjointAx A B ->
     icfpDisjointAx B A.

(* defns WellformedType *)
Inductive WF : ctx -> typ -> Prop :=    (* defn WF *)
 | Wf_int : forall (G:ctx),
     WF G t_int
 | Wf_top : forall (G:ctx),
     WF G t_top
 | Wf_arr : forall (G:ctx) (A B:typ),
     WF G A ->
     WF G B ->
     WF G (t_arrow A B)
 | Wf_and : forall (G:ctx) (A B:typ),
     WF G A ->
     WF G B ->
      disjointSpec  A   B  ->
     WF G (t_and A B).

(* defns ISubtyping *)
Inductive isub : typ -> typ -> Prop :=    (* defn isub *)
 | IS_z :
     isub t_int t_int
 | IS_top : forall (A:typ),
     isub A t_top
 | IS_arr : forall (A1 A2 B1 B2:typ),
     isub B1 A1 ->
     isub A2 B2 ->
     isub (t_arrow A1 A2) (t_arrow B1 B2)
 | IS_andl1 : forall (A1 A2 A3:typ),
     isub A1 A3 ->
     ord A3 ->
     isub (t_and A1 A2) A3
 | IS_andl2 : forall (A1 A2 A3:typ),
     isub A2 A3 ->
     ord A3 ->
     isub (t_and A1 A2) A3
 | IS_andr : forall (A1 A2 A3:typ),
     isub A1 A2 ->
     isub A1 A3 ->
     isub A1 (t_and A2 A3).

(* defns ITyping *)
Inductive ITyping : ctx -> dexp -> dirflag -> typ -> exp -> Prop :=    (* defn ITyping *)
 | ITyp_top : forall (G:ctx),
      uniq  G  ->
     ITyping G de_top Inf t_top e_top
 | ITyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     ITyping G (de_lit i5) Inf t_int (e_lit i5)
 | ITyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     ITyping G (de_var_f x) Inf A (e_var_f x)
 | ITyp_lam : forall (L:vars) (G:ctx) (ee:dexp) (A B:typ) (e:exp),
     WF G A ->
      ( forall x , x \notin  L  -> ITyping  (cons ( x , A )  G )   ( open_dexp_wrt_dexp ee (de_var_f x) )  Chk B  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     ITyping G  ( (de_abs ee) )  Chk (t_arrow A B)  ( (e_abs A e B) )
 | ITyp_app : forall (G:ctx) (ee1 ee2:dexp) (B:typ) (e1 e2:exp) (A:typ),
     ITyping G ee1 Inf (t_arrow A B) e1 ->
     ITyping G ee2 Chk A e2 ->
     ITyping G (de_app ee1 ee2) Inf B (e_app e1 e2)
 | ITyp_merge : forall (G:ctx) (ee1 ee2:dexp) (A B:typ) (e1 e2:exp),
     ITyping G ee1 Inf A e1 ->
     ITyping G ee2 Inf B e2 ->
     icfpDisjoint A B ->
     ITyping G (de_merge ee1 ee2) Inf (t_and A B) (e_merge e1 e2)
 | ITyp_anno : forall (G:ctx) (ee:dexp) (A:typ) (e:exp),
     ITyping G ee Chk A e ->
     ITyping G (de_ann ee A) Inf A e
 | ITyp_sub : forall (G:ctx) (ee:dexp) (B:typ) (e:exp) (A:typ),
     ITyping G ee Chk A e ->
     isub A B ->
     ITyping G ee Inf B (e_anno e B).

(* defns IBTyping *)
Inductive IBTyping : ctx -> dexp -> dirflag -> typ -> exp -> Prop :=    (* defn IBTyping *)
 | IBTyp_top : forall (G:ctx),
      uniq  G  ->
     IBTyping G de_top Inf t_top e_top
 | IBTyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     IBTyping G (de_lit i5) Inf t_int (e_lit i5)
 | IBTyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     IBTyping G (de_var_f x) Inf A (e_var_f x)
 | IBTyp_lam : forall (L:vars) (G:ctx) (ee:dexp) (A B:typ) (e:exp),
     WF G A ->
      ( forall x , x \notin  L  -> IBTyping  (cons ( x , A )  G )   ( open_dexp_wrt_dexp ee (de_var_f x) )  Chk B  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     IBTyping G (de_abs ee) Chk (t_arrow A B)  ( (e_abs A e B) )
 | IBTyp_app : forall (G:ctx) (ee1 ee2:dexp) (B:typ) (e1 e2:exp) (A:typ),
     IBTyping G ee1 Inf (t_arrow A B) e1 ->
     IBTyping G ee2 Chk A e2 ->
     IBTyping G (de_app ee1 ee2) Inf B (e_app e1 e2)
 | IBTyp_merge : forall (G:ctx) (ee1 ee2:dexp) (A B:typ) (e1 e2:exp),
     IBTyping G ee1 Inf A e1 ->
     IBTyping G ee2 Inf B e2 ->
      disjointSpec  A   B  ->
     IBTyping G (de_merge ee1 ee2) Inf (t_and A B) (e_merge e1 e2)
 | IBTyp_anno : forall (G:ctx) (ee:dexp) (A:typ) (e:exp),
     IBTyping G ee Chk A e ->
     IBTyping G (de_ann ee A) Inf A (e_anno e A)
 | IBTyp_sub : forall (G:ctx) (ee:dexp) (B:typ) (e:exp) (A:typ),
     IBTyping G ee Inf A e ->
     sub A B ->
     IBTyping G ee Chk B e
 | IBTyp_fix : forall (L:vars) (G:ctx) (ee:dexp) (A:typ) (e:exp),
     WF G A ->
      ( forall x , x \notin  L  -> IBTyping  (cons ( x , A )  G )   ( open_dexp_wrt_dexp ee (de_var_f x) )  Chk A  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     IBTyping G (de_fixpoint ee) Chk A (e_fixpoint A e).

(** infrastructure *)
#[export]
Hint Constructors value topLike ord disjoint sub subsub arrTyp TypedReduce step Typing DValue DunfieldStep icfpDisjoint icfpDisjointAx WF isub ITyping IBTyping lc_exp lc_dexp : core.


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

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

Print Assumptions sub.


Inductive Tree (X: Type) :=
| Leaf: X -> Tree X
| Node: Tree X -> Tree X -> Tree X.

Arguments Leaf [X] _.
Arguments Node [X] _ _.


(* This file defines canonical root normal forms and formalises the
   parts of subsection 5.3 not formalised in weak.v. *)

Require Export weak.
Require Import cases.

Inductive step_wh_n : nat -> term -> term -> Prop :=
| step_wh_0 : forall t s, t == s -> step_wh_n 0 t s
| step_wh_more : forall n t s s', step_wh t s -> step_wh_n n s s' -> step_wh_n (S n) t s'.

Lemma lem_step_wh_n_morphism : forall n, morphism (step_wh_n n).
Proof.
  unfold morphism.
  induction 1.
  - pose_term_eq; ycrush.
  - intros; econstructor.
    + rewrite H1 in H; apply H.
    + pose_term_eq; ycrush.
Qed.

Add Parametric Morphism (n : nat) : (step_wh_n n) with
    signature term_eq ==> term_eq ==> iff as step_wh_n_mor.
Proof.
  split; intro; eapply lem_step_wh_n_morphism; pose_term_eq; eauto.
Qed.

Lemma lem_step_wh_n_to_red_wh : forall n t s, step_wh_n n t s -> red_wh t s.
Proof.
  induction 1; ycrush.
Qed.

Lemma lem_red_wh_to_step_wh_n : forall t s, red_wh t s -> exists n, step_wh_n n t s.
Proof.
  induction 1; ycrush.
Qed.

(* Lemma 5.23 *)
Lemma lem_step_wh_n_unique : forall n t s s', step_wh_n n t s -> step_wh_n n t s' -> s == s'.
Proof.
  induction n.
  - pose_term_eq; iauto 2.
  - intros t s s' H1 H2.
    inversion_clear H1.
    inversion_clear H2.
    pose lem_step_wh_unique; ycrush.
Qed.

Lemma lem_step_wh_n_decompose :
  forall m n t s s', step_wh_n n t s -> step_wh_n m t s' -> m >= n -> red_wh s s'.
Proof.
  induction m.
  - scrush.
  - intros.
    inversion_clear H0.
    assert (HH: (m = n - 1 /\ n > 0) \/ m >= n) by omega.
    destruct HH.
    + assert (m >= n - 1) by omega.
      assert (step_wh_n (n - 1) s0 s).
      inversion H; subst; sauto.
      assert (HH1: s1 == s0) by
	  Reconstr.reasy (@weak.lem_step_wh_unique) Reconstr.Empty.
      rewrite HH1 in *; scrush.
      ycrush.
    + destruct n.
      * assert (HH: t == s) by scrush.
        rewrite HH in *; clear HH.
        assert (red_wh s0 s') by
	    Reconstr.reasy (@lem_step_wh_n_to_red_wh) Reconstr.Empty.
        ycrush.
      * assert (m >= n) by omega.
        inversion_clear H.
        assert (HH: s1 == s0) by
	    Reconstr.reasy (@weak.lem_step_wh_unique) Reconstr.Empty.
        rewrite HH in *; clear HH.
        assert (red_wh s0 s') by
	    Reconstr.reasy (@lem_step_wh_n_to_red_wh) Reconstr.Empty.
        ycrush.
Qed.

(* Definition 5.24 *)
Definition is_crnf t r := is_rnf r /\
                          exists n, step_wh_n n t r /\
                                    forall s m, step_wh_n m t s -> is_rnf s -> m >= n.
Hint Unfold is_crnf.

(* Formalisation of the remark after Definition 5.24: if t has a rnf
   then it has a crnf, which is unique by Lemma 5.23. This depends on
   the standardisation theorem 5.20 through lemma 5.22. *)
Lemma lem_crnf_exists : forall t, has_rnf t -> exists r, is_crnf t r.
Proof.
  intros t H.
  unfold has_rnf in H.
  destruct H as [t' [H1 H2]].
  generalize (lem_rnf_red_wh t t' H2 H1); intro HH; destruct HH as [s [HH1 [HH2 HH3]]].
  clear H2; revert HH1.
  rename HH2 into H.
  induction H; intros.
  - exists x; unfold is_crnf; split.
    + ycrush.
    + exists 0; split.
      * pose_term_eq; ycrush.
      * intros; omega.
  - generalize (is_rnf_xm x); intro Hd; destruct Hd as [ Hd | Hd ].
    + exists x; unfold is_crnf; split; [ auto | exists 0 ].
      split; [ pose_term_eq; ycrush | intros; omega ].
    + unfold is_crnf in *.
      generalize (IHstar HH3 HH1); intro HH; destruct HH as [r [Hr1 Hr2]].
      exists r; split; eauto; intros.
      destruct Hr2 as [n0 [Hr21 Hr22]].
      exists (S n0).
      split; [ econstructor; eauto | idtac ].
      intros.
      destruct H2.
      * rewrite H2 in *; ycrush.
      * assert (HH: s == y) by
	    Reconstr.reasy (@weak.lem_step_wh_unique) Reconstr.Empty.
        rewrite HH in *; clear HH.
        assert (n >= n0).
        apply Hr22 with (s := s'); eauto.
        omega.
Qed.

Definition crnf0 t (p : has_rnf t) : { r | is_crnf t r }.
  apply constructive_indefinite_description.
  apply lem_crnf_exists.
  assumption.
Defined.

Definition crnf t (p : has_rnf t) := proj1_sig (crnf0 t p).

Lemma lem_crnf_is_crnf : forall t (p : has_rnf t), is_crnf t (crnf t p).
Proof.
  intros; unfold crnf.
  destruct (crnf0 t p); sauto.
Qed.

Lemma lem_is_crnf_unique : forall t r r', is_crnf t r -> is_crnf t r' -> r == r'.
Proof.
  unfold is_crnf; sauto.
  assert (n >= n0) by scrush.
  assert (n0 >= n) by scrush.
  assert (n0 = n) by omega.
  pose lem_step_wh_n_unique; ycrush.
Qed.

Lemma lem_crnf_unique : forall t p p', crnf t p == crnf t p'.
Proof.
  pose lem_crnf_is_crnf; pose lem_is_crnf_unique; ycrush.
Qed.

(* Lemma 5.25, depends on Theorem 5.20 through Lemma 5.22 *)
Lemma lem_crnf_property :
  forall t r, is_crnf t r -> forall s, inf_beta t s -> is_rnf s -> red_wh t r /\ inf_wh r s.
Proof.
  intros.
  assert (exists s', is_rnf s' /\ red_wh t s' /\ inf_wh s' s) by
      Reconstr.reasy (@weak.lem_rnf_red_wh) Reconstr.Empty.
  unfold is_crnf in *; simp_hyps.
  assert (exists m, step_wh_n m t s') by
      Reconstr.reasy (@lem_red_wh_to_step_wh_n) Reconstr.Empty.
  simp_hyps.
  assert (m >= n) by scrush.
  assert (red_wh r s') by
      Reconstr.reasy (@lem_step_wh_n_decompose) Reconstr.Empty.
  Reconstr.reasy (@weak.lem_red_wh_refl, @weak.lem_beta_redex_to_step_wh, @lem_step_wh_n_to_red_wh, @weak.lem_aux_wh_to_inf_wh, @weak.lem_step_beta_to_inf_wh, @weak.lem_step_wh_to_inf_wh, @weak.lem_red_wh_to_inf_wh, @weak.lem_inf_beta_to_inf_wh, @weak.lem_red_beta_to_inf_wh, @weak.lem_inf_wh_prepend, @weak.lem_step_wh_to_red_wh) Reconstr.Empty.
Qed.

Lemma lem_red_wh_to_crnf : forall t (p : has_rnf t), red_wh t (crnf t p).
Proof.
  pose lem_crnf_is_crnf; pose lem_step_wh_n_to_red_wh; ycrush.
Qed.

Lemma lem_red_beta_to_crnf : forall t (p : has_rnf t), red_beta t (crnf t p).
Proof.
  Reconstr.reasy (lem_red_wh_to_crnf, lem_red_wh_to_red_beta) Reconstr.Empty.
Qed.

Lemma lem_crnf_not_bot : forall t p, crnf t p <> bot.
Proof.
  intros.
  generalize (lem_crnf_is_crnf t p).
  intro H.
  destruct H.
  destruct (crnf t p); sauto.
Qed.

Lemma lem_is_crnf_morphism : forall t t' r, t == t' -> is_crnf t r -> is_crnf t' r.
Proof.
  unfold is_crnf.
  sauto.
  exists n.
  sauto.
  - rewrite <- H; auto.
  - rewrite <- H in *; eauto.
Qed.

Lemma lem_crnf_morphism : forall t t' p p', t == t' -> crnf t p == crnf t' p'.
Proof.
  intros.
  assert (is_crnf t (crnf t p)) by (pose lem_crnf_is_crnf; ycrush).
  assert (is_crnf t' (crnf t' p')) by (pose lem_crnf_is_crnf; ycrush).
  assert (is_crnf t' (crnf t p)) by (pose lem_is_crnf_morphism; ycrush).
  pose lem_is_crnf_unique; ycrush.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import List.
Require Import Setoid.
Require Import BinPos.
Require Import BinList.
Require Import Znumtheory.
Require Import Zdiv_def.
Require Export Morphisms Setoid Bool.
Require Import ZArith.
Open Scope Z_scope.
Require Import Algebra_syntax.
Require Import Ring_polynom.
Require Export Cring.
Require Import Cring_initial.

Set Implicit Arguments.

Class is_closed_list T (l:list T) := {}.
Instance Iclosed_nil T
 : is_closed_list (T:=T) nil.
Instance Iclosed_cons T t l
 `{is_closed_list (T:=T) l}
 : is_closed_list (T:=T) (t::l).

Class is_in_list_at (R:Type) (t:R) (l:list R) (i:nat) := {}.
Instance  Ifind0 (R:Type) (t:R) l
 : is_in_list_at t (t::l) 0.
Instance  IfindS (R:Type) (t2 t1:R) l i
 `{is_in_list_at R t1 l i}
 : is_in_list_at t1 (t2::l) (S i) | 1.

Class reifyPE (R:Type) (e:PExpr Z) (lvar:list R) (t:R) := {}.
Instance  reify_zero (R:Type) (RR:Cring R) lvar
 : reifyPE (PEc 0%Z) lvar cring0.
Instance  reify_one (R:Type) (RR:Cring R) lvar
 : reifyPE (PEc 1%Z) lvar cring1.
Instance  reify_plus (R:Type)  (RR:Cring R)
  e1 lvar t1 e2 t2
 `{reifyPE R e1 lvar t1}
 `{reifyPE R e2 lvar t2}
 : reifyPE (PEadd e1 e2) lvar (cring_plus t1 t2).
Instance  reify_mult (R:Type)  (RR:Cring R)
  e1 lvar t1 e2 t2
 `{reifyPE R e1 lvar t1}
 `{reifyPE R e2 lvar t2}
 : reifyPE (PEmul e1 e2) lvar (cring_mult t1 t2).
Instance  reify_sub (R:Type) (RR:Cring R)
 e1 lvar t1 e2 t2
 `{reifyPE R e1 lvar t1}
 `{reifyPE R e2 lvar t2}
 : reifyPE (PEsub e1 e2) lvar (cring_sub t1 t2).
Instance  reify_opp (R:Type) (RR:Cring R)
 e1 lvar t1
 `{reifyPE R e1 lvar t1}
 : reifyPE (PEopp e1) lvar (cring_opp t1).
Instance  reify_pow (R:Type) (RR:Cring R)
 e1 lvar t1 n
 `{reifyPE R e1 lvar t1}
 : reifyPE (PEpow e1 n) lvar (@Ring_theory.pow_N _ cring1 cring_mult t1 n).
Instance  reify_var (R:Type) t lvar i
 `{is_in_list_at R t lvar i}
 : reifyPE (PEX Z (P_of_succ_nat i)) lvar t
 | 100.

Class reifyPElist (R:Type) (lexpr:list (PExpr Z)) (lvar:list R)
  (lterm:list R) := {}.
Instance reifyPE_nil (R:Type) lvar
 : @reifyPElist R nil lvar (@nil R).
Instance reifyPE_cons (R:Type) e1 lvar t1 lexpr2 lterm2
 `{reifyPE R e1 lvar t1} `{reifyPElist R lexpr2 lvar lterm2}
 : reifyPElist (e1::lexpr2) lvar (t1::lterm2).

Definition list_reifyl (R:Type) lexpr lvar lterm
 `{reifyPElist R lexpr lvar lterm}
 `{is_closed_list (T:=R) lvar} := (lvar,lexpr).

Unset Implicit Arguments.

Instance multiplication_phi_cring{R:Type}{Rr:Cring R} : Multiplication  :=
  {multiplication x y := cring_mult
    (@gen_phiZ R Rr x) y}.

(*
Print HintDb typeclass_instances.
*)
(* Reification *)

Ltac lterm_goal g :=
  match g with
  cring_eq ?t1 ?t2 => constr:(t1::t2::nil)
  | cring_eq ?t1 ?t2 -> ?g => let lvar := lterm_goal g in constr:(t1::t2::lvar)
  end.

Ltac reify_goal lvar lexpr lterm:=
(*  idtac lvar; idtac lexpr; idtac lterm;*)
  match lexpr with
     nil => idtac
   | ?e::?lexpr1 =>
        match lterm with
         ?t::?lterm1 => (* idtac "t="; idtac t;*)
           let x := fresh "T" in
           set (x:= t);
           change x with
             (@PEeval _ 0 addition multiplication subtraction opposite  Z
               (@gen_phiZ _ _)
               N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) lvar e);
           clear x;
           reify_goal lvar lexpr1 lterm1
        end
  end.

Existing Instance gen_phiZ_morph.
Existing Instance Zr.

Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y.
 intros x y H. rewrite (Zeq_bool_eq x y H). rrefl. Qed.

Lemma cring_eq_ext: forall (R:Type)(Rr:Cring R),
  ring_eq_ext addition multiplication opposite cring_eq.
intros. apply mk_reqe; set_cring_notations;intros.
cring_rewrite H0. cring_rewrite H. rrefl.
cring_rewrite H0. cring_rewrite H. rrefl.
 cring_rewrite H. rrefl. Defined.

Lemma cring_almost_ring_theory: forall (R:Type)(Rr:Cring R),
   almost_ring_theory 0 1 addition multiplication subtraction opposite cring_eq.
intros. apply mk_art ; set_cring_notations;intros.
cring_rewrite cring_add_0_l; rrefl.
cring_rewrite cring_add_comm; rrefl.
cring_rewrite cring_add_assoc; rrefl.
cring_rewrite cring_mul_1_l; rrefl.
apply cring_mul_0_l.
cring_rewrite cring_mul_comm; rrefl.
cring_rewrite cring_mul_assoc; rrefl.
cring_rewrite cring_distr_l; rrefl.
cring_rewrite cring_opp_mul_l; rrefl.
apply cring_opp_add.
cring_rewrite cring_sub_def ; rrefl. Defined.

Lemma cring_morph:  forall (R:Type)(Rr:Cring R),
  ring_morph  0 1 addition multiplication subtraction opposite cring_eq
             0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool
             (@gen_phiZ _ _).
intros. apply mkmorph ; intros; simpl; try rrefl; set_cring_notations.
cring_rewrite gen_phiZ_add; rrefl.
cring_rewrite cring_sub_def. unfold Zminus. cring_rewrite gen_phiZ_add.
cring_rewrite gen_phiZ_opp; rrefl.
cring_rewrite gen_phiZ_mul; rrefl.
cring_rewrite gen_phiZ_opp; rrefl.
rewrite (Zeqb_ok x y H). rrefl. Defined.

Lemma cring_power_theory :  forall (R:Type)(Rr:Cring R),
  power_theory 1 (@multiplication _ _ (@multiplication_cring R Rr)) cring_eq (fun n:N => n)
  (@Ring_theory.pow_N _  1 multiplication).
intros; apply mkpow_th; set_cring_notations. rrefl. Defined.

Lemma cring_div_theory: forall (R:Type)(Rr:Cring R),
  div_theory cring_eq Zplus Zmult (gen_phiZ Rr) Zquotrem.
intros. apply InitialRing.Ztriv_div_th. unfold Setoid_Theory.
simpl.   apply (@cring_setoid R Rr). Defined.

Ltac cring_gen :=
  match goal with
    |- ?g => let lterm := lterm_goal g in (* les variables *)
        match eval red in (list_reifyl (lterm:=lterm)) with
          | (?fv, ?lexpr) =>
(*         idtac "variables:";idtac fv;
           idtac "terms:"; idtac lterm;
           idtac "reifications:"; idtac lexpr;
           *)
            let lv := fresh "lvar" in
              set (lv := fv);
                reify_goal lv lexpr lterm;
                match goal with
                  |- ?g =>
                    set_cring_notations ; unfold lv;
                      generalize (@ring_correct _ 0 1 addition multiplication subtraction opposite
                        cring_eq
                        cring_setoid (@cring_eq_ext _ _) (@cring_almost_ring_theory _ _)
                        Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool
                        (@gen_phiZ _ _) (@cring_morph _ _) N (fun n:N => n)
                        (@Ring_theory.pow_N _  1 multiplication)
                        (@cring_power_theory _ _) Zquotrem (@cring_div_theory _ _) O fv nil);
                      set_cring_notations;
                      let rc := fresh "rc"in
                        intro rc; apply rc
                end
        end
  end.

Ltac cring_compute:= vm_compute; reflexivity.

Ltac cring:=
  unset_cring_notations; intros;
  unfold multiplication_phi_cring; simpl gen_phiZ;
  match goal with
    |- (@cring_eq ?r ?rd _ _ ) =>
          cring_gen; cring_compute
  end.

(* Pierre L: these tests should be done in a section, otherwise
   global axioms are generated. Ideally such tests should go in
   the test-suite directory *)

Section Tests.

(* Tests *)

Variable R: Type.
Variable Rr: Cring R.
Existing Instance Rr.

Goal forall x y z:R, 3%Z * x * (2%Z * y * z) == 6%Z * (x * y) * z.
cring.
Qed.

(* reification: 0,7s
sinon, le reste de la tactique donne le même temps que ring
*)
Goal forall x y z  t u :R, (x + y + z + t + u)^13 == (u + t + z + y + x) ^13.
(*Time*) cring. (*Finished transaction in 0. secs (0.410938u,0.s)*)
Qed.
(*
Goal forall x y z  t u :R, (x + y + z + t + u)^16 == (u + t + z + y + x) ^16.
Time cring.(*Finished transaction in 1. secs (0.968852u,0.001s)*)
Qed.
*)
(*
Require Export Ring.
Open Scope Z_scope.
Goal forall x y z  t u :Z, (x + y + z + t + u)^13 = (u + t + z + y + x) ^13.
intros.
Time ring.(*Finished transaction in 0. secs (0.371944u,0.s)*)
Qed.

Goal forall x y z  t u :Z, (x + y + z + t + u)^16 = (u + t + z + y + x) ^16.
intros.
Time ring.(*Finished transaction in 1. secs (0.914861u,0.s)*)
Qed.
*)

Goal forall x y z:R, 6*x^2 + y  == y + 3*2*x^2 + 0 .
cring.
Qed.

(*
Goal forall x y z:R, x + y  == y + x + 0 .
cring.
Qed.

Goal forall x y z:R, x * y * z == x * (y * z).
cring.
Qed.

Goal forall x y z:R, 3 * x * (2%Z * y * z) == 6 * (x * y) * z.
cring.
Qed.

Goal forall x y z:R, x ^ 2%N == x * x.
cring.
Qed.
*)

End Tests.