From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
Require Import pred prelude ordtype finmap.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*******************************)
(* Partial Commutative Monoids *)
(*******************************)

Module PCM.

Record mixin_of (T : Type) := Mixin {
    valid_op : T -> bool;
    join_op : T -> T -> T;
    unit_op : T;
    _ : commutative join_op;
    _ : associative join_op;
    _ : left_id unit_op join_op;
    (* monotonicity of valid *)
    _ : forall x y, valid_op (join_op x y) -> valid_op x;
    (* unit is valid *)
    _ : valid_op unit_op}.

Section ClassDef.

Notation class_of := mixin_of (only parsing).

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.

Definition pack c := @Pack T c T.
Definition clone := fun c & cT -> T & phant_id (pack c) cT => pack c.

Definition valid := valid_op class.
Definition join := join_op class.
Definition unit := unit_op class.

End ClassDef.

Implicit Arguments unit [cT].

Definition morph_axiom (A B : type) (f : sort A -> sort B) :=
  f unit = unit /\ forall x y, f (join x y) = join (f x) (f y).

Module Exports.
Coercion sort : type >-> Sortclass.
Notation pcm := type.
Notation PCMMixin := Mixin.
Notation PCM T m := (@pack T m).

Notation "[ 'pcmMixin' 'of' T ]" := (class _ : mixin_of T)
  (at level 0, format "[ 'pcmMixin'  'of'  T ]") : form_scope.
Notation "[ 'pcm' 'of' T 'for' C ]" := (@clone T C _ idfun id)
  (at level 0, format "[ 'pcm'  'of'  T  'for'  C ]") : form_scope.
Notation "[ 'pcm' 'of' T ]" := (@clone T _ _ id id)
  (at level 0, format "[ 'pcm'  'of'  T ]") : form_scope.

Notation "x \+ y" := (join x y) (at level 43, left associativity).
Notation valid := valid.
Notation Unit := unit.

Implicit Arguments unit [cT].
Prenex Implicits join unit.

Section Morphism.
Variables A B : pcm.

Structure pcm_morph_type := PCMMorph {
  pcm_func :> A -> B;
  _ : morph_axiom pcm_func}.

Definition pcm_morph_for of phant (A -> B) := pcm_morph_type.
Identity Coercion type_of_pcm_morph : pcm_morph_for >-> pcm_morph_type.

End Morphism.

Notation "{ 'pcm_morph' fT }" := (pcm_morph_for (Phant fT))
  (at level 0, format "{ 'pcm_morph'  '[hv' fT ']' }") : type_scope.

(* Restating the laws, with the notation. *)
(* Plus some additional derived lemmas.   *)

Section Laws.
Variable U V : pcm.

Lemma joinC (x y : U) : x \+ y = y \+ x.
Proof. by case: U x y=>tp [v j z Cj *]; apply: Cj. Qed.

Lemma joinA (x y z : U) : x \+ (y \+ z) = x \+ y \+ z.
Proof. by case: U x y z=>tp [v j z Cj Aj *]; apply: Aj. Qed.

Lemma joinAC (x y z : U) : x \+ y \+ z = x \+ z \+ y.
Proof. by rewrite -joinA (joinC y) joinA. Qed.

Lemma joinCA (x y z : U) : x \+ (y \+ z) = y \+ (x \+ z).
Proof. by rewrite joinA (joinC x) -joinA. Qed.

Lemma validL (x y : U) : valid (x \+ y) -> valid x.
Proof. case: U x y=>tp [v j z Cj Aj Uj /= Mj inv f]; apply: Mj. Qed.

Lemma validR (x y : U) : valid (x \+ y) -> valid y.
Proof. by rewrite joinC; apply: validL. Qed.

Lemma unitL (x : U) : Unit \+ x = x.
Proof. by case: U x=>tp [v j z Cj Aj Uj *]; apply: Uj. Qed.

Lemma unitR (x : U) : x \+ Unit = x.
Proof. by rewrite joinC unitL. Qed.

Lemma valid_unit : valid (@Unit U).
Proof. by case: U=>tp [v j z Cj Aj Uj Vm Vu *]. Qed.

Variable f : {pcm_morph U -> V}.

Lemma fjoin x y : f (x \+ y) = f x \+ f y.
Proof. by case: f=>? []. Qed.

Lemma funit : f Unit = Unit.
Proof. by case: f=>? []. Qed.

End Laws.

Hint Resolve valid_unit.

Section UnfoldingRules.
Variable U : pcm.

Lemma pcm_joinE (x y : U) : x \+ y = join_op (class U) x y.
Proof. by []. Qed.

Lemma pcm_validE (x : U) : valid x = valid_op (class U) x.
Proof. by []. Qed.

Lemma pcm_unitE : unit = unit_op (class U).
Proof. by []. Qed.

Definition pcmE := (pcm_joinE, pcm_validE, pcm_unitE).

End UnfoldingRules.

End Exports.

End PCM.

Export PCM.Exports.

(* definition of precision for an arbitrary PCM U *)

Definition precise (U : pcm) (P : Pred U) :=
  forall s1 s2 t1 t2,
    valid (s1 \+ t1) ->
    s1 \+ t1 = s2 \+ t2 ->
    s1 \In P -> s2 \In P -> s1 = s2.

