(** * Geometric (i.i.d.) tcwp semantics. *)

Set Implicit Arguments.

Require Import Basics.
Local Open Scope program_scope.

From zar Require Import
  cpGCL
  cpo
  cwp
  geometric_series
  misc
  eR
  tactics
  tcwp
  tcwp_facts
  tree
.

Local Open Scope order_scope.

Lemma loop_approx''_twp_fix_approx''' {I A}
  (st : I) (e : I -> bool) (g : I -> tree I) (k : I -> tree A) (n : nat) f :
  loop_approx'' e (fun f0 s => twp_ false (g s) f0)
    (fun s => twp_ false (k s) f) n st =
    twp (fix_approx''' st e g (fun s => if e s then Fail _ else k s) n) f.
Proof.
  unfold twp; revert st e g k f; induction n; intros st e g k f; simpl.
  { unfold loop_approx''; simpl; destr; auto. }
  unfold loop_approx'', loop_F; simpl.
  destruct (e st) eqn:Hest; simpl; auto.
  rewrite twp__tree_bind; f_equal; ext s; apply IHn.
Qed.

Lemma loop_approx''_false {A} e g f n (s : A) :
  e s = false ->
  loop_approx'' e g f n s = f s.
Proof.
  unfold loop_approx''.
  intro Hes; destruct n; simpl.
  - rewrite Hes; reflexivity.
  - unfold loop_F. rewrite Hes; reflexivity.
Qed.

