Require Import Strings.String.
Delimit Scope string_scope with string.
Local Open Scope string_scope.
Require Import Coq.Strings.Byte.
Local Open Scope list_scope.
Require Import Arith.
Require Import Ascii.
Require Import Bool.
Require Import Nat.
Require Setoid.
Require Import PeanoNat Le Gt Minus Bool Lt.
Set Implicit Arguments.
Open Scope list_scope.
Scheme Equality for string.

Inductive ErrNat :=
  | err_nat : ErrNat
  | num : nat -> ErrNat.

Inductive ErrBool :=
  | err_bool : ErrBool
  | boolean : bool -> ErrBool.

Inductive ErrString :=
  | err_string : ErrString
  | str : string -> ErrString.

Inductive Pointer :=
 | NULL : Pointer
 | pointer : string -> Pointer
 | reference : string -> Pointer .

(* in C un pointer poate fi asignat/declarat doar cu trei tipuri de valori: un alt pointer, referinta unei variabile
sau NULL*)

Scheme Equality for Pointer.

Coercion num: nat >-> ErrNat.
Coercion boolean: bool >-> ErrBool.
Coercion str: string >-> ErrString.
Coercion pointer: string >-> Pointer.

Check 7.
Check false.
Check "x".

(*String expressions *)

Inductive STRexp :=
 | str_err : ErrString -> STRexp
 | str_const : ErrString -> STRexp
 | str_var : string -> STRexp
 | strcmp : STRexp -> STRexp -> STRexp
 | strcat : STRexp -> STRexp -> STRexp.

Coercion str_var : string >-> STRexp.
Coercion str_err : ErrString >-> STRexp.

(*Arithmetic expressions *)

Inductive AExp :=
| avar: string -> AExp
| anum: ErrNat -> AExp
| aplus: AExp -> AExp -> AExp
| aminus: AExp -> AExp -> AExp
| amul: AExp -> AExp -> AExp
| adiv: AExp -> AExp -> AExp
| amod: AExp -> AExp -> AExp
| ainc : AExp -> AExp
| adec : AExp -> AExp
| strlen : STRexp -> AExp.

Coercion anum: ErrNat >-> AExp.
Coercion avar: string >-> AExp.

(*Boolean expressions *)

Inductive BExp :=
| b_err : ErrString -> BExp
| b_true : BExp
| b_false : BExp
| b_var: string -> BExp
| b_less : AExp -> AExp -> BExp
| b_more : AExp -> AExp -> BExp
| b_less_eq : AExp -> AExp -> BExp
| b_more_eq : AExp -> AExp -> BExp
| b_equal : AExp -> AExp -> BExp
| b_dif : AExp -> AExp -> BExp
| b_not : BExp -> BExp
| b_and : BExp -> BExp -> BExp
| b_or : BExp -> BExp -> BExp
| b_xor : BExp -> BExp -> BExp.

Coercion b_var : string >-> BExp.
Coercion b_err : ErrString >-> BExp.

(*Arrays*)

Inductive ErrArray :=
 | err_array : ErrArray
 | array_n : string -> nat -> (list nat) -> ErrArray
 | array_b : string -> nat -> (list bool) -> ErrArray
 | array_s : string -> nat -> (list string) -> ErrArray.

(* Array operations *)

Inductive ARRAY_exp :=
 | arr_const : ErrArray -> ARRAY_exp
 | arr_var : string -> ARRAY_exp
 | elem : ErrArray -> nat -> ARRAY_exp
 | delete : string -> nat -> ARRAY_exp
 | first_elem : ErrArray -> ARRAY_exp
 | last_elem : ErrArray -> ARRAY_exp.

(*Statements*)

Inductive Statement :=
  | nat_decl: string -> AExp -> Statement
  | bool_decl: string -> BExp -> Statement
  | str_decl : string -> STRexp -> Statement
  | array_decl : ErrArray -> Statement
  | ptr_nat_decl : string -> string -> Statement
  | ptr_bool_decl : string -> string -> Statement
  | ptr_string_decl : string -> string -> Statement
  | ref_decl : string -> string -> Statement
  | nat_assign : string -> AExp -> Statement
  | bool_assign : string -> BExp -> Statement
  | str_assign : string -> STRexp -> Statement
  | ptr_assign_n : string -> AExp -> Statement
  | ptr_assign_b : string -> BExp -> Statement
  | ptr_assign_s : string -> STRexp -> Statement
  | ref_assign : string -> string -> Statement
  | get_elem_array : string -> nat -> Statement
  | sequence : Statement  -> Statement  -> Statement
  | cin : string -> Statement (*input -> variable *)
  | cout : STRexp -> Statement
  | while : BExp -> Statement -> Statement
  | for_new : Statement -> BExp -> Statement -> Statement -> Statement
  | ifthen : BExp -> Statement -> Statement
  | ifthenelse : BExp -> Statement -> Statement -> Statement
  | empty : Statement (*bloc gol*)
  | break : Statement
  | continue : Statement
  | switchcase : AExp -> list Case -> Statement
  | fun_call : string -> (list string) -> Statement (*apel de functie cu o serie de parametrii *)
   with Case :=
    | case_default : Statement -> Case
    | case : ErrNat -> Statement -> Case.

Inductive Types :=
  | err : Types
  | err_undecl : Types
  | err_assign : Types
  | default : Types
  | val_nat : ErrNat -> Types (*valorile pe care le atribui unei variabile declarate  nat*)
  | val_bool : ErrBool -> Types
  | val_string : ErrString -> Types
  | val_pointer : nat -> bool -> Types
  | val_array : ErrArray -> Types
  | code : list string -> Statement -> Types. (* function code  *)

Coercion val_nat : ErrNat >-> Types.
Coercion val_bool : ErrBool >-> Types.
Coercion val_string : ErrString >-> Types.
Coercion val_array : ErrArray >-> Types.

Definition get_statement (cod : Types) : Statement :=
match cod with
| code _ statement => statement
| _ => empty
end.

(*Inductive type for functions *)

Inductive Pgm :=
| secv : Pgm -> Pgm -> Pgm (*Secventa de funcii si/sau declaratii de variabile *)
| default_nat_decl : string -> Pgm
| default_bool_decl : string -> Pgm
| default_string_decl : string -> Pgm
| default_array_decl : string -> nat -> Pgm
| default_ptr_decl : string -> Pgm
| main : Statement -> Pgm
| function : string -> list string -> Statement -> Pgm.

Definition type_equality  (t1 : Types)(t2 : Types) : bool :=
 match t1 with
 | err => match t2 with
         | err => true
         | _ => false
         end
 | err_undecl => match t2 with
                 | err_undecl => true
                 | _ => false
                end
 | err_assign => match t2 with
                 | err_assign => true
                 | _ => false
                end
 | default => match t2 with
                 | default => true
                 | _ => false
                end
 | val_nat a => match t2 with
              | val_nat b => true
              | _ => false
              end
 | val_bool b1 => match t2 with
              | val_bool b2 => true
              | _ => false
              end
 | val_string s1 => match t2 with
              | val_string s2 => true
              | _ => false
              end
 | val_pointer p1 p2 => match t2 with
                    | val_pointer p1' p2' => true
                    | _ => false
                     end
 | val_array v1 => match t2 with
                   | val_array v2 => true
                   | _ => false
                   end
 | code _ _x => match t2 with
                  | code _ _x => true
                  | _ => false
                 end
  end.

Definition Memory := nat -> Types.
Definition Adress := string -> nat.
Inductive MemLayer :=
| pair : Adress -> Memory -> nat -> Adress -> Memory -> nat -> MemLayer.
Notation "{< A1 , M1 , N1 >} -> {< A2 , M2 , N2 >}" := (pair A1 M1 N1 A2 M2 N2) (at level 0).

Definition local (m : MemLayer) (v : string) : bool :=
match m with
| pair adr1 mem1 _ adr2 mem2 _ => if (type_equality ( mem1 (adr1 v) ) err)
                              then false
                              else true
end.

Definition get_value (m : MemLayer) (v : string) : Types :=
match m with
| pair adr1 mem1 _ adr2 mem2 _ => if (local m v)
                              then mem1(adr1 v)
                              else mem2(adr2 v)
end.

Definition pointer_adress (a : Types) : nat :=
match a with
| val_pointer p _ => p
| _ => 0
end.

Definition pointer_value (m : MemLayer) (p : string) : Types :=
let pointer := get_value m p in
match pointer with
| val_pointer val local => match m with
                    | pair _ mem1 _ _ mem2 _ => if (local)
                                                then (mem1 (pointer_adress pointer) )
                                                else (mem2 (pointer_adress pointer) )
                    end
| _ => err
end.

Definition get_local_top (m : MemLayer) : nat :=
match m with
| pair _ _ maxval _ _ _  => maxval
end.

Definition get_global_top (m : MemLayer) : nat :=
match m with
| pair _ _ _ _ _ maxval  => maxval
end.

Definition get_adress (m : MemLayer) (v : string) : nat :=
match m with
| pair adr1 _ _ adr2 _ _ => if (Nat.eqb (adr1 v) 0)
                            then adr2 v
                             else adr1 v
end.

Definition get_local_adress (m : MemLayer) (v : string) : nat :=
match m with
| pair adress _ _ _ _ _ => adress v
end.

Definition get_global_adress (m : MemLayer) (v : string) : nat :=
match m with
| pair _ _ _ adress _ _ => adress v
end.

Definition update_adress (st : Adress) (v : string) (n : nat) : Adress :=
fun x => if (string_beq x v)
         then n
         else st x.

Definition update_memory (mem : Memory) (n : nat) (val : Types) : Memory :=
fun n' => if (Nat.eqb n' n)
          then val
          else mem n'.

Definition update_local_mem (M : MemLayer) (V : string) (T : Types) (nr : nat) : MemLayer :=
match M with
|{<adr1, mem1, top1>} -> {<adr2, mem2, top2>}
      =>
          if (andb (Nat.eqb nr (get_local_adress M V) ) (Nat.eqb nr 0) )
          then {<adr1, mem1, top1>} -> {<adr2, mem2, top2>}
          else {<update_adress adr1 V nr, update_memory mem1 nr T,
            (if (Nat.ltb nr top1) then top1 else Nat.add top1 1)>} -> {<adr2, mem2, top2>}
end.

Definition update_global_mem (M : MemLayer) (V : string) (T : Types) (nr : nat) : MemLayer :=
match M with
|{<adr1, mem1, top1>} -> {<adr2, mem2, top2>}
    =>
      if (andb (Nat.eqb nr (get_global_adress M V) ) (Nat.eqb nr 0) )
      then {<adr1, mem1, top1>} -> {<adr2, mem2, top2>}
       else
       {<adr1, mem1, top1>} -> {<update_adress adr2 V nr, update_memory mem2 nr T,
      (if (Nat.ltb nr top2) then top2 else Nat.add top2 1) >}
end.

Definition update_local_at_adress (M : MemLayer) (addr : nat) (T : Types): MemLayer :=
match M with
|{<adr1, mem1, top1>} -> {<adr2, mem2, top2>}
     =>
     if (Nat.eqb addr 0)
     then {<adr1, mem1, top1>} -> {<adr2, mem2, top2>}
     else {<adr1, update_memory mem1 addr T, top1 >} -> {<adr2, mem2, top2>}
end.

Definition update_global_at_adress (M : MemLayer) (addr : nat) (T : Types): MemLayer :=
match M with
|{<adr1, mem1, top1>} -> {<adr2, mem2, top2>}
     =>
     if (Nat.eqb addr 0)
     then {<adr1, mem1, top1>} -> {<adr2, mem2, top2>}
     else {<adr1, mem1, top1>} -> {<adr2, update_memory mem2 addr T, top2 >}
end.

Definition update_at_adress (M : MemLayer) (addr : nat) (T : Types) : MemLayer :=
match M with
|{<adr1, mem1, top1>} -> {<adr2, mem2, top2>}
      =>
       if (type_equality (mem1 addr) err)
       then update_global_at_adress M addr T
       else update_local_at_adress M addr T
end.

Definition mem_default : Memory := fun x => err.
Definition adress_default : Adress := fun x => 0.
Definition env_default := {<adress_default, mem_default, 1>} -> {<adress_default, mem_default, 1>}.

Definition env_local (m : MemLayer) : MemLayer :=
match m with
| {<adr1, mem1, top1>} -> {<adr2, mem2, top2>} => {<adress_default, mem_default, 1>} -> {<adr2, mem2, top2>}
end.

(*Operations with strings *)

Definition str_length (s : ErrString) : ErrNat :=
 match s with
  | err_string => err_nat
  | str s1 => num (length s1)
 end.

Definition str_cat (s1 s2 : ErrString) : ErrString :=
 match s1,s2 with
  | err_string, _ => err_string
  | _, err_string => err_string
  | str s1, str s2 => str (s1 ++ s2)
 end.

Definition str_cmp (s1 s2 : ErrString) : ErrString :=
 match s1,s2 with
  | err_string, _ => err_string
  | _, err_string => err_string
  | str s1, str s2 =>
     if (ltb (length s1) (length s2))
     then s2
     else s1
 end.

Definition Strlen (s : Types) :=
match s with
| val_string s1 => ( str_length s1 )
| _ => err
end.

Definition Strcat (s1 s2 : Types) :=
match s1, s2 with
| val_string s1', val_string s2' => match s1', s2' with
                                    | str x, str y =>  ( str_cat x y )
                                    | _, _ => err_string
                                     end
| _, _ => err
end.

Definition Strcmp (s1 s2 : Types) :=
match s1, s2 with
| val_string s1', val_string s2' => match s1', s2' with
                                    | str x, str y =>  ( str_cmp x y )
                                    | _, _ => err_string
                                     end
| _, _ => err
end.

(*Notations for string operations*)

Notation " len[ S ] " := (strlen S) (at level 31).
Notation " S1 /+/ S2 " := (strcat S1 S2) (at level 30).
Notation " S1 ? S2 " := (strcmp S1 S2) (at level 32).

(*Semantics for string operations*)

Reserved Notation "STR '=S[' St ']=>' N" (at level 60).
Inductive streval_fun : STRexp -> MemLayer -> Types -> Prop :=
| s_const : forall s sigma, str_const s =S[ sigma ]=> val_string s
| s_var : forall s sigma, str_var s =S[ sigma ]=> get_value sigma s
| s_cmp : forall s1 s2 sigma s str1 str2,
    s1 =S[ sigma ]=> str1 ->
    s2 =S[ sigma ]=> str2 ->
    s = Strcmp str1 str2 ->
    s1 ? s2  =S[ sigma ]=> s
