(*  DEC 2.0 language specification.
   Paolo Torrini
   Universite' de Lille - CRIStAL-CNRS
*)

Require Import List.
Require Import Equality.
Require Import Eqdep.
Require Import PeanoNat.
Require Import Omega.
Require Import Eqdep FunctionalExtensionality Tactics.
Require Import JMeq.
Require Import ProofIrrelevance.

Require Import AuxLibI1.
Require Import TypSpecI1.
Require Import ModTypI1.
Require Import LangSpecI1.
Require Import StaticSemI1.
Require Import DynamicSemI1.
Require Import WeakenI1.
Require Import UniqueTypI1.
Require Import DerivDynI1.
Require Import TransPrelimI1.
Require Import TSoundnessI1.
Require Import SReducI1.

Import ListNotations.

Module Determ (IdT: ModTyp) <: ModTyp.

Module SReducL := SReduc IdT.
Export SReducL.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Open Scope type_scope.

(** stepwise determinism *)

Definition UniqueEStep
                     (fenv: funEnv) (env: valEnv)
                     (s s1 s2: W) (n n1 n2: nat) (e e1 e2: Exp) :=
    EStep fenv env (Conf Exp s n e) ((Conf Exp s1 n1 e1)) ->
    EStep fenv env (Conf Exp s n e) ((Conf Exp s2 n2 e2)) ->
        (s1 = s2) /\ (n1 = n2) /\ (e1 = e2).

Definition UniquePStep
                     (fenv: funEnv) (env: valEnv)
                     (s s1 s2: W) (n n1 n2: nat) (ps ps1 ps2: Prms) :=
    PStep fenv env (Conf Prms s n ps) ((Conf Prms s1 n1 ps1)) ->
    PStep fenv env (Conf Prms s n ps) ((Conf Prms s2 n2 ps2)) ->
       (s1 = s2) /\ (n1 = n2) /\ (ps1 = ps2).

(*******************************************************)

Definition DPar_E (n9: nat) :=
  fun (ftenv: funTC) (tenv: valTC)
      (e: Exp) (t: VTyp)
      (p: ExpTyping ftenv tenv e t) =>
  forall (fenv: funEnv) (env: valEnv),
    FEnvTyping fenv ftenv ->
    EnvTyping env tenv ->
  forall (n: nat), n <= n9 ->
  forall (s s1 s2: W) (n1 n2: nat) (e1 e2: Exp),
         UniqueEStep fenv env s s1 s2 n n1 n2 e e1 e2.

Definition DPar_P (n9: nat) :=
  fun (ftenv: funTC) (tenv: valTC)
                (ps: Prms) (pt: PTyp)
                (p: PrmsTyping ftenv tenv ps pt) =>
  forall (fenv: funEnv) (env: valEnv),
    FEnvTyping fenv ftenv ->
    EnvTyping env tenv ->
  forall (n: nat), n <= n9 ->
  forall (s s1 s2: W) (n1 n2: nat) (ps1 ps2: Prms),
          UniquePStep fenv env s s1 s2 n n1 n2 ps ps1 ps2.

Definition ExpTypingDet_mut (n: nat) :=
  ExpTyping_mut (DPar_E n) (DPar_P n).

Definition PrmsTypingDet_mut (n: nat) :=
  PrmsTyping_mut (DPar_E n) (DPar_P n).

(************************************************************************)

Lemma deterAux1 (s1 s2: W) (n1 n2: nat) (v1 v2: Value) (e3 e4 e5 e6: Exp) :
  Conf Exp s1 n1 (IfThenElse (Val v1) e3 e4) =
  Conf Exp s2 n2 (IfThenElse (Val v2) e5 e6) ->
  v1 = v2.
  intros.
  inversion H; subst.
  auto.
 Defined.

Lemma deterAux2 (s1 s2: W) (n1 n2: nat) (e1 e2 e3 e4 e5 e6: Exp) :
  Conf Exp s1 n1 (IfThenElse e1 e3 e4) =
  Conf Exp s2 n2 (IfThenElse e2 e5 e6) ->
  e1 = e2.
  intros.
  inversion H; subst.
  auto.
 Defined.