Lemma g_loop_approx'_loop_approx'' {A} (e : A -> bool) g f n s :
  e s = true ->
  g (const 0) = const 0 ->
  g (loop_approx' e g f n) s = loop_approx'' e g f n s.
Proof.
  unfold shift, loop_approx', loop_approx'', const.
  revert e g f s; induction n; intros e g f s Hes Hg; simpl.
  { rewrite Hg, Hes; reflexivity. }
  unfold loop_F; simpl.
  rewrite Hes.
  f_equal.
  ext st.
  destruct (e st) eqn:Hest; simpl.
  - apply IHn; auto.
  - symmetry; apply loop_approx''_false; auto.
Qed.

Lemma shift_loop_approx'_loop_approx'' {A} (e : A -> bool) g f  :
  g (const 0) = const 0 ->
  shift (loop_approx' e g f) = loop_approx'' e g f.
Proof.
  intro Hg.
  unfold shift, loop_approx', loop_approx'', const.
  simpl; unfold loop_F.
  ext i. ext s.
  destruct (e s) eqn:Hes.
  - apply g_loop_approx'_loop_approx''; auto.
  - symmetry; apply loop_approx''_false; auto.
Qed.

Lemma twp_fix_chain_scalar {I} G (st : I) a t i :
  G st = true ->
  twp (fix_chain st G (fun _ => t) i) (fun s => if G s then a else 0) =
    a *  twp t (fun s : I => if G s then 1 else 0) ^ i.
Proof.
  unfold twp; revert G st a t; induction i; intros G st a t HGst; simpl.
  { rewrite HGst; eRauto. }
  rewrite twp__tree_bind.
  replace (fun s : I => twp_ false (if G s then t else Leaf s)
                       (fun s0 : I => if G s0 then a else 0)) with
    (fun s : I => if G s then twp t (fun s0 : I => if G s0 then a else 0)
               else 0).
  2: { ext s; destruct (G s) eqn:HGs; simpl; auto.
       rewrite HGs; reflexivity. }
  rewrite eRmult_comm.
  rewrite eRmult_assoc.
  rewrite (@eRmult_comm _ a).
  erewrite <- IHi; eauto; clear IHi.
  replace (fun s : I => if G s then a else 0) with
    (fun s : I => a * (if G s then 1 else 0)).
  2: { ext s; destr; eRauto. }
  rewrite 3!fold_twp.
  rewrite <- twp_scalar; unfold twp.
  f_equal; ext s; destr.
  - eRauto; rewrite eRmult_comm; apply twp_scalar.
  - eRauto.
Qed.

Lemma twp_fix_chain_geometric_series {I} (st : I) G t i f :
  G st = true ->
  twp_ false (fix_chain st G (fun _ => t) i) (fun s => if G s then 0 else f s) =
    geometric_series (twp t (fun s => if G s then 0 else f s))
      (twp t (fun s : I => if G s then 1 else 0)) i.
Proof.
  unfold twp; revert st G t f; induction i; intros st G t f HGst; simpl.
  { rewrite HGst; reflexivity. }
  rewrite twp__tree_bind.
  erewrite <- IHi; eauto; clear IHi.
  replace (fun s : I => twp_ false (if G s then t else Leaf s)
                       (fun s0 : I => if G s0 then 0 else f s0)) with
    (fun s => if G s then twp t (fun s0 : I => if G s0 then 0 else f s0) else f s).
  2: { ext s; destruct (G s) eqn:HGs; simpl; auto; rewrite HGs; reflexivity. }
  replace (fun s => if G s then twp t (fun s0 => if G s0 then 0 else f s0) else f s)
    with (fun s => (if G s then twp t (fun s0 => if G s0 then 0 else f s0) else 0) +
                  (if G s then 0 else f s)).
  2: { ext s; destr; eRauto. }
  rewrite 4!fold_twp.
  rewrite twp_plus.
  unfold twp.
  rewrite eRplus_comm; f_equal.
  rewrite 3!fold_twp.
  rewrite twp_fix_chain_scalar; auto.
Qed.

Lemma twp_fix_iid {A B} (st : A) (G : A -> bool) (t : tree A) (k : A -> tree B) f :
  wf_tree t ->
  (forall s, wf_tree (k s)) ->
  twp t (fun s => if G s then 1 else 0) < 1 ->
  G st = true ->
  twp (Fix st G (fun _ => t) k) f = twp t (fun s => if G s then 0 else twp (k s) f) /
                                   (1 - twp t (fun s => if G s then 1 else 0)).
Proof.
  intros Ht Hk Hlt HGst.
  unfold twp.
  simpl.
  unfold iter.
  rewrite sup_apply_eR.
  rewrite <- geometric_series_sup; eRauto.
  apply sup_shift_eR.
  { apply chain_iter_n''; eauto with twp order; intro; eRauto. }
  f_equal; ext i.
  rewrite <- loop_approx_iter_n_loop_F.
  rewrite loop_approx_loop_approx'.
  replace (shift
             (fun i0 : nat =>
                loop_approx' G (fun (f0 : A -> eR) (s : A) => twp_ false t f0)
                  (fun s : A => twp_ false (k s) f) i0 st) i) with
    (loop_approx'' G (fun (f0 : A -> eR) (s : A) => twp_ false t f0)
       (fun s : A => twp_ false (k s) f) i st).
  2: { rewrite <- shift_loop_approx'_loop_approx''.
       - reflexivity.
       - ext s; apply twp_strict. }
  rewrite loop_approx''_twp_fix_approx'''.
  rewrite fix_approx'''_tree_bind_fix_approx.
  rewrite twp_tree_bind.
  replace (fun s : A => twp (if G s then Fail _ else k s) f) with
    (fun s => if G s then 0 else twp (k s) f).
  2: { ext s; destr; reflexivity. }
  unfold twp.
  rewrite fix_approx_fix_chain.
  rewrite twp_fix_chain_geometric_series; auto.
Qed.


From Coq Require Import omega.Omega.
From Coq Require Import Arith.Arith.
From LF Require Import Imp Maps.

Open Scope imp_scope.
Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
    | SKIP =>
        st
    | l ::= a1 =>
        (l !-> aeval st a1 ; st)
    | c1 ;; c2 =>
        let st' := ceval_step1 st c1 in
        ceval_step1 st' c2
    | TEST b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_step1 st c1
          else ceval_step1 st c2
    | WHILE b1 DO c1 END =>
        st  (* bogus *)
  end.
Close Scope imp_scope.

Open Scope imp_scope.
Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => empty_st
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          (l !-> aeval st a1 ; st)
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | TEST b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.
Close Scope imp_scope.

Open Scope imp_scope.
Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (l !-> aeval st a1 ; st)
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | TEST b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.
Close Scope imp_scope.

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Open Scope imp_scope.
Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with

  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (l !-> aeval st a1 ; st)
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | TEST b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.
Close Scope imp_scope.

(* FIXME: wrong type inference with st Z...
Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None    => None
  | Some st => Some (st X, st Y, st Z)
  end.

( Compute
     (test_ceval empty_st
         (X ::= 2;;
          TEST (X <= 1)
            THEN Y ::= 3
            ELSE Z ::= 4
          FI)).
   ====>
      Some (2, 0, 4)
*)

Definition pup_to_n : com
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
(*

Example pup_to_n_1 :
  test_ceval (X !-> 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.
*)

(* Relational vs. Step-Indexed Evaluation *)

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      st =[ c ]=> st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].
  - (* i = 0 -- contradictory *)
    intros c st st' H. discriminate H.
  - (* i = S i' *)
    intros c st st' H.
    destruct c;
           simpl in H; inversion H; subst; clear H.
      + (* SKIP *) apply E_Skip.
      + (* ::= *) apply E_Ass. reflexivity.
      + (* ;; *)
        destruct (ceval_step st c1 i') eqn:Heqr1.
        * (* Evaluation of r1 terminates normally *)
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        * (* Otherwise -- contradiction *)
          discriminate H1.
      + (* TEST *)
        destruct (beval st b) eqn:Heqr.
        * (* r = true *)
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        * (* r = false *)
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
      + (* WHILE *) destruct (beval st b) eqn :Heqr.
        * (* r = true *)
         destruct (ceval_step st c i') eqn:Heqr1.
         { (* r1 = Some s *)
           apply E_WhileTrue with s. rewrite Heqr.
           reflexivity.
           apply IHi'. rewrite Heqr1. reflexivity.
           apply IHi'. simpl in H1. assumption. }
         { (* r1 = None *) discriminate H1. }
        * (* r = false *)
          injection H1. intros H2. rewrite <- H2.
          apply E_WhileFalse. apply Heqr. Qed.

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  - (* i1 = 0 *)
    simpl in Hceval. discriminate Hceval.
  - (* i1 = S i1' *)
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' <= i2') by omega.
    destruct c.
    + (* SKIP *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ::= *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ;; *)
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* st1'o = None *)
        discriminate Hceval.
    + (* TEST *)
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval;
        assumption.
    + (* WHILE *)
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* i1'o = None *)
        simpl in Hceval. discriminate Hceval. Qed.

Theorem ceval__ceval_step: forall c st st',
      st =[ c ]=> st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  (* FILL IN HERE *)
  - exists 1. reflexivity.
  - exists 1. subst. reflexivity.
  - destruct IHHce1 as [i1 H1].
    destruct IHHce2 as [i2 H2].
    exists (1 + i1 + i2).
    simpl.
    destruct (ceval_step st c1 (i1 + i2)) eqn: Heqn.
    + assert (st' = s).
      {
        apply (ceval_step_more i1 (i1 + i2)) in H1.
        rewrite H1 in Heqn.
        inversion Heqn.
        auto.
        omega.
      }
      subst s.
      apply (ceval_step_more i2 (i1 + i2)). omega. apply H2.
    + apply (ceval_step_more i1 (i1 + i2)) in H1. rewrite H1 in Heqn. discriminate. omega.
  - inversion IHHce as [i H'].
       exists (1 + i). simpl. rewrite H. apply H'.
  - destruct IHHce as [i H'].
    exists (1 + i). simpl. rewrite H. apply H'.
  -  exists 1. simpl. rewrite H. reflexivity.
  - destruct IHHce1 as [i1 H1].
    destruct IHHce2 as [i2 H2].
    exists (1 + i1 + i2).
    simpl. rewrite H.
    destruct (ceval_step st c (i1 + i2)) eqn: Heqn.
      + assert (st' = s).
        {
          apply (ceval_step_more i1 (i1 + i2)) in H1.
          rewrite H1 in Heqn.
          inversion Heqn.
          auto.
          omega.
         }
        subst s.
        apply (ceval_step_more i2 (i1 + i2)).
        omega.
        assumption.
      + apply (ceval_step_more i1 (i1 + i2)) in H1.
        * rewrite H1 in Heqn. discriminate Heqn.
        * omega.
Qed.

Theorem ceval_and_ceval_step_coincide: forall c st st',
  st =[ c ]=> st' <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

(* Determinism of Evaluation Again *)

Theorem ceval_deterministic': forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> st2 ->
  st1 = st2.
Proof.
  intros.
  apply ceval_and_ceval_step_coincide in H.
  apply ceval_and_ceval_step_coincide in H0.
  destruct H as [i1 H1].
  destruct H0 as [i2 H2].
  apply (ceval_step_more i1 (i1 + i2)) in H1.
  apply (ceval_step_more i2 (i1 + i2)) in H2.
  rewrite H1 in H2.
  inversion H2.
  auto. omega. omega.
Qed.


Require Import Coq.Program.Equality.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Arith.EqNat.
Require Import Ascii.

Add LoadPath "." as Top0.
Require Import Top0.Keys.

Definition empty_set `{T: Type} := Empty_set T.
Definition singleton_set `{T: Type} (e: T) := Singleton T e.
Definition set_union `{T: Type} (s1 s2: Ensemble T) := Union T s1 s2.
Definition set_elem `{T: Type} (s: Ensemble T) (e: T) := Ensembles.In T s e.
Definition not_set_elem `{T: Type} (s: Ensemble T) (e: T) := Ensembles.Complement T s e.
Definition included `{T: Type} (s1 s2: Ensemble T) := Ensembles.Included T s1 s2.
Definition set_minus `{T: Type} (s: Ensemble T) (e: T)  := Ensembles.Subtract T s e.

(* Static Labels *)
Definition Region :=  nat.

(* Program Variables *)
Definition Name := ascii.

Inductive rgn2 : bool * bool * bool -> Set :=
  | Rgn2_Const : forall fv bv, Region -> rgn2 (true, fv, bv)
  | Rgn2_FVar : forall c bv, Name -> rgn2 (c, true, bv)
  | Rgn2_BVar : forall c fv, nat -> rgn2 (c, fv, true).
Definition rgn2_in_exp := rgn2 (true, true, false).
Definition rgn2_in_typ := rgn2 (true, true, true).

Definition mk_rgn_type (u: rgn2_in_exp) : rgn2_in_typ
 := match u with
      | Rgn2_Const fv bv n => Rgn2_Const true true n
      | Rgn2_FVar c bv n => Rgn2_FVar true true n
      | Rgn2_BVar c fv n => Rgn2_BVar true true n
    end.

(* Static Actions; for type-and-effect system *)
Inductive StaticAction2 : Set :=
| SA2_Alloc : rgn2_in_typ -> StaticAction2
| SA2_Read  : rgn2_in_typ -> StaticAction2
| SA2_Write : rgn2_in_typ -> StaticAction2.

Definition Epsilon2 := Ensemble StaticAction2.

(* substitute for type *)
Inductive type2 :=
  | Ty2_Natural : type2
  | Ty2_Boolean : type2
  | Ty2_Effect  : type2
  | Ty2_Unit    : type2
  | Ty2_Pair    : type2 -> type2 -> type2
  | Ty2_Ref     : rgn2_in_typ -> type2 -> type2
  | Ty2_Arrow   : type2 -> Epsilon2 -> type2 -> Epsilon2 -> type2 -> type2
  | Ty2_ForallRgn : Epsilon2 -> type2 -> type2.

(** begin of openings **)
Definition opening_rgn_in_rgn2 (k : nat) (u: rgn2_in_typ) (t: rgn2_in_typ) : rgn2_in_typ
 := match t with
    | Rgn2_Const _ _ _ => t
    | Rgn2_FVar _ _ _ => t
    | Rgn2_BVar _ _ n => if (beq_nat n k) then u else t
    end.

Definition opening_rgn_in_sa2 (k : nat) (u: rgn2_in_typ) (sa: StaticAction2) : StaticAction2 :=
  match sa with
  | SA2_Alloc rgn => SA2_Alloc (opening_rgn_in_rgn2 k u rgn)
  | SA2_Read rgn  => SA2_Read (opening_rgn_in_rgn2 k u rgn)
  | SA2_Write rgn => SA2_Write (opening_rgn_in_rgn2 k u rgn)
  end.

Definition opening_rgn_in_eps2 (k : nat) (u: rgn2_in_typ) (eps: Epsilon2) : Epsilon2 :=
  fun sa => exists sa', eps sa' /\ opening_rgn_in_sa2 k u sa' = sa.

Fixpoint opening_rgn_exp (k: nat) (u: rgn2_in_typ) (t: type2) {struct t} : type2 :=
  match t with
  | Ty2_Natural => t
  | Ty2_Boolean => t
  | Ty2_Effect  => t
  | Ty2_Unit    => t
  | Ty2_Pair ty1 ty2  =>  Ty2_Pair (opening_rgn_exp k u ty1)  (opening_rgn_exp k u ty2)
  | Ty2_Ref rgn ty => Ty2_Ref (opening_rgn_in_rgn2 k u rgn) (opening_rgn_exp k u ty)
  | Ty2_Arrow aty ceff crty eeff erty => Ty2_Arrow (opening_rgn_exp k u aty)
                                                   (opening_rgn_in_eps2 k u ceff) (opening_rgn_exp k u crty)
                                                   (opening_rgn_in_eps2 k u eeff) (opening_rgn_exp k u erty)
  | Ty2_ForallRgn eff rty => Ty2_ForallRgn (opening_rgn_in_eps2 (S k) u eff) (opening_rgn_exp (S k) u rty)
  end.

Definition open_rgn_eff (u: rgn2_in_typ)  (eps: Epsilon2) : Epsilon2 := opening_rgn_in_eps2 0 u eps.
Definition open (u: rgn2_in_typ)  (t: type2) : type2 := opening_rgn_exp 0 u t.
Definition open_var (t : type2) (x : Name) : type2 :=
  let rgn_fvar := Rgn2_FVar true true x
  in opening_rgn_exp 0 (rgn_fvar) t.

(** end of openings **)

(** begin of substitutions **)
Definition subst_rgn  (z : Name) (u : rgn2_in_exp) (t: rgn2_in_typ) : rgn2_in_typ :=
  match t with
    | Rgn2_Const _ _ r => t
    | Rgn2_FVar _ _ r  => if (AsciiVars.eq_dec z r) then mk_rgn_type u else t
    | Rgn2_BVar _ _ _  => t
  end.

Definition subst_sa (z : Name) (u : rgn2_in_exp) (t: StaticAction2) : StaticAction2 :=
 match t with
  | SA2_Alloc rgn => SA2_Alloc (subst_rgn z u rgn)
  | SA2_Read rgn  => SA2_Read  (subst_rgn z u rgn)
  | SA2_Write rgn => SA2_Write (subst_rgn z u rgn)
 end.

Definition subst_eps  (z : Name) (u : rgn2_in_exp) (t: Epsilon2) : Epsilon2 :=
   fun sa => exists sa', t sa' /\ subst_sa z u sa' = sa.

Reserved Notation "'[' x ':=' u ']' t" (at level 20).
Fixpoint subst_type (z : Name) (u : rgn2_in_exp) (t : type2) {struct t} : type2 :=
  match t with
    | Ty2_Natural => Ty2_Natural
    | Ty2_Boolean => Ty2_Boolean
    | Ty2_Effect  => Ty2_Effect
    | Ty2_Unit    => Ty2_Unit
    | Ty2_Pair t1 t2  => Ty2_Pair (subst_type z u t1) (subst_type z u t2)
    | Ty2_Ref r t => Ty2_Ref (subst_rgn z u r) (subst_type z u t)
    | Ty2_Arrow aty ceff crty eeff erty => Ty2_Arrow (subst_type z u aty) (subst_eps z u ceff) (subst_type z u crty)
                                                     (subst_eps z u eeff) (subst_type z u erty)
    | Ty2_ForallRgn eff rty => Ty2_ForallRgn (subst_eps z u eff) (subst_type z u rty)
  end
where "'[' x ':=' u ']' t" := (subst_type x u t).

(** end of substitutions **)

(** begin of free regions **)
Definition free_rgn_vars_in_rgn2 (rgn: rgn2_in_typ) : Ensemble Name :=
  match rgn with
  | Rgn2_Const _ _ _ => empty_set
  | Rgn2_FVar _ _ n => singleton_set n
  | Rgn2_BVar _ _ _ => empty_set
  end.

Definition free_region (rgn: rgn2_in_typ) : Ensemble Name := free_rgn_vars_in_rgn2 rgn.

Definition free_rgn_vars_in_sa2 (sa: StaticAction2) : Ensemble Name :=
  match sa with
  | SA2_Alloc rgn => free_rgn_vars_in_rgn2 rgn
  | SA2_Read rgn => free_rgn_vars_in_rgn2 rgn
  | SA2_Write rgn => free_rgn_vars_in_rgn2 rgn
  end.

(*
Definition free_rgn_vars_in_eps2 (eps: Epsilon2) : Ensemble Name :=
  fun n => exists sa,
             ~ eps = Empty_set StaticAction2 /\
             (eps sa -> (free_rgn_vars_in_sa2 sa) n).
*)

Definition free_rgn_vars_in_eps2 (eps: Epsilon2) : Ensemble Name :=
  fun n => exists (sa : StaticAction2),
             eps sa /\ (free_rgn_vars_in_sa2 sa) n.

Fixpoint frv (t: type2) : Ensemble Name :=
  match t with
  | Ty2_Natural    => empty_set
  | Ty2_Boolean    => empty_set
  | Ty2_Effect     => empty_set
  | Ty2_Unit       => empty_set
  | Ty2_Pair t1 t2 => set_union (frv t1) (frv t2)
  | Ty2_Ref rgn ty => set_union (free_rgn_vars_in_rgn2 rgn) (frv ty)
  | Ty2_Arrow aty ceff crty eeff erty =>
                      set_union (frv aty)
                                (set_union (set_union (free_rgn_vars_in_eps2 ceff)
                                                      (free_rgn_vars_in_eps2 eeff))
                                           (set_union (frv crty)
                                                      (frv erty)))
  | Ty2_ForallRgn eff rty => set_union (free_rgn_vars_in_eps2 eff)
                                       (frv rty)
  end.

Fixpoint not_set_elem_frv (t: type2) x : Prop :=
  match t with
    | Ty2_Natural    => True
    | Ty2_Boolean    => True
    | Ty2_Effect     => True
    | Ty2_Unit       => True
    | Ty2_Pair t1 t2 => (not_set_elem (frv t1) x) /\ (not_set_elem (frv t2) x)
    | Ty2_Ref rgn ty => (not_set_elem (free_rgn_vars_in_rgn2 rgn) x) /\
                        (not_set_elem (frv ty) x)
    | Ty2_Arrow aty ceff crty eeff erty
      => (not_set_elem (frv aty) x) /\
         (not_set_elem (free_rgn_vars_in_eps2 ceff) x) /\
         (not_set_elem (free_rgn_vars_in_eps2 eeff) x) /\
         (not_set_elem (frv crty) x) /\
         (not_set_elem (frv erty) x)
    | Ty2_ForallRgn eff rty => (not_set_elem (free_rgn_vars_in_eps2 eff) x) /\
                               (not_set_elem (frv rty) x)
  end.

Notation "x '#' t" := (not_set_elem (frv t) x) (at level 60).

Lemma ClosedType :
 forall t x,
   frv t = empty_set ->
   x # t.
Proof.
  intros.
  unfold not_set_elem, Complement.
  rewrite H.
  intuition.
  contradiction.
Qed.

Lemma FreeVariables1 :
 forall x t, x # t ->  not_set_elem_frv t x .
Proof.
 intro x. induction t; intro; unfold not_set_elem, Complement in *; simpl in *; auto;
 split; unfold not_set_elem, Complement in *; intuition.
Qed.

Lemma FreeVariables2 :
 forall x t,  not_set_elem_frv t x -> x # t.
Proof.
 intro x. induction t; intro; unfold not_set_elem, Complement in *; simpl in *; auto.
 - intro. contradict H0.
 - intro. contradict H0.
 - intro. contradict H0.
 - intro. contradict H0.
 - destruct H; unfold not_set_elem, Complement in *; simpl in *; auto.
   intuition.
   destruct H1; intuition.
 - destruct H; unfold not_set_elem, Complement in *; simpl in *; auto.
   intuition.
   destruct H1; intuition.
 - destruct H; unfold not_set_elem, Complement in *; simpl in *; auto.
   intuition.
   destruct H1; [apply H; auto |].
   do 2 destruct H1; [apply H2 | apply H0 | apply H3 | apply H5]; auto.
 - destruct H; unfold not_set_elem, Complement in *; simpl in *; auto.
   intuition.
   destruct H1; intuition.
Qed.

 (** end of free regions **)

(** begin of closings **)
Definition closing_rgn_in_rgn2 (k : nat) (x: Name) (t: rgn2_in_typ) : rgn2_in_typ
 := match t with
    | Rgn2_Const _ _ _ => t
    | Rgn2_FVar _ _ n  => if AsciiVars.eq_dec n x then (Rgn2_BVar true true k) else t
    | Rgn2_BVar _ _ _  => t
    end.

Definition closing_rgn_in_sa2 (k : nat) (x: Name) (sa: StaticAction2) : StaticAction2 :=
  match sa with
  | SA2_Alloc rgn => SA2_Alloc (closing_rgn_in_rgn2 k x rgn)
  | SA2_Read rgn  => SA2_Read (closing_rgn_in_rgn2 k x rgn)
  | SA2_Write rgn => SA2_Write (closing_rgn_in_rgn2 k x rgn)
  end.

Definition closing_rgn_in_eps2 (k : nat) (x: Name) (eps: Epsilon2) : Epsilon2 :=
  fun sa => exists sa', eps sa' /\ closing_rgn_in_sa2 k x sa' = sa.

Fixpoint closing_rgn_exp (k: nat) (x: Name) (t: type2) {struct t} : type2 :=
  match t with
  | Ty2_Natural => t
  | Ty2_Boolean => t
  | Ty2_Effect  => t
  | Ty2_Unit    => t
  | Ty2_Pair t1 t2 => Ty2_Pair  (closing_rgn_exp k x t1) (closing_rgn_exp k x t2)
  | Ty2_Ref rgn ty => Ty2_Ref (closing_rgn_in_rgn2 k x rgn) (closing_rgn_exp k x ty)
  | Ty2_Arrow aty ceff crty eeff erty => Ty2_Arrow (closing_rgn_exp k x aty)
                                                   (closing_rgn_in_eps2 k x ceff) (closing_rgn_exp k x crty)
                                                   (closing_rgn_in_eps2 k x eeff) (closing_rgn_exp k x erty)
  | Ty2_ForallRgn eff rty => Ty2_ForallRgn (closing_rgn_in_eps2 (S k) x eff) (closing_rgn_exp (S k) x rty)
  end.

Definition close_var (x : Name) (t : type2) := closing_rgn_exp 0 x t.
Definition close_var_eff (x : Name) (eps : Epsilon2) := closing_rgn_in_eps2 0 x eps.
(** end of closings **)

(** locally closed **)
Inductive lc_type_rgn : rgn2_in_typ -> Prop :=
     | lc_rgn_const : forall r, lc_type_rgn (Rgn2_Const true true r)
     | lc_rgn_fvar  : forall r, lc_type_rgn (Rgn2_FVar true true r).

Inductive lc_type_sa : StaticAction2 -> Prop :=
     | lc_sa_alloc : forall r, lc_type_rgn (r) -> lc_type_sa (SA2_Alloc r)
     | lc_sa_read  : forall r, lc_type_rgn (r) -> lc_type_sa (SA2_Read r)
     | lc_sa_write : forall r, lc_type_rgn (r) -> lc_type_sa (SA2_Write r).

Inductive lc_type_eps : Epsilon2 -> Prop :=
     | lc_eps : forall eps, (forall (sa : StaticAction2), eps sa /\ lc_type_sa (sa)) ->
                            lc_type_eps (eps).

Definition lc u := lc_type_rgn (mk_rgn_type u).

Inductive lc_type : type2 -> Prop :=
  | lc_natural : lc_type Ty2_Natural
  | lc_pair    : forall t1 t2,
                   lc_type t1 -> lc_type t2 -> lc_type (Ty2_Pair t1 t2)
  | lc_ref     : forall r t,
                   lc_type_rgn r -> lc_type t -> lc_type (Ty2_Ref r t)
  | lc_arrow   : forall aty ceff crty eeff erty,
                   lc_type aty -> lc_type_eps ceff -> lc_type crty ->
                   lc_type_eps eeff -> lc_type erty ->
                   lc_type (Ty2_Arrow aty ceff crty eeff erty)
  | lc_forall  : forall L eff rty,
                   (forall x, not_set_elem L x -> lc_type (open_var rty x)) ->
                   lc_type_eps eff ->
                   lc_type rty ->
                   lc_type (Ty2_ForallRgn eff rty).
(** end of locally closed **)

(** definitions of lemmas **)

Definition close_open_var := forall t x, x # t -> close_var x (open_var t x) = t.

Definition open_close_var := forall x t, lc_type t -> open_var (close_var x t) x = t.

Definition open_var_inj := forall x t1 t2, x # t1 -> x # t2 -> open_var t1 x = open_var t2 x -> t1 = t2.

Definition open_lc := forall u t, lc_type t -> open u t = t.

Definition subst_open := forall x u t v, lc u -> [x := u] (open v t) = open (subst_rgn x u v) ([x := u] t).

Definition subst_open_var := forall x y u t, x <> y -> lc u -> [x := u] (open_var t y) = open_var ([x := u] t) y.

Definition subst_fresh := forall x t u, x # t -> [x := u] t = t.

Definition subst_intro := forall x t u, x # t -> lc u -> open (mk_rgn_type u) t = [x := u] (open_var t x).

Definition subst_as_close_open := forall x t u, lc_type t ->
                                                [x := u] t = open  (mk_rgn_type u) (close_var x t).

(** end of lemmas **)

Lemma subst_as_close_open_rgn : forall n r x u, lc_type_rgn r ->
                                               subst_rgn x u r = opening_rgn_in_rgn2 n (mk_rgn_type u) (closing_rgn_in_rgn2 n x r).
Proof.
  intros n r x u H. inversion H; subst; simpl.
  - reflexivity.
  - destruct (AsciiVars.eq_dec x r0).
    + inversion e. destruct (AsciiVars.eq_dec r0 r0); simpl.
      * rewrite PeanoNat.Nat.eqb_refl. reflexivity.
      * unfold AsciiVars.eq in *. contradict n0. reflexivity.
    + destruct (AsciiVars.eq_dec r0 x); unfold AsciiVars.eq in *.
      * symmetry in e. contradiction.
      * simpl. reflexivity.
Qed.

Lemma subst_as_close_open_sa : forall n x u sa, lc_type_sa sa ->
                                                subst_sa x u sa =
                                                opening_rgn_in_sa2 n (mk_rgn_type u) (closing_rgn_in_sa2 n x sa).
Proof.
  intros n x u sa H.
  inversion H; subst;
  unfold subst_sa, opening_rgn_in_sa2, closing_rgn_in_sa2;
  f_equal; now apply subst_as_close_open_rgn.
Qed.

Lemma subst_as_close_open_eps : forall n x u e, lc_type_eps e ->
                                                subst_eps x u e =
                                                opening_rgn_in_eps2 n (mk_rgn_type u) (closing_rgn_in_eps2 n x e).
Proof.
  intros n x u e H .
  apply Extensionality_Ensembles.
  unfold Same_set, Included. intuition; unfold In in *.
  - unfold subst_eps in H0. inversion H; subst.
    unfold opening_rgn_in_eps2, closing_rgn_in_eps2.
    destruct H0 as [sa [H2 H3]]. subst.
    exists (closing_rgn_in_sa2 n x sa). split.
    + exists sa. intuition.
    + rewrite <- subst_as_close_open_sa; auto.
      destruct (H1 sa). assumption.
  - unfold subst_eps. inversion H; subst.
    unfold opening_rgn_in_eps2, closing_rgn_in_eps2 in H0.
    destruct H0 as [x' [[x'' [H2 H3]] H4]]. subst.
    destruct (H1 x''). exists x''. intuition.
    rewrite <- subst_as_close_open_sa; auto.
Qed.

Lemma SUBST_AS_CLOSE_OPEN : subst_as_close_open.
Proof.
  intros x t u H. unfold open, close_var. generalize 0. intro.
  dependent induction t; intros; simpl; try (solve [reflexivity]).
  - inversion H; subst.
    f_equal; [apply IHt1 | apply IHt2]; assumption.
  - f_equal;[ | apply IHt]. unfold subst_rgn, opening_rgn_in_rgn2, closing_rgn_in_rgn2.
    unfold rgn2_in_typ in r. dependent induction r.
    + reflexivity.
    + destruct (AsciiVars.eq_dec n x); destruct (AsciiVars.eq_dec x n).
      * rewrite PeanoNat.Nat.eqb_refl. reflexivity.
      * unfold  AsciiVars.eq in *. symmetry in e. contradiction.
      * unfold  AsciiVars.eq in *. symmetry in e. contradiction.
      * reflexivity.
    + inversion H; subst.  inversion H2.
    + inversion H; subst. assumption.
  - f_equal;[apply IHt1 | | apply IHt2 | | apply IHt3]; try auto; inversion H; subst; auto.
    + now apply subst_as_close_open_eps.
    + now apply subst_as_close_open_eps.
  - f_equal.
    + apply subst_as_close_open_eps. inversion H. assumption.
    + apply IHt. inversion H; subst; auto.

Qed.

Lemma close_open_rgn :
  forall r n x, (In Name (free_rgn_vars_in_rgn2 r) x -> False) ->
                closing_rgn_in_rgn2 n x (opening_rgn_in_rgn2 n (Rgn2_FVar true true x) r) = r.
Proof.
  intros r n x H.
  unfold closing_rgn_in_rgn2, opening_rgn_in_rgn2.
  unfold rgn2_in_typ in r; dependent induction r; intros.
  - reflexivity.
  - case (AsciiVars.eq_dec n x); intros.
    + contradict H. inversion e; subst. unfold free_rgn_vars_in_rgn2. apply In_singleton.
    + reflexivity.
  - case_eq (beq_nat n n0); intros; simpl; [ | reflexivity].
    destruct (AsciiVars.eq_dec x x); [apply beq_nat_true in H0; subst; reflexivity | intuition].
Qed.

Lemma close_open_sa :
  forall sa n x, (In Name (free_rgn_vars_in_sa2 sa) x -> False) ->
                 closing_rgn_in_sa2 n x (opening_rgn_in_sa2 n (Rgn2_FVar true true x) sa) = sa.
Proof.
  intros sa n x H.
  unfold closing_rgn_in_sa2, opening_rgn_in_sa2.
  destruct sa; rewrite close_open_rgn; auto.
Qed.

Lemma close_open_eps :
  forall e x n , (In Name (free_rgn_vars_in_eps2 e) x -> False) ->
                 closing_rgn_in_eps2 n x (opening_rgn_in_eps2 n (Rgn2_FVar true true x) e) = e.
Proof.
  intros e x n H.
  apply Extensionality_Ensembles.
  split.
  + intro sa. unfold In in *.
    unfold closing_rgn_in_eps2; unfold opening_rgn_in_eps2; simpl.

    intros [sa' [[sa'' [H2 H3]] H1]]. subst.
    rewrite close_open_sa; eauto.
    intro. apply H.
    unfold free_rgn_vars_in_eps2; unfold In.
    exists sa''; auto.
    (*split; intuition.
    * subst. inversion H2.*)
  + intro sa. unfold In in *.
    unfold closing_rgn_in_eps2; unfold opening_rgn_in_eps2; simpl.
    intro H1.
    exists (opening_rgn_in_sa2 n (Rgn2_FVar true true x) sa).
    rewrite close_open_sa.
    split; [exists sa; auto | reflexivity].
    intro. apply H.
    unfold free_rgn_vars_in_eps2; unfold In.
    exists sa; auto.
    (*split; intuition.
    - subst. inversion H1.*)
Qed.

Lemma CLOSE_OPEN_VAR : close_open_var.
Proof.
  intros t x H.  unfold close_var, open_var. generalize 0.
  induction t; simpl; intuition;
  unfold not_set_elem, set_union, empty_set, Complement, not in *.
  - f_equal; [apply IHt1 | apply IHt2]; simpl in H; intuition.
  - simpl in H. assert (H' : In Name (free_rgn_vars_in_rgn2 r) x -> False)
      by (intros; apply H; now apply Union_introl).
    f_equal; unfold rgn2_in_typ in r; dependent induction r; subst; simpl.
    + reflexivity.
    + case (AsciiVars.eq_dec n x); intros. unfold AsciiVars.eq in e; subst.
      * contradict H'. unfold free_rgn_vars_in_rgn2. apply In_singleton.
      * reflexivity.
    + case_eq (beq_nat n n0); intros; simpl.
      * apply beq_nat_true in H0; subst.
        destruct (AsciiVars.eq_dec x x);  [reflexivity | contradict n; reflexivity].
      * reflexivity.
    + apply IHt. intros. apply H. now apply Union_intror.
    + apply IHt. intros. apply H. now apply Union_intror.
    + apply IHt. intros. apply H. now apply Union_intror.
  - simpl in H. f_equal.
    + apply IHt1; intuition.
    + apply close_open_eps.
      intros. apply H. apply Union_intror. apply Union_introl. now apply Union_introl.
    + apply IHt2; intuition.
    + apply close_open_eps.
      intros. apply H. apply Union_intror. apply Union_introl. now apply Union_intror.
    +  apply IHt3; intuition.
  - simpl in H. f_equal.
    + apply close_open_eps.
      intros. apply H.  now apply Union_introl.
    + apply IHt.
      intros. apply H.  now apply Union_intror.
Qed.

Lemma OPEN_VAR_INJ : open_var_inj.
Proof.
  intros x t1 t2 HF1 HF2 HEq.
  rewrite <- (CLOSE_OPEN_VAR t1 x); auto.
  rewrite <- (CLOSE_OPEN_VAR t2 x); auto.
  f_equal. assumption.
Qed.

Lemma open_close_rgn : forall r n x, lc_type_rgn r ->
                                     opening_rgn_in_rgn2 n (Rgn2_FVar true true x) (closing_rgn_in_rgn2 n x r) = r.
Proof.
  intros. induction H; unfold opening_rgn_in_rgn2, closing_rgn_in_rgn2.
  - reflexivity.
  - destruct (AsciiVars.eq_dec r x).
    + rewrite PeanoNat.Nat.eqb_refl. inversion e; now subst.
    + reflexivity.
Qed.
(*  - destruct (AsciiVars.eq_dec x0 x); simpl; auto.
    inversion e; subst; now rewrite NPeano.Nat.eqb_refl.
  - destruct (AsciiVars.eq_dec x0 x); simpl; auto.
    inversion e; subst; now rewrite NPeano.Nat.eqb_refl.
  - destruct (AsciiVars.eq_dec x0 x); simpl; auto.
    inversion e; subst; now rewrite NPeano.Nat.eqb_refl. *)

Lemma opening_lc_sa : forall n x sa, lc_type_sa sa ->
                                     opening_rgn_in_sa2 n (Rgn2_FVar true true x) sa = sa.
Proof.
  intros n x sa H. unfold opening_rgn_in_sa2.
  dependent induction sa; f_equal; inversion H; subst; inversion H1; simpl; reflexivity.
Qed.

Lemma open_close_sa : forall n x sa, lc_type_sa sa ->
                                     opening_rgn_in_sa2 n (Rgn2_FVar true true x) (closing_rgn_in_sa2 n x sa) = sa.
Proof.
  intros n x sa H.
  induction H; unfold opening_rgn_in_sa2, closing_rgn_in_sa2;
  now rewrite open_close_rgn.
Qed.

Lemma open_close_eps : forall eff n x, lc_type_eps eff ->
                                       opening_rgn_in_eps2 n (Rgn2_FVar true true x) (closing_rgn_in_eps2 n x eff) = eff.
Proof.
  intros eff n x H. unfold opening_rgn_in_eps2, closing_rgn_in_eps2.
  apply Extensionality_Ensembles.
  split.
  - intro sa. unfold In in *.
    intros [sa' [[sa'' [H2 H3]] H1]]. subst. inversion H; subst.
    destruct (H0 sa'').
    unfold opening_rgn_in_sa2, closing_rgn_in_sa2.
    destruct sa''; rewrite open_close_rgn; auto; inversion H3; now subst.
  - intro sa. intros. unfold In in *.
    inversion H; subst.
    exists (closing_rgn_in_sa2 n x sa). split.
    + exists sa. intuition.
    + destruct (H1 sa).
      rewrite open_close_sa; auto.
Qed.

Lemma OPEN_CLOSE_VAR : open_close_var.
Proof.
  intros x t H. unfold open_var, close_var. generalize 0.
  induction H; intros; simpl.
  - reflexivity.
  - f_equal; [apply IHlc_type1 | apply IHlc_type2].
  - f_equal; [ rewrite open_close_rgn; auto | apply IHlc_type].
  - f_equal; try (solve [rewrite  open_close_eps; auto]); [apply IHlc_type1 | apply IHlc_type2 | apply IHlc_type3].
  - f_equal. rewrite  open_close_eps; auto. apply  IHlc_type.
Qed.

Lemma open_subst_lc_sa: forall n u sa,
                          lc_type_sa sa -> opening_rgn_in_sa2 n u sa = sa.
Proof.
  intros n u sa H.
  unfold opening_rgn_in_sa2.
  inversion H; subst;
  unfold opening_rgn_in_rgn2; unfold rgn2_in_typ in r;
  dependent induction r; try (solve [reflexivity | inversion H1 | inversion H; inversion H2]).
Qed.

Lemma open_subst_lc_eps: forall n u eff, lc_type_eps eff -> opening_rgn_in_eps2 n u eff = eff.
Proof.
  intros n u eff Hlc.
  induction Hlc; intros; simpl.
  apply Extensionality_Ensembles. unfold Same_set, Included.
  intuition; unfold In in *.
  - unfold opening_rgn_in_eps2 in H0.
    destruct H0 as [x' [H1 H2]].
    erewrite open_subst_lc_sa in H2; eauto.
    + now subst.
    + destruct (H x'); auto.
  - unfold opening_rgn_in_eps2.
    exists x. intuition.
    erewrite open_subst_lc_sa; eauto.
    destruct (H x); auto.
Qed.

Lemma OPEN_LC : open_lc.
Proof.
  intros u t Hlc. unfold open.
  generalize 0. induction Hlc; intros; simpl.
  - reflexivity.
  - f_equal; [apply IHHlc1  | apply IHHlc2].
  - f_equal; [| apply IHHlc].
    unfold opening_rgn_in_rgn2.
    unfold rgn2_in_typ in r. dependent induction r.
    + reflexivity.
    + reflexivity.
    + inversion H.
  - f_equal; try (solve [apply IHHlc1 | apply IHHlc2 | apply IHHlc3]).
    + apply Extensionality_Ensembles. unfold Same_set, Included.
      split; intros. unfold In in *.
      * destruct H1 as [x' ?]. intuition.
        inversion H; subst.
        destruct (H1 x').
        eapply open_subst_lc_sa in H4; eauto.
        now rewrite H4.
      * rewrite open_subst_lc_eps; auto.
    + apply Extensionality_Ensembles. unfold Same_set, Included.
      split; intros. unfold In in *.
      * destruct H1 as [x' ?]. intuition.
        inversion H0; subst.
        destruct (H1 x').
        eapply open_subst_lc_sa in H4; eauto.
        now rewrite H4.
      * rewrite open_subst_lc_eps; auto.
  - f_equal; [ rewrite open_subst_lc_eps; auto | apply IHHlc].
Qed.

Lemma subst_open_rgn : forall x u n v r, subst_rgn x u (opening_rgn_in_rgn2 n v r) =
                                         opening_rgn_in_rgn2 n (subst_rgn x u v) (subst_rgn x u r).
Proof.
  intros x u n v r.
  unfold rgn2_in_typ in r.
  dependent induction r; try (solve [reflexivity]).
  - destruct (AsciiVars.eq_dec n0 x).
    + unfold subst_rgn, opening_rgn_in_rgn2, closing_rgn_in_rgn2.
      inversion e; subst.
      destruct (AsciiVars.eq_dec x x); [ | reflexivity].
      unfold rgn2_in_exp in u.
      dependent induction u; simpl; reflexivity.
    + unfold subst_rgn, opening_rgn_in_rgn2, closing_rgn_in_rgn2.
      unfold AsciiVars.eq in n1.
      destruct (AsciiVars.eq_dec x n0); [ | reflexivity].
      unfold AsciiVars.eq in e. symmetry in e. contradiction.
  - unfold subst_rgn, opening_rgn_in_rgn2, closing_rgn_in_rgn2.
    case (beq_nat n0 n); [ | reflexivity].
    unfold rgn2_in_typ in v.
    dependent induction v; reflexivity.
Qed.

Lemma subst_open_sa: forall n x u v e,
                        subst_sa x u (opening_rgn_in_sa2 n v e) =
                        opening_rgn_in_sa2 n (subst_rgn x u v) (subst_sa x u e).
Proof.
  intros n x u v e.
  destruct e; simpl; f_equal; rewrite subst_open_rgn; reflexivity.
Qed.

Lemma subst_open_eps: forall n x u v e,
                        (*lc_type_eps e ->*)
                        subst_eps x u (opening_rgn_in_eps2 n v e) =
                        opening_rgn_in_eps2 n (subst_rgn x u v) (subst_eps x u e).
Proof.
  intros n x u v e.
  unfold subst_eps, opening_rgn_in_eps2.
  apply Extensionality_Ensembles; unfold Same_set, Included.
  intuition; unfold In in *;
  destruct H as [x1 [[x2 [H2 H3]] H4]]; subst.
  - rewrite subst_open_sa.
    exists (subst_sa x u x2); intuition. exists x2; intuition.
  - rewrite <- subst_open_sa.
    exists (opening_rgn_in_sa2 n v x2); intuition. exists x2; intuition.
Qed.

Lemma SUBST_OPEN : subst_open.
Proof.
  intros x u t v.  unfold open.  generalize 0.
  induction t; intros; simpl.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - f_equal; [apply IHt1 |  apply IHt2]; assumption.
  - (*unfold open_rgn_in_type, close_rgn_in_type; simpl.*)
    f_equal; [ |  apply IHt]; auto.
    fold (subst_rgn x u (opening_rgn_in_rgn2 n v r)).
    fold (subst_rgn x u r).
    rewrite subst_open_rgn; auto.
  - (*unfold open_rgn_in_type, close_rgn_in_type; simpl.*)
    f_equal; try (solve [now apply IHt1 | now apply IHt2 | now apply IHt3]).
    + rewrite subst_open_eps; auto.
    + rewrite subst_open_eps; auto.
  - f_equal; [ |  apply IHt]; auto.
    rewrite subst_open_eps; auto.
Qed.

Lemma SUBST_OPEN_VAR : subst_open_var.
Proof.
  intros x y u t H Hlc.
  unfold open_var.
  rewrite SUBST_OPEN; auto.
  unfold open. f_equal. simpl.
  destruct (AsciiVars.eq_dec x y).
  - inversion e. contradiction.
  - reflexivity.
Qed.

Lemma singleton_eq : forall x y, x = y <-> Singleton Name x y.
Proof.
  intros x y. split.
  - intros H; subst. apply In_singleton.
  - intros H. now inversion H.
Qed.

Lemma subst_fresh_rgn : forall r x u, not_set_elem (free_region r) x ->
                                      subst_rgn x u r = r.
Proof.
  intros r x u H.
  unfold not_set_elem, free_region, Complement in H.
  unfold free_rgn_vars_in_rgn2 in H.
  unfold subst_rgn.
  unfold rgn2_in_typ in r.
  dependent induction r.
  - reflexivity.
  - unfold not, In, singleton_set in H.
    assert (x <> n) by (contradict H; now apply singleton_eq).
    destruct (AsciiVars.eq_dec x n).
    + inversion e. contradiction.
    + reflexivity.
  - reflexivity.
Qed.

Lemma subst_fresh_sa : forall sa x u, not_set_elem (free_rgn_vars_in_sa2 sa) x ->
                                      subst_sa x u sa = sa.
Proof.
  intros sa x u H.
  unfold not_set_elem, Complement, free_rgn_vars_in_sa2 in H.
  induction sa; unfold subst_sa, subst_rgn; f_equal;
  unfold free_rgn_vars_in_rgn2 in H; unfold In in *;
  unfold rgn2_in_typ in r;
  dependent induction r; try (solve [reflexivity |
                                     assert (x <> n) by (contradict H; now apply singleton_eq);
                                     destruct (AsciiVars.eq_dec x n); [inversion e; contradiction | reflexivity]]).
Qed.

Lemma subst_fresh_sa_ext :forall (e : Epsilon2) sa x u,
                            e sa -> not_set_elem (free_rgn_vars_in_sa2 sa) x ->
                            (exists sa' : StaticAction2, e sa' /\ subst_sa x u sa' = sa).
Proof.
  intros e sa x u H.
  exists sa. intuition.
  now apply subst_fresh_sa.
Qed.

Lemma subst_fresh_eps : forall e x u, not_set_elem (free_rgn_vars_in_eps2 e) x ->
                                      subst_eps x u e = e.
Proof.
  intros e x u H.
  unfold free_rgn_vars_in_eps2 in H.
  unfold subst_eps.
  apply Extensionality_Ensembles; unfold Same_set, Included.
  split.
  - unfold In. intros x0.
    intros [sa' [H1 H2]]. subst.
    rewrite subst_fresh_sa; auto.
    unfold not_set_elem, Complement, In, not in *.
    intros. apply H. exists sa'.
    split; intuition.
    (*+ subst. inversion H1.*)
  - unfold In.   intros x0 H0.
    exists x0. intuition.
    rewrite subst_fresh_sa; auto.
    unfold not_set_elem, Complement, In, not in *.
    intros. apply H. exists x0.
    split; intuition.
    (*+ subst. inversion H0.*)
Qed.

Lemma SUBST_FRESH : subst_fresh.
Proof.
  intros x. induction t; intros u H; simpl.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - f_equal; [apply IHt1 | apply IHt2];
    unfold not_set_elem, Complement in *;
    simpl in H; intuition.
  - unfold not_set_elem, Complement in H.
    f_equal; [ | apply IHt].
    + apply subst_fresh_rgn.
      unfold not_set_elem, free_region, Complement.
      unfold not in *; intros. apply H. simpl. now apply Union_introl.
    + unfold not_set_elem, free_region, Complement.
      unfold not in *; intros. apply H. simpl. now apply Union_intror.
  - unfold not_set_elem, Complement in H.
    f_equal; [apply IHt1 | | apply IHt2 | | apply IHt3].
    + unfold not_set_elem, free_region, Complement.
      unfold not in *; intros. apply H. simpl. now apply Union_introl.
    + rewrite subst_fresh_eps; auto.
      unfold not_set_elem, free_region, Complement.
      simpl in H. unfold not in *. intros.
      apply H.  apply Union_intror.  apply Union_introl. now  apply Union_introl.
    + unfold not_set_elem, free_region, Complement.
      simpl in H. unfold not in *. intros.
      apply H. apply Union_intror.  apply Union_intror. now apply Union_introl.
    + rewrite subst_fresh_eps; auto.
      unfold not_set_elem, free_region, Complement.
      simpl in H. unfold not in *. intros.
      apply H.  apply Union_intror.  apply Union_introl. now  apply Union_intror.
    + unfold not_set_elem, free_region, Complement.
      simpl in H. unfold not in *. intros.
      apply H. apply Union_intror.  apply Union_intror. now apply Union_intror.
  - f_equal; [ | apply IHt].
    + rewrite subst_fresh_eps; auto.
      unfold not_set_elem, free_region, Complement in *.
      simpl in H. unfold not in *. intros.
      apply H. now apply Union_introl.
    + simpl in H. unfold not_set_elem, free_region, Complement in *.
      unfold not in *. intros. apply H. now apply Union_intror.
Qed.

Lemma SUBST_INTRO : subst_intro.
Proof.
  intros x t u H1 H2. unfold open_var.
  replace (opening_rgn_exp 0 (Rgn2_FVar true true x) t) with (open  (Rgn2_FVar true true x) t) by (now unfold open).
  rewrite SUBST_OPEN; auto. f_equal.
  - simpl in *; destruct (AsciiVars.eq_dec x x); intros;
    [reflexivity | unfold AsciiVars.eq in n; contradict n; reflexivity ].
  - symmetry. now apply SUBST_FRESH.
Qed .


Require Import Strings.String.
Require Import Strings.Ascii.
Require Import Coq.ZArith.BinInt.
Require Import Lists.List.
Require Export BinNums.
Require Import BinPos BinNat.
Require Import Bool.
Import ListNotations.
Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope Z_scope.

Inductive NatType :=
  | error_nat : NatType
  | num :  nat -> NatType.

Inductive IntType :=
  | error_int : IntType
  | nr : Z -> IntType.

Inductive BoolType :=
  | error_bool : BoolType
  | boolean : bool -> BoolType.

Inductive StringType :=
  | error_string : StringType
  | strval : string -> StringType.

Coercion boolean: bool >-> BoolType.
Coercion nr : Z >-> IntType.
Coercion num : nat >-> NatType.
Notation "string( S )" := (strval S).
Notation "nat( N )" := (num N).
Notation "int( I )" := (nr I).
Notation "bool( B )" := (boolean B).

Inductive STREXP :=
| svar : string -> STREXP
| sconst: StringType -> STREXP
| strcat : string -> string -> STREXP
| get_vval_s : string -> nat -> STREXP
| to_string : string -> STREXP.

Notation "strcat( A , B )" := (strcat A B)(at level 52).
Notation "strcpy( A , B )" := (strcat A B)(at level 52).

Coercion sconst: StringType >-> STREXP.
Coercion svar: string >-> STREXP.

Fixpoint vect_s_parse (n : nat) (l: list StringType) (default : StringType):string:=
match n,l with
| O, x::l' =>  match x with
              | error_string => ""
              | strval s' => s'
              end
| O, other => match default with
              | error_string => ""
              | strval s' => s'
              end
| S m, nil =>  match default with
              | error_string => ""
              | strval s' => s'
              end
| S m, x::l' => vect_s_parse m l' default
end.

Inductive AExp :=
| avar: string -> AExp
| anum: NatType -> AExp
| aint: IntType -> AExp
| aplus: AExp -> AExp -> AExp
| asub: AExp -> AExp -> AExp
| amul: AExp -> AExp -> AExp
| adiv: AExp -> AExp -> AExp
| amod: AExp -> AExp -> AExp
| apow: AExp -> AExp -> AExp
| to_nat: string -> AExp
| to_int: string -> AExp
| get_vval_a : string -> nat -> AExp
| strlen: string -> AExp.

Coercion anum : NatType >-> AExp.
Coercion avar : string >-> AExp.
Coercion aint : IntType >-> AExp.

Notation "A +' B" := (aplus A B) (at level 48).
Notation "A -' B" := (asub A B) (at level 48).
Notation "A *' B" := (amul A B) (at level 46).
Notation "A /' B" := (adiv A B) (at level 46).
Notation "A %' B" := (amod A B) (at level 46).
Notation "A ^' B" := (apow A B) (at level 46).

Inductive BExp :=
| btrue : BExp
| bfalse : BExp
| bvar : string -> BExp
| bval : BoolType -> BExp
| blessthan : AExp -> AExp -> BExp
| bnot : BExp -> BExp
| band : BExp -> BExp -> BExp
| bgreaterthan: AExp -> AExp -> BExp
| bor : BExp -> BExp -> BExp
| bxor : BExp -> BExp -> BExp
| bxand : BExp -> BExp -> BExp
| strcmp : STREXP -> STREXP -> BExp
| blet : AExp -> AExp -> BExp
| bget : AExp -> AExp -> BExp
| beq : AExp -> AExp -> BExp
| bneq : AExp -> AExp -> BExp
| get_vval_b : string -> nat -> BExp
| to_bool : string -> BExp.

Coercion bvar: string >-> BExp.
Coercion bval: BoolType >-> BExp.

Notation "A <' B" := (blessthan A B) (at level 53).
Notation "A >' B" := (bgreaterthan A B) (at level 53).
Notation "A <=' B" := (blet A B) (at level 53).
Notation "A >=' B" := (bget A B) (at level 53).
Notation "` A " := (bnot A) (at level 40).
Notation "A &&' B" := (band A B) (at level 55).
Notation "A ||' B" := (bor A B) (at level 55).
Notation "A 'xor'' B" := (bxor A B) (at level 55).
Notation "A 'xand'' B" := (bxand A B) (at level 55).
Notation "A ==' B" := (beq A B) (at level 53).
Notation "A !=' B" := (bneq A B) (at level 53).
Notation "strcmp( A ; B )" := (strcmp A B) (at level 52).

Inductive vect :=
| error_vect: vect
| vector_int : nat -> list IntType -> vect
| vector_nat : nat -> list NatType -> vect
| vector_bool : nat -> list BoolType -> vect
| vector_str : nat -> list StringType -> vect.

Inductive Stmt :=
| def_nat : string -> AExp ->Stmt
| def_bool : string -> BExp -> Stmt
| def_int : string -> AExp -> Stmt
| def_string : string -> STREXP -> Stmt
| def_nat0 : string ->Stmt
| def_bool0 : string -> Stmt
| def_int0 : string  -> Stmt
| def_string0 : string -> Stmt
| def_vector : string -> vect -> Stmt
| assignment : string -> AExp -> Stmt
| bassignment : string -> BExp -> Stmt
| sassignment : string -> STREXP -> Stmt
| sequence : Stmt -> Stmt -> Stmt
| while : BExp -> Stmt -> Stmt
| dowhile : Stmt -> BExp -> Stmt
| ifthen : BExp -> Stmt -> Stmt
| ifthenelse : BExp -> Stmt -> Stmt -> Stmt
| For : Stmt -> BExp -> Stmt -> Stmt ->Stmt
| forcontent : BExp -> Stmt -> Stmt -> Stmt
| get_func : string -> list string -> Stmt
| break : Stmt
| continue  : Stmt
| switch: AExp -> list cases -> Stmt
| read: string -> Stmt
| write: STREXP -> Stmt
| strcpy : string -> string -> Stmt
| nullstmt : Stmt
with cases:=
| def: Stmt -> cases
| case : nat -> Stmt -> cases.

Inductive Val :=
| undecl: Val
| unassign: Val
| default: Val
| number: NatType -> Val
| integer : IntType -> Val
| bol: BoolType -> Val
| str: StringType -> Val
| vector: vect -> Val
| code: (list string) -> Stmt -> Val.
Coercion number: NatType >-> Val.
Coercion integer: IntType >-> Val.
Coercion bol: BoolType >-> Val.
Coercion str : StringType >-> Val.

Definition abs_nat (z:Z) : nat :=
  match z with
    | 0 => 0%nat
    | Zpos p => Pos.to_nat p
    | Zneg p => Pos.to_nat p
  end.
Fixpoint list_ascii_to_list_nat (l:list ascii):list nat:=
match l with
| nil =>  nil
| x::l' => (Nat.sub (nat_of_ascii x) 48)::list_ascii_to_list_nat l'
end.

Fixpoint list_int_to_list_nat (l:list IntType): list nat :=
match l with
| nil => nil
| x::l' => match x with
          |error_int => abs_nat 0::list_int_to_list_nat l'
          |nr x'=> (abs_nat x')::list_int_to_list_nat l'
          end
end.

Fixpoint list_NatType_to_list_nat (l:list NatType): list nat :=
match l with
| nil => nil
| x::l' => match x with
          |error_nat => (abs_nat 0)::list_NatType_to_list_nat l'
          |num x'=> (x')::list_NatType_to_list_nat l'
          end
end.
Fixpoint list_nat_to_list_int (l:list nat):list Z:=
match l with
| nil => nil
| x::l' =>  (Z_of_nat x)::list_nat_to_list_int l'
end.
Fixpoint list_Z_to_list_IntType (l:list Z): list IntType:=
match l with
| nil => nil
| x::l' =>  nr x::  list_Z_to_list_IntType l'
end.
Fixpoint list_BoolType_to_list_nat (l:list BoolType): list nat :=
match l with
| nil => nil
| x::l' => match x with
          |error_bool => (abs_nat 0)::list_BoolType_to_list_nat l'
          |boolean x'=> match(x')with
                        |false => (abs_nat 0)::list_BoolType_to_list_nat l'
                        |true => (abs_nat 1)::list_BoolType_to_list_nat l'
                        end
          end
end.
Fixpoint list_StrType_to_list_nat (l:list StringType): list nat :=
match l with
| nil => nil
| x::l' => match x with
          |error_string => (abs_nat 0)::list_StrType_to_list_nat l'
          |strval x'=> list_sum(list_ascii_to_list_nat(list_ascii_of_string(x')))::list_StrType_to_list_nat l'
          end
end.
Definition natural (val : Val) : nat :=
match val with
| undecl=> 0
| unassign=> 0
| default=> 0
| number n=> (match n with
            |error_nat => 0
            |num n' => n'
            end )
| integer i=> (match i with
               | error_int =>0
               | nr i' =>  ( abs_nat i' )end)
| bol b=> (match b with
          | error_bool => 0
          | boolean b' => match b' with
                          | true => 1
                          | false => 0 end
          end)
| str s=> match s with
          | error_string => 0
          | strval s' => list_sum(list_ascii_to_list_nat(list_ascii_of_string(s'))) end
| vector v=>  match v with
              |error_vect => 0
              | vector_int n i'=> list_sum(list_int_to_list_nat(i'))
              | vector_nat n n'=> list_sum(list_NatType_to_list_nat(n'))
              | vector_bool n b'=> list_sum(list_BoolType_to_list_nat(b'))
              | vector_str n s'=> list_sum(list_StrType_to_list_nat(s'))
              end