| s_cat : forall s1 s2 sigma s st1 st2,
    s1 =S[ sigma ]=> st1 ->
    s2 =S[ sigma ]=> st2 ->
    s = Strcat st1 st2 ->
    s1 /+/ s2 =S[ sigma ]=> s
where "STR '=S[' St ']=>' N" := (streval_fun STR St N).

(*Semantics for Arrays*)

Definition get_elem (a : ErrArray) (nr : nat) : Types :=
match a with
| array_n s n l => val_nat (List.nth nr l 0)
| array_b s n l => val_bool (List.nth nr l false)
| array_s s n l => val_string (List.nth nr l "")
| err_array => err_undecl
end.

Definition get_last_elem (a : ErrArray) : Types :=
match a with
| array_n s n l => val_nat (List.last l 0)
| array_b s n l => val_bool (List.last l false)
| array_s s n l => val_string (List.last l "")
| err_array => err_undecl
end.
Definition delete_elem (a : ErrArray) (nr : nat) : Types :=
match a with
| array_n s n l => val_array (array_n s n (List.remove eq_nat_dec (List.nth nr l 0) l))
| array_b s n l => val_array (array_b s n (List.remove bool_dec (List.nth nr l false) l))
| array_s s n l => val_array (array_s s n (List.remove string_dec (List.nth nr l "") l))
| err_array => err_undecl
end.

(*Arithmetic operations *)

Definition plus_err (a b : Types) :=
match a, b with
| val_nat x, val_nat y => match x, y with
                        | num n1, num n2 => num (n1 + n2)
                        | _, _ => err_nat
                        end
| _ , _ => err
end.

Definition minus_err (a b : Types) :=
match a, b with
| val_nat x, val_nat y => match x, y with
                        | num n1, num n2 => if (ltb n1 n2) then err_nat else num (n1 - n2)
                        | _, _ => err_nat
                        end
| _ , _ => err
end.

Definition mul_err (a b : Types) :=
match a, b with
| val_nat x, val_nat y => match x, y with
                        | num n1, num n2 => num (n1 * n2)
                        | _, _ => err_nat
                        end
| _ , _ => err
end.

Definition div_err (a b : Types) :=
match a, b with
| val_nat x, val_nat y => match x, y with
                        | num n1, num n2 => if (Nat.eqb n2 0) then err_nat else num (div n1 n2)
                        | _, _ => err_nat
                        end
| _ , _ => err
end.

Definition mod_err (a b : Types) :=
match a, b with
| val_nat x, val_nat y => match x, y with
                        | num n1, num n2 => if (Nat.eqb n2 0) then err_nat else num (modulo n1 n2)
                        | _, _ => err_nat
                        end
| _ , _ => err
end.

Definition inc (a : Types) :=
match a with
| val_nat x => match x with
                        | num n1 => num (n1 + 1)
                        | _ => err_nat
                        end
| _ => err
end.

Definition dec (a : Types) :=
match a with
| val_nat x => match x with
                        | num n1 => if (Nat.eqb n1 0) then err_nat else num (n1 - 1)
                        | _ => err_nat
                        end
| _  => err
end.

(*Notations for arithmetic expressions*)

Notation "A +' B" := (aplus A B)(at level 50, left associativity).
Notation "A -' B" := (aminus A B)(at level 50, left associativity).
Notation "A *' B" := (amul A B)(at level 48, left associativity).
Notation "A /' B" := (adiv A B)(at level 48, left associativity).
Notation "A %' B" := (amod A B)(at level 45, left associativity).
Notation "A +++" := (ainc A) (at level 40,left associativity).
Notation "A ---" := (adec A) (at level 49).

(*Semantics for arithmetic expressions*)

Reserved Notation "A =[ S ]=> N" (at level 65).
Inductive aeval_fun : AExp -> MemLayer -> Types -> Prop :=
| e_const : forall n sigma, anum n =[ sigma ]=> val_nat n
| e_avar : forall v sigma, avar v =[ sigma ]=> get_value sigma v
| e_add : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = plus_err i1 i2 ->
    a1 +' a2 =[ sigma ]=> n
| e_minus : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = minus_err i1 i2 ->
    a1 -' a2 =[ sigma ]=> n
| e_mul : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = mul_err i1 i2 ->
    a1 *' a2 =[ sigma ]=> n
| e_div : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = div_err i1 i2 ->
    a1 /' a2 =[ sigma ]=> n
| e_mod : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = mod_err i1 i2 ->
    a1 %' a2 =[ sigma ]=> n
| e_inc : forall a1 i1 sigma n,
    a1 =[ sigma ]=> i1 ->
    n = inc i1 ->
    a1 +++  =[ sigma ]=> n
| e_dec : forall a1 i1 sigma n,
    a1 =[ sigma ]=> i1 ->
    n = dec i1 ->
    a1 ---  =[ sigma ]=> n
| e_strlen : forall a1 sigma s1 n,
    a1 =S[ sigma ]=> s1 ->
    n = Strlen s1 ->
    len[ a1 ] =[ sigma ]=> n
where "a =[ sigma ]=> n" := (aeval_fun a sigma n).

(*Boolean operations*)

Definition less_err (b1 b2 : Types) : Types :=
  match b1, b2 with
  | val_nat b1', val_nat b2' => match b1', b2' with
                                 | num x, num y  => boolean (Nat.ltb x y)
                                 | _, _ => err_bool
                                 end
  |_, _ => err
  end.

Definition more_err (b1 b2 : Types) : Types :=
  match b1, b2 with
  | val_nat b1', val_nat b2' => match b1', b2' with
                                 | num x, num y  => boolean (negb (Nat.ltb x y))
                                 | _, _ => err_bool
                                 end
  |_, _ => err
  end.

Definition less_eq_err (b1 b2 : Types) : Types :=
  match b1, b2 with
  | val_nat b1', val_nat b2' => match b1', b2' with
                                 | num x, num y  => boolean (Nat.leb x y)
                                 | _, _ => err_bool
                                 end
  |_, _ => err
  end.

Definition more_eq_err (b1 b2 : Types) : Types :=
  match b1, b2 with
  | val_nat b1', val_nat b2' => match b1', b2' with
                                 | num x, num y  => boolean (negb(Nat.leb x y))
                                 | _, _ => err_bool
                                 end
  |_, _ => err
  end.

Definition equal_err (b1 b2 : Types) : Types :=
  match b1, b2 with
  | val_nat b1', val_nat b2' => match b1', b2' with
                                 | num x, num y  => boolean (Nat.eqb x y)
                                 | _, _ => err_bool
                                 end
  |_, _ => err
  end.

Definition dif_err (b1 b2 : Types) : Types :=
  match b1, b2 with
  | val_nat b1', val_nat b2' => match b1', b2' with
                                 | num x, num y  => boolean (negb (Nat.eqb x y))
                                 | _, _ => err_bool
                                 end
  |_, _ => err
  end.

Definition not_err (b1 : Types) : Types :=
  match b1 with
  | val_bool b1' => match b1' with
                   | boolean x => boolean (negb x)
                   | _ => err_bool
                     end
  |_ => err
  end.

Definition and_err (b1 b2 : Types) : Types :=
  match b1, b2 with
  | val_bool b1', val_bool b2' => match b1', b2' with
                                 | boolean x, boolean y  => boolean (andb x y)
                                 | _, _ => err_bool
                                 end
  |_, _ => err
  end.

Definition or_err (b1 b2 : Types) : Types :=
  match b1, b2 with
  | val_bool b1', val_bool b2' => match b1', b2' with
                                 | boolean x, boolean y  => boolean (orb x y)
                                 | _, _ => err_bool
                                 end
  |_, _ => err
  end.

Definition xorb_err (b1 b2 : ErrBool) : ErrBool :=
  match b1, b2 with
    | err_bool,_ => err_bool
    | _, err_bool => err_bool
    | true, true => false
    | true, false => true
    | false, true => true
    | false, false => false
  end.

Definition Xor (b1 b2 : Types) : Types :=
match b1, b2 with
| val_bool b1', val_bool b2' => match b1', b2' with
                              | boolean x, boolean y => val_bool (xorb_err x y)
                              | _, _ => err_bool
                              end
| _, _ => err
end.

(*Semantics for boolean expressions*)

Reserved Notation "B ={ S }=> B'" (at level 70).
Inductive beval_fun : BExp -> MemLayer -> Types -> Prop :=
| e_true : forall sigma, b_true ={ sigma }=> boolean true
| e_false : forall sigma, b_false ={ sigma }=> boolean false
| e_bvar : forall v sigma, b_var v ={ sigma }=> get_value sigma v
| e_less : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = less_err i1 i2 ->
   b_less a1 a2 ={ sigma }=> b
| e_more : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = more_err i1 i2 ->
   b_more a1 a2 ={ sigma }=> b
| e_less_eq : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = less_eq_err i1 i2 ->
   b_less_eq a1 a2 ={ sigma }=> b
| e_more_eq : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = more_eq_err i1 i2 ->
    b_more_eq a1 a2 ={ sigma }=> b
| e_equal: forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = equal_err i1 i2 ->
    b_equal a1 a2 ={ sigma }=> b
| e_dif : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = dif_err i1 i2 ->
    b_dif a1 a2 ={ sigma }=> b
| e_not_true : forall b sigma,
    b ={ sigma }=> boolean true ->
    b_not b ={ sigma }=> boolean false
| e_not_false : forall b sigma,
    b ={ sigma }=> boolean false ->
    b_not b ={ sigma }=> boolean true
| e_and_true : forall b1 b2 sigma t,
    b1 ={ sigma }=> boolean true ->
    b2 ={ sigma }=> t ->
    b_and b1 b2 ={ sigma }=> t
| e_and_false : forall b1 b2 sigma,
    b1 ={ sigma }=> boolean false ->
    b_and b1 b2 ={ sigma }=> boolean false
| e_or : forall b1 b2 sigma t t1 t2,
    b1 ={ sigma }=> t1 ->
    b2 ={ sigma }=> t2 ->
    t = or_err t1 t2 ->
   b_or b1 b2 ={ sigma }=> t
| e_xorb : forall b1 b2 sigma t t1 t2,
    b1 ={ sigma }=> t1 ->
    b2 ={ sigma }=> t2 ->
    t = Xor t1 t2 ->
   b_xor b1 b2 ={ sigma }=> t