Lemma ExpDeterm_Val (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (v : Value)
    (t : VTyp) (v0 : VTyping v t),
  DPar_E n ftenv tenv (Val v) t (Val_Typing ftenv tenv v t v0).
  unfold DPar_E.
  unfold UniqueEStep.
  intros.
  inversion X0.
Defined.

Lemma ExpDeterm_Var (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (t : VTyp) (i : IdTyping tenv x t),
    DPar_E n ftenv tenv (Var x) t (Var_Typing ftenv tenv x t i).
  unfold DPar_E, UniqueEStep.
  intros.
  inversion X; subst.
  inversion X0; subst.
  rewrite H5 in H6.
  inversion H6; subst.
  auto.
Defined.

Lemma ExpDeterm_BindN (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (e1 e2 : Exp)
    (t1 t2 : VTyp) (e : ExpTyping ftenv tenv e1 t1),
  DPar_E n ftenv tenv e1 t1 e ->
  forall e0 : ExpTyping ftenv tenv e2 t2,
  DPar_E n ftenv tenv e2 t2 e0 ->
  DPar_E n ftenv tenv (BindN e1 e2) t2
    (BindN_Typing ftenv tenv e1 e2 t1 t2 e e0).
  unfold DPar_E, UniqueEStep.
  intros.
  inversion X; subst.
  inversion X0; subst.
  auto.
  inversion X1.
  inversion X0; subst.
  inversion X1.
  specialize (H fenv env H1 H2 n0 H3 s s1 s2 n1 n2 e1' e1'0 X1 X2).
  destruct H as [c1 H].
  destruct H as [c2 c3].
  inversion c1; subst.
  auto.
Defined.

Lemma ExpDeterm_BindS (n: nat) :
  forall (ftenv : funTC) (tenv tenv' : valTC) (x : StaticSemL.Id)
    (e1 e2 : Exp) (t1 t2 : VTyp) (m : option VTyp)
    (m0 : Maybe t1 m) (e : tenv' = (x, t1) :: tenv)
    (e0 : ExpTyping ftenv tenv e1 t1),
  DPar_E n ftenv tenv e1 t1 e0 ->
  forall e3 : ExpTyping ftenv tenv' e2 t2,
  DPar_E n ftenv tenv' e2 t2 e3 ->
  DPar_E n ftenv tenv (BindS x m e1 e2) t2
         (BindS_Typing ftenv tenv tenv' x e1 e2 t1 t2 m m0 e e0 e3).
  unfold DPar_E, UniqueEStep.
  intros.
  inversion X; subst.
  inversion X0; subst.
  auto.
  inversion X1.
  inversion X0; subst.
  inversion X1.
  specialize (H fenv env H1 H2 n0 H3 s s1 s2 n1 n2 e1' e1'0 X1 X2).
  destruct H as [c1 H].
  destruct H as [c2 c3].
  inversion c1; subst.
  auto.
Defined.

Lemma ExpDeterm_BindMS (n: nat) :
  forall (ftenv : funTC) (tenv tenv0 tenv1 : valTC)
    (env0 : valEnv) (e : Exp) (t : VTyp) (e0 : EnvTyping env0 tenv0)
    (e1 : tenv1 = tenv0 ++ tenv) (e2 : ExpTyping ftenv tenv1 e t),
  DPar_E n ftenv tenv1 e t e2 ->
  DPar_E n ftenv tenv (BindMS env0 e) t
    (BindMS_Typing ftenv tenv tenv0 tenv1 env0 e t e0 e1 e2).
  unfold DPar_E, UniqueEStep.
  intros.
  inversion X; subst.
  inversion X0; subst.
  auto.
  inversion X1.
  inversion X0; subst.
  inversion X1.
  assert (EnvTyping (env0 ++ env) (tenv0 ++ tenv)) as H1'.
  eapply overrideEnvLemma.
  assumption.
  assumption.
  specialize (H fenv (env0 ++ env) H0 H1' n0 H2 s s1 s2 n1 n2 e' e'0 X1 X2).
  destruct H as [c1 H].
  destruct H as [c2 c3].
  inversion c1; subst.
  auto.
Defined.

Lemma ExpDeterm_IfThenElse (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (e1 e2 e3 : Exp)
    (t : VTyp) (e : ExpTyping ftenv tenv e1 Bool),
  DPar_E n ftenv tenv e1 Bool e ->
  forall e0 : ExpTyping ftenv tenv e2 t,
  DPar_E n ftenv tenv e2 t e0 ->
  forall e4 : ExpTyping ftenv tenv e3 t,
  DPar_E n ftenv tenv e3 t e4 ->
  DPar_E n ftenv tenv (IfThenElse e1 e2 e3) t
         (IfThenElse_Typing ftenv tenv e1 e2 e3 t e e0 e4).
  unfold DPar_E, UniqueEStep.
  intros.
  inversion X; subst.
  inversion X0; subst.
  auto.
  eapply deterAux1 in H7.
  unfold cst in H7.
  eapply inj_pair2 in H7.
  inversion H7.
  inversion X0; subst.
  rewrite <- H14.
  rewrite <- H14.
  auto.
  inversion X1.
  inversion X2.

  inversion X0; subst.
  eapply deterAux1 in H7.
  unfold cst in H7.
  eapply inj_pair2 in H7.
  inversion H7.
  auto.
  inversion X1.
  inversion X0; subst.
  inversion X1.
  inversion X1.
  assert (s1 = s2 /\ n1 = n2 /\ e' = e'0).
  eapply H.
  exact H2.
  exact H3.
  exact H4.
  exact X1.
  exact X2.
  destruct H5.
  destruct H6.
  rewrite H7.
  auto.
Defined.

Lemma ExpDeterm_Apply0 :
  forall (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (e : Exp) (ps : Prms) (pt : PTyp) (t : VTyp) (p : Pure e)
    (i : IdFTyping ftenv x (FT pt t)) (p0 : PrmsTyping ftenv tenv ps pt),
  DPar_P 0 ftenv tenv ps pt p0 ->
  forall e0 : ExpTyping ftenv tenv e Nat,
  DPar_E 0 ftenv tenv e Nat e0 ->
  DPar_E 0 ftenv tenv (Apply x ps e) t
    (Apply_Typing ftenv tenv x e ps pt t p i p0 e0).
  unfold DPar_E, DPar_P, UniqueEStep, UniquePStep.
  intros.
  assert (n = 0) as q.
  omega.
  inversion q; subst.
  clear H4.
  inversion X0; subst.
  inversion X; subst.
  assert ( s1 = s2 /\ n1 = n2 /\ e'0 = e').
  eapply H0.
  exact H1.
  exact H2.
  exact H3.
  exact X2.
  exact X1.
  destruct H4.
  destruct H5.
  inversion H6; subst.
  auto.
  inversion X1.
  inversion X1.

  inversion X; subst.
  inversion X2.

  assert (s1 = s2 /\ n1 = n2 /\ ps'0 = ps').
  eapply H.
  exact H1.
  exact H2.
  exact H3.
  exact X2.
  exact X1.
  destruct H4.
  destruct H5.
  inversion H6; subst.
  auto.
  assert (False).
  destruct ps'.
  eapply (NoPrmsStep fenv env (s1,0) (s2,n2)).
  simpl.
  exact X1.
  exact X2.
  inversion H4.

  inversion X; subst.
  inversion X2.

  assert (False).
  destruct ps'.
  eapply (NoPrmsStep fenv env (s2,0) (s1,n1)).
  simpl.
  exact X2.
  exact X1.
  inversion H4.
  unfold cst in H8.
  eapply inj_pair2 in H8.
  inversion H8; subst.
  auto.
Defined.

Lemma ExpDeterm_Call0 :
  forall (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (ls : list Exp) (pt : PTyp) (t : VTyp) (i : IdFTyping ftenv x (FT pt t))
    (p : PrmsTyping ftenv tenv (PS ls) pt),
  DPar_P 0 ftenv tenv (PS ls) pt p ->
  DPar_E 0 ftenv tenv (Call x (PS ls)) t
         (Call_Typing ftenv tenv x ls pt t i p).
  unfold DPar_E, DPar_P, UniqueEStep, UniquePStep.
  intros.
  assert (n = 0) as q.
  omega.
  inversion q; subst.
  clear H3.
  inversion X0; subst.
  inversion X; subst.
  assert (s1 = s2 /\ n1 = n2 /\ ps'0 = ps').
  eapply H.
  exact H0.
  exact H1.
  exact H2.
  exact X2.
  exact X1.
  destruct H3.
  destruct H4.
  inversion H5; subst.
  auto.

  eapply isValueList2IsValueT in X2.
  assert (False).
  destruct ps'.
  eapply (NoPrmsStep fenv env (s1,0) (s2,n2)).
  simpl.
  exact X1.
  exact X2.
  inversion H3.

  inversion X; subst.
  eapply isValueList2IsValueT in X1.
  assert (False).
  destruct ps'.
  eapply (NoPrmsStep fenv env (s2,0) (s1,n1)).
  simpl.
  exact X2.
  exact X1.
  inversion H3.

  rewrite H10 in H11.
  inversion H11; subst.
  auto.
Defined.

Lemma ExpDeterm_Modify (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (t1 t2 : VTyp)
    (XF : XFun t1 t2) (e : Exp) (e0 : ExpTyping ftenv tenv e t1),
  DPar_E n ftenv tenv e t1 e0 ->
  DPar_E n ftenv tenv (Modify t1 t2 XF e) t2
         (Modify_Typing ftenv tenv t1 t2 XF e e0).
  unfold DPar_E, UniqueEStep.
  intros.
  inversion X; subst.
  eapply inj_pair2 in H10.
  eapply inj_pair2 in H10.
  inversion H10; subst.
  clear H3.

  inversion X0; subst.
  eapply inj_pair2 in H12.
  inversion H12; subst.
  clear H11 H3.
  eapply inj_pair2 in H10.
  eapply inj_pair2 in H10.
  inversion H10; subst.
  clear H3.
  auto.

  inversion X1.

  eapply inj_pair2 in H10.
  eapply inj_pair2 in H10.
  inversion H10; subst.
  clear H3.

  inversion X0; subst.

  eapply inj_pair2 in H10.
  eapply inj_pair2 in H10.
  inversion H10; subst.
  clear H3.

  inversion X1.

  eapply inj_pair2 in H10.
  eapply inj_pair2 in H10.
  inversion H10; subst.
  clear H3.

  assert (s1 = s2 /\ n1 = n2 /\ e' = e'0).
  eapply H.
  exact H0.
  exact H1.
  exact H2.
  exact X1.
  exact X2.
  destruct H3.
  destruct H4.
  inversion H5; subst.
  auto.
Defined.

Lemma ExpDeterm_Nil (n: nat) :
  forall (ftenv : funTC) (tenv : valTC),
  DPar_P n ftenv tenv (PS []) (PT []) (PSNil_Typing ftenv tenv).
  unfold DPar_P, UniquePStep.
  intros.
  inversion X0.
Defined.

Lemma ExpDeterm_Cons (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (e : Exp) (t : VTyp)
    (es : list Exp) (ts : list VTyp) (e0 : ExpTyping ftenv tenv e t),
  DPar_E n ftenv tenv e t e0 ->
  forall p : PrmsTyping ftenv tenv (PS es) (PT ts),
  DPar_P n ftenv tenv (PS es) (PT ts) p ->
  DPar_P n ftenv tenv (PS (e :: es)) (PT (t :: ts))
         (PSCons_Typing ftenv tenv e t es ts e0 p).
  unfold DPar_P, UniquePStep, DPar_E, UniqueEStep.
  intros.
  inversion X; subst.
  inversion X0; subst.
  assert (s1 = s2 /\ n1 = n2 /\ PS es' = PS es'0).
  eapply H0.
  exact H1.
  exact H2.
  exact H3.
  exact X1.
  exact X2.
  destruct H4.
  destruct H5.
  inversion H6; subst.
  auto.

  inversion X2.
  inversion X0; subst.
  inversion X1.

  assert (s1 = s2 /\ n1 = n2 /\ e' = e'0).
  eapply H.
  exact H1.
  exact H2.
  exact H3.
  exact X1.
  exact X2.

  destruct H4.
  destruct H5.
  inversion H6; subst.
  auto.
Defined.

Lemma ExpDeterm_CallS (n: nat)
  (IHn : forall (ftenv : funTC) (tenv : valTC) (e : Exp) (t : VTyp),
         ExpTyping ftenv tenv e t ->
         forall (fenv : funEnv) (env : valEnv),
         FEnvTyping fenv ftenv ->
         EnvTyping env tenv ->
         forall n0 : nat,
         n0 <= n ->
         forall (s s1 s2 : W) (n1 n2 : nat) (e1 e2 : Exp),
         UniqueEStep fenv env s s1 s2 n0 n1 n2 e e1 e2) :
  forall (ftenv : funTC) (tenv : valTC) (x : Id)
    (ls : list Exp) (pt : PTyp) (t : VTyp) (i : IdFTyping ftenv x (FT pt t))
    (p : PrmsTyping ftenv tenv (PS ls) pt),
  DPar_P (S n) ftenv tenv (PS ls) pt p ->
  DPar_E (S n) ftenv tenv (Call x (PS ls)) t
         (Call_Typing ftenv tenv x ls pt t i p).
  unfold DPar_E, DPar_P, UniqueEStep, UniquePStep.
  intros.

  inversion X0; subst.
  inversion X; subst.
  assert (s1 = s2 /\ n1 = n2 /\ ps'0 = ps').
  eapply H.
  exact H0.
  exact H1.
  exact H2.
  exact X2.
  exact X1.
  destruct H3.
  destruct H4.
  inversion H5; subst.
  auto.

  eapply isValueList2IsValueT in X2.
  assert (False).
  destruct ps'.
  eapply (NoPrmsStep fenv env (s1,0) (s2,n2)).
  simpl.
  exact X1.
  exact X2.
  inversion H3.

  eapply isValueList2IsValueT in X2.
  assert (False).
  destruct ps'.
  eapply (NoPrmsStep fenv env (s1,(S n1)) (s2,n2)).
  simpl.
  exact X1.
  exact X2.
  inversion H3.

  inversion X; subst.
  eapply isValueList2IsValueT in X1.
  assert (False).
  destruct ps'.
  eapply (NoPrmsStep fenv env (s2,0) (s1,n1)).
  simpl.
  exact X2.
  exact X1.
  inversion H3.

  rewrite H10 in H11.
  inversion H11; subst.
  auto.

  inversion X; subst.
  eapply isValueList2IsValueT in X1.
  assert (False).
  destruct ps'.
  eapply (NoPrmsStep fenv env (s2,(S n2)) (s1,n1)).
  simpl.
  exact X2.
  exact X1.
  inversion H3.

  rewrite H10 in H11.
  inversion H11; subst.

  inversion X1; subst.
  inversion X2; subst.

  eapply mapEq in H4.
  inversion H4; subst.
  auto.
Defined.

Lemma ExpDeterm_ApplyS (n: nat)
  (IHn : forall (ftenv : funTC) (tenv : valTC) (e : Exp) (t : VTyp),
         ExpTyping ftenv tenv e t ->
         forall (fenv : funEnv) (env : valEnv),
         FEnvTyping fenv ftenv ->
         EnvTyping env tenv ->
         forall n0 : nat,
         n0 <= n ->
         forall (s s1 s2 : W) (n1 n2 : nat) (e1 e2 : Exp),
         UniqueEStep fenv env s s1 s2 n0 n1 n2 e e1 e2) :
  forall (ftenv : funTC) (tenv : valTC) (x : Id)
    (e : Exp) (ps : Prms) (pt : PTyp) (t : VTyp) (p : Pure e)
    (i : IdFTyping ftenv x (FT pt t)) (p0 : PrmsTyping ftenv tenv ps pt),
  DPar_P (S n) ftenv tenv ps pt p0 ->
  forall e0 : ExpTyping ftenv tenv e Nat,
  DPar_E (S n) ftenv tenv e Nat e0 ->
  DPar_E (S n) ftenv tenv (Apply x ps e) t
         (Apply_Typing ftenv tenv x e ps pt t p i p0 e0).
  unfold DPar_E, DPar_P, UniqueEStep, UniquePStep.
  intros.

  inversion X0; subst.
  inversion X; subst.
  assert ( s1 = s2 /\ n1 = n2 /\ e'0 = e').
  eapply H0.
  exact H1.
  exact H2.
  exact H3.
  exact X2.
  exact X1.
  destruct H4.
  destruct H5.
  inversion H6; subst.
  auto.
  inversion X1.
  inversion X1.

  inversion X; subst.
  inversion X2.

  assert (s1 = s2 /\ n1 = n2 /\ ps'0 = ps').
  eapply H.
  exact H1.
  exact H2.
  exact H3.
  exact X2.
  exact X1.
  destruct H4.
  destruct H5.
  inversion H6; subst.
  auto.
  assert (False).
  destruct ps'.
  eapply (NoPrmsStep fenv env (s1,n0) (s2,n2)).
  simpl.
  exact X1.
  exact X2.
  inversion H4.

  inversion X; subst.
  inversion X2.

  assert (False).
  destruct ps'.
  eapply (NoPrmsStep fenv env (s2,n0) (s1,n1)).
  simpl.
  exact X2.
  exact X1.
  inversion H4.
  unfold cst in H8.
  eapply inj_pair2 in H8.
  inversion H8; subst.
  auto.
Defined.

Lemma ExpDeterm (n9: nat) :
  forall (ftenv: funTC) (tenv: valTC)
         (e: Exp) (t: VTyp),
      ExpTyping ftenv tenv e t ->
  forall (fenv: funEnv) (env: valEnv),
    FEnvTyping fenv ftenv ->
    EnvTyping env tenv ->
  forall (n: nat), n <= n9 ->
  forall (s s1 s2: W) (n1 n2: nat) (e1 e2: Exp),
         UniqueEStep fenv env s s1 s2 n n1 n2 e e1 e2.
Proof.
induction n9.
eapply (ExpTypingDet_mut 0).
- (* Val *)
  eapply (ExpDeterm_Val 0).
- (* Var *)
  eapply (ExpDeterm_Var 0).
- (* BindN *)
  eapply (ExpDeterm_BindN 0).
- (* BindS *)
  eapply (ExpDeterm_BindS 0).
-  (* BindMS *)
  eapply (ExpDeterm_BindMS 0).
-   (* IfThenElse *)
  eapply (ExpDeterm_IfThenElse 0).
-   (* Apply *)
  eapply ExpDeterm_Apply0.
-   (* Call *)
  eapply ExpDeterm_Call0.
- (* Modify *)
  eapply (ExpDeterm_Modify 0).
- eapply (ExpDeterm_Nil 0).
- eapply (ExpDeterm_Cons 0).
- eapply (ExpTypingDet_mut (S n9)).
  * eapply (ExpDeterm_Val (S n9)).
  * eapply (ExpDeterm_Var (S n9)).
  * eapply (ExpDeterm_BindN (S n9)).
  * eapply (ExpDeterm_BindS (S n9)).
  * eapply (ExpDeterm_BindMS (S n9)).
  * eapply (ExpDeterm_IfThenElse (S n9)).
  * eapply (ExpDeterm_ApplyS n9).
    assumption.
  * eapply (ExpDeterm_CallS n9).
    assumption.
  * eapply (ExpDeterm_Modify (S n9)).
  * eapply (ExpDeterm_Nil (S n9)).
  * eapply (ExpDeterm_Cons (S n9)).
Defined.

Lemma ExpDeterm_aux1 (n9 : nat)
  (IHn9 : forall (ftenv : funTC) (tenv : valTC) (ps : Prms) (pt : PTyp),
         PrmsTyping ftenv tenv ps pt ->
         forall (fenv : funEnv) (env : valEnv),
         FEnvTyping fenv ftenv ->
         EnvTyping env tenv ->
         forall n : nat,
         n <= n9 ->
         forall (s s1 s2 : W) (n1 n2 : nat) (ps1 ps2 : Prms),
         UniquePStep fenv env s s1 s2 n n1 n2 ps ps1 ps2) :
  forall (ftenv : funTC) (tenv : valTC) (e : Exp) (t : VTyp),
  ExpTyping ftenv tenv e t ->
  forall (fenv : funEnv) (env : valEnv),
  FEnvTyping fenv ftenv ->
  EnvTyping env tenv ->
  forall n0 : nat,
  n0 <= n9 ->
  forall (s s1 s2 : W) (n1 n2 : nat) (e1 e2 : Exp),
    UniqueEStep fenv env s s1 s2 n0 n1 n2 e e1 e2.
  unfold UniquePStep, UniqueEStep in *.
  intros.
  assert (s1 = s2 /\ n1 = n2 /\ PS [e1] = PS [e2]).
  eapply (IHn9 ftenv tenv (PS [e]) (PT [t])).
  constructor.
  assumption.
  constructor.
  eassumption.
  eassumption.
  exact H1.
  econstructor.
  exact X0.
  econstructor.
  exact X1.
  destruct H2.
  destruct H3.
  inversion H4; subst.
  auto.
Defined.

Lemma PrmsDeterm (n9: nat) :
  forall (ftenv: funTC) (tenv: valTC)
         (ps: Prms) (pt: PTyp),
      PrmsTyping ftenv tenv ps pt ->
  forall (fenv: funEnv) (env: valEnv),
    FEnvTyping fenv ftenv ->
    EnvTyping env tenv ->
  forall (n: nat), n <= n9 ->
  forall (s s1 s2: W) (n1 n2: nat) (ps1 ps2: Prms),
         UniquePStep fenv env s s1 s2 n n1 n2 ps ps1 ps2.
Proof.
induction n9.
eapply (PrmsTypingDet_mut 0).
- (* Val *)
  eapply (ExpDeterm_Val 0).
- (* Var *)
  eapply (ExpDeterm_Var 0).
- (* BindN *)
  eapply (ExpDeterm_BindN 0).
- (* BindS *)
  eapply (ExpDeterm_BindS 0).
-  (* BindMS *)
  eapply (ExpDeterm_BindMS 0).
-   (* IfThenElse *)
  eapply (ExpDeterm_IfThenElse 0).
-   (* Apply *)
  eapply ExpDeterm_Apply0.
-   (* Call *)
  eapply ExpDeterm_Call0.
- (* Modify *)
  eapply (ExpDeterm_Modify 0).
- eapply (ExpDeterm_Nil 0).
- eapply (ExpDeterm_Cons 0).
- eapply (PrmsTypingDet_mut (S n9)).
  * eapply (ExpDeterm_Val (S n9)).
  * eapply (ExpDeterm_Var (S n9)).
  * eapply (ExpDeterm_BindN (S n9)).
  * eapply (ExpDeterm_BindS (S n9)).
  * eapply (ExpDeterm_BindMS (S n9)).
  * eapply (ExpDeterm_IfThenElse (S n9)).
  * eapply (ExpDeterm_ApplyS n9).
    eapply (ExpDeterm_aux1 n9 IHn9).
  * eapply (ExpDeterm_CallS n9).
    eapply (ExpDeterm_aux1 n9 IHn9).
  * eapply (ExpDeterm_Modify (S n9)).
  * eapply (ExpDeterm_Nil (S n9)).
  * eapply (ExpDeterm_Cons (S n9)).
Defined.

(*********************************************************************)

(** Confluence of evaluation *)

Definition UniqueEClos (fenv: funEnv) (env: valEnv)
           (s s1 s2: W) (n n1 n2: nat)
           (e : Exp) (v1 v2: Value) :=
    EClosure fenv env (Conf Exp s n e) ((Conf Exp s1 n1 (Val v1))) ->
    EClosure fenv env (Conf Exp s n e) ((Conf Exp s2 n2 (Val v2))) ->
        (n1 = n2) /\ (s1 = s2) /\ (v1 = v2).

Definition UniquePClos (fenv: funEnv) (env: valEnv)
           (s s1 s2: W) (n n1 n2: nat)
           (ps : Prms) (vs1 vs2: list Value) :=
  PClosure fenv env (Conf Prms s n ps)
              ((Conf Prms s1 n1 (PS (map Val vs1)))) ->
  PClosure fenv env (Conf Prms s n ps)
              ((Conf Prms s2 n2 (PS (map Val vs2)))) ->
        (n1 = n2) /\ (s1 = s2) /\ (vs1 = vs2).

Lemma ExpConfluence (n: nat) :
  forall (ftenv: funTC) (tenv: valTC)
         (e: Exp) (t: VTyp),
      ExpTyping ftenv tenv e t ->
  forall (fenv: funEnv) (D: FEnvWT fenv) (env: valEnv),
    FEnvTyping fenv ftenv ->
    EnvTyping env tenv ->
  forall (n0: nat), n0 <= n ->
  forall (s s1 s2: W) (n1 n2: nat) (v1 v2: Value),
         UniqueEClos fenv env s s1 s2 n0 n1 n2 e v1 v2.
Proof.
  unfold UniqueEClos.
  intros.
  dependent induction X0.
  intros.
  dependent destruction X1.
  auto.
  inversion e.
  destruct p2.

  assert (ExpTyping ftenv tenv qq t) as K1.
  {- eapply (ExpSubjectRed fenv D ftenv tenv).
     exact X.
     exact H.
     exact H0.
     exact e0.
  }
  assert (fuel <= n) as q.
  {- eapply StepIsEClos in e0.
     eapply ExpDecrease in e0.
     omega.
  }
  assert (EClosure fenv env (Conf Exp state fuel qq)
                   (Conf Exp s2 n2 (Val v2))) as K2.
  {- inversion X1; subst.
     inversion e0.
     destruct p2.
     assert (state0 = state /\ fuel0 = fuel /\ qq0 = qq).
     {+ eapply ExpDeterm.
        exact X.
        exact H.
        exact H0.
        exact H1.
        exact X2.
        exact e0.
     }
     destruct H2.
     destruct H3.
     inversion H4; subst.
     exact X3.
  }
  specialize (IHX0 qq K1 D H H0 fuel q state s1 n1 v1
                   eq_refl eq_refl K2).
  auto.
Defined.

Lemma PrmsConfluence (n: nat) :
  forall (ftenv: funTC) (tenv: valTC)
         (ps: Prms) (pt: PTyp),
      PrmsTyping ftenv tenv ps pt ->
  forall (fenv: funEnv) (D: FEnvWT fenv) (env: valEnv),
    FEnvTyping fenv ftenv ->
    EnvTyping env tenv ->
  forall (n0: nat), n0 <= n ->
  forall (s s1 s2: W) (n1 n2: nat) (vs1 vs2: list Value),
         UniquePClos fenv env s s1 s2 n0 n1 n2 ps vs1 vs2.
Proof.
  unfold UniquePClos.
  intros.
  dependent induction X0.
  intros.
  dependent destruction X1.
  eapply mapEq in x.
  inversion x; subst.
  auto.
  destruct p2.
  assert (isValueList2T (map Val vs1) vs1) as u1.
  constructor.
  eapply isValueList2IsValueT in u1.
  assert (False).
  destruct qq.
  eapply (NoPrmsStep fenv env (s1,n1) (state,fuel)).
  simpl.
  exact p.
  exact u1.
  inversion H2.

  destruct p2.
  assert (PrmsTyping ftenv tenv qq pt) as K1.
  {- eapply (PrmsSubjectRed fenv D ftenv tenv).
     exact X.
     exact H.
     exact H0.
     exact p. }
  assert (fuel <= n) as q.
  {- eapply StepIsPClos in p.
     eapply PrmsDecrease in p.
     omega.
  }
  assert (PClosure fenv env (Conf Prms state fuel qq)
                   (Conf Prms s2 n2 (PS (map Val vs2)))) as K2.
  {- inversion X1; subst.
     + assert (isValueList2T (map Val vs2) vs2) as u1.
       constructor.
       eapply isValueList2IsValueT in u1.
       assert (False).
       destruct qq.
       eapply (NoPrmsStep fenv env (s2,n2) (state,fuel)).
       simpl.
       exact p.
       exact u1.
       inversion H2.
     +
     destruct p2.
     assert (state0 = state /\ fuel0 = fuel /\ qq0 = qq).
     {+ eapply PrmsDeterm.
        exact X.
        exact H.
        exact H0.
        exact H1.
        exact X2.
        exact p.
     }
     destruct H2.
     destruct H3.
     inversion H4; subst.
     exact X3.
  }
  specialize (IHX0 qq K1 D H H0 fuel q state s1 n1 vs1
                   eq_refl eq_refl K2).
  auto.
Defined.

End Determ.


(** @Name Formalization of class diagrams
    @version 1.1
    @domains
    @authors Feng sheng
    @date 30/03/2017
    @description class and object diagrams (Coq v8.2)
**)

Require Import List.
Require Import String.
Require Import ListSet.
Require Import Arith.
Require Import Peano_dec.

Import ListNotations.

Open Scope list_scope.

(** ##### the structute of metamodel of class diagram #### **)

(** ----- basic element ----- **)
Inductive NamedElement : Set :=
| BNamedElement : nat -> string -> NamedElement.

(** ----- classifier ----- **)
Inductive Classifier : Set :=
| BClassifier (super : NamedElement).

(** ----- operation ----- **)
Inductive Operation : Set :=
| BOperation : NamedElement -> list string -> Operation.

(** ----- Data Type ---- **)
Inductive DataType : Set :=
| BDataType: Classifier -> DataType.

(** ----- attribute, primitive data type, class ----- **)
Inductive Attribute : Set :=
| BAttribute : NamedElement -> Classifier -> Attribute.

Inductive Class : Set :=
| BClass : Classifier -> bool -> list Attribute -> Class.

(** ----- association end ----- **)
Inductive Natural :=
| Nat : nat -> Natural
| Star : Natural.

Inductive AsEnd : Set :=
| BAsEnd: string -> Class -> (Natural * Natural) -> AsEnd.

(** ----- association ----- **)
Inductive asKind : Set :=
| none : asKind
| directed : asKind
| aggregate : asKind
| composite : asKind.

Inductive Assoc : Set :=
| BAssoc: NamedElement -> asKind -> (AsEnd * AsEnd) -> Assoc.

(** ----- generalization ----- **)
Inductive Gen : Set :=
| BGen : Class -> Class -> Gen.

(** ------------------------------- **)
(** -------- Source Model --------- **)
Record SimpleUML : Set :=
  mkSimpleUML {
      MClass_Instance : list Class;
      MAttr_Instance : list Attribute;
      MDataType_Instance : list DataType;
      MAssoc_Instance : list Assoc;
      MGen_Instance : list Gen
    }.

(* ----- Equality Judgement ----- *)
Definition eqClassifier_dec : forall x y: Classifier, {x = y} + {x <> y}.
  repeat decide equality.
Defined.

Definition beqClassifier c c' :=
  match eqClassifier_dec c c' with
  | left _ => true
  | right _ => false
  end.

Definition eqAttribute_dec : forall x y: Attribute, {x = y} + {x <> y}.
  repeat decide equality.
Defined.

Definition beqAttribute a a' :=
  match eqAttribute_dec a a' with
  | left _ => true
  | right _ => false
  end.

Definition eqAssoc_dec : forall x y: Assoc, {x = y} + {x <> y}.
  repeat decide equality.
Defined.

Definition beqAssoc a a' :=
  match eqAssoc_dec a a' with
  | left _ => true
  | right _ => false
  end.

Definition eqAsEnd_dec : forall x y: AsEnd, {x = y} + {x <> y}.
  repeat decide equality.
Defined.

Definition beqAsEnd a a' :=
  match eqAsEnd_dec a a' with
  | left _ => true
  | right _ => false
  end.

Definition eqOperation_dec : forall x y: Operation, {x = y} + {x <> y}.
  repeat decide equality.
Defined.

Definition beqOperation o o' :=
  match eqOperation_dec o o' with
  | left _ => true
  | right _ => false
  end.

Fixpoint eqClass_dec (x y : Class) : {x = y} + {x <> y}.
  repeat decide equality.
Defined.

Definition beqClass c c' :=
  match eqClass_dec c c' with
  | left _ => true
  | right _ => false
  end.

Fixpoint eqGen_dec (x y : Gen) : {x = y} + {x <> y}.
  repeat decide equality.
Defined.

Definition beqGen g g' :=
  match eqGen_dec g g' with
  | left _ => true
  | right _ => false
  end.

(** ---------- Functions --------- **)

(** --- get all parents --- **)
Fixpoint parents' (l : list Gen) (c : Class) :=
match l with
| [] => []
| (BGen p c') :: l' => if eqClass_dec c c'
                       then p :: parents' l' c
                       else parents' l' c
end.

Fixpoint deduplicate (ls : list Class) :=
  match ls with
  | [] => []
  | x :: [] => [x]
  | x :: xs
    => if leb (count_occ eqClass_dec ls x) 1
       then deduplicate xs
       else x :: deduplicate xs
  end.

Require Import Coq.Sorting.Mergesort.
Require Import Coq.Lists.List.

Definition parents_step (l : list Gen) (cs : list Class) :=
  deduplicate (cs ++ List.flat_map (parents' l) cs).

Fixpoint all_parents' (l : list Gen) (cs : list Class) (fuel : nat) :=
  match fuel with
  | 0 => cs
  | S fuel'
    => all_parents' l (parents_step l cs) fuel'
  end.

Definition parents (l : list Gen) (c : Class) :=
  deduplicate (all_parents' l (parents' l c) (List.length l)).

(** ------------------projection--------------------- **)

(** ----- get named element oid ----- **)
Definition NamedElement_oid (o : NamedElement) : nat :=
  match o with
    | (BNamedElement o _ ) => o
  end.

(** ----- get named element name ----- **)
Definition NamedElement_name (o : NamedElement) : string :=
  match o with
    | (BNamedElement _ n) => n
  end.

(** ------ get the basis of attribute ----- **)
Definition Attribute_super (a : Attribute) : NamedElement :=
  match a with
    | BAttribute s _ => s
  end.

Definition Attribute_name (a : Attribute) : string :=
  NamedElement_name (Attribute_super a).

Definition Attribute_oid (a : Attribute) : nat :=
  NamedElement_oid (Attribute_super a).

(** ------ get the classifier of attribute ----- **)
Definition Attribute_type (a : Attribute) : Classifier :=
  match a with
    | BAttribute _ c => c
  end.

(** ----- get the basis (name, abstract) of classifier ----- **)
Definition Classifier_super (c : Classifier) : NamedElement :=
  match c with
    | BClassifier s => s
  end.

Definition Classifier_name (c : Classifier) : string :=
  NamedElement_name (Classifier_super c).

Definition Classifier_oid (c : Classifier) :=
  NamedElement_oid (Classifier_super c).

(** ----- get the basis of class ------ **)
Definition Class_super (c : Class) : Classifier :=
  match c with
    | BClass c _ _  => c
  end.

Definition Class_name (c : Class) : string :=
  Classifier_name (Class_super c).

Definition Class_oid (c : Class) : nat :=
  Classifier_oid (Class_super c).

(** ----- get the abstract of class ----- **)
Definition Class_abstract (c : Class) : bool :=
  match c with
    | BClass _ a _ => a
  end.

(** ----- get the attributes of class ----- **)
Definition Class_attribute (c : Class) : list Attribute :=
  match c with
    | BClass _ _ a  => a
  end.

(** ----- get the classifier of primitive data type ------ **)
Definition DataType_super (p : DataType) : Classifier :=
  match p with
    | BDataType s => s
  end.

Definition DataType_name (c : DataType) : string :=
  Classifier_name (DataType_super c).

Definition DataType_oid (c : DataType) : nat :=
  Classifier_oid (DataType_super c).

(** ----- get the super class of generalization ----- **)
Definition Gen_src (g : Gen) : Class :=
  match g with
    | BGen s _ => s
  end.

(** ----- get the sub class of generalization ----- **)
Definition Gen_dest (g : Gen) : Class :=
  match g with
    | BGen _ sub => sub
  end.

(** ------ get the name of association end ----- **)
Definition AsEnd_name (a : AsEnd) : string :=
  match a with
  | BAsEnd n _ _  => n
  end.

(** ------ get the attached class of association end ----- **)
Definition AsEnd_class (a : AsEnd) : Class :=
  match a with
  | BAsEnd  _ c _  => c
  end.

(** ------ get the multipy of association ----- **)
Definition AsEnd_lower (a : AsEnd) : Natural:=
  match a with
    | BAsEnd _ _ l => fst l
  end.

Definition AsEnd_upper (a : AsEnd) : Natural:=
  match a with
    | BAsEnd _ _ l => snd l
  end.

(** ----- get the name of association ------ **)
Definition Assoc_super (a : Assoc) : NamedElement :=
  match a with
    | BAssoc s _ _ => s
  end.

Definition Assoc_name (a : Assoc) : string :=
  NamedElement_name (Assoc_super a).

Definition Assoc_oid (a : Assoc) : nat :=
  NamedElement_oid (Assoc_super a).

Definition Assoc_kind (a : Assoc) : asKind :=
  match a with
  | BAssoc _ k _ => k
  end.

(** ----- Get the ends of association ----- *)
Definition Assoc_node (a : Assoc) : AsEnd * AsEnd :=
  match a with
    | BAssoc _ _ k => k
  end.

(** ----- get the class of association ends ----- **)
Definition Assoc_src (a : Assoc) : Class :=
  AsEnd_class (fst (Assoc_node a)).

Definition Assoc_dest (a : Assoc) : Class :=
  AsEnd_class (snd (Assoc_node a)).

(** --------- the set of each concept--------- *)

Definition Class_Instances (model : SimpleUML) :=
  MClass_Instance model.

Definition DataType_Instances (model : SimpleUML) :=
  MDataType_Instance model.

Definition Assoc_Instances (model : SimpleUML) :=
  MAssoc_Instance model.

Definition Attribute_Instances (model : SimpleUML) :=
  MAttr_Instance model.

Definition Gen_Instances (model : SimpleUML) :=
  MGen_Instance model.

(** ###### Structural Constraints ##### **)

Definition lstClassOid (model : SimpleUML) : list nat :=
  map Class_oid (Class_Instances model).

Definition lstAttrOid (model : SimpleUML) : list nat :=
  map Attribute_oid (Attribute_Instances model).

Definition lstDataOid (model : SimpleUML) : list nat :=
  map DataType_oid (DataType_Instances model).

Definition lstAssocOid (model : SimpleUML) : list nat :=
  map Assoc_oid (Assoc_Instances model).

Definition UniqueOid (model : SimpleUML) : Prop :=
  NoDup (lstClassOid model ++ lstAttrOid model ++
         lstDataOid model ++ lstAssocOid model).

Definition UniqueClass (model : SimpleUML) : Prop :=
  NoDup (Class_Instances model).

Definition UniqueDataType (model : SimpleUML) : Prop :=
  NoDup (DataType_Instances model).

Definition UniqueAttribute (model : SimpleUML) : Prop :=
  NoDup (Attribute_Instances model).

Definition UniqueAttrInClass (model : SimpleUML) : Prop :=
  forall o: Class,  (In o (Class_Instances model)) ->
    NoDup (Class_attribute o).

(** ##### Non-structural Contraints ##### **)

Definition nsc_AttributeUniqueness (model : SimpleUML) : Prop :=
  forall o : Class,
    (In o (Class_Instances model)) ->
    NoDup (map Attribute_name (Class_attribute o)).

Definition nsc_ClassUniqueness (model : SimpleUML) : Prop :=
  NoDup (map Class_name (Class_Instances model)).

Definition nsc_DataTypeUniquenss (model : SimpleUML) : Prop :=
  NoDup (map DataType_name (DataType_Instances model)).

Definition nsc_AssocUniqueness (model : SimpleUML) : Prop :=
  NoDup (map Assoc_name (Assoc_Instances model)).

Definition NotSelfGenralization (model : SimpleUML) : Prop :=
  forall g: Gen, (In g (Gen_Instances model)) ->
    let sub := Gen_dest g in
    ~ In sub (parents (Gen_Instances model) sub).

(** ----- well formed ----- **)

Definition WellFormed (s : SimpleUML) :  Prop :=
  UniqueClass s /\ UniqueAttribute s /\  UniqueDataType s /\
  UniqueAttrInClass s /\ nsc_AttributeUniqueness s /\ nsc_ClassUniqueness s /\
  nsc_DataTypeUniquenss s /\ NotSelfGenralization s.


Require Import String.

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

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

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

Import HaskellListNotations.

Require Import HMAC.HMAC.

Require Import HMAC.HMAC_lib.
Require Import Cryptol.Prims.

Require Import List.
Import ListNotations.

Lemma kinit_eval :
  forall GE TE SE,
    wf_env ge GE TE SE ->
    forall (key : ext_val) keylen,
      has_type key (bytestream keylen) ->
      forall h hf,
        good_hash h GE TE SE hf ->
        forall digest t1 t2 t3 kexpr,
          eager_eval_type GE TE t1 (tvnum (Z.of_nat keylen)) ->
          eager_eval_type GE TE t2 (tvnum (Z.of_nat keylen)) ->
          eager_eval_type GE TE t3 (tvnum digest) ->
          eager_eval_expr GE TE SE kexpr (to_sval key) ->
          eager_eval_expr GE TE SE (apply (tapply (EVar kinit) (ETyp t1 :: ETyp t2 :: ETyp t3 ::  nil)) (h :: kexpr :: nil)) (to_sval key).
Proof.
  intros.
  eapply good_hash_eval in H1. do 4 destruct H1.

  unfold bytestream in H0. inversion H0. subst.
  gen_global (0,"demote").
  gen_global (14,">").
  gen_global (61,"take").
  gen_global (34,"#").
  gen_global (29,"zero").
  gen_global (35,"splitAt").

  e. e. e. e. e.
  gen_global kinit.
  ag.
  e. e. e. e.
  e.
  e. e. e. e.

  ag.

  e. e. e. e.
  ag.

  e. e. e.

  reflexivity. e. e. e.

  ag.

  e. e. e.
  reflexivity.
  e. lv. lv.
  simpl. unfold strictnum.

  rewrite gt_not_refl; reflexivity.
  simpl.

  use take_eval; try omega.

  use append_eval.

  instantiate (1 := l). simpl. lv.

  e.
  ag.

  e. e.

  simpl.
  f_equal. instantiate (1 := (repeat (eseq (repeat (ebit false) 8)) (length l))).
  simpl.
  f_equal.
  rewrite map_repeat. simpl.
  rewrite Nat2Z.id.
  reflexivity.
  reflexivity.
  rewrite app_length.
  rewrite Nat2Z.inj_add. omega.

  unfold take_model.
  rewrite Nat2Z.id.

  simpl. f_equal.
  rewrite firstn_app.
  rewrite firstn_all.
  replace (Datatypes.length l - Datatypes.length l)%nat with O by omega.
  rewrite firstn_O. rewrite app_nil_r.
  reflexivity.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep Relation_Operators.
From pcm Require Import pred prelude ordtype finmap pcm unionmap heap.
From htt Require Import domain.
From DiSeL Require Import Freshness State EqTypeX DepMaps Protocols.
From DiSeL Require Import Worlds NetworkSem Rely Actions Injection Process.
From DiSeL Require Import Always HoareTriples InductiveInv.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

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

[Unary Hoare-style specifications and auxiliary lemmas].

This file borrows basic definition of binary-to-unary Hoare triple
encoding (i.e., logvar and binarify definitions) from the development
of FCSL by Nanevski et al.

(FCSL is available at http://software.imdea.org/fcsl)

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

(* Spec s is parametrized by a ghost variable of type A *)
Definition logvar {B A} (s : A -> spec B) : spec B :=
  (fun i => exists x : A, (s x).1 i,
   fun y i m => forall x : A, (s x).2 y i m).

(* Representing q as a unary postcondition, including the precondition *)
Definition binarify {A} (p : pre) (q : cont A) : spec A :=
  (p, fun i y m => p i -> q y m).

Notation "'DHT' [ this , W ] ( p , q ) " :=
  (DTbin this W (binarify p q)) (at level 0,
   format "'[hv ' DHT  [ this , W ]  ( '[' p , '/' q ']' ) ']'").

(* A unary Hoare-style specification  *)
Notation "{ x .. y }, 'DHT' [ this , W ] ( p , q )" :=
  (DTbin this W (logvar (fun x => .. (logvar (fun y => binarify p q)) .. )))
   (at level 0, x binder, y binder, right associativity,
    format "'[hv ' { x .. y }, '/ ' DHT  [ this , W ]  ( '[' p , '/' q ']' ) ']'").

Section BasicRules.

Variable this : nid.

(* We can always assume coherence of the state *)
Lemma vrf_coh W A (e : DT this W A) i r :
        (i \In Coh W -> verify i e r) -> verify i e r.
Proof.
by move=>H C; apply: H.
Qed.

(* stability of preconditions *)
Lemma vrf_pre W A (e : DT this W A) i i' (k : cont A) :
        verify i e k -> network_rely W this i i' -> verify i' e k.
Proof.
move=>H M Ci' t H'; case: (rely_coh M)=>Ci _.
by apply: aft_imp (alw_envs (H Ci t H') M).
Qed.

(* stability of postconditions *)
Lemma vrf_post W A (e : DT this W A) i (k : cont A) :
        verify i e k ->
        verify i e (fun x m => forall m', network_rely W this m m' -> k x m').
Proof.
move=>H Ci t H'; move: (alw_envsq (H Ci t H')).
apply: alw_imp=>s p Cs H2 s3 M v E; apply: H2 E _ M.
Qed.

(* An inference rule for the sequential composition *)
Lemma bind_rule W A B (e1 : DT this W A) (e2 : A -> DT this W B) i
             (q : cont A) (r : cont B) :
        verify i e1 q ->
        (forall y j, q y j -> j \In Coh W  -> verify j (e2 y) r) ->
        verify i (bind e1 e2) r.
Proof.
move=>H1 H2 Ci t [->|[t'][H3 H4]].
- by apply: alw_unfin=>//; move/alw_coh: (H1 Unfinished (prog_unfin e1)).
by apply: aft_bnd H3 _; move/(H1 Ci): H4; apply: aft_imp=>y j Cj H; apply: H2.
Qed.

Arguments bind_rule [W A B e1 e2 i].

Lemma step W A B (e1 : DT this W A) (e2 : A -> DT this W B) i (r : cont B) :
        verify i e1 (fun y m => verify m (e2 y) r) ->
        verify i (bind e1 e2) r.
Proof. by move=>H; apply: (bind_rule (fun y m => verify m (e2 y) r)). Qed.

(* Inference rules for the calls to an already verified function f *)
Lemma call_rule' W A i (f : DT this W A) (k : cont A) :
  (* Verify precondition of the call *)
  (i \In Coh W -> pre_of f i) ->
  (* Verify the rest out of the postcondition *)
  (forall x m, post_of f i x m -> m \In Coh W -> k x m) ->
  verify i f k.
Proof.
case: f=>s [e] /= H H1 H2 Ci t H3.
apply: aft_imp (H i t (H1 Ci) Ci H3).
by move=>v m Cm H4; apply: H2.
Qed.

(* Same lemma for unary postconidtions *)
Lemma call_rule W A (p : Pred state) (q : A -> Pred state) i
      {e} (k : cont A) :
        (i \In Coh W -> p i) ->
        (forall x m, q x m -> m \In Coh W -> k x m) ->
        verify i (@with_spec this W A (binarify p q) e) k.
Proof.
move=>H1 H2; apply: vrf_coh=>C; apply: call_rule'=>//.
by move=>x m /(_ (H1 C)); apply: H2.
Qed.

(* Lemmas for manipulating with ghost variables *)
Section GhostRules.

Variables (W : world) (A B C : Type).

(* Weakening of the continuation postcondition *)
Lemma vrf_mono (e : DT this W A) i (r1 r2 : cont A) :
        r1 <== r2 -> verify i e r1 -> verify i e r2.
Proof. by move=>T H1 C' t; move/(H1 C'); apply: aft_imp=>v m _; apply: T. Qed.

Variable (e : DT this W A).

(* "Uncurrying" the ghosts in the specification s *)
Lemma ghE (s : B -> C -> spec A) :
        conseq e (logvar (fun x => logvar (s x))) <->
        conseq e (logvar (fun xy => s xy.1 xy.2)).
Proof.
split.
- move=>/= H1 i [[x y]] H2.
  have: exists x1 y1, (s x1 y1).1 i by exists x, y.
  by move/H1; apply: vrf_mono=>y1 m1 T1 [x2 y2]; apply: (T1 x2 y2).
move=>/= H1 i [x][y] H2.
have: exists x, (s x.1 x.2).1 i by exists (x, y).
by move/H1; apply: vrf_mono=>y1 m1 T1 x2 y2; apply: (T1 (x2, y2)).
Qed.

(* Pulling the ghosts out of the specification *)
Lemma ghC (p : B -> pre) (q : B -> A -> pre) :
        (forall i x, p x i -> i \In Coh W -> verify i e (q x)) ->
        conseq e (logvar (fun x => binarify (p x) (q x))).
Proof.
move=>H i /= [x Hp] Ci t Ht.
have S : alwsafe i t by apply: alw_imp (H i x Hp Ci Ci t Ht).
by apply/aftA=>// y; apply/aftI=>// /H; apply.
Qed.

(********************************************)
(* Lemmas for instantiating ghost variables *)
(********************************************)
Variables (s : C -> spec A) (f : DTbin this W (logvar s)).

(* helper lemma, to express the instantiation *)
Lemma gh_conseq t : conseq f (s t).
Proof.
case E: (s t)=>[a b] h /= H; apply: call_rule'=>[|x m].
- by exists t; rewrite E.
by move/(_ t); rewrite E.
Qed.

(* Instantiating the ghost of a call *)
Lemma gh_ex g i (k : cont A) :
        verify i (do' (@gh_conseq g)) k ->
        verify i (@with_spec this W A (logvar s) f) k.
Proof. by []. Qed.

End GhostRules.

Arguments gh_ex [W A C s f].

Lemma act_rule W A (a: action W A this) i (r : cont A) :
  (forall j, network_rely W this i j -> a_safe a j /\
   forall y k m, (exists pf : a_safe a j, a_step pf k y) -> network_rely W this k m -> r y m) ->
        verify i (act a) r.
Proof.
move=>H C p; case=>Z; subst p; first by apply: (alw_unfin C).
apply: (alw_act C)=>j R; case: (H j R)=>{H}S H; exists S.
split=>//k v m St R' v'[]<-.
have X: (exists pf : a_safe a j, a_step pf k v) by exists S.
by apply: (H _ _ _ X R').
Qed.

Lemma ret_rule W A i (v : A) (r : cont A) :
       (forall m, network_rely W this i m -> r v m) ->
       verify i (ret this W v) r.
Proof.
move=>H C p; case=>Z; subst p; first by apply: alw_unfin.
by apply: alw_ret=>//m R v'[]<-; apply: H.
Qed.

End BasicRules.

Section InjectLemmas.

Variable this : nid.
Variables (W V : world) (K : hooks) (A : Type) (w : injects V W K).
Notation W2 := (inj_ext w).

Variable (e1 : DT this V A).

Lemma inject_rule i j (r : cont A) :
        i \In Coh V ->
        verify i e1 (fun x i' => forall j',
          i' \+ j' \In Coh W -> network_rely W2 this j j' -> r x (i' \+ j')) ->
        verify (i \+ j) (inject w e1) r.
Proof.
move=>Ci H C t [->|[t' [H' ->{t}]]]; first by apply: alw_unfin.
move/aft_inject: {H H'} (H Ci _ H'); move/(_ _ _ w _ C).
apply: aft_imp=>v s Cs [i'][j'][E] Ci' S'.
by rewrite {s}E in Cs *; apply.
Qed.

End InjectLemmas.

Section InductiveInvLemmas.

Variable pr : protocol.

Notation l := (plab pr).
Variable I : dstatelet -> pred nid -> Prop.
Variable ii : InductiveInv pr I.

(* Tailored modal always-lemma *)

Variables (A : Type) (this: nid).
Notation V := (mkWorld pr).
Notation W := (mkWorld (ProtocolWithIndInv ii)).

Variable (e : DT this V A).

(*

[Inferences rule for invariant strengthening]

This rule essentially means that we can always verify the program in
stronger assumptions (i.e., in a protocol, enriched with the inductive
invariant), if we can provide this protocol in the first place. We can
then also make use of the invariant.

 *)

Notation getS i := (getStatelet i l).

Lemma with_inv_rule' i (r : cont A) :
  verify i e (fun x m =>
              I (getS m) (nodes pr (getS m)) -> r x m) ->
        verify i (with_inv ii e) r.
Proof.
move=> H C t [->|[t' [H' ->{t}]]]; first by apply: alw_unfin.
move/aft_ind_inv: {H H'}(H (with_inv_coh C) _ H')=>/(_ _ _ C).
apply: aft_imp=>v m _[C']; apply.
by case: C'=>_ _ _ _/(_ l); rewrite prEq; case.
Qed.

Lemma with_inv_rule i (r : cont A) :
        verify i e (fun x m => r x m) ->
        verify i (with_inv ii e) r.
Proof.
move=>H; apply: with_inv_rule'.
by move=>H1 p H2; move: (H H1 p H2)=>G; apply: (aft_imp _ G).
Qed.

End InductiveInvLemmas.


Require Import VST.progs.io_mem.
Require Import VST.progs.io_mem_specs.
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import ITree.ITree.
(*Import ITreeNotations.*)
Notation "t1 >>= k2" := (ITree.bind t1 k2)
  (at level 50, left associativity) : itree_scope.
Notation "x <- t1 ;; t2" := (ITree.bind t1 (fun x => t2))
  (at level 100, t1 at next level, right associativity) : itree_scope.
Notation "t1 ;; t2" := (ITree.bind t1 (fun _ => t2))
  (at level 100, right associativity) : itree_scope.
Notation "' p <- t1 ;; t2" :=
  (ITree.bind t1 (fun x_ => match x_ with p => t2 end))
(at level 100, t1 at next level, p pattern, right associativity) : itree_scope.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition putchars_spec := DECLARE _putchars putchars_spec.
Definition getchars_spec := DECLARE _getchars getchars_spec.

(* make a new exit_spec that only allows exit code 0 if the ITREE is fully used, or that exit is only done w/ 1,
and put empty itree in main_post *)

(* This tells us that exit(0) is never called, so if we terminate successfully, the postcondition of main
  must hold. *)
Definition exit_spec := DECLARE _exit
 WITH i : Z
 PRE [1%positive OF tint]
   PROP (repable_signed i; i <> 0) LOCAL(temp 1%positive (Vint (Int.repr i))) SEP()
 POST [ tvoid ]
   PROP(False) LOCAL() SEP().

Lemma div_10_dec : forall n, 0 < n ->
  (Z.to_nat (n / 10) < Z.to_nat n)%nat.
Proof.
  intros.
  change 10 with (Z.of_nat 10).
  rewrite <- (Z2Nat.id n) by omega.
  rewrite <- div_Zdiv by discriminate.
  rewrite !Nat2Z.id.
  apply Nat2Z.inj_lt.
  rewrite div_Zdiv, Z2Nat.id by omega; simpl.
  apply Z.div_lt; auto; omega.
Qed.

Program Fixpoint chars_of_Z (n : Z) { measure (Z.to_nat n) } : list int :=
  let n' := n / 10 in
  match n' <=? 0 with true => [Int.repr (n + char0)] | false => chars_of_Z n' ++ [Int.repr (n mod 10 + char0)] end.
Next Obligation.
Proof.
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous.
  eapply Z.lt_le_trans, Z_mult_div_ge with (b := 10); omega.
Defined.

(* The function computed by print_intr *)
Program Fixpoint intr n { measure (Z.to_nat n) } : list int :=
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Int.repr (n mod 10 + char0)]
  end.
Next Obligation.
Proof.
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous; omega.
Defined.

Definition replace_list {X} i (l : list X) (l' : list X) :=
  sublist 0 i l ++ l' ++ sublist (i + Zlength l') (Zlength l) l.

Definition print_intr_spec :=
 DECLARE _print_intr
  WITH sh : share, i : Z, buf : val, j : Z, contents : list val
  PRE [ _i OF tuint, _buf OF tptr tuchar, _j OF tint ]
    PROP (writable_share sh; 0 <= i <= Int.max_unsigned;
               0 <= j; j + Zlength (intr i) <= Zlength contents < Int.max_signed)
    LOCAL (temp _i (Vint (Int.repr i)); temp _buf buf; temp _j (Vint (Int.repr j)))
    SEP (data_at sh (tarray tuchar (Zlength contents)) contents buf)
  POST [ tint ]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (j + Zlength (intr i)))))
    SEP (data_at sh (tarray tuchar (Zlength contents)) (replace_list j contents (map Vint (intr i))) buf).

Definition print_int_spec :=
 DECLARE _print_int
  WITH gv : globals, i : Z, tr : IO_itree
  PRE [ _i OF tuint ]
    PROP (0 <= i < 10000)
    LOCAL (gvars gv; temp _i (Vint (Int.repr i)))
    SEP (mem_mgr gv; ITREE (write_list (chars_of_Z i ++ [Int.repr newline]) ;; tr))
  POST [ tvoid ]
    PROP ()
    LOCAL ()
    SEP (mem_mgr gv; ITREE tr).

Definition for_loop i z (body : Z -> itree IO_event bool) :=
  ITree.aloop (fun '(b, j) => if (b : bool) then inr true else if j <? z then inl (b <- body j ;; Ret (b, j + 1)) else inr false) (false, i).

Definition sum_Z l := fold_right Z.add 0 l.

Definition read_sum_inner n nums j :=
  if orb (10 <=? Znth j nums) (Znth j nums <? 0) then Ret true
  else write_list (chars_of_Z (n + sum_Z (sublist 0 (j + 1) nums)) ++ [Int.repr newline]);; Ret false.

Definition read_sum n lc : IO_itree :=
  ITree.aloop (fun '(b, n, lc) => if (b : bool) then inr tt else
  if zlt n 1000 then
    let nums := map (fun c => Int.unsigned c - char0) lc in
    inl (b <- for_loop 0 4 (read_sum_inner n nums) ;; if (b : bool) then Ret (true, n, lc) else
    lc' <- read_list 4;; Ret (false, n + sum_Z nums, lc'))
  else inr tt) (false, n, lc).

Definition main_itree := lc <- read_list 4;; read_sum 0 lc (* ;; exit 0 *).
(* !! Making exit an effect and requiring it to be called at the end of a program is a good
   way to get around the problem of dropping suffixes of an itree. *)

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre_ext prog main_itree nil gv
  POST [ tint ] PROP () LOCAL () SEP (mem_mgr gv; ITREE (Ret tt)).
(* making the post false forces user to call exit to terminate *)

(* override default spec for exit *)
Definition library_G  {cs: compspecs} prog :=
 let defs := prog_defs prog in
  try_spec "_malloc" malloc_spec' defs ++
  try_spec "_free" free_spec' defs.

Ltac with_library prog G :=
  let pr := eval unfold prog in prog in
 let x := constr:(library_G pr ++ G) in
  let x := eval cbv beta delta [app library_G] in x in
  let x := simpl_prog_defs x in
  let x := eval cbv beta iota zeta delta [try_spec] in x in
  let x := eval simpl in x in
    with_library' pr x.

Definition Gprog : funspecs := ltac:(with_library prog [putchars_spec; getchars_spec;
  exit_spec; print_intr_spec; print_int_spec; main_spec]).

Lemma divu_repr : forall x y,
  0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned ->
  Int.divu (Int.repr x) (Int.repr y) = Int.repr (x / y).
Proof.
  intros; unfold Int.divu.
  rewrite !Int.unsigned_repr; auto.
Qed.

(*Opaque bind.

Opaque Nat.div Nat.modulo.*)

Lemma intr_eq : forall n, intr n =
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Int.repr (n mod 10 + char0)]
  end.
Proof.
  intros.
  unfold intr at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold intr.
  destruct n; reflexivity.
Qed.

(* missing from standard library *)
Lemma Zdiv_le_compat_r : forall m n p, p > 0 -> m <= n -> m / p <= n / p.
Proof.
  intros; unfold Z.div.
  pose proof (Z_div_mod m _ H) as Hm.
  pose proof (Z_div_mod n _ H) as Hn.
  destruct (Z.div_eucl m p), (Z.div_eucl n p).
  destruct Hm, Hn; subst.
  destruct (zle z z1); auto.
  assert (p * z1 + p <= p * z); try omega.
  rewrite <- Z.mul_succ_r.
  apply Zmult_le_compat_l; omega.
Qed.

Lemma intr_lt : forall n, 0 < n -> Zlength (intr (n / 10)) = Zlength (intr n) - 1.
Proof.
  intros.
  rewrite (intr_eq n).
  destruct (n <=? 0) eqn: Hn.
  { apply Zle_bool_imp_le in Hn; omega. }
  rewrite Zlength_app, Zlength_cons, Zlength_nil; omega.
Qed.

Lemma replace_list_nil : forall {X} i (l : list X), 0 <= i <= Zlength l -> replace_list i l [] = l.
Proof.
  intros; unfold replace_list.
  rewrite Zlength_nil, Z.add_0_r; simpl.
  rewrite sublist_rejoin, sublist_same by omega; auto.
Qed.

Lemma replace_list_upd_snoc : forall {X} i (l l' : list X) x, 0 <= i -> i + Zlength l' < Zlength l ->
  upd_Znth (i + Zlength l') (replace_list i l l') x = replace_list i l (l' ++ [x]).
Proof.
  intros; unfold replace_list.
  rewrite upd_Znth_app2; rewrite ?Zlength_sublist; try rep_omega.
  f_equal.
  rewrite Z.sub_0_r, Z.add_simpl_l, upd_Znth_app2; rewrite ?Zlength_sublist; try rep_omega.
  rewrite Zminus_diag, Zlength_app, Zlength_cons, Zlength_nil, upd_Znth0, <- app_assoc; simpl; f_equal; f_equal.
  rewrite Zlength_sublist by rep_omega.
  rewrite sublist_sublist by rep_omega.
  f_equal; omega.
  { rewrite Zlength_app, Zlength_sublist; rep_omega. }
Qed.

Lemma body_print_intr: semax_body Vprog Gprog f_print_intr print_intr_spec.
Proof.
  start_function.
  forward.
  forward_if (PROP ()
    LOCAL (temp _k (Vint (Int.repr (j + Zlength (intr i) - 1))))
    SEP (data_at sh (tarray tuchar (Zlength contents)) (replace_list j contents (map Vint (intr i))) buf)).
  - forward.
    rewrite divu_repr by rep_omega.
    forward.
    forward_call (sh, i / 10, buf, j, contents).
    { rewrite intr_lt by omega; split; auto.
      assert (i / 10 < i).
      { apply Z.div_lt; omega. }
      split; [split|]; try omega.
      apply Z.div_pos; omega. }
    rewrite modu_repr by (omega || computable).
    forward.
    { entailer!.
      split; try rep_omega.
      rewrite intr_lt; omega. }
    entailer!.
    { rewrite intr_lt by omega.
      rewrite Z.add_sub_assoc; auto. }
    rewrite (intr_eq i).
    destruct (i <=? 0) eqn: Hi; [apply Zle_bool_imp_le in Hi; omega|].
    pose proof (Z_mod_lt i 10).
    rewrite <- (Zlength_map _ _ Vint), replace_list_upd_snoc.
    rewrite (zero_ext_inrange 8 (Int.repr (i mod 10))), add_repr.
    rewrite zero_ext_inrange, map_app.
    apply derives_refl.
    { rewrite Int.unsigned_repr; simpl; rep_omega. }
    { rewrite Int.unsigned_repr; simpl; rep_omega. }
    { omega. }
    { rewrite Zlength_map, intr_lt; rep_omega. }
  - forward.
    entailer!.
    (* spec has an off-by-one error *)
    { admit. }
    rewrite replace_list_nil by rep_omega; auto.
  - forward.
    rewrite Z.sub_simpl_r; entailer!.
Admitted.

Lemma chars_of_Z_eq : forall n, chars_of_Z n =
  let n' := n / 10 in
  match n' <=? 0 with true => [Int.repr (n + char0)] | false => chars_of_Z n' ++ [Int.repr (n mod 10 + char0)] end.
Proof.
  intros.
  unfold chars_of_Z at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold chars_of_Z.
  destruct (_ <=? _); reflexivity.
Qed.

Lemma chars_of_Z_intr : forall n,
  chars_of_Z n = if n <=? 0 then [Int.repr (n + char0)] else intr n.
Proof.
  intros.
  destruct (Z.leb_spec n 0).
  { rewrite chars_of_Z_eq; simpl.
    apply Zdiv_le_compat_r with (p := 10) in H; try omega.
    rewrite Zdiv_0_l in H.
    destruct (Z.leb_spec (n / 10) 0); auto; omega. }
  induction n as [? IH] using (well_founded_induction (Zwf.Zwf_well_founded 0)).
  rewrite chars_of_Z_eq, intr_eq.
  destruct (n <=? 0) eqn: Hn; [apply Zle_bool_imp_le in Hn; omega|].
  simpl.
  destruct (n / 10 <=? 0) eqn: Hdiv.
  - apply Zle_bool_imp_le in Hdiv.
    assert (0 <= n / 10).
    { apply Z.div_pos; omega. }
    assert (n / 10 = 0) as Hz by omega.
    rewrite Hz; simpl.
    apply Z.div_small_iff in Hz as [|]; try omega.
    rewrite Zmod_small; auto.
  - apply Z.leb_nle in Hdiv.
    rewrite IH; auto; try omega.
    split; try omega.
    apply Z.div_lt; auto; omega.
Qed.

Lemma intr_length : forall n a, 0 <= a -> n < Z.pow 10 a -> Zlength (intr n) <= a.
Proof.
  induction n using (well_founded_induction (Zwf.Zwf_well_founded 0)); intros.
  rewrite intr_eq.
  destruct (Z.leb_spec n 0); [rewrite Zlength_nil; omega|].
  rewrite Zlength_app.
  assert (Zlength (intr (n / 10)) <= a - 1); [|rewrite Zlength_cons, Zlength_nil; omega].
  assert (0 <= a - 1).
  { destruct (Z.eq_dec a 0); subst; simpl in *; omega. }
  apply H; auto.
  - split; try omega.
    apply Z.div_lt; auto; omega.
  - apply Zmult_lt_reg_r with 10; try omega.
    rewrite (Z.mul_comm (10 ^ _)), <- Z.pow_succ_r by auto.
    unfold Z.succ; rewrite Z.sub_simpl_r.
    eapply Z.le_lt_trans; eauto.
    rewrite Z.mul_comm; apply Z.mul_div_le; omega.
Qed.

Lemma chars_of_Z_length : forall n a, 0 < a -> n < Z.pow 10 a -> Zlength (chars_of_Z n) <= a.
Proof.
  intros.
  rewrite chars_of_Z_intr.
  destruct (Z.leb_spec n 0); [|apply intr_length; omega].
  rewrite Zlength_cons, Zlength_nil; omega.
Qed.

Lemma body_print_int: semax_body Vprog Gprog f_print_int print_int_spec.
Proof.
  start_function.
  forward_call (tarray tuchar 5, gv).
  { split; auto; simpl; computable. }
  Intro buf.
  forward_if (buf <> nullval).
  { if_tac; entailer!. }
  { forward_call 1.
    rep_omega.
    entailer!. }
  { forward.
    entailer!. }
  Intros; rewrite if_false by auto.
  forward_if (PROP ()
    LOCAL (temp _buf buf; gvars gv; temp _i (Vint (Int.repr i));
                 temp _k (Vint (Int.repr (Zlength (chars_of_Z i ++ [Int.repr newline])))))
    SEP (mem_mgr gv; malloc_token Ews (tarray tuchar 5) buf;
            data_at Ews (tarray tuchar 5) (map Vint (chars_of_Z i) ++ Vint (Int.repr newline) ::
              list_repeat (Z.to_nat (4 - Zlength (chars_of_Z i))) Vundef) buf;
            ITREE (write_list (chars_of_Z i ++ [Int.repr newline]);; tr))).
  - Intros.
    forward.
    forward.
    forward.
    entailer!.
  - Intros.
    sep_apply data_at__data_at.
    unfold default_val; simpl.
    assert (Zlength (intr i) <= 4).
    { apply intr_length; try omega.
      apply H. }
    forward_call.
    { rewrite !Zlength_cons, Zlength_nil.
      simpl; repeat (split; auto); rep_omega. }
    forward.
    { entailer!.
      rewrite !Zlength_cons, Zlength_nil; rep_omega. }
    forward.
    entailer!.
    { rewrite Zlength_app, Zlength_cons, Zlength_nil, chars_of_Z_intr.
      destruct (Z.leb_spec i 0); auto; omega. }
    unfold replace_list; simpl.
    rewrite (sublist_list_repeat _ _ 5 Vundef).
    rewrite !Zlength_cons, Zlength_nil, Zlength_map; simpl.
    rewrite upd_Znth_app2.
    rewrite Zlength_map, Zminus_diag, upd_Znth0, sublist_list_repeat; try omega.
    apply derives_refl'.
    f_equal.
    rewrite chars_of_Z_intr.
    destruct (Z.leb_spec i 0); try omega.
    rewrite zero_ext_inrange.
    f_equal; f_equal; f_equal; f_equal.
    rewrite Zlength_list_repeat; try omega.
    { simpl; rewrite Int.unsigned_repr; rep_omega. }
    { rewrite Zlength_list_repeat; omega. }
    { rewrite Zlength_map, Zlength_list_repeat; omega. }
    { rewrite Zlength_map; rep_omega. }
    { rewrite !Zlength_cons, Zlength_nil, Zlength_map; omega. }
  - forward_call (Ews, buf, chars_of_Z i ++ [Int.repr newline],
      5, list_repeat (Z.to_nat (4 - Zlength (chars_of_Z i))) Vundef, tr).
    { rewrite map_app, <- app_assoc; simpl; cancel. }
    forward_call (tarray tuchar 5, buf, gv).
    { rewrite if_false by auto; cancel. }
    forward.
Qed.

Lemma read_sum_eq : forall n lc, read_sum n lc ≈
  if zlt n 1000 then
    let nums := map (fun c => Int.unsigned c - char0) lc in
    b <- for_loop 0 4 (read_sum_inner n nums) ;; if (b : bool) then Ret tt else
    lc' <- read_list 4;; read_sum (n + sum_Z nums) lc'
  else Ret tt.
Proof.
  intros.
  unfold read_sum.
  rewrite unfold_aloop.
  if_tac; [|reflexivity].
  unfold ITree._aloop, id.
  rewrite bind_bind.
  apply eutt_bind; [|reflexivity].
  intros [].
  - rewrite Shallow.bind_ret, unfold_aloop.
    reflexivity.
  - rewrite bind_bind.
    apply eutt_bind; [|reflexivity].
    intro.
    rewrite Shallow.bind_ret; reflexivity.
Qed.

Lemma for_loop_eq : forall i z body,
  for_loop i z body ≈ if i <? z then b <- body i ;; if (b : bool) then Ret true else for_loop (i + 1) z body else Ret false.
Proof.
  intros.
  unfold for_loop.
  rewrite unfold_aloop.
  simple_if_tac; [|reflexivity].
  unfold ITree._aloop, id.
  rewrite bind_bind.
  apply eutt_bind; [|reflexivity].
  intros [].
  - rewrite Shallow.bind_ret, unfold_aloop.
    reflexivity.
  - rewrite Shallow.bind_ret; reflexivity.
Qed.

Lemma sum_Z_app : forall l1 l2, sum_Z (l1 ++ l2) = sum_Z l1 + sum_Z l2.
Proof.
  induction l1; auto; simpl; intros.
  rewrite IHl1; omega.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  replace_SEP 0 (ITREE main_itree).
  { go_lower; apply has_ext_ITREE. }
  forward.
  rewrite <- (emp_sepcon (ITREE main_itree)); Intros.
  replace_SEP 0 (mem_mgr gv).
  { go_lower; apply create_mem_mgr. }
  forward_call (tarray tuchar 4, gv).
  { simpl; repeat (split; auto); rep_omega. }
  Intro buf.
  forward_if (buf <> nullval).
  { if_tac; entailer!. }
  { forward_call 1.
    rep_omega.
    entailer!. }
  { forward.
    entailer!. }
  Intros; rewrite if_false by auto.
  unfold main_itree.
  forward_call (Ews, buf, 4, fun lc => read_sum 0 lc).
  { simpl; cancel. }
  Intros lc.
  set (Inv := EX n : Z, EX lc : list int,
    PROP (0 <= n < 1040; Forall (fun i => Int.unsigned i <= Byte.max_unsigned) lc)
    LOCAL (temp _i (Vint (Int.repr 4)); temp _buf buf; temp _n (Vint (Int.repr n)); gvars gv)
    SEP (ITREE (read_sum n lc); data_at Ews (tarray tuchar 4) (map Vint lc) buf;
      mem_mgr gv; malloc_token Ews (tarray tuchar 4) buf)).
  forward_while Inv.
  { Exists 0 lc; entailer!. }
  { entailer!. }
  - clear dependent lc; rename lc0 into lc.
    erewrite ITREE_ext by apply read_sum_eq.
    rewrite if_true by auto; simpl ITREE.
    set (nums := map (fun i => Int.unsigned i - char0) lc).
    assert_PROP (Zlength lc = 4).
    { entailer!.
      rewrite Zlength_map in *; auto. }
    assert (Zlength nums = 4) by (subst nums; rewrite Zlength_map; auto).
    forward_for_simple_bound 4 (EX j : Z, PROP (0 <= n + sum_Z (sublist 0 j nums) < 1000 + 10 * j)
     LOCAL (temp _i (Vint (Int.repr 4)); temp _buf buf; temp _n (Vint (Int.repr (n + sum_Z (sublist 0 j nums)))); gvars gv)
     SEP (ITREE (b <- for_loop j 4
         (read_sum_inner n nums) ;; if (b : bool) then Ret tt else lc' <- read_list 4 ;; read_sum (n + sum_Z nums) lc');
             data_at Ews (tarray tuchar 4) (map Vint lc) buf; mem_mgr gv; malloc_token Ews (tarray tuchar 4) buf)).
    + entailer!.
      { omega. }
    + simpl.
      forward.
      { entailer!.
        rewrite zero_ext_inrange by (apply Forall_Znth; auto; omega).
        apply Forall_Znth; auto; omega. }
      forward.
      rewrite zero_ext_inrange by (apply Forall_Znth; auto; omega).
      forward_if (0 <= Int.unsigned (Znth i lc) - char0 < 10).
      { forward_call (tarray tuchar 4, buf, gv).
        { rewrite if_false by auto; cancel. }
        forward.
        entailer!.
        apply ITREE_impl.
        rewrite for_loop_eq.
        destruct (Z.ltb_spec i 4); try omega.
        unfold read_sum_inner at 2.
        replace (_ || _)%bool with true.
        rewrite !Shallow.bind_ret; reflexivity.
        symmetry; rewrite orb_true_iff.
        rewrite Int.unsigned_sub_borrow in *.
        unfold Int.sub_borrow in *.
        subst nums; rewrite Znth_map by omega.
        rewrite (Int.unsigned_repr 48), Int.unsigned_zero, Z.sub_0_r in * by rep_omega.
        destruct (zlt _ _); [right; apply Z.ltb_lt | left; apply Z.leb_le]; auto.
        rewrite Int.unsigned_zero in *; simpl in *.
        unfold char0; omega. }
      { forward.
        entailer!.
        unfold Int.sub in *.
        rewrite Int.unsigned_repr_eq, Int.unsigned_repr in * by computable.
        pose proof (Int.unsigned_range (Znth i lc)).
        destruct (zlt (Int.unsigned (Znth i lc)) char0).
        { unfold char0 in *; rewrite <- Z_mod_plus_full with (b := 1), Zmod_small in *; rep_omega. }
        unfold char0 in *; rewrite Zmod_small in *; omega. }
      unfold Int.sub.
      rewrite Int.unsigned_repr by computable.
      forward.
      rewrite add_repr.
      erewrite ITREE_ext by (rewrite for_loop_eq; reflexivity).
      destruct (Z.ltb_spec i 4); try omega.
      unfold read_sum_inner at 2.
      unfold nums; rewrite Znth_map by omega.
      assert (((10 <=? Int.unsigned (Znth i lc) - char0) || (Int.unsigned (Znth i lc) - char0 <? 0))%bool = false) as Hin.
      { rewrite orb_false_iff.
        split; [apply Z.leb_nle | apply Z.ltb_nlt]; omega. }
      rewrite Hin.
      assert (sublist 0 (i + 1) nums = sublist 0 i nums ++ [Int.unsigned (Znth i lc) - char0]) as Hi.
      { rewrite (sublist_split _ i (i + 1)), (sublist_one i (i + 1)) by omega.
        f_equal; subst nums.
        rewrite Znth_map by omega; auto. }
      forward_call (gv, n + sum_Z (sublist 0 (i + 1) nums),
        b <- for_loop (i + 1) 4 (read_sum_inner n nums) ;; if (b : bool) then Ret tt else lc' <- read_list 4 ;; read_sum (n + sum_Z nums) lc').
      { entailer!.
        rewrite Hi, sum_Z_app; simpl.
        rewrite Z.add_assoc, Z.add_0_r; auto. }
      { rewrite sepcon_assoc; apply sepcon_derives; cancel.
        apply ITREE_impl; rewrite !bind_bind.
        apply eutt_bind; [|reflexivity].
        intros [].
        rewrite Shallow.bind_ret; reflexivity. }
      { rewrite Hi, sum_Z_app; simpl; omega. }
      entailer!.
      { rewrite Hi, sum_Z_app; simpl.
        rewrite Z.add_0_r, Z.add_assoc; split; auto; omega. }
    + erewrite ITREE_ext by (rewrite for_loop_eq; reflexivity).
      destruct (Z.ltb_spec 4 4); try omega.
      forward_call (Ews, buf, 4, fun lc' => read_sum (n + sum_Z nums) lc').
      { rewrite sepcon_assoc; apply sepcon_derives; cancel.
        apply ITREE_impl.
        simpl; rewrite Shallow.bind_ret; reflexivity. }
      Intros lc'.
      forward.
      rewrite sublist_same in * by auto.
      Exists (n + sum_Z nums, lc'); entailer!.
      apply derives_refl.
  - subst Inv.
    forward_call (tarray tuchar 4, buf, gv).
    { rewrite if_false by auto; cancel. }
    forward.
    cancel; apply ITREE_impl.
    rewrite read_sum_eq.
    rewrite if_false; [reflexivity | omega].
Qed.

Definition ext_link := ext_link_prog prog.

Instance Espec : OracleKind := IO_Espec ext_link.

Lemma prog_correct:
  semax_prog_ext prog main_itree Vprog Gprog.
Proof.
prove_semax_prog.
(*semax_func_cons_ext.
{ simpl; Intro i.
  apply typecheck_return_value; auto. }
semax_func_cons_ext.
semax_func_cons body_print_intr.
semax_func_cons body_print_int.
semax_func_cons body_main.
Qed.*)
Admitted.

Require Import VST.veric.SequentialClight.
Require Import VST.progs.io_mem_dry.

Definition init_mem_exists : { m | Genv.init_mem prog = Some m }.
Proof.
  unfold Genv.init_mem; simpl.
Admitted. (* seems true, but hard to prove -- can we compute it? *)

Definition init_mem := proj1_sig init_mem_exists.

Definition main_block_exists : {b | Genv.find_symbol (Genv.globalenv prog) (prog_main prog) = Some b}.
Proof.
  eexists; simpl.
  unfold Genv.find_symbol; simpl; reflexivity.
Qed.

Definition main_block := proj1_sig main_block_exists.

Theorem prog_toplevel : exists q : Clight_new.corestate,
  semantics.initial_core (Clight_new.cl_core_sem (globalenv prog)) 0 init_mem q init_mem (Vptr main_block Ptrofs.zero) [] /\
  forall n, @step_lemmas.dry_safeN _ _ _ _ Clight_sim.genv_symb_injective (Clight_sim.coresem_extract_cenv (Clight_new.cl_core_sem (globalenv prog)) (prog_comp_env prog))
             (io_dry_spec ext_link) {| Clight_sim.CC.genv_genv := Genv.globalenv prog; Clight_sim.CC.genv_cenv := prog_comp_env prog |} n
            main_itree q init_mem.
Proof.
  edestruct whole_program_sequential_safety_ext with (V := Vprog) as (b & q & m' & Hb & Hq & Hsafe).
  - apply juicy_dry_specs.
  - apply dry_spec_mem.
  - apply CSHL_Sound.semax_prog_ext_sound, prog_correct.
  - apply (proj2_sig init_mem_exists).
  - exists q.
    rewrite (proj2_sig main_block_exists) in Hb; inv Hb.
    assert (m' = init_mem); [|subst; auto].
    destruct Hq; tauto.
Qed.


Require Import List.
Import ListNotations.

Require Import Chord.Chord.

Require Import Chord.SystemReachable.

Definition has_first_succ (gst : global_state) (h : addr) (s : pointer) : Prop :=
  exists st,
    sigma gst h = Some st /\
    hd_error (succ_list st) = Some s.

Lemma has_first_succ_intro :
  forall gst h s st,
    sigma gst h = Some st ->
    hd_error (succ_list st) = Some s ->
    has_first_succ gst h s.
Proof.
  intros.
  eexists; eauto.
Qed.

Theorem first_succ_never_self :
  forall gst h s,
    reachable_st gst ->
    has_first_succ gst h s ->
    h <> (addr_of s).
Proof.
(*
Easy consequence of the (difficult) Zave invariant.

DIFFCULTY: 1
USED: In phase two.
*)
Admitted.


From ch2o_compcert Require Export return_divs_ch2o_safe return_divs_csyntaxgen_simplified ch2o_compcertc_lp64 compcertc_compiler.

Lemma return_divs_compcertc_safe: compcertc_safe_program (λ z, z = 2) prog.
Proof.
apply soundness with (2:=return_divs_ch2o_safe).
econstructor.
- apply δ_main.
- apply init_mem_ok.
  reflexivity.
- reflexivity.
- reflexivity.
- constructor.
  constructor.
  + constructor.
    * constructor.
      constructor; (unfold int_lower || unfold int_upper); simpl; lia.
    * constructor.
      constructor; (unfold int_lower || unfold int_upper); simpl; lia.
  + constructor.
    * constructor.
      constructor; (unfold int_lower || unfold int_upper); simpl; lia.
    * constructor.
      constructor; (unfold int_lower || unfold int_upper); simpl; lia.
Qed.

Theorem return_divs_asm_safe tp:
  transf_c_program prog = OK tp →
  asm_program_satisfies_spec tp (satisfies_postcondition (λ z, z = 2)).
Proof.
intros.
apply transf_c_program_safe with (1:=H).
apply return_divs_compcertc_safe.
Qed.