Load imports.

Inductive Set_Type :=
| TypeInt : Set_Type.
Definition Set_MethodName := string.
Definition Set_Val := Z.
Definition Set_Ident := string.
Inductive Set_Var :=
| VarResult : Set_Var
| VarIdent : Set_Ident -> Set_Var
| VarOldIdent : Set_Ident -> Set_Var.
Definition Set_BinOp := Set_Val -> Set_Val -> option Set_Val.
Definition Set_CompOp := Set_Val -> Set_Val -> bool.
Definition CompOpEq : Set_Val -> Set_Val -> bool := Zbool.Zeq_bool.

Definition DefaultValue (T : Set_Type) : Set_Val :=
  match T with
  | TypeInt => Z0
  end.

Inductive Set_Expr :=
| ExprVal : Set_Val -> Set_Expr
| ExprVar : Set_Var -> Set_Expr
| ExprBinOp : Set_BinOp -> Set_Expr -> Set_Expr -> Set_Expr.
Inductive Set_Formula :=
| FormTrue : Set_Formula
| FormCompOp : Set_CompOp -> Set_Expr -> Set_Expr -> Set_Formula
| FormAnd : Set_Formula -> Set_Formula -> Set_Formula.
Inductive Set_Stmt :=
| StmtSkip : Set_Stmt
| StmtVarAssign : Set_Var -> Set_Expr -> Set_Stmt
| StmtCall : Set_Var -> Set_MethodName -> Set_Var -> Set_Stmt
| StmtAssert : Set_Formula -> Set_Stmt
(* | StmtDeclare : Set_Type -> Set_Var -> Set_Stmt *)(* just special case of VarAssign *)
| StmtSeq : Set_Stmt -> Set_Stmt -> Set_Stmt.
Inductive Set_Contract :=
| Contract : Set_Formula -> Set_Formula -> Set_Contract.
Inductive Set_Method :=
| Method : Set_Type -> Set_MethodName -> Set_Type -> Set_Ident -> Set_Contract -> Set_Stmt -> Set_Method.
Inductive Set_Program :=
| Program : (list Set_Method) -> Set_Stmt -> Set_Program.

(*dyn sem*)
Inductive Set_VarEnv :=
| VarEnvFresh : Set_VarEnv
| VarEnvMapping : Set_Var -> Set_Val -> Set_VarEnv -> Set_VarEnv.
Inductive EvalVar : Set_VarEnv -> Set_Var -> Set_Val -> Prop :=
| EVarHead : ∀ (rho : Set_VarEnv) (x : Set_Var) (v : Set_Val), EvalVar (VarEnvMapping x v rho) x v
| EVarTail : ∀ (rho : Set_VarEnv) (x : Set_Var) (v : Set_Val) (x' : Set_Var) (v' : Set_Val), x <> x' -> EvalVar rho x v -> EvalVar (VarEnvMapping x' v' rho) x v.
Inductive Set_StackFrame :=
| StackFrame : Set_VarEnv -> Set_Stmt -> Set_StackFrame.
Inductive Set_Stack :=
| StackEmpty : Set_Stack
| StackCons : Set_StackFrame -> Set_Stack -> Set_Stack.
Definition Set_State := Set_Stack.

Inductive EvalExpr : Set_VarEnv -> Set_Expr -> Set_Val -> Prop :=
| EExprVal : ∀ (rho : Set_VarEnv) (v : Set_Val), EvalExpr rho (ExprVal v) v
| EExprVar : ∀ (rho : Set_VarEnv) (x : Set_Var) (v : Set_Val),
  EvalVar rho x v ->
  EvalExpr rho (ExprVar x) v
| EExprBinOp : ∀ (rho : Set_VarEnv) (op : Set_BinOp) (e1 : Set_Expr) (e2 : Set_Expr) (v1 : Set_Val) (v2 : Set_Val) (v : Set_Val),
  EvalExpr rho e1 v1 ->
  EvalExpr rho e2 v2 ->
  op v1 v2 = Some v ->
  EvalExpr rho (ExprBinOp op e1 e2) v.

Inductive EvalFormula : Set_VarEnv -> Set_Formula -> Prop :=
| EFormTrue : ∀ (rho : Set_VarEnv), EvalFormula rho FormTrue
| EFormCompOp : ∀ (rho : Set_VarEnv) (op : Set_CompOp) (e1 : Set_Expr) (e2 : Set_Expr) (v1 : Set_Val) (v2 : Set_Val),
  EvalExpr rho e1 v1 ->
  EvalExpr rho e2 v2 ->
  op v1 v2 = true ->
  EvalFormula rho (FormCompOp op e1 e2)
| EFormAnd : ∀ (rho : Set_VarEnv) (phi1 : Set_Formula) (phi2 : Set_Formula),
  EvalFormula rho phi1 ->
  EvalFormula rho phi2 ->
  EvalFormula rho (FormAnd phi1 phi2).

(* implication *)

Definition Evaluable : Set_Expr -> Prop :=
  fun e => exists (rho : Set_VarEnv) v, EvalExpr rho e v.
Definition Satisfiable : Set_Formula -> Prop :=
  fun phi => exists (rho : Set_VarEnv), EvalFormula rho phi.
Definition Implies : Set_Formula -> Set_Formula -> Prop :=
  fun phi1 phi2 => ∀ (rho : Set_VarEnv), EvalFormula rho phi1 -> EvalFormula rho phi2.