| code l s => 1
end.

Definition integ (val : Val) : Z :=
match val with
| undecl=> 0
| unassign=> 0
| default=> 0
| number n=> match n with
            | error_nat => 0
            | num n' => Z_of_nat n'
            end
| integer i=> match i with
              | error_int => 0
              | nr i' => i'
              end
| bol b=> match b with
          | error_bool => 0
          | boolean b' => match b' with
                          | true => 1
                          | false => 0
                          end
          end
| str s=> match s with
          | error_string => 0
          | strval s' => Z_of_nat (list_sum(list_ascii_to_list_nat(list_ascii_of_string(s'))))
          end
| vector v=>  match v with
              |error_vect => 0
              | vector_int n i'=> Z_of_nat (list_sum(list_int_to_list_nat(i')))
              | vector_nat n n'=> Z_of_nat (list_sum(list_NatType_to_list_nat(n')))
              | vector_bool n b'=> Z_of_nat (list_sum(list_BoolType_to_list_nat(b')))
              | vector_str n s'=> Z_of_nat (list_sum(list_StrType_to_list_nat(s')))
              end
| code l s => 1
end.

Definition boole (val : Val) : bool :=
match val with
| undecl=> false
| unassign=> false
| default=> false
| number n=> match n with
            | error_nat => false
            | num n' => if(Nat.eqb n' 0) then false else true
            end
