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

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

Module Export S := PackageSynthesis P.


Require Import CertiGraph.msl_ext.log_normalize.
Require Import CertiGraph.msl_ext.iter_sepcon.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.EnumEnsembles.
Require Import CertiGraph.lib.List_ext.
Require Import VST.msl.base.
Require Import VST.msl.simple_CCC.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.msl.Coqlib2.
Require Import VST.msl.ramification_lemmas.

Local Open Scope logic.

Section Ramification_P.

Context {A Env : Type}.
Context {ND : NatDed A}.
Context {SL : SepLog A}.
Context {CoSL: CorableSepLog A}.

Variable M: Env -> Env -> Prop.
Context {EqM: Equivalence M}.

(* Definition EnvironBox (P: Env -> A) : Env -> A := *)
(*   fun rho: Env => (ALL rho': Env, !! M rho rho' --> P rho'). *)

Definition EnvironStable (P: Env -> A) : Prop :=
  forall rho rho', M rho rho' -> P rho = P rho'.

Lemma EnvironStable_sepcon: forall P Q,
  EnvironStable P ->
  EnvironStable Q ->
  EnvironStable (P * Q).
Proof.
  unfold EnvironStable.
  intros.
  specialize (H _ _ H1).
  specialize (H0 _ _ H1).
  simpl.
  f_equal; auto.
Qed.

(*
Lemma EnvironBox_EnvironStable: forall P, EnvironStable (EnvironBox P).
(* This lemma is the reason why EqM is required. *)
Proof.
  intros.
  unfold EnvironBox, EnvironStable; intros.
  apply pred_ext; apply allp_right; intro rho''; apply (allp_left _ rho'');
  apply imp_andp_adjoint; normalize; rewrite prop_imp; auto.
  + rewrite H; auto.
  + rewrite <- H; auto.
Qed.

Lemma EnvironBox_T: forall P, EnvironBox P |-- P.
Proof.
  intros P rho.
  apply (allp_left _ rho).
  rewrite prop_imp by reflexivity.
  auto.
Qed.

Lemma EnvironBox_derives: forall P Q, P |-- Q -> EnvironBox P |-- EnvironBox Q.
Proof.
  intros P Q ? rho.
  apply allp_right; intro rho'.
  apply (allp_left _ rho').
  apply imp_andp_adjoint.
  apply derives_extract_prop'; intro.
  rewrite prop_imp by auto.
  auto.
Qed.

Lemma EnvironBox_sepcon: forall P Q, EnvironBox P * EnvironBox Q |-- EnvironBox (P * Q).
Proof.
  intros.
  unfold EnvironBox; simpl; intro rho.
  apply allp_right; intro rho'.
  apply imp_andp_adjoint; normalize.
  apply sepcon_derives; apply (allp_left _ rho');
  rewrite prop_imp by auto; auto.
Qed.

Lemma EnvironBox_andp: forall P Q, EnvironBox (P && Q) = EnvironBox P && EnvironBox Q.
Proof.
  intros.
  unfold EnvironBox; apply pred_ext; simpl; intro rho.
  + apply andp_right.
    - apply allp_right; intro rho'.
      apply -> imp_andp_adjoint; normalize.
      apply (allp_left _ rho');
      rewrite prop_imp by auto.
      apply andp_left1; auto.
    - apply allp_right; intro rho'.
      apply -> imp_andp_adjoint; normalize.
      apply (allp_left _ rho');
      rewrite prop_imp by auto.
      apply andp_left2; auto.
  + apply allp_right; intro rho'.
    apply -> imp_andp_adjoint; normalize.
    apply andp_derives; apply (allp_left _ rho');
    rewrite prop_imp by auto; auto.
Qed.

Lemma EnvironStable_allp: forall {T} P, (forall a: T, EnvironStable (P a)) -> EnvironStable (allp P).
Proof.
  intros.
  unfold EnvironStable in *.
  intros.
  simpl.
  apply allp_congr; intro a.
  apply H; auto.
Qed.

Lemma EnvironBox_TT: EnvironBox TT = TT.
Proof.
  intros.
  apply pred_ext.
  + apply TT_right.
  + unfold EnvironBox; intro rho.
    apply allp_right; intro rho'.
    apply imp_andp_adjoint.
    simpl; apply TT_right.
Qed.

Lemma EnvironStable_EnvironBox: forall P, EnvironStable P -> EnvironBox P = P.
Proof.
  intros.
  apply pred_ext; [apply EnvironBox_T |].
  unfold EnvironBox; intro rho.
  apply allp_right; intro rho'.
  apply imp_andp_adjoint; normalize.
  rewrite (H _ _ H0).
  auto.
Qed.

Lemma sepcon_EnvironBox_weaken: forall P Q R R', R |-- R' -> P |-- Q * EnvironBox R -> P |-- Q * EnvironBox R'.
Proof.
  intros.
  eapply derives_trans; [apply H0 |].
  apply sepcon_derives; auto.
  apply EnvironBox_derives; auto.
Qed.

Lemma EnvironBox_corable: forall P, corable P -> corable (EnvironBox P).
Proof.
  intros.
  simpl in H |- *.
  intro.
  unfold EnvironBox.
  auto.
Qed.

Lemma solve_ramify_P: forall (g l g' l' F: Env -> A),
  EnvironStable F ->
  g |-- l * F ->
  F * l' |-- g' ->
  g |-- l * EnvironBox (l' -* g').
Proof.
  intros.
  apply derives_trans with (l * F); auto.
  apply sepcon_derives; auto.
  unfold EnvironBox; simpl; intros rho.
  apply allp_right; intro rho'.
  apply imp_andp_adjoint.
  normalize.
  rewrite (H rho rho' H2).
  apply wand_sepcon_adjoint.
  apply H1.
Qed.

Lemma ramify_P_frame: forall g l g' l' F,
  EnvironStable F ->
  g |-- l * EnvironBox (l' -* g') ->
  g * F |-- l * EnvironBox (l' -* g' * F).
Proof.
  intros.
  apply solve_ramify_P with (EnvironBox (l' -* g') * F).
  + apply EnvironStable_sepcon; auto.
    apply EnvironBox_EnvironStable.
  + rewrite <- sepcon_assoc.
    apply sepcon_derives; auto.
  + rewrite (sepcon_comm _ l'), <- sepcon_assoc.
    apply sepcon_derives; [| auto].
    rewrite sepcon_comm; apply wand_sepcon_adjoint.
    apply EnvironBox_T.
Qed.

Lemma split_ramify_P: forall g1 g2 l1 l2 g1' g2' l1' l2',
  g1 |-- l1 * EnvironBox (l1' -* g1') ->
  g2 |-- l2 * EnvironBox (l2' -* g2') ->
  g1 * g2 |-- (l1 * l2) * EnvironBox (l1' * l2' -* g1' * g2').
Proof.
  intros.
  apply solve_ramify_P with (EnvironBox (l1' -* g1') * EnvironBox (l2' -* g2')).
  + apply EnvironStable_sepcon;
    apply EnvironBox_EnvironStable.
  + rewrite (sepcon_assoc l1), <- (sepcon_assoc l2), (sepcon_comm l2), (sepcon_assoc _ l2), <- (sepcon_assoc l1).
    apply sepcon_derives; auto.
  + apply wand_sepcon_adjoint.
    eapply derives_trans; [apply EnvironBox_sepcon |].
    eapply derives_trans; [apply EnvironBox_T |].
    apply wand_sepcon_wand.
Qed.

Lemma go_lower_ramify_P: forall (g l g' l': A),
  g |-- l * (l' -* g') ->
  @Basics.const A Env g |-- Basics.const l * EnvironBox (Basics.const l' -* Basics.const g').
Proof.
  intros.
  intro rho; unfold EnvironBox, Basics.const; simpl.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; [auto |].
  apply allp_right; intro rho'.
  apply imp_andp_adjoint.
  apply andp_left1.
  auto.
Qed.

Lemma ramify_PQ_reduce0: forall {B} g l (g' l': B -> Env -> A),
  g |-- l * EnvironBox (allp (l' -* g')) ->
  g |-- l * EnvironBox (exp l' -* exp g').
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; [auto |].
  apply EnvironBox_derives.
  apply wand_sepcon_adjoint.
  rewrite exp_sepcon2.
  apply exp_left; intro x; apply (exp_right x).
  apply wand_sepcon_adjoint.
  apply (allp_left _ x).
  auto.
Qed.

Lemma ramify_PQ_reduce1: forall {B} g l g0 l0 (g' l': B -> Env -> A),
  corable l0 ->
  g0 |-- l0 ->
  g |-- l * EnvironBox (allp (l' -* g')) ->
  g0 && g |-- (l0 && l) * EnvironBox (allp (l' -* g')).
Proof.
  intros.
  rewrite corable_andp_sepcon1 by auto.
  apply andp_derives; auto.
Qed.

Lemma ramify_PQ_reduce2: forall {B} g l g0 g' l' g0',
  corable g0 ->
  EnvironStable g0 ->
  (forall x: B, g0 |-- g0' x) ->
  g |-- l * EnvironBox (allp (l' -* g')) ->
  g0 && g |-- l * EnvironBox (allp (l' -* g0' && g')).
Proof.
  intros.
  eapply derives_trans; [apply andp_derives; [apply derives_refl | apply H2] |].
  rewrite <- corable_sepcon_andp1 by auto.
  apply sepcon_derives; [auto |].
  rewrite <- (EnvironStable_EnvironBox g0) at 1 by auto.
  rewrite <- EnvironBox_andp.
  apply EnvironBox_derives.
  apply allp_right; intro x.
  rewrite (andp_comm g0).
  apply imp_andp_adjoint.
  apply (allp_left _ x).
  apply imp_andp_adjoint.
  apply wand_sepcon_adjoint.
  rewrite corable_andp_sepcon2 by auto.
  change ((g0' && g') x) with (g0' x && g' x).
  change ((l' -* g') x) with (l' x -* g' x).
  apply andp_derives; auto.
  apply wand_sepcon_adjoint.
  auto.
Qed.

Lemma ramify_PQ_reduce3: forall {B} g l g' l' g0 l0 p,
  (forall x: B, corable (l0 x)) ->
  (forall x: B, l0 x |-- g0 x) ->
  (forall x: B, l0 x |-- p x) ->
  g |-- l * EnvironBox (allp (p --> (l' -* g'))) ->
  g |-- l * EnvironBox (allp (l0 && l' -* g0 && g')).
Proof.
  intros.
  apply derives_trans with (l * EnvironBox (allp (p --> (l' -* g')))).
  + auto.
  + apply sepcon_derives; auto.
    apply EnvironBox_derives.
    apply allp_right; intro x.
    apply (allp_left _ x).
    change ((l0 && l' -* g0 && g') x) with (l0 x && l' x -* g0 x && g' x).
    change ((p --> (l' -* g')) x) with (p x --> (l' x -* g' x)).
    apply wand_sepcon_adjoint.
    rewrite sepcon_comm, corable_andp_sepcon1, <- corable_sepcon_andp1 by auto.
    eapply derives_trans; [apply sepcon_derives; [apply derives_refl |] |].
    - apply andp_right; [apply andp_left1; apply derives_refl |].
      eapply derives_trans; [apply andp_derives; [apply H1 | apply derives_refl] |].
      apply modus_ponens.
    - rewrite corable_sepcon_andp1 by auto.
      apply andp_derives; auto.
      apply modus_ponens_wand.
Qed.

Lemma solve_ramify_PQ: forall {B} g l p g' l' F,
  EnvironStable F ->
  (forall x: B, corable (p x)) ->
  g |-- l * F ->
  (forall x: B, p x && (F * l' x) |-- g' x) ->
  g |-- l * EnvironBox (allp (p --> (l' -* g'))).
Proof.
  intros.
  apply derives_trans with (l * F); auto.
  apply sepcon_derives; auto.
  unfold EnvironBox; simpl; intros rho.
  apply allp_right; intro rho'.
  apply imp_andp_adjoint.
  normalize.
  rewrite (H rho rho' H3).
  clear rho H3; rename rho' into rho.
  apply allp_right; intro x.
  apply imp_andp_adjoint, wand_sepcon_adjoint.
  rewrite corable_andp_sepcon2 by apply (H0 x rho).
  apply (H2 x rho).
Qed.

Lemma ramify_PQ_frame: forall {B} g l p g' l' F,
  EnvironStable F ->
  (forall x: B, corable (p x)) ->
  g |-- l * EnvironBox (allp (p --> (l' -* g'))) ->
  g * F |-- l * EnvironBox (allp (p --> (l' -* g' * Basics.const F))).
Proof.
  intros.
  eapply derives_trans with (l * EnvironBox (allp (p --> (l' -* g'))) * F).
  + apply sepcon_derives; auto.
  + rewrite sepcon_assoc.
    apply sepcon_derives; auto.
    rewrite <- (EnvironStable_EnvironBox F) at 1 by auto.
    eapply derives_trans; [apply EnvironBox_sepcon |].
    apply EnvironBox_derives.
    apply allp_right; intro x.
    apply wand_sepcon_adjoint.
    apply (allp_left _ x).
    apply wand_sepcon_adjoint.
    change ((p --> (l' -* g' * Basics.const F)) x) with (p x --> (l' x -* g' x * F)).
    change ((p --> (l' -* g')) x) with (p x --> (l' x -* g' x)).
    apply imp_andp_adjoint.
    rewrite andp_comm, <- corable_andp_sepcon1 by auto.
    apply wand_sepcon_adjoint.
    eapply derives_trans; [apply modus_ponens |].
    rewrite wand_wand_comm.
    apply wand_derives; auto.
    apply wand_sepcon_adjoint; auto.
Qed.

Lemma split_ramify_PQ: forall {B} g1 g2 l1 l2 p g1' g2' l1' l2',
  (forall x: B, corable (p x)) ->
  g1 |-- l1 * EnvironBox (allp (p --> (l1' -* g1'))) ->
  g2 |-- l2 * EnvironBox (allp (p --> (l2' -* g2'))) ->
  g1 * g2 |-- (l1 * l2) * EnvironBox (allp (p --> (l1' * l2' -* g1' * g2'))).
Proof.
  intros.
  apply solve_ramify_PQ with (EnvironBox (allp (p --> (l1' -* g1'))) * EnvironBox (allp (p --> (l2' -* g2')))).
  + apply EnvironStable_sepcon;
    apply EnvironBox_EnvironStable.
  + auto.
  + rewrite (sepcon_assoc l1), <- (sepcon_assoc l2), (sepcon_comm l2), (sepcon_assoc _ l2), <- (sepcon_assoc l1).
    apply sepcon_derives; auto.
  + intros x.
    change ((l1' * l2') x) with (l1' x * l2' x).
    rewrite <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l1' x)), (sepcon_comm _ (l1' x)), <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l2' x)).
    rewrite <- (andp_dup (p x)), andp_assoc.
    rewrite <- corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
    rewrite <- !corable_sepcon_andp1 by auto.
    apply sepcon_derives.
    - apply wand_sepcon_adjoint; (eapply derives_trans; [apply EnvironBox_T |]).
      apply (allp_left _ x).
      apply wand_sepcon_adjoint.
      rewrite corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
      (eapply derives_trans; [apply sepcon_derives; [simpl; intros; apply modus_ponens | apply derives_refl] |]).
      apply wand_sepcon_adjoint; apply derives_refl.
    - apply wand_sepcon_adjoint; (eapply derives_trans; [apply EnvironBox_T |]).
      apply (allp_left _ x).
      apply wand_sepcon_adjoint.
      rewrite corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
      (eapply derives_trans; [apply sepcon_derives; [simpl; intros; apply modus_ponens | apply derives_refl] |]).
      apply wand_sepcon_adjoint; apply derives_refl.
Qed.

Lemma go_lower_ramify_PQ: forall {B} g l (p g' l': B -> A),
  g |-- l * (allp (p --> (l' -* g'))) ->
  Basics.const g |-- Basics.const l *
    EnvironBox (allp ((fun (x: B) (rho: Env) => p x) -->
      ((fun x _ => l' x) -* (fun x _ => g' x)))).
Proof.
  intros.
  intro rho; unfold EnvironBox, Basics.const; simpl.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; [auto |].
  apply allp_right; intro rho'.
  apply imp_andp_adjoint.
  apply andp_left1.
  auto.
Qed.

Lemma reduce_frame_from_ramification: forall F Q, EnvironStable F -> F |-- EnvironBox (Q -* Q * F).
Proof.
  intros.
  unfold EnvironBox.
  simpl; intros rho.
  apply allp_right; intros rho'.
  apply imp_andp_adjoint.
  normalize.
  apply wand_sepcon_adjoint.
  rewrite sepcon_comm.
  specialize (H _ _ H0).
  rewrite H.
  auto.
Qed.
*)
End Ramification_P.

(*

Lemma EnvironBox_allp: forall {A B Env : Type} {ND : NatDed A} (M: Env -> Env -> Prop) P, EnvironBox M (@allp _ _ B P) = ALL x: B, (EnvironBox M (P x)).
Proof.
  intros.
  unfold EnvironBox; apply pred_ext; simpl; intro rho.
  + apply allp_right; intro b.
    apply allp_right; intro rho'.
    apply imp_andp_adjoint; normalize.
    apply (allp_left _ rho').
    rewrite prop_imp by auto.
    apply (allp_left _ b).
    auto.
  + apply allp_right; intro rho'.
    apply imp_andp_adjoint; normalize.
    apply allp_right; intro b.
    apply (allp_left _ b).
    apply (allp_left _ rho').
    rewrite prop_imp by auto.
    auto.
Qed.

Lemma EnvironBox_weaken: forall {A Env : Type} {ND : NatDed A} (M1 M2: Env -> Env -> Prop) P, inclusion _ M1 M2 -> EnvironBox M2 P |-- EnvironBox M1 P.
Proof.
  intros.
  unfold EnvironBox.
  intro rho.
  apply allp_right; intro rho'.
  apply (allp_left _ rho').
  apply imp_andp_adjoint.
  apply derives_extract_prop'; intro.
  rewrite prop_imp by auto.
  auto.
Qed.

Lemma EnvironBox_EnvironStable_weaken: forall {A Env : Type} {ND : NatDed A} (M1 M2: Env -> Env -> Prop) {EqM2: Equivalence M2} P, inclusion _ M1 M2 -> EnvironStable M1 (EnvironBox M2 P).
(* This lemma is the reason why EqM is required. *)
Proof.
  intros.
  unfold EnvironBox, EnvironStable; intros.
  apply pred_ext; apply allp_right; intro rho''; apply (allp_left _ rho'');
  apply imp_andp_adjoint; normalize; rewrite prop_imp; auto.
  + apply H in H0.
    rewrite H0; auto.
  + apply H in H0.
    rewrite <- H0; auto.
Qed.

*)

Ltac solve_ramify_Q_with Fr :=
  match goal with
  | |- @derives ?Pred _ ?g (?l * @allp ?Pred _ ?T ?Func) =>
      let p := fresh "p" in evar (p: T -> Pred);
      let g' := fresh "g'" in evar (g': T -> Pred);
      let l' := fresh "l'" in evar (l': T -> Pred);
      let x := fresh "x" in
      let H := fresh "H" in
      assert (Func = p --> (l' -* g'));
      [
        extensionality x; cbv beta;
        match goal with
        | |- ?P --> (?L' -* ?G') = _ =>
             super_pattern P x; super_pattern L' x; super_pattern G' x
        end;
        match goal with
        | |- ?P _ --> (?L' _ -* ?G' _) = _ =>
             instantiate (1 := P) in (value of p);
             instantiate (1 := L') in (value of l');
             instantiate (1 := G') in (value of g')
        end;
        subst p g' l';
        reflexivity
      | subst p g' l'; rewrite H; clear H]
  end;
  apply RAMIF_Q'.solve with Fr.

Section Ramification_PredSepCon.

(******************************************

The purpose of these lemmas are specifying ramification premises, such that
spatial predicates and items (or pure predicates) can be modified from the
left side to the right side.

However, the frame part should be part-wise equivalent, i.e. spatial predicates
must be equivalent and items (or pure predicates) must be equivalent. E.g.
F = G and a = b is acceptable but only F a = G b is not. To prove a ramification
premise of latter situation should use iter_sepcon_map/pred_sepcon_map first.

******************************************)

Context {A : Type}.
Context {B : Type}.
Context {ND : NatDed A}.
Context {SL : SepLog A}.
Context {ClS: ClassicalSep A}.
Context {CoSL: CorableSepLog A}.

(******************************************

Ramification Premises with iter_sepcon

******************************************)

Lemma iter_sepcon_ramif_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (P': T -> B -> A) (g: list B) (g': T -> list B) (x: B) (x': T -> B),
  (exists f,
    Permutation g (x :: f) /\
    (forall a, Pure a -> Permutation (g' a) (x' a :: f)) /\
    (forall a, Pure a -> forall x, In x f -> P x = (P' a) x)) ->
  iter_sepcon g P |-- P x *
    (ALL a: T, !! Pure a -->
      ((P' a) (x' a) -* iter_sepcon (g' a) (P' a))).
Proof.
  intros.
  destruct H as [f [? [? ?]]].
  RAMIF_Q'.formalize.
  apply RAMIF_Q'.solve with (iter_sepcon f P).
  + simpl; auto.
  + rewrite H; simpl; auto.
  + intros a; normalize.
    specialize (H0 _ H2).
    specialize (H1 _ H2).
    rewrite H0.
    rewrite sepcon_comm.
    apply derives_refl'; simpl; f_equal.
    apply iter_sepcon_func_strong; auto.
Qed.

Lemma iter_sepcon_ramif_xQ: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (P': T -> B -> A) (g l: list B) (g' l': T -> list B),
  (exists f,
    Permutation g (l ++ f) /\
    (forall a, Pure a -> Permutation (g' a) (l' a ++ f)) /\
    (forall a, Pure a -> forall x, In x f -> P x = (P' a) x)) ->
  iter_sepcon g P |-- iter_sepcon l P *
    (ALL a: T, !! Pure a -->
      (iter_sepcon (l' a) (P' a) -* iter_sepcon (g' a) (P' a))).
Proof.
  intros.
  destruct H as [f [? [? ?]]].
  RAMIF_Q'.formalize.
  apply RAMIF_Q'.solve with (iter_sepcon f P).
  + simpl; auto.
  + rewrite H.
    apply derives_refl'.
    apply iter_sepcon_app_sepcon.
  + intros a; normalize.
    specialize (H0 _ H2).
    specialize (H1 _ H2).
    rewrite H0.
    rewrite sepcon_comm.
    apply derives_refl'.
    rewrite iter_sepcon_app_sepcon; f_equal.
    apply iter_sepcon_func_strong; auto.
Qed.

Lemma iter_sepcon_ramif_item_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (g: list B) (g': T -> list B) (x: B) (x': T -> B),
  (exists f,
    Permutation g (x :: f) /\
    (forall a, Pure a -> Permutation (g' a) (x' a :: f))) ->
  iter_sepcon g P |-- P x *
    (ALL a: T, !! Pure a -->
      (P (x' a) -* iter_sepcon (g' a) P)).
Proof.
  intros.
  apply (iter_sepcon_ramif_1Q Pure P (fun _ => P)).
  destruct H as [f [? ?]].
  exists f; split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_item_xQ: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (g l: list B) (g' l': T -> list B),
  (exists f,
    Permutation g (l ++ f) /\
    (forall a, Pure a -> Permutation (g' a) (l' a ++ f))) ->
  iter_sepcon g P |-- iter_sepcon l P *
    (ALL a: T, !! Pure a -->
      (iter_sepcon (l' a) P -* iter_sepcon (g' a) P)).
Proof.
  intros.
  apply (iter_sepcon_ramif_xQ Pure P (fun _ => P)).
  destruct H as [f [? ?]].
  exists f; split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_pred_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (P': T -> B -> A) (g: list B) (x: B),
  (exists f,
    Permutation g (x :: f) /\
    (forall a, Pure a -> forall x, In x f -> P x = (P' a) x)) ->
  iter_sepcon g P |-- P x *
    (ALL a: T, !! Pure a -->
      ((P' a) x -* iter_sepcon g (P' a))).
Proof.
  intros.
  apply (iter_sepcon_ramif_1Q _ _ _ g (fun _ => g) x (fun _ => x)).
  destruct H as [f [? ?]].
  exists f; split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_pred_xQ: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (P': T -> B -> A) (g l: list B),
  (exists f,
    Permutation g (l ++ f) /\
    (forall a, Pure a -> forall x, In x f -> P x = (P' a) x)) ->
  iter_sepcon g P |-- iter_sepcon l P *
    (ALL a: T, !! Pure a -->
      (iter_sepcon l (P' a) -* iter_sepcon g (P' a))).
Proof.
  intros.
  apply (iter_sepcon_ramif_xQ _ _ _ g l (fun _ => g) (fun _ => l)).
  destruct H as [f [? ?]].
  exists f; split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_1: forall P P' (g g': list B) (x x': B),
  (exists f,
    Permutation g (x :: f) /\
    Permutation g' (x' :: f) /\
    (forall x, In x f -> P x = P' x)) ->
  iter_sepcon g P |-- P x * (P' x' -* iter_sepcon g' P').
Proof.
  intros.
  pose proof iter_sepcon_ramif_1Q (fun x: unit => True) P (fun _ => P') g (fun _ => g') x (fun _ => x').
  rewrite allp_unit in H0.
  rewrite prop_imp in H0 by auto.
  apply H0.
  destruct H as [f [? [? ?]]]; exists f.
  split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_x: forall P P' (g g' l l': list B),
  (exists f,
    Permutation g (l ++ f) /\
    Permutation g' (l' ++ f) /\
    (forall x, In x f -> P x = P' x)) ->
  iter_sepcon g P |-- iter_sepcon l P * (iter_sepcon l' P' -* iter_sepcon g' P').
Proof.
  intros.
  pose proof iter_sepcon_ramif_xQ (fun x: unit => True) P (fun _ => P') g l (fun _ => g') (fun _ => l').
  rewrite allp_unit in H0.
  rewrite prop_imp in H0 by auto.
  apply H0.
  destruct H as [f [? [? ?]]]; exists f.
  split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_item_1: forall P (g g': list B) (x x': B),
  (exists f,
    Permutation g (x :: f) /\
    Permutation g' (x' :: f)) ->
  iter_sepcon g P |-- P x * (P x' -* iter_sepcon g' P).
Proof.
  intros.
  apply iter_sepcon_ramif_1.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_item_x: forall P (g g' l l': list B),
  (exists f,
    Permutation g (l ++ f) /\
    Permutation g' (l' ++ f)) ->
  iter_sepcon g P |-- iter_sepcon l P * (iter_sepcon l' P -* iter_sepcon g' P).
Proof.
  intros.
  apply iter_sepcon_ramif_x.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_pred_1: forall P P' (g: list B) (x: B),
  (exists f,
    Permutation g (x :: f) /\
    (forall x, In x f -> P x = P' x)) ->
  iter_sepcon g P |-- P x * (P' x -* iter_sepcon g P').
Proof.
  intros.
  apply iter_sepcon_ramif_1.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_stable_1: forall P (g: list B) (x: B),
    In x g -> iter_sepcon g P |-- P x * (P x -* iter_sepcon g P).
Proof.
  intros. apply In_Permutation_cons in H. destruct H as [f ?].
  apply iter_sepcon_ramif_pred_1. exists f. split; [assumption|intros; reflexivity].
Qed.

Lemma iter_sepcon_ramif_pred_x: forall P P' (g l: list B),
  (exists f,
    Permutation g (l ++ f) /\
    (forall x, In x f -> P x = P' x)) ->
  iter_sepcon g P |-- iter_sepcon l P * (iter_sepcon l P' -* iter_sepcon g P').
Proof.
  intros.
  apply iter_sepcon_ramif_x.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; intros; auto.
Qed.

(******************************************

Ramification Premises with pred_sepcon

******************************************)

(* A better way to prove it is using RAMIF_Q'.solve and sepcon properties of pred_sepcon.
Unfolding into iter_sepcon needs handling quatifiers, which is in convenient. The following
proof script only shows that it is doable. *)
Lemma pred_sepcon_ramif_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> Prop) (P': T -> B -> Prop) (p: B -> A) (p': T -> B -> A) (x: B) (x' : T -> B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    (forall a, Pure a -> Prop_join (eq (x' a)) Pf (P' a)) /\
    (forall a, Pure a -> (forall y, Pf y -> p y = (p' a) y))) ->
  pred_sepcon P p |-- p x *
    (ALL a: T, !! Pure a -->
      ((p' a) (x' a) -* pred_sepcon (P' a) (p' a))).
Proof.
  intros.
  unfold pred_sepcon.
  normalize; intros; normalize; rename x0 into g.
  destruct H as [Pf [? [? ?]]].
  destruct (Permutation_spec_Prop_join g P Pf x H (conj H0 H1)) as [f [? [? ?]]].
  evar (pp : T -> A). evar (ll: T -> A). evar (gg: list B -> T -> A).
  assert ((fun a : T =>
   !! Pure a -->
   (p' a (x' a) -*
    (EX l : list B,
            !! (forall x0 : B, In x0 l <-> P' a x0) && !! NoDup l && iter_sepcon l (p' a)))) = (pp --> (ll -* exp gg))). {
    extensionality x0.
    super_pattern (!! Pure x0) x0. super_pattern (p' x0 (x' x0)) x0.
    super_pattern (fun l => !! (forall x1 : B, In x1 l <-> P' x0 x1) && !! NoDup l && iter_sepcon l (p' x0)) x0.
    instantiate (1 := (fun t : T => !! Pure t)) in (value of pp).
    instantiate (1 := (fun t : T => p' t (x' t))) in (value of ll).
    instantiate (1 := (fun (l : list B) (t : T) => !! (forall x1 : B, In x1 l <-> P' t x1) && !! NoDup l && iter_sepcon l (p' t))) in (value of gg).
    subst pp gg ll. reflexivity.
  }
  subst pp gg ll. rewrite H7. clear H7.
  apply (RAMIF_Q'.exp_right (fun a => x' a :: f)); [simpl; auto |].
  pose proof iter_sepcon_ramif_1Q Pure p p' g (fun a => x' a :: f) x x'.
  spec H7; [clear H7 |].
  + exists f.
    split; auto.
    split; intros.
    - reflexivity.
    - apply (H3 _ H7).
      rewrite <- H5; auto.
  + eapply derives_trans; [exact H7 |]; clear H7.
    apply sepcon_derives; auto.
    apply allp_right; intros a.
    apply (allp_left _ a).
    simpl.
    apply imp_andp_adjoint; normalize.
    unfold TT; rewrite prop_imp by auto.
    apply wand_derives; auto.
    apply andp_right; auto.
    specialize (H2 _ H7).
    specialize (H3 _ H7).
    apply andp_right; apply prop_right.
    - intro y.
      rewrite H5.
      destruct H2 as [? _].
      symmetry; apply H2.
    - apply NoDup_cons; auto.
      destruct H2 as [_ ?].
      specialize (H2 (x' a) eq_refl).
      rewrite H5; auto.
Qed.

Lemma pred_sepcon_ramif_xQ: forall {T: Type} (Pure: T -> Prop) (G L: B -> Prop) (L' G': T -> B -> Prop) (p: B -> A) (p': T -> B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    (forall a, Pure a -> Prop_join (L' a) Pf (G' a)) /\
    (forall a, Pure a -> (forall y, Pf y -> p y = (p' a) y))) ->
  pred_sepcon G p |-- pred_sepcon L p *
    (ALL a: T, !! Pure a -->
      (pred_sepcon (L' a) (p' a) -* pred_sepcon (G' a) (p' a))).
Proof.
  intros.
  destruct H as [Pf [? [? ?]]].
  RAMIF_Q'.formalize.
  apply RAMIF_Q'.solve with (pred_sepcon Pf p).
  + simpl; auto.
  + apply derives_refl'; symmetry.
    apply pred_sepcon_sepcon; auto.
  + intros.
    normalize.
    specialize (H0 _ H2).
    specialize (H1 _ H2).
    apply derives_refl'.
    rewrite (pred_sepcon_strong_proper Pf Pf p (p' x)) by (auto; intros; tauto).
    rewrite sepcon_comm; apply pred_sepcon_sepcon; auto.
Qed.

Lemma pred_sepcon_ramif_pred_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> Prop) (p: B -> A) (p': T -> B -> A) (x: B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    (forall a, Pure a -> (forall y, Pf y -> p y = (p' a) y))) ->
  pred_sepcon P p |-- p x *
    (ALL a: T, !! Pure a -->
      ((p' a) x -* pred_sepcon P (p' a))).
Proof.
  intros.
  apply pred_sepcon_ramif_1Q.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_pred_xQ: forall {T: Type} (Pure: T -> Prop) (G L: B -> Prop) (p: B -> A) (p': T -> B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    (forall a, Pure a -> (forall y, Pf y -> p y = (p' a) y))) ->
  pred_sepcon G p |-- pred_sepcon L p *
    (ALL a: T, !! Pure a -->
      (pred_sepcon L (p' a) -* pred_sepcon G (p' a))).
Proof.
  intros.
  apply pred_sepcon_ramif_xQ.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_item_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> Prop) (P': T -> B -> Prop) (p: B -> A) (x: B) (x' : T -> B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    (forall a, Pure a -> Prop_join (eq (x' a)) Pf (P' a))) ->
  pred_sepcon P p |-- p x *
    (ALL a: T, !! Pure a -->
      (p (x' a) -* pred_sepcon (P' a) p)).
Proof.
  intros.
  apply pred_sepcon_ramif_1Q.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_item_xQ: forall {T: Type} (Pure: T -> Prop) (G L: B -> Prop) (L' G': T -> B -> Prop) (p: B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    (forall a, Pure a -> Prop_join (L' a) Pf (G' a))) ->
  pred_sepcon G p |-- pred_sepcon L p *
    (ALL a: T, !! Pure a -->
      (pred_sepcon (L' a) p -* pred_sepcon (G' a) p)).
Proof.
  intros.
  apply pred_sepcon_ramif_xQ.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_1: forall (P P': B -> Prop) (p p': B -> A) (x x': B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    Prop_join (eq x') Pf P' /\
    (forall y, Pf y -> p y = p' y)) ->
  pred_sepcon P p |-- p x * (p' x' -* pred_sepcon P' p').
Proof.
  intros.
  pose proof pred_sepcon_ramif_1Q (fun _: unit => True) P (fun _ => P') p (fun _ => p') x (fun _ => x').
  rewrite allp_unit in H0.
  rewrite prop_imp in H0 by auto.
  apply H0.
  destruct H as [f [? [? ?]]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_x: forall (G L L' G': B -> Prop) (p p': B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    Prop_join L' Pf G' /\
    (forall y, Pf y -> p y = p' y)) ->
  pred_sepcon G p |-- pred_sepcon L p * (pred_sepcon L' p' -* pred_sepcon G' p').
Proof.
  intros.
  pose proof pred_sepcon_ramif_xQ (fun _: unit => True) G L (fun _ => L') (fun _ => G') p (fun _ => p').
  rewrite allp_unit in H0.
  rewrite prop_imp in H0 by auto.
  apply H0.
  destruct H as [f [? [? ?]]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_pred_1: forall (P: B -> Prop) (p p': B -> A) (x: B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    (forall y, Pf y -> p y = p' y)) ->
  pred_sepcon P p |-- p x * (p' x -* pred_sepcon P p').
Proof.
  intros.
  apply pred_sepcon_ramif_1.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_pred_x: forall (G L: B -> Prop) (p p': B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    (forall y, Pf y -> p y = p' y)) ->
  pred_sepcon G p |-- pred_sepcon L p * (pred_sepcon L p' -* pred_sepcon G p').
Proof.
  intros.
  apply pred_sepcon_ramif_x.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_item_1: forall (P P': B -> Prop) (p: B -> A) (x x': B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    Prop_join (eq x') Pf P') ->
  pred_sepcon P p |-- p x * (p x' -* pred_sepcon P' p).
Proof.
  intros.
  apply pred_sepcon_ramif_1.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_item_x: forall (G L L' G': B -> Prop) (p: B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    Prop_join L' Pf G') ->
  pred_sepcon G p |-- pred_sepcon L p * (pred_sepcon L' p -* pred_sepcon G' p).
Proof.
  intros.
  apply pred_sepcon_ramif_x.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

End Ramification_PredSepCon.


Require Import Rpos.
Require Import RL.hr.term.
Require Import RL.hr.hseq.
Require Import RL.hr.hr.
Require Import RL.hr.semantic.
Require Import RL.hr.interpretation.

Require Import List.
Require Import Lra.

Require Import RL.OLlibs.Permutation_more.

Local Open Scope R_scope.

(** ** all rules are sound *)

Lemma W_sound : forall G T, G <> nil ->  RS_zero <== (sem_hseq G) -> RS_zero <== sem_hseq (T :: G).
Proof with try assumption.
  intros G T notEmpty Hleq.
  destruct G; [ now exfalso | ].
  unfold sem_hseq; fold(sem_hseq (s :: G)).
  apply leq_trans with (sem_hseq (s :: G))...
  eapply leq_cong_r; [ apply commu_max | ].
  now apply abso_min.
Qed.

Lemma C_sound : forall G T, sem_hseq (T :: T :: G) === sem_hseq (T :: G).
Proof with try assumption.
  intros G T.
  destruct G.
  - unfold sem_hseq.
    now auto with MGA_solver.
  - unfold sem_hseq; fold (sem_hseq (s :: G)).
    etransitivity ; [apply asso_max | ].
    now auto with MGA_solver.
Qed.

Lemma S_sound : forall G T1 T2, RS_zero <== sem_hseq ((T1 ++ T2) :: G) -> RS_zero <== sem_hseq (T1 :: T2 :: G).
Proof with try assumption.
  intros G T1 T2 Hleq.
  destruct G.
  - simpl in *.
    apply leq_div_2.
    eapply leq_cong_l; [ apply mul_2 | ].
    eapply leq_cong_l ;[ apply neutral_plus | ].
    eapply leq_cong_r in Hleq; [ | symmetry; apply sem_seq_plus].
    apply leq_trans with (sem_seq T1 +S sem_seq T2)...
    now apply mean_prop.
  - unfold sem_hseq in *; fold (sem_hseq (l :: G)) in *.
    eapply leq_cong_r; [ apply asso_max | ].
    apply cond_zero_leq_max_2.
    apply leq_antisym.
    + apply leq_trans with (((plus_pos One One) *S  neg (sem_seq T1 \/S sem_seq T2)) /\S neg (sem_hseq (l :: G))).
      * apply leq_min.
        -- apply leq_trans with (neg (sem_seq T1 \/S sem_seq T2)); [auto with MGA_solver | ].
           eapply leq_cong_r ; [apply mul_2 | ].
           eapply leq_cong_l; [symmetry; apply neutral_plus | ].
           eapply leq_cong_l; [apply commu_plus | ].
           apply leq_plus.
           now auto with MGA_solver.
        -- eapply leq_cong_l ; [ apply commu_min | ].
           now auto with MGA_solver.
      * apply leq_trans with (neg (sem_seq T1 +S sem_seq T2) /\S neg (sem_hseq (l :: G))).
        -- apply leq_min.
           ++ apply leq_trans with (plus_pos One One *S neg (sem_seq T1 \/S sem_seq T2)).
              ** now auto with MGA_solver.
              ** eapply leq_cong_l; [apply Rpos_mul_neg | ].
                 apply neg_leq_cond.
                 apply mean_prop.
           ++ eapply leq_cong_l; [ apply commu_min | ].
              apply min_leq.
        -- apply cond_min_neg_eq_zero in Hleq.
           eapply leq_cong_l.
           { apply min_left.
             apply max_left.
             apply (@ctxt RS_cohole).
             symmetry; apply sem_seq_plus. }
           eapply leq_cong_l; [apply Hleq | ].
           apply leq_refl.
    + apply leq_min; now auto with MGA_solver.
Qed.

Lemma M_sound : forall G T1 T2, RS_zero <== sem_hseq (T1 :: G) -> RS_zero <== sem_hseq (T2 :: G) ->
                                RS_zero <== sem_hseq ((T1 ++ T2) :: G).
Proof with try assumption.
  intros [ | T3 G ] T1 T2 Hleq1 Hleq2.
  - simpl in *.
    eapply leq_cong_r ; [ apply sem_seq_plus | ].
    eapply leq_cong_l; [ symmetry; apply neutral_plus | ].
    apply leq_plus_cong...
  - unfold sem_hseq in *; fold (sem_hseq (T3 :: G)) in *; fold (sem_hseq (T3 :: G)) in *; fold (sem_hseq (T3 :: G)).
    eapply leq_cong_r.
    { apply max_left.
      apply sem_seq_plus. }
    apply cond_zero_leq_max_2.
    apply leq_antisym.
    + eapply leq_trans.
      { apply leq_min.
        - eapply leq_trans.
          + apply min_leq.
          + apply neg_subdistri_plus.
        - eapply leq_cong_l; [apply commu_min | ].
          apply min_leq. }
      eapply leq_trans.
      * apply plus_pos_min; apply zero_leq_neg.
      * eapply leq_cong_r; [ symmetry; apply neutral_plus | ].
        apply leq_plus_cong;
          (eapply leq_cong_r ; [ symmetry; apply cond_min_neg_eq_zero | apply leq_refl]);
          assumption.
    + apply leq_min.
      * eapply leq_cong_r; [apply commu_max | ].
        apply leq_max.
      * eapply leq_cong_r; [apply commu_max | ].
        apply leq_max.
Qed.

Lemma T_sound :  forall G T r,
    RS_zero <== sem_hseq (seq_mul r T :: G) ->
    RS_zero <== sem_hseq (T :: G).
Proof with try assumption.
  intros [ | T2 G] T [r Hpos];
    remember (existT (fun r : R => (0 <? r)%R = true) r Hpos) as t; intros Hleq.
  - simpl in *.
    eapply leq_cong_r ; [ symmetry; apply mul_1 | ].
    replace One with (time_pos (inv_pos t) t).
    2:{ clear; apply Rpos_eq; destruct t; simpl; apply R_blt_lt in e; rewrite Rinv_l; nra. }
    eapply leq_cong_r; [ symmetry; apply mul_assoc | ].
    apply leq_cong_r with (inv_pos t *S (pos (t *S sem_seq T))).
    { apply mul_right.
      symmetry.
      etransitivity; [ apply commu_max | ].
      apply min_max.
      eapply leq_cong_r; [ | apply Hleq].
      symmetry; apply sem_seq_mul. }
    apply compa_mul_ax.
  - unfold sem_hseq in *; fold (sem_hseq (T2 :: G)) in *.
    apply leq_pos_max_mul_l with t.
    eapply leq_cong_r; [ | apply Hleq].
    apply max_left.
    symmetry; apply sem_seq_mul.
Qed.

(** The following lemma prove both the soundness of the ID rule and the CAN rule *)
Lemma ext_ID_sound : forall G T A r s,
    sum_vec r = sum_vec s -> sem_hseq (T :: G) === sem_hseq ((vec s (-S A) ++ vec r A ++ T) :: G).
Proof.
  intros [ | T2 G] T A r s Heq.
  - simpl.
    etransitivity; [ | symmetry; apply sem_seq_plus ].
    etransitivity; [ | symmetry; apply plus_right; apply sem_seq_plus ].
    etransitivity; [ | symmetry; apply asso_plus].
    etransitivity; [ | apply plus_left; apply commu_plus ].
    destruct r; destruct s.
    + simpl in *.
      etransitivity; [ | apply commu_plus].
      etransitivity; [ | symmetry; apply plus_right; apply neutral_plus].
      symmetry; apply neutral_plus.
    + exfalso.
      destruct r ; simpl in *.
      apply R_blt_lt in e.
      assert (H := (sum_vec_le_0 s)).
      nra.
    + exfalso.
      destruct r ; simpl in *.
      apply R_blt_lt in e.
      assert (H := (sum_vec_le_0 r0)).
      nra.
    + assert (r :: r0 <> nil) as H1 by now auto.
      assert (r1 :: s <> nil) as H2 by now auto.
      etransitivity; [ | apply plus_left; apply plus_left; symmetry; apply (sem_seq_vec _ _ H1)].
      etransitivity; [ | apply plus_left; apply plus_right; symmetry; apply (sem_seq_vec _ _ H2)].
      replace (existT (fun r2 : R => (0 <? r2) = true) (sum_vec (r :: r0)) (sum_vec_non_nil _ H1)) with (existT (fun r2 : R => (0 <? r2) = true) (sum_vec (r1 :: s)) (sum_vec_non_nil _ H2)) by (apply Rpos_eq; simpl in *; nra).
      etransitivity; [ | apply plus_left; apply plus_right; symmetry; apply mul_minus].
      etransitivity; [ | apply plus_left; symmetry; apply opp_plus].
      etransitivity; [ | apply commu_plus].
      symmetry; apply neutral_plus.
  - unfold sem_hseq; fold (sem_hseq (T2 :: G)).
    apply max_left.
    etransitivity; [ | symmetry; apply sem_seq_plus ].
    etransitivity; [ | symmetry; apply plus_right; apply sem_seq_plus ].
    etransitivity; [ | symmetry; apply asso_plus].
    etransitivity; [ | apply plus_left; apply commu_plus ].
    destruct r; destruct s.
    + simpl in *.
      etransitivity; [ | apply commu_plus].
      etransitivity; [ | symmetry; apply plus_right; apply neutral_plus].
      symmetry; apply neutral_plus.
    + exfalso.
      destruct r ; simpl in *.
      apply R_blt_lt in e.
      assert (H := (sum_vec_le_0 s)).
      nra.
    + exfalso.
      destruct r ; simpl in *.
      apply R_blt_lt in e.
      assert (H := (sum_vec_le_0 r0)).
      nra.
    + assert (r :: r0 <> nil) as H1 by now auto.
      assert (r1 :: s <> nil) as H2 by now auto.
      etransitivity; [ | apply plus_left; apply plus_left; symmetry; apply (sem_seq_vec _ _ H1)].
      etransitivity; [ | apply plus_left; apply plus_right; symmetry; apply (sem_seq_vec _ _ H2)].
      replace (existT (fun r2 : R => (0 <? r2) = true) (sum_vec (r :: r0)) (sum_vec_non_nil _ H1)) with (existT (fun r2 : R => (0 <? r2) = true) (sum_vec (r1 :: s)) (sum_vec_non_nil _ H2)) by (apply Rpos_eq; simpl in *; nra).
      etransitivity; [ | apply plus_left; apply plus_right; symmetry; apply mul_minus].
      etransitivity; [ | apply plus_left; symmetry; apply opp_plus].
      etransitivity; [ | apply commu_plus].
      symmetry; apply neutral_plus.
Qed.

Lemma Z_sound : forall G T r, sem_hseq (T :: G) === sem_hseq ((vec r RS_zero ++ T) :: G).
Proof.
  intros [ | T2 G] T [ | r0 r].
  - reflexivity.
  - unfold sem_hseq.
    assert ((r0 :: r) <> nil) as H by now auto.
    symmetry.
    etransitivity; [ apply sem_seq_plus | ].
    etransitivity; [ apply plus_left; apply (sem_seq_vec _ _ H) | ].
    etransitivity; [ apply plus_left; apply mul_0 | ].
    etransitivity; [ apply commu_plus | ].
    apply neutral_plus.
  - unfold sem_hseq; fold (sem_hseq (T2 :: G)).
    reflexivity.
  - unfold sem_hseq; fold (sem_hseq (T2 :: G)).
    apply max_left.
    assert ((r0 :: r) <> nil) as H by now auto.
    symmetry.
    etransitivity; [ apply sem_seq_plus | ].
    etransitivity; [ apply plus_left; apply (sem_seq_vec _ _ H) | ].
    etransitivity; [ apply plus_left; apply mul_0 | ].
    etransitivity; [ apply commu_plus | ].
    apply neutral_plus.
Qed.

Lemma plus_sound : forall G T A B r, sem_hseq ((vec r A ++ vec r B ++ T) :: G) === sem_hseq ((vec r (A +S B) ++ T) :: G).
Proof.
  intros [ | T2 G] T A B r.
  - simpl in *.
    etransitivity; [ apply sem_seq_plus | ].
    etransitivity; [ apply plus_right; apply sem_seq_plus | ].
    etransitivity; [ | symmetry; apply sem_seq_plus].
    destruct r as [ | r0 r].
    + simpl.
      etransitivity; [ apply commu_plus | ].
      etransitivity; [ apply neutral_plus | ].
      etransitivity; [ apply commu_plus | ].
      etransitivity; [ apply neutral_plus | ].
      symmetry.
      etransitivity; [ apply commu_plus | ].
      apply neutral_plus.
    + assert ((r0 :: r) <> nil) as H by now auto.
      etransitivity; [ apply plus_left ; apply (sem_seq_vec _ _ H)|].
      etransitivity; [ apply plus_right; apply plus_left; apply (sem_seq_vec _ _ H)|].
      etransitivity; [ | apply plus_left; symmetry; apply (sem_seq_vec _ _ H)].
      etransitivity; [ | apply plus_left; symmetry; apply mul_distri_term].
      auto.
  - unfold sem_hseq; fold (sem_hseq (T2 :: G)).
    apply max_left.
    etransitivity; [ apply sem_seq_plus | ].
    etransitivity; [ apply plus_right; apply sem_seq_plus | ].
    etransitivity; [ | symmetry; apply sem_seq_plus].
    destruct r as [ | r0 r].
    + simpl.
      etransitivity; [ apply commu_plus | ].
      etransitivity; [ apply neutral_plus | ].
      etransitivity; [ apply commu_plus | ].
      etransitivity; [ apply neutral_plus | ].
      symmetry.
      etransitivity; [ apply commu_plus | ].
      apply neutral_plus.
    + assert ((r0 :: r) <> nil) as H by now auto.
      etransitivity; [ apply plus_left ; apply (sem_seq_vec _ _ H)|].
      etransitivity; [ apply plus_right; apply plus_left; apply (sem_seq_vec _ _ H)|].
      etransitivity; [ | apply plus_left; symmetry; apply (sem_seq_vec _ _ H)].
      etransitivity; [ | apply plus_left; symmetry; apply mul_distri_term].
      auto.
Qed.

Lemma mul_sound : forall G T A r0 r, sem_hseq ((vec (mul_vec r0 r) A ++ T) :: G) === sem_hseq ((vec r (r0 *S A) ++ T) :: G).
Proof.
  intros [ | T2 G] T A r0 [ | r' r].
  - simpl; auto.
  - unfold sem_hseq.
    assert ((r' :: r) <> nil)as H by now auto.
    etransitivity; [ apply sem_seq_plus | ].
    etransitivity; [ apply plus_left; apply mul_vec_eq | ].
    etransitivity; [ apply plus_left; apply mul_right; apply (sem_seq_vec _ _ H) | ].
    etransitivity ; [ | symmetry; apply sem_seq_plus].
    etransitivity; [ | symmetry; apply plus_left; apply (sem_seq_vec _ _ H)].
    etransitivity; [ apply plus_left; apply mul_assoc | ].
    replace (time_pos r0 (existT (fun r1 : R => (0 <? r1) = true) (sum_vec (r' :: r)) (sum_vec_non_nil _ H))) with (time_pos (existT (fun r1 : R => (0 <? r1) = true) (sum_vec (r' :: r)) (sum_vec_non_nil _ H)) r0); auto.
    apply Rpos_eq; destruct r0; simpl; nra.
  - unfold mul_vec; unfold vec.
    reflexivity.
  - unfold sem_hseq; fold (sem_hseq (T2 :: G)).
    apply max_left.
    assert ((r' :: r) <> nil)as H by now auto.
    etransitivity; [ apply sem_seq_plus | ].
    etransitivity; [ apply plus_left; apply mul_vec_eq | ].
    etransitivity; [ apply plus_left; apply mul_right; apply (sem_seq_vec _ _ H) | ].
    etransitivity ; [ | symmetry; apply sem_seq_plus].
    etransitivity; [ | symmetry; apply plus_left; apply (sem_seq_vec _ _ H)].
    etransitivity; [ apply plus_left; apply mul_assoc | ].
    replace (time_pos r0 (existT (fun r1 : R => (0 <? r1) = true) (sum_vec (r' :: r)) (sum_vec_non_nil _ H))) with (time_pos (existT (fun r1 : R => (0 <? r1) = true) (sum_vec (r' :: r)) (sum_vec_non_nil _ H)) r0); auto.
    apply Rpos_eq; destruct r0; simpl; nra.
Qed.

Lemma max_sound : forall G T A B r, sem_hseq ((vec r B ++ T) :: (vec r A ++ T) :: G) === sem_hseq ((vec r (A \/S B) ++ T) :: G).
Proof.
  intros [ | G T2] T A B [ | r0 r].
  - simpl.
    apply max_idempotence.
  - unfold sem_hseq.
    assert ((r0 :: r) <> nil)as H by now auto.
    etransitivity; [ apply max_left; apply sem_seq_plus | ].
    etransitivity; [ apply max_right; apply sem_seq_plus | ].
    etransitivity; [ | symmetry; apply sem_seq_plus].
    etransitivity; [ apply max_left; apply plus_left; apply (sem_seq_vec _ _ H) | ].
    etransitivity; [ apply max_right; apply plus_left; apply (sem_seq_vec _ _ H) | ].
    etransitivity; [ | symmetry ; apply plus_left; apply (sem_seq_vec _ _ H)].
    remember (existT (fun r1 : R => (0 <? r1) = true) (sum_vec (r0 :: r)) (sum_vec_non_nil _ H)) as sr.
    etransitivity; [ | apply plus_left; symmetry; apply mul_distri_max_pos].
    etransitivity; [ | symmetry; apply max_plus].
    apply commu_max.
  - unfold sem_hseq; fold (sem_hseq (G :: T2)).
    unfold vec; unfold app.
    etransitivity; [ apply asso_max | ].
    apply max_left; apply max_idempotence.
  - unfold sem_hseq; fold (sem_hseq (G :: T2)).
    etransitivity; [ apply asso_max | ].
    apply max_left.
    assert ((r0 :: r) <> nil)as H by now auto.
    etransitivity; [ apply max_left; apply sem_seq_plus | ].
    etransitivity; [ apply max_right; apply sem_seq_plus | ].
    etransitivity; [ | symmetry; apply sem_seq_plus].
    etransitivity; [ apply max_left; apply plus_left; apply (sem_seq_vec _ _ H) | ].
    etransitivity; [ apply max_right; apply plus_left; apply (sem_seq_vec _ _ H) | ].
    etransitivity; [ | symmetry ; apply plus_left; apply (sem_seq_vec _ _ H)].
    remember (existT (fun r1 : R => (0 <? r1) = true) (sum_vec (r0 :: r)) (sum_vec_non_nil _ H)) as sr.
    etransitivity; [ | apply plus_left; symmetry; apply mul_distri_max_pos].
    etransitivity; [ | symmetry; apply max_plus].
    apply commu_max.
Qed.

Lemma min_sound : forall G T A  B r, sem_hseq ((vec r A ++ T) :: G) /\S sem_hseq ((vec r B ++ T) :: G) === sem_hseq ((vec r (A /\S B) ++ T) :: G).
  intros [ | T2 G] T A B [ | r0 r].
  - simpl.
    apply leq_refl.
  - unfold sem_hseq.
    assert ((r0 :: r) <> nil)as H by now auto.
    etransitivity; [ apply min_left; apply sem_seq_plus | ].
    etransitivity; [ apply min_left; apply plus_left; apply (sem_seq_vec _ _ H) | ].
    etransitivity; [ apply min_right; apply sem_seq_plus | ].
    etransitivity; [ apply min_right; apply plus_left; apply (sem_seq_vec _ _ H) | ].
    etransitivity; [ | symmetry; apply sem_seq_plus ].
    etransitivity; [ | symmetry; apply plus_left; apply (sem_seq_vec _ _ H) ].
    remember (existT (fun r1 : R => (0 <? r1) = true) (sum_vec (r0 :: r)) (sum_vec_non_nil _ H)) as sr.
    etransitivity; [ | apply plus_left;symmetry; apply mul_distri_min_pos].
    symmetry; apply min_plus.
  - unfold sem_hseq; fold (sem_hseq (T2 :: G)).
    unfold vec.
    apply leq_refl.
  - unfold sem_hseq; fold (sem_hseq (T2 :: G)).
    etransitivity; [ symmetry; apply max_distri_min | ].
    apply max_left.
    assert ((r0 :: r) <> nil)as H by now auto.
    etransitivity; [ apply min_left; apply sem_seq_plus | ].
    etransitivity; [ apply min_left; apply plus_left; apply (sem_seq_vec _ _ H) | ].
    etransitivity; [ apply min_right; apply sem_seq_plus | ].
    etransitivity; [ apply min_right; apply plus_left; apply (sem_seq_vec _ _ H) | ].
    etransitivity; [ | symmetry; apply sem_seq_plus ].
    etransitivity; [ | symmetry; apply plus_left; apply (sem_seq_vec _ _ H) ].
    remember (existT (fun r1 : R => (0 <? r1) = true) (sum_vec (r0 :: r)) (sum_vec_non_nil _ H)) as sr.
    etransitivity; [ | apply plus_left;symmetry; apply mul_distri_min_pos].
    symmetry; apply min_plus.
Qed.

(** ** HR is sound *)
Lemma hr_sound b : forall G, HR b G -> RS_zero <== sem_hseq G.
Proof with try assumption.
  intros G pi.
  induction pi.
  - apply leq_refl.
  - apply W_sound ; [now apply (@HR_not_empty b) | ]...
  - eapply leq_cong_r; [ symmetry; apply C_sound | ].
    apply IHpi.
  - now apply S_sound.
  - now apply M_sound.
  - now apply T_sound with r.
  - change (RS_covar n) with (-S (RS_var n)); eapply leq_cong_r; [ symmetry; apply ext_ID_sound | ]; try assumption.
  - eapply leq_cong_r; [ symmetry; apply Z_sound | ]; try assumption.
  - eapply leq_cong_r; [ symmetry; apply plus_sound | ]; try assumption.
  - eapply leq_cong_r; [ symmetry; apply mul_sound | ]; try assumption.
  - eapply leq_cong_r; [ symmetry; apply max_sound | ]; try assumption.
  - eapply leq_cong_r; [ symmetry; apply min_sound | ].
    now apply leq_min.
  - destruct G.
    + simpl in *; eapply leq_cong_r; [ symmetry; apply (sem_seq_permutation _ _ p)| ]; try assumption.
    + unfold sem_hseq in *; fold (sem_hseq (l :: G)) in *.
      eapply leq_cong_r; [ symmetry; apply max_left; apply (sem_seq_permutation _ _ p) | ]; try assumption.
  - eapply leq_cong_r; [ symmetry; apply (sem_hseq_permutation _ _ p) | ]; try assumption.
  - eapply leq_cong_r; [ apply ext_ID_sound | ]; try eassumption.
Qed.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult lv0 lv1) (mult lv2 lv0)).
Admitted.
QuickChick conj3synthconj2.


Require Extraction.

Require Import List.
Require Import Arith.
Require Import Nat.

Open Scope type_scope.
Open Scope list_scope.
Open Scope nat_scope.

(* STACK *)

Definition push {T:Type} (s: list T) a := a :: s.

Definition pop {T:Type} (s: list T) : list T * option T :=
    match s with
    | a :: s' => (s', Some a)
    | _ => (s, None)
    end.

Variable swap : forall {T:Type}, list T -> nat -> option (list T).

(* generate code *)
Local Load rules.

Inductive error : Set :=
    | OutOfBounds
    | OutOfGas
    | OutOfStack
    | OutOfCode
    | OutOfData
    | InvalidOpcode
.

(* MEMORY *)
Inductive memory_value : Set :=
    | Item8 : u256 -> memory_value
    | Item256 : u256 -> memory_value
.

Definition memory : Type := u256 -> option memory_value.

Definition empty_mem : memory := fun _ => None.

Definition update_mem_val (m:memory) (index:u256) (val:option memory_value) : memory :=
    fun i => match (u256_eqb i index) with
    | true => val
    | false => (m i)
    end.

Inductive return_type : Set :=
    | Normal : u256 -> return_type
    | Create : u256 -> return_type
    | Revert : return_type
.

Inductive vm_status : Set :=
    | Running : vm_status
    | Error   : error -> vm_status
    | Finish  : return_type -> vm_status
.

Inductive opcode : Set :=
    | STOP          : opcode
    | ADD           : opcode
    | MUL           : opcode
    | SUB           : opcode
    | DIV           : opcode
    | SDIV          : opcode
    | MOD           : opcode
    | SMOD          : opcode
    | ADDMOD        : opcode
    | MULMOD        : opcode
    | EXP           : opcode
    | SIGNEXTEND    : opcode
    | LT            : opcode
    | GT            : opcode
    | SLT           : opcode
    | SGT           : opcode
    | EQ            : opcode
    | ISZERO        : opcode
    | CALLVALUE     : opcode
    | CALLDATALOAD  : opcode
    | MLOAD         : opcode
    | MSTORE        : opcode
    | MSTORE8       : opcode
    | SLOAD         : opcode
    | SSTORE        : opcode
    | JUMP          : opcode
    | JUMPI         : opcode
    | PC            : opcode
    | MSIZE         : opcode
    | GAS           : opcode
    | JUMPDEST      : opcode
    | RETURN        : opcode
    | POP           : opcode
    | PUSH          : u256 -> opcode
    | DUP           : nat -> opcode
    | SWAP          : nat -> opcode
    | INVALID       : nat -> opcode
    (* TODO lots of things *)
    .

Definition gas_of op : nat :=
    let raw_gas := match op with
    | PUSH _    => 3
    | POP       => 2
    | _         => 1
    end
    in
    (raw_gas - 1)
.

Record state := mkState {
    stack   : list u256;
    mem     : memory;

    (* slightly different from the original form *)
    opcodes : list opcode;
    jumpmap : u256 -> nat;

    pc      : nat;
    status  : vm_status;
}.

Definition update_stack  s st := mkState st s.(mem) s.(opcodes) s.(jumpmap) s.(pc) s.(status).
Definition update_mem    s m  := mkState s.(stack) m s.(opcodes) s.(jumpmap) s.(pc) s.(status).
Definition update_pc     s i  := mkState s.(stack) s.(mem) s.(opcodes) s.(jumpmap) i s.(status).
Definition update_status s st := mkState s.(stack) s.(mem) s.(opcodes) s.(jumpmap) s.(pc) st.

Definition inc_pc        s    := update_pc s (s.(pc) + 1).

Definition get_opcode st :=
    match st with
    | mkState _ _ ops _ pc _ => nth pc ops (INVALID O)
    end.

(* avoid ambiguration on operators *)
Close Scope type_scope.

Definition interp : state -> state := fun st =>
    let op := get_opcode st in
    match op with
    | STOP          => update_status st (Finish (Normal (u256_of_nat 0)))
    | ADD           => let (s', a)  := (pop st.(stack)) in
                       let (s'', b) := (pop s') in
                       inc_pc
                       match a, b with
                       | Some a', Some b' => update_stack st (push s'' (u256_add a' b'))
                       | _, _ => update_status st (Error OutOfStack)
                       end
    | MUL           => let (s', a)  := (pop st.(stack)) in
                       let (s'', b) := (pop s') in
                       inc_pc
                       match a, b with
                       | Some a', Some b' => update_stack st (push s'' (u256_mul a' b'))
                       | _, _ => update_status st (Error OutOfStack)
                       end
    | SUB           => let (s', a)  := (pop st.(stack)) in
                       let (s'', b) := (pop s') in
                       inc_pc
                       match a, b with
                       | Some a', Some b' => update_stack st (push s'' (u256_sub a' b'))
                       | _, _ => update_status st (Error OutOfStack)
                       end
    | DIV           => let (s', a)  := (pop st.(stack)) in
                       let (s'', b) := (pop s') in
                       inc_pc
                       match a, b with
                       | Some a', Some b' => update_stack st (push s'' (u256_div a' b'))
                       | _, _ => update_status st (Error OutOfStack)
                       end
    | EXP           =>  let (s', a)   := (pop st.(stack)) in
                        let (s'', b) := (pop s') in
                        inc_pc
                        match a, b with
                        | Some a', Some b' => (update_stack st (push s'' (u256_pow a' b')))
                        | _, _ => update_status st (Error OutOfStack)
                        end
    | EQ            =>  let (s', a)  := (pop st.(stack)) in
                        let (s'', b) := (pop s') in
                        inc_pc
                        match a, b with
                        | Some a', Some b' => update_stack st (push s'' (if u256_eqb a' b' then (u256_of_nat 1) else (u256_of_nat 0)))
                        | _, _ => update_status st (Error OutOfStack)
                        end
    | ISZERO        =>  let (s', _a) := (pop st.(stack)) in
                        inc_pc
                        match _a with
                        | Some a  => update_stack st (push s' (if (u256_eqb a (u256_of_nat 0)) then (u256_of_nat 1) else (u256_of_nat 0)))
                        | None    => update_status st (Error OutOfStack)
                        end
                        (* FIXME *)
    | LT            =>  let (s', a)  := (pop st.(stack)) in
                        let (s'', b) := (pop s') in
                        inc_pc
                        match a, b with
                        | Some a', Some b' => update_stack st (push s'' (if u256_lt a' b' then (u256_of_nat 1) else (u256_of_nat 0)))
                        | _, _ => update_status st (Error OutOfStack)
                        end
    | CALLVALUE     =>  inc_pc (update_stack st (push st.(stack) u2560))
    | CALLDATALOAD  =>  let (s', _offset) := (pop st.(stack)) in
                        inc_pc
                        match _offset with
                            (* FIXME *)
                        | Some offset   => update_stack st (push s' (u256_of_nat 1))
                        | None          => update_status st (Error OutOfStack)
                        end
    | POP           =>  let (s', a) := (pop st.(stack)) in
                        inc_pc
                        match a with
                        | Some _  => update_stack st s'
                        | None    => update_status st (Error OutOfStack)
                        end
    | JUMP          =>  let (s', _dest) := (pop st.(stack)) in
                        match _dest with
                        | Some dest => update_pc (update_stack st s') (st.(jumpmap) dest)
                        | None      => update_status st (Error OutOfStack)
                        end
    | JUMPI         =>  let (s', _dest) := (pop st.(stack)) in
                        let (s'', _cond) := (pop s') in
                        match _dest, _cond with
                        | Some dest, Some cond =>
                            if (u256_eqb cond u2560) then
                                inc_pc (update_stack st s'')
                            else
                                update_pc st (st.(jumpmap) dest)
                        | _, _ => update_status st (Error OutOfStack)
                        end
    | JUMPDEST      =>  inc_pc st
    | PUSH a        =>  inc_pc (update_stack st (push st.(stack) a))
    | DUP i         =>  let _a := (nth_error st.(stack) (i - 1)) in
                        inc_pc
                        match _a with
                        | Some a  => update_stack st (push st.(stack) a)
                        | None    => update_status st (Error OutOfStack)
                        end
    | SWAP i        =>  let _s := swap st.(stack) i in
                        inc_pc
                        match _s with
                        | Some s => update_stack st s
                        | None => update_status st (Error OutOfStack)
                        end
    | MSTORE        =>  let (s', _offset) := (pop st.(stack)) in
                        let (s'', _val) := (pop s') in
                        inc_pc
                        match _offset, _val with
                        | Some offset, Some val =>
                            let m' := update_mem_val st.(mem) offset (Some (Item256 val)) in
                            update_mem (update_stack st s'') m'
                        | _, _ => update_status st (Error OutOfStack)
                        end
    | MSTORE8       =>  let (s', _offset) := (pop st.(stack)) in
                        let (s'', _val) := (pop s') in
                        inc_pc
                        match _offset, _val with
                        | Some offset, Some val =>
                            let m' := update_mem_val st.(mem) offset (Some (Item8 val)) in
                            update_mem (update_stack st s'') m'
                        | _, _ => update_status st (Error OutOfStack)
                        end
    | _                 => update_status st (Error InvalidOpcode)
    end.

Fixpoint iterate (gas:nat) (_s:state) (hook:state -> state) {struct gas} : state :=
    let s := hook _s in
    let op := get_opcode s in
    match gas with
    | O => update_status s (Error OutOfGas)
    | S gas =>
        let s' := interp s in
        match s'.(status) with
        | Running => iterate (gas - (gas_of op)) s' hook
        | _ => s'
        end
    end.

Definition run (ops: list opcode) (gas: nat) (jmap: u256 -> nat) (hook: state -> state): vm_status :=
    let init := mkState nil empty_mem ops jmap 0 Running in
    let result_state := iterate gas init hook in
    result_state.(status).

(* from here we start working on the theorems *)

Open Scope type_scope.

(* 1. proofs of correctness of contract code *)
Inductive is_successor s s' : Prop :=
    | DirectSuccessor   : (interp s = s' /\ s.(status) = Running) -> is_successor s s'
    | IndirectSuccessor : (s.(status) = Running /\ exists s'', interp s = s'' /\ is_successor s'' s') -> is_successor s s'
.

(* 2. proofs of optimization *)
Variable is_equivalent : list opcode -> list opcode -> Prop.

(* op1; op2 ...; PUSH a; POP; sop1; ... sopn *)

Theorem trivial_opt_push_pop:
    forall opprefix opsuffix a,
        is_equivalent
            (opprefix ++ opsuffix)
            (opprefix ++ (PUSH a) :: POP :: opsuffix)
.
Proof.
Admitted.

Extraction "evm.ml" run.


(* File reduced by coq-bug-finder from original input, then from 13191 lines to 1315 lines, then from 1601 lines to 595 lines, then from 585 lines to 379 lines *)
(* coqc version 8.5beta1 (March 2015) compiled on Mar 3 2015 3:50:31 with OCaml 4.01.0
   coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (ac62cda8a4f488b94033b108c37556877232137a) *)

Axiom admit : False.
Ltac admit := exfalso; exact admit.

Global Set Primitive Projections.

Notation projT1 := proj1_sig (only parsing).
Notation projT2 := proj2_sig (only parsing).

Definition relation (A : Type) := A -> A -> Type.

Class Reflexive {A} (R : relation A) :=
  reflexivity : forall x : A, R x x.

Class Symmetric {A} (R : relation A) :=
  symmetry : forall x y, R x y -> R y x.

Notation idmap := (fun x => x).
Delimit Scope function_scope with function.
Delimit Scope path_scope with path.
Delimit Scope fibration_scope with fibration.
Open Scope path_scope.
Open Scope fibration_scope.
Open Scope function_scope.

Notation pr1 := projT1.
Notation pr2 := projT2.

Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.
Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope.

Notation compose := (fun g f x => g (f x)).

Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : function_scope.

Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Arguments idpath {A a} , [A] a.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.

Definition inverse {A : Type} {x y : A} (p : x = y) : y = x
  := match p with idpath => idpath end.

Global Instance symmetric_paths {A} : Symmetric (@paths A) | 0 := @inverse A.

Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z :=
  match p, q with idpath, idpath => idpath end.

Notation "1" := idpath : path_scope.

Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope.

Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope.

Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
  match p with idpath => u end.

Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
  := match p with idpath => idpath end.

Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x)
  := forall x:A, f x = g x.

Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.

Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
: f == g
  := fun x => match h with idpath => 1 end.

Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
  forall x : A, r (s x) = x.

Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
                                               equiv_inv : B -> A ;
                                               eisretr : Sect equiv_inv f;
                                               eissect : Sect f equiv_inv;
                                               eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
                                             }.

Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : function_scope.

Class Contr_internal (A : Type) := BuildContr {
                                       center : A ;
                                       contr : (forall y : A, center = y)
                                     }.

Inductive trunc_index : Type :=
| minus_two : trunc_index
| trunc_S : trunc_index -> trunc_index.

Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope.
Local Open Scope trunc_scope.
Notation "-2" := minus_two (at level 0) : trunc_scope.
Notation "-1" := (-2.+1) (at level 0) : trunc_scope.
Notation "0" := (-1.+1) : trunc_scope.

Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
  match n with
    | -2 => Contr_internal A
    | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y)
  end.

Class IsTrunc (n : trunc_index) (A : Type) : Type :=
  Trunc_is_trunc : IsTrunc_internal n A.

Tactic Notation "transparent" "assert" "(" ident(name) ":" constr(type) ")" :=
  unshelve refine (let __transparent_assert_hypothesis := (_ : type) in _);
  [
      | (
        let H := match goal with H := _ |- _ => constr:(H) end in
        rename H into name) ].

Definition transport_idmap_ap A (P : A -> Type) x y (p : x = y) (u : P x)
: transport P p u = transport idmap (ap P p) u
  := match p with idpath => idpath end.

Section Adjointify.

  Context {A B : Type} (f : A -> B) (g : B -> A).
  Context (isretr : Sect g f) (issect : Sect f g).

  Let issect' := fun x =>
                   ap g (ap f (issect x)^)  @  ap g (isretr (f x))  @  issect x.

  Let is_adjoint' (a : A) : isretr (f a) = ap f (issect' a).
    admit.
  Defined.

  Definition isequiv_adjointify : IsEquiv f
    := BuildIsEquiv A B f g isretr issect' is_adjoint'.

End Adjointify.

Record TruncType (n : trunc_index) := BuildTruncType {
                                          trunctype_type : Type ;
                                          istrunc_trunctype_type : IsTrunc n trunctype_type
                                        }.
Arguments trunctype_type {_} _.

Coercion trunctype_type : TruncType >-> Sortclass.

Notation "n -Type" := (TruncType n) (at level 1) : type_scope.
Notation hSet := 0-Type.

Module Export Category.
  Module Export Core.
    Set Implicit Arguments.

    Delimit Scope morphism_scope with morphism.
    Delimit Scope category_scope with category.
    Delimit Scope object_scope with object.

    Record PreCategory :=
      Build_PreCategory' {
          object :> Type;
          morphism : object -> object -> Type;

          identity : forall x, morphism x x;
          compose : forall s d d',
                      morphism d d'
                      -> morphism s d
                      -> morphism s d'
          where "f 'o' g" := (compose f g);

          associativity : forall x1 x2 x3 x4
                                 (m1 : morphism x1 x2)
                                 (m2 : morphism x2 x3)
                                 (m3 : morphism x3 x4),
                            (m3 o m2) o m1 = m3 o (m2 o m1);

          associativity_sym : forall x1 x2 x3 x4
                                     (m1 : morphism x1 x2)
                                     (m2 : morphism x2 x3)
                                     (m3 : morphism x3 x4),
                                m3 o (m2 o m1) = (m3 o m2) o m1;

          left_identity : forall a b (f : morphism a b), identity b o f = f;
          right_identity : forall a b (f : morphism a b), f o identity a = f;

          identity_identity : forall x, identity x o identity x = identity x
        }.
    Arguments identity {!C%category} / x%object : rename.
    Arguments compose {!C%category} / {s d d'}%object (m1 m2)%morphism : rename.

    Definition Build_PreCategory
               object morphism compose identity
               associativity left_identity right_identity
      := @Build_PreCategory'
           object
           morphism
           compose
           identity
           associativity
           (fun _ _ _ _ _ _ _ => symmetry _ _ (associativity _ _ _ _ _ _ _))
           left_identity
           right_identity
           (fun _ => left_identity _ _ _).

    Module Export CategoryCoreNotations.
      Infix "o" := compose : morphism_scope.
      Notation "1" := (identity _) : morphism_scope.
    End CategoryCoreNotations.

  End Core.

End Category.
Module Export Core.
  Set Implicit Arguments.

  Delimit Scope functor_scope with functor.

  Local Open Scope morphism_scope.

  Section Functor.
    Variables C D : PreCategory.

    Record Functor :=
      {
        object_of :> C -> D;
        morphism_of : forall s d, morphism C s d
                                  -> morphism D (object_of s) (object_of d);
        composition_of : forall s d d'
                                (m1 : morphism C s d) (m2: morphism C d d'),
                           morphism_of _ _ (m2 o m1)
                           = (morphism_of _ _ m2) o (morphism_of _ _ m1);
        identity_of : forall x, morphism_of _ _ (identity x)
                                = identity (object_of x)
      }.
  End Functor.
  Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.

End Core.
Module Export Morphisms.
  Set Implicit Arguments.

  Local Open Scope category_scope.
  Local Open Scope morphism_scope.

  Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) :=
    {
      morphism_inverse : morphism C d s;
      left_inverse : morphism_inverse o m = identity _;
      right_inverse : m o morphism_inverse = identity _
    }.

  Class Isomorphic {C : PreCategory} s d :=
    {
      morphism_isomorphic :> morphism C s d;
      isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic
    }.

  Coercion morphism_isomorphic : Isomorphic >-> morphism.

  Local Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope.

  Section iso_equiv_relation.
    Variable C : PreCategory.

    Global Instance isisomorphism_identity (x : C) : IsIsomorphism (identity x)
      := {| morphism_inverse := identity x;
            left_inverse := left_identity C x x (identity x);
            right_inverse := right_identity C x x (identity x) |}.

    Global Instance isomorphic_refl : Reflexive (@Isomorphic C)
      := fun x : C => {| morphism_isomorphic := identity x |}.

    Definition idtoiso (x y : C) (H : x = y) : Isomorphic x y
      := match H in (_ = y0) return (x <~=~> y0) with
           | 1%path => reflexivity x
         end.
  End iso_equiv_relation.

End Morphisms.

Notation IsCategory C := (forall s d : object C, IsEquiv (@idtoiso C s d)).

Notation isotoid C s d := (@equiv_inv _ _ (@idtoiso C s d) _).

Notation cat_of obj :=
  (@Build_PreCategory obj
                      (fun x y => x -> y)
                      (fun _ x => x)
                      (fun _ _ _ f g => f o g)%core
                      (fun _ _ _ _ _ _ _ => idpath)
                      (fun _ _ _ => idpath)
                      (fun _ _ _ => idpath)
  ).
Definition set_cat : PreCategory := cat_of hSet.
Set Implicit Arguments.

Local Open Scope morphism_scope.

Section Grothendieck.
  Variable C : PreCategory.
  Variable F : Functor C set_cat.

  Record Pair :=
    {
      c : C;
      x : F c
    }.

  Local Notation Gmorphism s d :=
    { f : morphism C s.(c) d.(c)
    | morphism_of F f s.(x) = d.(x) }.

  Definition identity_H s
    := apD10 (identity_of F s.(c)) s.(x).

  Definition Gidentity s : Gmorphism s s.
  Proof.
    exists 1.
    apply identity_H.
  Defined.

  Definition Gcategory : PreCategory.
  Proof.
    unshelve refine (@Build_PreCategory
              Pair
              (fun s d => Gmorphism s d)
              Gidentity
              _
              _
              _
              _); admit.
  Defined.
End Grothendieck.

Lemma isotoid_1 {C} `{IsCategory C} {x : C} {H : IsIsomorphism (identity x)}
: isotoid C x x {| morphism_isomorphic := (identity x) ; isisomorphism_isomorphic := H |}
  = idpath.
  admit.
Defined.
Generalizable All Variables.

Section Grothendieck2.
  Context `{IsCategory C}.
  Variable F : Functor C set_cat.

  Instance iscategory_grothendieck_toset : IsCategory (Gcategory F).
  Proof.
    intros s d.
    unshelve refine (isequiv_adjointify _ _ _ _).
    {
      intro m.
      transparent assert (H' : (s.(c) = d.(c))).
      {
        apply (idtoiso C (x := s.(c)) (y := d.(c)))^-1%function.
        exists (m : morphism _ _ _).1.
        admit.

      }
      {
        transitivity {| x := transport (fun x => F x) H' s.(x) |}.
        admit.

        {
          change d with {| c := d.(c) ; x := d.(x) |}; simpl.
          apply ap.
          subst H'.
          simpl.
          refine (transport_idmap_ap _ (fun x => F x : Type) _ _ _ _ @ _ @ (m : morphism _ _ _).2).
          change (fun x => F x : Type) with (trunctype_type o object_of F)%function.
          admit.
        }
      }
    }
    {
      admit.
    }

    {
      intro x.
      hnf in s, d.
      destruct x.
      simpl.
      erewrite @isotoid_1.


Require Import FP.Structures.Monad.
Require Import FP.Structures.EqvEnv.
Require Import FP.Structures.FUnit.
Require Import FP.Structures.Proxy.
Require Import FP.Data.Function.
Require Import FP.Relations.Setoid.

Import MonadNotation.
Import FunctionNotation.

Class MState (S:Type) (m:Type->Type) : Type :=
  { get : m S
  ; put : S -> m unit
  }.

Section MonadState.
  Context {m} {Monad_:Monad m} {S} {MState_:MState S m}.
  Definition modify (f:S -> S) : m unit :=
    x <- get ;;
    put $ f x.
End MonadState.

Section MonadStateWF.
  Context {S:Type} {m:Type->Type}.
  Context {Monad_:Monad m} {MState_:MState S m}.
  Context {EqvEnv_:EqvEnv}.
  Context {EqvEnvLogical_:EqvEnvLogical}.
  Context {PE_R_E:Px (env_PER S)}.
  Context {PE_R_E':Px (env_PER_WF S)}.
  Context {PE_R_Eu:Px (env_PER unit)}.
  Context {PE_R_Eu':Px (env_PER_WF unit)}.
  Context {PE_R_t:forall {A} {aER:Px (env_PER A)}, Px (env_PER (m A))}.
  Context {PE_R_t' :
    forall {A} {aER:Px (env_PER A)} {aER':Px (env_PER_WF A)},
    Px (env_PER_WF (m A))}.

  Class MonadStateWF :=
    { mget_after_mput :
        forall
          (s:S) (sP:Proper env_eqv s),
            env_eqv
            (seq (put s) get)
            (seq (put s) (ret s))
    ; mput_after_mput :
        forall
          (s1:S) (s1P:Proper env_eqv s1)
          (s2:S) (s2P:Proper env_eqv s2),
            env_eqv
            (seq (put s1) (put s2))
            (put s2)
    }.
End MonadStateWF.
(*
Require Import FP.Data.Function.
Require Import FP.Structures.Monad.
Require Import FP.Structures.Injection.

Import FunctionNotation.
Import MonadNotation.

Section iso_MonadState.
  Variable (n:Type -> Type).
  Context {m} {B:HasFunctorBijection m n} {S} {nMR:MonadState S n}.

  Definition iso_MonadState_get : m S := ffrom get.
  Definition iso_MonadState_put (s:S) : m unit := ffrom $ put s.
  Definition iso_MonadState : MonadState S m :=
    {| get := @iso_MonadState_get
     ; put := @iso_MonadState_put
    |}.
End iso_MonadState.
*)


(* ** Construction of standard models *)
From Undecidability.FOL Require Import Syntax.Facts Semantics.Tarski.FullFacts ZF.
From Undecidability.FOL.Sets Require Import ZF binZF.
From Undecidability.FOL.Sets.Models Require Import Aczel Aczel_CE Aczel_TD.
From Coq Require Import Lia.

(* ** ZF-Models *)

Declare Scope sem.
Open Scope sem.

Arguments Vector.nil {_}, _.
Arguments Vector.cons {_} _ {_} _, _ _ _ _.

Notation "x ∈ y" := (@i_atom _ _ _ _ elem (Vector.cons x (Vector.cons y Vector.nil))) (at level 35) : sem.
Notation "x ≡ y" := (@i_atom _ _ _ _ equal (Vector.cons x (Vector.cons y Vector.nil))) (at level 35) : sem.
Notation "x ⊆ y" := (forall z, z ∈ x -> z ∈ y) (at level 34) : sem.

Notation "∅" := (@i_func ZF_func_sig ZF_pred_sig _ _ ZFSignature.eset Vector.nil) : sem.
Notation "'ω'" := (@i_func ZF_func_sig _ _ _ ZFSignature.om Vector.nil) : sem.
Notation "{ x ; y }" := (@i_func ZF_func_sig _ _ _ ZFSignature.pair (Vector.cons x (Vector.cons y Vector.nil))) (at level 31) : sem.
Notation "⋃ x" := (@i_func ZF_func_sig _ _ _ ZFSignature.union (Vector.cons x Vector.nil)) (at level 32) : sem.
Notation "'PP' x" := (@i_func ZF_func_sig _ _ _ ZFSignature.power (Vector.cons x Vector.nil)) (at level 31) : sem.

Notation "x ∪ y" := (⋃ {x; y}) (at level 32) : sem.
Notation "'σ' x" := (x ∪ {x; x}) (at level 32) : sem.

(* ** Internal axioms *)

Section ZF.

  Context { V : Type }.
  Context { M : interp V }.

  Hypothesis M_ZF : forall rho, rho ⊫ ZF'.
  Hypothesis VIEQ : extensional M.

  Lemma M_ext x y :
    x ⊆ y -> y ⊆ x -> x = y.
  Proof using VIEQ M_ZF.
    rewrite <- VIEQ. apply (@M_ZF (fun _ => ∅) ax_ext). cbn; tauto.
  Qed.

  Lemma M_eset x :
    ~ x ∈ ∅.
  Proof using VIEQ M_ZF.
    refine (@M_ZF (fun _ => ∅) ax_eset _ x). cbn; tauto.
  Qed.

  Lemma M_pair x y z :
    x ∈ {y; z} <-> x = y \/ x = z.
  Proof using VIEQ M_ZF.
    rewrite <- !VIEQ. apply (@M_ZF (fun _ => ∅) ax_pair). cbn; tauto.
  Qed.

  Lemma M_union x y :
    x ∈ ⋃ y <-> exists z, z ∈ y /\ x ∈ z.
  Proof using M_ZF.
    apply (@M_ZF (fun _ => ∅) ax_union). cbn; tauto.
  Qed.

  Lemma M_power x y :
    x ∈ PP y <-> x ⊆ y.
  Proof using M_ZF.
    apply (@M_ZF (fun _ => ∅) ax_power). cbn; tauto.
  Qed.

  Definition M_inductive x :=
    ∅ ∈ x /\ forall y, y ∈ x -> σ y ∈ x.

  Lemma M_om1 :
    M_inductive ω.
  Proof using M_ZF.
    apply (@M_ZF (fun _ => ∅) ax_om1). cbn; tauto.
  Qed.

  Lemma M_om2 x :
    M_inductive x -> ω ⊆ x.
  Proof using M_ZF.
    apply (@M_ZF (fun _ => ∅) ax_om2). cbn; tauto.
  Qed.

  Definition agrees_fun phi (P : V -> Prop) :=
    forall x rho, P x <-> (x.:rho) ⊨ phi.

  Definition def_pred (P : V -> Prop) :=
    exists phi rho, forall d, P d <-> (d.:rho) ⊨ phi.

  Lemma M_sep P x :
    (forall phi rho, rho ⊨ ax_sep phi) -> def_pred P -> exists y, forall z, z ∈ y <-> z ∈ x /\ P z.
  Proof.
    cbn. intros H [phi [rho Hp]].
    destruct (H phi rho x) as [y H']; clear H.
    exists y. intros z. specialize (H' z). setoid_rewrite sat_comp in H'.
    rewrite (sat_ext _ _ (xi:=z.:rho)) in H'; try now intros [].
    firstorder.
  Qed.

  Definition M_is_rep R x y :=
    forall v, v ∈ y <-> exists u, u ∈ x /\ R u v.

  Lemma is_rep_unique R x y y' :
    M_is_rep R x y -> M_is_rep R x y' -> y = y'.
  Proof using VIEQ M_ZF.
    intros H1 H2. apply M_ext; intros v.
    - intros H % H1. now apply H2.
    - intros H % H2. now apply H1.
  Qed.

  Definition functional (R : V -> V -> Prop) :=
    forall x y y', R x y -> R x y' -> y = y'.

  Definition def_rel (R : V -> V -> Prop) :=
    exists phi rho, forall x y, R x y <-> (x.:y.:rho) ⊨ phi.

  Lemma M_rep R x :
    (forall phi rho, rho ⊨ ax_rep phi) -> def_rel R -> functional R -> exists y, M_is_rep R x y.
  Proof using VIEQ.
    intros H1 [phi [rho Hp]]. intros H2.
    cbn in H1. specialize (H1 phi rho). destruct H1 with x as [y Hy].
    - intros a b b'. setoid_rewrite sat_comp.
      erewrite sat_ext. rewrite <- (Hp a b). 2: now intros [|[]].
      erewrite sat_ext. rewrite <- (Hp a b'). 2: now intros [|[]].
      rewrite VIEQ. apply H2.
    - exists y. intros v. split.
      + intros [u[U1 U2]] % Hy. exists u. split; trivial.
        setoid_rewrite sat_comp in U2. rewrite sat_ext in U2. rewrite (Hp u v). apply U2. now intros [|[]]; cbn.
      + intros [u[U1 U2]]. apply Hy. exists u. split; trivial.
        setoid_rewrite sat_comp. rewrite sat_ext. rewrite <- (Hp u v). apply U2. now intros [|[]]; cbn.
  Qed.

  (* ** Basic ZF *)

  Definition M_sing x :=
    {x; x}.

  Definition M_opair x y := ({{x; x}; {x; y}}).

  Lemma binunion_el x y z :
    x ∈ y ∪ z <-> x ∈ y \/ x ∈ z.
  Proof using VIEQ M_ZF.
    split.
    - intros [u [H1 H2]] % M_union.
      apply M_pair in H1 as [->| ->]; auto.
    - intros [H|H].
      + apply M_union. exists y. rewrite M_pair. auto.
      + apply M_union. exists z. rewrite M_pair. auto.
  Qed.

  Lemma sing_el x y :
    x ∈ M_sing y <-> x = y.
  Proof using VIEQ M_ZF.
    split.
    - now intros [H|H] % M_pair.
    - intros ->. apply M_pair. now left.
  Qed.

  Lemma M_pair1 x y :
    x ∈ {x; y}.
  Proof using VIEQ M_ZF.
    apply M_pair. now left.
  Qed.

  Lemma M_pair2 x y :
    y ∈ {x; y}.
  Proof using VIEQ M_ZF.
    apply M_pair. now right.
  Qed.

  Lemma sing_pair x y z :
    {x; x} = {y; z} -> x = y /\ x = z.
  Proof using VIEQ M_ZF.
    intros He. split.
    - assert (H : y ∈ {y; z}) by apply M_pair1.
      rewrite <- He in H. apply M_pair in H. intuition.
    - assert (H : z ∈ {y; z}) by apply M_pair2.
      rewrite <- He in H. apply M_pair in H. intuition.
  Qed.

  Lemma opair_inj1 x x' y y' :
    M_opair x y = M_opair x' y' -> x = x'.
  Proof using VIEQ M_ZF.
    intros He. assert (H : {x; x} ∈ M_opair x y) by apply M_pair1.
    rewrite He in H. apply M_pair in H as [H|H]; apply (sing_pair H).
  Qed.

  Lemma opair_inj2 x x' y y' :
    M_opair x y = M_opair x' y' -> y = y'.
  Proof using VIEQ M_ZF.
    intros He. assert (y = x' \/ y = y') as [->| ->]; trivial.
    - assert (H : {x; y} ∈ M_opair x y) by apply M_pair2.
      rewrite He in H. apply M_pair in H as [H|H].
      + symmetry in H. apply sing_pair in H. intuition.
      + assert (H' : y ∈ {x; y}) by apply M_pair2.
        rewrite H in H'. now apply M_pair in H'.
    - assert (x = x') as -> by now apply opair_inj1 in He.
      assert (H : {x'; y'} ∈ M_opair x' y') by apply M_pair2.
      rewrite <- He in H. apply M_pair in H as [H|H]; apply (sing_pair (eq_sym H)).
  Qed.

  Lemma opair_inj x x' y y' :
    M_opair x y = M_opair x' y' -> x = x' /\ y = y'.
  Proof using VIEQ M_ZF.
    intros H. split.
    - eapply opair_inj1; eassumption.
    - eapply opair_inj2; eassumption.
  Qed.

  Lemma sigma_el x y :
    x ∈ σ y <-> x ∈ y \/ x = y.
  Proof using VIEQ M_ZF.
    split.
    - intros [H|H] % binunion_el; auto.
      apply sing_el in H. now right.
    - intros [H| ->]; apply binunion_el; auto.
      right. now apply sing_el.
  Qed.

  Lemma sigma_eq x :
    x ∈ σ x.
  Proof using VIEQ M_ZF.
    apply sigma_el. now right.
  Qed.

  Lemma sigma_sub x :
    x ⊆ σ x.
  Proof using VIEQ M_ZF.
    intros y H. apply sigma_el. now left.
  Qed.

  Lemma binunion_eset x :
    x = ∅ ∪ x.
  Proof using VIEQ M_ZF.
    apply M_ext.
    - intros y H. apply binunion_el. now right.
    - intros y [H|H] % binunion_el.
      + now apply M_eset in H.
      + assumption.
  Qed.

  Lemma pair_com x y :
    {x; y} = {y; x}.
  Proof using VIEQ M_ZF.
    apply M_ext; intros z [->| ->] % M_pair; apply M_pair; auto.
  Qed.

  Lemma binunion_com x y :
    x ∪ y = y ∪ x.
  Proof using VIEQ M_ZF.
    now rewrite pair_com.
  Qed.

  Lemma binunionl a x y :
    a ∈ x -> a ∈ x ∪ y.
  Proof using VIEQ M_ZF.
    intros H. apply binunion_el. now left.
  Qed.

  Lemma binunionr a x y :
    a ∈ y -> a ∈ x ∪ y.
  Proof using VIEQ M_ZF.
    intros H. apply binunion_el. now right.
  Qed.

  Hint Resolve binunionl binunionr : core.

  Lemma binunion_assoc x y z :
    (x ∪ y) ∪ z = x ∪ (y ∪ z).
  Proof using VIEQ M_ZF.
    apply M_ext; intros a [H|H] % binunion_el; eauto.
    - apply binunion_el in H as [H|H]; eauto.
    - apply binunion_el in H as [H|H]; eauto.
  Qed.

  (* ** Numerals *)

  Fixpoint numeral n :=
    match n with
    | O => ∅
    | S n => σ (numeral n)
    end.

  Lemma numeral_omega n :
    numeral n ∈ ω.
  Proof using M_ZF.
    induction n; cbn; now apply M_om1.
  Qed.

  Definition trans x :=
    forall y, y ∈ x -> y ⊆ x.

  Lemma numeral_trans n :
    trans (numeral n).
  Proof using VIEQ M_ZF.
    induction n; cbn.
    - intros x H. now apply M_eset in H.
    - intros x [H| ->] % sigma_el; try apply sigma_sub.
      apply IHn in H. intuition eauto using sigma_sub.
  Qed.

  Lemma numeral_wf n :
    ~ numeral n ∈ numeral n.
  Proof using VIEQ M_ZF.
    induction n.
    - apply M_eset.
    - intros [H|H] % sigma_el; fold numeral in *.
      + apply IHn. eapply numeral_trans; eauto. apply sigma_eq.
      + assert (numeral n ∈ numeral (S n)) by apply sigma_eq.
        now rewrite H in H0.
  Qed.

  Lemma numeral_lt k l :
    k < l -> numeral k ∈ numeral l.
  Proof using VIEQ M_ZF.
    induction 1; cbn; apply sigma_el; auto.
  Qed.

  Lemma numeral_inj k l :
    numeral k = numeral l -> k = l.
  Proof using VIEQ M_ZF.
    intros Hk. assert (k = l \/ k < l \/ l < k) as [H|[H|H]] by lia; trivial.
    all: apply numeral_lt in H; rewrite Hk in H; now apply numeral_wf in H.
  Qed.

  Definition standard :=
    forall x, x ∈ ω -> exists n, x ≡ numeral n.

End ZF.

Arguments standard {_} _.

(* *** Extensional model of ZF using CE and TD *)

Section ZFM.

  Context { Delta : extensional_normaliser }.

  Instance SET_interp : interp SET.
  Proof.
    split; intros [].
    - intros _. exact Sempty.
    - intros v. exact (Supair (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (Sunion (Vector.hd v)).
    - intros v. exact (Spower (Vector.hd v)).
    - intros _. exact Som.
    - intros v. exact (IN (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (Vector.hd v = Vector.hd (Vector.tl v)).
  Defined.

  Lemma SET_ext :
    extensional SET_interp.
  Proof.
    intros x y. reflexivity.
  Qed.

  Lemma Anumeral_numeral n :
    NS (Anumeral n) = numeral n.
  Proof.
    induction n; trivial.
    cbn [numeral]. rewrite <- IHn.
    apply Aeq_NS_eq. cbn -[Anumeral].
    now rewrite <- !CR1.
  Qed.

  Lemma SET_standard :
    standard SET_interp.
  Proof.
    intros x. cbn. destruct x. unfold Som, NS, IN. cbn.
    rewrite <- (CR1 Aom). intros [n Hn]. exists n.
    rewrite <- Anumeral_numeral. now apply Aeq_p1_NS_eq.
  Qed.

  Lemma SET_ZF' rho :
    rho ⊫ ZF'.
  Proof.
    intros phi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]; cbn.
    - intros X Y H1 H2. now apply set_ext.
    - apply emptyE.
    - intros X Y Z. split; apply upairAx.
    - intros X Y. split; apply unionAx.
    - intros X Y. split; apply powerAx.
    - apply omAx1.
    - apply omAx2.
  Qed.

  Lemma SET_sep phi rho :
    rho ⊨ ax_sep phi.
  Proof.
    intros x. cbn.
    exists (Ssep (fun y => (y .: rho) ⊨ phi) x).
    intros y. rewrite sepAx.
    split; intros [H1 H2]; split; trivial.
    - setoid_rewrite sat_comp. eapply sat_ext; try apply H2. now intros [].
    - setoid_rewrite sat_comp in H2. eapply sat_ext; try apply H2. now intros [].
  Qed.

  Lemma SET_rep phi rho :
    rho ⊨ ax_rep phi.
  Proof.
    intros H x. cbn.
    exists (Srep (fun u v => (u .: (v .: rho)) ⊨ phi) x).
    intros y. rewrite repAx.
    - split; intros [z[H1 H2]]; exists z; split; trivial.
      + setoid_rewrite sat_comp. eapply sat_ext; try apply H2. now intros [|[]].
      + setoid_rewrite sat_comp in H2. eapply sat_ext; try apply H2. now intros [|[]].
    - intros a b b' H1 H2. apply (H a b b'); fold sat; eapply sat_comp, sat_ext.
      2: apply H1. 3: apply H2. all: intros [|[]]; reflexivity.
  Qed.

End ZFM.

Definition TD :=
  exists delta : (Acz -> Prop) -> Acz, forall P, (exists s : Acz, forall t : Acz, P t <-> Aeq t s) -> P (delta P).

Lemma TD_CE_normaliser :
  CE -> TD -> inhabited extensional_normaliser.
Proof.
  intros ce [delta H]. split. unshelve econstructor.
  - exact delta.
  - exact H.
  - intros P P' HP. now rewrite (ce _ _ HP).
  - intros s H1 H2. apply Aczel_CE.PI, ce.
Qed.

Lemma normaliser_model :
  CE -> TD -> exists V (M : interp V), extensional M /\ standard M /\ forall rho psi, ZF psi -> rho ⊨ psi.
Proof.
  intros H1 H2. assert (inhabited extensional_normaliser) as [H] by now apply TD_CE_normaliser.
  exists SET, SET_interp. split; try apply SET_ext.
  split; try apply SET_standard. intros rho psi [].
  - now apply SET_ZF'.
  - apply SET_sep.
  - apply SET_rep.
Qed.

Lemma normaliser_model_eq :
  CE -> TD -> exists V (M : interp V), extensional M /\ standard M /\ forall rho psi, ZFeq psi -> rho ⊨ psi.
Proof.
  intros H1 H2. assert (inhabited extensional_normaliser) as [H] by now apply TD_CE_normaliser.
  exists SET, SET_interp. split; try apply SET_ext.
  split; try apply SET_standard. intros rho psi [].
  - destruct H0 as [<-|[<-|[<-|[<-|H0]]]]; cbn; try congruence. now apply SET_ZF'.
  - apply SET_sep.
  - apply SET_rep.
Qed.

(* *** Extensional model of Z using CE *)

Section ZM.

  Hypothesis ce : CE.

  Instance SET_interp' : interp SET'.
  Proof using ce.
    split; intros [].
    - intros _. exact empty.
    - intros v. exact (upair ce (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (union ce (Vector.hd v)).
    - intros v. exact (power ce (Vector.hd v)).
    - intros _. exact om.
    - intros v. exact (ele (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (Vector.hd v = Vector.hd (Vector.tl v)).
  Defined.

  Lemma SET_ext' :
    extensional SET_interp'.
  Proof.
    intros x y. reflexivity.
  Qed.

  Lemma Anumeral_numeral' n :
    classof (Anumeral n) = numeral n.
  Proof.
    induction n.
    - reflexivity.
    - cbn [Anumeral]. rewrite <- (succ_eq ce).
      rewrite IHn. reflexivity.
  Qed.

  Lemma SET_standard' :
    standard SET_interp'.
  Proof.
    intros x. cbn. destruct (classof_ex ce x) as [s ->].
    intros [n Hn] % classof_ele. exists n.
    rewrite <- Anumeral_numeral'. now apply classof_eq.
  Qed.

  Lemma SET'_ZF' rho :
    rho ⊫ ZF'.
  Proof.
    intros phi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]; cbn.
    - intros X Y H1 H2. now apply Aczel_CE.set_ext.
    - now apply Aczel_CE.emptyE.
    - intros X Y Z. split; apply Aczel_CE.upairAx.
    - intros X Y. split; apply Aczel_CE.unionAx.
    - intros X Y. split; apply Aczel_CE.powerAx.
    - apply om_Ax1.
    - apply om_Ax2.
  Qed.

  Lemma SET_sep' phi rho :
    rho ⊨ ax_sep phi.
  Proof.
    intros x. cbn.
    exists (sep ce (fun y => (y .: rho) ⊨ phi) x).
    intros y. rewrite Aczel_CE.sepAx.
    split; intros [H1 H2]; split; trivial.
    - setoid_rewrite sat_comp. eapply sat_ext; try apply H2. now intros [].
    - setoid_rewrite sat_comp in H2. eapply sat_ext; try apply H2. now intros [].
  Qed.

End ZM.

Lemma extensionality_model :
  CE -> exists V (M : interp V), extensional M /\ standard M /\ forall rho phi, Z phi -> rho ⊨ phi.
Proof.
  intros ce. exists SET', (SET_interp' ce). split; try apply SET_ext'.
  split; try apply SET_standard'. intros rho phi [].
  - now apply SET'_ZF'.
  - apply SET_sep'.
Qed.

Lemma extensionality_model_eq :
  CE -> exists V (M : interp V), extensional M /\ standard M /\ forall rho phi, Zeq phi -> rho ⊨ phi.
Proof.
  intros ce. exists SET', (SET_interp' ce). split; try apply SET_ext'.
  split; try apply SET_standard'. intros rho phi [].
  - destruct H as [<-|[<-|[<-|[<-|H0]]]]; cbn; try congruence.
    now intros x x' y y' -> ->. now apply SET'_ZF'.
  - apply SET_sep'.
Qed.

(* *** Intensional model of Z' without assumptions *)

Section IM.

  Instance Acz_interp : interp Acz.
  Proof.
    split; intros [].
    - intros _. exact AEmpty.
    - intros v. exact (Aupair (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (Aunion (Vector.hd v)).
    - intros v. exact (Apower (Vector.hd v)).
    - intros _. exact Aom.
    - intros v. exact (Ain (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (Aeq (Vector.hd v) (Vector.hd (Vector.tl v))).
  Defined.

  Lemma Acz_standard :
    standard Acz_interp.
  Proof.
    intros s [n Hn]. cbn in Hn. exists n. apply Hn.
  Qed.

  Lemma Acz_ZFeq' rho :
    rho ⊫ ZFeq'.
  Proof.
    intros phi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]]]]]; cbn.
    - apply Aeq_ref.
    - apply Aeq_sym.
    - apply Aeq_tra.
    - intros s t s' t' -> ->. tauto.
    - apply Aeq_ext.
    - apply AEmptyAx.
    - intros X Y Z. apply AupairAx.
    - intros X Y. apply AunionAx.
    - intros X Y. apply ApowerAx.
    - apply AomAx1.
    - apply AomAx2.
  Qed.

End IM.

Lemma intensional_model :
  exists V (M : interp V), standard M /\ forall rho, rho ⊫ ZFeq'.
Proof.
  exists Acz, Acz_interp. split; try apply Acz_standard. apply Acz_ZFeq'.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C Oprime Aprime Bprime Cprime Eprimeprime Bprimeprime C2 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ A E /\ (wd_ Eprimeprime O /\ (wd_ O Oprime /\ (wd_ Bprimeprime O /\ (wd_ Bprime Oprime /\ (wd_ Eprimeprime A /\ (wd_ E Eprimeprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Oprime Eprimeprime /\ (wd_ E Oprime /\ (wd_ B Bprimeprime /\ (wd_ Eprime C2 /\ (wd_ Aprime C2 /\ (wd_ Oprime Aprime /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprimeprime Bprimeprime /\ (col_ O Eprimeprime Oprime /\ (col_ O Eprimeprime C2 /\ col_ O Eprimeprime Bprime)))))))))))))))))))))))))))))))) -> col_ O Oprime Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.
Require Import  p4_0.
Require Import  p4_1.
Require Import  p4_2.
Require Import  p4_3.
Require Import  p4_4.
Require Import  p4_5.
Require Import  p4_6.
Require Import  p4_7.
Require Import  p4_8.
Require Import  p4_9.
Require Import  p4_10.
Require Import  p4_11.
Require Import  p4_12.
Require Import  p4_13.
Require Import  p4_14.
Require Import  p4_15.
Require Import  p4_16.
Require Import  p4_17.
Require Import  p4_18.
Require Import  p4_19.
Require Import  p4_20.
Require Import  p4_21.
Require Import  p4_22.
Require Import  p4_23.
Require Import  p4_24.
Require Import  p4_25.
Require Import  p4_26.
Require Import  p4_27.
Require Import  p4_28.
Require Import  p4_29.
Require Import  p4_30.
Require Import  p4_31.
Require Import  p4_32.
Require Import  p4_33.
Require Import  p4_34.
Require Import  p4_35.
Require Import  p4_36.
Require Import  p4_37.
Require Import  p4_38.
Require Import  p4_39.
Require Import  p4_40.
Require Import  p4_41.
Require Import  p4_42.
Require Import  p4_43.
Require Import  p4_44.
Require Import  p4_45.
Require Import  p4_46.
Require Import  p4_47.
Require Import  p4_48.
Require Import  p4_49.
Require Import  p4_50.
Require Import  p4_51.
Require Import  p4_52.
Require Import  p4_53.
Require Import  p4_54.
Require Import  p4_55.
Require Import  p4_56.
Require Import  p4_57.
Require Import  p4_58.
Require Import  p4_59.
Require Import  p4_60.
Require Import  p4_61.
Require Import  p4_62.
Require Import  p4_63.
Require Import  p4_64.
Require Import  p4_65.
Require Import  p4_66.
Require Import  p4_67.
Require Import  p4_68.
Require Import  p4_69.
Require Import  p4_70.
Require Import  p4_71.
Require Import  p4_72.
Require Import  p4_73.
Require Import  p4_74.
Require Import  p4_75.
Require Import  p4_76.
Require Import  p4_77.
Require Import  p4_78.
Require Import  p4_79.
Require Import  p4_80.

Lemma  primo: prime 30775978630800914887828714698626998824250963966146709840627253349863461586126089678486814326379490843228492252402567569988859797633681112539675156090486818372680356168656473971448102729390315141640354592087783778469871309494791841329488509756595115983526455646971532760163657536084034042966759474257528202142602609013860369616999380774023410013810115957921339521455701267320756719385975584715291928657454187787309573331113295872135528700047058819691005104259282450154137634415308918857295793861293876104478941719109946052733065895798017219282948123605648341473405661658417064832118983730212047561353543456847192194833.
Proof.
exact
(primo0 (primo1 (primo2 (primo3 (primo4 (primo5 (primo6 (primo7 (primo8 (primo9 (primo10 (primo11 (primo12 (primo13 (primo14 (primo15 (primo16 (primo17 (primo18 (primo19 (primo20 (primo21 (primo22 (primo23 (primo24 (primo25 (primo26 (primo27 (primo28 (primo29 (primo30 (primo31 (primo32 (primo33 (primo34 (primo35 (primo36 (primo37 (primo38 (primo39 (primo40 (primo41 (primo42 (primo43 (primo44 (primo45 (primo46 (primo47 (primo48 (primo49 (primo50 (primo51 (primo52 (primo53 (primo54 (primo55 (primo56 (primo57 (primo58 (primo59 (primo60 (primo61 (primo62 (primo63 (primo64 (primo65 (primo66 (primo67 (primo68 (primo69 (primo70 (primo71 (primo72 (primo73 (primo74 (primo75 (primo76 (primo77 (primo78 (primo79 primo80)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).
Qed.


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

(***
Modulus : 2^256 - 2^32 - 977
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 64;
    bitwidth := 64;
    s := 2^256;
    c := [(1, 977); (2^32, 1)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

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

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.