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.


Require Import CPidgin.Control.Applicative.
Require Import CPidgin.Control.Functor.
Require Import CPidgin.Control.Monad.

Module Either.

Import Applicative.
Import Functor.
Import Monad.

(* The Either inductive type describes a disjunctive value. *)
Inductive Either (A B : Type) : Type :=
    | Left : A -> Either A B
    | Right : B -> Either A B.

(* The implicit type A maps to the Left type. *)
Arguments Left {A B} _ , [A] B _.
(* The implicit type B maps to the Right type. *)
Arguments Right {A B} _ , A [B] _.

(* The Either inductive type can be mapped to an Applicative functor space,   *)
(* in which operations on Either values can be mapped back to operations on   *)
(* regular values. *)
Instance eitherApplicative (e: Type) : Applicative (Either e) := {
    pure t x := Right x;
    app a b af ax :=
        match af with
            Left e => Left e
          | Right f =>
                match ax with
                    Left e => Left e
                  | Right x => Right (f x)
                end
        end
}.

(* The Either inductive type can be mapped to a Functor space in which        *)
(* functions are either executed on values or map to a left error value.      *)
Instance eitherFunctor (e: Type) : Functor (Either e) := {
    fmap a b f ax :=
        match ax with
            Left e => Left e
          | Right x => Right (f x)
        end
}.

(* The Either inductive type can be mapped to a Monad space in which          *)
(* computations on optional values can be short-circuited if these values do  *)
(* not exist. *)
Instance eitherMonad (e: Type) : Monad (Either e) := {
    mret t x := Right x;
    bind a b m f :=
        match m with
            Left x => Left x
          | Right y => f y
        end
}.

End Either.


From oadt.lang_oadt Require Import base syntax.
Import syntax.notations.

Implicit Types (b : bool).

(** * Definitions *)

(** ** Weak values *)
Inductive wval : expr -> Prop :=
| WLit b : wval <{ lit b }>
| WPair v1 v2 : wval v1 -> wval v2 -> wval <{ (v1, v2) }>
| WAbs l τ e : wval <{ \:{l}τ => e }>
| WInj b τ v : wval v -> wval <{ inj@b<τ> v }>
| WFold X v : wval v -> wval <{ fold<X> v }>
| WIte b v1 v2 :
    wval v1 -> wval v2 ->
    wval <{ ~if [b] then v1 else v2 }>
| WOVal v : oval v -> wval v
.

(** ** Weak oblivious values *)
Inductive woval : expr -> Prop :=
| OWIte b v1 v2 :
    woval v1 -> woval v2 ->
    woval <{ ~if [b] then v1 else v2 }>
| OWOVal v : oval v -> woval v
.

(** ** OADT value typing *)
(** [ovalty v ω] means [v] is an oblivious value of oblivious type value [ω].
This is essentially a subset of [typing], but we have it so that the dynamic
semantics does not depend on typing. *)
Inductive ovalty : expr -> expr -> Prop :=
| OTUnit : ovalty <{ () }> <{ 𝟙 }>
| OTOBool b : ovalty <{ [b] }> <{ ~𝔹 }>
| OTProd v1 v2 ω1 ω2 :
    ovalty v1 ω1 -> ovalty v2 ω2 ->
    ovalty <{ ~(v1, v2) }> <{ ω1 ~* ω2 }>
| OTOSum b v ω1 ω2 :
    ovalty v <{ ite b ω1 ω2 }> ->
    (* Make sure the unused oblivious type is a value. *)
    otval <{ ite b ω2 ω1 }> ->
    ovalty <{ [inj@b<ω1 ~+ ω2> v] }> <{ ω1 ~+ ω2 }>
.