| integer i=> match i with
            | error_int => false
            | nr i' =>  if(Z.leb i' 0 ) then false else true
            end
| bol b=> match b with
          | error_bool => false
          | boolean b' => b'
          end
| str s=> match s with
          |error_string => false
          | strval s' => if(string_dec s' "") then false else true
          end
| vector v=> match v with
              |error_vect => false
              | vector_int n i'=> true
              | vector_nat n n'=> true
              | vector_bool n b'=> true
              | vector_str n s'=> true
              end
| code l s => true
end.

Definition strng (val : Val) : string :=
match val with
| undecl=> ""
| unassign=> ""
| default=> ""
| number n=> match n with
             | error_nat => ""
             | num n' => string_of_list_ascii(cons (ascii_of_nat n') nil)
             end
| integer i=> match i with
              | error_int => ""
              | nr i' => string_of_list_ascii(cons (ascii_of_nat(abs_nat i')) nil)
              end
| bol b=> match b with
          | error_bool => ""
          | boolean b' => match  b' with
                          | true => "true"
                          | false => "false"
                          end
          end
| str s=> match s with
          | error_string => ""
          | strval s' => s'
          end
| vector v=>  match v with
              | error_vect => ""
              | vector_int n i'=> match i' with
                                  | nil => ""
                                  | x::l => "x"
                                  end
              | vector_nat n n'=> match n' with
                                  | nil => ""
                                  | x::l => "x"
                                  end
              | vector_bool n b'=> match b' with
                                  | nil => ""
                                  | x::l => "x"
                                  end
              | vector_str n s'=> match s' with
                                  | nil => ""
                                  | x::l => match x with
                                            |error_string => ""
                                            | strval s' => s'
                                            end
                                  end
              end