where "B ={ S }=> B'" := (beval_fun B S B').

Definition to_bool (b : Types) : bool :=
match b with
| val_bool b' => match b' with
                 |boolean true => true
                 |boolean false => false
                 |errBool => false
                 end
| _ => false
end.

Notation "'default:{' S };" := (case_default S) (at level 97).
Notation "'case(' X ):{ S };" := (case X S) (at level 97).

Definition get_case_Stmt (C : Case) : Statement :=
match C with
| default:{ s }; => s
| case( _ ):{ s }; => s
end.

Definition check_case (C : Case ) (n : Types) : bool :=
match C with
| default:{ _ }; => true
| case( a ):{ _ }; => to_bool (equal_err a n)
end.

Fixpoint execute_switchcase (n : Types) (cl : list Case) : Statement :=
match n with
| val_nat n' => match cl with
              | nil => empty
              | x :: next => if (check_case x n) then (get_case_Stmt x) else (execute_switchcase n next)
              end
| _ => empty
end.

Reserved Notation " L -{ M , S }-> M' , S'" (at level 60).
Inductive eval_fun : Statement -> MemLayer -> MemLayer -> MemLayer -> MemLayer -> Prop :=
| e_nat_decl : forall s x value sigma sigma' new,
    value =[ sigma ]=> x ->
    sigma' = update_local_mem sigma s x (get_local_top sigma) ->
    ( nat_decl s value )-{ sigma , new }-> sigma' , new
| e_bool_decl : forall s b value sigma sigma' new,
    value ={ sigma }=> b ->
    sigma' = update_local_mem sigma s b (get_local_top sigma) ->
    ( bool_decl s value)-{ sigma , new }-> sigma' , new
| e_str_decl : forall s value sigma sigma' str new,
    value =S[ sigma ]=> str ->
    sigma' = update_local_mem sigma s str (get_local_top sigma) ->
    ( str_decl s value )-{ sigma , new }-> sigma' , new
| e_ptr_nat_decl : forall P V sigma sigma' loc new,
    type_equality (get_value sigma V) (val_nat 0) = true ->
    loc = local sigma V ->
    sigma' = update_local_mem sigma P (val_pointer (get_adress sigma V) loc) (get_local_top sigma) ->
    ( ptr_nat_decl P V )-{ sigma , new }-> sigma', new
| e_ptr_bool_decl : forall P V sigma sigma1 loc new,
    type_equality (get_value sigma V) (val_bool false) = true ->
    loc = local sigma V ->
    sigma1 = update_local_mem sigma P (val_pointer (get_adress sigma V) loc) (get_local_top sigma) ->
    ( ptr_bool_decl P V )-{ sigma , new }-> sigma1 , new
| e_ptr_string_decl : forall P V sigma sigma1 loc new,
    type_equality (get_value sigma V) (val_string ("") ) = true ->
    loc = local sigma V ->
    sigma1 = update_local_mem sigma P (val_pointer (get_adress sigma V) loc) (get_local_top sigma) ->
    ( ptr_string_decl P V )-{ sigma , new }-> sigma1 , new
| e_nat_assign : forall s x value sigma sigma' new,
    type_equality (get_value sigma s) (val_nat 0) = true ->
    value =[ sigma ]=> x ->
    sigma' = update_at_adress sigma (get_adress sigma s) x ->
    ( nat_assign s value )-{ sigma , new }-> sigma' , new
| e_bool_assign : forall s b value sigma sigma' new,
    type_equality (get_value sigma s) (val_bool false) = true ->
    value ={ sigma }=> b ->
    sigma' = update_at_adress sigma (get_adress sigma s) b ->
    ( bool_assign s value )-{ sigma , new }-> sigma' , new
| e_str_assign : forall s value sigma sigma' sstr new,
    type_equality (get_value sigma s) (val_string ("") ) = true ->
    value =S[ sigma ]=> sstr ->
    sigma' = update_at_adress sigma (get_adress sigma s) sstr  ->
    ( str_assign s value )-{ sigma , new }-> sigma' , new
| e_ptrassign_n : forall V E i1 sigma sigma1 new,
    type_equality (get_value sigma V) (val_pointer 0 false) = true ->
    E =[ sigma ]=> i1 ->
    sigma1 = update_at_adress sigma (pointer_adress (get_value sigma V) ) i1  ->
    ( ptr_assign_n V E )-{ sigma , new }-> sigma1, new
| e_ptrassign_b : forall V E i1 sigma sigma1 new,
    type_equality (get_value sigma V) (val_pointer 0 false) = true ->
    E ={ sigma }=> i1 ->
    sigma1 = update_at_adress sigma (pointer_adress (get_value sigma V) ) i1 ->
   ( ptr_assign_b V E )-{ sigma , new }-> sigma1 , new
| e_ptrassign_s : forall V E i1 sigma sigma1 new,
    type_equality (get_value sigma V) (val_pointer 0 false) = true ->
    E =S[ sigma ]=> i1 ->
    sigma1 = update_at_adress sigma (pointer_adress (get_value sigma V) ) i1  ->
   ( ptr_assign_s V E )-{ sigma , new }-> sigma1 , new
| e_sequence : forall s1 s2 sigma sigma' sigma'' new new',
   ( s1 )-{ sigma , new }-> sigma' , new ->
   ( s2 )-{ sigma' , new }-> sigma'' , new' ->
   (sequence s1 s2 )-{ sigma , new }-> sigma'' , new'
| e_while_false : forall b s sigma new,
    b ={ sigma }=> false ->
    ( while b s )-{ sigma , new }-> sigma , new
| e_while_true : forall b s sigma sigma' new,
    b ={ sigma }=> true ->
    ( sequence s ( while b s ) )-{ sigma , new }-> sigma' , new ->
    ( while b s )-{ sigma , new }-> sigma' , new
| e_for_false : forall s b s1 s2 sigma sigma' new,
    ( s )-{ sigma, new }-> sigma', new ->
    b ={ sigma' }=> false ->
    ( for_new s b s1 s2 )-{ sigma , new }-> sigma' , new
| e_for_true : forall s b s1 s2 sigma sigma' sigma'' new,
    ( s )-{ sigma , new }-> sigma', new ->
    (while b ( sequence s2 s1) )-{ sigma' , new }-> sigma'' , new ->
    ( for_new s b s1 s2 )-{ sigma , new }-> sigma'' , new
| e_ifthen_false : forall b s1 sigma new,
    b ={ sigma }=> false ->
    ( ifthen b s1 )-{ sigma , new }-> sigma , new
| e_ifthen_true : forall b s1 sigma sigma' new,
    b ={ sigma }=> true ->
    ( s1 )-{ sigma , new }-> sigma' , new ->
    ( ifthen b s1 )-{ sigma , new }-> sigma' , new
| e_ifthenelse_false : forall b s1 s2 sigma sigma' new,
    b ={ sigma }=> false ->
    ( s2 )-{ sigma , new }-> sigma' , new ->
    ( ifthenelse b s1 s2 )-{ sigma , new }-> sigma' , new
| e_ifthenelse_true : forall b s1 s2 sigma sigma' new,
    b ={ sigma }=> true ->
    ( s1 )-{ sigma , new }-> sigma' , new ->
    ( ifthenelse b s1 s2 )-{ sigma , new }-> sigma' , new
| e_empty : forall sigma new,
   ( empty )-{ sigma , new }-> sigma , new
| e_break: forall sigma new,
   ( break ) -{ sigma, new }-> sigma , new
| e_break_case1 : forall b s n sigma new,
    b ={ sigma }=> true ->
    n = ( sequence break s) ->
    ( sequence s ( while b n) ) -{ sigma, new }-> sigma, new ->
    while b n -{ sigma, new }-> sigma, new
| e_break_case2 : forall b s n sigma sigma' new,
    b ={ sigma }=> true ->
    n = ( sequence s break) ->
    ( sequence s ( while b n)) -{ sigma, new }-> sigma' , new
| e_switchcase : forall a c sigma n v sigma' new,
    a =[ sigma ]=> n ->
    v = (execute_switchcase n c) ->
    v -{ sigma , new }-> sigma' , new ->
   ( switchcase a c ) -{ sigma , new }-> sigma' , new
| e_fun_call : forall s l stmt sigma sigma' new,
    stmt = get_statement (get_value sigma s ) ->
    ( stmt )-{ env_local sigma , sigma}-> sigma' , new ->
    ( fun_call s l )-{ sigma , new }-> sigma' , new
where "L -{ M , S }-> M' , S'" := (eval_fun L M S M' S').

(*Program semantics*)

Reserved Notation "P -{{ M1 }}=> M2" (at level 60).
Inductive pgm_eval : Pgm -> MemLayer -> MemLayer -> Prop :=
|e_secv : forall s s' sigma sigma' sigma'',
   ( s )-{{ sigma }}=> sigma' ->
   ( s' )-{{ sigma' }}=> sigma'' ->
   (secv s s' )-{{ sigma }}=> sigma''
| e_default_nat_decl : forall s sigma sigma',
  sigma' = update_global_mem sigma s (val_nat 0) (get_global_top sigma) ->
  ( default_nat_decl s )-{{ sigma }}=> sigma'
| e_default_bool_decl : forall s sigma sigma',
  sigma' = update_global_mem sigma s (val_bool false) (get_global_top sigma) ->
  ( default_bool_decl s )-{{ sigma }}=> sigma'
| e_default_string_decl : forall s sigma sigma',
  sigma' = update_global_mem sigma s (val_string "" ) (get_global_top sigma) ->
  ( default_string_decl s )-{{ sigma }}=> sigma'
| e_main : forall statements sigma sigma' new,
  new = env_default ->
  ( statements )-{ sigma , new }-> sigma' , new->
  ( main statements )-{{ sigma }}=> sigma'
| e_function : forall s L  statements sigma sigma',
  sigma' = update_global_mem sigma s (code L statements) (get_global_top sigma) ->
  ( function s L statements )-{{ sigma }}=> sigma'
where "P -{{ M1 }}=> M2" := (pgm_eval P M1 M2).

(*Notations for boolean expressions*)

Notation "A <' B" := (b_less A B) (at level 53).
Notation "A >' B" := (b_more A B) (at level 53).
Notation "A <=' B" := (b_less_eq A B) (at level 53).
Notation "A >=' B" := (b_more_eq A B) (at level 53).
Notation "A == B" := (b_equal A B) (at level 53).
Notation "A <!> B" := (b_dif A B) (at level 53).
Notation " ! A " := (b_not A) (at level 71).
Notation "A & B" := (b_and A B) (at level 75).
Notation "A | B" := (b_or A B) (at level 75).
Notation "A ^^ B" := (b_xor A B) (at level 60).

(*Notations for arrays*)
Notation "[ ]" := nil (format "[ ]") : list_scope.
Notation "[ x ]" := (cons x nil) : list_scope.
Notation "[ x , y , .. , z ]" := (cons x (cons y .. (cons z nil) ..)) : list_scope.

Notation "Array'::= A" := (array_decl A ) (at level 58).

Notation " A '[[' X ']]' n->  L  " := (array_n A X L) (at level 30).
Notation " B '[[' X ']]' b->  L  " := (array_b B X L) (at level 30).
Notation " S '[[' X ']]' s->  L  " := (array_s S X L) (at level 30).

Notation " s [[' i ']] " := (elem s i)(at level 22).

(*Notations for statements & functions *)

Notation " A **" := (pointer A)(at level 30).
Notation "&& A" := (reference A )(at level 30).

Notation "'NAT' X ::= A  " := (nat_decl X A)(at level 90).
Notation "'BOOL' X ::= A " := (bool_decl X A)(at level 90).
Notation "'STR' X ::= A " := (str_decl X A) (at level 90).

Notation " X := 'NAT**' A " := (ptr_nat_decl X A) (at level 90).
Notation " X := 'BOOL**' A " := (ptr_bool_decl X A) (at level 90).
Notation " X := 'STR**' A " := (ptr_string_decl X A) (at level 90).
Notation " X := '&&' A " := (ref_decl X A) (at level 90).

Notation "'Default_nat' X" := (default_nat_decl X) (at level 90).
Notation "'Default_bool' B" := (default_bool_decl  B) (at level 90).
Notation "'Default_str' S" := (default_string_decl S) (at level 90).
Notation "'Default_arr' A '[(' X ')]'" := (default_array_decl A X) (at level 90).
Notation "'Default_ptr' P" := (default_ptr_decl P) (at level 90).

Notation "X n:= A" := (nat_assign X A)(at level 90).
Notation "X b:= A" := (bool_assign X A)(at level 90).
Notation "X s:= A" := (str_assign X A)(at level 90).
Notation "X p:= 'n*' A" := (ptr_assign_n X A)(at level 90).
Notation "X p:= 'b*' A" := (ptr_assign_b X A)(at level 90).
Notation "X p:= 's*' A" := (ptr_assign_s X A)(at level 90).
Notation "X r:= '&&' A" := (ref_assign X A)(at level 90).

Notation "V [ P ]" := (get_elem_array V P)(at level 79).

Notation "S1 ;; S2" := (sequence S1 S2) (at level 93, right associativity).
Notation "S1 ;.; S2" := (secv S1 S2) (at level 93, right associativity).

Notation " 'While' '(' B ')' '{' S '}' 'End' " := (while B S) (at level 97).
Notation "'For' ( A ~ B ~ C ) 'Do' { S } 'End'" := (A ;; while B ( S ;; C )) (at level 97).
Notation "'If' '(' B ')' 'Then' '(' S1 ')' 'Else' '(' S2 ')' 'End'" := (ifthenelse B S1 S2) (at level 97).
Notation "'If'(' B ) 'Then'{' S '}End'" := (ifthen B S) (at level 97).

Notation "'default:{' S };" := (case_default S) (at level 97).
Notation "'case(' X ):{ S };" := (case X S) (at level 97).
Notation "'SWITCH' '(' Y ){ case_1 .. case_n '}'" := (switchcase Y (cons case_1 .. (cons case_n nil) .. )) (at level 40).

Notation "'int' 'main()' { S }" := (main S)(at level 90).
Notation "'int' 'main()' { }" := (main empty)(at level 95).
Notation "'int' F (){ S }" := (function F nil S)(at level 90).
Notation "'int' F (){ }" := (function F nil empty)(at level 95).
Notation "'int' F (( p_1 , .. , p_n )){ S }" := (function F (cons p_1 .. (cons p_n nil) .. ) S)(at level 90).
Notation "'int' F (( p_1 , .. , p_n )){ }" := (function F (cons p_1 .. (cons p_n nil) .. ) empty)(at level 95).

Notation "'cin>>(' I )" := (cin I) (at level 92).
Notation "'cout<<(' O )" := (cout O) (at level 92).

Notation "'f_call' F (( p_1 , .. , p_n ))" := (fun_call F (cons p_1 .. (cons p_n nil) .. ) ) (at level 89).
Notation "'f_call' F (( ))" := (fun_call F nil) (at level 89).

(*Semantics for statements*)

(*EXAMPLES*)
(*String operations *)

Check ("Info " /+/ "PLP") .
Check (len[ "Proiect" ]).
Check ("ab" ? "ba").

(*Arithmetic expressions *)

Check (2 +' 3 *' 5).
Check (2 +' 3 *' "n").
Check ("sum" /' "sum"---).
Check ("i" +++).
Check (3 %' 0).

(*Boolean expressions *)

Check ( 3 >=' ("x" /' 0) ) .
Check ( ( ("a" +' 5) /' ( ("b" -'1) *' 3) ) <=' 100 ).
Check ( ( ! b_false ) & b_true).
Check ( b_true | b_false | "sum" | ("a" <=' "b") ).
Check (b_true ^^ b_false).
Check ("a" ^^ "b").

(*Arrays*)
Check  [1 , 3 , 5 , 8].
Check [].
Check [true , false].
Check ["proiect" , "PLP"].

Check Array'::= "a" [[10]] n-> [1, 2].

Check "x"[[2]] n-> [ 0, 1].
Check "booleans"[[3]] b-> [true,true,false].
Check "homework"[[2]] s-> ["project", "syntax"].

(*Statements*)

Check Default_nat "i".
Check NAT "x" ::= 0.
Check BOOL "y" ::= b_true.
Check STR "s" ::= "sum".

Check "ptr" **.
Check &&"var".

Check
   "a" n:= 27 ;;  "b" n:= 3 ;;  "r" n:= 0 ;;
  While
      ( "b" )
      {"r" n:= "a" %' "b" ;;
       "a" n:= "b" ;;
       "b" n:= "r" } End.

Check
    (NAT "sum" ::= 0) ;;
    (BOOL "k" ::= b_true) ;;
       For ( NAT "i" ::= 0 ~ "i" <=' (length("var") *' 3) ~ "i" n:= "i" +++ )
         Do {
           "sum" n:= "sum" +' "i" ;;
            "k" b:= b_false
            } End.

Check
 (NAT "value" ::= 10) ;;
 (NAT "min" ::= 0 ) ;;
 (NAT "max" ::= 100) ;;
 If ( "max" <=' "value" )
   Then ( "max" b:= "value" )
   Else ( "min" b:= "value" )
End.

Check
 (STR "sir1" ::= "PLP") ;;
 (STR "sir2" ::= "Project") ;;
  If'( (length("sir1") ) >' (length("sir2") ) )
  Then'{
       STR "rez" ::= ("sir1")
     }End.

Check SWITCH( 0 ){ default:{ "a" n:= 0 };}.

Check

  Default_nat "i" ;.;
  Default_bool "k" ;.;
  int "printf" (("result")){
   cout<<("result")
} ;.;

  int main(){
    (NAT "max" ::= 0) ;; (NAT "min" ::=100) ;;
    (NAT "contor" ::= 50) ;;
    (NAT "n" ::= 1) ;;
    If'("k") Then'{
        "n" s:= "k"
     }End ;;
     While
      ( ! ("k") )
      { If ( "max" <=' "contor" )
            Then ( "max" b:= "contor" ;; break )
            Else ( "min" b:= "contor" )End
      } End ;;
    f_call "printf"(( "max" )) ;;
    f_call "printf"(( "min" ))
  }.

Check Default_ptr "NULL".
Check  "a" := && "b".

Check ( "nat_pointer" := NAT** "n") ;; ( "n" p:= n* "p")  .
Check ( "bool_pointer" := BOOL** "bool") ;; ( "bool" r:= && "b_true").
Check  ( "string_pointer" := STR** "str")  ;; ("str" r:= && "syntax").

Check (BOOL "new" ::= b_false) ;;
      ( "new" p:=b* "ok" ) ;; ("ok" r:= && "new").

(*SEMANTICS*)

Definition env_1 := update_local_mem env_default "x" (num 3) (get_local_top env_default).
Definition env_2 := update_local_mem env_1 "y" (num 5) (get_local_top env_1).
Definition env_3 := update_local_mem env_1 "value" (val_bool false) (get_local_top env_1).
Definition env_4 := update_local_mem env_default "str1" (val_string "proiectPLP") (get_local_top env_default).

Compute get_local_adress env_2 "x".
Compute get_local_adress env_2 "y".

Example ex_1 : ("x" /' 0)  =[ env_default ]=> err.
Proof.
  eapply e_div.
  - apply e_avar.
  - apply e_const.
  - simpl. reflexivity.
Qed.

Example ex_2 : (100 -' 50)  =[ env_default ]=> val_nat 50.
Proof.
  eapply e_minus.
  -apply e_const.
  -apply e_const.
  -simpl. reflexivity.
Qed.

Example ex_3 : "x" +' "y" =[ env_2 ]=> val_nat 8.
Proof.
  eapply e_add.
  -eapply e_avar.
    -simpl.
    +eapply e_avar.
    -simpl. reflexivity.
Qed.

Example ex_4: (b_true & b_false) ={ env_default }=> val_bool false.
Proof.
  eapply e_and_true.
  -eapply e_true.
  -eapply e_false.
Qed.

Example ex_5 : ( !(b_var "value") )  ={ env_3 }=> true.
Proof.
  eapply e_not_false.
  - eapply e_bvar.
Qed.

Example ex_6 : len[ "str1" ] =[ env_4 ]=> val_nat 10.
Proof.
   eapply e_strlen.
   - apply s_var.
   - simpl. reflexivity.
Qed.

Example ex_7 : exists env',
  (Default_nat "valnat" ;.;
   Default_bool "valbool" )-{{ env_default }}=> env'
        /\ get_value env' "valnat" = 0 /\ get_value env' "valbool" = false.
Proof.
 eexists.
  split.
  - eapply e_secv.
  + eapply e_default_nat_decl. simpl. trivial.
  + eapply e_default_bool_decl. simpl. trivial.
  -split; simpl; trivial.
Qed.

Example ex_8 : exists env', ( (NAT "p1" ::= 18) ;;
                                "p2" := NAT** "p1"  ) -{ env_default , env_default }-> env' , env_default
    /\ get_value env' "p1" = pointer_value env' "p2".

Proof.
  eexists.
  split.
  *eapply e_sequence.
  -eapply e_nat_decl. eapply e_const. simpl. trivial.
    -eapply e_ptr_nat_decl.
    +simpl. trivial.
    + simpl. trivial.
    + simpl. trivial.
    * simpl. trivial.
Qed.

Example ex_9 :  exists env', ( BOOL "bul" ::= b_false ;; "bul" b:= b_true )-{ env_default , env_default }-> env' , env_default
    /\ get_value env' "bul" = val_bool true.

Proof.
 eexists.
  split.
  *eapply e_sequence.
  +eapply e_bool_decl.
  -eapply e_false.
  -unfold local. simpl. trivial.
  +eapply e_bool_assign.
  -simpl. trivial.
  -eapply e_true.
  -unfold update_at_adress. simpl. trivial.
  *simpl. unfold update_memory. simpl. trivial.
Qed.

Example ex_10 : exists env',
              (
               (NAT "x" ::= 0 );;
               While
                ( "x" <' 0 )
                {"x" n:= "x" +++ } End
              )-{ env_default, env_default }-> env' , env_default
    /\ get_value env' "x" = 0.
Proof.
  eexists.
  split.
  -eapply e_sequence.
    +eapply e_nat_decl. eapply e_const. simpl. trivial.
    +eapply e_while_false.
      *eapply e_less. eapply e_avar. simpl. trivial.
       eapply e_const. simpl. trivial.
       - simpl. simpl. trivial.
Qed.


Require Coq.Strings.String.

Set Implicit Arguments.

Axiom falso : False.
Ltac admit := destruct falso.

Reserved Notation "[ x ]".

Record string_like (CharType : Type) :=
  {
    String :> Type;
    Singleton : CharType -> String where "[ x ]" := (Singleton x);
    Empty : String;
    Concat : String -> String -> String where "x ++ y" := (Concat x y);
    bool_eq : String -> String -> bool;
    bool_eq_correct : forall x y : String, bool_eq x y = true <-> x = y;
    Length : String -> nat
  }.

Delimit Scope string_like_scope with string_like.
Bind Scope string_like_scope with String.
Arguments Length {_%type_scope _} _%string_like.
Infix "++" := (@Concat _ _) : string_like_scope.

Definition str_le {CharType} {String : string_like CharType} (s1 s2 : String)
  := Length s1 < Length s2 \/ s1 = s2.
Infix "â‰¤s" := str_le (at level 70, right associativity).

Module Export ContextFreeGrammar.
  Import Coq.Strings.String.
  Import Coq.Lists.List.

  Section cfg.
    Variable CharType : Type.

    Section definitions.

      Inductive item :=
    | NonTerminal (name : string).

      Definition production := list item.
      Definition productions := list production.

      Record grammar :=
        {
          Start_symbol :> string;
          Lookup :> string -> productions
        }.
    End definitions.

    Section parse.
      Variable String : string_like CharType.
      Variable G : grammar.

      Inductive parse_of : String -> productions -> Type :=
      | ParseHead : forall str pat pats, parse_of_production str pat
                                         -> parse_of str (pat::pats)
      | ParseTail : forall str pat pats, parse_of str pats
                                         -> parse_of str (pat::pats)
      with parse_of_production : String -> production -> Type :=
      | ParseProductionCons : forall str pat strs pats,
                                parse_of_item str pat
                                -> parse_of_production strs pats
                                -> parse_of_production (str ++ strs) (pat::pats)
      with parse_of_item : String -> item -> Type :=
      | ParseNonTerminal : forall name str, parse_of str (Lookup G name)
                                            -> parse_of_item str (NonTerminal
name).
    End parse.
  End cfg.

End ContextFreeGrammar.
Module Export ContextFreeGrammarProperties.

  Section cfg.
    Context CharType (String : string_like CharType) (G : grammar)
            (P : String.string -> Type).

    Fixpoint Forall_parse_of {str pats} (p : parse_of String G str pats)
      := match p with
           | @ParseHead _ _ _ str pat pats p'
             => Forall_parse_of_production p'
           | @ParseTail _ _ _ _ _ _ p'
             => Forall_parse_of p'
         end
    with Forall_parse_of_production {str pat} (p : parse_of_production String G
str pat)
         := let Forall_parse_of_item {str it} (p : parse_of_item String G str
it)
                := match p return Type with
                     | @ParseNonTerminal _ _ _ name str p'
                       => (P name * Forall_parse_of p')%type
                   end in
            match p return Type with
              | @ParseProductionCons _ _ _ str pat strs pats p' p''
                => (Forall_parse_of_item p' * Forall_parse_of_production
p'')%type
            end.

    Definition Forall_parse_of_item {str it} (p : parse_of_item String G str it)
      := match p return Type with
           | @ParseNonTerminal _ _ _ name str p'
             => (P name * Forall_parse_of p')%type
         end.
  End cfg.

End ContextFreeGrammarProperties.

Module Export DependentlyTyped.
  Import Coq.Strings.String.

  Section recursive_descent_parser.

    Class parser_computational_predataT :=
      { nonterminal_names_listT : Type;
        initial_nonterminal_names_data : nonterminal_names_listT;
        is_valid_nonterminal_name : nonterminal_names_listT -> string -> bool;
        remove_nonterminal_name : nonterminal_names_listT -> string ->
nonterminal_names_listT }.

  End recursive_descent_parser.

End DependentlyTyped.
Import Coq.Strings.String.
Import Coq.Lists.List.

Section cfg.
  Context CharType (String : string_like CharType) (G : grammar).
  Context (names_listT : Type)
          (initial_names_data : names_listT)
          (is_valid_name : names_listT -> string -> bool)
          (remove_name : names_listT -> string -> names_listT).

  Inductive minimal_parse_of
  : forall (str0 : String) (valid : names_listT)
           (str : String),
      productions -> Type :=
  | MinParseHead : forall str0 valid str pat pats,
                     @minimal_parse_of_production str0 valid str pat
                     -> @minimal_parse_of str0 valid str (pat::pats)
  | MinParseTail : forall str0 valid str pat pats,
                     @minimal_parse_of str0 valid str pats
                     -> @minimal_parse_of str0 valid str (pat::pats)
  with minimal_parse_of_production
       : forall (str0 : String) (valid : names_listT)
                (str : String),
           production -> Type :=
  | MinParseProductionNil : forall str0 valid,
                              @minimal_parse_of_production str0 valid (Empty _)
nil
  | MinParseProductionCons : forall str0 valid str strs pat pats,
                               str ++ strs â‰¤s str0
                               -> @minimal_parse_of_item str0 valid str pat
                               -> @minimal_parse_of_production str0 valid strs
pats
                               -> @minimal_parse_of_production str0 valid (str
++ strs) (pat::pats)
  with minimal_parse_of_item
       : forall (str0 : String) (valid : names_listT)
                (str : String),
           item -> Type :=
  | MinParseNonTerminal
    : forall str0 valid str name,
        @minimal_parse_of_name str0 valid str name
        -> @minimal_parse_of_item str0 valid str (NonTerminal name)
  with minimal_parse_of_name
       : forall (str0 : String) (valid : names_listT)
                (str : String),
           string -> Type :=
  | MinParseNonTerminalStrLt
    : forall str0 valid name str,
        @minimal_parse_of str initial_names_data str (Lookup G name)
        -> @minimal_parse_of_name str0 valid str name
  | MinParseNonTerminalStrEq
    : forall str valid name,
        @minimal_parse_of str (remove_name valid name) str (Lookup G name)
        -> @minimal_parse_of_name str valid str name.
  Definition parse_of_item_name__of__minimal_parse_of_name
  : forall {str0 valid str name} (p : @minimal_parse_of_name str0 valid str
name),
      parse_of_item String G str (NonTerminal name).
  Proof.
    admit.
  Defined.

End cfg.

Section recursive_descent_parser.
  Context (CharType : Type)
          (String : string_like CharType)
          (G : grammar).
  Context {premethods : parser_computational_predataT}.
  Let P : string -> Prop.
  Proof.
    admit.
  Defined.

  Let mp_parse_nonterminal_name str0 valid str nonterminal_name
    := { p' : minimal_parse_of_name String G initial_nonterminal_names_data
remove_nonterminal_name str0 valid str nonterminal_name & Forall_parse_of_item
P (parse_of_item_name__of__minimal_parse_of_name p') }.

  Goal False.
  Proof.
    clear -mp_parse_nonterminal_name.
    subst P.
    simpl in *.
    admit.
  Qed.


(* This file defines what it means for a state of the Atari 2600 to be reachable from another state. *)

From Coq Require Import Relations.
Require Utils Word Memory Processor.
Import Word Memory(memory) Processor(cycle, cycles, read, write, zero, suc).

Inductive chip_selection :=
| ROM : word 12 -> chip_selection
| RAM : word 7 -> chip_selection
| TIA : word 6 -> chip_selection
| PIA : word 5 -> chip_selection
.

Definition chip_select (addr : word 16) : chip_selection :=
if       bit addr 12%b  then ROM (fst (split (m := 12) addr)) else
if negb (bit addr  7%b) then TIA (fst (split (m :=  6) addr)) else
if       bit addr  9%b  then PIA (fst (split (m :=  5) addr)) else
                             RAM (fst (split (m :=  7) addr))
.

Section with_rom.
    Variable rom : word 12 -> word 8.

    Definition cycle_rel {T}
        (input : cycle T * memory 7 (word 8))
        (output :      T * memory 7 (word 8)) : Prop :=
    match fst input with
    | read addr continuation => snd input = snd output /\
        match chip_select addr with
        | ROM addr => continuation (rom addr) = fst output
        | RAM addr => continuation (Memory.read addr (snd input)) = fst output
        | _ => exists w, continuation w = fst output
        end
    | write addr w continuation => continuation = fst output /\
        match chip_select addr with
        | RAM addr => Memory.write addr w (snd input) = snd output
        | _ => snd input = snd output
        end
    end.

    Definition cycles_rel {T}
        (input : cycles T * memory 7 (word 8))
        (output :       T * memory 7 (word 8)) : Prop :=
    clos_refl_trans_1n _
        (fun x => match fst x with
        | zero t => fun _ => False
        | suc t => cycle_rel (t, snd x)
        end)
        input (zero (fst output), snd output).

    Definition state := (Processor.registers * memory 7 (word 8))%type.

    Definition instruction_rel : relation state :=
    fun x z => exists y,
        cycle_rel (Processor.step (fst x), snd x) y /\
        match fst y with
        | Some c => cycles_rel (c, snd y) z
        (* If an illegal opcode is executed, I assume anything can happen. *)
        | None => True
        end.

    Definition reachable : relation state := clos_refl_trans_1n _ instruction_rel.
End with_rom.


Set Implicit Arguments.
Require Import Omega Logic List Classes.Morphisms.
Import List Notations.

From cbpv Require Import base syntax.

Scheme value_ind_2 := Induction for value Sort Prop
  with comp_ind_2  := Induction for comp Sort Prop.

Combined Scheme mutind_val_comp from value_ind_2, comp_ind_2.

(** * CBPV Types *)
(**
  Types of CBPV terms.
  Values in valtype are types of values
  and values in comptype are types of computations
*)
(** ** Value Types*)
Inductive valtype : Type :=
| zero: valtype
| one: valtype
| U: comptype -> valtype
| Sigma: valtype -> valtype -> valtype
| cross: valtype -> valtype -> valtype

(** ** Computation Types*)
with comptype : Type :=
| cone: comptype
| F: valtype -> comptype
| Pi: comptype -> comptype -> comptype
| arrow: valtype -> comptype -> comptype.

(** Combined induction schemes for types *)
Scheme valtype_ind_2 := Induction for valtype Sort Prop
  with comptype_ind_2  := Induction for comptype Sort Prop.

Combined Scheme mutind_valtype_comptype from valtype_ind_2, comptype_ind_2.

(** ** Ground Types*)
(** Ground Types, they only contain One, Sums and Pairs *)
Inductive groundtype : Type :=
| gone : groundtype
| gsum : groundtype -> groundtype -> groundtype
| gcross : groundtype -> groundtype -> groundtype.

(** We use the follwing obvious mapping from ground types to valtypes as a coercion,
    which hepls the notion on paper that every ground type is a valtype *)
Fixpoint to_valtype (G: groundtype) :=
  match G with
  | gone => one
  | gsum G1 G2 => Sigma (to_valtype  G1) (to_valtype  G2)
  | gcross G1 G2 => cross (to_valtype  G1) (to_valtype  G2)
  end.

Coercion to_valtype: groundtype >-> valtype.

Fixpoint nat_to_fin {m: nat} (n: nat)  : fin (S (it S n m)) :=
  match n with
  | O => var_zero
  | S n => Some (nat_to_fin n)
  end.

Definition var {m: nat} (n: nat) : value (S (it S n m)) :=
  var_value (nat_to_fin n).

(** We use the following notations for terms  *)
Notation "<{ c }>" := (thunk c).
Notation "c !" := (force c) (at level 50).
Notation "$ <- A ; B" := (letin A B) (at level 55).
Notation "⦉ A ; B ⦊" := (pair A B) (at level 52). (* used to be langle *)
Notation "A → B" := (arrow A B) (at level 53).
Notation "A * B" := (cross A B).
Coercion app : comp >-> Funclass.


Require Export Fiat.Parsers.ContextFreeGrammar.Fix.Definitions.
Require Import Fiat.Common.
Require Import Fiat.Common.Wf.
Require Import Fiat.Common.Notations.
Require Import Fiat.Common.BoolFacts.

Set Implicit Arguments.
Local Open Scope grammar_fixedpoint_scope.

Lemma state_beq_lb {prestate} {fp : grammar_fixedpoint_lattice_data prestate} (s s' : state) (H : s = s') : s =b s'.
Proof.
  subst; reflexivity.
Qed.

Lemma state_beq_refl {prestate} {fp : grammar_fixedpoint_lattice_data prestate} (s : state) : s =b s.
Proof.
  reflexivity.
Qed.

Lemma state_le_refl {prestate} {fp : grammar_fixedpoint_lattice_data prestate} (s : state) : s <= s.
Proof.
  unfold state_le.
  rewrite state_beq_lb by reflexivity.
  reflexivity.
Qed.

Global Instance state_lt_Irreflexive {T d} : Irreflexive (@state_lt T d).
Proof.
  intros x H.
  induction (state_gt_wf x) as [x H' IH].
  eauto.
Qed.

Global Instance state_le_Reflexive {T d} : Reflexive (@state_le T d).
Proof.
  unfold state_le; repeat intro; rewrite state_beq_refl; reflexivity.
Qed.

Global Instance state_beq_Proper_Proper {prestate} {d : grammar_fixedpoint_lattice_data prestate}
  : Proper (state_beq ==> state_beq ==> eq) state_beq.
Proof.
  intros a b H a' b' H'.
  destruct (b =b b') eqn:H'';
    fold_is_true.
  { etransitivity; [ eassumption | ].
    etransitivity; [ eassumption | ].
    symmetry; assumption. }
  { destruct (a =b a') eqn:H'''; trivial;
    rewrite <- H''; clear H''; symmetry;
    fold_is_true.
    etransitivity; [ | eassumption ].
    etransitivity; [ | eassumption ].
    symmetry; assumption. }
Qed.

Global Instance state_beq_Proper_le {prestate} {d : grammar_fixedpoint_lattice_data prestate}
  : Proper (state_beq ==> state_beq ==> eq) state_le.
Proof.
  intros a b H a' b' H'.
  unfold state_le.
  rewrite H, H'.
  reflexivity.
Qed.

Global Instance beq_subrelation_le {prestate} {d : grammar_fixedpoint_lattice_data prestate}
  : subrelation state_beq state_le.
Proof.
  intros ?? H.
  setoid_rewrite H.
  reflexivity.
Qed.

Global Instance state_le_Transitive {T d} : Transitive (@state_le T d).
Proof.
  unfold state_le, is_true; repeat intro;
    rewrite Bool.orb_true_iff in *;
    destruct_head or;
    repeat match goal with
           | [ H : context[?x = true] |- _ ] => progress fold (is_true x) in *
           | [ |- context[?x = true] ] => progress fold (is_true x) in *
           | [ H : is_true (?x =b ?y) |- _ ] => rewrite H in *; clear x H
           | _ => left; reflexivity
           | _ => solve [ eauto ]
           | _ => right; etransitivity; eassumption
           end.
Qed.

Lemma bottom_bottom {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : ⊥ <= s.
Proof.
  destruct s; reflexivity.
Qed.

Lemma top_top {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : s <= ⊤.
Proof.
  destruct s; reflexivity.
Qed.

Lemma no_state_lt_bottom {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (s < ⊥) = false.
Proof.
  destruct s; reflexivity.
Qed.

Lemma no_state_gt_top {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (⊤ < s) = false.
Proof.
  destruct s; reflexivity.
Qed.

Lemma state_le_bottom_eq_bottom {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (s <= ⊥) = (s =b ⊥).
Proof.
  destruct s; reflexivity.
Qed.

Lemma state_ge_top_eq_top {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (⊤ <= s) = (s =b ⊤).
Proof.
  destruct s; reflexivity.
Qed.

Lemma top_lub_r {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (s ⊔ ⊤) = ⊤.
Proof.
  destruct s; reflexivity.
Qed.

Lemma top_lub_l {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (⊤ ⊔ s) = ⊤.
Proof.
  destruct s; reflexivity.
Qed.

Lemma bottom_lub_r {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (s ⊔ ⊥) = s.
Proof.
  destruct s; reflexivity.
Qed.

Lemma bottom_lub_l {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (⊥ ⊔ s) = s.
Proof.
  destruct s; reflexivity.
Qed.

Global Instance state_le_Proper_le {state} {d : grammar_fixedpoint_lattice_data state}
: Proper (@state_le _ d ==> Basics.flip (@state_le _ d) ==> Basics.flip Basics.impl) (@state_le _ d).
Proof.
  unfold Basics.flip; intros ?? H ?? H' H''.
  repeat first [ eassumption | etransitivity; [ eassumption | ] ].
Qed.

Global Instance state_le_Proper_le' {state} {d : grammar_fixedpoint_lattice_data state}
: Proper (@state_le _ d ==> Basics.flip (@state_le _ d) ==> Basics.flip implb) (@state_le _ d).
Proof.
  unfold Basics.flip; intros (*?? [??]*) ?? H ?? H'; subst.
  match goal with |- is_true (implb ?v _) => destruct v eqn:?; simpl; [ | reflexivity ] end.
  repeat first [ eassumption | etransitivity; [ eassumption | ] ].
Qed.

Global Instance state_le_flip_Reflexive {state} {d : grammar_fixedpoint_lattice_data state}
: Reflexive (Basics.flip (@state_le _ d)) | 2.
Proof.
  unfold Basics.flip; intro; reflexivity.
Qed.

Global Instance prestate_le_Antisymmetric {prestate} {fpdata : grammar_fixedpoint_lattice_data prestate}
  : Antisymmetric _ prestate_beq prestate_le.
Proof.
  unfold prestate_le.
  intros x y H0 H1.
  bool_congr_setoid.
  destruct H0 as [H0|H0]; [ | destruct H1 as [H1|H1] ];
    [ assumption
    | symmetry; assumption
    | ].
  exfalso; eapply no_wf_cycle; [ eexact prestate_gt_wf | | ];
    unfold flip; eassumption.
Qed.

Global Instance state_le_Antisymmetric {prestate} {fpdata : grammar_fixedpoint_lattice_data prestate}
  : Antisymmetric _ state_beq state_le.
Proof.
  unfold state_le.
  intros x y H0 H1.
  bool_congr_setoid.
  destruct H0 as [H0|H0]; [ | destruct H1 as [H1|H1] ];
    [ assumption
    | symmetry; assumption
    | ].
  exfalso; eapply no_wf_cycle; [ eexact state_gt_wf | | ];
    unfold flip; eassumption.
Qed.

Global Instance state_beq_Proper_eq {a b}
  : Proper (eq ==> eq ==> eq) (@state_beq a b)
  := _.


Require Import Bool Arith List Omega ListSet.
Require Import Recdef Morphisms.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require FMapList.
Require FMapFacts.
Require Import Classical.
Require Import Coq.Classes.RelationClasses.
Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Sorting.Permutation.
Import ListNotations.
Require Import SImpECommon.
Require Import SImpE.

(*******************************************************************************
*
* SYNTAX
*
*******************************************************************************)

Section Syntax.
  Inductive val2 : Type :=
  | VSingle: val -> val2
  | VPair: val -> val -> val2.

  Definition not_pair_val (v : val2) : Prop :=
    match v with
    | VPair _ _ => False
    | _ => True
    end.
End Syntax.

(*******************************************************************************
*
* SEMANTICS
*
*******************************************************************************)

Section Semantics.
  Definition reg2 : Type := register val2.
  Definition reg_init2 : reg2 := fun x => VSingle (Vnat 0).
  Definition mem2 : Type := memory val2.

  Inductive event2 : Type :=
  | Emp2 : event2
  | Decl2 : exp -> mem2 -> event2
  | Mem2 : mem2 -> event2
  | Out2 : sec_level -> val2 -> event2
  | Update2 : mem2 -> location -> val2 -> event2
  | Assign2 : reg2 -> var -> val2 -> event2
  | ANonEnc2 : com -> event2
  | AEnc2 : forall c c' : com, enc_equiv c c' -> event2
  | EPair : event2 -> event2 -> event2.
  Definition trace2 : Type := list event2.

  Definition val_to_val2 (v: val) : val2 := VSingle v.
  Definition mem_to_mem2 (m: mem) : mem2 := fun x => val_to_val2 (m x).
  Definition reg_to_reg2 (r: reg) : reg2 := fun x => val_to_val2 (r x).
  Function merge_reg (r1 r2 : reg) : reg2 :=
    fun x =>
      if (val_decidable (r1 x) (r2 x)) then VSingle (r1 x) else VPair (r1 x) (r2 x).
  Function merge_mem (m1 m2 : mem) : mem2 :=
    fun l =>
      if (val_decidable (m1 l) (m2 l)) then VSingle (m1 l) else VPair (m1 l) (m2 l).

  Definition event_to_event2 (e: event) : event2 :=
    match e with
      | Mem m => Mem2 (mem_to_mem2 m)
      | Decl e m => Decl2 e (mem_to_mem2 m)
      | Out l v => Out2 l (val_to_val2 v)
      | Update m l v => Update2 (mem_to_mem2 m) l (val_to_val2 v)
      | Assign r x v => Assign2 (reg_to_reg2 r) x (val_to_val2 v)
      | ANonEnc c => ANonEnc2 c
      | AEnc c1 c2 enc_equiv => AEnc2 c1 c2 enc_equiv
      | Emp => Emp2
    end.
  Definition tracepair_len (t: trace * trace) := length (fst t) + length (snd t).
  Function merge_trace (t: trace * trace) {measure tracepair_len t} : trace2 :=
    match fst t, snd t with
    | a1::tl1, a2::tl2 => EPair (event_to_event2 a1)
                                 (event_to_event2 a2) :: (merge_trace (tl1, tl2))
    | a1::tl1, [] => EPair (event_to_event2 a1) Emp2 :: merge_trace (tl1, [])
    | [], a2::tl2 => EPair Emp2 (event_to_event2 a2) :: merge_trace ([], tl2)
    | _, _ => []
    end.
  Proof. all: intros; unfold tracepair_len; rewrite teq, teq0; simpl; omega. Qed.

  Function project_value (v: val2) (is_left: bool): val :=
    match v with
    | VPair v1 v2 => if is_left then v1 else v2
    | VSingle v => v
    end.
  Definition project_reg (r: reg2) (is_left : bool): reg :=
    fun x => match r x with
             | VPair v1 v2 => if is_left then v1 else v2
             | VSingle v => v
          end.
  Definition project_mem (m: mem2) (is_left : bool): mem :=
    fun x => match m x with
             | VPair v1 v2 => if is_left then v1 else v2
             | VSingle v => v
          end.

  Function event2_to_event (e: event2) (is_left: bool): event :=
     match e with
      | Mem2 m => Mem (project_mem m is_left)
      | Decl2 e m => Decl e (project_mem m is_left)
      | Out2 l v => Out l (project_value v is_left)
      | Update2 m l v => Update (project_mem m is_left) l (project_value v is_left)
      | Assign2 r x v => Assign (project_reg r is_left) x (project_value v is_left)
      | ANonEnc2 c => ANonEnc c
      | AEnc2 c1 c2 enc_equiv => AEnc c1 c2 enc_equiv
      | EPair e1 e2 => if is_left then event2_to_event e1 is_left
                        else event2_to_event e2 is_left
      | Emp2 => Emp
     end.
  Function project_trace (t: trace2) (is_left : bool) : trace :=
    match t with
    | [] => []
    | hd :: tl => let hd_proj := (event2_to_event hd is_left) in
      match hd_proj with
      | Emp => project_trace tl is_left
      | _ => hd_proj :: project_trace tl is_left
      end
    end.

  Definition econfig2 : Type := exp * reg2 * mem2.
  Definition ecfg_exp2 (ecfg: econfig2) : exp :=
    match ecfg with (e, _, _) => e end.
  Definition ecfg_reg2 (ecfg: econfig2) : reg2 :=
    match ecfg with (_, r, _) => r end.
  Definition ecfg_mem2 (ecfg: econfig2) : mem2 :=
    match ecfg with (_, _, m) => m end.
  Definition ecfg_update_exp2 (ecfg: econfig2) (e: exp) : econfig2 :=
    match ecfg with (_, r, m) => (e, r, m) end.
  Definition esemantics2 : Type := mode -> loc_mode -> econfig2 -> val2 -> Prop.

   Definition project_ecfg (ecfg : econfig2) (is_left : bool) : econfig :=
    (ecfg_exp2 ecfg, project_reg (ecfg_reg2 ecfg) is_left,
     project_mem (ecfg_mem2 ecfg) is_left).

   Definition contains_nat (v : val2) :=
     (exists n1, v = VSingle (Vnat n1)) \/
     (exists n1 n2, v = VPair (Vnat n1) (Vnat n2)).

   Fixpoint apply_op (op : nat -> nat -> nat) (v1 v2 : val2) :=
     match v1, v2 with
     | VSingle (Vnat n1), VSingle (Vnat n2) => VSingle (Vnat (op n1 n2))
     | VSingle (Vnat n1), VPair (Vnat n2) (Vnat n3) => VPair (Vnat (op n1 n2)) (Vnat (op n1 n3))
     | VPair (Vnat n1) (Vnat n2), VPair (Vnat n3) (Vnat n4) =>
                                  VPair (Vnat (op n1 n3)) (Vnat (op n2 n4))
     | VPair (Vnat n2) (Vnat n3), VSingle (Vnat n1) => VPair (Vnat (op n2 n1)) (Vnat (op n3 n1))
     | _, _ => v1
     end.

   Definition val2_add (v1 v2 :val2) := apply_op (fun x y => x + y) v1 v2.

   Inductive estep2 : esemantics2 :=
   | Estep2_nat : forall md d ecfg n,
       ecfg_exp2 ecfg = Enat n ->
       estep2 md d ecfg (VSingle (Vnat n))
   | Estep2_loc : forall md d ecfg l,
       ecfg_exp2 ecfg = Eloc l ->
       estep2 md d ecfg (VSingle (Vloc l))
   | Estep2_lambda : forall md d ecfg c,
       ecfg_exp2 ecfg = Elambda md c ->
      estep2 md d ecfg (VSingle (Vlambda md c))
   | Estep2_var : forall md d ecfg x v,
       ecfg_exp2 ecfg = Evar x ->
       ecfg_reg2 ecfg x = v ->
       estep2 md d ecfg v
   | Estep2_add : forall md d ecfg e1 e2 v1 v2,
       ecfg_exp2 ecfg = Eadd e1 e2 ->
       estep2 md d (ecfg_update_exp2 ecfg e1) v1 ->
       estep2 md d (ecfg_update_exp2 ecfg e2) v2 ->
       contains_nat v1 /\ contains_nat v2 ->
       estep2 md d ecfg (val2_add v1 v2)
   | Estep2_deref : forall md d ecfg e r m l v,
       ecfg = (Ederef e, r, m) ->
       estep2 md d (e, r, m) (VSingle (Vloc l)) ->
       m l = v ->
       mode_access_ok md d l ->
       estep2 md d ecfg v.

  (* Semantics for commands. *)
   Definition cconfig2 : Type := com * reg2 * mem2.
   Definition cterm2 : Type := reg2 * mem2.
   Definition ccfg_com2 (ccfg: cconfig2) : com :=
     match ccfg with (c, _, _) => c end.
   Definition ccfg_reg2 (ccfg: cconfig2) : reg2 :=
     match ccfg with (_, r, _) => r end.
   Definition ccfg_mem2 (ccfg: cconfig2) : mem2 :=
     match ccfg with (_, _, m) => m end.
   Definition ccfg_update_mem2 (ccfg: cconfig2) (l: location) (v: val2) : mem2 :=
     fun loc => if loc =? l then v
                else (ccfg_mem2 ccfg) loc.
   Definition ccfg_update_reg2 (ccfg: cconfig2) (x: var) (v: val2) : reg2 :=
     fun var => if var =? x then v
                else (ccfg_reg2 ccfg) var.
   Definition ccfg_to_ecfg2 (e: exp) (ccfg : cconfig2) : econfig2 :=
     (e, (ccfg_reg2 ccfg), (ccfg_mem2 ccfg)).
   Definition ccfg_update_com2 (c: com) (ccfg : cconfig2) : cconfig2 :=
     (c, (ccfg_reg2 ccfg), (ccfg_mem2 ccfg)).
   Definition csemantics2 : Type := mode -> loc_mode -> cconfig2 -> cterm2 -> trace2 -> Prop.

   Definition project_ccfg (ccfg : cconfig2) (is_left : bool) : cconfig :=
     (ccfg_com2 ccfg, project_reg (ccfg_reg2 ccfg) is_left,
      project_mem (ccfg_mem2 ccfg) is_left).

  Inductive cstep2 : csemantics2 :=
  | Cstep2_skip : forall md d ccfg,
      ccfg_com2 ccfg = Cskip ->
      cstep2 md d ccfg (ccfg_reg2 ccfg, ccfg_mem2 ccfg) []
  | Cstep2_assign : forall md d ccfg x e v r',
      ccfg_com2 ccfg = Cassign x e ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) v ->
      r' = ccfg_update_reg2 ccfg x v ->
      cstep2 md d ccfg (r', ccfg_mem2 ccfg) [Assign2 (ccfg_reg2 ccfg) x v]
  | Cstep2_declassify : forall md d ccfg x e v r',
      ccfg_com2 ccfg = Cdeclassify x e ->
      exp_novars e ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) v ->
      r' = ccfg_update_reg2 ccfg x v ->
      cstep2 md d ccfg (r', ccfg_mem2 ccfg) [Decl2 e (ccfg_mem2 ccfg)]
  | Cstep2_update : forall md d ccfg e1 e2 l v m',
      ccfg_com2 ccfg = Cupdate e1 e2 ->
      estep2 md d (ccfg_to_ecfg2 e1 ccfg) (VSingle (Vloc l)) ->
      estep2 md d (ccfg_to_ecfg2 e2 ccfg) v ->
      m' = ccfg_update_mem2 ccfg l v ->
      cstep2 md d ccfg (ccfg_reg2 ccfg, m') [Update2 (ccfg_mem2 ccfg) l v]
  | Cstep2_output : forall md d ccfg e sl v,
      ccfg_com2 ccfg = Coutput e sl ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) v ->
      cstep2 md d ccfg (ccfg_reg2 ccfg, ccfg_mem2 ccfg)
             [Mem2 (ccfg_mem2 ccfg); Out2 sl v]
  | Cstep2_call : forall md d ccfg e c r' m' tr,
      ccfg_com2 ccfg = Ccall e ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VSingle (Vlambda md c)) ->
      cstep2 md d (ccfg_update_com2 c ccfg) (r', m') tr ->
      cstep2 md d ccfg (r', m') tr
  | Cstep2_call_div : forall md d ccfg e c1 c2 r1 m1 t1 r2 m2 t2 rmerge mmerge,
      ccfg_com2 ccfg = Ccall e ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VPair (Vlambda md c1) (Vlambda md c2)) ->
      cstep md d (c1, project_reg (ccfg_reg2 ccfg) true,
                  project_mem (ccfg_mem2 ccfg) true)
                  (r1, m1) t1 ->
      cstep md d (c2, project_reg (ccfg_reg2 ccfg) false,
                  project_mem (ccfg_mem2 ccfg) false)
            (r2, m2) t2 ->
      merge_reg r1 r2 = rmerge ->
      merge_mem m1 m2 = mmerge ->
      cstep2 md d ccfg (rmerge, mmerge) (merge_trace (t1, t2))
  | Cstep2_enclave : forall md d ccfg enc c r' m' tr,
    md = Normal ->
    ccfg_com2 ccfg = Cenclave enc c ->
    cstep2 (Encl enc) d (c, ccfg_reg2 ccfg, ccfg_mem2 ccfg) (r', m') tr ->
    cstep2 md d ccfg (r', m') tr
  | Cstep2_seq_nil : forall md d ccfg,
      ccfg_com2 ccfg = Cseq [] ->
      cstep2 md d ccfg (ccfg_reg2 ccfg, ccfg_mem2 ccfg) []
  | Cstep2_seq_hd : forall md d ccfg hd tl r m tr r' m' tr',
      ccfg_com2 ccfg = Cseq (hd::tl) ->
      cstep2 md d (ccfg_update_com2 hd ccfg) (r, m) tr ->
      cstep2 md d (Cseq tl, r, m) (r', m') tr' ->
      cstep2 md d ccfg (r', m') (tr++tr')
  | Cstep2_if : forall md d ccfg e c1 c2 r' m' tr,
      ccfg_com2 ccfg = Cif e c1 c2 ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VSingle (Vnat 1)) ->
      cstep2 md d (ccfg_update_com2 c1 ccfg) (r', m') tr ->
      cstep2 md d ccfg (r', m') tr
  | Cstep2_else : forall md d ccfg e c1 c2 r' m' tr,
      ccfg_com2 ccfg = Cif e c1 c2 ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VSingle (Vnat 0)) ->
      cstep2 md d (ccfg_update_com2 c2 ccfg) (r', m') tr ->
      cstep2 md d ccfg (r', m') tr
  | Cstep2_if_div : forall md d ccfg e c1 c2 n1 n2 r1 m1 t1 r2 m2 t2 rmerge mmerge,
      ccfg_com2 ccfg = Cif e c1 c2 ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VPair (Vnat n1) (Vnat n2)) ->
      n1 < 2 /\ n2 < 2 ->
      let cleft := (match n1 with
                    | 0 => c2
                    | _ => c1 end) in
      cstep md d (cleft, project_reg (ccfg_reg2 ccfg) true,
                  project_mem (ccfg_mem2 ccfg) true)
                  (r1, m1) t1 ->
      let cright := (match n2 with
                     | 0 => c2
                     | _ => c1 end) in
      cstep md d (cright, project_reg (ccfg_reg2 ccfg) false,
                  project_mem (ccfg_mem2 ccfg) false)
                  (r2, m2) t2 ->
      merge_reg r1 r2 = rmerge ->
      merge_mem m1 m2 = mmerge ->
      cstep2 md d ccfg (rmerge, mmerge) (merge_trace (t1, t2))
  | Cstep2_while_t : forall md d ccfg e c r m tr r' m' tr',
      ccfg_com2 ccfg = Cwhile e c ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VSingle (Vnat 1)) ->
      cstep2 md d (ccfg_update_com2 c ccfg) (r, m) tr ->
      cstep2 md d (Cwhile e c,r,m) (r', m') tr' ->
      cstep2 md d ccfg (r', m') (tr++tr')
  | Cstep2_while_f : forall md d ccfg e c,
      ccfg_com2 ccfg = Cwhile e c ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VSingle (Vnat 0)) ->
      cstep2 md d ccfg (ccfg_reg2 ccfg, ccfg_mem2 ccfg) []
  | Cstep2_while_div : forall md d ccfg e c n1 n2 r1 m1 t1 r2 m2 t2 rmerge mmerge,
      ccfg_com2 ccfg = Cwhile e c ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VPair (Vnat n1) (Vnat n2)) ->
      n1 < 2 /\ n2 < 2 ->
      let cleft := (match n1 with
                    | 0 => Cskip
                    | _ => Cseq [c; Cwhile e c] end) in
      cstep md d (cleft, project_reg (ccfg_reg2 ccfg) true,
                  project_mem (ccfg_mem2 ccfg) true)
                  (r1, m1) t1 ->
      let cright := (match n2 with
                     | 0 => Cskip
                     | _ => Cseq [c; Cwhile e c] end) in
      cstep md d (cright, project_reg (ccfg_reg2 ccfg) false,
                  project_mem (ccfg_mem2 ccfg) false)
            (r2, m2) t2 ->
      merge_reg r1 r2 = rmerge ->
      merge_mem m1 m2 = mmerge ->
      cstep2 md d ccfg (rmerge, mmerge) (merge_trace (t1, t2))
  .
  Hint Constructors cstep2.

  Inductive imm_premise : com -> mode -> reg2 -> mem2 -> reg2 -> mem2 -> trace2 ->
                          com -> mode -> reg2 -> mem2 -> reg2 -> mem2 -> trace2 ->
                          loc_mode -> Prop :=
  | IPcall: forall md d e r m r' m' tr c,
      estep2 md d (e, r, m) (VSingle (Vlambda md c)) ->
      cstep2 md d (c, r, m) (r', m') tr ->
      cstep2 md d (Ccall e, r, m) (r', m') tr ->
      imm_premise c md r m r' m' tr
                  (Ccall e) md r m r' m' tr d
  | IPencl: forall d encl c r m r' m' tr,
      cstep2 (Encl encl) d (c, r, m) (r', m') tr ->
      cstep2 Normal d (Cenclave encl c, r, m) (r', m') tr ->
      imm_premise c (Encl encl) r m r' m' tr
                  (Cenclave encl c) Normal r m r' m' tr d
  | IPseq1: forall md d c rest r m r' m' r'' m'' tr tr',
      cstep2 md d (c, r, m) (r', m') tr' ->
      cstep2 md d (Cseq rest, r', m') (r'', m'') tr ->
      cstep2 md d (Cseq (c :: rest), r, m) (r'', m'') (tr' ++ tr) ->
      imm_premise c md r m r' m' tr'
                  (Cseq (c :: rest)) md r m r'' m'' (tr'++tr) d
  | IPseq2: forall md d c rest r m r' m' r'' m'' tr tr',
      cstep2 md d (c, r, m) (r', m') tr' ->
      cstep2 md d (Cseq rest, r', m') (r'', m'') tr ->
      cstep2 md d (Cseq (c :: rest), r, m) (r'', m'') (tr' ++ tr) ->
      imm_premise (Cseq rest) md r' m' r'' m'' tr
                  (Cseq (c :: rest)) md r m r'' m'' (tr' ++ tr) d
  | IPif: forall md d c1 c2 e r m r' m' tr,
      estep2 md d (e, r, m) (VSingle (Vnat 1)) ->
      cstep2 md d (c1, r, m) (r', m') tr ->
      cstep2 md d (Cif e c1 c2, r, m) (r', m') tr ->
      cstep2 md d (Cif e c1 c2, r, m) (r', m') (tr) ->
      imm_premise c1 md r m r' m' tr
                  (Cif e c1 c2) md r m r' m' tr d
  | IPelse: forall md d c1 c2 e r m r' m' tr,
      estep2 md d (e, r, m) (VSingle (Vnat 0)) ->
      cstep2 md d (c2, r, m) (r', m') tr ->
      cstep2 md d (Cif e c1 c2, r, m) (r', m') tr ->
      imm_premise c2 md r m r' m' tr (Cif e c1 c2) md r m r' m' tr d
  | IPwhilet1: forall md d c e r m r' m' r'' m'' tr tr',
      estep2 md d (e, r, m) (VSingle (Vnat 1)) ->
      cstep2 md d (c, r, m) (r', m') tr' ->
      cstep2 md d (Cwhile e c, r', m') (r'', m'') tr ->
      cstep2 md d (Cwhile e c, r, m) (r'', m'') (tr' ++ tr) ->
      imm_premise c md r m r' m' tr' (Cwhile e c) md r m r'' m'' (tr' ++ tr) d
  | IPwhilet2: forall md d c e r m r' m' r'' m'' tr tr',
      estep2 md d (e, r, m) (VSingle (Vnat 1)) ->
      cstep2 md d (c, r, m) (r', m') tr' ->
      cstep2 md d (Cwhile e c, r', m') (r'', m'') tr ->
      cstep2 md d (Cwhile e c, r, m) (r'', m'') (tr' ++ tr) ->
      imm_premise (Cwhile e c) md r' m' r'' m'' tr
                  (Cwhile e c) md r m r'' m'' (tr' ++ tr) d
  .
  Hint Constructors imm_premise.
End Semantics.

(*******************************************************************************
*
* SECURITY DEFINITIONS
*
*******************************************************************************)

Section Security_Defn.
  Parameter minit2_left : mem.
  Parameter minit2_right : mem.
  Axiom wf_minit2_left : forall d, meminit_wf minit2_left d.
  Axiom wf_minit2_right : forall d, meminit_wf minit2_right d.
  Definition minit2 := merge_mem minit2_left minit2_right.

  Definition meminit2_wf (m: mem2) d := forall l,
    match m l with
    | VSingle (Vlambda md c) => exists Gm p Gp q rt,
                               Loc_Contxt l = Some (Typ (Tlambda Gm p md Gp) q, rt) /\
                               com_type p md Gm d c Gp
    | VPair (Vlambda md1 c1) (Vlambda md2 c2) =>
      (exists Gm p Gp q rt,
          Loc_Contxt l = Some (Typ (Tlambda Gm p md1 Gp) q, rt) /\
          com_type p md1 Gm d c1 Gp) /\
      (exists Gm p Gp q rt,
          Loc_Contxt l = Some (Typ (Tlambda Gm p md2 Gp) q, rt) /\
          com_type p md2 Gm d c2 Gp)
    | VSingle (Vnat n) => True
    | VPair (Vnat n1) (Vnat n2) => True
    | _ => False
    end.

   Lemma wf_minit2 : forall d: loc_mode, meminit2_wf minit2 d.
   Proof.
     intros.
     unfold minit2.
     unfold meminit2_wf; intros.
     remember (minit2_left l) as vl; remember (minit2_right l) as vr.
     pose (wf_minit2_left d l) as wfl; rewrite <- Heqvl in wfl.
     pose (wf_minit2_right d l) as wfr; rewrite <- Heqvr in wfr.
     unfold merge_mem.
     rewrite <- Heqvl, <- Heqvr.
     destruct (val_decidable vl vr); destruct vl, vr; auto;
       destruct_conjs.
     rewrite H5 in H0; discriminate.
     rewrite H6 in H3; discriminate.
   Qed.

  Definition esc_hatch : Type := exp.
  Definition is_escape_hatch e : Prop := exp_novars e /\ exp_locs_immutable e.

  Definition tobs_sec_level (sl: sec_level) : trace -> trace :=
    filter (fun event => match event with
                         | Out sl' v => sec_level_le_compute sl' sl
                         | AEnc c c' enc_equiv => true
                         | ANonEnc c => true
                         | _ => false
                         end).

  Definition corresponds (G: context) : Prop :=
    (forall l p bt rt, g0 l = p -> Loc_Contxt l = Some (Typ bt p, rt))
    /\ (forall x, G x = Some (Typ Tnat (L))).

  Definition mem_sl_ind (sl: sec_level) :=
    forall l : location,
      sec_level_le (g0 l) sl <-> (project_mem minit2 true) l = (project_mem minit2 false) l.

  (* any memory---implicitly derived from minit2---has values at locations
   * used to compute escape hatches that result in the same value as minit
   * no variables are in the escape hatch, so we can quantify over any r *)
  Definition mem_esc_hatch_ind :=
    forall e, is_escape_hatch e -> forall m v, (exists md d r, estep2 md d (e,r,m) v) ->
                                               exists v', v = VSingle v'.

  Definition secure_prog (sl: sec_level) (d: loc_mode) (c: com) (G: context) : Prop :=
    forall m0 mknown r' m' t tobs,
      merge_mem m0 mknown = minit2 ->
      cstep2 Normal d (c, reg_init2, minit2) (r', m') t ->
      tobs = project_trace t true ->
      mem_sl_ind sl ->
      mem_esc_hatch_ind ->
      tobs_sec_level sl tobs = tobs_sec_level sl (project_trace t false).

    Definition cterm2_ok (md: mode) (G: context) (d: loc_mode) (r: reg2) (m: mem2)
      : Prop :=
      (forall x v1 v2 bt p,
          (r x = VPair v1 v2 /\ G x = Some (Typ bt p)) -> protected p /\ md <> Normal)
      /\ (forall l v1 v2 bt p rt,
          (m l = VPair v1 v2 /\ Loc_Contxt l = Some (Typ bt p, rt))
          -> protected p /\ d l <> Normal)
      /\ mem_sl_ind L
      /\ mem_esc_hatch_ind.

  Definition cconfig2_ok (pc: sec_level) (md: mode) (G: context) (d: loc_mode)
             (c: com) (r: reg2) (m: mem2) (G': context)
    : Prop :=
    com_type pc md G d c G'
    /\ (forall x v1 v2 bt p,
           (r x = VPair v1 v2
            /\ G x = Some (Typ bt p))
           -> protected p /\ md <> Normal)
    /\ (forall l v1 v2 bt p rt,
           ((m l) = VPair v1 v2 /\ Loc_Contxt (l) = Some (Typ bt p, rt))
           -> protected p /\ d l <> Normal)
    /\ mem_sl_ind L
    /\ mem_esc_hatch_ind.

End Security_Defn.

Section Axioms.
   Axiom Initial_State2: forall d r' m',
       exists c md tr, cstep2 md d (c, reg_init2, minit2) (r', m') tr.

   (* This follows from the axiom above and the assumption made in simpe *)
   Axiom pair_wf : forall v v1 v2,
       v = VPair v1 v2 <->
       v1 <> v2 /\
       ((exists n1 n2, v1 = Vnat n1 /\ v2 = Vnat n2) \/
        (exists md1 md2 c1 c2, v1 = Vlambda md1 c1 /\ v2 = Vlambda md2 c2)).
End Axioms.


Require Import VST.floyd.proofauto.
Require Import VST.progs.message.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(* This program, and its verification, are described in Chapter 29
   of _Program Logics for Certified Compilers_, by Appel et al., 2014 *)

Local Open Scope Z.
Local Open Scope logic.

(*   mf_assert msgfmt sh buf len data  := the [data] is formatted into a message
         at most [len] bytes,  stored starting at address [buf] with share [sh] *)

Record message_format (t: type) : Type :=
mf_build {
   mf_size: Z;
   mf_data_assert: forall (data: reptype t), Prop;
   mf_assert: forall (sh: share) (buf: val) (len: Z) (data: reptype t), mpred;
   mf_size_range:  0 <= mf_size <= Int.max_signed;
   mf_bufprop: forall sh buf len data,
           mf_assert sh buf len data |--
                 !!(0 <= len <= mf_size) && memory_block sh len buf;
   mf_restbuf := fun (sh: share) (buf: val) (len: Z) =>
          memory_block sh (mf_size-len) (offset_val len buf)
}.

Arguments mf_build {t}.
Arguments mf_size {t}.
Arguments mf_data_assert {t}.
Arguments mf_assert {t}.
Arguments mf_bufprop {t}.
Arguments mf_size_range {t}.
Arguments mf_restbuf {t}.

Definition t_struct_intpair := Tstruct _intpair noattr.
Definition t_struct_message := Tstruct _message noattr.

Program Definition intpair_message: message_format t_struct_intpair :=
  mf_build 8 (fun data => is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
             (fun sh buf len data => !!(len=8/\ is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
                           && data_at sh (tarray tint 2) [fst data; snd data] buf)
      _ _.
Next Obligation.
compute; split; congruence.
Qed.
Next Obligation.
  entailer!.
  change 8 with (sizeof (tarray tint 2)).
  apply data_at_memory_block.
Qed.

Definition serialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share
  PRE [ _p OF (tptr tvoid), _buf OF (tptr tuchar) ]
          PROP (readable_share sh; writable_share sh';
                mf_data_assert format data;
                align_compatible tint buf)
          LOCAL (temp _p p; temp _buf buf)
          SEP (data_at sh t data p;
                 memory_block sh' (mf_size format) buf)
  POST [ tint ]
         EX len: Z,
          PROP() LOCAL (temp ret_temp (Vint (Int.repr len)))
          SEP( data_at sh t data p;
                 mf_assert format sh' buf len data;
                 mf_restbuf format sh' buf len).

Definition deserialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share, len: Z
  PRE [ _p OF (tptr tvoid), _buf OF (tptr tuchar), _length OF tint ]
          PROP (readable_share sh'; writable_share sh;
                0 <= len <= mf_size format)
          LOCAL (temp _p p;
                 temp _buf buf;
                 temp _length (Vint (Int.repr len)))
          SEP (mf_assert format sh' buf len data;
                 data_at_ sh t p)
  POST [ tvoid ]
          PROP (mf_data_assert format data)  LOCAL ()
          SEP (mf_assert format sh' buf len data;
                 data_at sh t data p).

Definition intpair_serialize_spec :=
 DECLARE _intpair_serialize (serialize_spec intpair_message).

Definition intpair_deserialize_spec :=
 DECLARE _intpair_deserialize (deserialize_spec intpair_message).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog nil gv
  POST [ tint ] main_post prog nil gv.

Definition message (sh: share) {t: type} (format: message_format t) (m: val) : mpred :=
  EX fg: val*val,
          func_ptr' (serialize_spec format) (fst fg) *
          func_ptr' (deserialize_spec format) (snd fg) *
       data_at sh t_struct_message (Vint (Int.repr (mf_size format)), (fst fg, snd fg)) m.

Definition Gprog : funspecs :=   ltac:(with_library prog [
    intpair_serialize_spec; intpair_deserialize_spec; main_spec]).

Lemma body_intpair_serialize: semax_body Vprog Gprog f_intpair_serialize intpair_serialize_spec.
Proof.
unfold intpair_serialize_spec.
unfold serialize_spec.
start_function.
destruct H as [Dx Dy].
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction. clear Dx Dy.

change (mf_size intpair_message) with (sizeof (tarray tint 2)).
assert_PROP (field_compatible (tarray tint 2) [] buf).
  entailer!.
  hnf in H; decompose[and] H; repeat split; auto.
  (* TODO: abstract the following proof. *)
  unfold align_compatible in H0 |- *.
  destruct buf; auto.
  constructor.
  intros.
  eapply align_compatible_rec_by_value_inv in H0; [| reflexivity].
  econstructor; [reflexivity |].
  apply Z.divide_add_r; auto.
  exists i0; rewrite Z.mul_comm; auto.
rewrite memory_block_data_at_; auto.
change (data_at_ sh' (tarray tint 2) buf) with
   (data_at sh' (tarray tint 2) [Vundef;Vundef] buf).
forward. (* x = p->x; *)
forward. (* y = p->y; *)
forward. (*  ((int * )buf)[0]=x; *)
forward. (*  ((int * )buf)[1]=y; *)
forward. (* return 8; *)
Exists 8.
unfold mf_restbuf. simpl.
rewrite memory_block_zero.
entailer!.
Qed.

Lemma body_intpair_deserialize: semax_body Vprog Gprog f_intpair_deserialize intpair_deserialize_spec.
Proof.
unfold intpair_deserialize_spec, deserialize_spec.
start_function.
simpl. Intros. subst len.
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction.
clear H H1 H2.
forward. (* x = ((int * )buf)[0]; *)
forward. (* y = ((int * )buf)[1]; *)
forward. (* p->x = x; *)
forward. (* p->y = y; *)
forward. (* return; *)
simpl; entailer!.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
name buf _buf.

start_function.
set (ipm := gv _intpair_message).
fold cc_default noattr.
make_func_ptr _intpair_deserialize.
make_func_ptr _intpair_serialize.
set (des := gv _intpair_deserialize).
set (ser := gv _intpair_serialize).
gather_SEP 5 6 7.
replace_SEP 0
    (data_at Ews t_struct_message
      (Vint (Int.repr (mf_size intpair_message)), (ser, des)) ipm). {
 entailer!.
 unfold_data_at (data_at _ t_struct_message _ ipm).
 rewrite (field_at_data_at _ _ _ _ ipm).
rewrite data_at_tuint_tint.
(* rewrite <- (mapsto_field_at _ _ [StructField _bufsize] (Vint (Int.repr 8))) by auto with field_compatible. *)
 rewrite <- (mapsto_field_at _ _ [StructField _deserialize] des) by auto with field_compatible.
 rewrite <- (mapsto_field_at _ _ [StructField _serialize] ser) by auto with field_compatible.
 rewrite !field_compatible_field_address by auto with field_compatible.
 simpl.
 normalize.
 cancel.
}
forward. (* p.x = 1; *)
forward. (* p.y = 2; *)
forward. (* ser = intpair_message.serialize; *)

rewrite <- memory_block_data_at__tarray_tuchar_eq by computable.
change (memory_block Tsh 8 buf)
with (memory_block Tsh (mf_size intpair_message) buf).

assert_PROP (align_compatible tint buf).
  entailer!.
  destruct HPbuf; subst; simpl.
  econstructor; [reflexivity | apply Z.divide_0_r].
forward_call (* len = ser(&p, buf); *)
      ((Vint (Int.repr 1), Vint (Int.repr 2)), v_p, buf, Tsh, Tsh).
  split3; auto.
  repeat split; auto.
Intros rest.
simpl.
Intros. subst rest.

forward. (* des = intpair_message.deserialize; *)
forward_call (* des(&q, buf, 8); *)
        ((Vint (Int.repr 1), Vint (Int.repr 2)), v_q, buf, Tsh, Tsh, 8).
  simpl. fold t_struct_intpair. entailer!.
  split3; auto. simpl; computable.
(* after the call *)
forward. (* x = q.x; *)
forward. (* y = q.y; *)
forward. (* return x+y; *)
simpl.
entailer!.
sep_apply (data_at_memory_block Tsh (tarray tint 2) [Vint (Int.repr 1); Vint (Int.repr 2)] buf).
simpl sizeof.
sep_apply (memory_block_data_at__tarray_tuchar Tsh buf 8).
   computable.
entailer!.
Qed.


From isla Require Import opsem.

Definition a8016c : isla_trace :=
  Smt (DeclareConst 55%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 55%Z)) Mk_annot :t:
  Smt (DefineConst 58%Z (Manyop Concat [Val (Val_Bits (BV 32%N 0x0%Z)) Mk_annot; Manyop (Bvmanyarith Bvand) [Unop (Extract 31%N 0%N) (Val (Val_Symbolic 55%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 32%N 0xff%Z)) Mk_annot] Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R0" [] (RegVal_Base (Val_Symbolic 58%Z)) Mk_annot :t:
  Smt (DeclareConst 59%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 59%Z)) Mk_annot :t:
  Smt (DefineConst 60%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 59%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 60%Z)) Mk_annot :t:
  tnil
.


From Undecidability.Synthetic
     Require Import Definitions Undecidability.

From Undecidability.FOL
     Require Import Sets.FST
                    Semantics.Tarski.FullFacts
                    Semantics.Tarski.FullSoundness
                    Deduction.FullNDFacts
                    Sets.Models.FST_model.

From Undecidability.FOL.Undecidability.Reductions
     Require Import PCPb_to_FST PCPb_to_FSTD ZF_to_FST.

From Undecidability.PCP
     Require Import PCP PCP_undec Reductions.PCPb_iff_dPCPb.

Theorem undecidable_entailment_FSTeq :
  undecidable entailment_FSTeq.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists solvable'. intros B. split.
  - intros HP % (PCP_FSTD (p:=intu)).
    apply soundness in HP. intros I M rho H. apply HP, H.
  - apply PCP_FST.
Qed.

Theorem undecidable_deduction_FST :
  undecidable deduction_FST.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists solvable'. intros B. split.
  - intros HP % (PCP_FSTD (p:=intu)). apply HP.
  - intros HP % soundness. apply PCP_FST.
    intros I M rho H. apply HP. apply H.
Qed.

Theorem undecidable_entailment_FST :
  undecidable entailment_FST.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists solvable. intros B. apply PCPb_to_FST.PCP_FST.
  apply FST_model.
Qed.

Theorem undecidable_entailment_FSTI :
  undecidable entailment_FSTI.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists solvable. intros B. rewrite PCPb_iff_dPCPb. split; intros H.
  - destruct H as [s H]. intros M HM rho H1 H2. eapply PCP_FST1; eauto.
    intros sigma psi Hp. apply H2. now constructor.
  - destruct FSTI_model as (D & I & H1 & H2 & H3).
    specialize (H D I (fun _ => @i_func _ _ _ _ eset Vector.nil) H1 H3).
    apply PCP_FST2 in H as [s Hs]; trivial. now exists s.
    intros sigma psi Hp. apply H3. now constructor.
Qed.

Theorem undecidable_deduction_FSTI :
  undecidable deduction_FSTI.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists solvable. intros B. split; intros H.
  - exists FSTeq. split; try apply FSTeq_base. now apply PCPb_to_FSTD.PCP_FSTD.
  - destruct FSTI_model as (D & I & H1 & H2 & H3).
    rewrite PCPb_iff_dPCPb. unshelve eapply PCP_FST2; eauto.
    + exact (fun _ => @i_func _ _ _ _ eset Vector.nil).
    + intros sigma psi Hp. apply H3. now constructor.
    + apply (tsoundness H). intros psi [theta [<-|[<-|[<-|[<-|Hp]]]]|theta].
      1-4: cbn; setoid_rewrite H1; congruence.
      * apply H3. now constructor.
      * apply H3. constructor 2.
Qed.


Require Import Algebra.Utils Algebra.Monad SetoidUtils Algebra.SetoidCat.ListUtils Algebra.SetoidCat Algebra.Monad.StoreHeap Algebra.Monad.ContT Algebra.NearSemiRing Algebra.Monoid Tactics QAL.Definitions Algebra.FoldableFunctor Algebra.SetoidCat.PairUtils Algebra.Functor Algebra.Alternative Algebra.SetoidCat.MaybeUtils Algebra.Monad.Maybe Algebra.Applicative Algebra.SetoidCat.BoolUtils Algebra.SetoidCat.UnitUtils Algebra.Monoid.BoolUtils Algebra.Monoid.Alternative Algebra.Alternative.List Algebra.Functor.List Algebra.FoldableFunctor.List Algebra.Monad.Utils QAL.Concrete.Definitions QAL.AbstractStore QAL.AbstractHeap QAL.Command Algebra.Traversable.List Algebra.Functor.Monad Algebra.Applicative.Monad.

Require Import Coq.Lists.List PeanoNat RelationClasses Relation_Definitions Morphisms Coq.Program.Basics SetoidClass.

Module Type BuiltInCommand (PT : PredType) (VT : ValType) (S : AbstractStore VT) (H : AbstractHeap PT VT).
  Module TS := Types PT VT S H.
  Import TS.
  Parameter builtInCommand : Type.
  Parameter builtInCommandS : Setoid builtInCommand.
  Parameter freeVarsBuiltInCommand : builtInCommandS ~> varSetS.
  Parameter interpretBuiltInCommand : builtInCommandS ~> stateS unitS.
End BuiltInCommand.

Module Type Literal (VT : ValType).
  Import VT.
  Parameter literal : Type.
  Parameter literalS : Setoid literal.
  Parameter interpretLiteral : literalS ~> valS.
End Literal.

Section PrimitiveCommand.

  Context
    {literal : Type}
    {pred : Type}
    {builtin : Type}.

  Inductive term :=
  | termVar : var -> term
  | termVal : literal -> term
  .

  Program Instance termS : Setoid term.

  Inductive qalPrimitiveCommand :=
  | pcBuiltIn : builtin -> qalPrimitiveCommand
  | pcInsert : pred -> list term -> qalPrimitiveCommand
  | pcDelete : pred -> list term -> qalPrimitiveCommand
  | pcInsertProp : pred -> list term -> list term -> qalPrimitiveCommand
  | pcDeleteProp : pred -> list term -> list term -> qalPrimitiveCommand
  | pcAtomic : pred -> list term -> qalPrimitiveCommand
  .

  Program Instance qalPrimitiveCommandS : Setoid qalPrimitiveCommand.

End PrimitiveCommand.

Import FSetNatNotations.
Module QALPrimitiveCommand (PT : PredType) (VT : ValType)
       (L : Literal VT) (S : AbstractStore VT) (H : AbstractHeap PT VT) (BC : BuiltInCommand PT VT S H) : PrimitiveCommand PT VT S H.
  Open Scope type_scope.
  Module TS := Types PT VT S H.
  Module CA := CommandAux PT VT S H.
  Import PT VT L S H BC TS CA.

  Definition _termFreeVars (t : (@term literal)) : FVarSet.t :=
    match t with
        | termVal _ => ∅
        | termVar v => ﹛ v ﹜
    end
  .

  Existing Instance termS.

  Instance _termFreeVars_Proper : Proper (equiv ==> equiv) _termFreeVars.
  Proof.
    solve_proper.
  Qed.

  Definition termFreeVars := injF _termFreeVars _.

  Definition tlFreeVars (tl : list term) :=
            fold_right (fun t  fv =>
                      (termFreeVars @ t) ∪ fv) ∅ tl
  .

  Definition _qalPrimitiveCommandFreeVars (pc : @qalPrimitiveCommand literal pred builtInCommand) : FVarSet.t :=
    match pc with
      | pcBuiltIn b => freeVarsBuiltInCommand @ b
      | pcInsert _ tl => tlFreeVars tl
      | pcDelete _ tl => tlFreeVars tl
      | pcInsertProp _ ktl ptl => tlFreeVars ktl ∪ tlFreeVars ptl
      | pcDeleteProp _ ktl ptl => tlFreeVars ktl ∪ tlFreeVars ptl
      | pcAtomic _ tl => tlFreeVars tl
    end
  .

  Existing Instance qalPrimitiveCommandS.
  Instance _qalPrimitiveCommandFreeVars_Proper : Proper (equiv ==> equiv) _qalPrimitiveCommandFreeVars.
   Proof.
    solve_proper.
  Qed.

  Definition qalPrimitiveCommandFreeVars := injF _qalPrimitiveCommandFreeVars _.

  Definition freeVarsPrimitiveCommand := qalPrimitiveCommandFreeVars.

  Definition qalTerm := @term literal.
  Instance qalTermS : Setoid qalTerm := @termS literal.

  Instance argumentVal_Proper : Proper (equiv ==> equiv) (argumentVal val).
  Proof.
    unfold Proper, respectful. intros. auto.
  Qed.

  Definition argumentValS := injF (argumentVal val) _.
  Definition _evalTerm (t : term) : state (argument val) :=
    match t with
      | termVal l => ret @ (argumentValS @ (interpretLiteral @ l))
      | termVar v => getStore >>= ret ∘ (caseMaybeS @ argumentValS @ argumentVar val v) ∘ (S.read @ v)
    end
  .

  Instance _evalTerm_Proper : Proper (equiv ==> equiv) _evalTerm.
  Proof.
    solve_proper.
  Qed.

  Definition evalTerm := injF _evalTerm _.

  Existing Instance sh_Monad.
  Existing Instance monadFunctor.
  Existing Instance monad_Applicative.
  Definition evalTermList : listS (@termS literal) ~> stateS (listS (argumentS _ valS)) := mapM @ evalTerm.

  Definition _evalTermVal (t : term) : state ( val) :=
    match t with
      | termVal l => ret @ (interpretLiteral @ l)
      | termVar v => getStore >>= ret ∘ (S.read @ v) >>= stopNone
    end
  .

  Instance _evalTermVal_Proper : Proper (equiv ==> equiv) _evalTermVal.
  Proof.
    solve_proper.
  Qed.

  Definition evalTermVal := injF _evalTermVal _.

  Definition evalTermListVal : listS (@termS literal) ~> stateS (listS valS) := mapM @ evalTermVal.

  Definition updateStore2 : listS (varS ~*~ valS) ~> S.tS ~~> S.tS :=
    flipS @ (fold_rightS @ (uncurryS @ S.update)).

  Definition _unionWithCurrStore (s : list (var * val)) : state unit :=
    updateStore @ (updateStore2 @ s).

  Instance _unionWithCurrStore_Proper : Proper (equiv ==> equiv) _unionWithCurrStore.
  Proof.
    solve_properS _unionWithCurrStore.
  Qed.

  Definition unionWithCurrStore : listS (varS ~*~ valS) ~> stateS unitS := injF _unionWithCurrStore _.

  Definition _lookupAtom (p : pred) (tl : list (@term literal)) : state (H.l (list (var * val)) _) :=
    (H.lookup @ p)
        <$> (evalTermList @ tl)
        <*> getHeap.

  Instance _lookupAtom_Proper : Proper (equiv ==> equiv ==> equiv) _lookupAtom.
  Proof.
    solve_properS _lookupAtom.
  Qed.
  Definition lookupAtom := injF2 _lookupAtom _.

  Section LookupGeneric.
    Context (p : pred) (tl : list (@term literal)).

    Definition lookupGeneric : state unit :=
      lookupAtom @ p @ tl >>= branchVal >>= unionWithCurrStore.
  End LookupGeneric.
  Instance lookupGeneric_Proper : Proper (equiv ==> equiv ==> equiv) lookupGeneric.
  Proof.
    solve_properS lookupGeneric.
  Qed.

  Section InsertGeneric.
    Context
      (p : pred) (tl : list (@term literal)).

    Definition insertGeneric : state unit :=
      (H.insert @ p
         <$> (evalTermListVal @ tl)
         <*> getHeap) >>= stopNone >>= putHeap.
  End InsertGeneric.
  Instance insertGeneric_Proper : Proper (equiv ==> equiv ==> equiv) insertGeneric.
  Proof.
    solve_properS insertGeneric.
  Qed.

  Section DeleteGeneric.
    Context
      (p : pred) (tl : list (@term literal)).

    Definition deleteGeneric : state unit :=
      (H.delete @ p
         <$> evalTermListVal @ tl
         <*> getHeap) >>= stopNone >>= putHeap.
  End DeleteGeneric.

  Instance DeleteGeneric_Proper : Proper (equiv ==> equiv ==> equiv) deleteGeneric.
  Proof.
    solve_properS deleteGeneric.
  Qed.

  Section InsertPropGeneric.
    Context
      (p : pred) (ktl ptl : list (@term literal)).

    Definition insertPropGeneric : state unit :=
      (H.insertProp @ p
         <$> (evalTermListVal @ ktl)
         <*> (evalTermListVal @ ptl)
         <*> getHeap) >>= stopNone >>= putHeap.
  End InsertPropGeneric.
  Instance insertPropGeneric_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv) insertPropGeneric.
  Proof.
    solve_properS insertPropGeneric.
  Qed.

  Section DeletePropGeneric.
    Context
      (p : pred) (ktl ptl : list (@term literal)).

    Definition deletePropGeneric : state unit :=
      (H.deleteProp @ p
         <$> (evalTermListVal @ ktl)
         <*> (evalTermListVal @ ptl)
         <*> getHeap) >>= stopNone >>= putHeap.
  End DeletePropGeneric.

  Instance DeletePropGeneric_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv) deletePropGeneric.
  Proof.
    solve_properS deletePropGeneric.
  Qed.

  Fixpoint _reduce (pc : qalPrimitiveCommand)  : state unit :=
    match pc with
      | pcBuiltIn b =>
        interpretBuiltInCommand @ b
      | pcInsert pred tl =>
        insertGeneric pred tl
      | pcDelete pred tl =>
        deleteGeneric pred tl
      | pcInsertProp pred ktl ptl =>
        insertPropGeneric pred ktl ptl
      | pcDeleteProp pred ktl ptl =>
        deletePropGeneric pred ktl ptl
      | pcAtomic pred tl =>
        lookupGeneric pred tl
    end
  .

  Definition reduce : (@qalPrimitiveCommandS literal pred builtInCommand ) ~> stateS unitS := injF _reduce _.
  Definition primitiveCommand := @qalPrimitiveCommand literal pred builtInCommand .
  Definition primitiveCommandS := @qalPrimitiveCommandS literal pred builtInCommand.
  Definition interpretPrimitiveCommand := reduce.
End QALPrimitiveCommand.