(** ** Evaluation context (ℇ) *)
(* This style is inspired by Iron Lambda. Maybe I should try other encoding
style later. This one can be quite annoying for proof automation. *)
(** We define evaluation context [ℇ] as the hole-filling function. [ℇ e] fills
the hole in [ℇ] with [e]. [ectx ℇ] asserts that [ℇ] is a well-formed
context. *)
Variant ectx : (expr -> expr) -> Prop :=
| CtxProd1 τ2 : ectx (fun τ1 => <{ τ1 ~* τ2 }>)
| CtxProd2 ω1 : otval ω1 -> ectx (fun τ2 => <{ ω1 ~* τ2 }>)
| CtxOSum1 τ2 : ectx (fun τ1 => <{ τ1 ~+ τ2 }>)
| CtxOSum2 ω1 : otval ω1 -> ectx (fun τ2 => <{ ω1 ~+ τ2 }>)
| CtxApp1 e2 : ectx (fun e1 => <{ e1 e2 }>)
| CtxApp2 v1 : wval v1 -> ectx (fun e2 => <{ v1 e2 }>)
| CtxTApp X : ectx (fun e => <{ X@e }>)
| CtxLet e2 : ectx (fun e1 => <{ let e1 in e2 }>)
| CtxSec : ectx (fun e => <{ s𝔹 e }>)
| CtxIte e1 e2 : ectx (fun e0 => <{ if e0 then e1 else e2 }>)
| CtxOIte1 e1 e2 : ectx (fun e0 => <{ ~if e0 then e1 else e2 }>)
| CtxOIte2 v0 e2 : wval v0 -> ectx (fun e1 => <{ ~if v0 then e1 else e2 }>)
| CtxOIte3 v0 v1 : wval v0 -> wval v1 -> ectx (fun e2 => <{ ~if v0 then v1 else e2 }>)
| CtxPair1 l e2 : ectx (fun e1 => <{ (e1, e2){l} }>)
| CtxPair2 l v1 : wval v1 -> ectx (fun e2 => <{ (v1, e2){l} }>)
| CtxProj l b : ectx (fun e => <{ π{l}@b e }>)
| CtxInj b τ : ectx (fun e => <{ inj@b<τ> e }>)
| CtxOInj1 b e : ectx (fun τ => <{ ~inj@b<τ> e }>)
| CtxOInj2 b ω : otval ω -> ectx (fun e => <{ ~inj@b<ω> e }>)
| CtxCase e1 e2: ectx (fun e0 => <{ case e0 of e1 | e2 }>)
| CtxOCase e1 e2: ectx (fun e0 => <{ ~case e0 of e1 | e2 }>)
| CtxFold X : ectx (fun e => <{ fold<X> e }>)
| CtxUnfold X : ectx (fun e => <{ unfold<X> e }>)
| CtxTape : ectx (fun e => <{ tape e }>)
| CtxMux1 e1 e2 : ectx (fun e0 => <{ mux e0 e1 e2 }>)
| CtxMux2 v0 e2 : wval v0 -> ectx (fun e1 => <{ mux v0 e1 e2 }>)
| CtxMux3 v0 v1 : wval v0 -> wval v1 -> ectx (fun e2 => <{ mux v0 v1 e2 }>)
.

(** The evaluation context enclosing possibly leaking expressions. *)
Variant lectx : (expr -> expr) -> Prop :=
| LCtxApp v2 : wval v2 -> lectx (fun e1 => <{ e1 v2 }>)
| LCtxSec : lectx (fun e => <{ s𝔹 e }>)
| LCtxIte e1 e2 : lectx (fun e0 => <{ if e0 then e1 else e2 }>)
| LCtxProj b : lectx (fun e => <{ π@b e }>)
| LCtxCase e1 e2: lectx (fun e0 => <{ case e0 of e1 | e2 }>)
| LCtxUnfold X : lectx (fun e => <{ unfold<X> e }>)
.

(** ** Small-step relation *)
Section step.

Context (Σ : gctx).

Reserved Notation "e '-->!' e'" (at level 40).

Inductive step : expr -> expr -> Prop :=
| SApp l τ e v :
    wval v ->
    <{ (\:{l}τ => e) v }> -->! <{ e^v }>