| code l s => "code"
end.
Definition vect_list_s (val :Val) :list StringType:=
match val with
| undecl=> error_string::nil
| unassign=> error_string::nil
| default=> error_string::nil
| number n=> error_string::nil
| integer i=> error_string::nil
| bol b=> error_string::nil
| str s=> error_string::nil
| vector v=>  match v with
              | error_vect => error_string::nil
              | vector_int n i'=> error_string::nil
              | vector_nat n n'=> error_string::nil
              | vector_bool n b'=> error_string::nil
              | vector_str n s'=> match s' with
                                  | nil => nil
                                  | x::l => x::l
                                  end
              end
| code l s => error_string::nil
end
.
Definition vect_list_a (val :Val) :list IntType:=
match val with
| undecl=> error_int::nil
| unassign=> error_int::nil
| default=> error_int::nil
| number n=> error_int::nil
| integer i=> error_int::nil
| bol b=> error_int::nil
| str s=> error_int::nil
| vector v=>  match v with
              | error_vect => error_int::nil
              | vector_int n i'=> match i' with
                                  | nil => nil
                                  | x::l => x::l
                                  end
              | vector_nat n n'=> match n' with
                                  | nil => nil
                                  | x::l => match x with
                                            | error_nat => nr 0::list_Z_to_list_IntType(list_nat_to_list_int(list_NatType_to_list_nat l))
                                            | num p=> (nr (Z_of_nat p))::list_Z_to_list_IntType(list_nat_to_list_int(list_NatType_to_list_nat l))
                                            end
                                  end
              | vector_bool n b'=> error_int::nil
              | vector_str n s'=>  error_int::nil
              end
| code l s =>error_int::nil
end.
Definition vect_list_b (val :Val) :list BoolType:=
match val with
| undecl=> error_bool::nil
| unassign=> error_bool::nil
| default=> error_bool::nil
| number n=> error_bool::nil
| integer i=> error_bool::nil
| bol b=> error_bool::nil
| str s=> error_bool::nil
| vector v=>  match v with
              | error_vect => error_bool::nil
              | vector_int n i'=> error_bool::nil
              | vector_nat n n'=> error_bool::nil
              | vector_bool n b'=> match b' with
                                  | nil => nil
                                  | x::l => x::l
                                  end
              | vector_str n s'=>  error_bool::nil
              end
| code l s => error_bool::nil
end
.
Definition Env := string -> Val.
Inductive Envs :=
|pair: Env -> Env -> Envs.
Definition env_loc : Env := fun x => undecl.
Definition env_globe : Env := fun x => undecl.
Definition newenvs (e:Envs): Envs:=
match e with
| pair e1 e2 => pair env_globe env_loc
end.
Definition envs0 := pair env_loc env_globe.
Definition is_undecl (val:Val) :=
match val with
| undecl =>true
| _ => false
end.
Definition isglb(e:Envs)(s:string):bool:=
match e with
|pair e1 e2 => if(is_undecl(e2 s)) then true else false
end.
Definition gl(e:Envs)(s:string):Env:=
match e with
|pair e1 e2 => if(isglb e s) then e1 else e2
end.

Definition streval (str:STREXP) (env:Envs):string:=
match str with
| svar s => strng ((gl env s) s)
| sconst s => match s with
              | error_string => ""
              | strval s' => s'
              end
| get_vval_s s n => vect_s_parse n (vect_list_s((gl env s) s)) string("")
| strcat s1 s2 => ( s1 ++ s2)
| to_string s => strng(( gl env s) s)
end.

Definition eq_vals (val1:Val) (val2:Val) :=
match val1 with
| undecl =>  match val2 with
              | undecl => true
              | _ => false
              end
| unassign =>match val2 with
              | unassign => true
              | _ => false
              end
| default=>match val2 with
              | default => true
              | _ => false
              end
| number n=>match val2 with
              | number n'=> true
              | _ => false
              end
| integer i=>match val2 with
              | integer i'=> true
              | _ => false
              end
| bol b=>match val2 with
              | bol b'=> true
              | _ => false
              end
| str s=>match val2 with
              | str s'=> true
              | _ => false
              end
| vector v=>match val2 with
              | vector v'=> true
              | _ => false
              end
| code l c=>match val2 with
              | code l' c'=> true
              | _ => false
              end
end.
Definition update (env : Env) (str : string) (val : Val): Env :=
  fun str' => if (string_dec str str') then val else env str'.
Definition update_env (env:Env) (env1:Env): Env:=
  fun str => if( is_undecl(env1 str) ) then env str else (update env str (env1 str)) str
.
Definition update_envs (e:Envs)(s: string)(v:Val):Envs:=
match e with
| pair g l=>  if(isglb e s) then pair (update g s v) l else pair g (update l s v)
end.

Fixpoint list_update (env : Env) (l:list string) (env1 : Env) :=
  match l with
  |c::l' => list_update (update env c (env1 c)) l' env1
  |nil => env
  end
.
Definition update_local (e:Envs)(s: string)(v:Val):Envs:=
match e with
| pair g l=> pair g (update l s v)
end.
Definition update_global (e:Envs)(s: string)(v:Val):Envs:=
match e with
| pair g l=> pair (update g s v) l
end.
Definition get_globe(e:Envs):Env:=
match e with
| pair g l=> g
end.
Definition get_local(e:Envs):Env:=
match e with
| pair g l=> l
end.
Definition update_env_g (e1 e2:Envs):Envs:=
match e1 with
| pair g l=> match e2 with
             |pair g' l' => pair (update_env g g') l
             end
end.

Fixpoint lists_parse_i (l: list string) (l1 : list string) (env:Envs) (env1: Envs):Envs:=
  match l,l1 with
  | nil, nil => env1
  | x::l', x1::l1' => lists_parse_i l' l1' env (update_envs env1 x ((gl env x1) x1))
  | _, _ => envs0
  end
.
Compute env_loc "x".
Inductive Lang :=
| funcMain : Stmt -> Lang
| funcs : string -> list string -> Stmt -> Lang
| gdecl_int : string -> AExp -> Lang
| gdecl_nat : string -> AExp -> Lang
| gdecl_str : string -> STREXP -> Lang
| gdecl_bool : string -> BExp -> Lang
| gdecl_int0 : string -> Lang
| gdecl_nat0 : string -> Lang
| gdecl_str0 : string -> Lang
| gdecl_bool0 : string -> Lang
| secv : Lang -> Lang-> Lang
.

Fixpoint vect_parse {A:Type}(n:nat)(l:list A)(def: A): A:=
match n, l with
| O,  x::l' => x
| O, other => def
| S m, nil => def
| S m,  x::l' => vect_parse m l' def
end.
Fixpoint concat (s1 s2 : string) : string :=
  match s1 with
  | EmptyString => s2
  | String c s1' => String c (concat s1' s2)
  end
.

Definition plus_ErrorInt (n1 n2 : IntType) : IntType :=
  match n1, n2 with
    | error_int, _ => error_int
    | _, error_int => error_int
    | nr v1, nr v2 => nr (v1 + v2)
    end.

