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.


From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac auth.
From cap_machine Require Export cap_lang mono_ref sts iris_extra.

(* CMRΑ for memory *)
Class memG Σ := MemG {
  mem_invG : invG Σ;
  mem_gen_memG :> gen_heapG Addr Word Σ}.

(* CMRA for registers *)
Class regG Σ := RegG {
  reg_invG : invG Σ;
  reg_gen_regG :> gen_heapG RegName Word Σ; }.

(* invariants for memory, and a state interpretation for (mem,reg) *)
Instance memG_irisG `{MachineParameters} `{memG Σ, regG Σ} : irisG cap_lang Σ := {
  iris_invG := mem_invG;
  state_interp σ κs _ := ((gen_heap_ctx σ.1) ∗ (gen_heap_ctx σ.2))%I;
  fork_post _ := True%I;
}.
Global Opaque iris_invG.

(* Points to predicates for registers *)
Notation "r ↦ᵣ{ q } w" := (mapsto (L:=RegName) (V:=Word) r q w)
  (at level 20, q at level 50, format "r  ↦ᵣ{ q }  w") : bi_scope.
Notation "r ↦ᵣ w" := (mapsto (L:=RegName) (V:=Word) r 1 w) (at level 20) : bi_scope.

(* Points to predicates for memory *)
Notation "a ↦ₐ { q } w" := (mapsto (L:=Addr) (V:=Word) a q w)
  (at level 20, q at level 50, format "a  ↦ₐ { q }  w") : bi_scope.
Notation "a ↦ₐ w" := (mapsto (L:=Addr) (V:=Word) a 1 w) (at level 20) : bi_scope.

(* capabilities. We use the monotone monoid to construct a pointer which may only
   update according to its permission *)