Definition MaxImplies : (Set_Formula -> Prop) -> (Set_Formula -> Prop) := fun pred phi =>
  pred phi /\ (∀ phi', pred phi' -> Implies phi' phi).
Definition MinImplies : (Set_Formula -> Prop) -> (Set_Formula -> Prop) := fun pred phi =>
  pred phi /\ (∀ phi', pred phi' -> Implies phi phi').
Definition FormEqual (phi1 phi2 : Set_Formula) := Implies phi1 phi2 /\ Implies phi2 phi1.

Lemma ImpliesRefl : forall phi, Implies phi phi.
Proof.
  intro. intro. auto.
Qed.
Lemma ImpliesTrans : forall phi1 phi2 phi3, Implies phi1 phi2 -> Implies phi2 phi3 -> Implies phi1 phi3.
Proof.
  intro. intro. intro. intro im1. intro im2. intro. intro ef. auto.
Qed.

Lemma RecFormAndL : ∀ p1 p2, ~ FormAnd p1 p2 = p1.
Proof.
  induction p1; congruence.
Qed.
Lemma RecFormAndR : ∀ p2 p1, ~ FormAnd p1 p2 = p2.
Proof.
  induction p2; congruence.
Qed.

Inductive SubstExprVarExpr : Set_Var -> Set_Expr -> Set_Expr -> Set_Expr -> Prop :=
| SubstFormVarExprVal : ∀ (x : Set_Var) (e : Set_Expr) (v : Set_Val), SubstExprVarExpr x e (ExprVal v) (ExprVal v)
| SubstFormVarExprVarHit : ∀ (x : Set_Var) (e : Set_Expr), SubstExprVarExpr x e (ExprVar x) e
| SubstFormVarExprVarMiss : ∀ (x : Set_Var) (e : Set_Expr) (x' : Set_Var), x <> x' -> SubstExprVarExpr x e (ExprVar x') (ExprVar x')
| SubstFormVarExprBinOp : ∀ (x : Set_Var) (e : Set_Expr) (op : Set_BinOp) (e1 e2 e1' e2' : Set_Expr),
  SubstExprVarExpr x e e1 e1' ->
  SubstExprVarExpr x e e2 e2' ->
  SubstExprVarExpr x e (ExprBinOp op e1 e2) (ExprBinOp op e1' e2')
.
Inductive SubstFormVarExpr : Set_Var -> Set_Expr -> Set_Formula -> Set_Formula -> Prop :=
| SubstFormVarExprTrue : ∀ (x : Set_Var) (e : Set_Expr), SubstFormVarExpr x e FormTrue FormTrue
| SubstFormVarExprCompOp : ∀ (x : Set_Var) (e : Set_Expr) (op : Set_CompOp) (e1 e2 e1' e2' : Set_Expr),
  SubstExprVarExpr x e e1 e1' ->
  SubstExprVarExpr x e e2 e2' ->
  SubstFormVarExpr x e (FormCompOp op e1 e2) (FormCompOp op e1' e2')
| SubstFormVarExprAnd : ∀ (x : Set_Var) (e : Set_Expr) (phi1 phi2 phi1' phi2' : Set_Formula),
  SubstFormVarExpr x e phi1 phi1' ->
  SubstFormVarExpr x e phi2 phi2' ->
  SubstFormVarExpr x e (FormAnd phi1 phi2) (FormAnd phi1' phi2')
.
Inductive FreeVarExpr : Set_Var -> Set_Expr -> Prop :=
| FreeVarExprVar : ∀ (x : Set_Var), FreeVarExpr x (ExprVar x)
| FreeVarExprBinOp : ∀ (x : Set_Var) (op : Set_BinOp) (e1 e2 : Set_Expr),
  FreeVarExpr x e1 \/ FreeVarExpr x e2 ->
  FreeVarExpr x (ExprBinOp op e1 e2)
.
Inductive FreeVarForm : Set_Var -> Set_Formula -> Prop :=
| FreeVarFormCompOp : ∀ (x : Set_Var) (op : Set_CompOp) (e1 e2 : Set_Expr),
  FreeVarExpr x e1 \/ FreeVarExpr x e2 ->
  FreeVarForm x (FormCompOp op e1 e2)
| FreeVarFormAnd : ∀ (x : Set_Var) (phi1 phi2 : Set_Formula),
  FreeVarForm x phi1 \/ FreeVarForm x phi2 ->
  FreeVarForm x (FormAnd phi1 phi2)
.

Definition EImplies (e1 e2 : Set_Expr) := forall rho v, EvalExpr rho e1 v -> EvalExpr rho e2 v.
Definition EEqual (e1 e2 : Set_Expr) := EImplies e1 e2 /\ EImplies e2 e1.

Lemma EvalVarDet : ∀ rho x v1 v2, EvalVar rho x v1 -> EvalVar rho x v2 -> v1 = v2.
Proof.
  induction rho; intro; intro; intro; intro; intro.
  - inv H.
  - clac (s = x).
    * subst.
      inv H0; intuition.
      inv H; intuition.
    * inv H0; intuition.
      inv H; intuition.
      eapply IHrho; eauto.
Qed.

Lemma EvalExprDet : ∀ rho e v1 v2, EvalExpr rho e v1 -> EvalExpr rho e v2 -> v1 = v2.
Proof.
  intro.
  induction e; intro; intro; intro ee1; intro ee2.
  - inv ee1. inv ee2. auto.
  - inv ee1. inv ee2. eapply EvalVarDet; eauto.
  - inv ee1. inv ee2.
    assert (v0 = v4) as IH1. apply IHe1; auto.
    assert (v3 = v5) as IH2. apply IHe2; auto.
    subst.
    rewrite H6 in H9. inv H9. auto.
Qed.

Lemma SubstExprSemantics :
  ∀ x e e1 e2, SubstExprVarExpr x e e1 e2 ->
  ∀ rho v, EvalExpr rho e v ->
  ∀ ve, EvalExpr (VarEnvMapping x v rho) e1 ve <-> EvalExpr rho e2 ve.
Proof.
  induction e1; intro; intro subst; intro; intro; intro ev; intro; split; intro ee.
  - inv subst.
    inv ee. ctor.
  - inv subst.
    inv ee. ctor.
  - inv subst.
    * inv ee. inv H1; intuition.
    * inv ee. inv H1; intuition.
      ctor. assumption.
  - inv subst.
    * assert (v = ve). eapply EvalExprDet; eauto.
      subst.
      ctor. ctor.
    * inv ee.
      ctor. ctor; auto.
  - inv subst. inv ee. ctor; eauto.
    * eapply IHe1_1; eauto.
    * eapply IHe1_2; eauto.
  - inv subst. inv ee. ctor; eauto.
    * rewrite IHe1_1; eauto.
    * rewrite IHe1_2; eauto.
Qed.

Lemma SubstFormSemantics :
  ∀ x e phi1 phi2, SubstFormVarExpr x e phi1 phi2 ->
  ∀ rho v, EvalExpr rho e v ->
  EvalFormula (VarEnvMapping x v rho) phi1 <-> EvalFormula rho phi2.
Proof.
  intro. intro. intro. intro. intro subst. intro. intro. intro eev.
  generalize phi1 phi2 subst. clear subst phi1 phi2.
  induction phi1; intro; intro subst; split; intro ef.
  - inv subst. ctor.
  - inv subst. ctor.
  - inv subst. inv ef. ctor; eauto; eapply SubstExprSemantics; eauto.
  - inv subst. inv ef. ctor; eauto; eapply SubstExprSemantics; eauto.
  - inv subst. inv ef. ctor; eauto.
    * apply IHphi1_1; assumption.
    * apply IHphi1_2; assumption.
  - inv subst. inv ef. ctor; eauto.
    * rewrite (IHphi1_1 phi1'); assumption.
    * rewrite (IHphi1_2 phi2'); assumption.
Qed.

Lemma MonotoneFormAnd : ∀ phi1 phi2 phi1' phi2', Implies phi1 phi2 -> Implies phi1' phi2' -> Implies (FormAnd phi1 phi1') (FormAnd phi2 phi2').
Proof.
  intro. intro. intro. intro. intro ima. intro imb.
  intro. intro ef.
  inv ef.
  apply ima in H2.
  apply imb in H3.
  constructor; assumption.
Qed.

Lemma ObservablyIdenticalVarEnvEvalExpr : forall rho1 rho2 (xs : list Set_Var),
  (∀ x, In x xs -> ∀ v, EvalVar rho1 x v <-> EvalVar rho2 x v) ->
  ∀ e, (∀ x, FreeVarExpr x e → In x xs) -> ∀ v, EvalExpr rho1 e v <-> EvalExpr rho2 e v.
Proof.
  intro. intro.
  induction xs.
  - introc TMP.
    induction e; intro fv; intro.
    * split; intro evl; inv evl; ctor.
    * specialize (fv s).
      assert (In s []) as T. apply fv. ctor.
      inv T.
    * assert (∀ v : Set_Val, EvalExpr rho1 e1 v ↔ EvalExpr rho2 e1 v) as T1.
        apply IHe1. intro. intro fve. apply fv. ctor. auto.
      clear IHe1.
      assert (∀ v : Set_Val, EvalExpr rho1 e2 v ↔ EvalExpr rho2 e2 v) as T2.
        apply IHe2. intro. intro fve. apply fv. ctor. auto.
      clear IHe2.
      split; intro ee; inv ee;
      specialize (T1 v1);
      specialize (T2 v2);
      ctor; eauto;
      intuition.
  - intro freval.
    induction e; intro fv; intro.
    * split; intro evl; inv evl; ctor.
    * specialize (fv s).
      assert (In s (a :: xs)) as T. apply fv. ctor. clear fv.
      inv T.
      + assert (EvalVar rho1 s v ↔ EvalVar rho2 s v) as T. apply freval. ctor. auto.
        split; intro ee; inv ee;
        ctor;
        intuition.
      + assert (∀ e : Set_Expr, (∀ x : Set_Var, FreeVarExpr x e → In x xs) → ∀ v : Set_Val, EvalExpr rho1 e v ↔ EvalExpr rho2 e v) as IH.
          apply IHxs. intro. intro i. intro. apply freval. intuition.
        clear IHxs.
        apply IH.
        intro. intro fve. inv fve. assumption.
    * clear IHxs.
      assert (∀ v : Set_Val, EvalExpr rho1 e1 v ↔ EvalExpr rho2 e1 v) as T1.
        apply IHe1. intro. intro fve. apply fv. ctor. auto.
      clear IHe1.
      assert (∀ v : Set_Val, EvalExpr rho1 e2 v ↔ EvalExpr rho2 e2 v) as T2.
        apply IHe2. intro. intro fve. apply fv. ctor. auto.
      clear IHe2.
      split; intro ee; inv ee;
      specialize (T1 v1);
      specialize (T2 v2);
      ctor; eauto;
      intuition.
Qed.

Lemma ObservablyIdenticalVarEnvEvalFormula : forall (xs : list Set_Var) rho1 rho2,
  (∀ x, In x xs -> ∀ v, EvalVar rho1 x v <-> EvalVar rho2 x v) ->
  ∀ phi, (∀ x, FreeVarForm x phi → In x xs) -> (EvalFormula rho1 phi <-> EvalFormula rho2 phi).
Proof.
  intro. intro. intro. intro ev.
  induction phi.
  - introc TMP.
    split; ctor.
  - intro fv.
    assert (∀ v, (EvalExpr rho1 s0 v <-> EvalExpr rho2 s0 v)) as Hy1.
      eapply ObservablyIdenticalVarEnvEvalExpr; eauto.
      intros. apply fv. ctor. auto.
    assert (∀ v, (EvalExpr rho1 s1 v <-> EvalExpr rho2 s1 v)) as Hy2.
      eapply ObservablyIdenticalVarEnvEvalExpr; eauto.
      intros. apply fv. ctor. auto.
    split; intro ef; inv ef.
    * ctor; eauto; try rewrite Hy1 in *; try rewrite Hy2 in *; auto.
    * ctor; eauto; try rewrite Hy1; try rewrite Hy2; auto.
  - clear ev.
    intro fv.
    assert (EvalFormula rho1 phi1 ↔ EvalFormula rho2 phi1) as Hy1.
      apply IHphi1.
      intros. apply fv. ctor. auto.
    assert (EvalFormula rho1 phi2 ↔ EvalFormula rho2 phi2) as Hy2.
      apply IHphi2.
      intros. apply fv. ctor. auto.
    split; intro ef; inv ef.
    * ctor; eauto; try rewrite Hy1 in *; try rewrite Hy2 in *; auto.
    * ctor; eauto; try rewrite Hy1; try rewrite Hy2; auto.
Qed.

Lemma MonotoneSubstFormVarExpr_HelperExpr : ∀ x e rho e1 e2 v',
  SubstExprVarExpr x e e1 e2 → EvalExpr rho e2 v' → FreeVarExpr x e1 → ∃ v : Set_Val, EvalExpr rho e v.
Proof.
  induction e1; intro; intro;
  intro subst; intro ee; intro fve.
  - inv fve.
  - inv fve.
    inv subst.
    * eexists. eauto.
    * congruence.
  - inv subst.
    inv ee.
    inv fve.
    inv H1.
    * eapply IHe1_1 in H; eauto.
    * eapply IHe1_2 in H; eauto.
Qed.

Lemma MonotoneSubstFormVarExpr_HelperForm : ∀ x e rho phi1 phi1',
  SubstFormVarExpr x e phi1 phi1' → EvalFormula rho phi1' → FreeVarForm x phi1 → ∃ v : Set_Val, EvalExpr rho e v.
Proof.
  induction phi1; intro;
  intro subst; intro ef; intro fvf;
  inv fvf.
  - inv subst.
    inv ef.
    inv H1.
    * eapply MonotoneSubstFormVarExpr_HelperExpr in H; eauto.
    * eapply MonotoneSubstFormVarExpr_HelperExpr in H; eauto.
  - inv subst.
    inv ef.
    inv H1.
    * eapply IHphi1_1 in H; eauto.
    * eapply IHphi1_2 in H; eauto.
Qed.

Lemma FreeVarExprList : ∀ e, exists l, ∀ x, FreeVarExpr x e <-> In x l.
Proof.
  induction e.
  - exists [].
    split; intros; inv H.
  - exists [s].
    split; intros; inv H.
    * ctor. auto.
    * ctor.
    * inv H0.
  - unf.
    exists (x ++ x0).
    split; intros.
    * apply in_or_app.
      inv H1.
      inv H4.
      + apply H0 in H1. auto.
      + apply H in H1. auto.
    * apply in_app_or in H1.
      ctor.
      inv H1.
      + rewrite H. auto.
      + rewrite H0. auto.
Qed.

Lemma FreeVarFormList : ∀ phi, exists l, ∀ x, FreeVarForm x phi <-> In x l.
Proof.
  induction phi.
  - exists [].
    split; intros; inv H.
  - assert (e1 := FreeVarExprList s0).
    assert (e2 := FreeVarExprList s1).
    unf.
    exists (x ++ x0).
    split; intros.
    * apply in_or_app.
      inv H1.
      inv H4.
      + apply H0 in H1. auto.
      + apply H in H1. auto.
    * apply in_app_or in H1.
      ctor.
      inv H1.
      + rewrite H. auto.
      + rewrite H0. auto.
  - unf.
    exists (x ++ x0).
    split; intros.
    * apply in_or_app.
      inv H1.
      inv H4.
      + apply H0 in H1. auto.
      + apply H in H1. auto.
    * apply in_app_or in H1.
      ctor.
      inv H1.
      + rewrite H. auto.
      + rewrite H0. auto.
Qed.

Lemma FreeVarExprUpperBound : ∀ e, exists l, ∀ x, FreeVarExpr x e -> In x l.
Proof.
  induction e.
  - exists [].
    intros.
    inv H.
  - exists [s].
    intros.
    inv H.
    ctor.
    auto.
  - unf.
    exists (x ++ x0).
    intros.
    inv H1.
    intuition.
Qed.

Lemma FreeVarFormUpperBound : ∀ phi, exists l, ∀ x, FreeVarForm x phi -> In x l.
Proof.
  induction phi.
  - exists [].
    intros.
    inv H.
  - assert (e1 := FreeVarExprUpperBound s0).
    assert (e2 := FreeVarExprUpperBound s1).
    unf.
    exists (x ++ x0).
    intros.
    inv H1.
    intuition.
  - unf.
    exists (x ++ x0).
    intros.
    inv H1.
    intuition.
Qed.

Definition Deterministic (f : Set_Formula -> Set_Formula -> Prop) := forall phi phi1 phi2, f phi phi1 -> f phi phi2 -> phi1 = phi2.
Definition Monotone (f : Set_Formula -> Set_Formula -> Prop) := ∀ (phi1 phi2 phi1' phi2' : Set_Formula),
       f phi1 phi1' → f phi2 phi2'
       → Implies phi1 phi2 → Implies phi1' phi2'.
Definition MonotoneDef (f : Set_Formula -> Set_Formula -> Prop) := ∀ (phi1 phi1' : Set_Formula),
       f phi1 phi1' → forall phi2, Implies phi1 phi2 → exists phi2', f phi2 phi2'.

Definition MonotoneFull f := MonotoneDef f /\ Monotone f.

Inductive FirstStmt : Set_Stmt -> Set_Stmt -> Prop :=
| FirstStmtAtomic : ∀ (s : Set_Stmt), (~ exists s1 s2, StmtSeq s1 s2 = s) -> FirstStmt s s
| FirstStmtSeq : ∀ (s s1 s2 : Set_Stmt), FirstStmt s1 s -> FirstStmt (StmtSeq s1 s2) s.

Inductive StateExtract : Set_State -> list Set_VarEnv -> list Set_Stmt -> Prop :=
| StateExtractEmpty : StateExtract StackEmpty [] []
| StateExtractCons : ∀ S rhos ss rho s,
  StateExtract S rhos ss ->
  StateExtract (StackCons (StackFrame rho s) S) (rho :: rhos) (s :: ss)
.

(* x; s  ->  s  ->  x *)
Inductive ConsStmt : Set_Stmt -> Set_Stmt -> Set_Stmt -> Prop :=
| PopStmtSingle : forall x,
  x <> StmtSkip ->
  (forall a b, x <> StmtSeq a b) ->
  ConsStmt x StmtSkip x
| PopStmtSeq : forall s1 s1' s2 s,
  ConsStmt s1 s1' s ->
  ConsStmt (StmtSeq s1 s2) (StmtSeq s1' s2) s
| PopStmtSeqSkip : forall s2,
  ConsStmt (StmtSeq StmtSkip s2) s2 StmtSkip
.

Hint Constructors ConsStmt.

Lemma ConsStmtCodomain : forall b, (exists s a, ConsStmt s a b) <-> (forall x y, b <> StmtSeq x y).
Proof.
  split; intro hyp.
  - unf.
    induction H0.
    * assumption.
    * assumption.
    * congruence.
  - generalize b hyp.
    clear.
    induction b; intro hyp.
    * exists (StmtSeq StmtSkip StmtSkip).
      eex.
    * eex.
      ctor; congruence.
    * eex.
      ctor; congruence.
    * eex.
      ctor; congruence.
    * specialize (hyp b1 b2).
      congruence.
Qed.

Lemma ConsStmtFirst : ∀ s12 s1 s2, ConsStmt s12 s2 s1 -> FirstStmt s12 s1.
Proof.
  induction s12; intros; inv H;
  try congruence;
  try (ctor; intro c; unf; congruence; fail).
  - ctor. eapply IHs12_1. eauto.
  - ctor. ctor; intro c; unf; congruence.
Qed.

Section Semantics.

Variable p : Set_Program.

Definition LookupMethodAmbig : Set_MethodName -> Set_Method -> Prop := fun n m =>
match p with
| Program ms _ => In m ms /\ (match m with Method _ n' _ _ _ _ => n' = n end)
end.
Definition LookupMethod : Set_MethodName -> Set_Method -> Prop := fun n m =>
  LookupMethodAmbig n m /\ (∀ m', LookupMethodAmbig n m' -> m = m').

Inductive Step : Set_State -> Set_State -> Prop :=
| StepSkip : ∀ (s : Set_Stmt) (rho : Set_VarEnv) (S : Set_Stack),
  Step
    (StackCons (StackFrame rho (StmtSeq StmtSkip s)) S)
    (StackCons (StackFrame rho s) S)
| StepAssert : ∀ (rho : Set_VarEnv) (S : Set_Stack) (phi : Set_Formula),
  EvalFormula rho phi ->
  Step
    (StackCons (StackFrame rho (StmtAssert phi)) S)
    (StackCons (StackFrame rho StmtSkip) S)
| StepVarAssign : ∀ (rho : Set_VarEnv) (S : Set_Stack) (x : Set_Var) (e : Set_Expr) (v : Set_Val),
  EvalExpr rho e v ->
  Step
    (StackCons (StackFrame rho (StmtVarAssign x e)) S)
    (StackCons (StackFrame (VarEnvMapping x v rho) StmtSkip) S)
| StepCall : ∀ (r : Set_Stmt) (phi : Set_Formula) (rho rho' : Set_VarEnv) (S : Set_Stack) (x y : Set_Var) (i : Set_Ident) (v : Set_Val) (m : Set_MethodName) (_T1 _T2 : Set_Type) (_phi : Set_Formula) S1 S2,
  LookupMethod m (Method _T1 m _T2 i (Contract phi _phi) r) ->
  EvalVar rho x v ->
  rho' = VarEnvMapping (VarOldIdent i) v (VarEnvMapping (VarIdent i) v VarEnvFresh) ->
  EvalFormula rho' phi ->
  ConsStmt S1 S2 (StmtCall y m x) ->
  Step
    (StackCons (StackFrame rho S1) S)
    (StackCons (StackFrame rho' r) (StackCons (StackFrame rho S1) S))
| StepCallFinish : ∀ (_r : Set_Stmt) (phi : Set_Formula) (rho rho' : Set_VarEnv) (S : Set_Stack) (x y : Set_Var) (i : Set_Ident) (v  : Set_Val) (m : Set_MethodName) (T _T : Set_Type) (_phi : Set_Formula) S1 S2,
  LookupMethod m (Method T m _T i (Contract _phi phi) _r) ->
  EvalVar rho' VarResult v ->
  EvalFormula rho' phi ->
  ConsStmt S1 S2 (StmtCall y m x) ->
  Step
    (StackCons (StackFrame rho' StmtSkip) (StackCons (StackFrame rho S1) S))
    (StackCons (StackFrame (VarEnvMapping y v rho) S2) S)
| StepSeq : ∀ (s1 : Set_Stmt) (s1' : Set_Stmt) (s2 : Set_Stmt) (rho : Set_VarEnv) (rho' : Set_VarEnv) (S : Set_Stack),
  s1 <> StmtSkip
  ->
  Step
    (StackCons (StackFrame rho s1) S)
    (StackCons (StackFrame rho' s1') S)
  ->
  Step
    (StackCons (StackFrame rho (StmtSeq s1 s2)) S)
    (StackCons (StackFrame rho' (StmtSeq s1' s2)) S)
.

(* stat sem *)

Inductive WP : Set_Stmt -> Set_Formula -> Set_Formula -> Prop :=
| WpSkip : ∀ (phi : Set_Formula),
  WP StmtSkip phi phi
| WpAssert : ∀ (phi phia : Set_Formula),
  WP (StmtAssert phia) phi (FormAnd phia phi)
| WpVarAssign : ∀ (phi phi' : Set_Formula) (x : Set_Var) (e : Set_Expr),
  (~ exists i, x = VarOldIdent i) ->
  SubstFormVarExpr x e phi phi' ->
  WP (StmtVarAssign x e) phi (FormAnd (FormCompOp CompOpEq e e) phi') (* impl. detail: additional precond. to ensure evaluation *)
| WpCall : ∀ (phi phi1 phi2 phi1' phi2' phi2'' phi' : Set_Formula) (x y : Set_Var) (i : Set_Ident) (m : Set_MethodName) (_T1 _T2 : Set_Type) (_s : Set_Stmt),
  (~ exists i, y = VarOldIdent i) ->
  x <> y ->
  x <> VarResult ->
  LookupMethod m (Method _T1 m _T2 i (Contract phi1 phi2) _s) ->
  SubstFormVarExpr (VarIdent i) (ExprVar x) phi1 phi1' ->
  SubstFormVarExpr (VarOldIdent i) (ExprVar x) phi2 phi2'' ->
  SubstFormVarExpr VarResult (ExprVar y) phi2'' phi2' ->
  MaxImplies (fun phi' =>
    (forall x', FreeVarForm x' phi' -> x = x') /\
    Implies phi' phi1' /\
    Implies (FormAnd phi' phi2') phi
  ) phi' ->
  WP (StmtCall y m x) phi (FormAnd phi' (FormCompOp CompOpEq (ExprVar x) (ExprVar x)))
| WpSeq : ∀ (s1 s2 : Set_Stmt) (phi1 phi2 phi3 : Set_Formula),
  WP s2 phi3 phi2 ->
  WP s1 phi2 phi1 ->
  WP (StmtSeq s1 s2) phi3 phi1
.

Hint Constructors WP.

Lemma ConsStmtWP : forall s12 s1 s2, ConsStmt s12 s2 s1 -> forall a c, WP s12 c a <-> exists b, WP s2 c b /\ WP s1 b a.
Proof.
  induction s12; intro; intro; intro co; inv co; intro; intro; split; intro gw;
  unf;
  try (congruence; fail);
  try (eex; fail).
  - inv H2.
    assumption.
  - inv H2.
    assumption.
  - inv H2.
    assumption.
  - inv gw.
    eapply IHs12_1 in H5; eauto.
    unf.
    eex.
  - inv H0.
    ctor; eauto.
    eapply IHs12_1; eauto.
  - inv gw.
    eex.
  - ctor; eauto.
Qed.

Inductive StackWP : list Set_Stmt -> Set_Formula -> list Set_Formula -> Prop :=
| StackWpMain : ∀ (s : Set_Stmt) (phi : Set_Formula) (phi' : Set_Formula),
  WP s phi phi' ->
  StackWP [s] phi [phi']
| StackWpCall : ∀ (s s' _s : Set_Stmt) (S : list Set_Stmt) (phi _phi1 phi2 phi' : Set_Formula) (phi'' : list Set_Formula) (x y : Set_Var) _i (m : Set_MethodName) (_T1 _T2 : Set_Type),
  LookupMethod m (Method _T1 m _T2 _i (Contract _phi1 phi2) _s) ->
  WP s phi2 phi' ->
  FirstStmt s' (StmtCall y m x) ->
  StackWP (s' :: S) phi phi'' ->
  StackWP (s :: s' :: S) phi (phi' :: phi'')
.

(* validity *)

Definition ValidMethod : Set_Method -> Prop := fun m =>
match m with
| Method _ _ _ i c s =>
  match c with
  | Contract phi1 phi2 =>
    (forall x', FreeVarForm x' phi1 -> x' = (VarIdent i)) /\
    (forall x', FreeVarForm x' phi2 -> x' = (VarOldIdent i) \/ x' = VarResult) /\
    (exists phi'' phi', WP s phi2 phi'' /\ SubstFormVarExpr (VarOldIdent i) (ExprVar (VarIdent i)) phi'' phi' /\ Implies phi1 phi') /\
    Implies phi2 (FormCompOp CompOpEq (ExprVar VarResult) (ExprVar VarResult))
  end
end.

Definition ValidProgram : Set_Program -> Prop := fun p =>
match p with
| Program ms s =>
  (exists phi, WP s FormTrue phi /\ Implies FormTrue phi) /\
  (forall m, In m ms -> ValidMethod m)
end.

Definition ValidStateClassic : Set_State -> Prop := fun pi => exists rhos ss phis,
  StateExtract pi rhos ss /\
  StackWP ss FormTrue phis /\
  Forall2 EvalFormula rhos phis
.

Inductive ValidStateEx : Set_Formula -> Set_State -> Prop :=
| ValidStateBase : forall phi' phi rho s,
  WP s phi' phi ->
  EvalFormula rho phi ->
  ValidStateEx phi' (StackCons (StackFrame rho s) StackEmpty)
| ValidStateCons : forall phi' phi rho rho' s s' S m x i v _y _T1 _T2 _r _phi1 phi2,
  WP s' phi2 phi ->
  EvalFormula rho' phi ->
  FirstStmt s (StmtCall _y m x) ->
  LookupMethod m (Method _T1 m _T2 i (Contract _phi1 phi2) _r) ->
  EvalVar rho x v ->
  EvalVar rho' (VarOldIdent i) v ->
  ValidStateEx phi' (StackCons (StackFrame rho s) S) ->
  ValidStateEx phi' (StackCons (StackFrame rho' s') (StackCons (StackFrame rho s) S))
.

Definition ValidState := ValidStateEx FormTrue.

(* WP of next step satisfied *)
Definition LocallyValidState : Set_State -> Prop := fun pi => exists rho s S phi' phi,
  pi = StackCons (StackFrame rho s) S /\
  WP s phi' phi /\
  EvalFormula rho phi /\
  (s = StmtSkip -> (S = StackEmpty \/ (exists s' _S rho' y m x _T1 _T2 i _phi1 phi2 _s,
                     S = StackCons (StackFrame rho' s') _S
                  /\ FirstStmt s' (StmtCall y m x)
                  /\ LookupMethod m (Method _T1 m _T2 i (Contract _phi1 phi2) _s)
                  /\ EvalFormula rho phi2)))
.

Lemma ValidStateClassicness : forall pi, ValidState pi -> ValidStateClassic pi.
Proof.
  induction pi; intro vs; inv vs.
  - exists [rho]. exists [s0]. exists [phi].
    split. ctor. ctor.
    split. ctor. assumption.
    ctor. assumption.
    ctor.
  - apply IHpi in H8.
    unfold ValidStateClassic in *.
    unf.
    exists (rho' :: x0).
    exists (s' :: x1).
    exists (phi :: x2).
    split. ctor. assumption.
    split.
    * inv H0. inv H.
      + ctor; eauto.
        ctor. assumption.
      + ctor. Focus 2. eauto.
        eauto. eauto.
        ctor; eauto.
    * ctor; auto.
Qed.

Lemma LookupMethodDet : forall m m1 m2, LookupMethod m m1 -> LookupMethod m m2 -> m1 = m2.
Proof.
  intro. intro. intro. intro l1. intro l2.
  unfold LookupMethod in *. unf.
  apply H0 in H1. auto.
Qed.

Lemma LocalValidity : ∀ pi : Set_State, ValidState pi -> LocallyValidState pi.
Proof.
  intro pi.
  intro valid.
  unfold LocallyValidState in *.
  inv valid.
  - eex.
  - eex.
    intro ss. subst.
    inv H.
    apply or_intror.
    eex.
Qed.

Axiom Validity : ValidProgram p.

(* soundness *)

Definition FinalState : Set_State -> Prop := fun pi =>
  pi = StackEmpty \/
  (exists rho, pi = StackCons (StackFrame rho StmtSkip) StackEmpty).

Definition UsedVarForm (x : Set_Var) (phi : Set_Formula) := ~ ∀ rho, EvalFormula rho phi -> ∀ v, EvalFormula (VarEnvMapping x v rho) phi.
Definition UsedVarExpr (x : Set_Var) (e : Set_Expr) := ~ ∀ rho ve, EvalExpr rho e ve -> ∀ v, EvalExpr (VarEnvMapping x v rho) e ve.

Definition Z1 : Z := Zpos 1.

Lemma UsedVarExprVar : forall e, UsedVarExpr e (ExprVar e).
Proof.
  intros. intro.
  specialize (H (VarEnvMapping e Z0 VarEnvFresh) Z0).
  lapply H.
  - intro c.
    specialize (c Z1).
    inv c. inv H2. congruence.
  - ctor. ctor.
Qed.

(* dyn sem helper *)

Inductive InitializeVars : list Set_Var -> Set_VarEnv -> Set_VarEnv -> Prop :=
| InitializeVarsEmpty : forall rho, InitializeVars [] rho rho
| InitializeVarsCons : forall x xs rho rho',
  InitializeVars xs rho rho' ->
  InitializeVars (x :: xs) rho (VarEnvMapping x Z0 rho')
.
Lemma InitializeVarsExists : forall xs rho, exists rho', InitializeVars xs rho rho'.
Proof.
  induction xs; intro.
  - eexists. ctor.
  - specialize (IHxs rho).
    unf.
    eexists. ctor. eauto.
Qed.

Lemma NoUsedVarExprIsConst : ∀ e, (∀ x : Set_Var, ~ UsedVarExpr x e) -> ∀ v1 v2 rho1 rho2, EvalExpr rho1 e v1 -> EvalExpr rho2 e v2 -> v1 = v2.
Proof.
  intros.
  assert (exists xs, forall x, FreeVarExpr x e -> In x xs) as fvs.
    generalize e. clear.
    induction e.
      exists []. intros. inv H.
      exists [s]. intros. inv H. ctor. auto.
      unf. exists (app x x0). intro. specialize (H x1). specialize (H0 x1).
      intro fve. inv fve. intuition.
  unf.
  assert (ee1 := InitializeVarsExists x rho1).
  assert (ee2 := InitializeVarsExists x rho2).
  unf.
  assert (EvalExpr x1 e v1) as e1.
    generalize x x1 H4. clear x H4 H2 H3. induction x; intros.
      inv H4. assumption.
      inv H4. specialize (H a). apply NNPP in H. apply H. apply IHx. assumption.
  assert (EvalExpr x0 e v2) as e2.
    generalize x x0 H3. clear x H4 H2 H3. induction x; intros.
      inv H3. assumption.
      inv H3. specialize (H a). apply NNPP in H. apply H. apply IHx. assumption.
  clear H0 H1.

  apply (ObservablyIdenticalVarEnvEvalExpr x1 x0 x) in e1; auto.
    eapply EvalExprDet; eauto.
  intros.
  generalize x x0 x1 H3 H4 H1. clear.
  induction x; intro; intro; intro iv1; intro iv2; intro inx; inv inx.
  - inv iv1. inv iv2.
    split; intro ev; inv ev; try congruence; ctor.
  - inv iv1. inv iv2.
    eapply IHx in H4; eauto.
    clac (a = x2).
    * subst.
      split; intro ev; inv ev; try congruence; ctor.
    * split; intro ev; inv ev ; try congruence; ctor; auto;
      apply H4; auto.
Qed.

Lemma UsedVarExprEvaluable : ∀ e x, UsedVarExpr x e -> Evaluable e.
Proof.
  unfold UsedVarExpr.
  intro. intro. intro uv.
  clac (Evaluable e); auto.
  contradict uv.
  intro. intro. intro ee.
  contradict H.
  eexists. eexists. eauto.
Qed.

Lemma UsedVarFormSatisfiable : ∀ phi x, UsedVarForm x phi -> Satisfiable phi.
Proof.
  unfold UsedVarForm.
  intro. intro. intro uv.
  clac (Satisfiable phi); auto.
  contradict uv.
  intro. intro. intro ef.
  contradict H.
  eexists. eauto.
Qed.

Lemma UsedVarExprFree : ∀ x e, UsedVarExpr x e -> FreeVarExpr x e.
Proof.
  unfold UsedVarExpr.
  induction e; intro uv.
  - contradict uv.
    intro. intro. intro ee. intro.
    inv ee.
    ctor.
  - clac (x = s).
    * subst. ctor.
    * contradict uv.
      intro. intro. intro ee. intro.
      inv ee.
      ctor. ctor; auto.
  - ctor.
    apply not_all_ex_not in uv. inv uv.
    apply not_all_ex_not in H. inv H.
    apply not_all_ex_not in H0. inv H0.
    apply not_all_ex_not in H. inv H.
    inv x2.
    assert (~ EvalExpr (VarEnvMapping x x3 x0) e1 v1 \/ ~ EvalExpr (VarEnvMapping x x3 x0) e2 v2) as ee.
      apply not_and_or.
      intro ee. inv ee.
      contradict H0. ctor; eauto.
    clear H0.
    inv ee.
    * apply or_introl.
      apply IHe1.
      repeat (apply ex_not_not_all; eexists; eauto).
    * apply or_intror.
      apply IHe2.
      repeat (apply ex_not_not_all; eexists; eauto).
Qed.

Lemma UsedVarFormFree : ∀ x phi, UsedVarForm x phi -> FreeVarForm x phi.
Proof.
  unfold UsedVarForm.
  induction phi; intro uv.
  - contradict uv.
    intro. intro. intro. ctor.
  - ctor.
    apply not_all_ex_not in uv. inv uv.
    apply not_all_ex_not in H. inv H.
    apply not_all_ex_not in H0. inv H0.
    inv x1.
    assert (~ EvalExpr (VarEnvMapping x x2 x0) s0 v1 \/ ~ EvalExpr (VarEnvMapping x x2 x0) s1 v2) as ee.
      apply not_and_or.
      intro ee. inv ee.
      contradict H. ctor; eauto.
    clear H.
    inv ee.
    * apply or_introl.
      apply UsedVarExprFree.
      repeat (apply ex_not_not_all; eexists; eauto).
    * apply or_intror.
      apply UsedVarExprFree.
      repeat (apply ex_not_not_all; eexists; eauto).
  - ctor.
    apply not_all_ex_not in uv. inv uv.
    apply not_all_ex_not in H. inv H.
    apply not_all_ex_not in H0. inv H0.
    inv x1.
    assert (~ EvalFormula (VarEnvMapping x x2 x0) phi1 \/ ~ EvalFormula (VarEnvMapping x x2 x0) phi2) as ee.
      apply not_and_or.
      intro ee. inv ee.
      contradict H. ctor; eauto.
    clear H.
    inv ee.
    * apply or_introl.
      apply IHphi1.
      repeat (apply ex_not_not_all; eexists; eauto).
    * apply or_intror.
      apply IHphi2.
      repeat (apply ex_not_not_all; eexists; eauto).
Qed.

Lemma SwapVarEnvEvalVar : ∀ x1 x2,
  x1 <> x2 -> ∀ v1 v2 rho x v,
  EvalVar (VarEnvMapping x1 v1 (VarEnvMapping x2 v2 rho)) x v ->
  EvalVar (VarEnvMapping x2 v2 (VarEnvMapping x1 v1 rho)) x v.
Proof.
  intro. intro. intro neq. intro. intro. intro. intro. intro. intro ev.
  inv ev.
  - ctor; auto. ctor.
  - inv H5.
    * ctor.
    * ctor; auto. ctor; auto.
Qed.

Lemma SwapVarEnvEvalExpr : ∀ x1 x2,
  x1 <> x2 -> ∀ v1 v2 rho e v,
  EvalExpr (VarEnvMapping x1 v1 (VarEnvMapping x2 v2 rho)) e v ->
  EvalExpr (VarEnvMapping x2 v2 (VarEnvMapping x1 v1 rho)) e v.
Proof.
  intro. intro. intro neq. intro. intro. intro.
  induction e; intro; intro ev; inv ev.
  - ctor.
  - ctor. apply SwapVarEnvEvalVar; assumption.
  - ctor; eauto.
Qed.

Lemma SwapVarEnvEvalFormula : ∀ x1 x2,
  x1 <> x2 -> ∀ v1 v2 rho phi,
  EvalFormula (VarEnvMapping x1 v1 (VarEnvMapping x2 v2 rho)) phi ->
  EvalFormula (VarEnvMapping x2 v2 (VarEnvMapping x1 v1 rho)) phi.
Proof.
  intro. intro. intro neq. intro. intro. intro.
  induction phi; intro ev; inv ev.
  - ctor.
  - ctor; eauto; apply SwapVarEnvEvalExpr; assumption.
  - ctor; eauto.
Qed.

Lemma RecStack1 : ∀ (pi : Set_State) sf, ~ StackCons sf pi = pi.
Proof.
  induction pi; congruence.
Qed.
Lemma RecStack2 : ∀ (pi : Set_State) sf1 sf2, ~ StackCons sf1 (StackCons sf2 pi) = pi.
Proof.
  induction pi; congruence.
Qed.

Lemma StepPopOnlyWithSkip : ∀ (pi : Set_State) r' s' r1 s1 r2 s2,
  Step (StackCons (StackFrame r' s') (StackCons (StackFrame r1 s1) pi))
                                     (StackCons (StackFrame r2 s2) pi) ->
  s' = StmtSkip.
Proof.
  intro. intro.
  induction s'; intro; intro; intro; intro; intro step.
  - auto.
  - contradict step. generalize s1 s2. clear.
    unfold not. induction s1; intro; intro step; inv step;
    try (apply RecStack1 in H6; auto);
    try (apply RecStack2 in H4; auto).
  - contradict step. generalize s3 s2. clear.
    unfold not. induction s3; intro; intro step.
    * inv step. apply RecStack2 in H4. auto.
    * inv step. apply RecStack2 in H4. auto.
    * inv step. apply RecStack2 in H4. auto.
    * inv step. apply RecStack2 in H4. auto.
    * inv step. apply RecStack2 in H4. auto.
  - contradict step. generalize s1 s2. clear.
    unfold not. induction s1; intro; intro step; inv step;
    try (apply RecStack1 in H5; auto);
    try (apply RecStack2 in H4; auto).
  - contradict step. generalize s1 s2. clear.
    unfold not. induction s1; intro; intro step; inv step;
    try (apply RecStack1 in H6; auto);
    try (apply RecStack2 in H4; auto).
Qed.

(* static sem *)

Lemma SubstExprFreeVar : ∀ x e e1 e2,
  SubstExprVarExpr x e e1 e2 -> ∀ x1,
  FreeVarExpr x1 e1 ->
  ((x <> x1 /\ FreeVarExpr x1 e2) \/ (x = x1 /\ forall x2, FreeVarExpr x2 e -> FreeVarExpr x2 e2)).
Proof.
  intro. intro.
  induction e1; intro; intro subst; intro; intro fv.
  - inv subst. inv fv.
  - inv subst.
    * inv fv. auto.
    * inv fv. ctor. ctor; auto. ctor.
  - inv subst.
    inv fv. inv H1.
    * eapply (IHe1_1 e1') in H; auto.
      inv H; unf.
      + ctor. ctor; auto. ctor. auto.
      + apply or_intror. ctor; auto.
        intro. intro fv. apply H1 in fv. ctor. auto.
    * eapply (IHe1_2 e2') in H; auto.
      inv H; unf.
      + ctor. ctor; auto. ctor. auto.
      + apply or_intror. ctor; auto.
        intro. intro fv. apply H1 in fv. ctor. auto.
Qed.

Lemma SubstFormFreeVar : ∀ x e phi1 phi2,
  SubstFormVarExpr x e phi1 phi2 -> ∀ x1,
  FreeVarForm x1 phi1 ->
  ((x <> x1 /\ FreeVarForm x1 phi2) \/ (x = x1 /\ forall x2, FreeVarExpr x2 e -> FreeVarForm x2 phi2)).
Proof.
  intro. intro.
  induction phi1; intro; intro subst; intro; intro fv.
  - inv subst. inv fv.
  - inv subst. inv fv. inv H1.
    * eapply SubstExprFreeVar in H; eauto.
      inv H; unf.
      + ctor. ctor; auto. ctor. auto.
      + apply or_intror. ctor; auto.
        intro. intro fv. apply H1 in fv. ctor. auto.
    * eapply SubstExprFreeVar in H; eauto.
      inv H; unf.
      + ctor. ctor; auto. ctor. auto.
      + apply or_intror. ctor; auto.
        intro. intro fv. apply H1 in fv. ctor. auto.
  - inv subst. inv fv. inv H1.
    * eapply (IHphi1_1 phi1') in H; eauto.
      inv H; unf.
      + ctor. ctor; auto. ctor. auto.
      + apply or_intror. ctor; auto.
        intro. intro fv. apply H1 in fv. ctor. auto.
    * eapply (IHphi1_2 phi2') in H; eauto.
      inv H; unf.
      + ctor. ctor; auto. ctor. auto.
      + apply or_intror. ctor; auto.
        intro. intro fv. apply H1 in fv. ctor. auto.
Qed.

(* end *)

Lemma ProgressHelper : ∀ (pi : Set_State),
  LocallyValidState pi ->
  ~ FinalState pi ->
  (exists pi', Step pi pi').
Proof.
  destruct pi as [ | frame]; intro valid; intro not_final.
  - contradict not_final.
    reduce.
    auto.
  - destruct frame as [rho s].
    induction s.
    * destruct pi.
      + contradict not_final.
        reduce.
        eauto.
      + clear not_final.
        inv valid.
        unf.
        inv H0.
        intuition; try congruence.
        unf.
        inv H.
        inv H0.
        generalize x0 H2. clear x0 H2 H1.
        induction x0; intros; inv H2.
        **assert (exists v, EvalVar x VarResult v) as exx.
            assert (val := Validity). unfold ValidProgram in val.
            unfold LookupMethod in H3. unfold LookupMethodAmbig in H3.
            destruct p. unf. apply H0 in H3. inv H3.
            apply H8 in H5. inv H5. inv H13. eex.
          inv exx.
          eexists; eapply StepCallFinish; eauto. ctor. congruence. intros. congruence.
        **apply IHx0_1 in H4.
          unf.
          inversion H; subst.
          ++inv H10.
          ++eexists.
            eapply StepCallFinish;
            eauto.
    * clear not_final.
      inv valid.
      unf.
      clear H3.
      inv H0.
      inv H.
      inv H1.
      inv H4.
      eexists.
      eapply StepVarAssign.
      eauto.
    * clear not_final.
      inv valid.
      unf.
      clear H3.
      inv H0.
      inv H.
      inv H1.
      inv H13.
      unf.
      inv H10.
      inv H16.
      eexists.
      eapply StepCall; eauto.

      assert (lookup := H7).
      clear H5 H6 H11 H12 H17 H18.
      assert (EvalExpr x (ExprVar s1) v1) as ee. ctor. assumption.
      apply SwapVarEnvEvalFormula; try congruence.
      assert (subst := H8).
      eapply SubstFormSemantics in H8; eauto.
      apply H in H3. symmetry in H8. rewrite H8 in H3. clear H8.
      rewrite (ObservablyIdenticalVarEnvEvalFormula [(VarIdent i)]); eauto.
      --intro gx. intro ingx. inv ingx; try (intuition; fail).
        intro v. split; intro ev; inv ev; try (intuition; fail); ctor.
      --assert (va := Validity). unfold ValidProgram in va.
        inv lookup. unfold LookupMethodAmbig in H2.
        destruct p. unf.
        apply H10 in H6. inv H6.
        intro xx. intro fv. apply H11 in fv. ctor. congruence.
      --ctor. congruence. intros. congruence.
    * clear not_final.
      inv valid.
      unf.
      clear H3.
      inv H0.
      inv H.
      inv H1.
      eexists.
      eapply StepAssert.
      assumption.
    * clear not_final IHs2.
      clac (s1 = StmtSkip).
      + subst.
        eexists.
        eapply StepSkip.
      + assert (∃ pi' : Set_State, Step (StackCons (StackFrame rho s1) pi) pi').
          apply IHs1.
            inv valid. unf. inv H1. clear H4.
            inv H0.
            unfold LocallyValidState.
            eex. intros. subst. congruence.
          unfold not. intro fs. inv fs; try congruence.
          unf. inv H1. congruence.
        clear IHs1 valid.
        unf. destruct x.
          inv H1.
        destruct s.
        clac (x = pi).
        --subst.
          exists (StackCons (StackFrame s (StmtSeq s0 s2)) pi).
          constructor; assumption.
        --inversion H1; try congruence; subst.
          eexists. eapply StepCall; eauto.
Qed.

Proposition Progress : ∀ (pi : Set_State),
  ValidState pi ->
  ~ FinalState pi ->
  (exists pi', Step pi pi').
Proof.
  intros.
  apply ProgressHelper; auto.
  apply LocalValidity.
  auto.
Qed.

Inductive Invariant : Set_State -> Prop :=
| InvariantBase : forall rho s, Invariant (StackCons (StackFrame rho s) StackEmpty)
| InvariantCons : forall rho rho' s s' S m x i v _y _T1 _T2 _c _r,
  FirstStmt s (StmtCall _y m x) ->
  LookupMethod m (Method _T1 m _T2 i _c _r) ->
  EvalVar rho x v ->
  EvalVar rho' (VarOldIdent i) v ->
  Invariant (StackCons (StackFrame rho s) S) ->
  Invariant (StackCons (StackFrame rho' s') (StackCons (StackFrame rho s) S))
.

Lemma StepLocalityLocal1 : ∀ s s' rho rho',
  Step (StackCons (StackFrame rho s) StackEmpty) (StackCons (StackFrame rho' s') StackEmpty) ->
  ∀ pi, Step (StackCons (StackFrame rho s) pi) (StackCons (StackFrame rho' s') pi).
Proof.
  induction s; intro; intro; intro; intro step; intro;
  inv step;
  ctor; auto.
Qed.

Lemma StepLocalityLocal2 : ∀ s s' rho rho' pi,
  Step (StackCons (StackFrame rho s) pi) (StackCons (StackFrame rho' s') pi) ->
  Step (StackCons (StackFrame rho s) StackEmpty) (StackCons (StackFrame rho' s') StackEmpty).
Proof.
  induction s; intros;
  inv H;
  try (ctor; auto; fail).
  - apply RecStack1 in H5. inv H5.
  - symmetry in H4. apply RecStack1 in H4. inv H4.
  - apply RecStack1 in H5. inv H5.
  - apply RecStack1 in H5. inv H5.
  - apply RecStack1 in H5. inv H5.
  - apply RecStack1 in H5. inv H5.
  - eapply StepSeq; eauto.
Qed.

Lemma StepLocalityLocal : ∀ s s' rho rho' pi,
  Step (StackCons (StackFrame rho s) pi) (StackCons (StackFrame rho' s') pi) <->
  Step (StackCons (StackFrame rho s) StackEmpty) (StackCons (StackFrame rho' s') StackEmpty).
Proof.
  split; intro step.
  - eapply StepLocalityLocal2; eauto.
  - eapply StepLocalityLocal1; eauto.
Qed.

Lemma PreservationLocal : ∀ s s' rho rho',
  Step (StackCons (StackFrame rho s) StackEmpty) (StackCons (StackFrame rho' s') StackEmpty) -> forall p,
  (exists phi,  WP s  p phi  /\ EvalFormula rho  phi) ->
  (exists phi', WP s' p phi' /\ EvalFormula rho' phi').
Proof.
  induction s; intro; intro; intro; intro step; intro; intro valid;
  unf;
  rename H0 into wp;
  rename H1 into ev;
  inv wp; inv step.
  - inv ev.
    eexists.
    repeat ctor.
    eapply SubstFormSemantics; eauto.
  - inv ev.
    eexists.
    repeat ctor.
    assumption.
  - inv H4.
    eexists.
    split; eauto.
  - eapply IHs1 in H8.
    Focus 2. eexists. split; eauto.
    unf.
    eexists.
    split; eauto.
Qed.

Proposition PreservationEnter : ∀ y m x s rho rho',
  Step (StackCons (StackFrame rho (StmtCall y m x)) StackEmpty)
       (StackCons (StackFrame rho' s) (StackCons (StackFrame rho (StmtCall y m x)) StackEmpty)) ->
  (exists phi' phi2 _T1 _T2 i _phi1 v,
            (LookupMethod m (Method _T1 m _T2 i (Contract _phi1 phi2) s)) /\
            EvalVar rho x v /\
            EvalVar rho' (VarOldIdent i) v /\
            WP s phi2 phi' /\ EvalFormula rho' phi').
Proof.
  intro; intro; intro; intro; intro; intro; intro step.
  inv step.
  assert (exists p, WP s _phi p /\ forall rho, EvalVar rho (VarOldIdent i) v -> EvalVar rho (VarIdent i) v -> EvalFormula rho phi -> EvalFormula rho p) as ex.
    assert (val := Validity). unfold ValidProgram, LookupMethod, LookupMethodAmbig in *.
    destruct p. unf. apply H0 in H4.
    inv H4. unf.
    eexists.
    split. eauto.
    intro. intro ev1. intro ev2. intro ef.
    apply H13 in ef.
    eapply SubstFormSemantics in H9; eauto.
    Focus 2. ctor. eauto.
    apply H9 in ef.
    assert (fvl := FreeVarFormUpperBound x2). unf.
    eapply ObservablyIdenticalVarEnvEvalFormula; eauto.
    intro. intro inx. intro.
    split; intro evar.
      clac (x5 = VarOldIdent i).
        subst. assert (v0 = v). eapply EvalVarDet in evar; eauto. subst. ctor.
        ctor; auto.
      inv evar; auto.
  unf.
  inv H8.
  eexists. eexists. eexists. eexists. eexists. eexists. eexists.
  split. eauto.
  split. eauto.
  split. ctor.
  split. eauto.
  apply H1.
  - ctor.
  - ctor; try congruence. ctor.
  - assumption.
Qed.

Lemma StepLocalityEnter : ∀ s s' s'' rho rho' rho'' pi,
  Step (StackCons (StackFrame rho s) pi) (StackCons (StackFrame rho' s') (StackCons (StackFrame rho'' s'') pi)) <->
  Step (StackCons (StackFrame rho s) StackEmpty) (StackCons (StackFrame rho' s') (StackCons (StackFrame rho'' s'') StackEmpty)).
Proof.
  induction s; split; intro step; inv step;
  try (symmetry in H3; apply RecStack2 in H3; inv H3; fail);
  try (symmetry in H4; apply RecStack2 in H4; inv H4; fail);
  try (symmetry in H5; apply RecStack1 in H5; inv H5; fail);
  try (symmetry in H6; apply RecStack1 in H6; inv H6; fail).
  - ctor; eauto.
  - ctor; eauto.
  - inv H10.
  - inv H10.
  - inv H10. ctor; eauto.
  - inv H10. ctor; eauto.
  - inv H10.
  - inv H10.
  - inv H10. ctor; eauto.
  - inv H10. ctor; eauto.
Qed.

Lemma ConsStmtDet : forall S1 S2 s1 s2, ConsStmt S1 S2 s1 -> ConsStmt S1 S2 s2 -> s1 = s2.
Proof.
  induction S1; intro; intro; intro; intro c1; intro c2;
  inv c1; inv c2; auto.
  - specialize (H0 StmtSkip StmtSkip). congruence.
  - eapply IHS1_1; eauto.
  - inv H3. auto.
  - specialize (H0 StmtSkip StmtSkip). congruence.
  - inv H3. auto.
Qed.

Proposition PreservationExit : ∀ S1 S2 y m x s rho rho' rho'' _phi1 phi2 i _T1 _T2 v,
  Step (StackCons (StackFrame rho'' StmtSkip) (StackCons (StackFrame rho S1) StackEmpty))
       (StackCons (StackFrame rho' S2) StackEmpty) ->
  ConsStmt S1 S2 (StmtCall y m x) ->
  EvalVar rho x v -> EvalVar rho'' (VarOldIdent i) v ->
  LookupMethod m (Method _T1 m _T2 i (Contract _phi1 phi2) s) -> forall p,
  (exists phi, WP (StmtCall y m x) p phi /\ EvalFormula rho phi) ->
  EvalFormula rho' p.
Proof.
  intro. intro. intro. intro. intro. intro. intro. intro. intro. intro. intro. intro. intro. intro. intro.
  intro step. intro fst. intro ev1. intro ev2. intro lookup. intro.
  intro pre.
  unf.
  inv step.
  inv H0.
  eapply LookupMethodDet in lookup; eauto. inv lookup.
  eapply ConsStmtDet in fst; eauto. inv fst. assert (fst := H10). apply ConsStmtFirst in fst.
  eapply LookupMethodDet in H6; eauto. inv H6.
  inv H17. apply H. (*MaxImplies*)
  ctor.
  - inv H1.
    eapply (ObservablyIdenticalVarEnvEvalFormula [x]); eauto.
    * intro gx. intro ingx. inv ingx; try (intuition; fail).
      intro vx. split; intro ev.
      + inv ev; try congruence.
      + ctor; assumption.
    * intro xx. intro fvf. apply H in fvf. subst. ctor. auto.
  - (* first subst *)
    assert (EvalExpr (VarEnvMapping y v0 rho) (ExprVar y) v0) as tmp.
      ctor. ctor.
    eapply SubstFormSemantics in H16; eauto.
    symmetry in H16.
    rewrite H16.
    clear H16 tmp.
    (* second subst *)
    assert (exists vv, EvalExpr (VarEnvMapping VarResult v0 (VarEnvMapping y v0 rho)) (ExprVar x) vv /\ EvalVar rho'' (VarOldIdent i0) vv) as tmp.
      inv H1. inv H15. exists v1. inv H16.
      split.
        ctor. ctor; try congruence. ctor; congruence.
        eapply EvalVarDet in ev1; eauto.
        subst. assumption.
    inv tmp. inv H2.
    eapply SubstFormSemantics in H13; eauto.
    symmetry in H13.
    rewrite H13. clear H13.
    (* obs. eq. *)
    eapply (ObservablyIdenticalVarEnvEvalFormula [(VarOldIdent i0); VarResult]); eauto.
    * inv H3. inv H14; try congruence. inv H18; try congruence.
      intro gx. intro ingx. intro vv.
      split; intro ev.
      + inv ev; auto.
        inv ingx; try congruence. inv H2. Focus 2. inv H3.
        inv H20; try intuition.
      + inv ingx.
        --eapply EvalVarDet in H6; eauto. subst. ctor.
        --inv H2; try (intuition; fail).
          ctor; try congruence.
          eapply EvalVarDet in H8; eauto. subst. ctor.
    * intro. intro fvf.
      assert (va := Validity).
      unfold ValidProgram in va.
      rename H11 into lookup. inv lookup. unfold LookupMethodAmbig in *.
      destruct p. unf. apply H15 in H13.
      reduce in H13.
      apply H13 in fvf. inv fvf; intuition.
Qed.

Lemma StepLocalityExit : ∀ s'' s s' rho rho' rho'' pi,
  Step (StackCons (StackFrame rho s) (StackCons (StackFrame rho'' s'') pi)) (StackCons (StackFrame rho' s') pi) <->
  Step (StackCons (StackFrame rho s) (StackCons (StackFrame rho'' s'') StackEmpty)) (StackCons (StackFrame rho' s') StackEmpty).
Proof.
  induction s''; split; intro step; inv step;
  try (apply RecStack1 in H5; inv H5; fail);
  try (apply RecStack2 in H4; inv H4; fail);
  inv H9;
  auto.
  - ctor; eauto.
  - ctor; eauto.
  - ctor; eauto.
  - ctor; eauto.
Qed.

Proposition ValidStateLocality : ∀ p rho' s' rho s pi,
  ValidStateEx p (StackCons (StackFrame rho' s') (StackCons (StackFrame rho s) pi)) <->
  ValidStateEx p (StackCons (StackFrame rho s) pi) /\
  (exists m phi _phi _y _x _T1 _T2 _i _r v, FirstStmt s (StmtCall _y m _x) /\ LookupMethod m (Method _T1 m _T2 _i (Contract _phi phi) _r) /\
  EvalVar rho' (VarOldIdent _i) v /\
  EvalVar rho _x v /\
  ValidStateEx phi (StackCons (StackFrame rho' s') StackEmpty)).
Proof.
  split; intro vs.
  - inv vs.
    split; auto.
    eex.
    ctor; eauto.
  - unf.
    inv H5.
    ctor; eauto.
Qed.

Proposition ValidStateTopMost : ∀ p sf pi,
  ValidStateEx p (StackCons sf pi) ->
  exists p', ValidStateEx p' (StackCons sf StackEmpty).
Proof.
  intros.
  destruct pi.
  - eex.
  - destruct sf. destruct s. apply ValidStateLocality in H.
    unf.
    eex.
Qed.

Proposition PreservationLocalEx : ∀ pi sf sf',
  Step (StackCons sf pi) (StackCons sf' pi) -> forall p,
  (ValidStateEx p (StackCons sf pi)) ->
  (ValidStateEx p (StackCons sf' pi)).
Proof.
  intro. intro. intro. intro step. intro. intro valid.
  destruct sf. destruct sf'.
  apply StepLocalityLocal in step.
  destruct pi.
  - inv valid.
    eapply PreservationLocal in step.
    Focus 2. eex.
    unf.
    ctor; eauto.
  - destruct s3. apply ValidStateLocality in valid.
    apply ValidStateLocality.
    split. apply valid.
    apply proj2 in valid.
    unf.
    assert (step' := step).
    eapply PreservationLocal in step.
    Focus 2. inv H4. eex.
    unf.
    eex.
    * inv H4.
      generalize s0 x0 s2 phi H9 H1 step'. clear. induction s0; intro; intro; intro; intro wp; intro ev; intro step; inv step; auto.
      + inv wp.
        eapply not_ex_all_not in H2.
        ctor; eauto.
      + inv wp.
        eapply IHs0_1 in H6; eauto.
    * ctor; eauto.
Qed.

Lemma PreservationEnterExHelper : ∀ s0 rho sf' sf'' pi,
  Step (StackCons (StackFrame rho s0) pi) (StackCons sf' (StackCons sf'' pi)) -> forall p,
  (ValidStateEx p (StackCons (StackFrame rho s0) StackEmpty)) ->
  (StackFrame rho s0) = sf'' /\
  exists rho' s2 y m x,
  sf' = (StackFrame rho' s2) /\
  FirstStmt s0 (StmtCall y m x) /\
  exists _T1 _T2 x' _phi phi,
  LookupMethod m (Method _T1 m _T2 x' (Contract _phi phi) s2) /\
  ValidStateEx phi (StackCons sf' StackEmpty) /\
  exists v, EvalVar rho x v /\ EvalVar rho' (VarOldIdent x') v.
Proof.
  intro; intro; intro; intro; intro; intro step; intro; intro valid; inv step;
  try (symmetry in H2; apply RecStack2 in H2; inv H2; fail);
  try (symmetry in H3; apply RecStack2 in H3; inv H3; fail);
  try (symmetry in H4; apply RecStack1 in H4; inv H4; fail);
  try (symmetry in H5; apply RecStack1 in H5; inv H5; fail);
  try (inv H8).
  - split. auto.
    eexists. eexists. eexists. eexists. eexists.
    split. ctor.
    split. ctor. intro c. unf. inv H2.
    eexists. eexists. eexists. eexists. eexists.
    split. eauto.
    split. Focus 2. eex. ctor.

    assert (val := Validity).
    unfold ValidProgram, LookupMethod, LookupMethodAmbig in *. destruct p. unf. apply H2 in H4. inv H4. unf. ctor. eauto.
    apply H14 in H7. eapply SubstFormSemantics in H10. apply H10 in H7. Focus 2. ctor. ctor; try congruence. ctor.
    assert (fvf := FreeVarFormUpperBound x1). unf.
    eapply ObservablyIdenticalVarEnvEvalFormula; eauto.
    intros. split; intro ev; inv ev; ctor; auto.
    * ctor; auto.
    * inv H23; congruence.
  - split. auto.
    eexists. eexists. eexists. eexists. eexists.
    split. ctor.
    split. ctor. eapply ConsStmtFirst. eauto.
    eexists. eexists. eexists. eexists. eexists.
    split. eauto.
    split. Focus 2. eex. ctor.

    assert (val := Validity).
    unfold ValidProgram, LookupMethod, LookupMethodAmbig in *. destruct p. unf. apply H1 in H4. inv H4. unf. ctor. eauto.
    apply H13 in H7. eapply SubstFormSemantics in H9. apply H9 in H7. Focus 2. ctor. ctor; try congruence. ctor.
    assert (fvf := FreeVarFormUpperBound x1). unf.
    eapply ObservablyIdenticalVarEnvEvalFormula; eauto.
    intros. split; intro ev; inv ev; ctor; auto.
    * ctor; auto.
    * inv H22; congruence.
Qed.

Lemma PreservationEnterEx : ∀ sf sf' sf'' pi,
  Step (StackCons sf pi) (StackCons sf' (StackCons sf'' pi)) -> forall p,
  (ValidStateEx p (StackCons sf pi)) ->
  (ValidStateEx p (StackCons sf' (StackCons sf'' pi))).
Proof.
  intro. destruct sf. generalize s0 s. clear.
  intro; intro; intro; intro; intro; intro step; intro; intro valid;
  destruct sf'; destruct sf''.
  destruct pi.
  - eapply PreservationEnterExHelper in step; eauto.
    unf. inv H. inv H0.
    eapply ValidStateLocality.
    split; auto.
    eex.
  - destruct s5. apply ValidStateLocality in valid.
    unf.
    eapply PreservationEnterExHelper in step; eauto.
    unf. inv H4. inv H6.
    eapply ValidStateLocality.
    split. inv H5. ctor; eauto.
    eex.
Qed.

Lemma FirstStmtDet : forall s s1 s2, FirstStmt s s1 -> FirstStmt s s2 -> s1 = s2.
Proof.
  induction s; intro; intro; intro fs1; intro fs2; inv fs1; inv fs2; auto.
  - contradict H. eex.
  - contradict H. eex.
Qed.

Lemma StepExitDoesntAlterOldVariable : forall s s' rho rho' sf i v phi1 phi2,
  WP s phi1 phi2 ->
  Step (StackCons sf (StackCons (StackFrame rho s) StackEmpty)) (StackCons (StackFrame rho' s') StackEmpty) ->
  EvalVar rho (VarOldIdent i) v ->
  EvalVar rho' (VarOldIdent i) v.
Proof.
  induction s; intro; intro; intro; intro; intro; intro; intro; intro; intro wp; intro step; intro ev; inv step; inv H8.
  - inv wp.
    ctor; eauto.
  - inv wp.
    eapply IHs1 in H8; eauto.
    ctor; eauto.
Qed.

Lemma PreservationExitEx : ∀ sf'' sf sf' pi,
  Step (StackCons sf' (StackCons sf'' pi)) (StackCons sf pi) -> forall p,
  (ValidStateEx p (StackCons sf' (StackCons sf'' pi))) ->
  (ValidStateEx p (StackCons sf pi)).
Proof.
  intro. intro. intro. intro. intro step. intro. intro valid.
  destruct sf'. destruct sf''.
  destruct sf.
  apply StepLocalityExit in step.
  assert (s0 = StmtSkip). inv step. auto. subst.
  inv valid.
  inv H4.
  assert (ConsStmt s2 s4 (StmtCall _y m x)). inv step. assert (co := H14). apply ConsStmtFirst in H14. eapply FirstStmtDet in H7; eauto. inv H7. assumption.
  inv H11.
  - eapply ConsStmtWP in H3; eauto. unf.
    ctor; eauto.
    eapply PreservationExit in step; eauto.
  - eapply ConsStmtWP in H3; eauto. unf.
    ctor; eauto.
    * eapply PreservationExit in step; eauto.
    * inv step.
      ctor; auto.
      eapply ConsStmtDet in H; eauto. inv H.
      inv H2.
      intro c. contradict H11. eex.
Qed.

Proposition Preservation : ∀ (pi pi' : Set_State),
  Step pi pi' -> forall p,
  (ValidStateEx p pi) ->
  (ValidStateEx p pi').
Proof.
  intro. intro. intro step. intro.
  intro valid.
  inversion step; subst;
  try (eapply PreservationLocalEx in step; eauto; fail);
  try (eapply PreservationEnterEx in step; eauto; fail);
  try (eapply PreservationExitEx in step; eauto; fail).
Qed.

End Semantics.


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

(* Clairvoyant coin using (untyped) sequence prophecies. *)

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

Definition read_coin : val := λ: "cp", !(Fst "cp").

Definition toss_coin : val :=
  λ: "cp",
  let: "c" := Fst "cp" in
  let: "p" := Snd "cp" in
  let: "r" := nondet_bool #() in
  "c" <- "r";; resolve_proph: "p" to: "r";; #().

Section proof.
  Context `{!heapG Σ}.

  Definition prophecy_to_list_bool (vs : list (val * val)) : list bool :=
    (λ v, bool_decide (v = #true)) ∘ snd <$> vs.

  Definition coin (cp : val) (bs : list bool) : iProp Σ :=
    (∃ (c : loc) (p : proph_id) (vs : list (val * val)),
        ⌜cp = (#c, #p)%V⌝ ∗
        ⌜bs ≠ []⌝ ∗ ⌜tail bs = prophecy_to_list_bool vs⌝ ∗
        proph p vs ∗
        from_option (λ b : bool, c ↦ #b) (∃ b : bool, c ↦ #b) (head bs))%I.

  Lemma coin_exclusive (cp : val) (bs1 bs2 : list bool) :
    coin cp bs1 -∗ coin cp bs2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct "H1" as (c1 p1 vs1) "(-> & _ & _ & Hp1 & _)".
    iDestruct "H2" as (c2 p2 vs2) "(% & _ & _ & Hp2 & _)".
    simplify_eq. iApply (proph_exclusive with "Hp1 Hp2").
  Qed.

  Lemma new_coin_spec : {{{ True }}} new_coin #() {{{ c bs, RET c; coin c bs }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    wp_lam.
    wp_apply wp_new_proph; first done.
    iIntros (vs p) "Hp".
    wp_apply nondet_bool_spec; first done.
    iIntros (b) "_".
    wp_alloc c as "Hc".
    wp_pair.
    iApply ("HΦ" $! (#c, #p)%V (b :: prophecy_to_list_bool vs)).
    rewrite /coin; eauto with iFrame.
  Qed.

  Lemma read_coin_spec cp bs :
    {{{ coin cp bs }}}
      read_coin cp
    {{{ b bs', RET #b; ⌜bs = b :: bs'⌝ ∗ coin cp bs }}}.
  Proof.
    iIntros (Φ) "Hc HΦ".
    iDestruct "Hc" as (c p vs -> ? ?) "[Hp Hb]".
    destruct bs as [|b bs]; simplify_eq/=.
    wp_lam. wp_load.
    iApply "HΦ"; iSplit; first done.
    rewrite /coin; eauto 10 with iFrame.
  Qed.

  Lemma toss_coin_spec cp bs :
    {{{ coin cp bs }}}
      toss_coin cp
    {{{ b bs', RET #(); ⌜bs = b :: bs'⌝ ∗ coin cp bs' }}}.
  Proof.
    iIntros (Φ) "Hc HΦ".
    iDestruct "Hc" as (c p vs -> ? ?) "[Hp Hb]".
    destruct bs as [|b bs]; simplify_eq/=.
    wp_lam. do 2 (wp_proj; wp_let).
    wp_apply nondet_bool_spec; first done.
    iIntros (r) "_".
    wp_store.
    wp_apply (wp_resolve_proph with "[Hp]"); first done.
    iIntros (ws) "[-> Hp]".
    wp_seq.
    iApply "HΦ"; iSplit; first done.
    destruct r; rewrite /coin; eauto 10 with iFrame.
  Qed.

End proof.

Definition clairvoyant_coin_spec_instance `{!heapG Σ} :
  clairvoyant_coin_spec.clairvoyant_coin_spec Σ :=
  {| clairvoyant_coin_spec.new_coin_spec := new_coin_spec;
     clairvoyant_coin_spec.read_coin_spec := read_coin_spec;
     clairvoyant_coin_spec.toss_coin_spec := toss_coin_spec;
     clairvoyant_coin_spec.coin_exclusive := coin_exclusive |}.

Typeclasses Opaque coin.


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

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

Print Assumptions freeze.


Require Import Relation_Definitions.
Require Import Nat.

Section fromrodin_simple.
(*
not x |-> y: k
Q <: P
k~ [{c}]=P \ {c}
x /= y
x: Q
|-
c /= y
 *)
  (* simplified:
not y |-> x: kinv
kinv [{c}] = P \ {c}
x /= y
x: P
y: P
|-
c /= y
*)
  (* more simplified:
not y |-> x: kinv
kinv [{c}] = nat \ {c}
x /= y
x: nat
y: nat
|-
c /= y
*)

  Lemma cisinty:
    forall x y c: nat, forall kinv: relation nat,
      not (kinv y x) ->
      (forall e: nat, e <> c -> kinv c e) ->
      x <> y ->
      c <> y.
  Proof.
    intros x y c kinv nkinv a2 df.
    intros Heq.
    apply nkinv. clear nkinv.
    rewrite <- Heq.
    apply a2. clear a2.
    intro Heq2.
    apply df. clear df.
    apply (eq_trans Heq2 Heq).
  Qed.

  Parameter (x y c: nat).
  Parameter kinv: relation nat.

  Axiom nkinv: not (kinv y x).
  Axiom a2: forall e: nat, e <> c -> kinv c e.
  Axiom df: x <> y.

  Lemma cisnty': c <> y.
  Proof.
    intros Heq.
    apply nkinv.
    rewrite <- Heq.
    apply a2.
    intro Heq2.
    apply df.
    apply (eq_trans Heq2 Heq).
  Qed.

(*
Axiom df: x <> y.
Axiom comp: forall v: nat, P v. (* -> Q v.*)
Axiom nk: (x, y)  kinv.
Axiom a2: kinv {c} = nat \ {c}.
*)
End fromrodin_simple.


Require Import Coq.Lists.List Program NArith. Import ListNotations.
Require Import SyDPaCC.Support.UIP.
Require Import SyDPaCC.Support.NList.
Require Import SyDPaCC.Support.List.
Require Import SyDPaCC.Core.Bmf SyDPaCC.Core.Parallelization.
From SyDPaCC.Bsml.Model Require Import Core Pid.
Set Implicit Arguments.

(** * Distributed Vectors *)

(** In order to automatically parallelize applications, it is
    necessary to proof the correspondence between parallel
    datastructures and sequential datastructures. *)

(** Distributed vectors are implemented as parallel vectors of lists and
    are shown to correspond to sequential lists.  The correspondence
    is obtained simply by taking the contatenation of the lists hold
    by the processors. *)

(** ** Type Correspondence Implementation *)
Module C(Import Bsml: BSML)(Import Pid : Pid.TYPE Bsml.Bsp).

  Definition join A (v:par A) : { l : list A | length l = Bsp.p }.
    exists (List.map (proj v) pids).
    now autorewrite with length.
  Defined.

  Lemma list_length_inj:
    forall A (l l':list A)(Hl: length l = Bsp.p)(Hl': length l' = Bsp.p),
      l = l' ->
      exist (fun l=>length l=Bsp.p) l Hl = exist _ l' Hl'.
  Proof.
    intros A l l' Hl Hl' H.
    revert Hl; rewrite H. intro.
    assert(Hl = Hl') as HH by apply N.UIP.
    now rewrite HH.
  Qed.

  Global Instance surjective_join (A:Type) : Surjective (join (A:=A)).
  Proof.
    constructor; intros [ l Hl ]; simpl.
    assert(NonEmpty l) as H
        by (constructor; destruct l; pid; intro; discriminate).
    set(v := mkpar(fun pid =>nth (proj1_sig pid) l (hd l))).
    exists v; unfold join; apply list_length_inj.
    rewrite nth_seq with (d:=hd l). rewrite Hl, <- pids_seq.
    apply pids_ind.
    - unfold v; simpl; autorewrite with bsml; auto.
    - intros i Hlast IH. rewrite map_map.
      apply map_ext; intro j; unfold v.
      now autorewrite with bsml.
  Qed.

  Global Program Instance list_par_list_corr A :
    TypeCorr (@join A).

End C.

(** ** Module Type *)
Module Type T (Bsml: BSML)(Pid: Pid.TYPE Bsml.Bsp).
  Include C Bsml Pid.
End T.


Require Import Coq.ZArith.Zpower Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Crypto.Util.ListUtil Crypto.Util.CaseUtil Crypto.Util.ZUtil.
Require Import Crypto.ModularArithmetic.ExtendedBaseVector.
Require Import Crypto.ModularArithmetic.PrimeFieldTheorems.
Require Import Crypto.Tactics.VerdiTactics.
Require Import Crypto.ModularArithmetic.PseudoMersenneBaseParams.
Require Import Crypto.BaseSystem.
Require Import Crypto.BaseSystemProofs.
Require Import Crypto.ModularArithmetic.Pow2Base.
Require Import Crypto.ModularArithmetic.Pow2BaseProofs.
Require Crypto.BaseSystem.
Local Open Scope Z_scope.

Section PseudoMersenneBaseParamProofs.
  Context `{prm : PseudoMersenneBaseParams}.
  Local Notation base := (base_from_limb_widths limb_widths).

  Lemma limb_widths_nonneg : forall w, In w limb_widths -> 0 <= w.
  Proof. auto using Z.lt_le_incl, limb_widths_pos. Qed.

  Lemma k_nonneg : 0 <= k.
  Proof. apply sum_firstn_limb_widths_nonneg, limb_widths_nonneg. Qed.

  Lemma lt_modulus_2k : modulus < 2 ^ k.
  Proof.
    replace (2 ^ k) with (modulus + c) by (unfold c; ring).
    pose proof c_pos; omega.
  Qed. Hint Resolve lt_modulus_2k.

  Lemma modulus_pos : 0 < modulus.
  Proof.
    pose proof (NumTheoryUtil.lt_1_p _ prime_modulus); omega.
  Qed. Hint Resolve modulus_pos.

  Lemma modulus_nonzero : Z.pos modulus <> 0.
    pose proof (Znumtheory.prime_ge_2 _ prime_modulus); omega.
  Qed.

  (* a = r + s(2^k) = r + s(2^k - c + c) = r + s(2^k - c) + cs = r + cs *)
  Lemma pseudomersenne_add: forall x y, (x + ((2^k) * y)) mod modulus = (x + (c * y)) mod modulus.
  Proof.
    intros.
    replace (2^k) with ((2^k - c) + c) by ring.
    rewrite Z.mul_add_distr_r, Zplus_mod.
    unfold c.
    rewrite Z.sub_sub_distr, Z.sub_diag.
    rewrite Z.mul_comm, Z.mod_add_l; auto using modulus_nonzero.
    rewrite <- Zplus_mod; auto.
  Qed.

  Lemma pseudomersenne_add': forall x y0 y1 z, (z - x + ((2^k) * y0 * y1)) mod modulus = (c * y0 * y1 - x + z) mod modulus.
  Proof.
    intros; rewrite <- !Z.add_opp_r, <- !Z.mul_assoc, pseudomersenne_add; apply f_equal2; omega.
  Qed.

  Lemma extended_shiftadd: forall (us : digits),
    decode (ext_base limb_widths) us =
      decode base (firstn (length base) us)
        + (2 ^ k * decode base (skipn (length base) us)).
  Proof.
    intros.
    unfold decode; rewrite <- mul_each_rep.
    rewrite ext_base_alt by apply limb_widths_nonneg.
    fold k; fold (mul_each (2 ^ k) base).
    rewrite base_mul_app.
    rewrite <- mul_each_rep; auto.
  Qed.

  Global Instance bv : BaseSystem.BaseVector base := {
    base_positive := base_positive limb_widths_nonneg;
    b0_1 := fun x => b0_1 x limb_widths_nonnil;
    base_good := base_good limb_widths_nonneg limb_widths_good
  }.

  Lemma nth_default_base_positive : forall i, (i < length base)%nat ->
    nth_default 0 base i > 0.
  Proof.
    intros.
    pose proof (nth_error_length_exists_value _ _ H).
    destruct H0.
    pose proof (nth_error_value_In _ _ _ H0).
    pose proof (BaseSystem.base_positive _ H1).
    unfold nth_default.
    rewrite H0; auto.
  Qed.

  Lemma base_succ_div_mult : forall i, ((S i) < length base)%nat ->
    nth_default 0 base (S i) = nth_default 0 base i *
    (nth_default 0 base (S i) / nth_default 0 base i).
  Proof.
    intros.
    apply Z_div_exact_2; try (apply nth_default_base_positive; omega).
    apply base_succ; distr_length; eauto using limb_widths_nonneg.
  Qed.

End PseudoMersenneBaseParamProofs.


Abort All.
Load typing.

Print type_Rel.
Lemma type_Rel2 Σ Γ : forall (n : nat) (decl : Ast.context_decl) T,
    wf_local Σ Γ ->
    nth_error Γ n = Some decl ->
    T = (lift0 (S n)) (Ast.decl_type decl) ->
    Σ;;; Γ |- tRel n : T.
Proof.
  intros.
  subst T.
  now apply type_Rel.
Qed.

Lemma type_LambdaL: forall (Σ : global_env_ext) (Γ : context) n1 n2 t1 t2 (b bty : term),
    t1=t2 -> n1=n2 ->
Σ;;; Γ,, vass n1 t1 |- b : bty -> Σ;;; Γ |- tLambda n1 t1 b : tProd n2 t2 bty.
Proof.
  intros.
  subst t2 n2.
  now apply type_Lambda2.
Qed.

Lemma type_LambdaR: forall (Σ : global_env_ext) (Γ : context) n1 n2 t1 t2 (b bty : term),
    t1=t2 -> n1=n2 ->
Σ;;; Γ,, vass n2 t2 |- b : bty -> Σ;;; Γ |- tLambda n1 t1 b : tProd n2 t2 bty.
Proof.
  intros.
  subst t2 n2.
  now apply type_Lambda2.
Qed.


From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From MetaCoq Require Import Ast utils Typing.
From Translation Require Import util Sorts SAst SLiftSubst.

Section Equality.

Context `{Sort_notion : Sorts.notion}.

(*! Equality between terms *)
(* This goes through the definition of a nameless syntax *)

Inductive nlterm : Type :=
| nlRel (n : nat)
| nlSort (s : sort)
| nlProd (A B : nlterm)
| nlLambda (A B t : nlterm)
| nlApp (u : nlterm) (A B v : nlterm)
(* Σ-types *)
| nlSum (A B : nlterm)
| nlPair (A B u v : nlterm)
| nlPi1 (A B p : nlterm)
| nlPi2 (A B p : nlterm)
(* Homogenous equality *)
| nlEq (A u v : nlterm)
| nlRefl (A u : nlterm)
| nlJ (A u P w v p : nlterm)
| nlTransport (T1 T2 p t : nlterm)
(* Heterogenous equality *)
| nlHeq (A a B b : nlterm)
| nlHeqToEq (p : nlterm)
| nlHeqRefl (A a : nlterm)
| nlHeqSym (p : nlterm)
| nlHeqTrans (p q : nlterm)
| nlHeqTransport (p t : nlterm)
| nlCongProd (B1 B2 pA pB : nlterm)
| nlCongLambda (B1 B2 t1 t2 pA pB pt : nlterm)
| nlCongApp (B1 B2 pu pA pB pv : nlterm)
| nlCongSum (B1 B2 pA pB : nlterm)
| nlCongPair (B1 B2 pA pB pu pv : nlterm)
| nlCongPi1 (B1 B2 pA pB pp : nlterm)
| nlCongPi2 (B1 B2 pA pB pp : nlterm)
| nlCongEq (pA pu pv : nlterm)
| nlCongRefl (pA pu : nlterm)
| nlEqToHeq (p : nlterm)
| nlHeqTypeEq (A B p : nlterm)
(* Packing *)
| nlPack (A1 A2 : nlterm)
| nlProjT1 (p : nlterm)
| nlProjT2 (p : nlterm)
| nlProjTe (p : nlterm)
(* External axioms *)
| nlAx (id : ident)
.

Fixpoint nl (t : sterm) : nlterm :=
  match t with
  | sRel n => nlRel n
  | sSort s => nlSort s
  | sProd n A B => nlProd (nl A) (nl B)
  | sLambda n A B t => nlLambda (nl A) (nl B) (nl t)
  | sApp u A B v => nlApp (nl u) (nl A) (nl B) (nl v)
  | sSum n A B => nlSum (nl A) (nl B)
  | sPair A B u v => nlPair (nl A) (nl B) (nl u) (nl v)
  | sPi1 A B p => nlPi1 (nl A) (nl B) (nl p)
  | sPi2 A B p => nlPi2 (nl A) (nl B) (nl p)
  | sEq A u v => nlEq (nl A) (nl u) (nl v)
  | sRefl A u => nlRefl (nl A) (nl u)
  | sJ A u P w v p => nlJ (nl A) (nl u) (nl P) (nl w) (nl v) (nl p)
  | sTransport T1 T2 p t => nlTransport (nl T1) (nl T2) (nl p) (nl t)
  | sHeq A a B b => nlHeq (nl A) (nl a) (nl B) (nl b)
  | sHeqToEq p => nlHeqToEq (nl p)
  | sHeqRefl A a => nlHeqRefl (nl A) (nl a)
  | sHeqSym p => nlHeqSym (nl p)
  | sHeqTrans p q => nlHeqTrans (nl p) (nl q)
  | sHeqTransport p t => nlHeqTransport (nl p) (nl t)
  | sCongProd B1 B2 pA pB => nlCongProd (nl B1) (nl B2) (nl pA) (nl pB)
  | sCongLambda B1 B2 t1 t2 pA pB pt =>
    nlCongLambda (nl B1) (nl B2) (nl t1) (nl t2) (nl pA) (nl pB) (nl pt)
  | sCongApp B1 B2 pu pA pB pv =>
    nlCongApp (nl B1) (nl B2) (nl pu) (nl pA) (nl pB) (nl pv)
  | sCongSum B1 B2 pA pB => nlCongSum (nl B1) (nl B2) (nl pA) (nl pB)
  | sCongPair B1 B2 pA pB pu pv =>
    nlCongPair (nl B1) (nl B2) (nl pA) (nl pB) (nl pu) (nl pv)
  | sCongPi1 B1 B2 pA pB pp => nlCongPi1 (nl B1) (nl B2) (nl pA) (nl pB) (nl pp)
  | sCongPi2 B1 B2 pA pB pp => nlCongPi2 (nl B1) (nl B2) (nl pA) (nl pB) (nl pp)
  | sCongEq pA pu pv => nlCongEq (nl pA) (nl pu) (nl pv)
  | sCongRefl pA pu => nlCongRefl (nl pA) (nl pu)
  | sEqToHeq p => nlEqToHeq (nl p)
  | sHeqTypeEq A B p => nlHeqTypeEq (nl A) (nl B) (nl p)
  | sPack A1 A2 => nlPack (nl A1) (nl A2)
  | sProjT1 p => nlProjT1 (nl p)
  | sProjT2 p => nlProjT2 (nl p)
  | sProjTe p => nlProjTe (nl p)
  | sAx id => nlAx id
  end.

Section nldec.

  Ltac finish :=
    let h := fresh "h" in
    right ;
    match goal with
    | e : ?t <> ?u |- _ =>
      intro h ; apply e ; now inversion h
    end.

  Ltac fcase c :=
    let e := fresh "e" in
    case c ; intro e ; [subst ; try (left ; reflexivity) | finish].

  Ltac nl_dec_tac nl_dec :=
    repeat match goal with
           | t : nlterm, u : nlterm |- _ => fcase (nl_dec t u)
           | s : sort, z : sort |- _ => fcase (Sorts.eq_dec s z)
           | n : nat, m : nat |- _ => fcase (Nat.eq_dec n m)
           | i : ident, i' : ident |- _ => fcase (string_dec i i')
           end.

  Fixpoint nl_dec (t u : nlterm) : { t = u } + { t <> u }.
  Proof.
    destruct t ; destruct u ; try (right ; discriminate).
    all: nl_dec_tac nl_dec.
  Defined.

End nldec.

Definition eq_term (t u : sterm) : bool :=
  if nl_dec (nl t) (nl u) then true else false.

Lemma eq_term_spec :
  forall {t u},
    eq_term t u = true <-> nl t = nl u.
Proof.
  intros t u. split.
  - unfold eq_term. case (nl_dec (nl t) (nl u)).
    + intros. assumption.
    + intros. discriminate.
  - unfold eq_term. case (nl_dec (nl t) (nl u)).
    + reflexivity.
    + intros h e. exfalso. apply h. apply e.
Defined.

Fact eq_term_refl :
  forall {t}, eq_term t t = true.
Proof.
  intro t. unfold eq_term.
  case (nl_dec (nl t) (nl t)).
  - intro. reflexivity.
  - intro h. exfalso. apply h. reflexivity.
Defined.

Fact eq_term_sym :
  forall {t u}, eq_term t u = true -> eq_term u t = true.
Proof.
  unfold eq_term.
  intros t u.
  case (nl_dec (nl u) (nl t)) ; intro e.
  - reflexivity.
  - case (nl_dec (nl t) (nl u)) ; intro e'.
    + exfalso. apply e. easy.
    + intro. easy.
Defined.

Fact eq_term_trans :
  forall {t u v}, eq_term t u = true -> eq_term u v = true -> eq_term t v = true.
Proof.
  intros t u v.
  unfold eq_term.
  case (nl_dec (nl t) (nl u)) ; intro e1.
  - intros _. rewrite e1. auto.
  - discriminate.
Defined.

Lemma nl_lift :
  forall {t u n k},
    nl t = nl u ->
    nl (lift n k t) = nl (lift n k u).
Proof.
  intros t u n k.
  case (nl_dec (nl t) (nl u)).
  - intros e _.
    revert u e n k.
    induction t ;
    intros u e m k ; destruct u ; cbn in e ; try discriminate e.
    all:
      try (cbn ; inversion e ;
           repeat (erewrite_assumption by eassumption) ; reflexivity).
  - intros h e. exfalso. apply h. apply e.
Defined.

Lemma eq_term_lift :
  forall {t u n k},
    eq_term t u = true ->
    eq_term (lift n k t) (lift n k u) = true.
Proof.
  intros t u n k h. apply eq_term_spec in h.
  apply eq_term_spec.
  apply nl_lift. assumption.
Defined.

Lemma nl_subst :
  forall {t t' u u' n},
    nl t = nl t' ->
    nl u = nl u' ->
    nl (t{n := u}) = nl (t'{n := u'}).
Proof.
  intros t t' u u' n ht hu. revert t' ht u u' hu n.
  induction t ;
  intros t' ht.
  all: destruct t' ; cbn in ht ; try discriminate ht.
  all: intros u u' hu m.
  all: try (cbn ; inversion ht ;
            repeat (erewrite_assumption by eassumption) ; reflexivity).
  symmetry in ht. inversion ht. subst. clear ht. cbn.
  case_eq (m ?= n) ; intro e ; bprop e.
  + subst. eapply nl_lift. assumption.
  + reflexivity.
  + reflexivity.
Defined.

Corollary eq_term_subst :
  forall {t t' u u' n},
    eq_term t t' = true ->
    eq_term u u' = true ->
    eq_term (t{n := u}) (t'{n := u'}) = true.
Proof.
  intros t t' u u' n ht hu.
  apply eq_term_spec in ht.
  apply eq_term_spec in hu.
  apply eq_term_spec.
  apply nl_subst ; assumption.
Defined.

End Equality.


(* Coq formalization of the type safety theorem for the calculus from
   "An Introduction to Algebraic Effects and Handlers" by Matija Pretnar
   https://www.sciencedirect.com/science/article/pii/S1571066115000705). *)

From Coq Require Import Strings.String.
From AlgEffects Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Sets.Uniset.
From AlgEffects Require Import Calculus.

Module Safety.

(* This module contains proof of the type-safety theorem using a standard
   technique of progress and preservation. To be able to proof the preservation
   theorem we also need weakening and substitution lemmas. *)

Import Calculus.

(* Canonical forms lemmas, though not used in later proofs, they serve
   as a good sanity checks for our definitions. *)
Lemma canonical_forms_bool : forall E v,
  E \ empty |- v \in BoolType ->
  v = VTrue \/ v = VFalse.
Proof with auto.
  intros.
  inversion H. subst.
  - inversion H0.
  - left...
  - right...
Qed.

Lemma canonical_forms_fun : forall E v T1 T2,
  E \ empty |- v \in (FunType T1 T2) ->
  exists x c, v = VFun x T1 c.
Proof with eauto.
  intros.
  inversion H; subst...
  - inversion H0.
Qed.

Lemma canonical_forms_handler : forall E v T1 T2,
  E \ empty |- v \in (HandlerType T1 T2) ->
  exists xr cr opCase, v = VHandler xr cr opCase.
Proof with eauto.
  intros.
  inversion H; subst...
  - inversion H0.
Qed.

(* Tactics that try to find definition for inversion
   and then try to proceed with eauto / eauto using. *)
Ltac solve_by_inversion :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      subst; try discriminate; eauto]
  end end.

Ltac solve_by_inversion_with t :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      subst; try discriminate; eauto using t ]
  end end.

(* Progress.
   if computation c is well typed in the empty context then either:
   - c = return v
   - c = op v y c'
   - c --> c'
*)
Theorem progress : forall E c T,
  E \ empty ||- c \in T ->
  (exists v, c = CReturn v) \/
  (exists op v y c', c = COp op v y c') \/
  exists c', (E \ c --> c').
Proof with eauto.
  intros E C T Ht.
  remember empty as Gamma.
  induction Ht; subst Gamma; try solve_by_inversion...
  - inversion H0; subst; try discriminate; right; left...
  - destruct IHHt1; subst; try reflexivity; right; right...
    + destruct H as [v H]. subst...
    + destruct H.
      * destruct H as (op & v & y & c' & H). subst...
      * destruct H as [c' H]...
 - destruct IHHt; try reflexivity; right; right; inversion H; subst; try discriminate.
  + destruct H0 as [v H0]. subst...
  + destruct H0.
    * destruct H0 as (op' & v & y & c' & H0); inversion H7; subst.
      destruct (eqb_stringP op op'); subst...
    * destruct H0 as [c' H0]...
Qed.

Lemma weakening : forall v E Gamma Gamma' T,
  inclusion Gamma Gamma' ->
  E \ Gamma  |- v \in T  ->
  E \ Gamma' |- v \in T.
Proof with eauto.
  (* We use mutual induction scheme for computations, values and op branches. *)
  apply (value_mut (fun c => forall E Gamma Gamma' T,
      inclusion Gamma Gamma' ->
      E \ Gamma  ||- c \in T  ->
      E \ Gamma' ||- c \in T)
    (fun v => forall E Gamma Gamma' T,
      inclusion Gamma Gamma' ->
      E \ Gamma  |- v \in T  ->
      E \ Gamma' |- v \in T)
    (fun opCase => forall E Gamma Gamma' op T,
      inclusion Gamma Gamma' ->
      has_type_opCase E Gamma op opCase T ->
      has_type_opCase E Gamma' op opCase T));
    (* All cases solved smoothly with simple automation. *)
    intros; solve_by_inversion_with inclusion_update.
Qed.

Lemma weakening_empty : forall E Gamma v T,
     E \ empty |- v \in T  ->
     E \ Gamma |- v \in T.
Proof.
  intros E Gamma c T.
  eapply weakening.
  discriminate.
Qed.

Lemma weakening_computation : forall c E Gamma Gamma' T,
  inclusion Gamma Gamma' ->
  E \ Gamma  ||- c \in T  ->
  E \ Gamma' ||- c \in T.
Proof with eauto using weakening, inclusion_update.
  intros c E Gamma Gamma' T Hi Ht.
  generalize dependent Gamma'.
  induction Ht; intros; subst...
Qed.

(* Abstracting most repetitive part from substitution lemma proof. *)
Ltac solve_simple_env_update x y :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      destruct (eqb_stringP x y); subst; eauto
       + rewrite update_shadow in H; eauto
       + rewrite update_permute in H; eauto ]
  end end.

Lemma substitution_preserves_typing : forall c E Gamma x U v T,
  E \ x |-> U ; Gamma ||- c \in T ->
  E \ empty |- v \in U   ->
  E \ Gamma ||- subst x v c \in T.
Proof with eauto using weakening_empty.
   (* Again we use mutual induction scheme. *)
   apply (computation_mut (fun c => forall E Gamma x U v T,
      E \ x |-> U ; Gamma ||- c \in T ->
      E \ empty |- v \in U   ->
      E \ Gamma ||- subst x v c \in T)
    (fun v => forall E Gamma x U v' T,
      E \ x |-> U ; Gamma |- v \in T ->
      E \ empty |- v' \in U   ->
      E \ Gamma |- subst_in_value x v' v \in T)
    (fun opCase => forall E Gamma x U v op T,
      has_type_opCase E (x |-> U ; Gamma) op opCase T ->
      E \ empty |- v \in U   ->
      has_type_opCase E Gamma op (subst_in_opCase x v opCase) T));

  intros; subst; simpl; try solve_by_inversion;
  try (inversion H1; solve_simple_env_update x0 x).
  - inversion H. destruct (eqb_stringP x0 x); subst...
    + apply weakening_empty. rewrite update_eq in H4.
      injection H4 as H4. subst...
    + rewrite update_neq in H4...
  - inversion H0. solve_simple_env_update x0 x.
  - inversion H0. destruct (eqb_stringP x0 x); subst; simpl.
    + econstructor...
      rewrite update_permute in H12...
      rewrite update_shadow in H12...
      rewrite update_permute in H12...
    + destruct (eqb_stringP x0 k); subst.
      * econstructor... rewrite update_shadow in H12...
      * econstructor... eapply H...
        rewrite update_permute...
        rewrite update_permute with (x1 := x0)...
Qed.

(* Two simple lemmas about maps and sets. *)
Lemma inclusion_empty_in_any : forall (A : Type) (m : partial_map A), inclusion empty m.
Proof.
  unfold inclusion.
  intros. inversion H.
Qed.

Lemma set_remove_neq_incl : forall x y Delta Delta',
  x <> y ->
  In Delta x ->
  incl (set_remove y Delta) Delta' ->
  In Delta' x.
Proof with eauto.
  intros.
  unfold In in *. unfold incl in H1.
  unfold set_remove in H1. simpl in H1. specialize H1 with x.
  destruct (eqb_stringP y x).
  - unfold not in H. exfalso...
  - rewrite -> H0 in H1. inversion H1...
Qed.

(* Preservation.
   if c has type T and c --> c' then c' also has type T.
*)
Theorem preservation : forall E c c' T,
  E \ empty ||- c \in T  ->
  E \ c --> c'  ->
  E \ empty ||- c' \in T.
Proof with eauto using inclusion_empty_in_any, substitution_preserves_typing.
  intros E c c' T HT.
  remember empty as Gamma.
  generalize dependent c'.
  induction HT; intros; subst;
  try solve_by_inversion_with inclusion_empty_in_any.
  - inversion H1. subst. inversion H. subst...
  - inversion H; subst; inversion HT1; subst...
    + eapply T_Op; subst... eapply T_Do ...
      destruct (eqb_stringP x y); subst.
      * rewrite update_shadow...
      * apply weakening_computation with (Gamma := (x |-> T1))...
        unfold inclusion. intros. destruct (eqb_stringP x x0); subst.
        -- rewrite update_eq in H0. rewrite update_eq...
        -- rewrite update_neq in H0... inversion H0.
  - inversion H0; subst...
    + inversion H. subst. eapply substitution_preserves_typing...
      inversion HT...
    + inversion H. inversion HT. inversion H9. subst.
      eapply substitution_preserves_typing...
      * eapply substitution_preserves_typing...
        rewrite H17 in H30. injection H30 as H30. subst...
      * rewrite H30. rewrite H17 in H30. injection H30 as H30. simpl.
        subst. constructor. econstructor...
        injection H18 as H18. subst. apply weakening with (Gamma := empty)...
   + inversion H. subst. inversion HT. subst. inversion H10. subst.
      econstructor...
     * eapply set_remove_neq_incl...
     * econstructor... apply weakening with (Gamma := empty)...
Qed.

(* Theorem 4.2 (Safety).
   if c has type T!Delta in the empty context then either:
   - c = return v, and v has type T
   - c = op v y c', and op belongs to Delta
   - c --> c', and c' has type T!Delta
*)
Corollary safety : forall E c T Delta,
  E \ empty ||- c \in ComputationType T Delta ->
  (exists v, c = CReturn v /\ E \ empty |- v \in T) \/
  (exists op v y c', c = COp op v y c' /\ In Delta op) \/
  (exists c', E \ c --> c' /\ E \ empty ||- c' \in ComputationType T Delta).
Proof with eauto 7.
  (* By using progress and preservation proof proceeds without any problems. *)
  intros. apply progress in H as H'. destruct H' as [[v H1] | H23];
  try destruct H23 as [H2 | H3].
  - left. exists v. subst. inversion H. subst...
  - right. left. destruct H2 as (op & v & y & c' & H2). subst. inversion H.
    subst...
  - right. right. destruct H3 as [c' H3]. exists c'. split...
    eapply preservation...
Qed.

(* Simple corollary from the above theorem.
   if c has type T!{} in the empty context then either:
   - c = return v, and v has type T
   - c --> c', and c' has type T!{}
*)
Corollary safety_pure : forall E c T,
  E \ empty ||- c \in ComputationType T (Emptyset string) ->
  (exists v, c = CReturn v /\ E \ empty |- v \in T) \/
  (exists c', E \ c --> c' /\ E \ empty ||- c' \in ComputationType T (Emptyset string)).
Proof with eauto 7.
  intros. apply safety in H. destruct H.
  - left ...
  - destruct H.
    + destruct H as (op & _ & _ & _ & _ & H). inversion H.
    + right ...
Qed.

End Safety.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import Coq.Classes.Morphisms.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrnat.
Require Import Sets Tactics.
Require Import Recdef.
Require Import List.

Require Import ZArith ZArith.Znat Arith.

Require Import Producer Generators Enumerators.

Set Bullet Behavior "Strict Subproofs".

Local Open Scope set_scope.

(** Apply a function n times *)
Fixpoint appn {A} (f : A -> A) (n : nat) : A ->  A :=
  fun x =>
    match n with
      | 0%nat => x
      | S n' => f (appn f n' x)
    end.

Infix "^" := appn (at level 30, right associativity) : fun_scope.

(** Instance Hierarchy

   GenSized
      |
      |
     Gen   Shrink
       \    /
        \  /
      Arbitrary
*)

(** * Generator-related classes *)

(* begin gen_sized_class *)
Class GenSized (A : Type) :=
  { arbitrarySized : nat -> G A }.
(* end gen_sized_class *)

(* begin gen_class *)
Class Gen (A : Type) := { arbitrary : G A }.
(* end gen_class *)

(** Shrink class *)
Class Shrink (A : Type) :=
  { shrink : A -> list A }.

(** Arbitrary Class *)
Class Arbitrary (A : Type) `{Gen A} `{Shrink A}.

Class EnumSized (A : Type) := { enumSized : nat -> E A }.

Class Enum (A : Type) := { enum : E A }.

(* ZP: This is not longer usefull *)
(*
(** * Sizes of types *)

Class Sized (A : Type) :=
  { size : A -> nat }.

Class CanonicalSized (A : Type) `{Sized A} :=
  {
    zeroSized : set A;
    succSized : set A -> set A;

    zeroSized_spec : zeroSized <--> [ set x : A | size x = 0 ];
    succSized_spec :
      forall n, succSized [ set x : A | size x <= n ] <--> [ set x : A | size x <= S n ]

  }.

Lemma size_ind (A : Type) `{Hyp : Sized A} :
  forall (P : A -> Prop), (forall y, (forall x, size x < size y -> P x) -> P y) -> (forall x, P x).
Proof.
  intros P H1.
  intros x.
  assert (Hin : [ set y :  A | size y <= size x] x); eauto.
  revert Hin.
  generalize (size x). intros n.
  revert x. induction n.
  - intros x Hl. apply H1. intros x1 Hlt. ssromega.
  - intros x Hleq. eapply H1. intros x1 Hlt.
    eapply IHn. ssromega.
Qed.

Lemma size_lfp (A : Type) `{Hyp : CanonicalSized A} :
  [set x : A | True ] <--> \bigcup_(s : nat) [set x : A | size x <= s ].
Proof.
  intros a; split; eauto. intros _.
  exists (size a). split; eauto. constructor.
Qed.

Lemma succ_lfp (A : Type) `{Hyp : CanonicalSized A}
      `{Proper _ (respectful set_eq set_eq) succSized} s :
  [set x : A | size x <= s ] <-->  (succSized ^ s) zeroSized.
Proof.
  induction s.
  simpl.
  - rewrite zeroSized_spec.
    split; intros; ssromega.
  - simpl. rewrite <- succSized_spec.
    rewrite IHs. reflexivity.
Qed.
*)
(* Lemma succ_lfp' (A : Type) `{Hyp : CanonicalSized A} : *)
(*   \bigcup_(s : nat)  (succSized ^ s) zeroSized <--> [ set x : A | True ]. *)
(* Proof. *)
(*   intros. split; eauto. *)
(*   intros _. *)
(*   eapply set_eq_trans. *)
(*   Focus 2. symmetry. *)
(*   eapply succ_lfp. *)
(*   simpl.  *)
(*   rewrite succ_lfp at 2. *)
(* split. *)
(*     split. rewrite IHs. firstorder. *)
(*     IHs. *)
(*   firstorder. reflexivity. split; intros; eauto. *)
(*   exists (size a). *)
(*   remember (size a) as s. *)
(*   revert a Heqs. induction s; intros. *)
(*   - split. constructor. *)
(*     simpl. eapply zeroSized_spec. now eauto. *)
(*   - split. constructor. *)
(*     simpl. *)
(*     eapply (succSized_spec. *)
(*     eassumption. *)
(*   eapply size_ind. *)

(*   [set x : A | True ] <-->  . *)

(** * Correctness classes *)

(** Correctness of sized generators *)

Class CorrectSized {A : Type} {G} `{Producer G} (g : nat -> G A)  :=
  { prodCorrectSized :
      [ set n | exists s, semProd (g s) n ] <--> [set : A]
  }.

(** Correctness of generators *)
Class Correct (A : Type) {G} `{Producer G} (g : G A)  :=
  {
    prodCorrect : semProd g <--> [set : A]
  }.

(** * Monotonic generators *)

(** Monotonicity of size parametric generators *)
Class GenSizedMonotonic (A : Type) `{GenSized A}
      `{forall s, SizeMonotonic (arbitrarySized s)}.

(** Monotonicity of size parametric generators v2 *)
Class GenSizedSizeMonotonic (A : Type) `{GenSized A}
        `{SizedMonotonic A G arbitrarySized}.

Class GenMonotonic (A : Type) `{Gen A} `{@SizeMonotonic A G ProducerGen arbitrary}.

(** Monotonicity of size parametric generators *)
Class EnumSizedMonotonic (A : Type) `{EnumSized A}
      `{forall s, @SizeMonotonic A E ProducerEnum (enumSized s)}.

(** Monotonicity of size parametric generators v2 *)
Class EnumSizedSizeMonotonic (A : Type) `{EnumSized A}
        `{@SizedMonotonic A E ProducerEnum enumSized}.

Class EnumMonotonic (A : Type) `{Enum A}
        `{@SizeMonotonic A E ProducerEnum enum}.

(** * Correct generators *)

Class GenSizedCorrect (A : Type) `{GenSized A}
      `{@CorrectSized A G ProducerGen arbitrarySized}.

Class GenCorrect (A : Type) `{Gen A}
        `{@Correct A G ProducerGen arbitrary}.

(* Monotonic and Correct generators *)
Class GenMonotonicCorrect (A : Type)
      `{Gen A}
      `{@SizeMonotonic A G ProducerGen arbitrary}
      `{@Correct  A G ProducerGen arbitrary}.

Class EnumSizedCorrect (A : Type)
        `{EnumSized A} `{@CorrectSized A E ProducerEnum enumSized}.

Class EnumCorrect (A : Type) `{Enum A}
        `{@Correct A E ProducerEnum enum}.

(* Monotonic and Correct generators *)
Class EnumMonotonicCorrect (A : Type)
      `{Enum A}
      `{@SizeMonotonic A E ProducerEnum enum}
      `{@Correct A E ProducerEnum enum}.

(** Coercions *)

#[global]
Instance GenSizedMonotonicOfSizeMonotonic
         (A : Type) (Hgen : GenSized A) (Hmon : forall s, @SizeMonotonic A G ProducerGen (arbitrarySized s))
: @GenSizedMonotonic A Hgen Hmon := {}.

#[global]
Instance GenMonotonicOfSizeMonotonic
         (A : Type) (Hgen : Gen A) (Hmon : @SizeMonotonic A G ProducerGen arbitrary)
: @GenMonotonic A Hgen Hmon := {}.

#[global]
Instance GenSizedCorrectOfSizedCorrect
         (A : Type) (Hgen : GenSized A)
         `{Hcor : @CorrectSized A G ProducerGen arbitrarySized}
: @GenSizedCorrect A Hgen Hcor := {}.

#[global]
Instance GenMonotonicCorrectOfMonotnicCorrect
         (A : Type) (Hgen : Gen A)
         (Hmon : @SizeMonotonic A G ProducerGen arbitrary)
         `{Hcor : @Correct A G ProducerGen arbitrary}
  : @GenMonotonicCorrect A Hgen Hmon Hcor := {}.

#[global]
Instance GenSizedSizeMonotonicOfSizedMonotonic
         (A : Type) (Hgen : GenSized A) (Hmon : @SizedMonotonic A G ProducerGen arbitrarySized)
: @GenSizedSizeMonotonic A Hgen ProducerGen Hmon := {}.

#[global] Instance GenOfGenSized {A} `{GenSized A} : Gen A :=
  {| arbitrary := sized arbitrarySized |}.

#[global] Instance ArbitraryOfGenShrink {A} `{Gen A} `{Shrink A} : Arbitrary A := {}.

Generalizable Variables PSized PMon PSMon PCorr.

#[global] Instance GenMonotonicOfSized (A : Type)
         `{H : GenSized A}
         `{@GenSizedMonotonic A H PMon}
         `{@GenSizedSizeMonotonic A H ProducerGen PSMon}
  : @GenMonotonic A
                  (@GenOfGenSized A H)
                  (@sizedSizeMonotonic G ProducerGen _ A
                                       (@arbitrarySized A H)
                                       PMon PSMon) := {}.

#[global]
Instance GenCorrectOfSized (A : Type)
         {H : GenSized A}
         `{@GenSizedMonotonic A H PMon}
         `{@GenSizedSizeMonotonic A H ProducerGen PSMon}
         `{@GenSizedCorrect A H PCorr} : Correct A arbitrary.
Proof.
  constructor. unfold arbitrary, GenOfGenSized.
  eapply set_eq_trans.
  - eapply semSized_alt; now eauto with typeclass_instances.
  - destruct PCorr.
    rewrite <- prodCorrectSized0.

    split. intros [n [? H3]]. eexists. eassumption.

    intros [s H4]. eexists; split; eauto. reflexivity.
Qed.

(*
Lemma nat_set_ind (A : Type) `{GenSized A} `{Hyp : CanonicalSized A} :
  (semProd (arbitrarySized 0) <--> zeroSized) ->
  (forall (s : nat) (elems : set A),
     semProd (arbitrarySized s) <--> elems ->
     semProd (arbitrarySized (s.+1)) <--> succSized elems) ->
  (forall s : nat, semProd (arbitrarySized s) <--> (fun x : A => size x <= s)).
Proof.
  intros HO IH. intros n; induction n.
  - eapply set_eq_trans with (B := (fun x : A => size x = 0)).
    rewrite -zeroSized_spec //=.
    intros s. destruct (size s). now firstorder.
    split; intros; ssromega.
  - rewrite -succSized_spec. eauto.
Qed.
 *)

#[global] Instance EnumSizedMonotonicOfSizeMonotonic
         (A : Type) (Hgen : EnumSized A) (Hmon : forall s, @SizeMonotonic A E ProducerEnum (enumSized s))
: @EnumSizedMonotonic A Hgen Hmon := {}.

#[global] Instance EnumMonotonicOfSizeMonotonic
         (A : Type) (Hgen : Enum A) (Hmon : @SizeMonotonic A E ProducerEnum enum)
: @EnumMonotonic A Hgen Hmon := {}.

#[global] Instance EnumSizedCorrectOfSizedCorrect
         (A : Type) (Hgen : EnumSized A)
         `{Hcor : @CorrectSized A E ProducerEnum enumSized}
: @EnumSizedCorrect A Hgen Hcor := {}.

#[global] Instance EnumCorrectOfCorrect
         (A : Type) (Hgen : Enum A)
         `{Hcor : @Correct A E ProducerEnum enum}
: @EnumCorrect A Hgen Hcor := {}.

#[global] Instance EnumMonotonicCorrectOfMonotnicCorrect
         (A : Type) (Hgen : Enum A)
         (Hmon : @SizeMonotonic A E ProducerEnum enum)
         `{Hcor : @Correct A E ProducerEnum enum}
  : @EnumMonotonicCorrect A Hgen Hmon Hcor := {}.

#[global] Instance EnumSizedSizeMonotonicOfSizedMonotonic
         (A : Type) (Hgen : EnumSized A) (Hmon : @SizedMonotonic A E ProducerEnum enumSized)
: @EnumSizedSizeMonotonic A Hgen Hmon := {}.

#[global] Instance EnumOfEnumSized {A} `{EnumSized A} : Enum A :=
  {| enum := sized enumSized |}.

(*
#[global] Instance EnumOfGenShrink {A} `{Gen A} `{Shrink A} : Arbitrary A := {}.
 *)

#[global] Instance EnumMonotonicOfSized (A : Type)
         `{H : EnumSized A}
         `{@EnumSizedMonotonic A H PMon}
         `{@EnumSizedSizeMonotonic A H PSMon}
  : @EnumMonotonic A
                  (@EnumOfEnumSized A H)
                  (@sizedSizeMonotonic E ProducerEnum _ A
                                       (@enumSized A H)
                                       PMon PSMon) := {}.

#[global] Instance EnumCorrectOfSized' (A : Type)
         {H : EnumSized A}
         `{@EnumSizedMonotonic A H PMon}
         `{@EnumSizedSizeMonotonic A H PSMon}
         `{@EnumSizedCorrect A H PCorr} : Correct A enum.
Proof.
  constructor. unfold arbitrary, EnumOfEnumSized.
  eapply set_eq_trans.
  - eapply semSized_alt; eauto with typeclass_instances.
  - destruct PCorr.
    rewrite <- prodCorrectSized0.

    split. intros [n [? H3]]. eexists. eassumption.

    intros [s H4]. eexists; split; eauto. reflexivity.
Qed.

#[global] Instance EnumCorrectOfSized (A : Type)
         (H1 : EnumSized A)
         (H3 : forall s : nat, SizeMonotonic (enumSized s))
         (H4 : SizedMonotonic enumSized)
         (H5 : CorrectSized enumSized)
  : Correct A enum.
Proof.
  eapply EnumCorrectOfSized'; eauto.
  constructor; eauto.
  constructor; eauto.
  constructor; eauto.
Qed.

Lemma enumerating_complete A (e : E A) {Hc : Correct A e} ch :
  (exists x, ch x = Some true) ->
  exists s, enumerating e ch s = Some true.
Proof.
  intros [x Hch].
  unfold enumerating.
  assert (Hin : semProd e x).
  { eapply Hc. reflexivity. }
  destruct Hin as [s [_ Hsem]]. simpl in *.
  unfold semEnumSize in *.
  exists s. revert Hsem.
  generalize (Enumerators.run e s), false.
  induction l; intros b Hin; inv Hin; simpl.
  - rewrite Hch. reflexivity.
  - destruct (ch a); eauto.
    destruct b0; eauto.
Qed.

Lemma lazylist_backtrack_opt_is_true A (l: LazyList.LazyList (option A)) ch b :
  lazylist_backtrack_opt l ch true = Some b -> b = true.
Proof.
  induction l.
  - simpl. congruence.
  - simpl in *.
    destruct a.
    + destruct (ch a) eqn:Heq. destruct b0. congruence.
      now eauto. now eauto.
    + eauto.
Qed.

Lemma lazylist_backtrack_opt_is_false A (l: LazyList.LazyList (option A)) ch b :
  lazylist_backtrack_opt l ch b = Some false -> b = false.
Proof.
  revert b; induction l; intros b.
  - simpl. destruct b; try congruence.
  - simpl in *.
    destruct a.
    + destruct (ch a) eqn:Heq. destruct b0. congruence.
      now eauto. intros Hin. eapply H in Hin. congruence.
    + intros Hn. eapply lazylist_backtrack_opt_is_true in Hn.
      congruence.
Qed.

Lemma lazylist_backtrack_opt_true A (l: LazyList.LazyList (option A)) ch b :
  lazylist_backtrack_opt l ch b = Some true <->
  exists x, LazyList.In_ll (Some x) l /\ ch x = Some true.
Proof.
  revert b; induction l; intros b.
  - simpl. split; intros Hc; try congruence.
    destruct b; congruence.
    destruct Hc. inv H; exfalso; eauto.
  - split.
    + intros Hl.
      simpl in *. destruct a.
      destruct (ch a) eqn:Heq.
      * destruct b0.
        -- eexists. split; eauto.
        -- eapply H in Hl. destruct Hl. inv H0.
           eexists; split; eauto.
      * eapply H in Hl. destruct Hl. inv H0.
        eexists; split; eauto.
      * eapply H in Hl. destruct Hl. inv H0.
        eexists; split; eauto.
    + intros Hc; inv Hc. inv H0. simpl in *. destruct a.
      * inv H1. inv H3. rewrite H2. reflexivity.
        destruct (ch a) eqn:Heq. destruct b0. reflexivity.
        eapply H. eexists. now split; eauto.
        eapply H. eexists. now split; eauto.
      * inv H1. congruence. eapply H. eexists. now split; eauto.
Qed.

Lemma lazylist_backtrack_opt_false A (l: LazyList.LazyList (option A)) ch :
  lazylist_backtrack_opt l ch false = Some false <->
  (forall x, LazyList.In_ll (Some x) l -> ch x = Some false) /\
  ~ LazyList.In_ll None l.
Proof.
  induction l.
  - simpl. split; intros Hc.
    split; eauto. intros. now inv H.
    reflexivity.
  - split.
    + intros Hl.
      simpl in *.
      destruct a.
      * destruct (ch a) eqn:Heq. destruct b.
        congruence.

        -- eapply H in Hl. inv Hl.
           split.
           intros. inv H2; eauto. inv H3. eassumption.

           intros Hc; inv Hc. congruence. eauto.

        -- eapply lazylist_backtrack_opt_is_false in Hl. congruence.

      * eapply lazylist_backtrack_opt_is_false in Hl. congruence.

    + intros [H1 H2].
      simpl.
      destruct a.
      * destruct (ch a) eqn:Heq. destruct b.
        rewrite H1 in Heq. congruence.
        now left.
        eapply H. split. intros. eapply H1.
        right. eassumption.
        intros Hc. eapply H2. right. eassumption.
        rewrite H1 in Heq. congruence. now left.

      * exfalso. eapply H2. now left.
Qed.

Lemma enumeratingOpt_monotonic A (e : E (option A))
      {Hc : SizeMonotonicOpt e} {Hfp : SizeFP e}
      ch1 ch2 s1 s2 b :
  (s1 <= s2)%coq_nat ->
  (forall x, ch1 x = Some b -> ch2 x = Some b) ->
  enumeratingOpt e ch1 s1 = Some b ->
  enumeratingOpt e ch2 s2 = Some b.
Proof.
  intros Hleq Hall Hen.

  specialize (Hc _ _ Hleq).
  specialize (Hfp _ _ Hleq).

  unfold enumeratingOpt in *.
  unfold semProdSizeOpt in *. simpl in *.
  unfold semEnumSize in *.
  revert Hc Hfp Hen.

  generalize (run e s1), (run e s2).

  intros l1 l2 Hs1 Hs2 Hl.
  destruct b.

  - eapply lazylist_backtrack_opt_true in Hl.
    destruct Hl. destruct H.

    eapply lazylist_backtrack_opt_true.
    eexists. split.
    eapply Hs1. eassumption.
    eapply Hall. eassumption.

  - eapply lazylist_backtrack_opt_false in Hl.
    destruct Hl.

    eapply lazylist_backtrack_opt_false.

    split. intros x Hin. eapply Hall. eapply H.
    eapply Hs2. eassumption. eassumption.

    intros Hc. eapply H0. eapply Hs2. eassumption. eassumption.
Qed.