Definition sub_ErrorInt (n1 n2 : IntType) : IntType :=
  match n1, n2 with
    | error_int, _ => error_int
    | _, error_int => error_int
    | nr n1, nr n2 => nr (n1 - n2)
    end.

Definition mul_ErrorInt (n1 n2 : IntType) : IntType :=
  match n1, n2 with
    | error_int, _ => error_int
    | _, error_int => error_int
    | nr v1, nr v2 => nr (v1 * v2)
    end.

Definition div_ErrorInt (n1 n2 : IntType) : IntType :=
  match n1, n2 with
    | error_int, _ => error_int
    | _, error_int => error_int
    | _, nr 0 => error_int
    | nr v1, nr v2 => nr (Z.div v1 v2)
    end.

Definition mod_ErrorInt (n1 n2 : IntType) : IntType :=
  match n1, n2 with
    | error_int, _ => error_int
    | _, error_int => error_int
    | _, nr 0 => error_int
    | nr v1, nr v2 => nr (v1 - v2 * (Z.div v1 v2))
    end.
Definition pow_ErrorInt (n1 n2 : IntType) : IntType :=
  match n1, n2 with
    | error_int, _ => error_int
    | _, error_int => error_int
    | nr v1, nr v2 => nr (Z.pow v1 v2)
    end.

Reserved Notation "A -[ S ]-> N" (at level 60).
Inductive seval : STREXP -> Envs -> StringType -> Prop:=
| s_const : forall s sigma, sconst s-[ sigma ]-> s
| s_var : forall s sigma, svar s-[ sigma ]->strval(strng((gl sigma s) s))
| s_cat : forall s1 s2 sigma s12 s1' s2',
  s1'= (streval s1 sigma) ->
  s2'= (streval s2 sigma) ->
  s12 = (concat s1' s2') ->
  strcat s1' s2' -[ sigma ]-> strval s12
| s_get_vval_s : forall s n l sigma v,
  l= vect_list_s ((gl sigma s) s) ->
  v=vect_parse n l error_string ->
  get_vval_s s n -[sigma]->v
| s_to_string:forall s sigma s',
  s' = strng ((gl sigma s) s) ->
  to_string s -[sigma]-> strval s'
where "a -[ sigma ]-> s" := (seval a sigma s).

Reserved Notation "A =[ S ]=> N" (at level 60).

Fixpoint length_str (s : string) : nat :=
  match s with
  | EmptyString => 0
  | String c s' => S (length_str s')
  end.
Definition inttype_to_z (i:IntType):Z:=
match i with
| error_int => 0
| nr i' => i'
end.
Definition NatType_to_nat (n: NatType): nat :=
match n with
         | error_nat => 0
         | num n' => n'
         end
.

Inductive aeval_int : AExp -> Envs -> IntType-> Prop :=
| const_nat : forall  n sigma, anum n =[ sigma ]=> integ n (* <n,sigma> => <n> *)
| const_int : forall  n sigma, aint n =[ sigma ]=>  n (* <n,sigma> nat=> <n> *)
| var : forall v sigma, avar v =[ sigma ]=> ( integ((gl sigma v)v)) (* <v,sigma> => sigma(x) *)
| add : forall a1 a2 i1 i2 v1 v2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = (integ i1) ->
    v2 = (integ i2) ->
    n = plus_ErrorInt v1 v2 ->
    a1 +' a2 =[sigma]=> n
| times : forall a1 a2 i1 i2 v1 v2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = (integ i1) ->
    v2 = (integ i2) ->
    n = mul_ErrorInt v1 v2 ->
    a1 *' a2 =[sigma]=> n
| dec: forall a1 a2 i1 i2 v1 v2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = (integ i1) ->
    v2 = (integ i2) ->
    n =  sub_ErrorInt v1 v2 ->
    a1 -' a2 =[sigma]=> n
| div : forall a1 a2 i1 i2 v1 v2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 =( integ i1) ->
    v2 = (integ i2) ->
    n = ( div_ErrorInt v1 v2) ->
    a1 /' a2 =[sigma]=> n
| modu: forall a1 a2 i1 i2 v1 v2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = (integ i1) ->
    v2 = (integ i2) ->
    n = (mod_ErrorInt v1 v2) ->
    a1 %' a2 =[sigma]=> n
| pow: forall a1 a2 i1 i2 v1 v2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = (integ i1) ->
    v2 = (integ i2) ->
    n =( pow_ErrorInt v1 v2) ->
    i1 ^' i2 =[sigma]=>n
| tonat : forall s1 sigma,
    to_nat s1 =[ sigma ]=> (integ((gl sigma s1) s1))
| toint : forall s1 sigma,
    to_int s1 =[ sigma ]=> (integ ((gl sigma s1)s1))
| len: forall s sigma,
    strlen s =[ sigma ]=> integ(length_str s)
| e_getvval_a : forall s n l sigma v,
  l= vect_list_a ((gl sigma s) s) ->
  v=vect_parse n l error_int ->
  get_vval_a s n =[sigma]=>v
where "a =[ sigma ]=> n" := (aeval_int a sigma n).

Reserved Notation "B ={ S }=> B'" (at level 70).

Definition IntType_to_Z (i: IntType) :Z:=
match  i with
|error_int => 0
|nr i' => i'
end.
Definition StringType_to_string (s: StringType) :string:=
match s with
|error_string => ""
|strval s' => s'
end.
Definition stringeq (s1 s2:string) :bool:=
if(string_dec s1 s2) then true else false
.
Inductive beval : BExp -> Envs -> BoolType -> Prop :=
| e_true : forall sigma, btrue ={ sigma }=> true
| e_false : forall sigma, bfalse ={ sigma }=> false
| e_var : forall v sigma, bvar v ={ sigma }=> (boole ((gl sigma v) v))
| e_val : forall v sigma, boolean v ={sigma}=> v
| e_blt : forall a1 a2 i1 i2 v1 v2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = IntType_to_Z i1->
    v2 = IntType_to_Z i2->
    b = Z.ltb v1 v2 ->
    a1 <' a2 ={ sigma }=> b
| e_nottrue : forall b sigma,
    b ={ sigma }=> true ->
    (bnot b) ={ sigma }=> false
| e_notfalse : forall b sigma,
    b ={ sigma }=> false ->
    (bnot b) ={ sigma }=> true
| e_andtrue : forall b1 b2 sigma t,
    b1 ={ sigma }=> true ->
    b2 ={ sigma }=> t ->
    band b1 b2 ={ sigma }=> t
| e_andfalse : forall b1 b2 sigma,
    b1 ={ sigma }=> false ->
    band b1 b2 ={ sigma }=> false
| e_bgt : forall a1 a2 i1 i2 v1 v2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = IntType_to_Z i1->
    v2 = IntType_to_Z i2->
    b = Z.ltb v2 v1->
    a1 >' a2 ={ sigma }=> b
| e_ortrue :forall b1 b2 sigma,
    b1 ={ sigma }=> true ->
    bor b1 b2 ={ sigma }=> true
| e_orfalse : forall b1 b2 sigma t,
    b1 ={ sigma }=> false ->
    b2 ={ sigma }=> t ->
    bor b1 b2 ={ sigma }=> t
| e_blet : forall a1 a2 i1 i2 v1 v2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = IntType_to_Z i1->
    v2 = IntType_to_Z i2->
    b = Z.leb v1 v2 ->
    a1 <=' a2 ={ sigma }=> b
| e_bget : forall a1 a2 i1 i2 v1 v2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = IntType_to_Z i1->
    v2 = IntType_to_Z i2->
    b = Z.leb v2 v1 ->
    a1 <=' a2 ={ sigma }=> b
| e_xor_true_tf : forall b1 b2 sigma,
    b1 ={ sigma }=> true ->
    b2 ={ sigma }=> false ->
    bxor b1 b2 ={ sigma }=> true
| e_xor_true_ft : forall b1 b2 sigma,
    b1 ={ sigma }=> false ->
    b2 ={ sigma }=> true ->
    bxor b1 b2 ={ sigma }=> true
| e_xor_false : forall b1 b2 sigma t,
    b1 ={ sigma }=> t ->
    b2 ={ sigma }=> t ->
    bxor b1 b2 ={ sigma }=> false
| e_xand_true : forall b1 b2 sigma t,
    b1 ={ sigma }=> t ->
    b2 ={ sigma }=> t ->
    bxand b1 b2 ={ sigma }=> true
| e_xand_false_tf : forall b1 b2 sigma,
    b1 ={ sigma }=> true ->
    b2 ={ sigma }=> false ->
    bxand b1 b2 ={ sigma }=> false
| e_xand_false_ft : forall b1 b2 sigma,
    b1 ={ sigma }=> false ->
    b2 ={ sigma }=> true ->
    bxand b1 b2 ={ sigma }=> false
| e_beq : forall a1 a2 i1 i2 b v1 v2 sigma,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = IntType_to_Z i1->
    v2 = IntType_to_Z i2->
    b = Z.eqb v1 v2 ->
    a1 ==' a2 ={ sigma }=> b
| e_bneq_true: forall a1 a2 i1 i2 v1 v2 b sigma,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    v1 = IntType_to_Z i1->
    v2 = IntType_to_Z i2->
    b = ( orb ( Z.gtb v1 v2) ( Z.ltb v1 v2)) ->
    a1 !=' a2 ={ sigma }=> b
| e_bneq_false : forall a1 a2 t sigma,
    a1 =[ sigma ]=> t ->
    a2 =[ sigma ]=> t ->
    a1 !=' a2 ={sigma}=> false
| e_strcmp : forall s1 s2 s11 s22 sigma s,
    s1 -[ sigma ]-> s11 ->
    s2 -[ sigma ]-> s22 ->
    s = stringeq (StringType_to_string s11) (StringType_to_string s22) ->
    strcmp s1 s2  ={sigma}=> s
| e_tobol : forall v sigma,
    to_bool v ={ sigma }=> (boole (( gl sigma v) v))
| e_getvval_b : forall s n v l sigma,
    l= vect_list_b ((gl sigma s) s) ->
    v= vect_parse n l error_bool ->
    get_vval_b s n ={sigma}=>v
where "B ={ S }=> B'" := (beval B S B').

Definition get_def (l :cases): Stmt :=
match l with
| def d => d
| case n c => nullstmt
end.
Fixpoint list_cases_parse (n:nat) (l: list cases) : Stmt :=
match l with
| x::l' => match x with
              |def s => s
              |case n' s => if(Nat.eqb n' n) then s else list_cases_parse n l'
              end
| nil => nullstmt
end.

Reserved Notation "S -{ sigma }->  sigma'" (at level 60).
Check update.

Definition get_stmt (val:Val) :Stmt:=
match val with
| undecl => nullstmt
| unassign => nullstmt
| default => nullstmt
| number n => nullstmt
| integer i => nullstmt
| bol b => nullstmt
| str s => nullstmt
| vector v => nullstmt
| code l s => s
end.

Definition get_list (val : Val) : list string:=
match val with
| undecl => nil
| unassign => nil
| default => nil
| number n => nil
| integer i => nil
| bol b => nil
| str s => nil
| vector v => nil
| code l s => l
end.

Inductive eval : Stmt -> Envs -> Envs -> Prop :=
| e_def_nat: forall a i x sigma sigma',
    i=[sigma]=>x ->
    sigma' = (update_local sigma a x) ->
    (def_nat a i) -{ sigma }-> sigma'
| e_def_int: forall a i x sigma sigma',
    i=[sigma]=>x ->
    sigma' = (update_local sigma a x) ->
    (def_int a i) -{ sigma }-> sigma'
| e_def_bool: forall a i x sigma sigma',
    i={sigma}=>x ->
    sigma' = (update_local sigma a x ) ->
    (def_bool a i) -{ sigma }-> sigma'
| e_def_string: forall a i x sigma sigma',
    i-[sigma]->x ->
    sigma' = (update_local sigma a x) ->
    (def_string a i) -{ sigma }-> sigma'
| e_def_nat0: forall a sigma sigma' ,
    sigma' = (update_local sigma a unassign) ->
    (def_nat0 a) -{ sigma }-> sigma'
| e_def_int0: forall a sigma sigma',
    sigma' = (update_local sigma a unassign) ->
    (def_int0 a) -{ sigma }-> sigma'
| e_def_bool0: forall a sigma sigma',
    sigma' = (update_local sigma a unassign ) ->
    (def_bool0 a) -{ sigma }-> sigma'
| e_def_string0: forall a sigma sigma',
    sigma' = (update_local sigma a unassign) ->
    (def_string0 a) -{ sigma }-> sigma'
| e_def_vector_n: forall s n l sigma sigma',
    sigma' =(update_local sigma s (vector(vector_nat n l))) ->
    def_vector s (vector_nat n l) -{sigma}->sigma'
| e_def_vector_i: forall s n l sigma sigma',
    sigma' =(update_local sigma s (vector(vector_int n l)))->
    def_vector s (vector_int n l) -{sigma}->sigma'
| e_def_vector_b: forall s n l sigma sigma',
    sigma' =(update_local sigma s (vector(vector_bool n l)))->
    def_vector s (vector_bool n l) -{sigma}->sigma'
| e_def_vector_s: forall s n l sigma sigma',
    sigma' =(update_local sigma s (vector(vector_str n l)))->
    def_vector s (vector_str n l) -{sigma}->sigma'
| e_assignment: forall a i x sigma sigma',
    (negb (is_undecl((gl sigma a) a)))= true ->
    i =[sigma]=> x ->
    sigma' = (update_envs sigma a x) ->
    (assignment a i) -{ sigma }-> sigma'
| e_bassignment: forall a i x sigma sigma',
    (negb (is_undecl(( gl sigma a)a)))= true ->
    i ={sigma}=> x ->
    sigma' = (update_envs sigma a x) ->
    (bassignment a i) -{ sigma }-> sigma'
| e_sassignment: forall a i x sigma sigma',
    (negb (is_undecl((gl sigma a) a)))= true ->
    i -[sigma]-> x ->
    sigma' = (update_envs sigma a x) ->
    (sassignment a i) -{ sigma }-> sigma'