Section Capabilities.

  Definition LeastPermUpd (w : Word) : Perm :=
    match w with
    | inl _ => URW
    | inr ((_,Global),_,_,_) => URW
    | _ => URWL
    end.

  (* It could have been better to define the second in terms of the first here *)
  Lemma isLocal_RWL w:
    isLocalWord w = true → LeastPermUpd w = URWL.
  Proof.
    intros HiLW. destruct w.
    - cbv in HiLW. by exfalso.
    - destruct_cap c. cbv in HiLW.
      destruct c3; by cbv.
  Qed.

  Lemma not_isLocal_WL w:
    isLocalWord w = false → LeastPermUpd w = URW.
  Proof.
    intros HiLW. destruct w.
    - auto.
    - destruct_cap c. cbv in HiLW.
      destruct c3; by cbv.
  Qed.

  Lemma LeastPermUpd_atleast w:
    PermFlows URW (LeastPermUpd w).
  Proof.
    destruct w as [|c]; cbn. constructor.
    destruct_cap c. case_match; constructor.
  Qed.

  Inductive CapR : relation (Word * Perm) :=
  | P_res w p1 p2 : PermFlows p1 p2 → CapR (w,p2) (w,p1)
  | W_upd w1 w2 p : PermFlows (LeastPermUpd w2) p → CapR (w1,p) (w2,p).

  Definition PerP := λ p1 p2, PermFlows p2 p1.
  Lemma PerP_refl : ∀ p, PerP p p.
  Proof. apply PermFlows_refl. Qed.
  Lemma PerP_trans : ∀ P1 P2 P3, PerP P1 P2 → PerP P2 P3 → PerP P1 P3.
  Proof.
    intros p1 p2 p3. rewrite /PerP /PermFlows /PermFlowsTo;
    intros Hp1 Hp2.
    destruct p1,p2,p3; simpl; auto.
  Qed.

  Definition CapR_rtc := rtc CapR.

  Instance WordPerm_Equiv : Equiv (leibnizO (Word * Perm)).
  Proof. apply _. Defined.

  Instance WordPerm_Dist : Dist (leibnizO (Word * Perm)).
  Proof. apply _. Defined.

  Global Instance CapR_rtc_ProperPreOrder : monocmra.ProperPreOrder CapR_rtc.
  Proof. split; apply _. Defined.

  Instance PermFlows_Equiv : Equiv (leibnizO Perm).
  Proof. apply _. Defined.

  Instance PermFlows_Dist : Dist (leibnizO Perm).
  Proof. apply _. Defined.

  Global Instance PerP_ProperPreOrder : monocmra.ProperPreOrder PerP.
  Proof.
    split; [|apply _].
    split; intro;[rewrite /Reflexive;apply PerP_refl|rewrite /Transitive;apply PerP_trans].
  Defined.

  Global Instance PermFlows_ProperPreOrder : monocmra.ProperPreOrder PermFlows.
  Proof.
    split; [|apply _].
    split; intro;[rewrite /Reflexive;apply PerP_refl|rewrite /Transitive;apply PermFlows_trans].
  Defined.

  Context `{MonRefG (leibnizO _) CapR_rtc Σ, !memG Σ}.
  Notation A := (leibnizO (Word * Perm)).

  Definition MonRefMapsto_def l γ (v : A) :=
    (Exact (A:=A) CapR_rtc γ v ∗ atleast (A:=A) CapR_rtc γ v
           ∗ (l ↦ₐ v.1 ∨ ⌜v.2 = O⌝))%I.
  (* if the permission is O, we do not have ownership of the location *)
  Definition MonRefMapsto_aux l γ v : seal (MonRefMapsto_def l γ v).
  Proof. by eexists. Qed.
  Definition MonRefMapsto l γ v : iProp Σ := (MonRefMapsto_aux l γ v).(unseal).
  Definition MonRefMapsto_eq l γ v :
    MonRefMapsto l γ v = MonRefMapsto_def l γ v :=
    (MonRefMapsto_aux l γ v).(seal_eq).

  Notation "a ↦ₐ [ p ] w" := (∃ cap_γ, MonRefMapsto a cap_γ (w,p))%I
              (at level 20, p at level 50, format "a  ↦ₐ [ p ]  w") : bi_scope.

  Lemma MonRefAlloc l v p :
    l ↦ₐ v ==∗ l ↦ₐ[p] v.
  Proof.
    iIntros "Hl".
    iMod (MonRef_alloc (A:=A)) as (γ) "[HE Hal]"; eauto.
    iModIntro. iExists _.
    rewrite MonRefMapsto_eq /MonRefMapsto_def. iFrame.
  Qed.

  Lemma MonRefAlloc_sepL2 (p:Perm) (l1: list Addr) (l2: list Word) :
    ([∗ list] k;v ∈ l1;l2, k ↦ₐ v) ==∗ ([∗ list] k;v ∈ l1;l2, k ↦ₐ[p] v).
  Proof.
    iIntros "H".
    iDestruct (big_sepL2_mono with "H") as "H".
    { intros. apply MonRefAlloc. }
    iDestruct (big_sepL2_bupd with "H") as "H". eauto.
  Qed.

  Lemma MonRefAlloc_sepM (p:Perm) (m: gmap Addr Word) :
    ([∗ map] k↦v ∈ m, k ↦ₐ v) ==∗ ([∗ map] k↦v ∈ m, k ↦ₐ[p] v).
  Proof.
    iIntros "H".
    iDestruct (big_sepM_mono with "H") as "H".
    { intros. apply MonRefAlloc. }
    iDestruct (big_sepM_bupd with "H") as "H". eauto.
  Qed.

  Lemma MonRefDealloc l γ v p :
    MonRefMapsto l γ (v,p) -∗
                 (l ↦ₐ v ∨ ⌜p = O⌝) ∗
       ∃ P, P ∗ (P -∗ ∀ w, ⌜CapR_rtc (v,p) w⌝ -∗
                       (l ↦ₐ w.1 ∨ ⌜w.2 = O⌝) ==∗ MonRefMapsto l γ w).
  Proof.
    rewrite MonRefMapsto_eq /MonRefMapsto_def.
    iIntros "(HE & Ha & Hl)".
    iFrame.
    iDestruct (MonRef_related (A:=A) with "HE Ha") as %Hab.
    iExists (Exact (A:=A) CapR_rtc γ (v,p) ∗
                   atleast (A:=A) CapR_rtc γ (v,p))%I; iFrame.
    iIntros "[HE Ha]". iIntros ([w p'] Hcap) "Hl /=".
    rewrite MonRefMapsto_eq /MonRefMapsto_def; iFrame.
    iMod (MonRef_update (A:=A) CapR_rtc γ (v,p) with "HE") as "[$ $]"; eauto.
  Qed.

  Lemma snap_shot l γ v : MonRefMapsto l γ v ==∗ atleast (A:=A) CapR_rtc γ v.
  Proof.
    rewrite MonRefMapsto_eq /MonRefMapsto_def atleast_eq /atleast_def.
    iIntros "(HE & Hal & Hl)"; eauto.
  Qed.

  Lemma recall l γ v w :
    atleast (A:=A) CapR_rtc γ w -∗ MonRefMapsto l γ v -∗ ⌜CapR_rtc w v⌝.
  Proof.
    rewrite MonRefMapsto_eq /MonRefMapsto_def.
    iIntros "Hal (HE & Hal' & Hl)".
    iDestruct (MonRef_related with "HE Hal") as "?"; eauto.
  Qed.

  Instance Exact_Timeless : Timeless (Exact (A:=A) CapR_rtc γ v).
  Proof. apply _. Qed.

  Instance atleast_Timeless : Timeless (atleast (A:=A) CapR_rtc γ v).
  Proof.
    intros. rewrite (atleast_eq (A:=A) CapR_rtc γ v). apply _. Qed.

  Global Instance MonRefMapsto_Timeless : Timeless (MonRefMapsto l γ v).
  Proof.
    intros.
    rewrite MonRefMapsto_eq /MonRefMapsto_def.
    apply _.
  Qed.

End Capabilities.

Section World.
  Local Definition STS : Type := (STS_states * STS_rels).

  Inductive RelW : (STS * bool) → (STS * bool) -> Prop :=
  | RelW_pr (W1 W2 : STS) : related_sts_priv W1.1 W2.1 W1.2 W2.2
                            -> RelW (W1,true) (W2,true)
  | RelW_pu (W1 W2 : STS) : related_sts_pub W1.1 W2.1 W1.2 W2.2
                            -> RelW (W1,false) (W2,false)
  | RelW_pu_to_pr (W1 W2 : STS) : related_sts_priv W1.1 W2.1 W1.2 W2.2
                              → RelW (W1,false) (W2,true).

  Instance PrivRelW_Equiv : Equiv (leibnizO (STS * bool)).
  Proof. apply _. Defined.

  Instance PrivRelW_Dist : Dist (leibnizO (STS * bool)).
  Proof. apply _. Defined.

  Global Instance PrivRelW_ProperPreOrder : monocmra.ProperPreOrder RelW.
  Proof.
    split; [|apply _].
    split; intro.
    - destruct x. destruct b.
      + apply RelW_pr. apply related_sts_priv_refl.
      + apply RelW_pu. apply related_sts_pub_refl.
    - intros y z. destruct x,y,z; inversion 1; inversion 1.
      + constructor. apply related_sts_priv_trans with s0.1 s0.2; auto.
      + constructor. apply related_sts_pub_trans with s0.1 s0.2; auto.
      + subst. constructor. apply related_sts_pub_priv_trans with s0.1 s0.2; auto.
      + subst. constructor. apply related_sts_priv_trans with s0.1 s0.2; auto.
  Defined.

End World.

Definition logN : namespace := nroot .@ "logN".

(* --------------------------- LTAC DEFINITIONS ----------------------------------- *)

Ltac inv_head_step :=
  repeat match goal with
         | _ => progress simplify_map_eq/= (* simplify memory stuff *)
         | H : to_val _ = Some _ |- _ => apply of_to_val in H
         | H : _ = of_val ?v |- _ =>
           is_var v; destruct v; first[discriminate H|injection H as H]
         | H : cap_lang.prim_step ?e _ _ _ _ _ |- _ =>
           try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable *)
           (*    and can thus better be avoided. *)
           let φ := fresh "φ" in
           inversion H as [| φ]; subst φ; clear H
         end.

Ltac option_locate_m_once m :=
  match goal with
  | H : m !! ?a = Some ?w |- _ => let Htmp := fresh in
                                rename H into Htmp ;
                                let Ha := fresh "H" m a in
                                pose proof (mem_lookup_eq _ _ _ Htmp) as Ha; clear Htmp
  end.
Ltac option_locate_r_once r :=
  match goal with
  | H : r !! ?a = Some ?w |- _ => let Htmp := fresh in
                                rename H into Htmp ;
                                let Ha := fresh "H" r a in
                                pose proof (regs_lookup_eq _ _ _ Htmp) as Ha; clear Htmp
  end.
Ltac option_locate_mr_once m r :=
  first [ option_locate_m_once m | option_locate_r_once r ].
Ltac option_locate_mr m r :=
  repeat option_locate_mr_once m r.
Ltac option_locate_m m :=
  repeat option_locate_m_once m.
Ltac option_locate_r m :=
  repeat option_locate_r_once m.

Section cap_lang_rules.
  Context `{MachineParameters}.
  Context `{memG Σ, regG Σ, MonRefG (leibnizO _) CapR_rtc Σ,
            World: MonRefG (leibnizO _) RelW Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.
  Notation A := (leibnizO (Word * Perm)).
  Notation P := (leibnizO Perm).
  Notation WORLD_S := (leibnizO ((STS_states * STS_rels) * bool)).
  Implicit Types M : WORLD_S.
  Implicit Types W : (STS_states * STS_rels).

  (* Definition atleast_p γ p := atleast (A:=P) PermFlows γ p. *)
  (* Definition Exact_p γ p := Exact (A:=P) PermFlows γ p. *)

  (* --------------------------- WORLD REL MONOID ----------------------------------- *)
  Definition atleast_w γ M := atleast (A:=WORLD_S) RelW γ M.
  Definition Exact_w γ M := Exact (A:=WORLD_S) RelW γ M.

  Lemma RelW_private M W γ :
    atleast_w γ M -∗ Exact_w γ (W,true) -∗ ⌜related_sts_priv M.1.1 W.1 M.1.2 W.2⌝.
  Proof.
    rewrite /atleast_w /Exact_w.
    iIntros "#HM HW".
    iDestruct (MonRef_related (A:=WORLD_S) with "HW HM") as %Hrel.
      by inversion Hrel; subst.
  Qed.

  Lemma RelW_public M W γ :
    atleast_w γ M -∗ Exact_w γ (W,false) -∗ ⌜related_sts_pub M.1.1 W.1 M.1.2 W.2⌝.
  Proof.
    rewrite /atleast_w /Exact_w.
    iIntros "#HM HW".
    iDestruct (MonRef_related (A:=WORLD_S) with "HW HM") as %Hrel.
      by inversion Hrel; subst.
  Qed.

  Lemma RelW_public_to_private W γ :
    Exact_w γ (W,false) ==∗ Exact_w γ (W,true) ∗ atleast_w γ (W,true).
  Proof.
    iIntros "HW".
    iMod (MonRef_update (A:=WORLD_S) with "HW"); auto.
    constructor. apply related_sts_priv_refl.
  Qed.

  (* ----------------------------- LOCATΕ LEMMAS ----------------------------------- *)

  Lemma locate_ne_reg reg r1 r2 w w' :
    r1 ≠ r2 → reg !r! r1 = w → <[r2:=w']> reg !r! r1 = w.
  Proof.
    intros. rewrite /RegLocate.
    rewrite lookup_partial_alter_ne; eauto.
  Qed.

  Lemma locate_eq_reg reg r1 w w' :
    reg !r! r1 = w → <[r1:=w']> reg !r! r1 = w'.
  Proof.
    intros. rewrite /RegLocate.
    rewrite lookup_partial_alter; eauto.
  Qed.

  Lemma locate_ne_mem mem a1 a2 w w' :
    a1 ≠ a2 → mem !m! a1 = w → <[a2:=w']> mem !m! a1 = w.
  Proof.
    intros. rewrite /MemLocate.
    rewrite lookup_partial_alter_ne; eauto.
  Qed.

  (* Conditionally unify on the read register value *)
  Definition read_reg_inr  (regs : Reg) (r : RegName) p g b e a :=
    regs !! r = Some (inr ((p, g), b, e, a)) ∨ ∃ z, regs !! r = Some(inl z).

  (* ------------------------- registers points-to --------------------------------- *)

  Lemma regname_dupl_false r w1 w2 :
    r ↦ᵣ w1 -∗ r ↦ᵣ w2 -∗ False.
  Proof.
    iIntros "Hr1 Hr2".
    iDestruct (mapsto_valid_2 with "Hr1 Hr2") as %?.
    contradiction.
  Qed.

  Lemma regname_neq r1 r2 w1 w2 :
    r1 ↦ᵣ w1 -∗ r2 ↦ᵣ w2 -∗ ⌜ r1 ≠ r2 ⌝.
  Proof.
    iIntros "H1 H2" (?). subst r1. iApply (regname_dupl_false with "H1 H2").
  Qed.

  Lemma map_of_regs_1 (r1: RegName) (w1: Word) :
    r1 ↦ᵣ w1 -∗
    ([∗ map] k↦y ∈ {[r1 := w1]}, k ↦ᵣ y).
  Proof. by rewrite big_sepM_singleton. Qed.

  Lemma regs_of_map_1 (r1: RegName) (w1: Word) :
    ([∗ map] k↦y ∈ {[r1 := w1]}, k ↦ᵣ y) -∗
    r1 ↦ᵣ w1.
  Proof. by rewrite big_sepM_singleton. Qed.

  Lemma map_of_regs_2 (r1 r2: RegName) (w1 w2: Word) :
    r1 ↦ᵣ w1 -∗ r2 ↦ᵣ w2 -∗
    ([∗ map] k↦y ∈ (<[r1:=w1]> (<[r2:=w2]> ∅)), k ↦ᵣ y) ∗ ⌜ r1 ≠ r2 ⌝.
  Proof.
    iIntros "H1 H2". iPoseProof (regname_neq with "H1 H2") as "%".
    rewrite !big_sepM_insert ?big_sepM_empty; eauto.
    2: by apply lookup_insert_None; split; eauto.
    iFrame. eauto.
  Qed.

  Lemma regs_of_map_2 (r1 r2: RegName) (w1 w2: Word) :
    r1 ≠ r2 →
    ([∗ map] k↦y ∈ (<[r1:=w1]> (<[r2:=w2]> ∅)), k ↦ᵣ y) -∗
    r1 ↦ᵣ w1 ∗ r2 ↦ᵣ w2.
  Proof.
    iIntros (?) "Hmap". rewrite !big_sepM_insert ?big_sepM_empty; eauto.
    by iDestruct "Hmap" as "(? & ? & _)"; iFrame.
    apply lookup_insert_None; split; eauto.
  Qed.

  Lemma map_of_regs_3 (r1 r2 r3: RegName) (w1 w2 w3: Word) :
    r1 ↦ᵣ w1 -∗ r2 ↦ᵣ w2 -∗ r3 ↦ᵣ w3 -∗
    ([∗ map] k↦y ∈ (<[r1:=w1]> (<[r2:=w2]> (<[r3:=w3]> ∅))), k ↦ᵣ y) ∗
     ⌜ r1 ≠ r2 ∧ r1 ≠ r3 ∧ r2 ≠ r3 ⌝.
  Proof.
    iIntros "H1 H2 H3".
    iPoseProof (regname_neq with "H1 H2") as "%".
    iPoseProof (regname_neq with "H1 H3") as "%".
    iPoseProof (regname_neq with "H2 H3") as "%".
    rewrite !big_sepM_insert ?big_sepM_empty; simplify_map_eq; eauto.
    iFrame. eauto.
  Qed.

  Lemma regs_of_map_3 (r1 r2 r3: RegName) (w1 w2 w3: Word) :
    r1 ≠ r2 → r1 ≠ r3 → r2 ≠ r3 →
    ([∗ map] k↦y ∈ (<[r1:=w1]> (<[r2:=w2]> (<[r3:=w3]> ∅))), k ↦ᵣ y) -∗
    r1 ↦ᵣ w1 ∗ r2 ↦ᵣ w2 ∗ r3 ↦ᵣ w3.
  Proof.
    iIntros (? ? ?) "Hmap". rewrite !big_sepM_insert ?big_sepM_empty; simplify_map_eq; eauto.
    iDestruct "Hmap" as "(? & ? & ? & _)"; iFrame.
  Qed.

  Lemma map_of_regs_4 (r1 r2 r3 r4: RegName) (w1 w2 w3 w4: Word) :
    r1 ↦ᵣ w1 -∗ r2 ↦ᵣ w2 -∗ r3 ↦ᵣ w3 -∗ r4 ↦ᵣ w4 -∗
    ([∗ map] k↦y ∈ (<[r1:=w1]> (<[r2:=w2]> (<[r3:=w3]> (<[r4:=w4]> ∅)))), k ↦ᵣ y) ∗
     ⌜ r1 ≠ r2 ∧ r1 ≠ r3 ∧ r1 ≠ r4 ∧ r2 ≠ r3 ∧ r2 ≠ r4 ∧ r3 ≠ r4 ⌝.
  Proof.
    iIntros "H1 H2 H3 H4".
    iPoseProof (regname_neq with "H1 H2") as "%".
    iPoseProof (regname_neq with "H1 H3") as "%".
    iPoseProof (regname_neq with "H1 H4") as "%".
    iPoseProof (regname_neq with "H2 H3") as "%".
    iPoseProof (regname_neq with "H2 H4") as "%".
    iPoseProof (regname_neq with "H3 H4") as "%".
    rewrite !big_sepM_insert ?big_sepM_empty; simplify_map_eq; eauto.
    iFrame. eauto.
  Qed.

  Lemma regs_of_map_4 (r1 r2 r3 r4: RegName) (w1 w2 w3 w4: Word) :
    r1 ≠ r2 → r1 ≠ r3 → r1 ≠ r4 → r2 ≠ r3 → r2 ≠ r4 → r3 ≠ r4 →
    ([∗ map] k↦y ∈ (<[r1:=w1]> (<[r2:=w2]> (<[r3:=w3]> (<[r4:=w4]> ∅)))), k ↦ᵣ y) -∗
    r1 ↦ᵣ w1 ∗ r2 ↦ᵣ w2 ∗ r3 ↦ᵣ w3 ∗ r4 ↦ᵣ w4.
  Proof.
    intros. iIntros "Hmap". rewrite !big_sepM_insert ?big_sepM_empty; simplify_map_eq; eauto.
    iDestruct "Hmap" as "(? & ? & ? & ? & _)"; iFrame.
  Qed.

  (* -------------- semantic heap + a map of pointsto -------------------------- *)

  Lemma gen_heap_valid_inSepM:
    ∀ (L V : Type) (EqDecision0 : EqDecision L) (H : Countable L)
      (Σ : gFunctors) (gen_heapG0 : gen_heapG L V Σ)
      (σ σ' : gmap L V) (l : L) (q : Qp) (v : V),
      σ' !! l = Some v →
      gen_heap_ctx σ -∗
      ([∗ map] k↦y ∈ σ', mapsto k q y) -∗
      ⌜σ !! l = Some v⌝.
  Proof.
    intros * Hσ'.
    rewrite (big_sepM_delete _ σ' l) //. iIntros "? [? ?]".
    iApply (gen_heap_valid with "[$]"). eauto.
  Qed.

  Lemma gen_heap_valid_inSepM':
    ∀ (L V : Type) (EqDecision0 : EqDecision L) (H : Countable L)
      (Σ : gFunctors) (gen_heapG0 : gen_heapG L V Σ)
      (σ σ' : gmap L V) (q : Qp),
      gen_heap_ctx σ -∗
      ([∗ map] k↦y ∈ σ', mapsto k q y) -∗
      ⌜forall (l: L) (v: V), σ' !! l = Some v → σ !! l = Some v⌝.
  Proof.
    intros *. iIntros "? Hmap" (l v Hσ').
    rewrite (big_sepM_delete _ σ' l) //. iDestruct "Hmap" as "[? ?]".
    iApply (gen_heap_valid with "[$]"). eauto.
  Qed.

  Lemma gen_heap_valid_inclSepM:
    ∀ (L V : Type) (EqDecision0 : EqDecision L) (H : Countable L)
      (Σ : gFunctors) (gen_heapG0 : gen_heapG L V Σ)
      (σ σ' : gmap L V) (q : Qp),
      gen_heap_ctx σ -∗
      ([∗ map] k↦y ∈ σ', mapsto k q y) -∗
      ⌜σ' ⊆ σ⌝.
  Proof.
    intros *. iIntros "Hσ Hmap".
    iDestruct (gen_heap_valid_inSepM' with "Hσ Hmap") as "#H".
    iDestruct "H" as %Hincl. iPureIntro. intro l.
    unfold option_relation.
    destruct (σ' !! l) eqn:HH'; destruct (σ !! l) eqn:HH; naive_solver.
  Qed.

  Lemma gen_heap_valid_allSepM:
    ∀ (L V : Type) (EqDecision0 : EqDecision L) (H : Countable L)
      (EV: Equiv V) (REV: Reflexive EV) (LEV: @LeibnizEquiv V EV)
      (Σ : gFunctors) (gen_heapG0 : gen_heapG L V Σ)
      (σ σ' : gmap L V) (q : Qp),
      (forall (l:L), is_Some (σ' !! l)) →
      gen_heap_ctx σ -∗
      ([∗ map] k↦y ∈ σ', mapsto k q y) -∗
      ⌜ σ = σ' ⌝.
  Proof.
    intros * ? ? * Hσ'. iIntros "A B".
    iAssert (⌜ forall l, σ !! l = σ' !! l ⌝)%I with "[A B]" as %HH.
    { iIntros (l).
      specialize (Hσ' l). unfold is_Some in Hσ'. destruct Hσ' as [v Hσ'].
      rewrite Hσ'.
      eapply (gen_heap_valid_inSepM _ _ _ _ _ _ σ σ') in Hσ'.
      iApply (Hσ' with "[$]"). eauto. }
    iPureIntro. eapply map_leibniz. intro.
    eapply leibniz_equiv_iff. auto.
    Unshelve.
    unfold equiv. unfold Reflexive. intros [ x |].
    { unfold option_equiv. constructor. apply REV. } constructor.
  Qed.

  Lemma gen_heap_update_inSepM :
    ∀ {L V : Type} {EqDecision0 : EqDecision L}
      {H : Countable L} {Σ : gFunctors}
      {gen_heapG0 : gen_heapG L V Σ}
      (σ σ' : gmap L V) (l : L) (v : V),
      is_Some (σ' !! l) →
      gen_heap_ctx σ
      -∗ ([∗ map] k↦y ∈ σ', mapsto k 1 y)
      ==∗ gen_heap_ctx (<[l:=v]> σ)
          ∗ [∗ map] k↦y ∈ (<[l:=v]> σ'), mapsto k 1 y.
  Proof.
    intros * Hσ'. destruct Hσ'.
    rewrite (big_sepM_delete _ σ' l) //. iIntros "Hh [Hl Hmap]".
    iMod (gen_heap_update with "Hh Hl") as "[Hh Hl]". iModIntro.
    iSplitL "Hh"; eauto.
    rewrite (big_sepM_delete _ (<[l:=v]> σ') l).
    { rewrite delete_insert_delete. iFrame. }
    rewrite lookup_insert //.
  Qed.

  (* --------------------------- CAPABILITY PREDICATE ------------------------------- *)
  (* Points to predicates for memory *)
  Notation "a ↦ₐ [ p ] w" := (∃ cap_γ, MonRefMapsto a cap_γ (w,p))%I
              (at level 20, p at level 50, format "a  ↦ₐ [ p ]  w") : bi_scope.
  Definition mapsto_nO (a: Addr) (p: Perm) (w: Word) := (a ↦ₐ[p] w ∗ ⌜p ≠ O⌝)%I.

  Lemma gen_heap_valid_cap
        (σ : gmap Addr Word) (a : Addr) (w : Word) (p : Perm) :
    p ≠ O →
    gen_heap_ctx σ -∗ a ↦ₐ[p] w -∗ ⌜σ !! a = Some w⌝.
  Proof.
    iIntros (Hne) "Hσ Ha".
    iDestruct "Ha" as (γ_cap) "Ha".
    rewrite MonRefMapsto_eq /MonRefMapsto_def /=.
    iDestruct "Ha" as "(Hex & Hal & [Ha | %])"; [|contradiction].
    iApply (gen_heap_valid with "Hσ Ha").
  Qed.

  Lemma cap_duplicate_false a p p' w w' :
    p ≠ O ∧ p' ≠ O →
    a ↦ₐ[p] w ∗ a ↦ₐ[p'] w' -∗ False.
  Proof.
    iIntros ([Hne1 Hne2]) "[Ha1 Ha2]".
    iDestruct "Ha1" as (γ1) "Ha1".
    iDestruct "Ha2" as (γ2) "Ha2".
    do 2 rewrite MonRefMapsto_eq /MonRefMapsto_def /=.
    iDestruct "Ha1" as "(_ & _ & [Ha | %])"; [|contradiction].
    iDestruct "Ha2" as "(_ & _ & [Ha' | %])"; [|contradiction].
    iDestruct (mapsto_valid_2 with "Ha Ha'") as %Hcontr. done.
  Qed.

  Lemma cap_restrict (a : Addr) (w : Word) (p p' : Perm) :
    PermFlows p' p →
    a ↦ₐ[p] w ==∗ a ↦ₐ[p'] w.
  Proof.
    iIntros (Hfl) "Ha".
    iDestruct "Ha" as (γ_cap) "Ha". iExists (γ_cap).
    do 2 rewrite MonRefMapsto_eq /MonRefMapsto_def /=.
    iDestruct "Ha" as "(Hex & Hal & Ha)".
    iMod (MonRef_update (A:=A) with "Hex") as "[HE HFr']"; eauto.
    right with (w,p');[|left].
    constructor; auto.
    iFrame.
    iDestruct "Ha" as "[Ha | %]".
    - iLeft. by iFrame.
    - subst. destruct p'; inversion Hfl. by iRight.
  Qed.

  Lemma gen_heap_update_cap (σ : gmap Addr Word) (a : Addr) (p : Perm) (w w' : Word) :
    PermFlows (LeastPermUpd w') p →
    gen_heap_ctx σ -∗ a ↦ₐ[p] w ==∗ gen_heap_ctx (<[a:=w']> σ) ∗ a ↦ₐ[p] w'.
  Proof.
    iIntros (Hf) "Hσ Ha".
    iDestruct "Ha" as (γ_cap) "Ha". iApply bi.sep_exist_l. iExists γ_cap.
    do 2 rewrite MonRefMapsto_eq /MonRefMapsto_def /=.
    assert (p ≠ O) as Ho.
    { assert (PermFlows URW p) as Hflp.
      by etransitivity; eauto using LeastPermUpd_atleast.
      inversion Hflp; destruct p; eauto. }
    iDestruct "Ha" as "(Hex & Hal & [Ha | %])"; [|contradiction].
    iMod (MonRef_update (A:=A) with "Hex") as "[$ $]"; eauto.
    { right with (w',p); [|left]. by constructor. }
    by iMod (gen_heap_update with "Hσ Ha") as "[$ $]".
  Qed.

  Lemma wp_lift_atomic_head_step_no_fork_determ {s E Φ} e1 :
    to_val e1 = None →
    (∀ (σ1:cap_lang.state) κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
     ∃ κ e2 (σ2:cap_lang.state) efs, ⌜cap_lang.prim_step e1 σ1 κ e2 σ2 efs⌝ ∗
      (▷ |==> (state_interp σ2 κs n ∗ from_option Φ False (to_val e2))))
      ⊢ WP e1 @ s; E {{ Φ }}.
  Proof.
    iIntros (?) "H". iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 κ κs n)  "Hσ1 /=".
    iMod ("H" $! σ1 κ κs n with "[Hσ1]") as "H"; auto.
    iDestruct "H" as (κ' e2 σ2 efs) "[H1 H2]".
    iModIntro. iSplit.
    - rewrite /head_reducible /=.
      iExists κ', e2, σ2, efs. auto.
    - iNext. iIntros (? ? ?) "H".
      iDestruct "H" as %Hs1.
      iDestruct "H1" as %Hs2.
      destruct (cap_lang_determ _ _ _ _ _ _ _ _ _ _ Hs1 Hs2) as [Heq1 [Heq2 [Heq3 Heq4]]].
      subst a; subst a0; subst a1.
      iMod "H2". iModIntro. iFrame. inv Hs1; auto.
  Qed.

  (* -------------- predicates on memory maps -------------------------- *)

  (* Permission-carrying memory type, used to describe maps of locations and permissions in the load and store cases *)
  Definition PermMem := gmap Addr (Perm * Word).

  Lemma resource_exists a p' w:
    a ↦ₐ[p'] w ⊣⊢ (∃ (p : Perm) (w0 : Word), ⌜(p', w) = (p, w0)⌝ ∗ a ↦ₐ[p] w0).
  Proof.
    iSplit; first by auto.
    iIntros "HH"; iDestruct "HH" as (p w0 Heq) "HH"; by inversion Heq.
  Qed.

  Lemma address_dupl_false a w1 w2 p1 p2 :
    p1 ≠ O → p2 ≠ O → a ↦ₐ[p1] w1 -∗ a ↦ₐ[p2] w2 -∗ False.
  Proof.
    iIntros (p1ne p2ne) "Hr1 Hr2".
    iDestruct "Hr1" as (g1) "Hr1".
    iDestruct "Hr2" as (g2) "Hr2".
    iDestruct (MonRefDealloc with "[$Hr1]") as "[[Hr1 | %] _]"; last congruence.
    iDestruct (MonRefDealloc with "[$Hr2]") as "[[Hr2 | %] _]"; last congruence.
    iDestruct (mapsto_valid_2 with "Hr1 Hr2") as %?.
    contradiction.
  Qed.

  Lemma extract_sep_if_split a pc_a P Q R:
     (if (a =? pc_a)%a then P else Q ∗ R)%I ≡
     ((if (a =? pc_a)%a then P else Q) ∗
     if (a =? pc_a)%a then emp else R)%I.
  Proof.
    destruct (a =? pc_a)%a; auto.
    iSplit; auto. iIntros "[H1 H2]"; auto.
  Qed.

  Lemma address_neq a1 a2 w1 w2 p1 p2  :
    p1 ≠ O → p2 ≠ O → a1 ↦ₐ[p1] w1 -∗ a2 ↦ₐ[p2] w2 -∗ ⌜ a1 ≠ a2 ⌝.
  Proof.
    iIntros (p1ne p2ne) "H1 H2". iIntros (contr). subst a1. iApply (address_dupl_false with "H1 H2");auto.
  Qed.

  Lemma memMap_resource_0  :
        True ⊣⊢ ([∗ map] a↦pw ∈ ∅, ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w).
  Proof.
    by rewrite big_sepM_empty.
  Qed.

  Lemma memMap_resource_1 (a : Addr) (p' : Perm) (w : Word)  :
        a ↦ₐ[p'] w  ⊣⊢ ([∗ map] a↦pw ∈ <[a:=(p',w)]> ∅, ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w)%I.
  Proof.
    rewrite big_sepM_delete; last by apply lookup_insert.
    rewrite delete_insert; last by auto. rewrite -memMap_resource_0.
    iSplit; iIntros "HH".
    - rewrite resource_exists. by iSplitL.
    - rewrite resource_exists. by iDestruct "HH" as "[HH _]".
  Qed.

  Lemma memMap_resource_2ne (a1 a2 : Addr) (p1' p2' : Perm) (w1 w2 : Word)  :
    a1 ≠ a2 → ([∗ map] a↦pw ∈  <[a1:=(p1',w1)]> (<[a2:=(p2',w2)]> ∅), ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w)%I ⊣⊢ a1 ↦ₐ[p1'] w1 ∗ a2 ↦ₐ[p2'] w2.
  Proof.
    intros.
    rewrite big_sepM_delete; last by apply lookup_insert.
    rewrite (big_sepM_delete _ _ a2 (p2',w2)); rewrite delete_insert; try by rewrite lookup_insert_ne. 2: by rewrite lookup_insert.
    rewrite delete_insert; auto.
    rewrite -memMap_resource_0.
    iSplit; iIntros "HH".
    - iDestruct "HH" as "[H1 [H2 _ ] ]".  iSplitL "H1"; by rewrite -resource_exists.
    - iDestruct "HH" as "[H1 H2]". iSplitL "H1"; auto.
  Qed.

  Lemma memMap_resource_2ne_apply (a1 a2 : Addr) (p1' p2' : Perm) (w1 w2 : Word)  :
    p1' ≠ O → p2' ≠ O → a1 ↦ₐ[p1'] w1 -∗ a2 ↦ₐ[p2'] w2 -∗ ([∗ map] a↦pw ∈  <[a1:=(p1',w1)]> (<[a2:=(p2',w2)]> ∅), ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w) ∗ ⌜a1 ≠ a2⌝.
  Proof.
    iIntros (Hne1 Hne2) "Hi Hr2a".
    iDestruct (address_neq  with "Hi Hr2a") as %Hne; auto.
    iSplitL; last by auto.
    iApply memMap_resource_2ne; auto. iSplitL "Hi"; auto.
  Qed.

  Lemma memMap_resource_2gen (a1 a2 : Addr) (p1' p2' : Perm) (w1 w2 : Word)  :
    ( ∃ mem, ([∗ map] a↦pw ∈ mem, ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w) ∧
       ⌜ if  (a2 =? a1)%a
       then mem =  (<[a1:=(p1',w1)]> ∅)
       else mem = <[a1:=(p1',w1)]> (<[a2:=(p2',w2)]> ∅)⌝
    )%I ⊣⊢ (a1 ↦ₐ[p1'] w1 ∗ if (a2 =? a1)%a then emp else a2 ↦ₐ[p2'] w2) .
  Proof.
    destruct (a2 =? a1)%a eqn:Heq.
    - apply Z.eqb_eq, z_of_eq in Heq. rewrite memMap_resource_1.
      iSplit.
      * iDestruct 1 as (mem) "[HH ->]".  by iSplit.
      * iDestruct 1 as "[Hmap _]". iExists (<[a1:=(p1', w1)]> ∅); iSplitL; auto.
    - apply Z.eqb_neq in Heq.
      rewrite -memMap_resource_2ne; auto. 2 : congruence.
      iSplit.
      * iDestruct 1 as (mem) "[HH ->]". done.
      * iDestruct 1 as "Hmap". iExists (<[a1:=(p1', w1)]> (<[a2:=(p2', w2)]> ∅)); iSplitL; auto.
  Qed.

  Lemma memMap_resource_2gen_d (a1 a2 : Addr) (p1' p2' : Perm) (w1 w2 : Word)  :
    ( ∃ mem, ([∗ map] a↦pw ∈ mem, ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w) ∧
       ⌜ if  (a2 =? a1)%a
       then mem =  (<[a1:=(p1',w1)]> ∅)
       else mem = <[a1:=(p1',w1)]> (<[a2:=(p2',w2)]> ∅)⌝
    ) -∗ (a1 ↦ₐ[p1'] w1 ∗ if (a2 =? a1)%a then emp else a2 ↦ₐ[p2'] w2) .
  Proof.
    iIntros. by rewrite memMap_resource_2gen.
  Qed.

  (* Not the world's most beautiful lemma, but it does avoid us having to fiddle around with a later under an if in proofs *)
  Lemma memMap_resource_2gen_clater (a1 a2 : Addr) (p1' p2' : Perm) (w1 w2 : Word)  :
    (▷ a1 ↦ₐ[p1'] w1) -∗
    (if (a2 =? a1)%a then emp else ▷ a2 ↦ₐ[p2'] w2) -∗
    (∃ mem, ▷ ([∗ map] a↦pw ∈ mem, ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w) ∗
       ⌜if  (a2 =? a1)%a
       then mem =  (<[a1:=(p1',w1)]> ∅)
       else mem = <[a1:=(p1',w1)]> (<[a2:=(p2',w2)]> ∅)⌝
    )%I.
  Proof.
    iIntros "Hc1 Hc2".
    destruct (a2 =? a1)%a eqn:Heq.
    - iExists (<[a1:=(p1', w1)]> ∅); iSplitL; auto. iNext. by rewrite memMap_resource_1.
    - iExists (<[a1:=(p1', w1)]> (<[a2:=(p2', w2)]> ∅)); iSplitL; auto.
      iNext. iDestruct (memMap_resource_2ne with "[$Hc1 $Hc2]") as "Hmem".
      {apply Z.eqb_neq in Heq. congruence. }
      done.
  Qed.

  Lemma memMap_delete:
    ∀(a : Addr) (p' : Perm) (w : Word) (mem0 : PermMem),
      mem0 !! a = Some (p', w) →
      ([∗ map] a↦pw ∈ mem0, ∃ (p : Perm) (w0 : Word), ⌜pw = (p, w0)⌝ ∗ a ↦ₐ[p] w0)
      ⊣⊢ (a ↦ₐ[p'] w
         ∗ ([∗ map] k↦y ∈ delete a mem0, ∃ (p : Perm) (w0 : Word),
               ⌜y = (p, w0)⌝ ∗ k ↦ₐ[p] w0)).
  Proof.
    intros a p' w mem0 Hmem0a.
    rewrite resource_exists.
    rewrite -(big_sepM_delete _ _ a); auto.
  Qed.

  Lemma gen_mem_valid_inSepM:
    ∀ (a : Addr) (p' : Perm) (r1 r2 : RegName) (w : Word) (mem0 : PermMem) (r : Reg) (m : Mem),
      p' ≠ O →
      mem0 !! a = Some (p', w) →
      gen_heap_ctx m
                   -∗ ([∗ map] a↦pw ∈ mem0, ∃ (p : Perm) (w0 : Word), ⌜pw = (p, w0)⌝ ∗ a ↦ₐ[p] w0)
                   -∗ ⌜m !! a = Some w⌝.
  Proof.
    iIntros (a p' r1 r2 w mem0 r m Hpnz Hmem_pc) "Hm Hmem".
    iDestruct (memMap_delete a with "Hmem") as "[Hpc_a Hmem]"; eauto.
    iDestruct (gen_heap_valid_cap with "Hm Hpc_a") as %?; auto.
  Qed.

  Lemma mem_v_implies_m_v:
    ∀ (mem0 : PermMem) (m : Mem) (p : Perm) (g : Locality) (b e a : Addr) (p' : Perm) (v : Word),
      mem0 !! a = Some (p', v)
      → p' ≠ O
      → ([∗ map] a0↦pw ∈ mem0, ∃ (p0 : Perm) (w : Word),
            ⌜pw = (p0, w)⌝ ∗ a0 ↦ₐ[p0] w)
          -∗ gen_heap_ctx m -∗ ⌜m !m! a = v⌝.
  Proof.
    iIntros (mem0 m p g b e a p' v Hmema HPFp) "Hmem Hm".
    iDestruct (memMap_delete a with "Hmem") as "[H_a Hmem]"; eauto.
    iDestruct (gen_heap_valid_cap with "Hm H_a") as %?; auto.
    by option_locate_mr_once m r.
  Qed.

  Lemma gen_mem_update_inSepM :
    ∀ {Σ : gFunctors} {gen_heapG0 : gen_heapG Addr Word Σ}
      (σ : gmap Addr Word) (mem : PermMem) (l : Addr) (p : Perm) (v' v : Word),
      mem !! l = Some (p,v') → PermFlows (LeastPermUpd v) p →
      gen_heap_ctx σ
      -∗ ([∗ map] a0↦pw ∈ mem, ∃ (p0 : Perm) (w0 : Word),
             ⌜pw = (p0, w0)⌝ ∗ a0 ↦ₐ[p0] w0)
      ==∗ gen_heap_ctx (<[l:=v]> σ)
          ∗ ([∗ map] a0↦pw ∈ <[l:=(p,v)]> mem, ∃ (p0 : Perm) (w0 : Word),
             ⌜pw = (p0, w0)⌝ ∗ a0 ↦ₐ[p0] w0).
  Proof.
    intros.
    rewrite (memMap_delete l) //. iIntros "Hh [Hl Hmap]".
    iMod (gen_heap_update_cap with "Hh Hl") as "[Hh Hl]"; eauto.
    iModIntro.
    iSplitL "Hh"; eauto.
    iApply (memMap_delete l); first by rewrite lookup_insert.
    rewrite delete_insert_delete. iFrame.
  Qed.

  (* ----------------------------------- FAIL RULES ---------------------------------- *)

  Lemma wp_notCorrectPC:
    forall E w,
      ~ isCorrectPC w ->
      {{{ PC ↦ᵣ w }}}
        Instr Executable @ E
        {{{ RET FailedV; PC ↦ᵣ w }}}.
  Proof.
    intros *. intros Hnpc.
    iIntros (ϕ) "HPC Hϕ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 l1 l2 n) "Hσ1 /="; destruct σ1; simpl;
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (@gen_heap_valid with "Hr HPC") as %?.
    option_locate_mr m r.
    rewrite -HrPC in Hnpc.
    iApply fupd_frame_l.
    iSplit. by iPureIntro; apply normal_always_head_reducible.
    iModIntro. iIntros (e1 σ2 efs Hstep).
    apply prim_step_exec_inv in Hstep as (-> & -> & (c & -> & Hstep)).
    eapply step_fail_inv in Hstep as [-> ->]; eauto.
    iNext. iModIntro. iSplitR; auto. iFrame. cbn. by iApply "Hϕ".
  Qed.

  (* Subcases for respecitvely permissions and bounds *)

  Lemma wp_notCorrectPC_perm E pc_p pc_g pc_b pc_e pc_a :
      pc_p ≠ RX ∧ pc_p ≠ RWX ∧ pc_p ≠ RWLX →
      {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)}}}
      Instr Executable @ E
      {{{ RET FailedV; True }}}.
  Proof.
    iIntros (Hperm φ) "HPC Hwp".
    iApply (wp_notCorrectPC with "[HPC]");
      [apply not_isCorrectPC_perm;eauto|iFrame|].
    iNext. iIntros "HPC /=".
    by iApply "Hwp".
  Qed.

  Lemma wp_notCorrectPC_range E pc_p pc_g pc_b pc_e pc_a :
       ¬ (pc_b <= pc_a < pc_e)%a →
      {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)}}}
      Instr Executable @ E
      {{{ RET FailedV; True }}}.
  Proof.
    iIntros (Hperm φ) "HPC Hwp".
    iApply (wp_notCorrectPC with "[HPC]");
      [apply not_isCorrectPC_bounds;eauto|iFrame|].
    iNext. iIntros "HPC /=".
    by iApply "Hwp".
  Qed.

  (* ----------------------------------- ATOMIC RULES -------------------------------- *)

  Lemma wp_halt E pc_p pc_g pc_b pc_e pc_a w pc_p' :
    decodeInstrW w = Halt →
    PermFlows pc_p pc_p' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a) ∗ pc_a ↦ₐ[pc_p'] w }}}
      Instr Executable @ E
    {{{ RET HaltedV; PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a) ∗ pc_a ↦ₐ[pc_p'] w }}}.
  Proof.
    intros Hinstr Hfl Hvpc.
    iIntros (φ) "[Hpc Hpca] Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 l1 l2 n) "Hσ1 /=". destruct σ1; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (@gen_heap_valid with "Hr Hpc") as %?.
    iDestruct (@gen_heap_valid_cap with "Hm Hpca") as %?.
    { destruct pc_p'; auto. destruct pc_p; inversion Hfl.
      inversion Hvpc; subst. naive_solver. }
    iModIntro.
    iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iIntros (e2 σ2 efs Hstep).
    eapply prim_step_exec_inv in Hstep as (-> & -> & (c & -> & Hstep)).
    eapply step_exec_inv in Hstep; eauto. cbn in Hstep. simplify_eq.
    iNext. iModIntro. iSplitR; eauto. iFrame. iApply "Hφ". by iFrame.
  Qed.

  Lemma wp_fail E pc_p pc_g pc_b pc_e pc_a w pc_p' :
    decodeInstrW w = Fail →
    PermFlows pc_p pc_p' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a) ∗ pc_a ↦ₐ[pc_p'] w }}}
      Instr Executable @ E
    {{{ RET FailedV; PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a) ∗ pc_a ↦ₐ[pc_p'] w }}}.
  Proof.
    intros Hinstr Hfl Hvpc.
    iIntros (φ) "[Hpc Hpca] Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 l1 l2 n) "Hσ1 /=". destruct σ1; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (@gen_heap_valid with "Hr Hpc") as %?.
    iDestruct (@gen_heap_valid_cap with "Hm Hpca") as %?.
    { destruct pc_p'; auto. destruct pc_p; inversion Hfl.
      inversion Hvpc; subst. naive_solver. }
    iModIntro.
    iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iIntros (e2 σ2 efs Hstep).
    eapply prim_step_exec_inv in Hstep as (-> & -> & (c & -> & Hstep)).
    eapply step_exec_inv in Hstep; eauto. cbn in Hstep. simplify_eq.
    iNext. iModIntro. iSplitR; eauto. iFrame. iApply "Hφ". by iFrame.
   Qed.

  (* ----------------------------------- PURE RULES ---------------------------------- *)

  Local Ltac solve_exec_safe := intros; subst; do 3 eexists; econstructor; eauto.
  Local Ltac solve_exec_puredet := simpl; intros; by inv_head_step.
  Local Ltac solve_exec_pure := intros ?; apply nsteps_once, pure_head_step_pure_step;
                                constructor; [solve_exec_safe|]; intros;
                                (match goal with
                                | H : head_step _ _ _ _ _ _ |- _ => inversion H end).

  Global Instance pure_seq_failed :
    PureExec True 1 (Seq (Instr Failed)) (Instr Failed).
  Proof. by solve_exec_pure. Qed.

  Global Instance pure_seq_halted :
    PureExec True 1 (Seq (Instr Halted)) (Instr Halted).
  Proof. by solve_exec_pure. Qed.

  Global Instance pure_seq_done :
    PureExec True 1 (Seq (Instr NextI)) (Seq (Instr Executable)).
  Proof. by solve_exec_pure. Qed.

End cap_lang_rules.

(* Points to predicates for memory *)
Notation "a ↦ₐ [ p ] w" := (∃ cap_γ, MonRefMapsto a cap_γ (w,p))%I
  (at level 20, p at level 50, format "a  ↦ₐ [ p ]  w") : bi_scope.
Notation "a ↦ₐ < p > w" := (mapsto_nO a p w)
    (at level 20, p at level 50, format "a  ↦ₐ < p >  w") : bi_scope.

(* Used to close the failing cases of the ftlr.
  - Hcont is the (iris) name of the closing hypothesis (usually "Hφ")
  - fail_case_name is one constructor of the spec_name,
    indicating the appropriate error case
 *)
Ltac iFailCore fail_case_name :=
      iPureIntro;
      econstructor; eauto;
      eapply fail_case_name ; eauto.

Ltac iFailWP Hcont fail_case_name :=
  by (cbn; iFrame; iApply Hcont; iFrame; iFailCore fail_case_name).

(* ----------------- useful definitions to factor out the wp specs ---------------- *)

(*--- register equality ---*)
  Lemma addr_ne_reg_ne {regs : leibnizO Reg} {r1 r2 : RegName}
        {p0 g0 b0 e0 a0 p g b e a}:
    regs !! r1 = Some (inr (p0, g0, b0, e0, a0))
    → regs !! r2 = Some (inr (p, g, b, e, a))
    → a0 ≠ a → r1 ≠ r2.
  Proof.
    intros Hr1 Hr2 Hne.
    destruct (decide (r1 = r2)); simplify_eq; auto.
  Qed.

(*--- word_of_argument ---*)

Definition word_of_argument (regs: Reg) (a: Z + RegName): option Word :=
  match a with
  | inl n => Some (inl n)
  | inr r => regs !! r
  end.

Lemma word_of_argument_Some_inv (regs: Reg) (arg: Z + RegName) (w:Word) :
  word_of_argument regs arg = Some w →
  ((∃ z, arg = inl z ∧ w = inl z) ∨
   (∃ r, arg = inr r ∧ regs !! r = Some w)).
Proof.
  unfold word_of_argument. intro. repeat case_match; simplify_eq/=; eauto.
Qed.

Lemma word_of_argument_Some_inv' (regs regs': Reg) (arg: Z + RegName) (w:Word) :
  word_of_argument regs arg = Some w →
  regs ⊆ regs' →
  ((∃ z, arg = inl z ∧ w = inl z) ∨
   (∃ r, arg = inr r ∧ regs !! r = Some w ∧ regs' !! r = Some w)).
Proof.
  unfold word_of_argument. intro. repeat case_match; simplify_eq/=; eauto.
  intros HH. unshelve epose proof (lookup_weaken _ _ _ _ _ HH); eauto.
Qed.

(*--- addr_of_argument ---*)

Definition addr_of_argument regs src :=
  match z_of_argument regs src with
  | Some n => z_to_addr n
  | None => None
  end.

Lemma addr_of_argument_Some_inv (regs: Reg) (arg: Z + RegName) (a:Addr) :
  addr_of_argument regs arg = Some a →
  ∃ z, z_to_addr z = Some a ∧
       (arg = inl z ∨ ∃ r, arg = inr r ∧ regs !! r = Some (inl z)).
Proof.
  unfold addr_of_argument, z_of_argument.
  intro. repeat case_match; simplify_eq/=; eauto. eexists. eauto.
Qed.

Lemma addr_of_argument_Some_inv' (regs regs': Reg) (arg: Z + RegName) (a:Addr) :
  addr_of_argument regs arg = Some a →
  regs ⊆ regs' →
  ∃ z, z_to_addr z = Some a ∧
       (arg = inl z ∨ ∃ r, arg = inr r ∧ regs !! r = Some (inl z) ∧ regs' !! r = Some (inl z)).
Proof.
  unfold addr_of_argument, z_of_argument.
  intros ? HH. repeat case_match; simplify_eq/=; eauto. eexists. split; eauto.
  unshelve epose proof (lookup_weaken _ _ _ _ _ HH); eauto.
Qed.

(*--- regs_of ---*)

Definition regs_of_argument (arg: Z + RegName): gset RegName :=
  match arg with
  | inl _ => ∅
  | inr r => {[ r ]}
  end.

Definition regs_of (i: instr): gset RegName :=
  match i with
  | Lea r1 arg => {[ r1 ]} ∪ regs_of_argument arg
  | GetP r1 r2 => {[ r1; r2 ]}
  | GetL r1 r2 => {[ r1; r2 ]}
  | GetB r1 r2 => {[ r1; r2 ]}
  | GetE r1 r2 => {[ r1; r2 ]}
  | GetA r1 r2 => {[ r1; r2 ]}
  | Add r arg1 arg2 => {[ r ]} ∪ regs_of_argument arg1 ∪ regs_of_argument arg2
  | Sub r arg1 arg2 => {[ r ]} ∪ regs_of_argument arg1 ∪ regs_of_argument arg2
  | Lt r arg1 arg2 => {[ r ]} ∪ regs_of_argument arg1 ∪ regs_of_argument arg2
  | IsPtr dst src => {[ dst; src ]}
  | Mov r arg => {[ r ]} ∪ regs_of_argument arg
  | Restrict r1 arg => {[ r1 ]} ∪ regs_of_argument arg
  | Subseg r arg1 arg2 => {[ r ]} ∪ regs_of_argument arg1 ∪ regs_of_argument arg2
  | Load r1 r2 => {[ r1; r2 ]}
  | Store r1 arg => {[ r1 ]} ∪ regs_of_argument arg
  | Jnz r1 r2 => {[ r1; r2 ]}
  | LoadU dst src offs => {[ dst; src ]} ∪ regs_of_argument offs
  | StoreU dst offs src => {[ dst ]} ∪ regs_of_argument offs  ∪ regs_of_argument src
  | PromoteU dst => {[ dst ]}
  | _ => ∅
  end.

Lemma indom_regs_incl D (regs regs': Reg) :
  D ⊆ dom (gset RegName) regs →
  regs ⊆ regs' →
  ∀ r, r ∈ D →
       ∃ (w:Word), (regs !! r = Some w) ∧ (regs' !! r = Some w).
Proof.
  intros * HD Hincl rr Hr.
  assert (is_Some (regs !! rr)) as [w Hw].
  { eapply @elem_of_dom with (D := gset RegName). typeclasses eauto.
    eapply elem_of_subseteq; eauto. }
  exists w. split; auto. eapply lookup_weaken; eauto.
Qed.

(*--- incrementPC ---*)

Definition incrementPC (regs: Reg) : option Reg :=
  match regs !! PC with
  | Some (inr ((p, g), b, e, a)) =>
    match (a + 1)%a with
    | Some a' => Some (<[ PC := inr ((p, g), b, e, a') ]> regs)
    | None => None
    end
  | _ => None
  end.

Lemma incrementPC_Some_inv regs regs' :
  incrementPC regs = Some regs' ->
  exists p g b e a a',
    regs !! PC = Some (inr ((p, g), b, e, a)) ∧
    (a + 1)%a = Some a' ∧
    regs' = <[ PC := inr ((p, g), b, e, a') ]> regs.
Proof.
  unfold incrementPC.
  destruct (regs !! PC) as [ [| [ [ [ [? ?] ?] ?] u] ] |];
    try congruence.
  case_eq (u+1)%a; try congruence. intros ? ?. inversion 1.
  do 6 eexists. split; eauto.
Qed.

Lemma incrementPC_None_inv regs pg b e a :
  incrementPC regs = None ->
  regs !! PC = Some (inr (pg, b, e, a)) ->
  (a + 1)%a = None.
Proof.
  unfold incrementPC.
  destruct (regs !! PC) as [ [| [ [ [ [? ?] ?] ?] u] ] |];
    try congruence.
  case_eq (u+1)%a; congruence.
Qed.

Lemma incrementPC_overflow_mono regs regs' :
  incrementPC regs = None →
  is_Some (regs !! PC) →
  regs ⊆ regs' →
  incrementPC regs' = None.
Proof.
  intros Hi HPC Hincl. unfold incrementPC in *. destruct HPC as [c HPC].
  pose proof (lookup_weaken _ _ _ _ HPC Hincl) as HPC'.
  rewrite HPC HPC' in Hi |- *.
  destruct c as [| ((((?&?)&?)&?)&aa)]; first by auto.
  destruct (aa+1)%a; last by auto. congruence.
Qed.

(* todo: instead, define updatePC on top of incrementPC *)
Lemma incrementPC_fail_updatePC regs m :
   incrementPC regs = None ->
   updatePC (regs, m) = (Failed, (regs, m)).
Proof.
   rewrite /incrementPC /updatePC /RegLocate /=.
   destruct (regs !! PC) as [X|]; auto.
   destruct X as [| [[[[? ?] ?] ?] a']]; auto.
   destruct (a' + 1)%a; auto. congruence.
Qed.

Lemma incrementPC_success_updatePC regs m regs' :
  incrementPC regs = Some regs' ->
  ∃ p g b e a a',
    regs !! PC = Some (inr ((p, g, b, e, a))) ∧
    (a + 1)%a = Some a' ∧
    updatePC (regs, m) = (NextI, (<[ PC := inr ((p, g), b, e, a') ]> regs, m)) ∧
    regs' = <[ PC := inr ((p, g), b, e, a') ]> regs.
Proof.
  rewrite /incrementPC /updatePC /update_reg /RegLocate /=.
  destruct (regs !! PC) as [X|] eqn:?; auto; try congruence; [].
  destruct X as [| [[[[? ?] ?] ?] a']] eqn:?; try congruence; [].
  destruct (a' + 1)%a eqn:?; [| congruence]. inversion 1; subst regs'.
  do 6 eexists. repeat split; auto.
Qed.

Lemma updatePC_success_incl m m' regs regs' w :
  regs ⊆ regs' →
  updatePC (regs, m) = (NextI, (<[ PC := w ]> regs, m)) →
  updatePC (regs', m') = (NextI, (<[ PC := w ]> regs', m')).
Proof.
  intros * Hincl Hu. rewrite /updatePC /= in Hu |- *.
  destruct (regs !! PC) as [ w1 |] eqn:Hrr.
  { pose proof (regs_lookup_eq _ _ _ Hrr) as Hrr2. rewrite Hrr2 in Hu.
    pose proof (lookup_weaken _ _ _ _ Hrr Hincl) as ->%regs_lookup_eq.
    destruct w1 as [|((((?&?)&?)&?)&a1)]; simplify_eq.
    destruct (a1 + 1)%a eqn:Ha1; simplify_eq. rewrite /update_reg /=.
    f_equal. f_equal.
    assert (HH: forall (reg1 reg2:Reg), reg1 = reg2 -> reg1 !! PC = reg2 !! PC)
      by (intros * ->; auto).
    apply HH in Hu. rewrite !lookup_insert in Hu. by simplify_eq. }
  { unfold RegLocate in Hu. rewrite Hrr in Hu. inversion Hu. }
Qed.

Lemma updatePC_fail_incl m m' regs regs' :
  is_Some (regs !! PC) →
  regs ⊆ regs' →
  updatePC (regs, m) = (Failed, (regs, m)) →
  updatePC (regs', m') = (Failed, (regs', m')).
Proof.
  intros [w HPC] Hincl Hfail. rewrite /updatePC /RegLocate /= in Hfail |- *.
  rewrite !HPC in Hfail. have -> := lookup_weaken _ _ _ _ HPC Hincl.
  destruct w as [|((((?&?)&?)&?)&a1)]; simplify_eq; auto;[].
  destruct (a1 + 1)%a; simplify_eq; auto.
Qed.

Ltac incrementPC_inv :=
  match goal with
  | H : incrementPC _ = Some _ |- _ =>
    apply incrementPC_Some_inv in H as (?&?&?&?&?&?&?&?&?)
  | H : incrementPC _ = None |- _ =>
    eapply incrementPC_None_inv in H
  end; simplify_eq.

Lemma pair_eq_inv {A B} {y u : A} {z t : B} {x} :
    x = (y, z) -> x = (u, t) ->
    y = u ∧ z = t.
Proof. intros ->. inversion 1. auto. Qed.

(* TODO: integrate into stdpp? *)
Tactic Notation "simplify_pair_eq" :=
  repeat
    lazymatch goal with
    | H1 : ?x = (?y, ?z), H2 : ?x = (?u, ?t) |- _ =>
      assert (y = u ∧ z = t) as [? ?] by (exact (pair_eq_inv H1 H2)); clear H2
    | H1 : (?y, ?z) = ?x, H2 : ?x = (?u, ?t) |- _ =>
      assert (y = u ∧ z = t) as [? ?] by (exact (pair_eq_inv (eq_sym H1) H2)); clear H2
    | H1 : ?x = (?y, ?z), H2 : (?u, ?t) = ?x |- _ =>
      assert (y = u ∧ z = t) as [? ?] by (exact (pair_eq_inv H1 (eq_sym H2))); clear H2
    | H1 : (?y, ?z) = ?x, H2 : (?u, ?t) = ?x |- _ =>
      assert (y = u ∧ z = t) as [? ?] by (exact (pair_eq_inv (eq_sym H1) (eq_sym H2))); clear H2
    | |- _ => progress simplify_eq
    end.

(*----------------------- FIXME TEMPORARY ------------------------------------*)
(* This is a copy-paste from stdpp (fin_maps.v), plus a fix to avoid using
   "rewrite .. by .." that is not available when using ssreflect's rewrite. *)
(* TODO: upstream the fix into stdpp, and remove the code below whenever we
   upgrade to a version of stdpp that includes it *)

Tactic Notation "simpl_map" "by" tactic3(tac) := repeat
  match goal with
  | H : context[ ∅ !! _ ] |- _ => rewrite lookup_empty in H
  | H : context[ (<[_:=_]>_) !! _ ] |- _ =>
    rewrite lookup_insert in H || (rewrite lookup_insert_ne in H; [| by tac])
  | H : context[ (alter _ _ _) !! _] |- _ =>
    rewrite lookup_alter in H || (rewrite lookup_alter_ne in H; [| by tac])
  | H : context[ (delete _ _) !! _] |- _ =>
    rewrite lookup_delete in H || (rewrite lookup_delete_ne in H; [| by tac])
  | H : context[ {[ _ := _ ]} !! _ ] |- _ =>
    rewrite lookup_singleton in H || (rewrite lookup_singleton_ne in H; [| by tac])
  | H : context[ (_ <$> _) !! _ ] |- _ => rewrite lookup_fmap in H
  | H : context[ (omap _ _) !! _ ] |- _ => rewrite lookup_omap in H
  | H : context[ lookup (A:=?A) ?i (?m1 ∪ ?m2) ] |- _ =>
    let x := fresh in evar (x:A);
    let x' := eval unfold x in x in clear x;
    let E := fresh in
    assert ((m1 ∪ m2) !! i = Some x') as E by (clear H; by tac);
    rewrite E in H; clear E
  | |- context[ ∅ !! _ ] => rewrite lookup_empty
  | |- context[ (<[_:=_]>_) !! _ ] =>
    rewrite lookup_insert || (rewrite lookup_insert_ne; [| by tac])
  | |- context[ (alter _ _ _) !! _ ] =>
    rewrite lookup_alter || (rewrite lookup_alter_ne; [| by tac])
  | |- context[ (delete _ _) !! _ ] =>
    rewrite lookup_delete || (rewrite lookup_delete_ne; [| by tac])
  | |- context[ {[ _ := _ ]} !! _ ] =>
    rewrite lookup_singleton || (rewrite lookup_singleton_ne; [| by tac])
  | |- context[ (_ <$> _) !! _ ] => rewrite lookup_fmap
  | |- context[ (omap _ _) !! _ ] => rewrite lookup_omap
  | |- context [ lookup (A:=?A) ?i ?m ] =>
    let x := fresh in evar (x:A);
    let x' := eval unfold x in x in clear x;
    let E := fresh in
    assert (m !! i = Some x') as E by tac;
    rewrite E; clear E
  end.

Tactic Notation "simpl_map" := simpl_map by eauto with simpl_map map_disjoint.

Tactic Notation "simplify_map_eq" "by" tactic3(tac) :=
  decompose_map_disjoint;
  repeat match goal with
  | _ => progress simpl_map by tac
  | _ => progress simplify_eq/=
  | _ => progress simpl_option by tac
  | H : {[ _ := _ ]} !! _ = None |- _ => rewrite lookup_singleton_None in H
  | H : {[ _ := _ ]} !! _ = Some _ |- _ =>
    rewrite lookup_singleton_Some in H; destruct H
  | H1 : ?m1 !! ?i = Some ?x, H2 : ?m2 !! ?i = Some ?y |- _ =>
    let H3 := fresh in
    feed pose proof (lookup_weaken_inv m1 m2 i x y) as H3; [done|by tac|done|];
    clear H2; symmetry in H3
  | H1 : ?m1 !! ?i = Some ?x, H2 : ?m2 !! ?i = None |- _ =>
    let H3 := fresh in
    apply (lookup_weaken _ m2) in H1; [congruence|by tac]
  | H : ?m ∪ _ = ?m ∪ _ |- _ =>
    apply map_union_cancel_l in H; [|by tac|by tac]
  | H : _ ∪ ?m = _ ∪ ?m |- _ =>
    apply map_union_cancel_r in H; [|by tac|by tac]
  | H : {[?i := ?x]} = ∅ |- _ => by destruct (map_non_empty_singleton i x)
  | H : ∅ = {[?i := ?x]} |- _ => by destruct (map_non_empty_singleton i x)
  | H : ?m !! ?i = Some _, H2 : ?m !! ?j = None |- _ =>
     unless (i ≠ j) by done;
     assert (i ≠ j) by (by intros ?; simplify_eq)
  end.
Tactic Notation "simplify_map_eq" "/=" "by" tactic3(tac) :=
  repeat (progress csimpl in * || simplify_map_eq by tac).
Tactic Notation "simplify_map_eq" :=
  simplify_map_eq by eauto with simpl_map map_disjoint.
Tactic Notation "simplify_map_eq" "/=" :=
  simplify_map_eq/= by eauto with simpl_map map_disjoint.


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.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^266 - 3
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 9%nat;
    base := 32;
    bitwidth := 32;
    s := 2^266;
    c := [(1, 3)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(* 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.