| STApp X τ' τ v :
    wval v ->
    Σ !! X = Some (DOADT τ' τ) ->
    <{ X@v }> -->! <{ τ^v }>
| SFun x T e :
    Σ !! x = Some (DFun T e) ->
    <{ gvar x }> -->! <{ e }>
| SLet v e :
    wval v ->
    <{ let v in e }> -->! <{ e^v }>
| SSec b :
    <{ s𝔹 b }> -->! <{ [b] }>
| SIte b e1 e2 :
    <{ if b then e1 else e2 }> -->! <{ ite b e1 e2 }>
| SProj l b v1 v2 :
    wval v1 -> wval v2 ->
    <{ π{l}@b (v1, v2){l} }> -->! <{ ite b v1 v2 }>
| SOInj b ω v :
    otval ω -> oval v ->
    <{ ~inj@b<ω> v }> -->! <{ [inj@b<ω> v] }>
| SCase b τ v e1 e2 :
    wval v ->
    <{ case inj@b<τ> v of e1 | e2 }> -->! <{ ite b (e1^v) (e2^v) }>
(* One of the most interesting rules. *)
| SOCase b ω1 ω2 v e1 e2 v1 v2 :
    oval v ->
    ovalty v1 ω1 -> ovalty v2 ω2 ->
    <{ ~case [inj@b<ω1 ~+ ω2> v] of e1 | e2 }> -->!
      <{ ~if [b] then (ite b (e1^v) (e1^v1)) else (ite b (e2^v2) (e2^v)) }>
| SUnfold X X' v :
    wval v ->
    <{ unfold<X> (fold <X'> v) }> -->! v
| SMux b v1 v2 :
    wval v1 -> wval v2 ->
    <{ mux [b] v1 v2 }> -->! <{ ite b v1 v2 }>
| STapeOIte b v1 v2 :
    woval v1 -> woval v2 ->
    <{ tape (~if [b] then v1 else v2) }> -->! <{ mux [b] (tape v1) (tape v2) }>
(* [tape v] is a no-op if [v] is an oblivious value. *)
| STapeOVal v :
    oval v ->
    <{ tape v }> -->! <{ v }>
| SOIte b v1 v2 ℇ :
    lectx ℇ ->
    wval v1 -> wval v2 ->
    ℇ <{ ~if [b] then v1 else v2 }> -->! <{ ~if [b] then ,(ℇ v1) else ,(ℇ v2) }>
(* Step under evaluation context *)
| SCtx ℇ e e' :
    ectx ℇ ->
    e -->! e' ->
    ℇ e -->! ℇ e'

where "e '-->!' e'" := (step e e').

End step.

(** * Notations *)
Module notations.

Notation "Σ '⊨' e '-->!' e'" := (step Σ e e') (at level 40,
                                                e custom oadt at level 99,
                                                e' custom oadt at level 99).

Notation "Σ '⊨' e '-->*' e'" := (rtc (step Σ) e e')
                                  (at level 40,
                                   e custom oadt at level 99,
                                   e' custom oadt at level 99).

Notation "Σ '⊨' e '-->{' n '}' e'" := (nsteps (step Σ) n e e')
                                        (at level 40,
                                         e custom oadt at level 99,
                                         n constr at level 99,
                                         e' custom oadt at level 99,
                                         format "Σ  '⊨'  e  '-->{' n '}'  e'").

Notation "e '-->!' e'" := (step _ e e') (at level 40).

Notation "e '-->*' e'" := (rtc (step _) e e') (at level 40).

Notation "e '-->{' n '}' e'" := (nsteps (step _) n e e') (at level 40).

End notations.


Require Export BisimRefinement.TraceMonad.

(* An (St1,St2)-bisimulation permission is:

  1. The ability to read either St1 or St2 as an element of the other type,
     given by the relation R between the two types that intuitively describes
     the "information" you get from reading St1 as an St2 by describing the set
     of elements St2 you "see" when reading a particular element of St1; AND

  2. The ability to update either St1 or St2, given by a preorder on (St1 * St2)
     that describes the allowed updates to St1 along with corresponding updates
     to St2 that have to be made to "match" those updates to St1.

 *)
Record BPerm St1 St2 `{LR St1} `{LR St2} : Type :=
  {
    bperm_R : St1 -> St2 -> Prop;
    bperm_upd : relation (St1 * St2);

    proper_bperm_R : Proper (lr_equiv ==> lr_equiv ==> lr_equiv) bperm_R;
    proper_bperm_upd : Proper (lr_equiv ==> lr_equiv ==> lr_equiv) bperm_upd;
    preorder_bperm_upd : PreOrder bperm_upd;
  }.

Arguments bperm_R {St1 St2 _ _}.
Arguments bperm_upd {St1 St2 _ _}.

Instance Proper_bperm_R_equiv St1 St2 `{LR St1} `{LR St2} (bperm: BPerm St1 St2) :
  Proper (lr_equiv ==> lr_equiv ==> lr_equiv) (bperm_R bperm) :=
  proper_bperm_R _ _ _.

Instance Proper_bperm_R St1 St2 `{LR St1} `{LR St2} (bperm: BPerm St1 St2) :
  Proper (lr_equiv ==> lr_equiv ==> Basics.impl) (bperm_R bperm).
Proof.
  intros st1 st1' eq1 st2 st2' eq2 R12.
  apply (proper_bperm_R _ _ bperm st1 st1' eq1 st2 st2' eq2). assumption.
Qed.

Instance Proper_bperm_upd_equiv St1 St2 `{LR St1} `{LR St2} (bperm: BPerm St1 St2) :
  Proper (lr_equiv ==> lr_equiv ==> lr_equiv) (bperm_upd bperm) :=
  proper_bperm_upd _ _ _.

Instance Proper_bperm_upd St1 St2 `{LR St1} `{LR St2} (bperm: BPerm St1 St2) :
  Proper (lr_equiv ==> lr_equiv ==> Basics.impl) (bperm_upd bperm).
Proof.
  intros st1 st1' eq1 st2 st2' eq2 R12.
  apply (proper_bperm_upd _ _ bperm st1 st1' eq1 st2 st2' eq2). assumption.
Qed.

Instance PreOrder_bperm_upd St1 St2 `{LR St1} `{LR St2} (bperm: BPerm St1 St2) :
  PreOrder (bperm_upd bperm) := preorder_bperm_upd _ _ _.

(***
 *** Examples of Bisimulation Perms
 ***)

(* The trivial permission, that does not allow any updates *)
Program Definition trivial_bperm {St1 St2} `{LR St1} `{LR St2} : BPerm St1 St2 :=
  {|
    bperm_R st1 st2 := True;
    bperm_upd := lr_equiv;
  |}.
Next Obligation.
  intros st1 st1' eq1 st2 st2' eq2. reflexivity.
Defined.

(* Conjoin two permissions building the permission that allows updates from
either permission *)
Program Definition conjoin_bperms {St1 St2} `{LR St1} `{LR St2}
        (bperm1 bperm2: BPerm St1 St2) : BPerm St1 St2 :=
  {|
    bperm_R st1 st2 := bperm_R bperm1 st1 st2 /\ bperm_R bperm2 st1 st2;
    bperm_upd :=
      clos_refl_trans
        _ (fun st12 st12' =>
             bperm_upd bperm1 st12 st12' \/ bperm_upd bperm2 st12 st12');
  |}.
Next Obligation.
  intros st1 st1' eq1 st2 st2' eq2. rewrite eq1. rewrite eq2. reflexivity.
Defined.
Next Obligation.
  intros st1 st1' eq1 st2 st2' eq2.
  (*
  split; intro R12; induction R12.
  - apply rt_step. destruct H1; [ left | right ].
    + eapply Proper_bperm_upd; try symmetry; try eassumption.
    + eapply Proper_bperm_upd; try symmetry; try eassumption.
  - apply rt_step. left. eapply Proper_bperm_upd; try symmetry; try eassumption.
    reflexivity.
  - *)
  admit. (* FIXME HERE *)
Admitted.
Next Obligation.
  constructor.
  - intro. constructor. left; reflexivity.
  - intros st1 st2 st3 upd12 upd23.
    eapply rt_trans; eassumption.
Defined.

(* Composition of permissions *)
Program Definition compose_bperms {St1 St2 St3} `{LR St1} `{LR St2} `{LR St3}
        (bperm1: BPerm St1 St2) (bperm2: BPerm St2 St3) : BPerm St1 St3 :=
  {|
    bperm_R st1 st3 :=
      exists st2, bperm_R bperm1 st1 st2 /\ bperm_R bperm2 st2 st3;
    bperm_upd st13 st13' :=
      forall st2, exists st2',
          bperm_upd bperm1 (fst st13, st2) (fst st13', st2') /\
          bperm_upd bperm2 (st2, snd st13) (st2', snd st13')
  |}.
Next Obligation.
  intros st1 st1' eq1 st3 st3' eq3.
  split; intros [ st2 [ R12 R23 ]]; exists st2.
  - rewrite <- eq1; rewrite <- eq3. split; assumption.
  - rewrite eq1; rewrite eq3. split; assumption.
Defined.
Next Obligation.
  intros st13_1 st13_1' eq1 st13_2 st13_2' eq2.
  split; intros R_12 st2; destruct (R_12 st2) as [ st2' [R12 R23]]; exists st2'.
  - split; rewrite <- eq1; rewrite <- eq2; assumption.
  - split; rewrite eq1; rewrite eq2; assumption.
Defined.
Next Obligation.
  constructor.
  - intros st13 st2. exists st2. split; reflexivity.
  - intros st_1 st_2 st_3 R12 R23 st2.
    destruct (R12 st2) as [ st2' [R12_1 R12_2]].
    destruct (R23 st2') as [ st2'' [R23_1 R23_2]].
    exists st2''. split; etransitivity; eassumption.
Defined.

(* A lens is a BPerm, where get defines the read and put defines the update. Get
goes from left (the "bigger" type) to right (the "smaller" type) *)
Program Definition lens_bperm {St1 St2} `{LR St1} `{LR St2} (l: Lens St1 St2) :
  BPerm St1 St2 :=
  {|
    bperm_R st1 st2 := getL l st1 =lr= st2;
    bperm_upd st12 st12' :=
      (* This says we can change the smaller type any way at all, while we can
      only change the bigger type using put *)
      (exists st2, putL l st2 (fst st12) =lr= fst st12');
  |}.
Next Obligation.
  intros st1 st1' eq1 st2 st2' eq2. rewrite eq1. rewrite eq2. reflexivity.
Defined.
Next Obligation.
  intros st1 st1' eq1 st2 st2' eq2.
  split; intros [ st2'' eq_fst ]; exists st2'';
    [ rewrite <- eq1; rewrite <- eq2 | rewrite eq1; rewrite eq2 ];
    assumption.
Defined.
Next Obligation.
  constructor.
  - intros [ st1 st2 ]. exists (getL l st1). apply lens_get_put.
  - intros [ st1_1 st2_1 ] [ st1_2 st2_2 ] [ st1_3 st2_3 ]
           [st2_12 eq12] [st2_23 eq23].
    exists st2_23. rewrite <- eq12 in eq23. etransitivity; [ | apply eq23 ].
    rewrite lens_put_put. reflexivity.
Defined.

(***
 *** Separability of Permissions
 ***)

Definition bperms_separable {St1 St2} `{LR St1} `{LR St2}
           (bperm1 bperm2: BPerm St1 St2) : Prop :=
  (* Updates with bperm2 do not mess up the R of bperm1 *)
  (forall st1 st2 st1' st2',
      bperm_R bperm1 st1 st2 ->
      bperm_upd bperm2 (st1,st2) (st1',st2') ->
      bperm_R bperm1 st1' st2')
  /\
  (* Updates with bperm1 do not mess up the R of bperm2 *)
  (forall st1 st2 st1' st2',
      bperm_R bperm2 st1 st2 ->
      bperm_upd bperm1 (st1,st2) (st1',st2') ->
      bperm_R bperm2 st1' st2')
  /\
  (* The updates commute with each other *)
  (forall st1 st2 st1' st2',
      (exists st1'' st2'',
          bperm_upd bperm1 (st1,st2) (st1'',st2'') /\
          bperm_upd bperm2 (st1'',st2'') (st1',st2'))
      <->
      (exists st1'' st2'',
          bperm_upd bperm2 (st1,st2) (st1'',st2'') /\
          bperm_upd bperm1 (st1'',st2'') (st1',st2'))).

(* FIXME HERE: lemmas about permissions that are separable *)


Require Export Iron.Language.SystemF2Effect.Step.Frame.
Require Export Iron.Language.SystemF2Effect.Store.Bind.

(* Store typing models the store.
   All types in the store typing have a corresponding binding in the store.
   We don't want entries in the store typing that don't have corresponding
   bindings in the store. *)
Definition StoreM (se: stenv) (ss: store)
 := length se = length ss.
Hint Unfold StoreM.

(* Extended store environment models the extended store *)
Lemma storeM_snoc
 :  forall se ss t stv
 ,  StoreM se ss
 -> StoreM (t <: se) (stv <: ss).
Proof.
 intros.
 unfold StoreM.
 have (length se = length ss).
 burn.
Qed.
Hint Resolve storeM_snoc.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From QuickChick Require Import QuickChick.
From adtind Require Import goal50.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (not (@eq natural (Zero) (Zero))).
Admitted.
QuickChick lfind_hyp_test.


Require Import Iron.Language.SystemF2Data.Exp.
Require Import Iron.Language.SystemF2Data.Step.Step.

(********************************************************************)
(* If we have a well typed case match on a data object then there
   is a case alternative corresponding to that data constructor *)
Lemma getAlt_has
 :  forall ds dc ts xs alts t
 ,  DEFSOK ds
 -> TYPE ds nil nil (XCase (XCon dc ts xs) alts) t
 -> (exists x, getAlt dc alts = Some (AAlt dc x)).
Proof.
 intros.
 eapply getAlt_exists.
 inverts_type.
 norm.
 eapply H8.
 have (getCtorOfType (TCon tc) = Some tc) as HC.
 erewrite getCtorOfType_makeTApps in H5; eauto.
 inverts H5.
 eauto.
Qed.
Hint Resolve getAlt_has.

(* Well typed primitives applied to values can always progress. *)
Lemma progress_prim
 :  forall ds p tsArg tResult xs
 ,  primDef p = DefPrim tsArg tResult
 -> Forall2 (TYPE ds nil nil) xs tsArg
 -> Forall  wnfX xs
 -> (exists x, STEP (XPrim p xs) x).
Proof.
 intros.
 destruct p.

 - Case "PAdd".
   snorm. inverts H.
   inverts H0. inverts H5. inverts H6.
   eapply value_form_nat in H4.
   + destruct H4 as [n]. subst.
     eapply value_form_nat in H3.
     * destruct H3 as [n']. subst.
       exists (XLit (LNat (n + n'))).
       eauto.
     * have (closedX x0).
       eauto.
   + have (closedX x).
     eauto.

 - Case "PIsZero".
   snorm. inverts H.
   inverts H0. inverts H5.
   eapply value_form_nat in H4.
   + destruct H4 as [n]. subst.
     exists (XLit (LBool (beq_nat n 0))).
     eauto.
   + have (closedX x).
     eauto.
Qed.
Hint Resolve progress_prim.

(********************************************************************)
(* A well typed expression is either a well formed value,
   or can transition to the next state. *)
Theorem progress
 :  forall ds x t
 ,  DEFSOK ds
 -> TYPE ds nil nil x t
 -> value x \/ (exists x', STEP x x').
Proof.
 intros. gen t.
 induction x using exp_mutind with
  (PA := fun a => a = a);
   intros.

 (*************************************)
 - Case "XVar".
   (* Variables aren't values. *)
   nope.

 (*************************************)
 - Case "XLAM".
   (* Closed type abstractions are already values. *)
   left. apply type_wfX in H0. auto.

 (*************************************)
 - Case "XAPP".
   inverts keep H0.
   edestruct IHx. eauto.

   (* If the function part of a type application is a value then
      is can only step if it is a type abstraction. *)
   + SCase "x value".
     right.
     inverts H1.
     inverts H3; try nope.
     (* The function part is a type abstraction,
        so we can do the substitution. *)
     * SSCase "x = XLAM".
       exists (substTX 0 t2 x1).
       eapply EsLAMAPP.

     (* Can't happen, fully applied data constructors never have
        quantified types. *)
     * SSCase "x = XCon".
       inverts_type.
       have (takeTCon (TCon tc0) = takeTCon (TForall t0))
        by (eapply makeTApps_takeTCon; eauto).
       snorm. nope.

     (* Can't happen, literals never have quantified types. *)
     * SSCase "x = XLit".
       destruct l0; snorm; congruence.

   (* The function part can take a step. *)
   + SCase "x steps".
     right.
     dest x'.
     exists (XAPP x' t2).
     lets D: EsContext XcAPP H1.
     eauto.

 (*************************************)
 (* Closed function abstractions are already values. *)
 - Case "XLam".
   left.
   eapply type_wfX in H0. auto.

 (*************************************)
 - Case "XApp".
   right.
   inverts_type.
   edestruct IHx1; eauto.
   + SCase "value x1".
     edestruct IHx2; eauto.
     * SSCase "value x2".
       have (exists t x, x1 = XLam t x) as HF.
       destruct HF as [t11].
       destruct H2 as [x12].
       subst.
       exists (substXX 0 x2 x12).
       apply EsLamApp; eauto.

     * SSCase "x2 steps".
       destruct H1 as [x2'].
       exists (XApp x1 x2'). auto.

   + SCase "x1 steps".
     destruct H0  as [x1'].
     exists (XApp x1' x2).
     eapply (EsContext (fun xx => XApp xx x2)); auto.

 (*************************************)
 - Case "XCon".
   inverts_type.

   (* All ctor args are either wnf or can step. *)
   assert (Forall (fun x => wnfX x \/ (exists x', STEP x x')) xs) as HWS.
   { repeat nforall. intros.
     have (exists t, TYPE ds nil nil x t).
     destruct H2 as [t'].
     have (value x \/ (exists x', STEP x x')).
     intuition.
   }

   (* All ctor args are wnf, or there is a context where one can step *)
   lets D: (@exps_ctx_run exp exp) HWS.
   inverts D.
   (* All ctor args are wnf *)
   + left.
     have (Forall (wfT 0) ts)
      by (rrwrite (0 = length (@nil ki));
          eapply kind_wfT_Forall2; eauto).

     have (Forall (wfX 0 0) xs)
      by (have (0 = length (@nil ki)) as HKL;
          rewrite HKL at 1;
          rrwrite (0 = length (@nil ty)); eauto).
     eauto.

   + (* There is a context where one ctor arg can step *)
     right.
     dest C. dest x'. rip.
     lets D: step_context_XCon_exists H2 H4.
     destruct D as [x'']. eauto.

 (*************************************)
 - Case "XCase".
   right.
   inverts keep H1.
   have (value x \/ (exists x', STEP x x')) as HS.
   inverts HS.

   (* Scrutinee is a value *)
   + SCase "x value".
     clear IHx.

     (* Consider the forms of the scrutinee. *)
     destruct x; nope.

     (* Can't happen, TForall is not a data type. *)
     * SSCase "XCase (XLAM x) alts".
       have (exists t', tObj = TForall t').
       dest t'. subst. nope.

     (* Can't happen, tFun is not a data type. *)
     * SSCase "XCase (XLam t x) alts".
       have (exists t11 t12, tObj = tFun t11 t12).
       dest t11. dest t12. subst.
       unfold tFun in H6. simpl in H6. inverts H6.
       have (DEFOK ds (DefDataType TyConFun ks dcs)) as HD.
       inverts HD. nope.

     (* When we have a well typed case match on some data object,
        then there is a corresponding alternative. *)
     * SSCase "XCase (XCon d ts xs) alts".
       have (exists x, getAlt d aa = Some (AAlt d x)).
       dest x. exists (substXXs 0 l0 x).
       eapply EsCaseAlt; eauto.

     (* Can't happen, prim types are not data types. *)
     * SSCase "XCase (XLit l) alts".
       inverts_type.
       have HD: (DEFOK ds (DefDataType tcObj ks dcs)).
       inverts HD.
       destruct l; snorm; nope.

  (* Discriminant steps *)
  + SCase "x steps".
    destruct H2 as [x'].
    exists (XCase x' aa).
    lets D: EsContext XcCase; eauto.

 (*************************************)
 - Case "XPrim".
   inverts_type.
   right.

   (* All prim args are either wnf or can step. *)
   assert (Forall (fun x => wnfX x \/ (exists x', STEP x x')) xs) as HWS.
   { repeat nforall. intros.
     have (exists t, TYPE ds nil nil x t).
     destruct H2 as [t'].
     eapply H0 in H1.
     intuition. eauto.
   }

   (* All ctor args are wnf, or there is a context where one can step. *)
   lets D: (@exps_ctx_run exp exp) HWS. inverts D.

   (* All arguments are wnf. *)
   + eapply progress_prim; eauto.

   (* One of the arguments can step. *)
   + dest C. dest x'. rip.
     lets D: step_context_XPrim_exists H2 H5.
     destruct D as [x'']. eauto.

 (*************************************)
 - Case "XLit".
   (* Literals are already values. *)
   inverts_type.
   left. eauto.

 (*************************************)
 - Case "XAlt".
   auto.
Qed.