| e_seq : forall s1 s2 sigma sigma' sigma'',
    s1 -{ sigma }-> sigma' ->
    s2 -{ sigma' }-> sigma'' ->
    (sequence s1 s2) -{ sigma }-> sigma''
| e_whilefalse : forall b s sigma,
    b ={ sigma }=> false ->
    while b s -{ sigma }-> sigma
| e_whiletrue : forall b s sigma sigma',
    b ={ sigma }=> true ->
    (sequence s (while b s)) -{ sigma }-> sigma' ->
    while b s -{ sigma }-> sigma'
| e_iffalse1 : forall b s1 sigma,
    b ={ sigma }=> false ->
    ifthen b s1 -{ sigma }-> sigma
| e_iftrue1 : forall b s1 sigma sigma',
    b ={ sigma }=> true ->
    s1 -{ sigma }-> sigma' ->
    ifthen b s1 -{ sigma }-> sigma'
| e_iffalse2 : forall b s1 s2 sigma sigma',
    b ={ sigma }=> false ->
    s2 -{ sigma }-> sigma' ->
    ifthenelse b s1 s2 -{ sigma }-> sigma'
| e_iftrue2 : forall b s1 s2 sigma sigma',
    b ={ sigma }=> true ->
    s1 -{ sigma }-> sigma' ->
    ifthenelse b s1 s2 -{ sigma }-> sigma'
| e_for_false : forall a b st s1 sigma sigma',
    a -{ sigma }-> sigma' ->
    b ={ sigma' }=> false ->
    For a b st s1 -{ sigma }-> sigma'
| e_for_true : forall a b st s1 sigma sigma' sigma'',
    a -{ sigma }-> sigma' ->
    b ={ sigma' }=> true ->
    (sequence s1 (sequence st  (forcontent b st s1))) -{ sigma' }-> sigma'' ->
    For a b st s1 -{ sigma }-> sigma''
| e_forcontent_false : forall b st s1 sigma,
    b ={ sigma}=> false ->
    forcontent b st s1 -{ sigma }-> sigma
| e_forcontent_true : forall b st s1 sigma sigma',
    b ={ sigma }=> true ->
    (sequence s1 (sequence st (forcontent b st s1))) -{ sigma }-> sigma' ->
    forcontent b st s1 -{ sigma }-> sigma'
| e_dowhile_true : forall st b sigma sigma' sigma'',
    st -{ sigma }-> sigma' ->
    while b st -{ sigma' }-> sigma'' ->
    dowhile st b -{ sigma }-> sigma'
| e_dowhile_false : forall st b sigma sigma',
    st -{ sigma }-> sigma' ->
    b ={ sigma' }=> false ->
    dowhile st b -{ sigma }-> sigma'
| e_switch : forall a b sigma n v sigma',
    a =[ sigma ]=> n ->
    v = (list_cases_parse (abs_nat(IntType_to_Z n)) b ) ->
    v -{ sigma }-> sigma' ->
    switch a (b) -{ sigma }-> sigma'
| e_strcpy : forall s1 s2 sigma sigma' s2',
    s2' = (gl sigma s2) s2 ->
    sigma' = (update_envs sigma s1 s2') ->
    strcpy s1 s2 -{ sigma }-> sigma'
| e_getfunc : forall s l1 sigma sigma' st sigma'' sigma''' l sigma'''',
    l = (get_list ((get_globe sigma) s) ) ->
    length l = length l1 ->
    sigma'= (lists_parse_i l l1 sigma (pair (update_env (get_globe envs0) (get_globe sigma)) (get_local envs0))) ->
    st = get_stmt(get_globe sigma s) ->
    st -{ sigma'}-> sigma'' ->
    sigma''' =(update_env_g sigma sigma'') ->
    sigma'''' =(lists_parse_i l1 l sigma'' sigma''') ->
    get_func s l1 -{sigma}-> sigma''''
| e_null_stmt : forall sigma,
    nullstmt -{sigma}-> sigma
where "s -{ sigma }-> sigma'" := (eval s sigma sigma').

Reserved Notation "A =| sigma |=> B"(at level 0).
Inductive Leval : Lang -> Envs -> Envs -> Prop :=
| e_funcMain: forall s sigma sigma' sigma'',
    (is_undecl ((get_globe sigma) "main")) = true ->
    sigma' =(update_global sigma "main" (code nil s)) ->
    s -{sigma'}->sigma'' ->
    (funcMain s) =| sigma |=> sigma''
| e_funcs: forall s l st sigma sigma',
    (is_undecl ((get_globe sigma) "main")) ={sigma}=> true->
    sigma' = (update_global sigma s (code l st)) ->
    (funcs s l st) =|sigma|=>sigma'
| e_gdecl_int: forall s i x sigma sigma',
    i=[sigma]=>x ->
    sigma' = (update_global sigma s x) ->
    (gdecl_int s i) =|sigma|=> sigma'
| e_gdecl_nat:forall s i x sigma sigma',
    i=[sigma]=>x ->
    sigma' = (update_global sigma s x) ->
    (gdecl_nat s i) =|sigma|=> sigma'
| e_gdecl_str:forall s i x sigma sigma',
    i-[sigma]->x ->
    sigma' = (update_global sigma s x) ->
    (gdecl_str s i) =|sigma|=> sigma'
| e_gdecl_bool:forall s i x sigma sigma',
    i={sigma}=>x ->
    sigma' = (update_global sigma s x) ->
    (gdecl_bool s i) =|sigma|=> sigma'
| e_gdecl_int0:forall s sigma sigma',
    sigma' = (update_global sigma s unassign) ->
    (gdecl_int0 s) =|sigma|=> sigma'
| e_gdecl_nat0:forall s sigma sigma',
    sigma' = (update_global sigma s unassign) ->
    (gdecl_nat0 s) =|sigma|=> sigma
| e_gdecl_str0:forall s sigma sigma',
    sigma' = (update_global sigma s unassign) ->
    (gdecl_str0 s) =|sigma|=> sigma
| e_gdecl_bool0:forall s sigma sigma',
    sigma' = (update_global sigma s unassign) ->
    (gdecl_bool0 s) =|sigma|=> sigma
| e_secv:forall s1 s2 sigma sigma' sigma'',
    s1 =|sigma|=> sigma' ->
    s2 =|sigma'|=> sigma'' ->
    (secv s1 s2) =| sigma |=> sigma''
where "s =| sigma |=> sigma'" :=(Leval s sigma sigma').

Inductive EXP:=
| stre : STREXP -> EXP
| be : BExp -> EXP
| ae: AExp -> EXP
.
Definition interpret_strexp (e : STREXP) (env : Env):string:=
match e with
| svar s => s
| sconst s=> strng s
| strcat s1 s2=> concat s1 s2
| get_vval_s v n=> strng (vect_parse n (vect_list_s (env v) ) error_string)
| to_string s=> strng (env s)
end.
Fixpoint interpret_aexp (e : AExp) (env : Env) : Z :=
match e with
| avar s => integ (env s)
| anum n => Z_of_nat (NatType_to_nat n)
| aint i => IntType_to_Z i
| aplus a b => interpret_aexp a env + interpret_aexp b env
| asub a b => interpret_aexp a env - interpret_aexp b env
| amul a b => interpret_aexp a env * interpret_aexp b env
| adiv a b => interpret_aexp a env / interpret_aexp b env
| amod a b => Z.modulo (interpret_aexp a env) (interpret_aexp b env)
| apow a b =>  Z.pow (interpret_aexp a env) (interpret_aexp b env)
| to_nat s => integ ( ( natural ( env s) ) )
| to_int s => integ ( env s)
| get_vval_a v n=> IntType_to_Z (vect_parse n (vect_list_a ( env v) ) error_int )
| strlen s => Z_of_nat (length_str s)
end.
Fixpoint interpret_bexp (e : BExp) (env : Env):=
match e with
| btrue => true
| bfalse => false
| bvar b => boole(env b)
| bval b => boole b
| blessthan a1 a2 => Z.ltb(interpret_aexp a1 env) (interpret_aexp a2 env)
| bnot b=> (negb (interpret_bexp b env ) )
| band a b=> (interpret_bexp a env) && (interpret_bexp b env)
| bgreaterthan a1 a2=> Z.gtb (interpret_aexp a1 env) (interpret_aexp a2 env)
| bor a b=> (interpret_bexp a env) || (interpret_bexp b env)
| bxor a b=> xorb (interpret_bexp a env) (interpret_bexp b env)
| bxand a b=> negb (xorb (interpret_bexp a env) (interpret_bexp b env) )
| strcmp s1 s2=> if(string_dec (interpret_strexp s1 env) (interpret_strexp s2 env) ) then true else false
| blet a b=> Z.leb (interpret_aexp a env) (interpret_aexp b env)
| bget a b=> Z.geb (interpret_aexp a env) (interpret_aexp b env)
| beq a b=> Z.eqb (interpret_aexp a env) (interpret_aexp b env)
| bneq a b=> negb (Z.eqb (interpret_aexp a env) (interpret_aexp b env) )
| get_vval_b v n => boole ( vect_parse n  (vect_list_b (env v) ) error_bool)
| to_bool b => boole  (env b)
end.
(*Fixpoint interpret_stmt (e : Stmt) (env : Envs) : Envs :=
match e with
| def_nat s v => (update env s v)
| def_bool s v => (update env s v)
| def_int s v=> (update env s v)
| def_string s v=> (update env s v)
| def_nat0 s => (update env s v)
| def_bool0 s => (update env s unassign)
| def_int0 s => (update env s unassign)
| def_string0 s => (update env s unassign)
| def_vector s v =>(update env s v)
| assignment s v => (update env s v)
| bassignment s v=> (update env s v)
| sassignment s v => (update env s v)
| sequence s1 s2 => interpret_stmt s2 (interpret_stmt s1 env )
| ifthen b s => (interpret_stmt s env)
| ifthenelse b s1 s2 => if(b)then (interpret_stmt s env) else (interpret_stmt s env)
| For s1 b s2 st=> interpret_stmt forcontent (interpret_stmt s1 env)
| forcontent b st s=> for(nullstmt;b;s)interpret_stmt st env
| get_func s l=> interpret_stmt (get_stmt s) env
| break => env
| continue  => env
| switch i l => list_cases_parse
| read s => env
| write s => env
| strcpy s1 s2 => update_envs s1 (env s2)
| nullstmt => env
| while b s=> (interpret_stmt s env)
| dowhile s b=> (interpret_stmt (while b s) (interpret_stmt s env))
end.
Fixpoint interpret_lang (e : Lang) (env : Envs) : Envs :=
match e with
|funcMain s => interpret_stmt(s, env)
|funcs s l st => (update_envs env s (code l st))
| gdecl_int s v => (update_envs env s v)
| gdecl_nat s v => (update_envs env s v)
| gdecl_str s v => (update_envs env s v)
| gdecl_bool s v => (update_envs env s v)
| gdecl_int0 s =>(update_envs env s unassign)
| gdecl_nat0 s => (update_envs env s unassign)
| gdecl_str0 s => (update_envs env s unassign)
| gdecl_bool0 s => (update_envs env s unassign)
| secv s1 s2 => (interpret_lang s2 (interpret_lang s1 env) )
end.*)

Inductive Instruction :=
| push_const : Val -> Instruction
| push_var : string -> Instruction
| lt : Instruction
| gt : Instruction
| leqt: Instruction
| geqt: Instruction
| not: Instruction
| xand : Instruction
| xor : Instruction
| scmp : Instruction
| and : Instruction
| or : Instruction
| eq : Instruction
| neq : Instruction
| plus : Instruction
| sub : Instruction
| mul : Instruction
| inm : Instruction
| modulo : Instruction
| slen : Instruction
| power : Instruction
.
Definition Stack := list Val.

Definition string_eq (s1 s2:string): bool :=
if (string_dec s1 s2) then true else false.
Definition run_instruction (i : Instruction) (env : string -> Val) (stack : Stack) : Stack :=
  match i with
  | push_const c => ( c :: stack)
  | push_var x => ((env x) :: stack)
  | lt =>match stack with
           | n1 :: n2 :: stack' => bol (Z.ltb (integ n2) (integ n1)) :: stack'
           | _ => stack
           end
  | gt => match stack with
           | n1 :: n2 :: stack' => bol (Z.gtb ( integ n2) ( integ n1)) :: stack'
           | _ => stack
           end
  | leqt => match stack with
           | n1 :: n2 :: stack' => bol (Z.leb ( integ n2) ( integ n1)) :: stack'
           | _ => stack
           end
  | geqt=> match stack with
           | n1 :: n2 :: stack' => bol (Z.geb ( integ n2) ( integ n1)) :: stack'
           | _ => stack
           end
  | not =>match stack with
           |  b :: stack' => bol (negb (boole b) ) :: stack'
           | _ => stack
           end
  | xand =>match stack with
           |  b1 :: b2 :: stack' => bol (negb (xorb (boole b1) (boole b2))) :: stack'
           | _ => stack
           end
  | xor =>match stack with
           |  b1 :: b2 :: stack' => bol (xorb (boole b1) (boole b2) ) :: stack'
           | _ => stack
           end
  | scmp =>match stack with
           |  s1 :: s2 :: stack' => bol (string_eq (strng s1) (strng s2) ) :: stack'
           | _ => stack
           end
  | and =>match stack with
           | b1 :: b2 :: stack' => bol (andb (boole b1) (boole b2) ) :: stack'
           | _ => stack
           end
  | or =>match stack with
           | b1 :: b2 :: stack' => bol (orb (boole b1) (boole b2) ) :: stack'
           | _ => stack
           end
  | eq =>match stack with
           |  b1 :: b2 :: stack' => bol (Z.eqb (integ b1) (integ b2) ) :: stack'
           | _ => stack
           end
  | neq =>match stack with
           |  b1 :: b2 :: stack' => bol (negb (Z.eqb (integ b1) (integ b2))) :: stack'
           | _ => stack
           end
  | plus =>match stack with
           |  a1 :: a2 :: stack' => integer ((integ a1) + ( integ a2) ) :: stack'
           | _ => stack
           end
  | sub =>match stack with
           |  a1 :: a2 :: stack' => integer ((integ a2) - ( integ a1) ) :: stack'
           | _ => stack
           end
  | mul =>match stack with
           |  a1 :: a2 :: stack' => integer ((integ a2) * ( integ a1) ) :: stack'
           | _ => stack
           end
  | inm =>match stack with
           |   a1 :: a2 :: stack' => integer ((integ a2) / ( integ a1) ) :: stack'
           | _ => stack
           end
  | modulo =>match stack with
           |   a1 :: a2 :: stack' => integer (Z.modulo (integ a1) ( integ a2) ) :: stack'
           | _ => stack
           end
  | slen =>match stack with
           |   s :: stack' => integer (Z_of_nat (length_str (strng s))) :: stack'
           | _ => stack
           end
  |power =>match stack with
           |  a1 :: a2 :: stack' => integer ((integ a2) ^ ( integ a1) ) :: stack'
           | _ => stack
           end
  end.
Definition env0 := fun x => if string_dec x "x" then 10 else 0.
Check env0.
Compute (run_instruction (push_const 1012) env0 []).
Compute (run_instruction (push_var "x") env0 []).
Compute (run_instruction plus env0 [integer 10;integer 12;integer 20]).
Compute (run_instruction mul env0 [integer 10;integer 12;integer 20]).
Fixpoint run_instructions (is' : list Instruction)(env : string -> Val) (stack : Stack) : Stack :=
  match is' with
  | [] => stack
  | i :: is'' => run_instructions is'' env (run_instruction i env stack)
  end.

Definition pgm1 := [
                    push_const 19 ;
                    push_var "x" ;
                    lt
                  ].
Compute run_instructions pgm1 env0 [].
Definition pgm2 := [
                    push_const 19 ;
                    push_var "x" ;
                    plus;
                    push_var "x";
                    mul
                  ].
Compute run_instructions pgm2 env0 [].

Definition compile_str(e : STREXP) : list Instruction :=
 match e with
| svar s' =>[push_var s']
| sconst s' => [push_const s']
| strcat s1 s2 => []
| get_vval_s v n=> []
| to_string s'=> []
 end.
Fixpoint compile_aexp (e: AExp): list Instruction:=
 match e with
| avar a => [push_var a]
| anum n => [push_const n]
| aint i => [push_const i]
| aplus a b => (compile_aexp a) ++ (compile_aexp b) ++ [plus]
| asub a b => (compile_aexp a) ++ (compile_aexp b) ++ [sub]
| amul a b =>(compile_aexp a) ++ (compile_aexp b) ++ [mul]
| adiv a b =>(compile_aexp a) ++ (compile_aexp b) ++ [inm]
| amod a b =>(compile_aexp a) ++ (compile_aexp b) ++ [modulo]
| apow a b =>(compile_aexp a) ++ (compile_aexp b) ++ [power]
| to_nat n=> []
| to_int i=> []
| get_vval_a v n => []
| strlen s => (compile_str s) ++ [slen]
end.
Fixpoint compile (e : BExp) : list Instruction :=
  match e with
| btrue => [push_const true]
| bfalse => [push_const false]
| bvar b => [push_var b]
| bval b => [push_const b]
| blessthan a b => (compile_aexp a) ++ (compile_aexp b) ++ [lt]
| bnot b => (compile b) ++ [not]
| band a b => (compile a) ++ (compile b) ++ [and]
| bgreaterthan a b=> (compile_aexp a) ++ (compile_aexp b) ++ [gt]
| bor a b=> (compile a) ++ (compile b) ++ [or]
| bxor a b=> (compile a) ++ (compile b) ++ [xor]
| bxand a b=> (compile a) ++ (compile b) ++ [xand]
| strcmp s1 s2 => (compile_str s1 ) ++ (compile_str  s2) ++ [scmp]
| blet a b => (compile_aexp a) ++ (compile_aexp b) ++ [leqt]
| bget a b=> (compile_aexp a) ++ (compile_aexp b) ++ [geqt]
| beq a b=> (compile_aexp a) ++ (compile_aexp b) ++ [eq]
| bneq a b=> (compile_aexp a) ++ (compile_aexp b) ++ [neq]
| get_vval_b v n => []
| to_bool b => []
end.
Compute compile_aexp (2 +' (id "x")).
Compute compile_aexp (2 +' (id "x") *' 7).
Compute compile_aexp (2 *' (id "x") +' 7).
Compute interpret_aexp (2 *' (id "x") +' 7) env0.
Compute run_instructions
        (compile_aexp (2 *' (id "x") +' 7))
        env0
        [].
Lemma soundness_helper :
  forall e env stack is',
    run_instructions (compile_aexp e ++ is') env stack =
    run_instructions is' env (integer(interpret_aexp e env) :: stack).
Proof.
  induction e; intros; simpl; trivial.
  - rewrite <- app_assoc.
    rewrite <- app_assoc.

Notation "X ::= A" := (assignment X A ) (at level 50).
Notation "X :b:= A" := (bassignment X A ) (at level 50).
Notation "X :s:= A" := (sassignment X A ) (at level 50).
Notation "S1 ;; S2" := (sequence S1 S2) (at level 92).
Notation "'If' ( C ) 'then' { A } 'else' { B } 'end''" := (ifthenelse C A B) (at level 59).
Notation "'If' ( C ) 'then' { A } 'end''" := (ifthen C A) (at level 59).
Notation "'while'' ( A ) { B } " := (while A B) (at level 91).
Notation "'do' { A } 'while' ( B )" := (dowhile A B) (at level 91).
Notation "'for' ( A ; B ; C ) { D }" := (For A B C D) (at level 91).
Notation "'nat' A := B" := (def_nat A B)(at level 50).
Notation "'bool' A := B" := (def_bool A B)(at level 50).
Notation "'int' A := B" := (def_int A B)(at level 50).
Notation "'string' A := B" := (def_string A B)(at level 50).
Notation "'nat' A |" := (def_nat0 A )(at level 50).
Notation "'bool' A |" := (def_bool0 A )(at level 50).
Notation "'int' A |" := (def_int0 A )(at level 50).
Notation "'string' A |" := (def_string0 A )(at level 50).
Notation "'nat'' A := B" := (gdecl_nat A B)(at level 50).
Notation "'bool'' A := B" := (gdecl_bool A B)(at level 50).
Notation "'int'' A := B" := (gdecl_int A B)(at level 50).
Notation "'string'' A := B" := (gdecl_str A B)(at level 50).
Notation "'nat'' A |" := (gdecl_nat0 A )(at level 50).
Notation "'bool'' A |" := (gdecl_bool0 A )(at level 50).
Notation "'int'' A |" := (gdecl_int0 A)(at level 50).
Notation "'string'' A |" := (gdecl_str0 A )(at level 50).

Notation "'default' : { A }" := (def A) (at level 92).
Notation "'case' ( A ) : { B }" := (case A B) (at level 92).
Notation "'switch'' ( A ) : { B } " := (switch A (cons B nil)) (at level 93).
Notation "'switch'' ( A ) : { B1 ; B2 ; .. ; Bn }" := (switch A (cons B1 (cons B2 .. (cons Bn nil) ..))) (at level 93).
Notation "'(int)'  A  " := (to_int A)( at level 35).
Notation "'(nat)'  A " := (to_nat A)( at level 35).
Notation "'(bool)'  A " := (to_bool A)( at level 35).
Notation "'(string)'  A " := (to_string A)( at level 35).
Notation "'func'' main():{ C }" := (funcMain C )(at level 97).
Notation "'func'' A (( B1 ; B2 ; .. ; Bn )):{ C }" := (funcs A (cons B1 (cons B2 .. (cons Bn nil) ..)) C )(at level 97).
Notation "'func'' A (( B )):{ C }" := (funcs A (cons B nil) C )(at level 97).
Notation "A ';;'' B" := (secv A B)(at level 96).
Notation "'->' A (( B1 ; B2 ; .. ; Bn )) " := (get_func A (cons B1 (cons B2 .. (cons Bn nil) ..)))(at level 91).
Notation "'int' A [ B ]={ C1 ; C2 ; .. ; Cn }" := ( def_vector A ( vector_int B (cons int(C1) (cons int(C2) .. (cons int(Cn) nil) ..) ) ) )(at level 50).
Notation "'nat' A [ B ]={ C1 ; C2 ; .. ; Cn }" := ( def_vector A ( vector_nat B (cons nat(C1) (cons nat(C2) .. (cons nat(Cn) nil) ..) ) ) )(at level 50).
Notation "'bool' A [ B ]={ C1 ; C2 ; .. ; Cn }" := ( def_vector A ( vector_bool B (cons bool(C1) (cons bool(C2) .. (cons bool(Cn) nil) ..) ) ) )(at level 50).
Notation "'string' A [ B ]={ C1 ; C2 ; .. ; Cn }" := ( def_vector A ( vector_str B (cons string(C1) (cons string(C2) .. (cons string(Cn) nil) ..) ) ) )(at level 50).
Notation "'int' A [ B ]" := ( def_vector A ( vector_int B nil ) )(at level 50).
Notation "'nat' A [ B ]" := ( def_vector A ( vector_nat B nil ) )(at level 50).
Notation "'bool' A [ B ]" := ( def_vector A ( vector_bool B nil ) )(at level 50).
Notation "'string' A [ B ]" := ( def_vector A ( vector_str B nil ) )(at level 50).

Notation "A a[ B ]" :=(get_vval_a A B)(at level 51).
Notation "A s[ B ]" :=(get_vval_s A B)(at level 51).
Notation "A b[ B ]" :=(get_vval_b A B)(at level 51).

Compute switch' (5) : {case (1): {If(1=='1) then {nat "AA" := 7} else {int "BB" := 7} end'} ; case(2): {If(1=='1) then {int "CC":= 13}end'} ; default : {bool "3" := true}}.
Compute int "ASD" [50]={ -1 ; 2 ; -3 }.
Compute nat "ASD"[50]={ 1 ; 2 ; 3 }.
Compute bool "ASD"[50]={ true ; false ; true }.
Compute string "ASD"[50]={ "1" ; "2" ; "3" }.
Compute nat "ASD"[50].
Compute "ASD"a[50].
Compute func' main():{ If( 1=='1) then { "x" ::= 3 } end' }.
Compute func' "test" (( "text1" )):{
           If ( 1 ==' 1 ) then
              { "text1" :s:= string( "test" ) } end' } .
Compute func' "test" (( "text1" ; "text2" )):{
          If ( 1 ==' 1 ) then
            { -> "test" (( "text1" ; "text2" ))
            } end' ;;
            string "QWE"[55]
          } ;;'
          int' "x" := 5 ;;'
          func' main():{
          If( 1=='1) then
            { "x" ::= 3 ;; int "y" | ;; int "j" := 7 ;; -> "test" (("x" ; "y"));; string "u" :=(string) "j" }
            end'
          }.

Definition alg1 :=
  func' "test" (("abc"; "bcd"; "aac")):{
    "abc" ::= 3;;
    "bcd" ::= 40 ;;
    "aac" ::= 60 ;;
    "x" ::=55
  } ;;'
  int' "n" := 1 ;;'
  int' "x" := 0 ;;'
  func' main():{
  int "i" := 1 ;;
  int "sum" := 0 ;;
  If ( "i" <=' "n" ) then {
          "sum" ::= "sum" +' "i" ;;
          "i" ::= "i" +' 1
        }
  else {
    "sum" ::= "sum" +' 50 ;;
    "i" ::= "i" +' 15 ;;
    "x" ::= "sum" /' "i" ;;
    string "qeq" := string("abc");;
    string "eqe" := string("ddf");;
    string "aaaa" := strcat("qeq", "eqe")
  }
  end';;
  -> "test" (("n" ; "sum" ; "i"))
}.
Check func' "test" (("abc"; "bcd"; "aac")):{
    "abc" ::= 3;;
    "bcd" :s:= "sss"
  }.
Example eval_alg1 :
  exists state,
  alg1 =| envs0 |=> state /\ (gl state "x")"x" = 55.
Proof.
eexists.
split.
  - unfold alg1. eapply e_secv. eapply e_secv. eapply e_secv.
  + eapply e_funcs; eauto.  simpl. eapply e_val;eauto.
  + eapply e_gdecl_int;eauto. eapply const_int.
  + eapply e_gdecl_int;eauto. eapply const_int.
  + eapply e_funcMain; eauto. simpl. eapply e_seq.
    ++ eapply e_seq. eapply e_seq.
      eapply e_def_int; eauto. eapply const_int.
      eapply e_def_int; eauto. eapply const_int.
      eapply e_iftrue2.
        +++ eapply e_blet; eauto.
            ++++ eapply var.
            ++++ eapply var.
            ++++ trivial.
        +++ eapply e_seq.
            ++++ eapply e_assignment; eauto. simpl. eapply add; eauto. eapply var. eapply var; eauto.
            ++++ eapply e_assignment; eauto.
               +++++ simpl. eapply add. eapply var; eauto.  eapply const_int; eauto. trivial. trivial. simpl. trivial.
    ++ eapply e_getfunc; eauto. simpl. eapply e_seq; eauto. eapply e_seq; eauto.
    eapply e_seq. eapply e_assignment; eauto. simpl. eapply const_int. eapply e_assignment;
    eauto. simpl. eapply const_int. eapply e_assignment; eauto. simpl. eapply const_int.
    eapply e_assignment; eauto. eapply const_int.
-  simpl. unfold update_env. simpl. unfold update. simpl. reflexivity.
Qed.
Definition alg2 :=

func' main():{
int "y"[50]={1 ;2 ;3} ;;
int "a" := ("y"a[0]) ;;
switch' ("a"):{
    case (1):{
       If(1=='1) then {nat "AA" := 7}
        else {int "BB" := 7} end'
    } ;
    case(2): {
       If(1=='1) then {int "CC":= 13}end'
    } ;
    default : {bool "3" := true}
  };;
  bool "ghi" := (bool)"a" ;;
  do {
  "a"::="a" +' 1
  } while("a"<' 2) ;;
  "ghi" :b:= ("ghi" xor' true)
}.
Example eval_alg2 :
  exists state,
  alg2 =| envs0 |=> state /\ (gl state "AA")"AA" = 7 /\ (gl state "ghi")"ghi" = false.
Proof.
eexists.
split.
unfold alg2.
- eapply e_funcMain; eauto. eapply e_seq. eapply e_seq. eapply e_def_vector_i; eauto.
eapply e_def_int; eauto. eapply e_getvval_a; eauto. eapply e_seq. eapply e_seq.
eapply e_seq. eapply e_switch; eauto. eapply var. unfold list_cases_parse. simpl.
eapply e_iftrue2. eapply e_beq;eauto. eapply const_int. eapply const_int.
trivial. eapply e_def_nat;eauto. eapply const_int. eapply e_def_bool;eauto. eapply e_tobol.
eapply e_dowhile_false;eauto. eapply e_assignment;eauto. simpl. eapply add;eauto. eapply var. eapply const_int.
eapply e_blt;eauto. eapply var. eapply const_int. simpl. trivial. eapply e_bassignment;eauto.
eapply e_xor_false; eauto. eapply e_var. simpl.  eapply e_val.
- simpl. unfold update. simpl. split. trivial. trivial.
Qed.