(****************************************************)
(* Sometimes we want to construct PCM's by lifting. *)
(* We need a structure which by lifting becomes PCM *)
(* This will give us uniform notation for lifting   *)
(****************************************************)

Module Unlifted.

Record mixin_of (T : Type) := Mixin {
  ounit_op : T;
  ojoin_op : T -> T -> option T;
  ojoinC_op : forall x y, ojoin_op x y = ojoin_op y x;
  ojoinA_op : forall x y z,
    obind (ojoin_op x) (ojoin_op y z) = obind (ojoin_op^~ z) (ojoin_op x y);
  ounitL_op : forall x, ojoin_op ounit_op x = Some x}.

Section ClassDef.

Notation class_of := mixin_of (only parsing).

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition pack c := @Pack T c T.
Definition clone := fun c & cT -> T & phant_id (pack c) cT => pack c.

Definition ounit := ounit_op class.
Definition ojoin := ojoin_op class.

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Notation unlifted := type.
Notation UnliftedMixin := Mixin.
Notation Unlifted T m := (@pack T m).

Notation "[ 'unliftedMixin' 'of' T ]" := (class _ : mixin_of T)
  (at level 0, format "[ 'unliftedMixin'  'of'  T ]") : form_scope.
Notation "[ 'unlifted' 'of' T 'for' C ]" := (@clone T C _ idfun id)
  (at level 0, format "[ 'unlifted'  'of'  T  'for'  C ]") : form_scope.
Notation "[ 'unlifted' 'of' T ]" := (@clone T _ _ id id)
  (at level 0, format "[ 'unlifted'  'of'  T ]") : form_scope.

Notation ounit := ounit.
Notation ojoin := ojoin.

Implicit Arguments ounit [cT].

Lemma ojoinC (U : unlifted) (x y : U) : ojoin x y = ojoin y x.
Proof. by case: U x y=>T [ou oj ojC]. Qed.

Lemma ojoinA (U : unlifted) (x y z : U) :
        obind (ojoin x) (ojoin y z) = obind (@ojoin U^~ z) (ojoin x y).
Proof. by case: U x y z=>T [ou oj ojC ojA]. Qed.

Lemma ounitL (U : unlifted) (x : U) : ojoin ounit x = Some x.
Proof. by case: U x=>T [ou oj ojC ojA ojL]. Qed.

End Exports.

End Unlifted.

Export Unlifted.Exports.

(**************************************************)
(* Lifting turns an unlifted structure into a PCM *)
(**************************************************)

Module Lift.
Section Lift.
Variable A : unlifted.

Structure lift : Type := Undef | Up of A.

Let unit := Up ounit.

Let valid :=
  [fun x : lift => if x is Up _ then true else false].

Let join :=
  [fun x y : lift =>
     if (x, y) is (Up v, Up w) then
       if ojoin v w is Some u then Up u
       else Undef
     else Undef].

Lemma joinC (x y : lift) : join x y = join y x.
Proof. by case: x y=>[|x][|y] //=; rewrite ojoinC. Qed.

Lemma joinA (x y z : lift) : join x (join y z) = join (join x y) z.
Proof.
case: x y z =>[|x][|y][|z] //=; first by case: (ojoin x y).
case E1: (ojoin y z)=>[v1|].
- case E2: (ojoin x y)=>[v2|];
  by move: (ojoinA x y z); rewrite E1 E2 /=; move=>->.
case E2: (ojoin x y)=>[v2|] //.
by move: (ojoinA x y z); rewrite E1 E2 /= =><-.
Qed.

Lemma unitL x : join unit x = x.
Proof. by case: x=>[|x] //=; rewrite ounitL. Qed.

Lemma validL x y : valid (join x y) -> valid x.
Proof. by case: x y=>[|x][|y]. Qed.

Lemma validU : valid unit.
Proof. by []. Qed.

End Lift.
End Lift.

Notation lift A := (@Lift.lift A).
Notation undef := (@Lift.Undef _).
Notation up a := (@Lift.Up _ a).

(* A view for pattern-matching lifted pcm's *)

CoInductive lift_spec A : lift A -> Type :=
| undef_spec : lift_spec undef
| up_spec : forall a : A, lift_spec (up a).

Lemma liftP A (x : lift A) : lift_spec x.
Proof. by case: x=>[|a]; [apply: undef_spec | apply: up_spec]. Qed.

Definition liftPCMMixin A :=
  PCMMixin (@Lift.joinC A) (@Lift.joinA A)
           (@Lift.unitL A) (@Lift.validL A) (@Lift.validU A).
Canonical liftPCM A := Eval hnf in PCM (lift A) (liftPCMMixin A).

(* simplifying up-up expressions *)

Lemma upupE (A : unlifted) (a1 a2 : A) :
        up a1 \+ up a2 =
        if ojoin a1 a2 is Some a then up a else undef.
Proof. by []. Qed.

(* We can prove that lifting preserves equality types *)

Module LiftEqType.
Section LiftEqType.
Variable (A : eqType) (c : Unlifted.mixin_of A).

Let U := (Unlifted A c).

Definition lift_eq (u v : lift U) :=
  match u, v with
    Lift.Up a, Lift.Up b => a == b
  | Lift.Undef, Lift.Undef => true
  | _, _ => false
  end.

Lemma lift_eqP : Equality.axiom lift_eq.
Proof.
case=>[|x][|y] /=; try by constructor.
by apply: (iffP eqP)=>[->|[]].
Qed.

End LiftEqType.
End LiftEqType.

Definition liftEqMixin A c := EqMixin (@LiftEqType.lift_eqP A c).
Canonical liftEqType A c := Eval hnf in EqType _ (@liftEqMixin A c).

(******************************)
(* Now some PCM constructions *)
(******************************)

(* heaps are pcms, albeit large *)
(* remove this line eventually; this is here for legacy *)
(*
Definition old_heapPCMMixin := PCMMixin unC unA un0h defUnl def0.
Canonical old_heapPCM := Eval hnf in PCM heap old_heapPCMMixin.
*)

(* nats with addition are a pcm *)

Definition natPCMMixin :=
  PCMMixin addnC addnA add0n (fun x y => @id true) (erefl _).
Canonical natPCM := Eval hnf in PCM nat natPCMMixin.

(* also with multiplication, but we don't make that one canonical *)

Definition multPCMMixin :=
  PCMMixin mulnC mulnA mul1n (fun x y => @id true) (erefl _).
Definition multPCM := Eval hnf in PCM nat multPCMMixin.

(* with max too *)

Definition maxPCMMixin :=
  PCMMixin maxnC maxnA max0n (fun x y => @id true) (erefl _).
Definition maxPCM := Eval hnf in PCM nat maxPCMMixin.

(* mutexes are an unlifted pcm and an equality type *)

Structure mutex := own | nown.

Module MutexUnlift.

Definition mutex_eq x y :=
  match x, y with
    own, own => true
  | nown, nown => true
  | _, _ => false
  end.

Lemma mutex_eqP : Equality.axiom mutex_eq.
Proof. by case; case; constructor. Qed.

Definition ojoin x y :=
  match x, y with
    own, nown => Some own
  | nown, own => Some own
  | nown, nown => Some nown
  | _, _ => None
  end.

Let ounit := nown.

Lemma ojoinC x y : ojoin x y = ojoin y x.
Proof. by case: x; case: y. Qed.

Lemma ojoinA x y z :
        obind (ojoin x) (ojoin y z) = obind (ojoin^~ z) (ojoin x y).
Proof. by case: x; case: y; case: z. Qed.

Lemma ounitL x : ojoin ounit x = Some x.
Proof. by case: x. Qed.

End MutexUnlift.

Definition mutexEqMixin := EqMixin MutexUnlift.mutex_eqP.
Canonical mutexEqType := Eval hnf in EqType mutex mutexEqMixin.

Definition mutexUnliftedMixin :=
  UnliftedMixin MutexUnlift.ojoinC MutexUnlift.ojoinA MutexUnlift.ounitL.
Canonical mutexUnlifted := Eval hnf in Unlifted mutex mutexUnliftedMixin.

(* some lemmas for mutexes *)

Lemma mtx00E m1 m2 : m1 \+ m2 = up nown -> m1 = up nown /\ m2 = up nown.
Proof. by case: (liftP m1)=>//; case: (liftP m2)=>//; case; case. Qed.

(* pairs of pcms are a pcm *)

Module ProdPCM.
Section ProdPCM.
Variables (U V : pcm).
Local Notation tp := (U * V)%type.

Definition pvalid := [fun x : tp => valid x.1 && valid x.2].
Definition pjoin := [fun x1 x2 : tp => (x1.1 \+ x2.1, x1.2 \+ x2.2)].
Definition punit : tp := (Unit, Unit).

Lemma joinC x y : pjoin x y = pjoin y x.
Proof.
move: x y => [x1 x2][y1 y2] /=.
by rewrite (joinC x1) (joinC x2).
Qed.

Lemma joinA x y z : pjoin x (pjoin y z) = pjoin (pjoin x y) z.
Proof.
move: x y z => [x1 x2][y1 y2][z1 z2] /=.
by rewrite (joinA x1) (joinA x2).
Qed.

Lemma validL x y : pvalid (pjoin x y) -> pvalid x.
Proof.
move: x y => [x1 x2][y1 y2] /=.
by case/andP=>D1 D2; rewrite (validL D1) (validL D2).
Qed.

Lemma unitL x : pjoin punit x = x.
Proof. by case: x=>x1 x2; rewrite /= !unitL. Qed.

Lemma validU : pvalid punit.
Proof. by rewrite /pvalid /= !valid_unit. Qed.

End ProdPCM.
End ProdPCM.

Definition prodPCMMixin U V :=
  PCMMixin (@ProdPCM.joinC U V) (@ProdPCM.joinA U V)
           (@ProdPCM.unitL U V) (@ProdPCM.validL U V) (@ProdPCM.validU U V).
Canonical prodPCM U V := Eval hnf in PCM (_ * _) (@prodPCMMixin U V).

(* unit is a pcm; just for kicks *)

Module UnitPCM.
Section UnitPCM.

Definition uvalid (x : unit) := true.
Definition ujoin (x y : unit) := tt.
Definition uunit := tt.

Lemma ujoinC x y : ujoin x y = ujoin y x.
Proof. by []. Qed.

Lemma ujoinA x y z : ujoin x (ujoin y z) = ujoin (ujoin x y) z.
Proof. by []. Qed.

Lemma uvalidL x y : uvalid (ujoin x y) -> uvalid x.
Proof. by []. Qed.

Lemma uunitL x : ujoin uunit x = x.
Proof. by case: x. Qed.

Lemma uvalidU : uvalid uunit.
Proof. by []. Qed.

End UnitPCM.
End UnitPCM.

Definition unitPCMMixin :=
  PCMMixin UnitPCM.ujoinC UnitPCM.ujoinA
           UnitPCM.uunitL UnitPCM.uvalidL UnitPCM.uvalidU.
Canonical unitPCM := Eval hnf in PCM unit unitPCMMixin.

(* bools with conjunction are a pcm *)

Module BoolConjPCM.
Lemma unitL x : true && x = x. Proof. by []. Qed.
End BoolConjPCM.

Definition boolPCMMixin := PCMMixin andbC andbA BoolConjPCM.unitL
                           (fun x y => @id true) (erefl _).
Canonical boolConjPCM := Eval hnf in PCM bool boolPCMMixin.

(* finite maps with disjoint union are a pcm *)

Module FinMapPCM.
Section FinMapPCM.
Variables (K : ordType) (V : Type).

Structure finmap := Undef | Def of {finMap K -> V}.

Definition valid (f : finmap) :=
  if f is Def _ then true else false.

Definition join (f1 f2 : finmap) :=
  if (f1, f2) is (Def m1, Def m2) then
    if disj m1 m2 then Def (fcat m1 m2)
    else Undef
  else Undef.

Definition unit := Def (@nil K V).

Lemma joinC f1 f2 : join f1 f2 = join f2 f1.
Proof.
case: f1 f2=>[|m1][|m2] //; rewrite /join.
by case: ifP=>E; rewrite disjC E // fcatC.
Qed.

Lemma joinCA f1 f2 f3 : join f1 (join f2 f3) = join f2 (join f1 f3).
Proof.
case: f1 f2 f3=>[|m1][|m2][|m3] //.
rewrite /join; case E1: (disj m2 m3); last first.
- by case E2: (disj m1 m3)=>//; rewrite disj_fcat E1 andbF.
rewrite disj_fcat andbC.
case E2: (disj m1 m3)=>//; rewrite disj_fcat (disjC m2) E1 /= andbT.
by case E3: (disj m1 m2)=>//; rewrite fcatAC // E1 E2 E3.
Qed.

Lemma joinA f1 f2 f3 : join f1 (join f2 f3) = join (join f1 f2) f3.
Proof. by rewrite (joinC f2) joinCA joinC. Qed.

Lemma validL f1 f2 : valid (join f1 f2) -> valid f1.
Proof. by case: f1. Qed.

Lemma unitL f : join unit f = f.
Proof. by case: f=>[//|m]; rewrite /join/unit disjC disj_nil fcat0s. Qed.

Lemma validU : valid unit.
Proof. by []. Qed.

End FinMapPCM.

Module Exports.
Notation finmap := finmap.

Section Exports.
Variables (K : ordType) (V : Type).

Definition finmapPCMMixin :=
  PCMMixin (@joinC K V) (@joinA K V) (@unitL K V) (@validL K V) (@validU K V).
Canonical finmapPCM := Eval hnf in PCM (finmap K V) finmapPCMMixin.

End Exports.
End Exports.
End FinMapPCM.

Export FinMapPCM.Exports.


(***************************************************************************
* Formalization of ES calculi			                           *
*									   *
* General rewriting definitions	for explicit substitutions		   *
*									   *
* Fabien Renaud & Stephane Zimmerman, 2011				   *
* Flavio L. C. de Moura & Daniel L. Ventura & Washington R. Segundo, 2014  *
* Flavio L. C. de Moura, 2017                                              *
***************************************************************************)

Require Import Metatheory.
Require Import LambdaES_Defs.
Require Import List.

(** Given a relation Red, constructs its contextual closure. The contextual closure of a reduction is build in such a way that regularity is preserved. In particular, note the condition requiring that only terms can be introduced by the constructors for applications and explicit substitutions. *)
Inductive L_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | L_redex : forall t s, Red t s -> L_contextual_closure Red t s
  | L_app_left : forall t t' u, L_contextual_closure Red t t' ->
	  		      L_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | L_app_right : forall t u u', L_contextual_closure Red u u' ->
	  		       L_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | L_abs_in : forall t t' L, (forall x, x \notin L -> L_contextual_closure Red (t^x) (t'^x)) ->
                            L_contextual_closure Red (pterm_abs t) (pterm_abs t').

Inductive ES_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | ES_redex : forall t s, Red t s -> ES_contextual_closure Red t s
  | ES_app_left : forall t t' u, ES_contextual_closure Red t t' ->
	  		      ES_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | ES_app_right : forall t u u', ES_contextual_closure Red u u' ->
	  		       ES_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | ES_abs_in : forall t t' L, (forall x, x \notin L -> ES_contextual_closure Red (t^x) (t'^x)) ->
                            ES_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | ES_subst_left : forall t t' u L, (forall x, x \notin L -> ES_contextual_closure Red (t^x) (t'^x)) ->
	          ES_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u)
  | ES_subst_right : forall t u u', ES_contextual_closure Red u u' ->
	  	ES_contextual_closure Red  (pterm_sub t u) (pterm_sub t u').

Inductive ESlab_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
| ESlab_redex : forall t s, Red t s -> ESlab_contextual_closure Red t s
| ESlab_app_left : forall t t' u, ESlab_contextual_closure Red t t' ->
	  		          ESlab_contextual_closure Red (pterm_app t u) (pterm_app t' u)
| ESlab_app_right : forall t u u', ESlab_contextual_closure Red u u' ->
	  		           ESlab_contextual_closure Red (pterm_app t u) (pterm_app t u')
| ESlab_abs_in : forall t t' L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) ->
                                ESlab_contextual_closure Red (pterm_abs t) (pterm_abs t')
| ESlab_subst_left : forall t t' u L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) ->
                                      ESlab_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u)
| ESlab_subst_right : forall t u u', ESlab_contextual_closure Red u u' ->
	  	                     ESlab_contextual_closure Red  (pterm_sub t u) (pterm_sub t u')
| ESlab_lsubst_left : forall t t' u L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) -> ESlab_contextual_closure Red  (pterm_sub' t u) (pterm_sub' t' u)
| ESlab_lsubst_right : forall t u u', ESlab_contextual_closure Red u u' ->
	  	                      ESlab_contextual_closure Red  (pterm_sub' t u) (pterm_sub' t u').

Lemma ES_cc_is_ESlab_cc: forall R t u, ES_contextual_closure R t u -> ESlab_contextual_closure R t u.
Proof.
  introv Hes. induction Hes.
  - apply ESlab_redex; assumption.
  - apply ESlab_app_left; assumption.
  - apply ESlab_app_right; assumption.
  - apply ESlab_abs_in with L; assumption.
  - apply ESlab_subst_left with L; assumption.
  - apply ESlab_subst_right; assumption.
Qed.

Inductive ext_lab_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
| ext_lab_redex : forall t s, Red t s -> ext_lab_contextual_closure Red t s
| ext_lab_app_left : forall t t' u, ext_lab_contextual_closure Red t t' ->
	  		        ext_lab_contextual_closure Red (pterm_app t u) (pterm_app t' u)
| ext_lab_app_right : forall t u u', ext_lab_contextual_closure Red u u' ->
	  		         ext_lab_contextual_closure Red (pterm_app t u) (pterm_app t u')
| ext_lab_abs_in : forall t t' L, (forall x, x \notin L -> ext_lab_contextual_closure Red (t^x) (t'^x))
                              -> ext_lab_contextual_closure Red (pterm_abs t) (pterm_abs t')
| ext_lab_subst_left : forall t t' u L, (forall x, x \notin L -> ext_lab_contextual_closure Red (t^x) (t'^x)) -> ext_lab_contextual_closure Red  (t[u]) (t'[u])
| ext_lab_subst_right : forall t u u', ext_lab_contextual_closure Red u u' ->
	  	                   ext_lab_contextual_closure Red  (t[u]) (t[u'])
| ext_lab_subst'_ext : forall t t' u L, (forall x, x \notin L -> ext_lab_contextual_closure Red (t^x) (t'^x)) -> ext_lab_contextual_closure Red  (t[[u]]) (t'[[u]]).

(** Given a relation Red, constructs its parallel contextual closure
Inductive L_p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | L_p_redex : forall t s, Red t s -> L_p_contextual_closure Red t s
  | L_p_app : forall t t' u u', L_p_contextual_closure Red t t' -> L_p_contextual_closure Red u u' ->
	  		L_p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
  | L_p_abs_in : forall t t' L, (forall x, x \notin L -> L_p_contextual_closure Red (t^x) (t'^x)) ->
               L_p_contextual_closure Red (pterm_abs t) (pterm_abs t').

Inductive ES_p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | ES_p_redex : forall t s, Red t s -> ES_p_contextual_closure Red t s
  | ES_p_app : forall t t' u u', ES_p_contextual_closure Red t t' -> ES_p_contextual_closure Red u u' ->
	  		ES_p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
  | ES_p_abs_in : forall t t' L, (forall x, x \notin L -> ES_p_contextual_closure Red (t^x) (t'^x)) ->
               ES_p_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | ES_p_subst : forall t t' u u' L, (forall x, x \notin L -> ES_p_contextual_closure Red (t^x) (t'^x)) ->
              ES_p_contextual_closure Red u u' ->
	      ES_p_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u').
*)
Hint Constructors L_contextual_closure ES_contextual_closure  ESlab_contextual_closure.
     (* L_p_contextual_closure ES_p_contextual_closure. *)

(** Given a relation Red, constructs its transitive closure *)
Inductive trans_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | one_step_reduction : forall t u, Red t u -> trans_closure Red t u
  | transitive_reduction : forall t u v, Red t u -> trans_closure Red u v -> trans_closure Red t v.

Lemma ES_cc_trans_is_ESlab_cc_trans: forall R t u, trans_closure (ES_contextual_closure R) t u -> trans_closure (ESlab_contextual_closure R) t u.
Proof.
  introv Hes. induction Hes.
  - apply one_step_reduction. apply ES_cc_is_ESlab_cc in H; assumption.
  - apply ES_cc_is_ESlab_cc in H. apply transitive_reduction with u; assumption.
Qed.

(** Given a relation Red, constructs its transitive reflexive closure *)
Inductive star_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | reflexive_reduction : forall t, star_closure Red t t
  | star_trans_reduction : forall t u, trans_closure Red t u -> star_closure Red t u.

Lemma star_transitive_closure:
    forall (Red: pterm -> pterm -> Prop) (t u v : pterm),
     Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
 intros Red t u v H0 H1.
 induction H1.
   apply star_trans_reduction.
   apply one_step_reduction.
   assumption.
   apply star_trans_reduction.
   apply transitive_reduction with (u := t0); trivial.
Qed.

Lemma transitive_closure :
    forall Red t u v, trans_closure Red t u -> Red u v -> trans_closure Red t v.
Proof.
  introv Htrans Hred. induction Htrans.
  - apply transitive_reduction with u.
    + assumption.
    + apply one_step_reduction; assumption.
  - apply transitive_reduction with u.
    + assumption.
    + apply IHHtrans; assumption.
Qed.

Lemma transitive_closure_composition :
    forall Red t u v, trans_closure Red t u -> trans_closure Red u v -> trans_closure Red t v.
Proof.
  intros.
  induction H.
    apply transitive_reduction with (u := u); trivial.
    apply transitive_reduction with (u := u) ; auto.
Qed.

Lemma star_transitive_closure':
    forall (Red: pterm -> pterm -> Prop) (t u v : pterm),
     star_closure Red t u -> Red u v -> star_closure Red t v.
Proof.
 introv Hstar Hred. induction Hstar.
 - apply star_trans_reduction.
   apply one_step_reduction. assumption.
 - apply star_trans_reduction.
   apply transitive_closure with u; assumption.
Qed.

Lemma star_transitive_closure_composition_1 :
    forall Red t u v, trans_closure Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
  intros.
  induction H0.
    apply star_trans_reduction; trivial.
    apply star_trans_reduction.
    apply transitive_closure_composition with (u := t0); trivial.
Qed.

Lemma star_transitive_closure_composition_2 :
    forall Red t u v, star_closure Red t u -> trans_closure Red u v -> star_closure Red t v.
Proof.
  intros.
  induction H.
    apply star_trans_reduction; trivial.
    apply star_trans_reduction.
    apply transitive_closure_composition with (u := u); trivial.
Qed.

Lemma star_closure_composition:
    forall Red t u v, star_closure Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
  intros.
  induction H.
  assumption.
  apply star_transitive_closure_composition_1 with (u := u); assumption.
Qed.

Lemma transitive_star_derivation:
    forall (Red : pterm -> pterm -> Prop) (t v: pterm),
    trans_closure Red t v -> exists u, Red t u /\  star_closure Red u v.
Proof.
  intros.
  case H. intros t' u' H0.
  exists u'. split; trivial.
  apply reflexive_reduction.
  intros t' u' v' H0 H1. exists u'.
  split; trivial.
  apply star_trans_reduction; trivial.
Qed.

Lemma transitive_star_derivation':
    forall (Red : pterm -> pterm -> Prop) (t v: pterm),
    trans_closure Red t v <-> (Red t v \/ (exists u, Red t u /\  (exists u', star_closure Red u u' /\ Red u' v))).
Proof.
 intros. split. intros. destruct H.
 left; trivial. right. exists u. split; trivial.
 clear H. induction H0. exists t0. split; trivial.
 apply reflexive_reduction. destruct IHtrans_closure.
 exists x. split. apply star_transitive_closure with (u := u); trivial.
 apply H1. apply H1. intros. case H. intro.
 apply one_step_reduction; trivial. intro.
 destruct H0. destruct H0. destruct H1. destruct H1. destruct H1.
 apply transitive_reduction with (u := t0); trivial.
 apply one_step_reduction; trivial.
 apply transitive_reduction with (u := t0); trivial.
 apply transitive_closure_composition with (u := u); trivial.
 apply one_step_reduction; trivial.
Qed.

Lemma star_transitive_derivation: forall (Red : pterm -> pterm -> Prop) (t u: pterm),
      star_closure Red t u <-> (t = u \/ trans_closure Red t u).
Proof.
 intros. split. intro. destruct H.
 left. reflexivity. right; trivial.
 intro. case H.
 clear H. intro H. rewrite H. apply reflexive_reduction.
 clear H. intro H. apply star_trans_reduction; trivial.
Qed.

Lemma trans_R1_R2 : forall (R1 R2: pterm -> pterm -> Prop),
                           (forall t t', R1 t t' -> R2 t t') ->
                           (forall t t', trans_closure R1 t t' -> trans_closure R2 t t').
Proof.
 intros R1 R2 H t t' H'. induction H'.
 apply one_step_reduction. apply H; trivial.
 apply transitive_reduction with (u := u); trivial.
 apply H; trivial.
Qed.

Lemma star_R1_R2: forall (R1 R2: pterm -> pterm -> Prop),
                           (forall t t', R1 t t' -> R2 t t') ->
                           (forall t t', star_closure R1 t t' -> star_closure R2 t t').
Proof.
 intros R1 R2 H t t' H'. induction H'.
 apply reflexive_reduction.
 apply star_trans_reduction.
 apply trans_R1_R2 with (R1 := R1); trivial.
Qed.


(* In this file we explain how to do the "parallel increment" example (Example
   7.5) from the lecture notes in Iris in Coq. *)

(* Contains definitions of the weakest precondition assertion, and its basic
   rules. *)
From iris.program_logic Require Export weakestpre.
(* Definition of invariants and their rules (expressed using the fancy update
    modality). *)
From iris.base_logic.lib Require Export invariants.

(* Files related to the interactive proof mode. The first import includes the
    general tactics of the proof mode. The second provides some more specialized
    tactics particular to the instantiation of Iris to a particular programming
    language. *)
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Import proofmode.
From iris.heap_lang Require Export lang.

(* Instantiation of Iris with the particular language. The notation file
    contains many shorthand notations for the programming language constructs, and
    the lang file contains the actual language syntax. *)
From iris.heap_lang Require Import notation adequacy.

(* We also import the parallel composition construct. This is not a primitive of
    the language, but is instead derived. This file contains its definition, and
    the proof rule associated with it. *)
From iris.heap_lang.lib Require Import par.

(* The following line imports some Coq configuration we commonly use in Iris
    projects, mostly with the goal of catching common mistakes. *)
From iris.prelude Require Import options.

(* We define our terms. The Iris Coq library defines many notations for
    programming language constructs, e.g., lambdas, allocation, accessing and so
    on. The complete list of notations can be found in
    theories/heap_lang/notations.v file in the iris-coq repository.
    The # in the notation is used to embed literals, e.g., variables, numbers, as
    values of the programmin language. *)

From RecordUpdate Require Import RecordSet.

Inductive Phase :=
  | First: Phase
  | Second: Phase
  | Third: Phase.

Definition phase_incr (p : Phase) : Phase :=
  match p with
  | First => Second
  | Second => Third
  | Third => First
  end.

Lemma phase_incr_third :  phase_incr Third = First.
    unfold phase_incr.
    reflexivity.
Qed.

(* There is a way to define and update record data type *)
Record BounceUnit := mkBounceUnit { Id: nat; P: Phase }.
Instance etaBounceUnit : Settable _ := settable! mkBounceUnit <Id; P>.
Definition setPhase p x := set P p x.

(* Example using location and values *)
Definition phase_transit: expr :=
    λ: "l",
    let: "phase" := !"l" in
    match !"phase" with
        #1 => "l" <- #2
      | #2 => "l" <- #3
      | _ => "l" <- #1
      (* | #3 => "l" <- #1
      (* Throw an error in this case,
        or probably try with Inductive. *)
      | _ => #-1 *)
    end.

Section proof.
(* In order to do the proof we need to assume certain things about the
    instantiation of Iris. The particular, even the heap is handled in an
    analogous way as other ghost state. This line states that we assume the
    Iris instantiation has sufficient structure to manipulate the heap, e.g.,
    it allows us to use the points-to predicate. *)
Context `{!heapGS Σ}.
(* Recall that parallel composition construct is defined in terms of fork. To
    prove the expected rules for this construct we need some particular ghost
    state in the instantiation of Iris, as explained in the lecture notes. The
    following line states that we have this ghost state. *)
Context `{!spawnG Σ}.
(* The variable Σ has to do with what ghost state is available, and the type
    of Iris propositions (written Prop in the lecture notes) depends on this Σ.
    But since Σ is the same throughout the development we shall define
    shorthand notation which hides it. *)
Notation iProp := (iProp Σ).
(* As in the paper proof we will need an invariant to share access to a
    location. This invariant will be allocated in this namespace which is a
    parameter of the whole development. *)
Context (N : namespace).

Lemma phase_transit_3 (l:loc):
{{{l ↦ #3 }}}
    phase_transit #l
{{{ RET #() ;  l ↦ #1}}}.
Proof.
    iIntros (Φ) "Hpt HΦ".
    unfold phase_transit.
    wp_pures.
    wp_load.

    wp_store.
    iModIntro.
    iApply "HΦ".
    iFrame.
Qed.

End proof.


Require Export Coq.funind.Recdef.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Coq.Program.Basics.

Open Scope program_scope.

Notation "V ↑ n" := (iter Type n option V) (at level 5, left associativity) : type_scope.
Notation "^ V" := (option V) (at level 4, right associativity) : type_scope.

(* [tm V] represents a term with free variables of type [V] *)
Inductive tm (V : Type) :=
| tm_var : V -> tm V
| tm_app : tm V -> tm V -> tm V
| tm_abs : tm ^V -> tm V
.
Hint Constructors tm : core.
Arguments tm_var {V}.
Arguments tm_app {V}.
Arguments tm_abs {V}.

(* [var_n n] creates the n-th de bruijn index - which is [Some^n None] *)
Fixpoint var_n {V : Type} (n : nat) : V ↑ 1 ↑ n :=
  match n with
  | 0 => None
  | S n => Some (var_n n)
  end.

Declare Custom Entry term_scope.
Notation "<{ e }>" := e (at level 1, e custom term_scope at level 99).
Notation "( x )" := x (in custom term_scope, x at level 99).
Notation "{ x }" := x (in custom term_scope at level 0, x constr).
Notation "x" := x (in custom term_scope at level 0, x constr at level 0).
Notation tm_var_n n := (tm_var (var_n n)).
Notation "0" := (tm_var_n 0) (in custom term_scope at level 0).
Notation "1" := (tm_var_n 1) (in custom term_scope at level 0).
Notation "2" := (tm_var_n 2) (in custom term_scope at level 0).
Notation "3" := (tm_var_n 3) (in custom term_scope at level 0).
Notation "4" := (tm_var_n 4) (in custom term_scope at level 0).
Notation "'var' V" := (tm_var V) (in custom term_scope at level 1, left associativity).
Notation "x y" := (tm_app x y) (in custom term_scope at level 1, left associativity).
Notation "'λ' e" :=
  (tm_abs e) (in custom term_scope at level 90,
                e custom term_scope at level 99,
                left associativity).

(* https://hal.archives-ouvertes.fr/hal-01294214/document *)
Fixpoint map {A B : Type} (f : A -> B) (e : tm A) : tm B :=
  match e with
  | <{ var a }> => <{ var {f a} }>
  | <{ e1 e2 }> => <{ {map f e1} {map f e2} }>
  | <{ λ e'  }> => <{ λ {map (option_map f) e'} }>
  end.

Notation "f <$> a" := (map f a) (at level 40, left associativity).

Lemma map_id_law : forall {V} (f : V -> V) e,
  (forall x, f x = x) ->
  f <$> e = e.
Proof.
  intros. induction e; cbn.
  - rewrite H; reflexivity.
  - rewrite IHe1; auto.
    rewrite IHe2; auto.
  - rewrite IHe; auto.
    intros [x|]; auto. cbn. rewrite H. reflexivity.
Qed.

Lemma map_comp_law : forall A e B C (f:A->B) (g:B->C),
  g <$> (f <$> e) = g ∘ f <$> e.
Proof.
  intros A; induction e; intros; auto; cbn.
  - rewrite IHe1. rewrite IHe2. reflexivity.
  - rewrite IHe. repeat f_equal. unfold option_map.
    apply functional_extensionality; intros [x|]; auto.
Qed.

Fixpoint bind {A B : Type} (f : A -> tm B) (e : tm A) : tm B :=
  match e with
  | <{ var a }> => f a
  | <{ e1 e2 }> => <{ {bind f e1} {bind f e2} }>
  | <{ λ e'  }> => tm_abs (bind (fun a' =>
      match a' with
      | None   => tm_var None
      | Some a => map Some (f a)
      end) e')
  end.

Notation "e >>= f" := (bind f e) (at level 20, left associativity).

Lemma bind_is_map : forall A e B (f:A->B),
  f <$> e = e >>= (fun v => tm_var (f v)).
Proof.
  intros A; induction e; intros; auto; cbn.
  - rewrite IHe1. rewrite IHe2. reflexivity.
  - rewrite IHe. repeat f_equal.
    apply functional_extensionality. intros [x|]; auto.
Qed.

Lemma bind_law : forall A e B C (f:A->tm B) (g:B->tm C),
  e >>= f >>= g = e >>= (fun a => f a >>= g).
Proof.
  intro A; induction e; intros; auto; cbn.
  - cbn. rewrite IHe1. rewrite IHe2. reflexivity.
  - f_equal.
    rewrite IHe. repeat f_equal.
    apply functional_extensionality. intros [x|]; cbn; auto.
    fold (@bind B).
    repeat rewrite bind_is_map.
Admitted.

(* Closed terms *)

Inductive Void : Type := .
Definition term := tm Void.

(* Closed terms - Examples *)

Example tm_id : term :=
  <{ λ 0 }>.             (* λx, x *)
Example tm_ω  : term :=
  <{ λ 0 0 }>.           (* λx, x x *)
Example tm_Ω  : term :=
  <{ (λ 0 0) (λ 0 0) }>. (* (λx, x x)(λx, x x) *)

Example tm_ω_without_notation :
  tm_abs (tm_app (tm_var None) (tm_var None)) = tm_ω.
Proof. reflexivity. Qed.

(* Failed attempt to create open terms *)
(* These definitions simply does not type check *)
Fail Example ex_tm_var : term :=
  <{ 0 }>.
Fail Example ex_tm_abs : term :=
  <{ λ 1 }>.

(* Weak Head Normal Form *)

Inductive whnf : term -> Prop :=
| val_abs : forall e, whnf <{ λ e }>
.
Hint Constructors whnf : core.

(* Substitution *)

Definition sub {V} e' (v:^V) :=
  match v with
  | None => e'
  | Some v => <{ var v }>
  end.

Definition tm_subst0 {V} (e:tm ^V) (e':tm V) :=
  e >>= sub e'.

Notation "e [ 0 := e' ]" := (tm_subst0 e e')
  (in custom term_scope at level 0,
    e custom term_scope,
    e' custom term_scope at level 99).

(* Evaluation *)

(* Reserved Notation "e1 '-->' e2" (at level 40).
Inductive step : term -> term -> Prop :=
| step_redex : forall e e',
    <{ (λ e) e' }> --> <{ e [0 := e'] }>
| step_app1 : forall e1 e2 e,
    e1 --> e2 ->
    <{ e1 e }> --> <{ e2 e }>
| step_app2 : forall e1 e2 v,
    whnf v ->
    e1 --> e2 ->
    <{ v e1 }> --> <{ v e2 }>
where "e1 '-->' e2" := (step e1 e2).
Hint Constructors step : core.

Remark tm_ω_value : ~ exists e, tm_ω --> e.
Proof. unfold tm_ω. intros [e H]. inv H. Qed.

Remark tm_Ω_reduces_to_itself : tm_Ω --> tm_Ω.
Proof. intros. unfold tm_Ω. constructor. Qed. *)

(* Types *)

(* Inductive ty :=
| ty_unit : ty
| ty_arr : ty -> ty -> ty
.
Hint Constructors ty : core.

Notation "A -> B" := (ty_arr A B) (in custom term_scope at level 50, right associativity). *)

(* Typing Context *)

(* Definition ctx V := V -> ty.

Definition emp : ctx Void := fun no => match no with end.
Notation "·" := emp.

Definition ctx_cons {V : Type} (A : ty) (Γ : ctx V) : ctx ^V :=
  fun V' =>
    match V' with
    | None => A
    | Some V => Γ V
    end.
Notation "Γ , A" := (ctx_cons A Γ) (at level 100, A custom term_scope at level 0). *)

(* Typing relation *)

(* Reserved Notation "Γ '|-' A ':' T"
  (at level 101, A custom term_scope, T custom term_scope at level 0).
Inductive has_type : forall {V}, ctx V -> tm V -> ty -> Prop :=
| var_has_type : forall {V} Γ (x : V) A,
    Γ x = A ->
    Γ |- var x : A
| abs_has_type : forall {V} Γ A B (e : tm ^V),
    Γ, A |- e : B ->
    Γ |- λ e : (A -> B)
| app_has_type : forall {V} (Γ : ctx V) B A e1 e2,
    Γ |- e1 : (A -> B) ->
    Γ |- e2 : A ->
    Γ |- e1 e2 : B
where "Γ '|-' A ':' T" := (has_type Γ A T).
Hint Constructors has_type : core.

Remark tm_id_typeable : forall (A:ty),
  · |- tm_id : (A -> A).
Proof. unfold tm_id; auto. Qed.

Remark ty_not_equi_recursive : forall A B,
  A = ty_arr A B ->
  False.
Proof.
  induction A; intros.
  - discriminate H.
  - injection H; intros; subst.
    eapply IHA1. eassumption.
Qed.

Remark tm_ω_not_typeable :
  ~ exists T, · |- tm_ω : T.
Proof.
  unfold tm_ω.
  intros [T H].
  dependent destruction H.
  dependent destruction H.
  fold · in *.
  assert (A = ty_arr A B) by (inv H; inv H0; assumption).
  eapply ty_not_equi_recursive. eassumption.
Qed. *)

(* Typing is not deterministic for Curry-style terms *)

(* Definition typing_deterministic := forall V (Γ : ctx V) e t1 t2,
  Γ |- e : t1 ->
  Γ |- e : t2 ->
  t1 = t2.

Lemma typing_is_not_deterministic : ~ typing_deterministic.
Proof.
  unfold typing_deterministic; intro H.
  set (T1 := <{ ty_unit -> ty_unit }>).
  set (T2 := <{ T1 -> T1 }>).
  assert (H1: · |- tm_id : T1) by apply tm_id_typeable.
  assert (H2: · |- tm_id : T2) by apply tm_id_typeable.
  cut (T1 = T2). intro H0; discriminate H0.
  eapply H; eauto.
Qed. *)

(* Lemma val_arr_inversion : forall v A B,
  whnf v ->
  · |- v : (A -> B) ->
  exists e', v = <{ λ e' }>.
Proof.
  intros.
  inv H0; try inv H.
  exists e. reflexivity.
Qed. *)

(* Progress *)
(* Our first main theorem: Progress - well-typed terms never get 'stuck'
  if the term [e] type-checks then it's either a value or it makes a step
  *)
(* Theorem progress : forall e A,
  · |- e : A ->
  whnf e \/ exists e', e --> e'.
Proof with try solve [right; eexists; constructor; eauto | left; constructor].
  intros e A H.
  dependent induction H; fold · in *... (* lambda case solved already: value *)
  - contradiction. (* variable case is impossible as the terms are closed *)
  - assert (whnf e1 \/ (exists e', e1 --> e')) by auto; clear IHhas_type1.
    assert (whnf e2 \/ (exists e', e2 --> e')) by auto; clear IHhas_type2.
    destruct H1 as [H1 | [e' H1]]...
    destruct H2 as [H2 | [e' H2]]...
    apply (val_arr_inversion _ A B) in H1 as [e' H1]; auto.
    subst... (* we have a redex *)
Qed. *)

(* Weakening *)
(* The second theorem we want to prove is called Preservation,
  but before we can formalize it we need:
  - Weakening lemma
  - Substitution lemma
  *)

(* Lemma compose_cons : forall V W Γ (f:V->W) A,
  Γ ∘ f, A = (Γ, A) ∘ option_map f.
Proof. intros; apply functional_extensionality; destruct x; auto. Qed.

Theorem weakening : forall V e W (f:V->W) Γ A,
  Γ ∘ f |- e : A ->
  Γ |- {f <$> e} : A.
Proof.
  induction e; intros; inv H; cbn; auto.
  - econstructor; eauto.
  - constructor. apply IHe.
    rewrite <- compose_cons. assumption.
Qed.

Notation "↑ e" := (Some <$> e) (at level 70).
Notation "Γ \ 0" := (fun v => Γ (Some v)) (at level 5).

Theorem Weakening : forall V e (Γ : ctx ^V) A,
  Γ \ 0 |-    e  : A ->
  Γ     |- {↑ e} : A.
Proof.
  intros. apply weakening in H. assumption.
  Qed.

Lemma substitution_lemma : forall V e W (f:ctx W->ctx V) (fsub:V->tm W) Γ A,
  (forall v, Γ |- {fsub v} : {f Γ v}) ->
  f Γ |- e : A ->
  Γ |- {e >>= fsub} : A.
Proof.
  induction e; intros W f fsub Γ A Hv He; inv He; cbn; auto; econstructor; eauto.
  apply IHe with (f := fun _ => f Γ, A); auto.
  intros [v|]; cbn; auto.
  apply weakening.
  assert (HΓ: (Γ, A) ∘ Some = Γ) by (apply functional_extensionality; auto).
  rewrite HΓ. apply Hv.
Qed.

Lemma Substitution_lemma : forall V e (e':tm V) Γ A B,
  Γ, B |- e : A ->
  Γ |- e' : B ->
  Γ |- e [0 := e'] : A.
Proof.
  intros V e e' Γ A B He He'.
  apply (substitution_lemma ^V e V (ctx_cons B) (sub e') Γ A); auto.
  intros [v|]; cbn; auto.
Qed. *)

(* Preservation *)

(* Theorem preservation : forall e e',
  e --> e' -> forall A,
  · |- e  : A ->
  · |- e' : A.
Proof.
  intros e e' Hstep.
  induction Hstep; intros A He; inv He; fold · in *.
  - inv He1. fold · in *.
    eapply Substitution_lemma; eauto.
  - apply IHHstep in He1.
    econstructor; eauto.
  - apply IHHstep in He2.
    econstructor; eauto.
  Qed. *)

(* Full normalization *)

(* Inductive nval : forall {V}, tm V -> Prop :=
| nval_var : forall V (v : V),
    nval <{ var v }>
| nval_app_var : forall V e (v : V),
    nval e ->
    nval <{ (var v) e }>
| nval_app : forall V (e1 e2 e : tm V),
    nval <{ e1 e2 }> ->
    nval e ->
    nval <{ e1 e2 e }>
| nval_abs : forall V (e : tm ^V),
    nval e ->
    nval <{ λ e }>
.
Hint Constructors nval : core.

Reserved Notation "t1 '-->n' t2" (at level 40).
Inductive norm : forall {V}, tm V -> tm V -> Prop :=
| norm_redex : forall V e (e' : tm V),
    <{ (λ e) e' }> -->n <{ e [0 := e'] }>
| norm_app1 : forall V (e1 e2 e : tm V),
    e1 -->n e2 ->
    <{ e1 e }> -->n <{ e2 e }>
| norm_app2 : forall V (e1 e2 v : tm V),
    nval v ->
    e1 -->n e2 ->
    <{ v e1 }> -->n <{ v e2 }>
| norm_abs : forall V (e1 e2 : tm ^V),
    e1 -->n e2 ->
    <{ λ e1 }> -->n <{ λ e2 }>
where "t1 '-->n' t2" := (norm t1 t2).
Hint Constructors norm : core.

Lemma nval_no_steps : forall V (e : tm V),
  nval e ->
  ~ exists e', e -->n e'.
Proof with eauto.
  intros V e Hval [e' H].
  induction Hval; inv H...
  inv H...
  Qed. *)

(* Theorem open_preservation : forall V (e e' : tm V),
  e -->n e' -> forall Γ A,
  Γ |- e  : A ->
  Γ |- e' : A.
Proof.
  intros V e e' Hstep.
  induction Hstep; intros Γ t0 He; inv He; try (econstructor; eauto).
  - inv He1.
    eapply Substitution_lemma; eauto.
  Qed.

Theorem open_progress : forall V Γ (e : tm V) A,
  Γ |- e : A ->
  nval e \/ exists e', e -->n e'.
Proof with try solve [right; eexists; eauto | left; auto].
  intros V Γ e A H.
  dependent induction H...
  - destruct IHhas_type  as [H0 | [e' H0]]...
  - destruct IHhas_type1 as [H1 | [e' H1]]... (* e1 makes a step *)
    destruct IHhas_type2 as [H2 | [e' H2]]... (* e2 makes a step *)
    destruct H1... (* either an app value [x e1 .. en] or redex *)
Qed. *)


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

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

Print Assumptions mul.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime AB CD : Universe, ((wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (col_ O E AB /\ col_ O E CD)))) -> col_ O AB CD)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


Require Import Verdi.Verdi.
Require Import FunctionalExtensionality.
Require Import Verdi.SeqNum.

Section SeqNumCorrect.
  Context {orig_base_params : BaseParams}.
  Context {orig_multi_params : MultiParams orig_base_params}.

  Lemma processPackets_correct :
    forall n l n' l',
      processPackets n l = (n', l') ->
      forall p,
        In p l' ->
        n' > (tmNum (snd p)).
  Proof using.
    induction l; intros; simpl in *.
    - find_inversion. simpl in *. intuition.
    - break_match. find_inversion. simpl in *. intuition.
      + subst. simpl. omega.
      + eauto using le_gt_trans, le_plus_l.
  Qed.

  Lemma processPackets_num_monotonic :
    forall n l n' l',
      processPackets n l = (n', l') ->
      n' >= n.
  Proof using.
    induction l; intros; simpl in *.
    - intros. find_inversion. intuition.
    - break_match. find_inversion.
      find_insterU. find_insterU. conclude_using eauto.
      omega.
  Qed.

  Lemma processPackets_ge_start :
    forall n l n' l',
      processPackets n l = (n', l') ->
      forall p,
        In p l' ->
        n <= (tmNum (snd p)).
  Proof using.
    induction l; intros; simpl in *.
    - invcs H. intuition.
    - break_match.
      invcs H. intuition.
      + subst. simpl.
        apply processPackets_num_monotonic in Heqp0. intuition.
      + specialize (IHl n0 l0). apply IHl; auto.
  Qed.

  Unset Regular Subst Tactic.

  Lemma processPackets_nums_unique :
    forall n l n' l' p p',
      processPackets n l = (n', l') ->
      In p l' ->
      In p' l' ->
      p <> p' ->
      (tmNum (snd p)) <> (tmNum (snd p')).
  Proof using.
    induction l; intros; simpl in *.
    - invcs H. intuition.
    - break_match. invcs H.
      intuition.
      + subst. intuition.
      + subst. simpl in *.
        apply processPackets_correct with (p := p') in Heqp0; intuition.
      + subst. simpl in *.
        apply processPackets_correct with (p := p) in Heqp0; intuition.
      + apply IHl with n0 l0 p p'; intuition.
  Qed.

  Set Regular Subst Tactic.

  Lemma processPackets_seq_eq :
    forall n l n' l' x y,
      processPackets n l = (n', l') ->
      In x l' ->
      In y l' ->
      tmNum (snd x) = tmNum (snd y) ->
      x = y.
  Proof using.
    induction l; intros; simpl in *.
    - find_inversion. simpl in *. intuition.
    - break_match. find_inversion. simpl in *.
      intuition; subst; simpl in *; eauto;
      subst; eapply processPackets_correct in Heqp; eauto; omega.
  Qed.

  Lemma processPackets_NoDup : forall n l n' l',
                                  processPackets n l = (n', l') ->
                                  NoDup l'.
  Proof using.
    induction l; intros.
    - simpl in *. find_inversion. constructor.
    - simpl in *. break_match. find_inversion.
      specialize (IHl n0 l0). concludes.
      constructor; auto.
      intro.
      eapply processPackets_correct in H; eauto.
      simpl in *. omega.
  Qed.

  Lemma processPackets_preserves_messages :
    forall n l,
      map (fun p => (fst p, tmMsg (snd p))) (snd (processPackets n l)) = l.
  Proof using.
    induction l.
    - auto.
    - simpl. break_match. simpl in *. rewrite IHl. destruct a. auto.
  Qed.

  Definition orig_packet := @packet _ orig_multi_params.
  Definition orig_network := @network _ orig_multi_params.
  Definition seq_num_packet := @packet _ multi_params.
  Definition seq_num_network := @network _ multi_params.

  Definition revertPacket (p : seq_num_packet) : orig_packet :=
    @mkPacket _ orig_multi_params (pSrc p) (pDst p) (tmMsg (pBody p)).

  Definition pkt_eq_dec (x y : seq_num_packet) : {x = y} + {x <> y}.
    decide equality.
    - apply msg_eq_dec.
    - apply name_eq_dec.
    - apply name_eq_dec.
  Defined.

  Definition revertNetwork (net: seq_num_network) : orig_network :=
    mkNetwork
      (map revertPacket
           (filter (fun (p : seq_num_packet) =>
                      if member (tmNum (pBody p)) (assoc_default name_eq_dec (tdSeen (nwState net (pDst p))) (pSrc p) [])
                      then false else true)
                   (dedup pkt_eq_dec (nwPackets net))))
      (fun h => (tdData (nwState net h))).

  Lemma network_eq (net net' : orig_network) :
    nwState net = nwState net' ->
    nwPackets net = nwPackets net' ->
    net = net'.
  Proof using.
    intros; destruct net, net'.
    simpl in *.
    subst.
    auto.
  Qed.

  Definition sequence_sane (net : seq_num_network) :=
    (forall p,
       In p (nwPackets net) ->
       tmNum (pBody p) < (tdNum ((nwState net) (pSrc p)))).

  Lemma reachable_sane :
    true_in_reachable step_dup step_async_init sequence_sane.
  Proof using.
    apply inductive_invariant_true_in_reachable. unfold inductive_invariant, inductive.
    unfold sequence_sane. simpl in *. intuition.
    match goal with
      | [ H : step_dup _ _ _ |- _ ] =>
        invcs H
    end; try find_inversion.
    - (* deliver case *)
      unfold seq_num_net_handlers in *.
      simpl in *.
      do_in_app. intuition.
      + (* p is a new packet *)
        do_in_map.
        subst; simpl in *.
        repeat break_match; try find_inversion; simpl in *; intuition.
        eapply processPackets_correct; eauto.
      + (* p is an old packet *)
        simpl in *.
        repeat find_rewrite.
        do_in_app.
        repeat break_match; try find_inversion.
        * rewrite <- e. intuition.
        * apply processPackets_num_monotonic in Heqp0.
          apply lt_le_trans with (m := (tdNum (nwState a (pDst p0)))); auto.
          rewrite <- e. intuition.
        * intuition.
        * intuition.
    - unfold seq_num_input_handlers in *. simpl in *. do_in_app. intuition.
      + do_in_map. subst; simpl in *.
        repeat break_match; try find_inversion; simpl in *; intuition.
        eapply processPackets_correct; eauto.
      + simpl in *.
        repeat break_match; try find_inversion;
        simpl in *; find_apply_lem_hyp processPackets_num_monotonic;
        find_apply_hyp_hyp; try omega.
    - in_crush; eauto with *.
  Qed.

  Definition sequence_seen (net : seq_num_network) :=
    forall h h' n,
      In n (assoc_default name_eq_dec (tdSeen (nwState net h')) h []) ->
      n < (tdNum (nwState net h)).

  Lemma reachable_seen :
    true_in_reachable step_dup step_async_init sequence_seen.
  Proof using.
    apply true_in_reachable_reqs;
    unfold sequence_seen; simpl in *; intuition.
    find_apply_lem_hyp reachable_sane.
    unfold sequence_sane in *.
    match goal with H : step_dup _ _ _ |- _ => invcs H end.
    - (* step case *)
      unfold seq_num_net_handlers in *.
      repeat (break_match; try find_inversion; simpl in *; eauto);
      match goal with
        | [ H : processPackets _ _ = _ |- _ ] =>
          apply processPackets_num_monotonic in H
      end;
      try break_if; simpl in *; intuition; subst; eauto;
      repeat find_rewrite; (eapply lt_le_trans; [|eauto]; eauto).
      * case (name_eq_dec (pSrc p) (pDst p)); intro.
        + rewrite <- e in H2.
          rewrite get_set_same_default in H2.
          rewrite e in H2.
          case H2; intro.
          -- rewrite <- H.
             rewrite <- e.
             eapply H0.
             apply in_or_app.
             right; left.
             auto.
          -- eapply H1; eauto.
        + match goal with
          | [H: In _ (assoc_default _ (assoc_set _ _ _ _) _ _) |- _ ] =>
            rewrite get_set_diff_default in H
          end; eauto.
      * case (name_eq_dec (pSrc p) h); intro.
        + rewrite <- e in H2.
          rewrite get_set_same_default in H2.
          rewrite e in H2.
          case H2; intro.
          -- rewrite <- H.
             rewrite <- e.
             eapply H0.
             apply in_or_app.
             right; left.
             auto.
          -- eapply H1; eauto.
        + match goal with
          | [H: In _ (assoc_default _ (assoc_set _ _ _ _) _ _) |- _ ] =>
            rewrite get_set_diff_default in H
          end; eauto.
    - unfold seq_num_input_handlers in *.
      repeat (break_match; try find_inversion; simpl in *; eauto);
      match goal with
        | [ H : processPackets _ _ = _ |- _ ] =>
          apply processPackets_num_monotonic in H
      end;
      try break_if; simpl in *; intuition; subst; eauto;
      repeat find_rewrite;
      (eapply lt_le_trans; [|eauto]; eauto).
    - eauto.
  Qed.

  Definition sequence_equality (net : seq_num_network) :=
    forall p p',
      In p (nwPackets net) ->
      In p' (nwPackets net) ->
      (tmNum (pBody p)) = (tmNum (pBody p')) ->
      pSrc p = pSrc p' ->
      p = p'.

  Theorem reachable_equality :
    true_in_reachable step_dup step_async_init sequence_equality.
  Proof using.
    apply true_in_reachable_reqs;
    unfold sequence_equality; simpl in *; intuition.
    match goal with
        H : reachable _ _ _ |- _ =>
        apply reachable_sane in H
    end.
    unfold sequence_sane, sequence_equality in *.
    intros.
    match goal with H : step_dup _ _ _ |- _ => invcs H end; simpl in *; find_inversion.
    - unfold seq_num_net_handlers in *.
      repeat do_in_app.
      repeat find_rewrite.
      repeat break_match; find_inversion; simpl in *; intuition;
      repeat do_in_map; subst; simpl in *.
      + repeat do_in_app. intuition.
      + find_inversion.
        match goal with
          | x : prod _ _, x' : prod _ _ |- _ =>
            replace x with x' by (eapply processPackets_seq_eq; eauto)
        end; auto.
      + match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
      + find_inversion.
        match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
      + match goal with
            H : forall _ _ : packet, In _ _ -> _ |- ?p = ?p' =>
            specialize (H p p'); repeat (forward H; [in_crush|]; concludes)
        end; auto.
    - unfold seq_num_input_handlers in *.
      repeat do_in_app.
      repeat break_match; find_inversion; simpl in *; intuition;
      repeat do_in_map; subst; simpl in *.
      + find_inversion.
        match goal with
          | x : prod _ _, x' : prod _ _ |- _ =>
            replace x with x' by (eapply processPackets_seq_eq; eauto)
        end; auto.
      + match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
      + find_inversion.
        match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
    - repeat find_rewrite. in_crush.
  Qed.

  Lemma revertNetwork_In :
    forall net (p : seq_num_packet),
      In p (nwPackets net) ->
      ~ In (tmNum (pBody p)) (assoc_default name_eq_dec (tdSeen (nwState net (pDst p))) (pSrc p) []) ->
      In (revertPacket p) (nwPackets (revertNetwork net)).
  Proof using.
    intros. unfold revertNetwork. simpl in *.
    in_crush.
    apply filter_In. intuition.
    - apply dedup_In. auto.
    - break_if; intuition.
  Qed.

  Lemma revertNetwork_packets :
    forall xs net (p : seq_num_packet) ys,
      ~ In (tmNum (pBody p)) (assoc_default name_eq_dec (tdSeen (nwState net (pDst p))) (pSrc p) []) ->
      nwPackets net = xs ++ p :: ys ->
      exists xs' ys',
        nwPackets (revertNetwork net) =
        xs' ++ (revertPacket p) :: ys'.
  Proof using.
    intros.
    apply in_split. apply revertNetwork_In; repeat find_rewrite; in_crush.
  Qed.

  Lemma processPackets_dedup :
    forall processed (rest : list seq_num_packet) n' l h net,
      (forall p, In p rest -> In p (nwPackets net)) ->
      sequence_sane net ->
      processPackets (tdNum (nwState net h)) l = (n', processed) ->
      dedup pkt_eq_dec ((@send_packets _ multi_params h processed) ++ rest)
      = (send_packets h processed) ++ (dedup pkt_eq_dec rest).
  Proof using.
    intros. simpl in *.
    rewrite dedup_app; f_equal.
    - apply dedup_NoDup_id.
      apply NoDup_map_injective; eauto using processPackets_NoDup.
      intros. find_inversion.
      rewrite surjective_pairing at 1.
      rewrite surjective_pairing.
      unfold msg in *. simpl in *.
      repeat find_rewrite. auto.
    - intuition.
      subst.
      find_apply_lem_hyp in_map_iff. break_exists. intuition.
      find_eapply_lem_hyp processPackets_ge_start; eauto.
      match goal with
        | _ : In ?p _, net : network |- _ =>
          assert (In p (nwPackets net)) by eauto
      end.
      unfold sequence_sane in *.
      find_apply_hyp_hyp. simpl in *. subst. simpl in *. omega.
  Qed.

  Lemma revertNetwork_deliver_step :
    forall (st : seq_num_network) p xs ys (d : @data orig_base_params) l l' n,
      sequence_sane st ->
      sequence_seen st ->
      sequence_equality st ->
      nwPackets st = xs ++ p :: ys ->
      ~ In (tmNum (pBody p)) (assoc_default name_eq_dec (tdSeen (nwState st (pDst p))) (pSrc p) []) ->
      processPackets (tdNum (nwState st (pDst p))) l = (n, l') ->
      exists xs' ys',
        nwPackets (revertNetwork st) = xs' ++ revertPacket p :: ys' /\
        revertNetwork
          (@mkNetwork _ multi_params
                      (map
                         (fun m : name * seq_num_msg =>
                            {| pSrc := pDst p; pDst := fst m; pBody := snd m |})
                         l' ++ xs ++ ys)
                      (update name_eq_dec (nwState st) (pDst p)
                              (@mkseq_num_data _ orig_multi_params
                                               n
                                               (assoc_set name_eq_dec
                                                  (tdSeen (nwState st (pDst p))) (pSrc p)
                                                  (tmNum (pBody p) :: assoc_default name_eq_dec (tdSeen (nwState st (pDst p))) (pSrc p) []))
                                               d)))
        = {|
          nwPackets := (@send_packets _ orig_multi_params (pDst p) l) ++ xs' ++ ys';
          nwState := update name_eq_dec (nwState (revertNetwork st)) (pDst p) d
        |}.
  Proof using.
    intros.
    simpl in *.
    unfold revertNetwork.
    simpl in *.
    repeat find_rewrite.
    match goal with
        [ |- context [ dedup ?eq (map ?f ?l ++ ?xs ++ ?ys) ] ] =>
        assert (dedup eq (map f l ++ xs ++ ys) = (map f l) ++ (dedup eq (xs ++ ys)))
          by (find_eapply_lem_hyp processPackets_dedup;
              eauto; repeat find_rewrite; in_crush)
    end.
    find_rewrite.
    rewrite filter_app.
    rewrite map_app.
    assert (In p (nwPackets st)) by (find_rewrite; in_crush).
    match goal with
      | H : In _ _ |- _ =>
        apply dedup_In with (A_eq_dec := pkt_eq_dec) in H
    end.
    find_apply_lem_hyp in_split. break_exists. repeat find_rewrite.
    find_copy_apply_lem_hyp dedup_partition.
    unfold seq_num_packet in *.
    repeat find_rewrite.
    assert (NoDup (x ++ p :: x0)) by (repeat find_reverse_rewrite; apply NoDup_dedup).
    match goal with
      | [ |- context [ filter ?f (?xs ++ ?p :: ?ys) ] ] =>
        assert (In p (filter f (xs ++ p :: ys)))
          by (apply filter_In; repeat break_if; intuition)
    end. find_apply_lem_hyp in_split. break_exists.
    repeat find_rewrite.
    exists (map revertPacket x1), (map revertPacket x2).
    intuition; map_crush; auto.
    simpl in *.
    f_equal. f_equal.
    - rewrite filter_true_id.
      + match goal with
          | _ : processPackets ?n ?l = _ |- _ =>
            rewrite <- (processPackets_preserves_messages n l)
        end.
        find_rewrite. simpl in *.
        unfold revertPacket.
        repeat rewrite map_map. auto.
      + intros.
        in_crush.
        find_eapply_lem_hyp processPackets_ge_start; [|eauto].
        match goal with
            p : packet |- _ =>
            assert (tmNum (pBody p) < tdNum (nwState st (pSrc p))) by
                (eapply_prop sequence_sane; find_rewrite; in_crush)
        end.
        repeat (break_if; simpl in *; repeat find_rewrite; intuition);
          unfold sequence_seen in *.
        -- case (name_eq_dec (pSrc p) (pDst p)); intro.
           ++ rewrite <- e0 in i.
             rewrite get_set_same_default in i.
             rewrite e0 in i.
             case i; intro.
             ** rewrite <- H12 in H11.
                rewrite <- e0 in H11.
                omega.
             ** pose proof (H0 _ _ _ H12).
                omega.
           ++ match goal with
             | [H: In _ (assoc_default _ (assoc_set _ _ _ _) _ _) |- _ ] =>
               rewrite get_set_diff_default in H
             end; auto.
             pose proof (H0 _ _ _ i).
             omega.
        -- pose proof (H0 _ _ _ i).
           omega.
    - rewrite <- filter_except_one
      with (f := (fun p0 : seq_num_packet =>
                   if member (tmNum (pBody p0)) (assoc_default name_eq_dec (tdSeen (nwState st (pDst p0))) (pSrc p0) [])
                   then false
                   else true)) (x := p) (A_eq_dec := pkt_eq_dec).
      + unfold seq_num_packet in *. repeat find_rewrite.
        rewrite filter_app.
        find_apply_lem_hyp filter_partition; intuition.
        repeat find_rewrite. eauto using map_app.
      + intros. repeat (break_if; simpl in *; repeat find_rewrite; intuition).
        -- contradict n0.
           case (name_eq_dec (pSrc p) (pSrc y)); intro.
           ** rewrite <- e0.
              rewrite get_set_same_default.
              right.
              rewrite e0.
              auto.
           ** rewrite get_set_diff_default; auto.
        -- exfalso.
           match goal with H : _ = _ -> False |- _ => apply H end.
           eapply_prop sequence_equality; repeat find_rewrite; in_crush.
           ** find_apply_lem_hyp in_dedup_was_in. in_crush.
           ** case (name_eq_dec (pSrc p) (pSrc y)); intro.
              ++ rewrite e0 in i.
                rewrite get_set_same_default in i.
                case i; intro; intuition.
              ++ rewrite get_set_diff_default in i; intuition.
           ** case (name_eq_dec (pSrc p) (pSrc y)); intro; auto.
              rewrite get_set_diff_default in i; intuition.
      + repeat (break_if; simpl in *; intuition).
        contradict n0.
        rewrite get_set_same_default.
        left; auto.
    - apply functional_extensionality. intros; repeat break_if; simpl in *; intuition.
  Qed.

  Theorem revertNetwork_input :
    forall (st : seq_num_network) h (d : @data orig_base_params) l l' n,
      sequence_sane st ->
      sequence_seen st ->
      sequence_equality st ->
      processPackets (tdNum (nwState st h)) l = (n, l') ->
      revertNetwork
        (@mkNetwork _ multi_params
                    (send_packets h l' ++ nwPackets st)
                    (update name_eq_dec (nwState st) h
                            (@mkseq_num_data _ orig_multi_params
                                             n
                                             (tdSeen (nwState st h))
                                             d)))
        = {|
          nwPackets := (@send_packets _ orig_multi_params h l) ++ (nwPackets (revertNetwork st));
          nwState := update name_eq_dec (nwState (revertNetwork st)) h d
        |}.
  Proof using.
    intros.
    unfold revertNetwork.
    simpl in *.
    match goal with
        [ |- context [ dedup ?eq (map ?f ?l ++ ?l') ] ] =>
        assert (dedup eq (map f l ++ l') = (map f l) ++ (dedup eq l'))
          by (find_eapply_lem_hyp processPackets_dedup;
              eauto; repeat find_rewrite; in_crush)
    end.
    find_rewrite.
    rewrite filter_app. rewrite map_app. f_equal. f_equal.
    - rewrite filter_true_id.
      + match goal with
          | _ : processPackets ?n ?l = _ |- _ =>
            rewrite <- (processPackets_preserves_messages n l)
        end.
        find_rewrite. simpl in *.
        unfold revertPacket.
        repeat rewrite map_map. auto.
      + intros.
        in_crush.
        find_eapply_lem_hyp processPackets_ge_start; [|eauto].
        repeat (break_if; simpl in *; repeat find_rewrite; intuition);
          unfold sequence_seen in *; find_apply_hyp_hyp; omega.
    - f_equal. apply filter_fun_ext_eq.
      intros. repeat (break_if; simpl in *; repeat find_rewrite; intuition).
    - apply functional_extensionality. intros; repeat break_if; simpl in *; intuition.
  Qed.

  (* We need this for dedup_eliminates_duplicates *)
  Arguments dedup _ _ _ : simpl nomatch.

  Lemma reachable_revert_step :
    forall st st' tr,
      reachable step_dup step_async_init st ->
      step_dup st st' tr ->
      step_async (revertNetwork st) (revertNetwork st') tr \/
      (revertNetwork st = revertNetwork st' /\ filterMap trace_non_empty_out tr = []).
  Proof using.
    intros.
    find_copy_apply_lem_hyp reachable_sane.
    find_copy_apply_lem_hyp reachable_seen.
    find_copy_apply_lem_hyp reachable_equality.
    break_exists.
    match goal with H : step_dup _ _ _ |- _ => invcs H end.
    - unfold seq_num_net_handlers in *.
      match goal with
      | [H : context [ if _ then _ else _ ] |- _] =>
        revert H
      end.
      break_if; intros.
      + right. find_inversion. simpl in *.
        unfold revertNetwork. simpl in *. intuition.
        f_equal.
        * f_equal. find_rewrite. symmetry.
          match goal with
            | |- filter ?f _ = filter ?g _ =>
              assert (f = g) by
                  (apply functional_extensionality;
                   intros; repeat break_if; repeat find_rewrite; intuition)
          end.
          find_rewrite.
          apply filter_dedup.
          break_if; intuition.
        * apply functional_extensionality.
          intros. break_if; subst; intuition.
      + left. repeat break_let. find_inversion.
        match goal with
        | [ H : processPackets _ _ = _, H' : net_handlers _ _ _ _ = (_, d0, _) |- _ ] =>
          eapply revertNetwork_deliver_step with (d := d0) in H; eauto
        end.
        break_exists.
        break_and.
        match goal with
        | [H : nwPackets _ = _ |- _ ] =>
          eapply (StepAsync_deliver _ _ _ _ H); eauto
        end.
    - left. unfold seq_num_input_handlers in *. repeat break_let.
      find_inversion.
      find_eapply_lem_hyp revertNetwork_input; eauto.
      econstructor 2; simpl; eauto.
    - right.
      split; auto.
      unfold revertNetwork.
      f_equal. f_equal. f_equal.
      simpl. find_rewrite. eauto using dedup_eliminates_duplicates.
  Qed.

  Lemma step_dup_star_revert_simulation :
    forall net tr,
      step_dup_star step_async_init net tr ->
      exists tr', step_async_star step_async_init (revertNetwork net) tr' /\
      filterMap trace_non_empty_out tr = filterMap trace_non_empty_out tr'.
  Proof using.
    intros.
    remember step_async_init as y in *.
    revert Heqy.
    induction H using refl_trans_1n_trace_n1_ind; simpl; intros.
    - find_rewrite.
      exists []; simpl.
      split; auto.
      apply RT1nTBase.
    - concludes.
      subst.
      break_exists_name tr'.
      break_and.
      assert (H_r: reachable step_dup step_async_init x') by (exists tr1; auto).
      eapply reachable_revert_step in H_r; eauto.
      break_or_hyp.
      * exists (tr' ++ tr2); split.
        + eapply refl_trans_1n_trace_trans; eauto.
          rewrite (app_nil_end tr2).
          eapply RT1nTStep; eauto.
          apply RT1nTBase.
        + rewrite filterMap_app.
          rewrite filterMap_app.
          find_reverse_rewrite.
          reflexivity.
      * break_and.
        find_rewrite.
        exists tr'; split; simpl; auto.
        match goal with
        | [H : filterMap _ _ = filterMap _ _ |- _ ] =>
          rewrite <- H
        end.
        rewrite filterMap_app.
        destruct tr2; simpl in *; [ rewrite <- app_nil_end | idtac ]; auto.
        match goal with
        | [H : _ = [] |- _ ] =>
          rewrite H
        end.
        rewrite <- app_nil_end; auto.
  Qed.

  Theorem reachable_revert :
    true_in_reachable step_dup step_async_init
                      (fun st =>
                         reachable step_async step_async_init (revertNetwork st)).
  Proof using.
    apply true_in_reachable_reqs.
    - unfold revertNetwork. simpl.
      unfold reachable. exists []. constructor.
    - intros.
      find_apply_lem_hyp reachable_revert_step; auto.
      intuition.
      + unfold reachable in *.
        break_exists.
        eexists.
        apply refl_trans_n1_1n_trace.
        econstructor; eauto using refl_trans_1n_n1_trace.
      + find_rewrite. auto.
  Qed.

  Theorem true_in_reachable_transform :
    forall P,
      true_in_reachable step_async step_async_init P ->
      true_in_reachable step_dup step_async_init (fun net => P (revertNetwork net)).
  Proof using.
    intros. find_apply_lem_hyp true_in_reachable_elim. intuition.
    apply true_in_reachable_reqs; eauto.
    intros. find_copy_apply_lem_hyp reachable_revert.
    find_apply_lem_hyp reachable_revert_step; auto.
    intuition.
    - break_exists. eauto.
    - repeat find_rewrite. auto.
  Qed.
End SeqNumCorrect.


Require Import Coq.Bool.Bool.
Require Import ExtLib.Structures.Monoid.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.Bool.
Require Import Markov.Random.
Require Import Markov.RandomM.

Import MonadNotation.
Local Open Scope monad_scope.

(** [P T] is a computable probability distribution on [T] *)
Definition P (T : Type) : Type := PD T.

(** Markov Decision Process *)
Record MDP : Type :=
{ State  : Type
; Action : Type
; Trans  : State -> Action -> P State
; Obs    : Type
; Look   : State -> P Obs
}.

(** The meaning of an MDP as a program
 **)
Section mdp.
  Variable m : MDP.

  Definition step (s : m.(State)) (a : m.(Action)) : PD (m.(State) * m.(Obs)) :=
    s' <- m.(Trans) s a ;;
    o <- m.(Look) s' ;;
    ret (s', o).

  Fixpoint mfold (n : nat) {S O} (M : Monoid O) (m : S -> PD (S * O)) (s : S) (o : O) : PD (S * O) :=
    match n with
    | O => ret (s, o)
    | S n => x <- m s ;;
             let (s',o') := x in
             mfold n M m s' (monoid_plus M o o')
    end.

End mdp.

Section on_off.

  Definition on_off : MDP :=
  {| State  := bool
   ; Action := unit
   ; Trans  := fun s _ =>
                 x <- fair_coin ;;
                 if x then ret s
                 else ret (negb s)
   ; Obs    := bool
   ; Look   := fun s =>
                 x <- fair_coin (* flip {| QArith_base.Qnum := 3 ; QArith_base.Qden := 4 |} *) ;;
                 if x then ret s
                 else ret (negb s)
   |}.

End on_off.

Definition tracer (n : nat) (m : MDP) (s : m.(State)) (z : m.(Action)) : PD (list m.(Obs)) :=
  x <- mfold n (@Monoid_list_app m.(Obs))
               (fun s =>
                  x <- step m s z ;;
                  ret (fst x, snd x :: nil)) s nil ;;
  ret (snd x).

Eval vm_compute
  in let samples := 100 in
     let length := 3 in
     sample_discrete samples (x <- fair_coin ;;
                              tracer length on_off x tt)%monad.


(* An example of type inference *)

Axiom A : Type.
Definition f (x y : A) := x.
Axiom g : forall x y : A, f x y = y -> Prop.
Axiom x : A.
Check (g x _ (refl_equal x)).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a4_ : Universe.
Variable a3_ : Universe.
Variable a2_ : Universe.
Variable a1_ : Universe.

Variable ax1_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ dom_ a4_))).
Variable ax2_2 : (forall A1 A2 A3 A4 : Universe, ((dom_ A1 /\ (dom_ A2 /\ (dom_ A3 /\ dom_ A4))) -> p_ A1 A2 A3 A4)).
Variable ax3_3 : (p_ a4_ a3_ a2_ a1_ -> goal_).

Theorem lemma4_4 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import String.
Require Import Lia.
Require Import List.
Require Import Nat.
Require Import Coq.Vectors.Vector.
Require Import Coq.Vectors.VectorEq.
Require Import Coq.Arith.Bool_nat.
Require Export Coq.Arith.Compare_dec.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export RelationClasses.
Require Export Morphisms.
Require Import Program.
From ST Require Import EVarsScratchwork.
From ST Require Import Vector.
From ST Require Export Logic.V Logic.Term.
From ST Require Export SoftType.Radix SoftType.Adjective.
Import ListNotations.
Import VectorNotations.
Open Scope string_scope.
(* ** Soft Types

We can encode a [SoftType] as an ordered pair of a list of [Adjective] and
a [Radix] type.
*)
Definition SoftType : Type := (list Adjective)*Radix.
Definition Star : SoftType := (List.nil, Ast).

Definition arity (T : SoftType) : nat :=
  match T with
  | (_, R) => Radix.arity R
  end.

Global Instance EqSoftType : Eq SoftType := {
  eqb (T1 T2 : SoftType) :=
  match T1,T2 with
  | (adjs1, R1), (adjs2, R2) => andb (list_eqb adjs1 adjs2 eqb) (eqb R1 R2)
  end
}.

Global Instance substSoftType : Subst SoftType := {
  subst (x : V) (t : Term) (T : SoftType) :=
  match T with
  | (List.nil, R) => (List.nil, subst x t R)
  | (adjs, R) => (List.map (fun (a : Adjective) => subst x t a) adjs, subst x t R)
  end
}.

Global Instance liftSoftType : Lift SoftType :=
{
  lift (c d : nat) (T : SoftType) :=
  match T with
  | (adjs, R) => (List.map (fun (a : Adjective) => (lift c d a)) adjs, lift c d R)
  end;
  unlift (c d : nat) (T : SoftType) :=
  match T with
  | (adjs, R) => (List.map (fun (a : Adjective) => (unlift c d a)) adjs, unlift c d R)
  end
}.

Global Instance EnumerateEVarsSoftType : EnumerateEVars SoftType := {
list_evars T := match T with
| (adjectives,T) => List.fold_left (fun l' => fun (adj : Adjective) => insert_merge (list_evars adj) l')
 adjectives (list_evars T)
end
}.

Theorem list_evars_soft_type_sorted : forall (T : SoftType),
  sorted (list_evars T).
Proof. intros. destruct T.
  assert (sorted (list_evars r)). { apply list_evars_radix_sorted. }
  unfold list_evars; unfold EnumerateEVarsSoftType.
  apply insert_merge_list_fold_sorted2 with (init := list_evars r).
  assumption.
Qed.

(** *** Miscellaneous predicates concerning soft types *)
Definition type_is_named (T : SoftType) (n : name) : Prop :=
  match T with
  | (_, Mode k1 s1 args1) => n = s1
  | _ => False
  end.

Definition mk_mode {n} (M : name) (args : Vector.t Term n) : SoftType :=
  (List.nil, (Mode n M args)).

Definition prefix (a : Adjective) (T : SoftType) : SoftType :=
  match T with
  | (adjs, R) => (* if List.existsb (fun (adj : Adjective) => eqb a adj) adjs
                 then T else *) (List.cons a adjs, R)
  end.

Fixpoint prefix_all (adjs : list Adjective) (T : SoftType) : SoftType :=
  match adjs with
  | List.nil => T
  | List.cons a ad2 => prefix_all ad2 (prefix a T)
  end.

Definition non (a : Adjective) : Adjective :=
  match a with
  | Pos attr => Neg attr
  | Neg attr => Pos attr
  end.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Limits.Limit Limits.GenProd_GenSum.
Require Import Archetypal.Discr.Discr.
Require Import Basic_Cons.Terminal.

(** In category of types, generalized products are simply dependent prdoducts. *)
Section Type_Cat_GenProd.
  Context (A : Type) (map : A → Type).

  Local Notation Fm := (Discr_Func Type_Cat map) (only parsing).

  Program Definition Type_Cat_GenProd_Cone : Cone Fm :=
    {|
      cone_apex := {|FO := fun _ => ∀ x : A, (Fm _o x)%object; FA := fun _ _ _ h => h|};
      cone_edge := {|Trans := fun x y => y x |}
    |}.

  Program Definition Type_Cat_GenProd : @GenProd _ Type_Cat map :=
    {|
      LRKE := Type_Cat_GenProd_Cone;
      LRKE_morph_ex :=
        fun Cn =>
          {|
            cone_morph :=
              {|Trans :=
                  fun c X x  =>
                    match c as u return ((Cn _o)%object u → map x) with
                    | tt => fun X : (Cn _o)%object tt => Trans Cn x X
                    end X
              |}
          |}
    |}.

  Next Obligation.
  Proof.
    destruct c; destruct c'; destruct h.
    extensionality x; extensionality y.
    apply (equal_f ((@Trans_com _ _ _ _ Cn) y y eq_refl) x).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Type_Cat_GenProd_obligation_1.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y; extensionality z.
    destruct x.
    set (hc := (cone_morph_com h')).
    rewrite (cone_morph_com h) in hc.
    set (hc' := (f_equal (fun w :
                  ((Cn ∘ (Functor_To_1_Cat (Discr_Cat A))) –≻ Fm)%nattrans =>
           Trans w z y) hc)); clearbody hc'; clear hc.
    trivial.
  Qed.

End Type_Cat_GenProd.


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

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

Print Assumptions square.


Require
  MathClasses.misc.JMrelation.
Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.functors MathClasses.theory.categories.

Record Object := object
  { obj:> Type
  ; Arrows_inst: Arrows obj
  ; Equiv_inst: ∀ x y: obj, Equiv (x ⟶ y)
  ; CatId_inst: CatId obj
  ; CatComp_inst: CatComp obj
  ; Category_inst: Category obj }.

Arguments object _ {Arrows_inst Equiv_inst CatId_inst CatComp_inst Category_inst}.
Existing Instance Arrows_inst.
Existing Instance Equiv_inst.
Existing Instance CatId_inst.
Existing Instance CatComp_inst.
Existing Instance Category_inst.

Record Arrow (x y: Object): Type := arrow
  { map_obj:> obj x → obj y
  ; Fmap_inst: Fmap map_obj
  ; Functor_inst: Functor map_obj _ }.

Arguments arrow {x y} _ _ _.
Arguments map_obj {x y} _ _.
Existing Instance Fmap_inst.
Existing Instance Functor_inst.

Instance: Arrows Object := Arrow.
(* Hint Extern 4 (Arrows Object) => exact Arrow: typeclass_instances. *)

Section contents.
  Section more_arrows.
    Context (x y: Object).

    Global Instance e: Equiv (x ⟶ y) := λ a b,
      (∀ v, a v ≡ b v) ∧
      (∀ `(f: v ⟶ w), JMrelation.R (=) (fmap a f) _ (=) (fmap b f)).

    Instance e_refl: Reflexive e.
    Proof.
     intro a. unfold e. intuition.
     apply JMrelation.reflexive, _.
    Qed.

    Instance e_sym: Symmetric e.
    Proof with intuition.
     unfold e. intros ?? [P Q]...
     apply JMrelation.symmetric...
    Qed.

    Instance e_trans: Transitive e.
    Proof with intuition.
     unfold e. intros a b c [P Q] [R S]...
      transitivity (b v)...
     apply JMrelation.transitive with _ (=) (fmap b f)...
    Qed.

    Global Instance: Setoid (x ⟶ y).
    Proof. split; apply _. Qed.
  End more_arrows.

  Global Instance: CatId Object := λ _, arrow id _ _.

  Global Program Instance: CatComp Object := λ _ _ _ x y, arrow (x ∘ y) _ _.

  Global Instance: ∀ x y z: Object, Proper ((=) ==> (=) ==> (=)) ((◎): (y ⟶ z) → (x ⟶ y) → (x ⟶ z)).
  Proof with intuition; try apply _.
   unfold equiv, e.
   intros x y z a b [P Q] c d [R S].
   split; intros.
    change (a (c v) ≡ b (d v)). congruence.
   change (JMrelation.R (=) (fmap a (fmap c f)) _ (=) (fmap b (fmap d f))).
   apply JMrelation.transitive with _ (=) (fmap a (fmap d f))...
   specialize (S _ _ f). revert S.
   generalize (fmap c f) (fmap d f).
   repeat rewrite R.
   intros. apply JMrelation.relate.
   rewrite (JMrelation.unJM _ _ _ _ _ S)... (* <- uses K *)
  Qed.

  Global Instance: Category Object.
  Proof. repeat (split; try apply _); intuition; apply reflexivity. Qed.
End contents.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.

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

(* We need a custom equality type, as the default one from
   ssreflect breaks constraint solving when defining worlds.

   TODO: figure out, why?
 *)

Module EqualityX.

Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y).

Structure mixin_of T := Mixin {op : rel T; _ : axiom op}.
Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).

Definition class := let: Pack _ c _ := cT return class_of cT in c.

Definition pack c := @Pack T c T.
Definition clone := fun c & cT -> T & phant_id (pack c) cT => pack c.

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Notation eqTypeX := type.
Notation EqMixinX := Mixin.
Notation EqTypeX T m := (@pack T m).
End Exports.

End EqualityX.
Export EqualityX.Exports.

Section EqualityConversion.

Variable U: eqTypeX.
Definition eq_opX T := EqualityX.op (EqualityX.class T).

Lemma eqxP : Equality.axiom (@eq_opX U).
Proof. by case: U=>s[op a ?]; apply: a. Qed.

Canonical eqMixinX := EqMixin eqxP.
Canonical eqTypeX' := EqType U eqMixinX.

End EqualityConversion.

(* Section EqualityConversion2. *)

(* Variable U: eqType. *)
(* Local Definition eq_op T := Equality.op (Equality.class T). *)

(* Lemma eqP' : Equality.axiom (@eq_op U). *)
(* Proof. by case: U=>s[op a ?]; apply: a. Qed. *)

(* Canonical eqMixinX2 := EqMixinX eqP'. *)
(* Canonical eqTypeX2' := EqTypeX U eqMixinX2.                                    *)

(* End EqualityConversion2. *)


Require Import Common.Definitions.
Require Import Common.Values.
Require Import CompCert.Events.
Require Import CompCert.Smallstep.
Require Import CompCert.Behaviors.
Require Import Lib.Extra.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

(* Define a canonical structure on event equality. If needed, richer event types
   can extend the encoding by using nested sums. *)
Definition sum_of_event (e : event) :=
  match e with
  | ERet C v mem C' => inl (C, v, mem, C')
  | ECall C P v mem C' => inr (C, P, v, mem, C')
  (*| ERet C v C' => inl (inl (C, v, C'))
  | ECall C P v C' => inl (inr (C, P, v, C'))
  | ERead C p v => inr (inl (C, p, v))
  | EWrite C p v => inr (inr (C, p, v))*)
  end.

Lemma sum_of_event_inj : injective sum_of_event.
Proof.
by case=> [?????|????(*|???|???*)] [?????|????(*|???|???*)] //= => [[-> -> -> -> ->]|[-> -> -> ->](*|[-> -> ->]|[-> -> ->]*)].
Qed.

Definition event_eqMixin := @InjEqMixin _ _ sum_of_event sum_of_event_inj.
Canonical event_eqType := Eval hnf in EqType event event_eqMixin.

Definition empty_behavior {Ev: Type} (beh : @program_behavior Ev) :=
  match beh with
  | Terminates t | Diverges t | Goes_wrong t =>
                                match t with
                                | nil => true
                                | _ => false
                                end
  | Reacts _ => false
  end.

Lemma empty_behaviorPn {Ev: Type} beh :
  reflect (exists e beh', beh = behavior_app [:: e] beh')
          (~~ @empty_behavior Ev beh).
Proof.
case: beh=> [[|e t]|[|e t]|[e t]|[|e t]] /=; constructor;
try by case=> [e [[|||]]].
- eexists e, (Terminates _); rewrite /=; eauto.
- eexists e, (Diverges _); rewrite /=; eauto.
- eexists e, (Reacts _); rewrite /=; eauto.
- eexists e, (Goes_wrong _); rewrite /=; eauto.
Qed.

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

(* Smallstep semantics: alternative star. *)

Section CLOSURES.

Variable genv: Type.
Variable state: Type.
Variable event: Type.

Variable step: genv -> state -> trace event -> state -> Prop.

Inductive starR (ge: genv): state -> trace event -> state -> Prop :=
  | starR_refl: forall s,
      starR ge s E0 s
  | starR_step: forall s1 t1 s2 t2 s3 t,
      starR ge s1 t1 s2 -> step ge s2 t2 s3 -> t = t1 ** t2 ->
      starR ge s1 t s3.

Lemma starR_one:
  forall ge s1 t s2, step ge s1 t s2 -> starR ge s1 t s2.
Proof.
  intros. eapply starR_step; eauto. apply starR_refl. traceEq.
Qed.

Lemma starR_trans:
  forall ge s1 t1 s2, starR ge s1 t1 s2 ->
  forall t2 s3 t, starR ge s2 t2 s3 -> t = t1 ** t2 -> starR ge s1 t s3.
Proof.
  intros ge s1 t1 s2 HstarR1 t2 s3 t HstarR2 Ht.
  generalize dependent t.
  generalize dependent t1.
  generalize dependent s1.
  induction HstarR2 as [| s1 t1 s2 t2 s3 t HstarR1 IHHstarR2 Hstep2 Ht].
  - intros s1 t1 HstarR1 t Ht.
    rewrite E0_right in Ht.
    subst.
    assumption.
  - intros s0 t0 HstarR0 t3 Ht3.
    eapply starR_step.
    + apply (IHHstarR2 _ _ HstarR0 _ (@erefl _ (t0 ** t1))).
    + apply Hstep2.
    + subst.
      rewrite Eapp_assoc.
      reflexivity.
Qed.

Lemma star_iff_starR : forall ge s1 t s2, star step ge s1 t s2 <-> starR ge s1 t s2.
Proof.
  split.
  - intros H.
    induction H.
    + apply starR_refl.
    + apply starR_one in H.
      apply (starR_trans H IHstar H1).
  - intros H.
    induction H.
    + apply star_refl.
    + apply star_one in H0.
      apply (star_trans IHstarR H0 H1).
Qed.

Lemma star_E0_ind' ge (P : state -> state -> Prop) :
  (forall s, P s s) ->
  (forall s1 s2 s3, step ge s1 E0 s2 -> star step ge s2 E0 s3 -> P s2 s3 -> P s1 s3) ->
  forall s1 s2, star step ge s1 E0 s2 -> P s1 s2.
Proof.
move=> H0 H1 s1 s2; move e_t: E0 => t Hstar.
elim: s1 t s2 / Hstar e_t => // s1 t1 s2 t2 s3 t Hstep Hstar IH ->.
move=> /(@esym _ _ _)/Eapp_E0_inv [??]; subst t1 t2.
by apply: H1; eauto.
Qed.

End CLOSURES.

Section Inversion.

Variables (event: Type) (L : semantics event) (Hsingle : single_events L).

Lemma star_cons_inv s1 e t s2 :
  Star L s1 (e :: t) s2 ->
  exists s1' s2', Star L s1 E0 s1' /\ Step L s1' [e] s2' /\ Star L s2' t s2.
Proof.
rewrite -[e :: t]/([e] ** t).
case/(star_app_inv Hsingle)=> s2'' [Hstar1 Hstar2].
case/star_non_E0_split: Hstar1=> // [s1' [s2' [A [B C]]]].
by exists s1', s2'; do !split=> //; apply: star_trans; eauto.
Qed.

Lemma star_middle1_inv s1 t1 e t2 s2 :
  Star L s1 (t1 ** e :: t2) s2 ->
  exists s1' s2', Star L s1 t1 s1' /\ Step L s1' [e] s2' /\ Star L s2' t2 s2.
Proof.
case/(star_app_inv Hsingle)=> s0 [Hstar0].
case/star_cons_inv=> s1' [s2' [Hstar1 [Hstep2 Hstar3]]].
exists s1', s2'; do !split=> //; apply: star_trans; eauto.
by rewrite E0_right.
Qed.

End Inversion.

(* Finite prefixes and behaviors. *)

Inductive finpref_behavior {Ev: Type} : Type :=
  | FTerminates: trace Ev -> finpref_behavior
  | FGoes_wrong: trace Ev -> finpref_behavior
  | FTbc : trace Ev -> finpref_behavior.

Definition not_wrong_finpref {Ev: Type} (m: @finpref_behavior Ev) : Prop :=
  match m with
  | FGoes_wrong _ => False
  | _             => True
  end.

Definition prefix {Ev: Type} (m: @finpref_behavior Ev) (b:program_behavior) : Prop :=
  match m, b with
  | FTerminates t1, Terminates t2
  | FGoes_wrong t1, Goes_wrong t2 => t1 = t2
  | FTbc t1, b => behavior_prefix t1 b
  | _, _ => False
  end.

Definition finpref_trace {Ev: Type} (m : finpref_behavior) : trace Ev :=
  match m with
  | FTerminates t | FGoes_wrong t | FTbc t => t
  end.

Definition trace_finpref_prefix {Ev: Type} (t : trace Ev) (m : finpref_behavior) : Prop :=
  match m with
  | FTerminates t' | FGoes_wrong t' | FTbc t' => trace_prefix t t'
  end.

Definition finpref_trace_prefix {Ev: Type} (m : finpref_behavior) (t : trace Ev) : Prop :=
  match m with
  | FTerminates t' | FGoes_wrong t' => False
  | FTbc t' => trace_prefix t' t
  end.

Definition behavior_improves_finpref {Ev: Type} (b: @program_behavior Ev) (m:finpref_behavior) :=
  exists t, b = Goes_wrong t /\ trace_finpref_prefix t m.

(* CH: Introduce a definition for
       does_prefix and use it everywhere where it's
       possible, instead of unfolding it everywhere. *)
Definition does_prefix  {Ev: Type} x (m: @finpref_behavior Ev) := exists b, program_behaves x b /\ prefix m b.
(* CH: Alternatively could define this in terms of Star and prove the
       predicate above as an alternative characterization. *)

(* Properties of prefixes. *)

Lemma help {Ev: Type} : forall (m1: trace Ev) m2 T,
    trace_prefix m1 T -> trace_prefix m2 T ->
    (trace_prefix m1 m2 \/ trace_prefix m2 m1).
Proof.
  intros m1. induction m1 as [| e m1]; intros m2 T [x1 H1] [x2 H2].
  - left. now exists m2.
  - assert (foo : (exists s, m2 = e :: s) \/ m2 = []).
   { destruct m2. right. reflexivity. subst T. inversion H2.
     left. now exists m2. }
    destruct foo as [[s k0] | k1].
     + subst m2. subst T. inversion H2. specialize (IHm1 s (m1 ** x1)).
       assert (use1 : trace_prefix m1 (m1 ** x1)) by now exists x1.
       assert (use2 : trace_prefix s (m1 ** x1)) by (rewrite H0; now exists x2).
       destruct (IHm1 use1 use2) as [K | K]. clear IHm1.
       left. destruct K as [m K]. exists m. simpl. now rewrite K.
     + right. destruct K as [m K]. exists m. simpl. now rewrite K.
     + right. rewrite k1. now exists (e :: m1).
Qed.

Lemma help_inf {Ev: Type} : forall (m1: trace Ev) m2 T,
    traceinf_prefix m1 T -> traceinf_prefix m2 T ->
    (trace_prefix m1 m2 \/ trace_prefix m2 m1).
Proof.
   intros m1. induction m1 as [| e m1]; intros m2 T [x1 H1] [x2 H2].
  - left. now exists m2.
  - assert (foo : (exists s, m2 = e :: s) \/ m2 = []).
   { destruct m2. right. reflexivity. subst T. inversion H2.
     left. now exists m2. }
    destruct foo as [[s k0] | k1].
     + subst m2. subst T. inversion H2. specialize (IHm1 s (m1 *** x1)).
       assert (use1 : traceinf_prefix m1 (m1 *** x1)) by now exists x1.
       assert (use2 : traceinf_prefix s (m1 *** x1)) by (rewrite H0; now exists x2).
       destruct (IHm1 use1 use2) as [K | K]. clear IHm1.
       left. destruct K as [m K]. exists m. simpl. now rewrite K.
     + right. destruct K as [m K]. exists m. simpl. now rewrite K.
     + right. rewrite k1. now exists (e :: m1).
Qed.

(* How to simplify this proof ? *)
Lemma behavior_prefix_comp {Ev: Type} : forall (m1: trace Ev) m2 b,
    behavior_prefix m1 b ->
    behavior_prefix m2 b ->
    (trace_prefix m1 m2 \/ trace_prefix m2 m1).
Proof.
  intros m1 m2 b [beh1 H1] [beh2 H2].
  destruct b.

  destruct beh1; inversion H1;
  destruct beh2; inversion H2;
  inversion H1; inversion H2.
  assert (K1 : trace_prefix m1 t) by now exists t0.
  assert (K2 : trace_prefix m2 t) by now exists t1.
  apply (help K1 K2).

  destruct beh1; inversion H1.
  destruct beh2; inversion H2.
  assert (K1 : trace_prefix m1 t ) by now exists t0.
  assert (K2 : trace_prefix m2 t) by now exists t1.
  apply (help K1 K2).

  destruct beh1; inversion H1.
  destruct beh2; inversion H2.
  assert (K1 : traceinf_prefix m1 t) by now exists t0.
  assert (K2 : traceinf_prefix m2 t) by now exists t1.
  apply (help_inf K1 K2).

  destruct beh1; inversion H1.
  destruct beh2; inversion H2.
  assert (K1 : trace_prefix m1 t) by now exists t0.
  assert (K2 : trace_prefix m2 t) by now exists t1.
  apply (help K1 K2).
Qed.

Lemma behavior_prefix_comp' {Ev: Type} : forall m1 m2 (b: @program_behavior Ev),
    prefix m1 b ->
    behavior_prefix m2 b ->
    (finpref_trace_prefix m1 m2 \/ trace_finpref_prefix m2 m1).
Proof.
  unfold prefix, finpref_trace_prefix, trace_finpref_prefix.
  intros m1 m2 b Hbp1 Hbp2.
  (* Destruct behaviors. *)
  destruct m1 as [m1'|m1'|m1'];
    destruct b as [b'|b'|b'|b'];
    (* Non-matching cases are discarded by a simple inversion. *)
    try (inversion Hbp1; fail);
    (* Matching cases are proved by the lemma on standard behaviors. *)
    try (apply (behavior_prefix_comp Hbp1 Hbp2));
    (* The remaining cases are trivial. *)
    subst m1'; destruct Hbp2 as [b'' Happ]; destruct b''; inversion Happ as [Hb'];
      right; now exists t.
Qed.

Lemma trace_behavior_prefix_trans {Ev: Type} : forall m1 m2 (b: @program_behavior Ev),
    finpref_trace_prefix m1 m2 ->
    behavior_prefix m2 b ->
    prefix m1 b.
Proof.
  unfold finpref_trace_prefix, behavior_prefix, prefix.
  intros f m b Hf [b' Hb'].
  subst b.
  destruct f as [| | f].
  - inversion Hf.
  - inversion Hf.
  - unfold trace_prefix in Hf. destruct Hf as [t Ht]. subst m.
    exists (behavior_app t b'). now rewrite <- behavior_app_assoc.
Qed.

Lemma trace_behavior_prefix_trans' {Ev: Type} : forall m1 m2 (b: @program_behavior Ev),
  trace_finpref_prefix m1 m2 ->
  prefix m2 b ->
  behavior_prefix m1 b.
Proof.
  unfold trace_finpref_prefix, prefix, behavior_prefix.
  intros t f b Hf Hfb.
  destruct f as [t1 | t1 | t1];
    destruct Hf as [t2 Ht2]; subst t1.
  - destruct b as [t3 | t3 | t3 | t3]; try (inversion Hfb; fail).
    + subst t3. exists (Terminates t2). reflexivity.
  - destruct b as [t3 | t3 | t3 | t3]; try (inversion Hfb; fail).
    + subst t3. exists (Goes_wrong t2). reflexivity.
  - destruct Hfb as [b1 Hb1]. subst b.
    exists (behavior_app t2 b1). now rewrite <- behavior_app_assoc.
Qed.

Lemma behavior_prefix_goes_wrong_trans {Ev: Type} : forall (t1: trace Ev) t2 b,
  behavior_prefix t1 (Goes_wrong t2) ->
  behavior_prefix t2 b ->
  behavior_prefix t1 b.
Proof.
  unfold behavior_prefix.
  intros t1 t2 b [b1 Hprefix1] [b2 ?]; subst b.
  unfold behavior_app in Hprefix1.
  destruct b1; try (inversion Hprefix1).
  - subst t2. exists (behavior_app t b2). now rewrite <- behavior_app_assoc.
Qed.

Lemma behavior_prefix_improves_trans' {Ev: Type} : forall (t: @program_behavior Ev) b m,
  behavior_prefix m t ->
  behavior_improves t b ->
  behavior_prefix m b.
Proof.
  unfold behavior_prefix, behavior_improves.
  intros b1 b2 t1 [b3 Happb1] [Heqb1 | [t2 [Hwrongb1 [b4 Happb2]]]].
  - subst. eauto.
  - subst.
    unfold behavior_app in Hwrongb1. destruct b3; try (inversion Hwrongb1; fail).
    + inversion Hwrongb1 as [Heqt2].
      exists (behavior_app t b4). now rewrite <- behavior_app_assoc.
Qed.

Lemma behavior_prefix_app_inv {Ev: Type} : forall t1 t2 (b: @program_behavior Ev),
  behavior_prefix (t1 ++ t2) b ->
  behavior_prefix t1 b.
Proof.
  intros t1 t2 ? [b ?]; subst.
  exists (behavior_app t2 b).
  rewrite behavior_app_assoc.
  reflexivity.
Qed.

Lemma program_behaves_finpref_exists {Ev: Type} :
  forall L s (t: trace Ev) s',
    initial_state L s ->
    Star L s t s' ->
  exists beh,
    program_behaves L beh /\
    prefix (FTbc t) beh.
Proof.
  intros L s t s' Hini HStar.
  destruct (state_behaves_exists L s') as [beh_s' Hbeh_s'].
  pose proof program_runs Hini (state_behaves_app HStar Hbeh_s') as Hbeh.
  eexists. split.
  - exact Hbeh.
  - simpl. exists beh_s'. reflexivity.
Qed.