theory Big_Step_7p9
imports Com_7p9
begin

(* concrete syntax (_,_) \<Rightarrow> _ is possible becasue we declared the transition arrow \<Rightarrow> as an
   infix symbol below with precendence 55 *)

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where

Skip:       "(SKIP,s) \<Rightarrow> s" |
Assign:     "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq:        "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue:     "\<lbrakk> bval b s;   (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse:    "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:  "\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
              \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
OrLeft:     "(c\<^sub>1, s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t" |
OrRight:    "(c\<^sub>2, s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t"

(* `print_theorems` is incredibly useful for seeing what certain
   declarations bring into scope *)
print_theorems

declare big_step.intros [intro]

(* From the textbook:
"This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:"
*)
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct

schematic_goal ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
  apply(rule Seq)
   apply(rule Assign)
  apply simp
  apply(rule Assign)
done

(* The following command tells Isabelle to generate code for the predicate \<Rightarrow> and thus make the
predicate available in the `values` command, which is similar to `value`, but works on
inductive definitions and computes a set of possible results.  *)

code_pred big_step . (* The period is necessary at the end of this line *)

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

values "{map t [''x'', ''y'']| t. (''x'' ::= N 2;; ''y'' ::= plus (V ''x'') (N 1), \<lambda>_.0) \<Rightarrow> t}"

(* 7.2.3 Rule Inversion *)

(* Inductive definitions like above bring into scope automatically generated .induct and .cases theorems *)

(* Now we prove a bunch of rule inversions. I've decided not to use inductive_cases as in
   the official solutions and instead prove the rule inversions as they were expressed in
   the textbook.

   I must mention my indebtedness to this particular Isabelle mailing list post:
   https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2013-January/msg00118.html

*)

lemma SkipE[elim!]: "(SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
  by (erule big_step.cases, simp+)

lemma AssignE[elim!]:  "(x ::= a,s) \<Rightarrow> t \<Longrightarrow> t = s(x := aval a s)"
  by (erule big_step.cases, simp+)

lemma SeqE[elim!]: "(c1;;c2, s1) \<Rightarrow> s3 \<Longrightarrow> \<exists>s2. (c1,s1) \<Rightarrow> s2 \<and> (c2,s2) \<Rightarrow> s3"
  by (erule big_step.cases, auto)

lemma IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t \<Longrightarrow> bval b s \<and> (c1, s) \<Rightarrow> t \<or> \<not>bval b s \<and> (c2, s) \<Rightarrow> t"
  by (erule big_step.cases, simp+)

lemma WhileE[elim]:
  "(WHILE b DO c, s) \<Rightarrow> t
  \<Longrightarrow>   bval b s \<and> (\<exists>s'. (c, s) \<Rightarrow> s' \<and> (WHILE b DO c, s') \<Rightarrow> t)
      \<or> \<not>bval b s \<and> t = s"
   by  (erule big_step.cases, auto)

lemma OrE[elim!]:
  "(c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1, s) \<Rightarrow> t \<or> (c\<^sub>2, s) \<Rightarrow> t"
  by (erule big_step.cases, auto)

inductive_cases SkipE2[elim!]: "(SKIP, s) \<Rightarrow> t"
inductive_cases AssignE2[elim!]: "(x ::= a,s) \<Rightarrow> t"
inductive_cases SeqE2[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
inductive_cases IfE2[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
inductive_cases WhileE2[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
inductive_cases OrE2[elim!]: "(c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t"

(* Lemma 7.2 *)
lemma seq_assoc_l: "(c1;; c2;; c3, s) \<Rightarrow> s' \<Longrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
  apply clarify
  apply (rule Seq, simp)
  apply (rule Seq, simp+)
  done

lemma seq_assoc_r: "(c1;; (c2;; c3), s) \<Rightarrow> s' \<Longrightarrow> (c1;; c2;; c3, s) \<Rightarrow> s'"
  apply clarify
  apply (rule Seq, rule Seq, simp+)
  done

lemma seq_assoc: "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
  by (auto simp: seq_assoc_l seq_assoc_r)

(* Section 7.2.4 *)

abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c, s) \<Rightarrow> t = (c', s) \<Rightarrow> t)"

print_theorems

lemma while_if_equiv: "WHILE b DO c \<sim> IF b THEN (c;; WHILE b DO c) ELSE SKIP"
  by blast

lemma if_equiv: "IF b THEN c ELSE c \<sim> c"
  by blast

(* Lemma 7.6 *)
(* Uses advanced rule induction from section 5.4.6 *)

lemma
  assumes "(WHILE b DO c, s) \<Rightarrow> t"
  assumes "c \<sim> c'"
  shows "(WHILE b DO c', s) \<Rightarrow> t"
using assms
  apply (induct "(WHILE b DO c, s)" "t" arbitrary: s)
   apply blast
  apply blast
  done

  (* or you can do *)
lemma  while_equiv_aux: "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> c \<sim> c' \<Longrightarrow> (WHILE b DO c', s) \<Rightarrow> t"
  apply(induction "(WHILE b DO c)" s t arbitrary: b c rule: big_step_induct)
   apply blast
  apply blast
  done

(*
  I found the unification that was going on with the advance rule induction to be a bit
  mysterious. The following theorem is very close to what we get after:

  apply (induction "(WHILE b DO c, s)" t arbitrary: b c s rule: big_step.induct)
*)

thm big_step.induct[of "(WHILE b DO c, s)" "t" "\<lambda>(c,s1) s2. \<forall>b ca. c = WHILE b DO ca \<longrightarrow> ca \<sim> c' \<longrightarrow> (WHILE b DO c', s1) \<Rightarrow> s2"]

(* Peter Gammie showed me how to get exactly what you get after the induction step in the proofs
   above. Not the use of the `for` construct and the `rule_format` attribute (also known as a
   "directive")
*)

lemmas unified_big_step = big_step.induct[of "(WHILE b DO c, s)" "t"
  "\<lambda>(c,s1) s2. \<forall>b ca. c = WHILE b DO ca \<longrightarrow> ca \<sim> c' \<longrightarrow> (WHILE b DO c', s1) \<Rightarrow> s2", simplified,
    rule_format] for b c c' s t

(* We can now prove the lemma again with this new theorem *)
lemma  "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> c \<sim> c' \<Longrightarrow> (WHILE b DO c', s) \<Rightarrow> t"
  apply (erule unified_big_step)
  apply auto
  done

(* We now use Lemma 7.6 to prove the following *)
lemma while_equiv: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
  by (auto simp: while_equiv_aux)

(* Lemma 7.8 *)

lemma sim_refl: "c \<sim> c" by auto
lemma sim_sym: "c \<sim> c' \<Longrightarrow> c' \<sim> c" by auto
lemma sim_trans: "\<lbrakk> c \<sim> c'; c' \<sim> c'' \<rbrakk> \<Longrightarrow> c \<sim> c''" by auto

(* Lemma 7.9 IMP is deterministic can no longer be proved since it is not deterministic!*)

lemma or_comm: "c\<^sub>1 OR c\<^sub>2 \<sim> c\<^sub>2 OR c\<^sub>1"
  by blast

end


theory abstEvm
  imports Main
begin

(* Isabelle 2018 *)

section \<open>First EVM abstract semantics : yellow paper\<close>

subsection \<open>Common assumptions for the two abstract semantics\<close>
text \<open>
   This theory defines an asbtract version of the Ethereum Virtual Machine (EVM)
   The corresponding functions are:
      smallstep ::"call_stack \<Rightarrow> call_stack"  (for one step evaluation)
      execute :: "call_stack \<Rightarrow> frame"        (for complete evaluation)
   The main purpose of this theory is to show termination of the execute function.
  \<close>

text \<open>
  Here are the abstractions that are done w.r.t. EVM semantics:
  - We make no difference between different calls w.r.t. gas consumption
  - We make no difference between all "local" operations, they have an arbitrary cost greater than 0
  - We make no difference between all jump operations: Jump does not take any destination, the semantics
    applies this instruction by jumping to an arbitrary position in the program (encodes both JUMP and
    JUMPI)
  - The call stack size is bounded by a natural greater than 0 (called stack_lim)
  - The create is represented by a call on an undefined contract name. It creates the contract
    with an arbitrary program, and runs it.
  - We make no difference between return and revert
  - We make no difference between stop and suicide/selfdestruct
  \<close>

subsection \<open>Specific assumptions : yellow paper\<close>

text \<open>Assumptions coherent with the yellow paper:
  - A call consumes the gas **after** the return
  - Because of the above assumption, a contract recursively calling itself would
    never stop (it consumes no gas) if there was no call stack limit. This is why
    the termination proof highly depends on the call stack bound.
  - A successful call can result into a gas refund
  - When a call returns with a gas greater than the gas that was initially sent,
    we throw an exception.
  \<close>

subsection \<open>Main datatypes\<close>

(* Maximum call stack size *)
consts
 stack_lim::nat

axiomatization
  where min_stack_lim: "stack_lim>0"

type_synonym
  gas = nat

type_synonym
  pc= nat

type_synonym
  contractName= string

datatype
  instr = Nil  (* Undefined instruction *)
  | Local "gas" (* For each local operation we associate a gas cost *)
  (* The call operation has two gas values. The first one is the cost of the call instruction
     and the second one is the gas transferred to the called contract *)
  | Call "gas*gas*contractName"  (*g_base_mem(gas 1) = Cbase+Cmem on Yellow paper ; gcall(gas 2)= ccall *)
  | Stop (* Stop represent selfdestruct (suicide), stop, and return *)
  | Jump "gas" (* Jump has no destination, the destination will be arbitrarily given in the semantics *)

type_synonym program = "instr list"

definition "p1= [Local 10,Call (1,1,''c1''),(Jump (5))]"

value "nth p1 0"
value "nth p1 1"
value "nth p1 2"

(* The instruction associated to a pc in a given program *)
fun mynth :: "program \<Rightarrow> pc \<Rightarrow> instr" ("_.(_)")
  where
  "mynth p pc = (if pc < (length p ) then (nth p pc) else Stop)"

value "p1.(0)"
value "p1.(1)"
value "p1.(2)"
value "p1.(5)"

abbreviation "name_test \<equiv> (''hello''::contractName) "

type_synonym env= "contractName \<Rightarrow> program option"

(* Examples of environments  *)
definition "(e1::env)= (\<lambda>x. None)"                 (* The empty environement *)
definition "(e2::env)= e1 (''c1'':= Some [Nil])"   (* association between contract name "c1" and a [Nil] program *)
definition "(e3::env)= e2 (''c2'':= Some [Local 10,Stop])"
definition "(e4::env)= e3 (''c1'':= Some [Jump((5::gas))])"      (* we change the program associated to c1*)
definition "(e5::env) = e4 (name_test := Some [Stop])"

value "e4(''c1'')"
value "e4(''c2'')"
value "e4(''c3'')"   (* Contract ''c3'' is undefined *)
value "e4(name_test)"
value "e5(name_test)"

subsection \<open>Valid instructions, programs, environments, frames, stacks\<close>

(* This predicates represents valid instructions, i.e., instructions with a strictly positive cost! *)
fun valid_instr :: "instr \<Rightarrow> bool"
  where
  "valid_instr (Local n) = (n>0)"|
  "valid_instr (Stop) = True"|
  "valid_instr (Nil) = True"|
  "valid_instr (Call (g,gcall,name)) = ((g>0)\<and>(gcall>0))"|
  "valid_instr (Jump(n)) = (n>0)"

(* Remark: Nil is a valid instruction whose execution will result into an exception *)

(* A valid program is composed of valid instructions *)
fun valid_prog :: "program \<Rightarrow> bool"
  where
  "valid_prog  [] = True"|
  "valid_prog (i#p) = ((valid_instr i) \<and> (valid_prog p))"

(* A function returning an arbitrary valid program *)
consts
  any_valid_program:: "nat \<Rightarrow> program"

axiomatization
  where any_valid_is_valid: "\<forall> x. valid_prog (any_valid_program x)"

(* A valid environement maps contracts names to valid programs *)
fun valid_env :: "env \<Rightarrow> bool"
  where
"valid_env e= (\<forall> n.
  (case e(n) of
     None \<Rightarrow> True
   | (Some p) \<Rightarrow> valid_prog p))"

(* Datatype of frames (i.e. program evaluation states) *)
datatype
  frame =
    Ok "gas*pc*program*env"  (* Regular program state *)
    | Exception              (* Exceptional program final state *)
    | Halt "gas*env"         (* Regular program final state *)
    | Invalid_frame          (* Invalid_frame should never occur. Present only for totality of the small_step semantic function (on programs that are ill formed) *)

type_synonym
  call_stack = "frame list"

(* A call stack is a list of frames where the most recent frame is at the beginning of the list *)
(* We show in the soundness theorem below (see finalCorrection) that the execution of any valid call_stack (i.e. without Invalid_frames)
   results into another valid call_stack *)

fun depth_stack:: " call_stack \<Rightarrow> nat"
  where "depth_stack stack = (length  stack)"

(* The valid_stack_aux function only checks that a stack is composed of OK states *)
fun valid_stack_aux :: "call_stack \<Rightarrow> bool"
  where
    "valid_stack_aux [] = True"|
    "valid_stack_aux ((Ok (g,pc,p,e))#[]) = ((valid_env e) \<and> (valid_prog p ))"|
    "valid_stack_aux ((Ok (g,pc,p,e))#(Ok (g2,pc2,p2,env2))#l) =
       (case p2.(pc2) of
          Call(gcall,ccall,name) \<Rightarrow> (if ((gcall+ccall)>g2 | (gcall\<le>0) | (ccall\<le>0)) then False
                                     else ((valid_prog p) \<and> (valid_env e) \<and> (valid_stack_aux (Ok(g2,pc2,p2,env2)#l))))
        | _ \<Rightarrow> False)" |
    "valid_stack_aux l = False"

(* A stack is valid if it is a list of valid program states and after a Halt/Exception there can only
   be OK frames ... and the current called instruction in the state Ok should be
   a call with correct values.
   Besides, all environement should map names to valid programs (valid_env)!
 *)
fun valid_stack :: "call_stack \<Rightarrow> bool"
  where
  "valid_stack [] = False"|
  "valid_stack [Halt (g,e)] = (valid_env e)"|
  "valid_stack [Exception] = True"|
  "valid_stack [Invalid_frame] = False"|
  "valid_stack ((Ok (g,pc,p,e))#[]) = ((valid_env e) \<and> (valid_prog p ))"|
  "valid_stack ((Ok (g,pc,p,e))#(Ok (g2,pc2,p2,env2))#l) =
       (case p2.(pc2) of
          Call(gcall,ccall,name) \<Rightarrow> (if ((gcall+ccall)>g2 | (gcall\<le>0) | (ccall\<le>0)) then False
                                     else ((valid_prog p) \<and> (valid_env e) \<and> (valid_stack_aux (Ok(g2,pc2,p2,env2)#l))))
        | _ \<Rightarrow> False)" |
  "valid_stack ((Ok (g,pc,p,e))#_) = False" |
  "valid_stack ((Halt (g,e))#Ok(g2,pc,p,env2)#l) =
      (case p.(pc) of
          Call(gcall,ccall,name) \<Rightarrow> (if ((gcall+ccall)>g2 | (gcall\<le>0) | (ccall\<le>0)) then False
                                    else ((valid_env e) \<and> (valid_stack_aux (Ok(g2,pc,p,env2)#l))))
        | _ \<Rightarrow> False)" |
  "valid_stack ((Halt (g,e))#_) = False" |
  "valid_stack ((Exception)#Ok(g2,pc,p,env2)#l) = (case p.(pc) of
          Call(gcall,ccall,name) \<Rightarrow> (if ((gcall+ccall)>g2 | (gcall\<le>0) | (ccall\<le>0)) then False
                                    else (valid_stack_aux (Ok(g2,pc,p,env2)#l)))
        | _ \<Rightarrow> False)"|
  "valid_stack ((Exception)#_) = False"|
  "valid_stack (Invalid_frame#l) = False"

(* We associate gas for exception/Invalid frame for the termination measures *)
fun get_gas_frame :: "frame \<Rightarrow> nat"
  where
  "get_gas_frame Invalid_frame = 1"|
  "get_gas_frame Exception = 1"|
  "get_gas_frame (Halt (g,e)) = g+2"|
  "get_gas_frame (Ok (g,pc,p,e)) = g+3"

value "get_gas_frame Exception"
value "get_gas_frame Invalid_frame"

fun get_gas :: "call_stack \<Rightarrow> nat "
  where
  "get_gas [] = 0"|
  "get_gas (a#l) = (get_gas_frame a)+(get_gas l)"

subsection \<open>Measure definition\<close>

fun order :: "nat \<Rightarrow> call_stack \<Rightarrow> nat"
  where
  "order n [] = 0"|
  "order n (Exception#l) = (if (n>(length l)) then 0 else ((get_gas_frame (nth (rev (Exception#l)) n))))"|
  "order n (Invalid_frame#l) = (if (n>(length l)) then 0 else ((get_gas_frame (nth (rev (Invalid_frame#l)) n))))"|
  "order n ((Halt (g,e))#l) = (if (n>(length l)) then (g+3) else ((get_gas_frame (nth (rev ((Halt (g,e))#l)) n))))"|
  "order n ((Ok (g,pc,p,e))#l) = (if (n>(length l)) then (g+4) else ((get_gas_frame (nth (rev ((Ok (g,pc,p,e))#l)) n))))"

fun list_order_aux :: "nat \<Rightarrow> nat \<Rightarrow> (call_stack \<Rightarrow> nat) list"
  where
"list_order_aux 0 _ = []" |
"list_order_aux (Suc x) y= (order (y - (Suc x)))#(list_order_aux x y)"

(* This is the main termination measure function: given a maximal stack size i,
   it results into a list (of length i) of measure functions mapping call_stack to nat

   E.g., (list_order 3) is [(order 0),(order 1),(order 2)]
 *)
fun list_order :: "nat \<Rightarrow> (call_stack \<Rightarrow> nat) list"
  where
"list_order i = (list_order_aux i i)"

value "list_order 3"

(* Basic properties on list_order *)
lemma size_list_order_aux: "(length (list_order_aux i j)) = i"
  apply (induct i arbitrary:j)
   apply auto
  done

lemma size_list_order: "(length (list_order i)) = i"
  using size_list_order_aux apply auto
  done

lemma list_order_aux_nth:"(j\<ge>i \<and> k<i) \<longrightarrow> ((list_order_aux i j) ! k) = (order (j - i + k))"
  apply (induct i arbitrary:j k)
   apply auto
  using less_Suc_eq_0_disj by auto

lemma list_order_nth:"(i<j) \<longrightarrow> ((list_order j)! i) = (order i)"
  using list_order_aux_nth by auto

(* Recall that a call stack is a list of frames where the most recent frame is at the beginning of the list *)
value "order 0 [Ok (18,pc,p,e)]"
value "order 1 [Ok (18,pc,p,e)]"
(* After a call 10 given to contract c1, the stack become *)
value "order 0 [Ok (10,pc2,p2,e_2),Ok (18,pc,p,e)]"
(* After a call 5 given to contract c2, the stack becomes  *)
value "order 0 [Ok (5,pc3,p3,e_2),Ok (10,pc2,p2,e2),Ok (18,pc,p,e)]"
value "order 1 [Halt(2,e_4),Ok (10,pc2,p2,e2),Ok (18,pc,p,e)]" (* We assume that contract c2 ends with 2 gas *)
value "order 0 [Ok (7,pc2,p2,e_2),Ok (18,pc,p,e)]" (* We return from the contract c2*)
value "order 0 [Halt (7,e_2),Ok (18,pc,p,e)]"   (* Contract c1 ends with 7 gas *)
value "order 0 [Ok (12,pc,p,e)]"               (* We return from the contract c1 *)

value "order 3 [Exception, Ok (7,pc2,p2,e_2),Ok (18,pc,p,e)]"

value "order 0 [Exception]"
value "order 0 [Invalid_frame]"
value "order 1 [Ok (12,pc,p,e),Invalid_frame]"
value "order 1 [Invalid_frame]"
value "order 1 [Invalid_frame,Invalid_frame]"

(* Functions used to explain the measure *)
fun specialMap:: "('a \<Rightarrow> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b list"
  where
"specialMap [] _ = []" |
"specialMap (f#r) x = (f x)#(specialMap r x)"

fun demoMeasure:: "nat \<Rightarrow> call_stack \<Rightarrow> nat list"
  where
"demoMeasure max_stack_size c = specialMap (list_order max_stack_size) c"

(* How order is used?*)
(* We associate to each frame stack a list of natural numbers *)
(* For instance, by executing a call(...,10,...) we move from [Ok (18,pc,p,e)] to stack:
   [Ok (10,pc2,p2,e_2),Ok (18,pc,p,e)]

   For a stack, the measure becomes a list of natural numbers that are compared with lexicographic order

  e.g the above stacks are (in the correct order for lexicographic comparison):
  ||Ok 18|         and       ||Ok 18|Ok 10|  the measurement lists are of the form
  [18,19,19,19]    and       [18,10,11,11]     (where the numbers may be greater in the real measure functions (there are +2 and +3 in Justine's
                                                measure functions)

*)

value "demoMeasure 4 [Ok (18,pc,p,e)]"
value "demoMeasure 4 [Exception,Ok (18,pc,p,e)]"
value "demoMeasure 4 [Ok (18,pc,p,e)]"

value "demoMeasure 4 [Ok (10,pc2,p2,e_2),Ok (18,pc,p,e)]"
value "demoMeasure 4 [Ok (5,pc3,p3,e_2),Ok (10,pc2,p2,e2),Ok (18,pc,p,e)]"
value "demoMeasure 4 [Halt(2,e_4)]"
value "demoMeasure 4 [Exception]"

(* because the measure is a list of functions, [(order 0), (order 1), (order 2), (order 3)] and we have *)
value "order 0 [Ok (5,pc3,p3,e_2),Ok (10,pc2,p2,e2),Ok (18,pc,p,e)]"
value "order 1 [Ok (5,pc3,p3,e_2),Ok (10,pc2,p2,e2),Ok (18,pc,p,e)]"
value "order 2 [Ok (5,pc3,p3,e_2),Ok (10,pc2,p2,e2),Ok (18,pc,p,e)]"
value "order 3 [Ok (5,pc3,p3,e_2),Ok (10,pc2,p2,e2),Ok (18,pc,p,e)]"

value "demoMeasure 4 [Halt(2,e_4),Ok (10,pc2,p2,e2),Ok (18,pc,p,e)]"
value "demoMeasure 4 [Ok (7,pc2,p2,e_2),Ok (18,pc,p,e)]"
value "demoMeasure 4 [Ok (12,pc,p,e)]"

(*____________________________Some lemmas on order______________________________________ *)

lemma order_equal_frame : " n < length l \<longrightarrow> get_gas_frame (((rev l)@a) !  n ) = get_gas_frame ( (rev l)! n) "
  by (simp add: nth_append)

lemma order_equal_base : "  (n < length (i#l)) \<longrightarrow> get_gas_frame (((rev (i#l))@a) ! n) = order n (i#l)"
  apply (induct i)
  apply auto
  apply (simp add: nth_append)
  apply (metis length_rev less_Suc_eq nth_append nth_append_length)
  apply (metis length_rev less_Suc_eq nth_append nth_append_length)
  apply (simp add: nth_append)
  done

lemma order_equal : "n<(length l) \<longrightarrow> (order n (a#l)) = (order n l)"
  apply (cases "l=[]")
  apply simp
  apply (induct a)
  apply auto
  apply (metis get_gas.elims order_equal_base)
  apply (metis get_gas.elims order_equal_base)
  apply (metis get_gas.elims order_equal_base)
  apply (metis get_gas.elims order_equal_base)
  done

lemma order_rev : "(n<(length l)) \<longrightarrow> (order n l ) = (get_gas_frame (nth (rev l) n))"
  using less_Suc_eq order_equal order_equal_base order_equal_frame by auto

lemma order_rev_length : " (order (length l) (a#l)) = (get_gas_frame a)"
  by (metis length_Cons length_rev lessI nth_append_length order_rev rev.simps(2))

lemma trivial : "(~ i = [] ) \<longrightarrow> ((order 0 (a#i)) = (order 0 i)) "
  by (simp add: order_equal)

lemma min_callstack : " ~ ((i = [])\<or>(i=[Invalid_frame]))\<longrightarrow> (a = nth (rev i) 0 )\<longrightarrow> order 0 i > 0"
  apply (induct a)
  apply simp
     apply (simp add: order_rev)
  using frame.distinct(5) get_gas_frame.elims gr_zeroI numeral_3_eq_3 apply auto[1]
  apply simp
  using get_gas_frame.elims order_rev apply force
  apply simp
  using get_gas_frame.elims order_rev apply force
  apply simp
  by (simp add: order_rev)

lemma order_min_diff : "get_gas_frame a > get_gas_frame b \<longrightarrow> (order (length l) (a#l) ) > (order (length l) (b#l) )"
  apply (induct l)
  apply (simp add: order_rev)
  by (metis length_Cons length_rev lessI nth_append_length order_rev rev.simps(2))

lemma order_list_part1 : "(length l)< stack_lim \<longrightarrow> ( ((n<(length l)) \<longrightarrow> (order n (a#l)) = (order n (b#l))))"
  by (simp add: order_equal)

lemma order_list_part2 : "(length l)< stack_lim \<longrightarrow> get_gas_frame a > get_gas_frame b \<longrightarrow> (order (length l) (a#l) ) > (order (length l) (b#l))"
  by (simp add: order_min_diff)

value "order 0 [Halt (18,Map.empty)]"
value "order 0 [Exception]"

lemma list_order_rec1: "((f1 a) = (f1 b)) \<longrightarrow> (((a,b) \<in> (measures (f1#lf))) = ((a,b) \<in> (measures lf)))"
  apply simp
  done

lemma list_order_rec2: "(i<(length (lf::('a \<Rightarrow> nat)list)) \<and> (\<forall> j. (j<i \<longrightarrow> (((lf!j) a) = ((lf!j) b))) \<and> ((lf!i) a) < ((lf!i) b))) \<longrightarrow>
                            (\<forall> j. (j<i \<and> f=lf!j) \<longrightarrow> \<not> ((f a)>(f b)))"
  apply (induct lf arbitrary: f a b)
   apply auto
  done

lemma list_order_length: "(\<exists> i. lf=[] \<and> i<(length (f1#lf)) \<and> (((f1#lf)!i) a)<(((f1#lf)!i) b)) \<longrightarrow> ((a,b) \<in> (measures (f1#lf)))"
  apply auto
  done

lemma list_order_length2: "(\<exists> i. i>0 \<and> i<(length (f1#lf)) \<and> (\<forall> j. j<i \<longrightarrow> (((f1#lf)!j) a) = (((f1#lf)!j) b))) \<longrightarrow> (((a,b) \<in> (measures (f1#lf))) = ((a,b) \<in> (measures lf)) )"
  apply auto
  done

lemma list_order_seq: "(\<exists> i. i<(length lf) \<and> (\<forall> j. (j<i) \<longrightarrow> ((lf!j) a) = ((lf!j) b)) \<and> ((lf!i) a) < ((lf!i) b)) \<longrightarrow> ((a,b) \<in> (measures lf))"
  apply (case_tac "(\<exists> i. i<(length lf) \<and> (\<forall> j. (j<i) \<longrightarrow> ((lf!j) a) = ((lf!j) b)) \<and> ((lf!i) a) < ((lf!i) b))")
  apply auto
   apply (induct lf arbitrary: a b)
   apply simp
  apply (rename_tac f1 lf i a b)
  by (metis gr0_conv_Suc in_measures(2) length_Cons not_less_eq nth_Cons_0 nth_Cons_Suc nth_non_equal_first_eq)

lemma list_order_pos: "(a\<noteq>[] \<and> b\<noteq>[]) \<longrightarrow>(\<exists> i. i<stack_lim \<and> (\<forall> j. (j<i) \<longrightarrow> ((order j) a) = ((order j) b)) \<and> ((order i) a) < ((order i) b)) \<longrightarrow> ((a,b) \<in> (measures (list_order stack_lim)))"
  apply auto
  apply (case_tac "(\<exists> i. i<(length (list_order stack_lim)) \<and> (\<forall> j. (j<i) \<longrightarrow> (((list_order stack_lim)!j) a) = (((list_order stack_lim)!j) b)) \<and> (((list_order stack_lim)!i) a) < (((list_order stack_lim)!i) b))")
  apply (simp add: list_order_seq)
  apply (case_tac "length (list_order stack_lim) = stack_lim")
  defer
  using size_list_order apply blast
  apply (case_tac "j<i \<longrightarrow> ((list_order stack_lim ! j) a = (list_order stack_lim ! j) b)")
  defer
  using list_order_nth apply auto[1]
  apply (case_tac "((list_order stack_lim ! i) a < (list_order stack_lim ! i) b)")
  defer
  using list_order_nth apply auto[1]
  using list_order_nth by auto

lemma gas_order: "get_gas_frame a > get_gas_frame b \<longrightarrow> (order (length l) (a#l) ) > (order (length l) (b#l))"
  apply (induct l)
  apply auto
  apply (metis list.size(3) order_rev_length)
  by (metis length_Cons order_rev_length)

lemma list_order_aux:"((length l)< stack_lim \<and> (\<forall> j<(length l). (order j (a#l)) = (order j (b#l))) \<and>
                  (order (length l) (a#l) ) > (order (length l) (b#l)) \<and> lf= (list_order stack_lim)) \<longrightarrow>
          (\<exists> i. i=(length l) \<and> (\<forall> j. (j<i) \<longrightarrow> ((lf!j) (a#l)) = ((lf!j) (b#l))) \<and> ((lf!i) (a#l)) > ((lf!i) (b#l)))"
  apply simp
  apply (case_tac "(list_order_aux stack_lim stack_lim ! length l) = (order (length l))")
  apply (metis less_imp_le_nat less_le_trans list_order.simps list_order_nth)
  by (metis list_order.simps list_order_nth )

lemma list_order_seq2: "((length l)< stack_lim \<and> (\<forall> j<(length l). (order j (a#l)) = (order j (b#l))) \<and>
                  (order (length l) (a#l) ) > (order (length l) (b#l))) \<longrightarrow> ((b#l),(a#l))\<in> measures (list_order stack_lim)"
  apply (case_tac "(\<exists> i. i=(length l) \<and> (\<forall> j. (j<i) \<longrightarrow> (((list_order stack_lim)!j) (a#l)) = (((list_order stack_lim)!j) (b#l))) \<and> (((list_order stack_lim)!i) (a#l)) > (((list_order stack_lim)!i) (b#l)))")
  apply (metis list_order_seq size_list_order)
  using list_order_aux by auto

lemma order_list : " (length l)<( stack_lim ) \<longrightarrow> get_gas_frame a > get_gas_frame b \<longrightarrow> ((b#l),(a#l))\<in> measures (list_order stack_lim)"
  using list_order_seq2 order_list_part1 order_rev_length by auto

lemma impossible_case_aux : " length l > 1 \<longrightarrow> order 1 l > 0"
  using get_gas_frame.elims order_rev by force

lemma teste : " order 1 l = 0 \<longrightarrow> length l \<le> 1"
  using impossible_case_aux not_less by blast

lemma impossible_case :"order 1 l = 0 \<longrightarrow> (l = [Invalid_frame] \<or> l = [Exception] \<or> l = []) "
  apply (case_tac l)
  apply simp
  apply (case_tac list)
  prefer 2
  using impossible_case_aux apply auto[1]
  apply (case_tac a)
  apply auto
  done

lemma min_invalid_frame : "(length i\<le>stack_lim) \<longrightarrow> \<not>(i =[Invalid_frame] \<or> i = []\<or>(i=[Exception])) \<longrightarrow> ([Invalid_frame],i) \<in> measures (list_order stack_lim)"
  apply auto
  apply (case_tac i)
  apply simp
  apply (case_tac "(order 0 (a#list))>(order 0 [Invalid_frame])")
  apply (metis diff_self_eq_0 gr0_conv_Suc list_order_aux.simps(2) measures_less min_stack_lim)
  apply (case_tac "(order 0 (a#list)) =(order 0 [Invalid_frame])")
  apply (case_tac "(order 1 (a#list))>(order 1 [Invalid_frame])")
    apply (case_tac "stack_lim<1")
  using min_stack_lim apply linarith
  apply (metis (no_types, hide_lams) add_2_eq_Suc' add_cancel_right_left get_gas_frame.elims get_gas_frame.simps(1) le_eq_less_or_eq length_Cons length_greater_0_conv less_add_Suc2 less_one list_order.simps list_order_pos not_less numeral_3_eq_3 order_rev_length)
  using impossible_case apply auto[1]
  by (simp add: Suc_lessI min_callstack)

lemma min_exception : "(length i\<le>stack_lim) \<longrightarrow> \<not>(i =[Invalid_frame] \<or> i = []\<or>(i=[Exception])) \<longrightarrow> ([Exception],i) \<in> measures (list_order stack_lim)"
  apply auto
  apply (case_tac i)
  apply simp
  apply (case_tac "(order 0 (a#list))>(order 0 [Exception])")
  apply (metis diff_self_eq_0 gr0_conv_Suc list_order_aux.simps(2) measures_less min_stack_lim)
  apply (case_tac "(order 0 (a#list)) =(order 0 [Exception])")
   apply (case_tac "(order 1 (a#list))>(order 1 [Exception])")
    apply (case_tac "stack_lim<1")
  using min_stack_lim apply linarith
  apply (metis One_nat_def diff_Suc_1 get_gas_frame.simps(1) get_gas_frame.simps(2) in_measures(1) less_one list.distinct(1) list.size(3) list_order.simps list_order_aux.simps(1) list_order_aux.simps(2) list_order_pos list_order_rec1 min_invalid_frame not_less_iff_gr_or_eq order_rev_length)
  using impossible_case apply auto[1]
  by (simp add: Suc_lessI min_callstack)

(*_______________________Semantics______________________________________________________________*)

subsection \<open>Semantics\<close>

(* To model the jump destination we use a function returning an arbitrary natural *)
consts
  any_jump:: "nat \<Rightarrow> nat"

(* The small step function of EVM *)
fun smallstep ::"call_stack \<Rightarrow> call_stack"
  where
  "smallstep ((Ok (g,pc,p,e))#l) = (case p.(pc) of
                                  Stop \<Rightarrow> ((Halt (g,e))#l) |
                                  Nil  \<Rightarrow>  (Exception#l)|
                                  \<comment> \<open>Basic instruction : pc is increased and we consume the gas of the instuction (n)\<close>
                                  Local(n) \<Rightarrow>( if (n>0) then (
                                                        if (n\<le>g) then
                                                                     ((Ok ((g-n),pc+1,p,e))#l)
                                                                  else
                                                                    (Exception#l))
                                                       else ([Invalid_frame]) )|
                                 Jump(n) \<Rightarrow> if (n>0) then (let pj= any_jump 0 in
                                                           if (n\<le>g) then (if (pj<(length p)) then
                                                                                ((Ok (g-n,pj,p,e))#l)
                                                                                else
                                                                                (Exception#l))
                                                                     else (Exception#l) )
                                                        else ([Invalid_frame]) |
                                \<comment> \<open>Call instruction call: gas is not consumed (yet) and we stack a frame_stack\<close>
                                Call (gcall,ccall,name) \<Rightarrow> if ((gcall>0)\<and>(ccall>0)\<and>(((length l)+1)<stack_lim)\<and>((gcall+ccall)\<le>g)) then
                                                                            (case e(name) of
                                                                                None \<Rightarrow>
                                                                                \<comment> \<open>If the contract name is undefined then the contract is defined (i.e. create)
                                                                                we stack a new frame in which we run an arbitrary new program.
                                                                                In the environment, we associate the new name to this empty program (Some pnew). \<close>
                                                                                (let pnew=(any_valid_program 0) in ((Ok (ccall,0,pnew,e( name := (Some pnew) )))#(Ok (g,pc,p,e))#l))
                                                                            \<comment>\<open>Otherwise, we create a new frame where the current program becomes pcall \<close>
                                                                               | (Some pcall) \<Rightarrow>((Ok (ccall,0,pcall,e))#(Ok (g,pc,p,e))#l))
                                                            else ( if (((length l)\<ge>(stack_lim - 1))|((gcall+ccall)>g)) then  (Exception#l)
                                                                   else ([Invalid_frame]) )
                             )"|
  "smallstep ([Halt (g,e)]) = [Halt (g,e)] "|
  "smallstep ([Exception]) =[Exception] "|
                                                  \<comment> \<open>Call return with an exception\<close>
  "smallstep ( (Exception)#(Ok (g,pc,p,e))#l ) = (case p.(pc) of
                                                                              \<comment>\<open>if running the call was impossible initially then we produce an invalid_frame
                                                                                Only here for totality reasons (cannot happend)\<close>
                                                   Call(gcall,ccall,name) \<Rightarrow>  (if ((gcall+ccall)>g) | (gcall\<le>0)|(ccall\<le>0) then [Invalid_frame]
                                                                               \<comment> \<open>Normal call return with an exception: we consume the gas: gcall and ccall\<close>
                                                                               else  ((Ok ((g-gcall-ccall),(pc+1),p,e))#l))
                                                  | _ \<Rightarrow> [Invalid_frame] )"|
                                               \<comment> \<open>Standard call return with a regular Halt event\<close>
 "smallstep ((Halt (gend,ef))#(Ok (g,pc,p,e))#l) = (case p.(pc) of
                                                  Call(gcall,ccall,name) \<Rightarrow>  if ((gcall+ccall)>g) then [Invalid_frame]
                                                                             else if (gcall\<le>0) then [Invalid_frame]
                                                                             else if (ccall\<le>0) then [Invalid_frame]
                                                                             \<comment> \<open>This is coherent with the yellow paper: a call return is valid iff the returned gas is
                                                                                lesser or equal to the gas sent for the call. Otherwise we throw an exception\<close>
                                                                             else if (ccall<gend) then (Exception#(Ok (g,pc,p,e))#l)
                                                                              \<comment>\<open>The resulting (modified) environment ef is passed to the current OK top stack_frame\<close>
                                                                             else  ((Ok ((g+gend-gcall-ccall),(pc+1),p,ef))#l)|
                                                  _ \<Rightarrow> [Invalid_frame] )"|
  "smallstep l = [Invalid_frame]"

subsection \<open>Validity proof\<close>

lemma validMember: "(valid_prog p) \<longrightarrow> (List.member p i) \<longrightarrow> (valid_instr i)"
  apply (induct p)
   apply auto
  apply (simp add: member_rec(2))
  by (simp add: member_rec(1))

lemma validInstr: "(valid_prog p) \<longrightarrow> (pc < (length p)) \<longrightarrow> (valid_instr (p ! pc))"
  by (meson in_set_member nth_mem validMember)

lemma notValidStackExceptionException: "\<not> (valid_stack (e#(Exception#l)))"
  apply (case_tac e)
     apply auto
  done

lemma valid_stack_aux: "valid_stack_aux (e#l) \<longrightarrow> (valid_stack_aux l)"
  apply (induct "(e#l)" rule:valid_stack_aux.induct)
  apply auto
  apply (case_tac "p2!pc2")
      apply auto
  apply (smt instr.simps(24) instr.simps(27))
  apply (smt instr.simps(25) instr.simps(27))
  apply (smt instr.simps(26) instr.simps(27) old.prod.case)
  apply (smt instr.simps(27))
  by (smt instr.simps(27) instr.simps(28))

lemma invalid_invalid: "\<not> (valid_stack (Invalid_frame#l))"
  apply (induct l)
   apply auto
  done

lemma validstack_Ok_prog: "(valid_stack (Ok(g,pc,p,e)#l)) \<longrightarrow> (valid_prog p)"
  apply (case_tac l)
   apply auto
  apply (case_tac a)
  apply (case_tac x1)
  apply (rename_tac g2 pc2 p2 e2)
  apply auto[1]
  apply (case_tac "p2!pc2")
  apply (smt instr.simps(24) instr.simps(27))
  apply (smt instr.simps(25) instr.simps(27))
  apply (case_tac "x3")
  apply (rename_tac gcall2 ccall2 name2)
  apply auto[1]
  apply (smt case_prod_conv instr.simps(26) instr.simps(27) valid_env.elims(2))
  apply (smt instr.simps(27))
  apply (smt instr.simps(27) instr.simps(28))
  apply simp
  apply simp
  by simp

lemma validstack_Ok_env: "(valid_stack (Ok(g,pc,p,e)#l)) \<longrightarrow> (valid_env e)"
  apply (case_tac l)
  apply auto
  apply (case_tac a)
  apply (case_tac x1)
  apply (rename_tac g2 pc2 p2 e2)
  apply auto[1]
  apply (case_tac "p2!pc2")
  apply (smt instr.simps(24) instr.simps(27))
  apply (smt instr.simps(25) instr.simps(27))
  apply (case_tac "x3")
  apply (rename_tac gcall2 ccall2 name2)
  apply auto[1]
  apply (smt case_prod_conv instr.simps(26) instr.simps(27) valid_env.elims(2))
  apply (smt instr.simps(27))
  apply (smt instr.simps(27) instr.simps(28))
  apply simp
  apply simp
  by auto

lemma validstack_Ok_aux: "(valid_stack (Ok(g,pc,p,e)#l)) \<longrightarrow> (valid_stack_aux (Ok(g,pc,p,e)#l))"
  apply (case_tac l)
  apply auto
  apply (case_tac a)
  apply auto
  done

lemma validstack_Ok_aux2: "(valid_stack_aux (Ok(g,pc,p,e)#l)) \<longrightarrow> (valid_stack (Ok(g,pc,p,e)#l))"
  apply (case_tac l)
  apply auto
  apply (case_tac a)
  apply auto
  done

lemma validstack_Ok: "(valid_stack (Ok(g,pc,p,e)#l)) \<longrightarrow> (valid_stack (Ok(g2,pc2,p,e)#l))"
  apply (case_tac l)
  apply auto
  apply (case_tac a)
  apply auto
  done

lemma validstack_Ok2: "(valid_env env2) \<longrightarrow> (valid_stack (Ok(g,pc,p,e)#l)) \<longrightarrow> (valid_stack (Ok(g,pc,p,env2)#l))"
  apply (case_tac l)
  apply auto
  apply (case_tac "\<not>(valid_stack_aux (a#list))")
  using valid_stack_aux validstack_Ok_aux apply blast
  apply (case_tac a)
  apply simp
  apply (case_tac x1)
  apply (rename_tac y g2 pc2 p2 env3)
  apply simp
  apply (case_tac "p2!pc2")
  apply auto[1]
  apply (smt instr.simps(24) instr.simps(27))
  using instr.simps(27) apply fastforce
  apply auto[1]
  apply (meson gr_zeroI)
  apply (meson neq0_conv)
  using instr.simps(27) apply fastforce
  using instr.simps(27) apply fastforce
  using instr.simps(27) apply fastforce
  apply simp
  apply simp
  apply simp
  done

lemma validstack_exception_step: "(valid_stack (e#l)) \<longrightarrow> (valid_stack (Exception#l))"
  apply (case_tac e)
  apply auto
  apply (case_tac l)
  apply auto
  apply (case_tac ac)
  apply (case_tac x1)
  apply auto
  apply (case_tac "c ! baa ")
  apply auto
  apply (meson neq0_conv)
  apply (meson neq0_conv)
  using instr.simps(27) apply fastforce
  apply (case_tac l)
  apply auto
  apply (case_tac aa)
  apply auto
  apply (case_tac "ad ! ac ")
  apply auto
  apply (meson neq0_conv)
  apply (meson neq0_conv)
  using instr.simps(27) apply fastforce
  by (simp add: invalid_invalid)

lemma validstack_halt_step: "(valid_env env2) \<longrightarrow> (valid_stack (Ok(g,pc,p,e)#l)) \<longrightarrow> (valid_stack (Halt(g2,env2)#l))"
   apply auto
   apply (case_tac l)
   apply auto
   (* by case on the frame below *)
   apply (case_tac a)
   apply (case_tac x1)
   apply auto
   apply (case_tac "c ! ba ")
   apply auto
   apply (meson neq0_conv)
   apply (meson neq0_conv)
  using instr.simps(27) by fastforce

lemma validstack_exception_top: "valid_stack (Exception # l) \<longrightarrow> valid_stack (smallstep (Exception # l))"
  apply (case_tac l)
  apply simp
  apply simp
  apply (case_tac a)
  apply simp
  apply (case_tac x1)
  (* (1) Ok on top *)
     apply (rename_tac y g pc p e)
     apply (case_tac "p.(pc)")
     apply auto[1]
        apply (simp add: validstack_exception_step)
        (* call case *)
         apply (case_tac x3)
         apply (rename_tac z gcall ccall name)
         apply (case_tac "(gcall>0)\<and>(ccall>0)\<and>(((length list)+1)<stack_lim)\<and>((gcall+ccall)\<le>g)")
         apply auto[1]
         using validstack_Ok validstack_Ok_aux2 apply blast
         apply auto[1]
         using validstack_Ok validstack_Ok_aux2 apply blast
   apply auto
done

lemma validstack_halt_top: "valid_stack ((Halt x) # l) \<longrightarrow> valid_stack (smallstep ((Halt x) # l))"
  apply (case_tac l)
   apply auto
  apply (metis frame.distinct(11) frame.distinct(7) get_gas_frame.elims smallstep.simps(2) valid_stack_aux.simps(5) validstack_Ok_aux)
  apply (case_tac a)
  apply simp
  apply (case_tac x1)
  apply simp
  (* (1) Ok on top *)
     apply (rename_tac y g pc p e)
     apply (case_tac "p.(pc)")
     apply auto[1]
     using validstack_exception_step
     apply force
     using validstack_exception_step apply force
        (* call case *)
         apply (case_tac x3)
         apply (rename_tac z gcall ccall name)
            (* by case on the return value of Halt *)
         apply (case_tac x)
         apply (rename_tac gend ef)
         apply (case_tac "(gcall>0)\<and>(ccall>0)\<and>(((length list)+1)<stack_lim)\<and>((gcall+ccall)\<le>g)\<and>(gend\<le>gcall)")
         apply simp
         apply (case_tac "\<not> (valid_stack (Ok (g, pc, p, e) # list))")
         apply auto [1]
         apply (simp add: validstack_Ok_aux2)
         apply (simp add: validstack_Ok_aux2)
           apply auto[1]
           apply (case_tac list)
            apply auto[1]
         (* We first show that the sublist is necessarily valid *)
         apply (case_tac "\<not> (valid_stack_aux list)")
     using valid_stack_aux apply blast
         (* We then show that the new environement ef is valid *)
           apply (case_tac "\<not> (valid_env ef)")
     apply simp
      apply (case_tac "\<not> (valid_stack (Ok (g + gend - (gcall + ccall), Suc pc, p, e) # list))")
     using validstack_Ok validstack_Ok_aux2 apply blast
     using validstack_Ok2 apply blast
     apply auto[1]
     apply (meson neq0_conv)
     apply (meson neq0_conv)
     apply (meson valid_env.elims(3) validstack_Ok validstack_Ok2 validstack_Ok_aux2)
     apply (meson not_gr0)
     apply (meson neq0_conv)
     apply (meson valid_env.elims(3) validstack_Ok validstack_Ok2 validstack_Ok_aux2)
     apply (case_tac x)
     apply auto[1]
     apply (case_tac x)
     apply auto[1]
     apply auto
     apply (simp add: notValidStackExceptionException)
     using valid_stack.simps(16) validstack_exception_step apply blast
     using valid_stack.simps(17) validstack_exception_step by blast

(* If a stack is valid then we can replace the program of the top frame by any valid program *)
lemma validstack_any_valid_prog: "(valid_stack (Ok(g,pc,p,e)#l) \<and> (valid_prog p2)) \<longrightarrow> (valid_stack (Ok (g, i, p2, e(name := (Some p2))) #l))"
  apply (induct l arbitrary: g pc p e p2 rule: valid_stack.induct )
  apply auto
  apply (case_tac "p!pc")
  apply auto
  apply (meson neq0_conv)
  apply (meson neq0_conv)
  apply (case_tac "p!pc")
  apply auto
  apply (meson neq0_conv)
  apply (meson neq0_conv)
  apply (meson neq0_conv)
  apply (meson not_gr0)
     apply (case_tac "a=0")
      apply auto
  apply (case_tac "p!pc")
  apply auto
  apply (meson neq0_conv)
  apply (meson neq0_conv)
    apply (case_tac "a=0")
     apply auto
   apply (case_tac "p!pc")
       apply auto
  apply (meson neq0_conv)
  apply (meson neq0_conv)
  apply (meson valid_stack_aux.simps(11))
  apply (case_tac "p!pc")
  apply auto
  apply (meson neq0_conv)
  apply (meson neq0_conv)
    apply (case_tac "a=0")
     apply auto
  done

subsubsection \<open>Main Validity Theorem for one step of semantics\<close>

lemma validstack_smallstep: "(valid_stack l)\<longrightarrow> (valid_stack (smallstep l))"
  apply (case_tac l)
  apply simp
  apply simp
  apply (case_tac a)
  apply simp
  apply (case_tac x1)
  (* (1) Ok on top *)
     apply (rename_tac y g pc p e)
     apply (case_tac "p.(pc)")
         apply auto[1]
         apply (simp add: validstack_exception_step)
         (* Local case *)
         apply (rename_tac n)
         apply (case_tac "n>0 \<and> n\<le>g")
         apply auto[1]
         using validstack_Ok apply blast
         apply (case_tac "n\<le>0")
         apply auto[1]
         apply (case_tac "list=[]")
         apply auto[1]
         apply (metis instr.distinct(11) less_numeral_extra(3) validInstr valid_instr.simps(1))
         apply (case_tac "valid_prog p")
         apply (metis instr.distinct(11) less_numeral_extra(3) validInstr valid_instr.simps(1))
         using validstack_Ok_prog apply blast
         apply (simp add: validstack_exception_step)
         (* Call case *)
         apply (case_tac x3)
         apply (rename_tac z gcall ccall name)
         apply (case_tac "(gcall>0)\<and>(ccall>0)\<and>(((length list)+1)<stack_lim)\<and>((gcall+ccall)\<le>g)")
         apply auto[1]
         apply (case_tac "e(name)")
         apply auto[1]
         using validstack_Ok_env apply auto[1]
         apply (case_tac "\<not>(valid_env e)")
         apply auto[1]
         apply auto[1]
         (* This is the case where call mimic a create.
            We first prove that adding a frame where the program is empty is valid and then we use the lemma validstack_any_valid_prog
            stating that this program can be replaced by any (arbitrary) valid program *)
         apply (case_tac "valid_stack ((Ok (ccall, 0, [], e(name := Some []))) # Ok (g, pc, p, e) # list)")
         apply (meson any_valid_is_valid validstack_Ok2 validstack_Ok_env validstack_any_valid_prog)
         apply auto[1]
         apply (metis (full_types) option.simps(5) valid_prog.simps(1))
         using validstack_Ok_aux apply auto[1]
         apply auto[1]
         apply (metis option.simps(5) valid_env.elims(2) validstack_Ok_env)
         using validstack_Ok_env apply auto[1]
         using validstack_Ok_aux apply blast
         apply auto[1]
         using validstack_exception_step apply blast
         using validstack_exception_step apply blast
         using validstack_exception_step apply blast
         apply (simp add: validstack_exception_step)
         apply (metis instr.distinct(15) less_numeral_extra(3) validInstr valid_instr.simps(4) validstack_Ok_prog)
         using validstack_exception_step apply blast
         using validstack_exception_step apply blast
         apply (metis instr.distinct(15) less_numeral_extra(3) validInstr valid_instr.simps(4) validstack_Ok_prog)
         using validstack_exception_step apply blast
         apply (simp add: validstack_exception_step)
         apply auto[1]
         using validstack_Ok_env validstack_halt_step apply blast
         (* Jump case *)
         apply (case_tac x5)
         apply simp
         apply (metis instr.distinct(19) less_numeral_extra(3) validInstr valid_instr.simps(5) validstack_Ok_prog)
         apply (smt instr.case(5) smallstep.simps(1) validstack_Ok validstack_exception_step zero_less_Suc)
         (* (2) Exception on top *)
         apply (simp add: validstack_exception_top)
         (* (3) Halt on top *)
         apply (simp add: validstack_halt_top)
         (* (4) Invalid frame on top *)
         by (simp add: invalid_invalid)

subsection \<open>Semantics : complete execution\<close>

function (sequential)  execute :: "call_stack \<Rightarrow> frame"
  where
  "execute ([]) = Invalid_frame"|
  "execute ([Halt (g,e)]) = (Halt (g,e))"|
  "execute ([Exception]) = (Exception)"|
  "execute ([Invalid_frame]) = Invalid_frame"|
  "execute l = (if (length l > stack_lim) then Invalid_frame else execute (smallstep l)) "
  apply pat_completeness
  apply auto
  done

(* --------------------- Examples of runs of the execute function --------------------------------*)

(* See the examples below, after the proofs *)

(*________________________________Termination proof________________________________________________*)

subsection \<open>Termination proof\<close>

(* _________________________ Some technical lemmas __________________________________________________*)

subsubsection \<open>Some technical lemmas\<close>

lemma ok_nil : "instr.Nil = mynth p pc \<longrightarrow> n = length l \<longrightarrow> (order n ((Ok (g,pc,p,e))#l))> (order n (smallstep ((Ok (g,pc,p,e))#l)))"
  by (metis (no_types, lifting) Suc_1 add_Suc_right get_gas_frame.simps(2) get_gas_frame.simps(4) instr.simps(24) le_imp_less_Suc less_add_Suc2 less_imp_le_nat numeral_3_eq_3 numerals(2) order_rev_length smallstep.simps(1))

lemma ok_local_caseinf : "x \<le> 0 \<longrightarrow> Local x = mynth p pc \<longrightarrow> n = length l \<longrightarrow> smallstep (Ok (g, pc, p, e) # l) = [Invalid_frame]"
  by (smt instr.simps(25) le_zero_eq less_numeral_extra(3) smallstep.simps(1))

lemma ok_local_casesup : " \<not> x \<le> 0 \<longrightarrow>
    \<not> g < x \<longrightarrow> Local x = mynth  p pc  \<longrightarrow>  (smallstep (Ok (g, pc, p, e) # l)) = ((Ok (g-x,pc+1,p,e))#l) "
  by (smt instr.simps(25) leI smallstep.simps(1))

lemma ok_local_casesup_2 : "\<not> x \<le> 0 \<longrightarrow>
    \<not> g < x \<longrightarrow>  Local x = mynth  p pc  \<longrightarrow> get_gas_frame (((Ok (g,pc,p,e))#l) ! 0) > get_gas_frame ((smallstep ( (Ok (g,pc,p,e))#l)) ! 0 )"
  using ok_local_casesup by auto

lemma ok_local : "Local x = mynth p pc \<longrightarrow> n = length l \<longrightarrow> (order n ((Ok (g,pc,p,e))#l))> (order n (smallstep ((Ok (g,pc,p,e))#l)))"
  apply (case_tac "x\<le>0")
  apply (metis (no_types, lifting) One_nat_def Suc_less_eq get_gas_frame.simps(1) get_gas_frame.simps(4) length_greater_0_conv lessI less_add_Suc2 less_trans list.size(3) numeral_3_eq_3 ok_local_caseinf order.simps(3) order_rev_length)
  apply (case_tac "x>g")
  apply (smt Suc_1 add_Suc_right get_gas_frame.simps(2) get_gas_frame.simps(4) instr.simps(25) le_less_trans lessI less_add_Suc2 less_or_eq_imp_le not_le numeral_3_eq_3 numerals(2) order_rev_length smallstep.simps(1))
  by (metis (no_types) nth_Cons_0 ok_local_casesup ok_local_casesup_2 order_min_diff)

lemma ok_jump_aux : " (n>0) \<longrightarrow> (n\<le>g)\<longrightarrow> Jump(n) = mynth p pc \<longrightarrow> ((\<exists> pj. (pj<(length p)) \<longrightarrow> (smallstep ((Ok (g,pc,p,e))#l)) = ((Ok (g-n,pj,p,e))#l)) \<or> ((smallstep ((Ok (g,pc,p,e))#l)) = Exception#l))"
  by blast

lemma ok_jump_case1 : " (n>0) \<longrightarrow> (n\<le>g)\<longrightarrow>(pj<(length p))\<longrightarrow> Jump(n) = mynth p pc \<longrightarrow> (len = length l) \<longrightarrow> (order len (smallstep ((Ok (g,pc,p,e))#l))) < (order len ((Ok (g,pc,p,e))#l))"
  apply (case_tac "(\<exists> pj. (pj<(length p)) \<longrightarrow> (smallstep ((Ok (g,pc,p,e))#l)) = ((Ok (g-n,pj,p,e))#l))")
  apply (smt One_nat_def add_mono_thms_linordered_field(1) get_gas_frame.simps(2) get_gas_frame.simps(4) instr.case(5) le_add_diff_inverse less_Suc_eq less_add_same_cancel2 not_add_less2 not_less_eq numeral_3_eq_3 order_rev_length smallstep.simps(1))
  by blast

lemma ok_jump_subcase : " n> 0 \<longrightarrow> Jump (n) = mynth p pc \<longrightarrow> len = length l \<longrightarrow> (order len (smallstep ((Ok (g,pc,p,e))#l))) < (order len ((Ok (g,pc,p,e))#l))"
  apply (case_tac "n\<le>g")
  apply (case_tac "pj < (length p) ")
  using ok_jump_case1 apply blast
  apply (metis instr.distinct(19) mynth.simps ok_jump_case1)
  by (smt One_nat_def get_gas_frame.simps(2) get_gas_frame.simps(4) instr.case(5) less_Suc_eq not_add_less2 not_less_eq numeral_3_eq_3 order_rev_length smallstep.simps(1))

lemma ok_jump_case_1_2 : " n> 0 \<longrightarrow> Jump (n) = mynth p pc \<longrightarrow> len = length l\<longrightarrow> len < stack_lim \<longrightarrow>  ((smallstep ((Ok (g,pc,p,e))#l)),((Ok (g,pc,p,e))#l)) \<in> measures (list_order stack_lim)"
  by (smt One_nat_def get_gas_frame.simps(2) get_gas_frame.simps(4) instr.simps(28) less_Suc_eq linorder_neqE_nat not_add_less2 numeral_3_eq_3 ok_jump_case1 old.prod.case order_list order_rev_length smallstep.simps(1))

lemma ok_jump : "n>0 \<longrightarrow> Jump (n) = mynth p pc \<longrightarrow> length l < stack_lim \<longrightarrow> ((smallstep ((Ok (g,pc,p,e))#l)),((Ok (g,pc,p,e))#l)) \<in> measures (list_order stack_lim)"
  apply (subst smallstep.simps)
  using ok_jump_case_1_2 by auto

lemma ok_stop_aux : " Stop = mynth p pc \<longrightarrow> ((smallstep ((Ok (g,pc,p,e))#l)) =(( Halt (g,e)) # l))"
  apply auto
  done

lemma ok_stop : " Stop = mynth p pc \<longrightarrow> len = length l \<longrightarrow> (order len (smallstep ((Ok (g,pc,p,e))#l)))<(order len ( (Ok (g,pc,p,e))#l))"
  using get_gas_frame.simps(3) get_gas_frame.simps(4) ok_stop_aux order_rev_length by presburger

lemma modularityOrder1: "(length l < stack_lim) \<longrightarrow> ((order (length l) (a#l)) < (order (length l) (b#l))) \<longrightarrow> ((a#l,b#l)\<in> measures (list_order stack_lim))"
  apply (induct l)
   apply auto
  apply (metis list.size(3) list_order.simps order_list order_rev_length)
  apply (metis length_Cons order_rev_length)
  by (metis length_Cons list_order.simps order_list order_rev_length)

lemma exceptionOrder: "(length l < stack_lim) \<longrightarrow> (Exception#l,Ok(g,pc,p,e)#l) \<in> measures (list_order stack_lim)"
  by (metis One_nat_def Suc_lessI add_gr_0 get_gas_frame.simps(2) get_gas_frame.simps(4) less_add_Suc2 less_antisym not_numeral_less_one numeral_eq_one_iff order_list semiring_norm(86) zero_less_numeral)

lemma ok_call_order: "(length (Ok (g,pc,p,e)#l) < stack_lim) \<longrightarrow> g2<g \<longrightarrow> (Ok(g2,pc2,p2,env2)#(Ok (g,pc,p,e)#l),Ok (g,pc,p,e)#l)\<in> measures (list_order stack_lim)"
  apply (case_tac "(order ((length l)+1) (Ok(g2,pc2,p2,env2)#(Ok (g,pc,p,e)#l)))<(order ((length l)+ 1) (Ok (g,pc,p,e)#l))")
  apply (metis (no_types, lifting) One_nat_def list.distinct(1) list.size(4) list_order_pos order_equal)
  by (smt One_nat_def add_Suc add_Suc_right add_less_mono get_gas_frame.simps(4) length_Cons lessI list.size(4) nat_1_add_1 numeral_2_eq_2 numeral_3_eq_3 numeral_Bit0 order.simps(5) order_rev_length)

lemma ok_call_possibilities: "(Call (gcall,ccall,name) = mynth p pc  \<and> (res = (smallstep (((Ok(g,pc,p,e)))#l)))) \<longrightarrow>
      (res=[Invalid_frame]\<or> res= Exception#l \<or> (\<exists> g2 pc2 p2 e2. (length (Ok(g,pc,p,e)#l)) < stack_lim \<and> res= (Ok(g2,pc2,p2,e2)#(Ok (g,pc,p,e)#l)) \<and> g2<g))"
  apply (case_tac "p!pc")
  apply simp
  apply simp
    apply (case_tac "\<not>(x3=(gcall, ccall, name))")
     apply auto[1]
    apply simp
    apply (case_tac "(gcall>0)\<and>(ccall>0)\<and>(((length (Ok(g,pc,p,e)#l))<stack_lim))\<and>((gcall+ccall)\<le>g)")
  apply (case_tac "e(name)")
      apply auto
  by (metis (no_types, hide_lams) add.commute less_add_same_cancel1 less_le_trans)

lemma ok_call : "(length l < stack_lim) \<longrightarrow>  Call (gcall,ccall,name) = mynth p pc  \<longrightarrow> ((smallstep (((Ok(g,pc,p,e)))#l)),((Ok (g,pc,p,e))#l)) \<in> measures (list_order stack_lim) "
  (* Eval of call, case 1: [Invalid_frame] *)
  apply (case_tac "(smallstep (((Ok(g,pc,p,e)))#l)) = [Invalid_frame]")
  using min_invalid_frame apply auto[1]
  (* Eval of call, case 2: Exception *)
  apply (case_tac "(smallstep (((Ok(g,pc,p,e)))#l)) =  Exception#l")
  using exceptionOrder apply auto[1]
  apply (case_tac "(\<exists> g2 pc2 p2 e2. ((length (Ok(g,pc,p,e)#l)) < stack_lim) \<and> (smallstep (((Ok(g,pc,p,e)))#l)) = (Ok(g2,pc2,p2,e2)#(Ok (g,pc,p,e)#l)) \<and> g2<g)")
  using ok_call_order
  apply fastforce
  using ok_call_possibilities apply blast
  done

subsubsection \<open>Case 1 : Exception\<close>
(*_________________________________Case 1 : Exception _____________________________________________*)

lemma case1_subcaseOK_Nil : "instr.Nil = mynth p pc \<longrightarrow> (smallstep (Exception # Ok (g, pc, p, e) # vb) = [Invalid_frame])"
  by simp

lemma case1_subcaseOk_Local : " Local x = mynth p pc \<longrightarrow> (smallstep (Exception # Ok (g, pc, p, e) # vb)) = [Invalid_frame]"
  by (smt instr.simps(25) smallstep.simps(4))

lemma case1_subcaseOK_call1 : "Call (gcall,ccall,name)  = mynth  p pc \<longrightarrow>((gcall+ccall)>g)|(gcall\<le>0)|(ccall\<le>0)\<longrightarrow> (smallstep (Exception # Ok (g, pc, p, e) # vb)) = [Invalid_frame] "
  apply (case_tac "(gcall+ccall)>g")
  apply (smt instr.simps(26) old.prod.case smallstep.simps(4))
  apply (case_tac "gcall\<le>0")
  apply (smt case_prod_conv instr.simps(26) smallstep.simps(4))
  apply (case_tac "ccall\<le>0")
  apply (smt case_prod_conv instr.simps(26) smallstep.simps(4))
  by blast

lemma case1_smallstep_OK: "(res= (smallstep (Exception # (Ok (g,pc,p,e))# vb))) \<longrightarrow> (res=[Invalid_frame] \<or> (\<exists> g2 pc2. res= Ok(g2,pc2,p,e)#vb \<and> g2<g))"
  apply (case_tac "p!pc")
  apply simp
  apply simp
  apply (case_tac x3)
  apply (rename_tac x gcall ccall name)
  apply (case_tac "gcall+ccall>g \<or> gcall\<le>0 \<or> ccall\<le>0")
  apply auto
  done

lemma case1 : " \<not> stack_lim < length (Exception # v # vb) \<longrightarrow> (smallstep (Exception # v # vb), Exception # v # vb) \<in> measures (list_order stack_lim)"
  apply (case_tac v)
  (* For Exception + Ok, first case, we continue on Ok *)
  apply (case_tac x1)
  apply (rename_tac y g pc p e)
  apply (case_tac "(\<exists> g2 pc2. (smallstep (Exception # (Ok (g,pc,p,e))# vb)= Ok(g2,pc2,p,e)#vb) \<and> g>g2)")
  apply (rename_tac y mg mpc mp me)
  apply (smt add_mono_thms_linordered_field(1) get_gas_frame.simps(4) length_Cons less_Suc_eq linorder_neqE_nat list.simps(3) list_order_pos order_equal order_rev_length)
  apply (metis case1_smallstep_OK leI list.inject list.simps(3) min_invalid_frame)
  using min_invalid_frame apply auto[1]
  using min_invalid_frame apply auto[1]
  using min_invalid_frame by auto

subsubsection \<open>Case 2 of termination proof\<close>

(*___________________case 2 ______________________________________________________________________*)

lemma case2_okTop: "((smallstep (Ok(g,pc,p,e) # va)) = res) \<longrightarrow>(
          (res= [Invalid_frame] \<or> res= (Halt (g,e)#va) \<or> (res= (Exception#va))
            \<or> (\<exists> g2 pc2. res= (Ok(g2,pc2,p,e)#va) \<and> g2<g)) \<or> \<comment>\<open>Local inst case or jump\<close>
                (\<exists> g2 pc2 p2 e2. res= (Ok(g2,pc2,p2,e2)#Ok(g,pc,p,e)#va) \<and> g2<g) \<comment>\<open>Call case env may be augmented if contract call does not exist\<close>
              )"
  apply (case_tac "p!pc")
  apply simp
  apply simp
  apply auto[1]
  apply (case_tac x3)
  apply (case_tac "e c")
     apply auto[1]
  apply (metis (no_types, lifting) leI less_add_same_cancel2 less_le_trans)
  apply (metis mynth.simps ok_call_possibilities ok_stop_aux)
  apply simp
  apply (case_tac x5)
   apply auto[1]
  by (smt instr.case(5) le_add_diff_inverse less_add_same_cancel2 mynth.simps ok_stop_aux smallstep.simps(1))

lemma case2 : "\<not> stack_lim < length ((Ok (g,pc,p,e))  # va)\<longrightarrow> (smallstep ((Ok (g,pc,p,e)) # va), (Ok (g,pc,p,e)) # va) \<in> measures (list_order stack_lim)"
  apply (case_tac "(\<exists> g2 pc2 p2 e2. (smallstep (Ok(g,pc,p,e) # va)) = (Ok(g2,pc2,p2,e2)#Ok(g,pc,p,e)#va) \<and> g2<g)")
  apply (case_tac "p!pc") (* Proof by case on the instruction at position pc in p *)
  apply (metis (no_types, lifting) length_Cons lessI mynth.elims nat_neq_iff ok_nil ok_stop_aux order_equal)
  apply (metis length_Cons lessI less_irrefl_nat mynth.elims ok_local ok_stop_aux order_equal)
  apply (case_tac x3)
  apply (metis antisym_conv3 length_Cons lessI mynth.simps ok_call ok_call_order ok_stop_aux)
  apply (metis antisym_conv3 length_Cons lessI mynth.simps ok_call_order ok_stop_aux)
  apply (case_tac x5)
  apply (smt instr.case(5) list.inject list.simps(3) mynth.simps not_Cons_self2 ok_stop_aux old.prod.case smallstep.simps(1))
  apply (case_tac "(smallstep (Ok(g,pc,p,e) # va)) = [Invalid_frame]")
  using min_invalid_frame apply auto[1]
  apply (case_tac "(smallstep (Ok(g,pc,p,e) # va)) = (Exception#va)")
  apply (metis Suc_lessI add_gr_0 get_gas_frame.simps(2) get_gas_frame.simps(4) le_imp_less_Suc length_Cons nat_1_add_1 not_add_less2 not_less numeral_2_eq_2 numeral_3_eq_3 order_list zero_less_numeral)
  apply (case_tac "(smallstep (Ok(g,pc,p,e) # va)) = (Halt (g,e)#va)")
  apply (metis add_less_cancel_left get_gas_frame.simps(3) get_gas_frame.simps(4) leI le_imp_less_Suc length_Cons lessI numeral_2_eq_2 numeral_3_eq_3 order_list)
  apply (case_tac "(\<exists> g2 pc2. (smallstep (Ok(g,pc,p,e) # va)) = (Ok(g2,pc2,p,e)#va) \<and> g2<g)")
  apply (metis (no_types, lifting) add_lessD1 add_mono_thms_linordered_field(1) antisym_conv3 get_gas_frame.simps(4) length_Cons lessI list.size(4) order_list)
   apply (metis length_Cons mynth.simps not_less_eq ok_jump ok_stop_aux zero_less_Suc)
  apply (case_tac "((smallstep (Ok(g,pc,p,e) # va)) = [Invalid_frame])\<or> ((smallstep (Ok(g,pc,p,e) # va)) = (Exception#va)) \<or> ((smallstep (Ok(g,pc,p,e) # va)) = (Halt (g,e)#va)) \<or> (\<exists> g2 pc2. (smallstep (Ok(g,pc,p,e) # va)) = (Ok(g2,pc2,p,e)#va) \<and> g2<g)")
  using min_invalid_frame order_list apply auto[1]
  using case2_okTop by blast

subsubsection \<open>Case 3 of termination proof\<close>

(*__________________case 3_________________________________________________________________________*)

lemma case3 : "\<not> stack_lim < length (Invalid_frame # v # vb) \<longrightarrow> (smallstep (Invalid_frame # v # vb), Invalid_frame # v # vb) \<in> measures (list_order stack_lim)"
  using min_invalid_frame by auto

subsubsection \<open>Case 4 of termination proof\<close>

(*___________________case 4________________________________________________________________________*)

(* When halting correctly, we end up on a stack with an Ok with good property, or we end up with an Invalid_frame *)
lemma case4_haltTop: "((smallstep (Halt x # ((Ok(g,pc,p,e) # vc)))) = res) \<longrightarrow> (res= [Invalid_frame] \<or> (res= Exception # (Ok(g,pc,p,e) # vc)) \<or> (\<exists> g2 e2. res= (Ok(g2,pc+1,p,e2)#vc) \<and> g2<g))"
  apply (case_tac x)
  apply (case_tac "p!pc")  (* Proof by case on the instruction at position pc in p *)
  apply auto [1]
  apply auto [1]
  (* Call case *)
  apply (case_tac x3)
  apply (rename_tac y gcall ccall name)
  apply (case_tac x)
  apply (rename_tac gend ef)
  apply simp
  apply (case_tac "gcall+ccall>g")
  apply auto [1]
  apply (case_tac "gcall\<le>0")
  apply auto [1]
  apply (case_tac "ccall\<le>0")
  apply auto [1]
  apply (case_tac "ccall\<le>gend")
  apply auto [1]
  apply auto[1]
  apply auto
  done

lemma case4_subcaseHalt : "\<not> stack_lim < length (Halt x # vb # vc) \<longrightarrow> (smallstep (Halt x # vb # vc), Halt x # vb # vc) \<in> measures (list_order stack_lim)"
  apply (case_tac vb)
  (* vb=Ok*)
  apply (case_tac x1)
  apply (rename_tac y g pc p e)
  apply (case_tac "smallstep (Halt x # vb # vc) = [Invalid_frame]")
  using min_invalid_frame apply auto[1]
  apply (case_tac "smallstep (Halt x # vb # vc) = Exception # vb # vc")
  apply (metis One_nat_def frame.distinct(11) frame.distinct(3) frame.distinct(7) get_gas_frame.elims get_gas_frame.simps(2) length_Cons not_add_less2 not_less_eq numerals(2) order_list)
  apply (case_tac "\<not>(\<exists> g2 e2. smallstep (Halt x # vb # vc) = (Ok(g2,pc+1,p,e2)#vc) \<and> g2<g)")
  using case4_haltTop apply blast
  apply auto[1]
  apply (smt add_mono_thms_linordered_field(1) get_gas_frame.simps(4) length_Cons less_Suc_eq linorder_neqE_nat list.distinct(1) list_order.simps list_order_pos order_equal order_rev_length)
  using min_invalid_frame apply auto[1]
  using min_invalid_frame apply auto[1]
  using min_invalid_frame by auto

lemma case4: "\<not> stack_lim < length (v # vb # vc) \<longrightarrow> (smallstep (v # vb # vc), v # vb # vc) \<in> measures (list_order stack_lim)"
  apply (case_tac v)
  apply (metis (no_types, lifting) case2 case4_subcaseHalt frame.distinct(1) frame.distinct(5) get_gas_frame.elims)
  using case1 apply blast
  using case4_subcaseHalt apply blast
  using case3 by blast

subsubsection \<open>The main termination theorem\<close>

(* --------------------------- The termination theorem ---------------------------------------------*)

termination execute
  apply (relation "measures (list_order stack_lim)")
  apply simp
  using case2 apply force
  using case1 apply blast
  using case3 apply blast
  using case4 by blast

(* --------------------------- The soundness theorem ---------------------------------------------*)
lemma finalLength : "(length l\<le> stack_lim) \<longrightarrow> (length (smallstep l)\<le> stack_lim)"
  apply (induct l rule:smallstep.induct)
              apply auto
  apply (case_tac "p!pc")
  apply auto
  apply (case_tac "e b")
  apply auto
  apply (metis Suc_leI length_Cons)
  apply (smt length_Cons)
  apply (case_tac "p!pc")
  apply auto
  apply (case_tac "p!pc")
  apply auto
  by (simp add: Suc_le_eq min_stack_lim)

lemma finalSoundnessTheorem: "(valid_stack l \<and> (length l \<le> stack_lim)) \<longrightarrow> (valid_stack [(execute l)])"
  apply (induct l rule:execute.induct)
  apply simp
  apply simp
  apply simp
  apply simp
  apply simp
  using finalLength validstack_smallstep apply auto[1]
  apply (simp add: finalLength validstack_exception_top)
  apply simp
  by (simp add: finalLength validstack_smallstep)

(* For running test cases only... we define a default value for stack_lim *)
(* ----------------------------------- Examples --------------------------------------- *)

(* (testSem i s) performs at most i steps of EVM semantincs on a call_stack s *)
fun testSem:: "nat \<Rightarrow> call_stack \<Rightarrow> call_stack"
  where
"testSem 0 fs = fs" |
"testSem (Suc x) fs = (testSem x (smallstep fs))"

(* An example environement for a test execution of the semantics *)
definition "(exenv1::env)= (\<lambda>x. None)"       (* l'env vide *)
definition "(exenv2::env)= exenv1 (''c1'':= Some [(Call(1,10,''c2'')),Stop])"  (* useless for the test *)
definition "(exenv3::env)= exenv2 (''c2'':= Some [(Call(1,5,''c3'')),Stop])"
definition "(exenv4::env)= exenv3 (''c3'':= Some [Local(3),Stop])"

value "exenv4(''c1'')"
value "exenv4(''c2'')"
value "exenv4(''c3'')"

(* An example stack for running the test *)
definition "exstack= [Ok(18,0,[(Call(1,10,''c2'')),Stop],exenv4)]"

axiomatization
  (* A maximal call stack size defined for tests *)
  where stack_lim[code]: "stack_lim=4"
  (* The function returning an arbitrary program (CREATE) for test only *)
  and any_valid_program[code]: "any_valid_program x= [Stop]"
  (* The function returning an arbitrary jump destination for test only *)
  and any_jump[code]: "any_jump x = 0"

value "testSem 0 exstack"
value "testSem 0 exstack"
value "testSem 1 exstack"
value "testSem 2 exstack"
value "testSem 3 exstack"
value "testSem 4 exstack"
value "testSem 5 exstack"
value "testSem 6 exstack"
value "testSem 7 exstack"
value "testSem 8 exstack"
value "testSem 9 exstack"

definition "invalidStack= [Exception,Ok(18,0,[],exenv4),Exception]"
value "(testSem 1 invalidStack)"
value "(testSem 2 invalidStack)"

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Signed Words"

theory Signed_Words
  imports "HOL-Library.Word"
begin

text \<open>Signed words as separate (isomorphic) word length class. Useful for tagging words in C.\<close>

typedef ('a::len0) signed = "UNIV :: 'a set" ..

lemma card_signed [simp]: "CARD (('a::len0) signed) = CARD('a)"
  unfolding type_definition.card [OF type_definition_signed]
  by simp

instantiation signed :: (len0) len0
begin

definition
  len_signed [simp]: "len_of (x::'a::len0 signed itself) = LENGTH('a)"

instance ..

end

instance signed :: (len) len
  by (intro_classes, simp)

lemma scast_scast_id [simp]:
  "scast (scast x :: ('a::len) signed word) = (x :: 'a word)"
  "scast (scast y :: ('a::len) word) = (y :: 'a signed word)"
  by (auto simp: is_up scast_up_scast_id)

lemma ucast_scast_id [simp]:
  "ucast (scast (x :: 'a::len signed word) :: 'a word) = x"
  by transfer (simp add: take_bit_signed_take_bit)

lemma scast_of_nat [simp]:
  "scast (of_nat x :: 'a::len signed word) = (of_nat x :: 'a word)"
  by transfer (simp add: take_bit_signed_take_bit)

lemma scast_ucast_id [simp]:
  "scast (ucast (x :: 'a::len word) :: 'a signed word) = x"
  by transfer (simp add: take_bit_signed_take_bit)

lemma scast_eq_scast_id [simp]:
  "((scast (a :: 'a::len signed word) :: 'a word) = scast b) = (a = b)"
  by (metis ucast_scast_id)

lemma ucast_eq_ucast_id [simp]:
  "((ucast (a :: 'a::len word) :: 'a signed word) = ucast b) = (a = b)"
  by (metis scast_ucast_id)

lemma scast_ucast_norm [simp]:
  "(ucast (a :: 'a::len word) = (b :: 'a signed word)) = (a = scast b)"
  "((b :: 'a signed word) = ucast (a :: 'a::len word)) = (a = scast b)"
  by (metis scast_ucast_id ucast_scast_id)+

lemma scast_2_power [simp]: "scast ((2 :: 'a::len signed word) ^ x) = ((2 :: 'a word) ^ x)"
  by (rule bit_word_eqI) (auto simp add: bit_simps)

lemma ucast_nat_def':
  "of_nat (unat x) = (ucast :: 'a :: len word \<Rightarrow> ('b :: len) signed word) x"
  by (fact of_nat_unat)

lemma zero_sle_ucast_up:
  "\<not> is_down (ucast :: 'a word \<Rightarrow> 'b signed word) \<Longrightarrow>
          (0 <=s ((ucast (b::('a::len) word)) :: ('b::len) signed word))"
  by transfer (simp add: bit_simps)

lemma word_le_ucast_sless:
  "\<lbrakk> x \<le> y; y \<noteq> -1; LENGTH('a) < LENGTH('b) \<rbrakk> \<Longrightarrow>
    (ucast x :: ('b :: len) signed word) <s ucast (y + 1)"
  for x y :: \<open>'a::len word\<close>
  apply (cases \<open>LENGTH('b)\<close>)
  apply simp_all
  apply transfer
  apply (simp add: signed_take_bit_take_bit)
  apply (metis add.commute mask_eq_exp_minus_1 take_bit_incr_eq zle_add1_eq_le)
  done

lemma zero_sle_ucast:
  "(0 <=s ((ucast (b::('a::len) word)) :: ('a::len) signed word))
                = (uint b < 2 ^ (LENGTH('a) - 1))"
  apply transfer
  apply (cases \<open>LENGTH('a)\<close>)
   apply (simp_all add: take_bit_Suc_from_most bit_simps)
  apply (simp_all add: bit_simps disjunctive_add)
  done

lemma nth_w2p_scast:
  "(bit (scast ((2::'a::len signed word) ^ n) :: 'a word) m)
         \<longleftrightarrow> (bit (((2::'a::len  word) ^ n) :: 'a word) m)"
  by (simp add: bit_simps)

lemma scast_nop1 [simp]:
  "((scast ((of_int x)::('a::len) word))::'a signed word) = of_int x"
  by transfer (simp add: take_bit_signed_take_bit)

lemma scast_nop2 [simp]:
  "((scast ((of_int x)::('a::len) signed word))::'a word) = of_int x"
  by transfer (simp add: take_bit_signed_take_bit)

lemmas scast_nop = scast_nop1 scast_nop2 scast_id

type_synonym 'a sword = "'a signed word"

end


section \<open>Implementation of Prim's Algorithm\<close>
theory Prim_Impl
imports
  Prim_Abstract
  Undirected_Graph_Impl
  "HOL-Library.While_Combinator"
  "Priority_Search_Trees.PST_RBT"
  "HOL-Data_Structures.RBT_Map"
begin

subsection \<open>Implementation using ADT Interfaces\label{sec:prim_data_structs}\<close>

locale Prim_Impl_Adts =
  G: adt_wgraph G_\<alpha>w G_\<alpha>g G_invar G_adj G_empty G_add_edge
+ M: Map M_empty M_update M_delete M_lookup M_invar
(*+ S: Set S_empty S_insert S_delete S_isin S_\<alpha> S_invar*)
+ Q: PrioMap Q_empty Q_update Q_delete Q_invar Q_lookup Q_is_empty Q_getmin

  for typG :: "'g itself" and typM :: "'m itself" and typQ :: "'q itself"
  and G_\<alpha>w and G_\<alpha>g :: "'g \<Rightarrow> ('v) ugraph" and G_invar G_adj G_empty G_add_edge

  and M_empty M_update M_delete and M_lookup :: "'m \<Rightarrow> 'v \<Rightarrow> 'v option" and M_invar

  and Q_empty Q_update Q_delete Q_invar and Q_lookup :: "'q \<Rightarrow> 'v \<Rightarrow> nat option"
  and Q_is_empty Q_getmin

begin

text \<open>Simplifier setup\<close>
lemmas [simp] = G.wgraph_specs
lemmas [simp] = M.map_specs
lemmas [simp] = Q.prio_map_specs

end

locale Prim_Impl_Defs = Prim_Impl_Adts
  where typG = typG and typM = typM and typQ = typQ and G_\<alpha>w = G_\<alpha>w and G_\<alpha>g = G_\<alpha>g
  for typG :: "'g itself" and typM :: "'m itself" and typQ :: "'q itself"
  and G_\<alpha>w and G_\<alpha>g :: "'g \<Rightarrow> ('v::linorder) ugraph" and g :: 'g and r :: 'v
begin

subsubsection \<open>Concrete Algorithm\<close>
term M_lookup
definition "foreach_impl_body u \<equiv> (\<lambda>(v,d) (Qi,\<pi>i).
  if v=r then (Qi,\<pi>i)
  else
    case (Q_lookup Qi v, M_lookup \<pi>i v) of
      (None,None) \<Rightarrow> (Q_update v d Qi, M_update v u \<pi>i)
    | (Some d',_) \<Rightarrow> (if d<d' then (Q_update v d Qi, M_update v u \<pi>i) else (Qi,\<pi>i))
    | (None, Some _) \<Rightarrow> (Qi,\<pi>i)
  )"

definition foreach_impl :: "'q \<Rightarrow> 'm \<Rightarrow> 'v \<Rightarrow> ('v\<times>nat) list \<Rightarrow> 'q \<times> 'm" where
  "foreach_impl Qi \<pi>i u adjs = foldr (foreach_impl_body u) adjs (Qi,\<pi>i)"

definition "outer_loop_impl Qi \<pi>i \<equiv> while (\<lambda>(Qi,\<pi>i). \<not>Q_is_empty Qi) (\<lambda>(Qi,\<pi>i).
  let
    (u,_) = Q_getmin Qi;
    adjs = G_adj g u;
    (Qi,\<pi>i) = foreach_impl Qi \<pi>i u adjs;
    Qi = Q_delete u Qi
  in (Qi,\<pi>i)) (Qi,\<pi>i)"

definition "prim_impl = (let
  Qi = Q_update r 0 Q_empty;
  \<pi>i = M_empty;
  (Qi,\<pi>i) = outer_loop_impl Qi \<pi>i
  in \<pi>i)
"

text \<open>The whole algorithm as one function\<close>
lemma prim_impl_alt: "prim_impl = (let
  \<comment> \<open>Initialization\<close>
  (Q,\<pi>) = (Q_update r 0 Q_empty, M_empty);
  \<comment> \<open>Main loop: Iterate until PQ is empty\<close>
  (Q, \<pi>) =
  while (\<lambda>(Q, \<pi>). \<not> Q_is_empty Q) (\<lambda>(Q, \<pi>). let
    (u, _) = Q_getmin Q;
    \<comment> \<open>Inner loop: Update for adjacent nodes\<close>
    (Q, \<pi>) =
    foldr ((\<lambda>(v, d) (Q, \<pi>). let
        qv = Q_lookup Q v;
        \<pi>v = M_lookup \<pi> v
      in
        if v\<noteq>r \<and> (qv\<noteq>None \<or> \<pi>v=None) \<and> enat d < enat_of_option qv
        then (Q_update v d Q, M_update v u \<pi>)
        else (Q, \<pi>))
    ) (G_adj g u) (Q, \<pi>);
    Q = Q_delete u Q
    in (Q, \<pi>)) (Q, \<pi>)
  in \<pi>
)"
proof -

  have 1: "foreach_impl_body u = (\<lambda>(v,d) (Qi,\<pi>i). let
        qiv = (Q_lookup Qi v);
        \<pi>iv = M_lookup \<pi>i v
      in
        if v\<noteq>r \<and> (qiv\<noteq>None \<or> \<pi>iv=None) \<and> enat d < enat_of_option qiv
        then (Q_update v d Qi, M_update v u \<pi>i)
        else (Qi, \<pi>i))" for u
    unfolding foreach_impl_body_def
    apply (intro ext)
    by (auto split: option.split)

  show ?thesis
    unfolding prim_impl_def outer_loop_impl_def foreach_impl_def 1
    by (simp)
qed

subsubsection \<open>Abstraction of Result\<close>

text \<open>Invariant for the result, and its interpretation as (minimum spanning) tree:
  \<^item> The map \<open>\<pi>i\<close> and set \<open>Vi\<close> satisfy their implementation invariants
  \<^item> The \<open>\<pi>i\<close> encodes irreflexive edges consistent with the nodes determined
    by \<open>Vi\<close>. Note that the edges in \<open>\<pi>i\<close> will not be symmetric, thus we take
    their symmetric closure \<open>E\<union>E\<inverse>\<close>.

\<close>

definition "invar_MST \<pi>i \<equiv> M_invar \<pi>i"

definition "\<alpha>_MST \<pi>i \<equiv> graph {r} {(u,v) | u v. M_lookup \<pi>i u = Some v}"

end

subsection \<open>Refinement of State\<close>

locale Prim_Impl = Prim_Impl_Defs
  where typG = typG and typM = typM and typQ = typQ and G_\<alpha>w = G_\<alpha>w and G_\<alpha>g = G_\<alpha>g
  for typG :: "'g itself" and typM :: "'m itself" and typQ :: "'q itself"
  and G_\<alpha>w and G_\<alpha>g :: "'g \<Rightarrow> ('v::linorder) ugraph"
  +
  assumes G_invar[simp]: "G_invar g"
begin

sublocale Prim2 "G_\<alpha>w g" "G_\<alpha>g g" r .

subsubsection \<open>Abstraction of \<open>Q\<close>\<close>
text \<open>The priority map implements a function of type @{typ \<open>'v\<Rightarrow>enat\<close>},
  mapping @{const None} to @{term \<infinity>}.
\<close>

definition "Q_\<alpha> Qi \<equiv> enat_of_option o Q_lookup Qi :: 'v \<Rightarrow> enat"

lemma Q_\<alpha>_empty: "Q_\<alpha> Q_empty = (\<lambda>_. \<infinity>)"
  unfolding Q_\<alpha>_def by (auto)

lemma Q_\<alpha>_update: "Q_invar Q \<Longrightarrow> Q_\<alpha> (Q_update u d Q) = (Q_\<alpha> Q)(u := enat d)"
  unfolding Q_\<alpha>_def by (auto)

lemma Q_\<alpha>_is_empty: "Q_invar Q \<Longrightarrow> Q_lookup Q = Map.empty \<longleftrightarrow> Q_\<alpha> Q = (\<lambda>_. \<infinity>)"
  unfolding Q_\<alpha>_def by (auto simp: fun_eq_iff)

lemma Q_\<alpha>_delete: "Q_invar Q \<Longrightarrow> Q_\<alpha> (Q_delete u Q) = (Q_\<alpha> Q)(u:=\<infinity>)"
  unfolding Q_\<alpha>_def by (auto simp: fun_eq_iff)

lemma Q_\<alpha>_min:
  assumes MIN: "Q_getmin Qi = (u, d)"
  assumes I: "Q_invar Qi"
  assumes NE: "\<not> Q_is_empty Qi"
  shows "Q_\<alpha> Qi u = enat d" (is ?G1) and
        "\<forall>v. enat d \<le> Q_\<alpha> Qi v" (is ?G2)
proof -
  from Q.map_getmin[OF MIN]
    have "Q_lookup Qi u = Some d" "(\<forall>x\<in>ran (Q_lookup Qi). d \<le> x)"
    using NE I by auto
  thus "?G1" "?G2"
    unfolding Q_\<alpha>_def apply simp_all
    by (metis enat_of_option.elims enat_ord_simps(1) enat_ord_simps(3) ranI)
qed

lemmas Q_\<alpha>_specs = Q_\<alpha>_empty Q_\<alpha>_update Q_\<alpha>_is_empty Q_\<alpha>_delete

subsubsection \<open>Concrete Invariant\<close>

text \<open>The implementation invariants of the concrete state's components,
  and the abstract invariant of the state's abstraction\<close>
definition "prim_invar_impl Qi \<pi>i \<equiv>
    Q_invar Qi \<and> M_invar \<pi>i \<and> prim_invar2 (Q_\<alpha> Qi) (M_lookup \<pi>i)"

end

subsection \<open>Refinement of Algorithm\<close>

context Prim_Impl
begin

lemma foreach_impl_correct:
  fixes Qi Vi \<pi>i defines "Q \<equiv> Q_\<alpha> Qi" and "\<pi> \<equiv> M_lookup \<pi>i"
  assumes A: "foreach_impl Qi \<pi>i u (G_adj g u) = (Qi',\<pi>i')"
  assumes I: "prim_invar_impl Qi \<pi>i"
  shows "Q_invar Qi'" and "M_invar \<pi>i'"
    and "Q_\<alpha> Qi' = Qinter Q \<pi> u" and "M_lookup \<pi>i' = \<pi>' Q \<pi> u"
proof -
  from I have [simp]: "Q_invar Qi" "M_invar \<pi>i"
    unfolding prim_invar_impl_def Q_def \<pi>_def by auto

  {
    fix Qi \<pi>i d v and adjs :: "('v \<times> nat) list"
    assume "Q_invar Qi" "M_invar \<pi>i" "(v, d) \<in> set adjs"
    then have
      "(case foreach_impl_body u (v, d) (Qi, \<pi>i) of
         (Qi, \<pi>i) \<Rightarrow> Q_invar Qi \<and> M_invar \<pi>i)
              \<and> map_prod Q_\<alpha> M_lookup (foreach_impl_body u (v, d) (Qi, \<pi>i))
                = foreach_body u (v, d) (Q_\<alpha> Qi, M_lookup \<pi>i)"
      unfolding foreach_impl_body_def foreach_body_def
      unfolding Q_\<alpha>_def
      by (auto simp: fun_eq_iff split: option.split)

  } note aux=this

  from foldr_refine[
    where I="\<lambda>(Qi,\<pi>i). Q_invar Qi \<and> M_invar \<pi>i" and \<alpha>="map_prod Q_\<alpha> M_lookup",
    of "(Qi,\<pi>i)" "(G_adj g u)" "foreach_impl_body u" "foreach_body u"
    ]
  and A aux[where ?adjs3="(G_adj g u)"]
    have "Q_invar Qi'" "M_invar \<pi>i'"
      and 1: "foreach u (G_adj g u) (Q_\<alpha> Qi, M_lookup \<pi>i)
              = (Q_\<alpha> Qi', M_lookup \<pi>i')"
    unfolding foreach_impl_def foreach_def
    unfolding Q_def \<pi>_def
    by (auto split: prod.splits)
  then show "Q_invar Qi'" "M_invar \<pi>i'" by auto

  from 1 foreach_refine[where adjs="G_adj g u" and u=u] show
    "Q_\<alpha> Qi' = Qinter Q \<pi> u" and "M_lookup \<pi>i' = \<pi>' Q \<pi> u"
    by (auto simp: Q_def \<pi>_def)

qed

(*<*)
lemma foreach_impl_correct_presentation:
  fixes Qi Vi \<pi>i defines "Q \<equiv> Q_\<alpha> Qi" and "\<pi> \<equiv> M_lookup \<pi>i"
  assumes A: "foreach_impl Qi \<pi>i u (G_adj g u) = (Qi',\<pi>i')"
  assumes I: "prim_invar_impl Qi \<pi>i"
  shows "Q_invar Qi' \<and> M_invar \<pi>i'
        \<and> Q_\<alpha> Qi' = Qinter Q \<pi> u \<and> M_lookup \<pi>i' = \<pi>' Q \<pi> u"
  using foreach_impl_correct assms by blast
(*>*)

definition "T_measure_impl \<equiv> \<lambda>(Qi,\<pi>i). T_measure2 (Q_\<alpha> Qi) (M_lookup \<pi>i)"

lemma prim_invar_impl_init: "prim_invar_impl (Q_update r 0 Q_empty) M_empty"
  using invar2_init
  by (auto simp: prim_invar_impl_def Q_\<alpha>_specs initQ_def init\<pi>_def zero_enat_def)

lemma maintain_prim_invar_impl:
  assumes
      I: "prim_invar_impl Qi \<pi>i" and
      NE: "\<not> Q_is_empty Qi" and
      MIN: "Q_getmin Qi = (u, d)" and
      FOREACH: "foreach_impl Qi \<pi>i u (G_adj g u) = (Qi', \<pi>i')"
  shows "prim_invar_impl (Q_delete u Qi') \<pi>i'" (is ?G1)
     and "T_measure_impl (Q_delete u Qi', \<pi>i') < T_measure_impl (Qi,\<pi>i)" (is "?G2")
proof -
  note II[simp] = I[unfolded prim_invar_impl_def]
  note FI[simp] = foreach_impl_correct[OF FOREACH I]
  note MIN' = Q_\<alpha>_min[OF MIN _ NE, simplified]

  show ?G1
    unfolding prim_invar_impl_def
    using Q_\<alpha>_delete maintain_invar2[OF _ MIN']
    by (simp add: Q'_def)

  show ?G2
    unfolding prim_invar_impl_def T_measure_impl_def
    using Q_\<alpha>_delete maintain_invar2[OF _ MIN']
    apply (simp add: Q'_def Q_\<alpha>_def)
    by (metis FI(3) II Q'_def Q_\<alpha>_def
        \<open>\<And>\<pi>. prim_invar2 (Q_\<alpha> Qi) \<pi>
            \<Longrightarrow> T_measure2 (Q' (Q_\<alpha> Qi) \<pi> u) (\<pi>' (Q_\<alpha> Qi) \<pi> u)
                < T_measure2 (Q_\<alpha> Qi) \<pi>\<close>)

qed

lemma maintain_prim_invar_impl_presentation:
  assumes
      I: "prim_invar_impl Qi \<pi>i" and
      NE: "\<not> Q_is_empty Qi" and
      MIN: "Q_getmin Qi = (u, d)" and
      FOREACH: "foreach_impl Qi \<pi>i u (G_adj g u) = (Qi', \<pi>i')"
  shows "prim_invar_impl (Q_delete u Qi') \<pi>i'
       \<and> T_measure_impl (Q_delete u Qi', \<pi>i') < T_measure_impl (Qi,\<pi>i)"
  using maintain_prim_invar_impl assms by blast

lemma prim_invar_impl_finish:
  "\<lbrakk>Q_is_empty Q; prim_invar_impl Q \<pi>\<rbrakk>
    \<Longrightarrow> invar_MST \<pi> \<and> is_MST (G_\<alpha>w g) rg (\<alpha>_MST \<pi>)"
  using invar2_finish
  by (auto simp: Q_\<alpha>_specs prim_invar_impl_def invar_MST_def \<alpha>_MST_def Let_def)

lemma prim_impl_correct:
  assumes "prim_impl = \<pi>i"
  shows
    "invar_MST \<pi>i" (is ?G1)
    "is_MST (G_\<alpha>w g) (component_of (G_\<alpha>g g) r) (\<alpha>_MST \<pi>i)" (is ?G2)
proof -
  have "let (Qi, \<pi>i) = outer_loop_impl (Q_update r 0 Q_empty) M_empty in
    invar_MST \<pi>i \<and> is_MST (G_\<alpha>w g) rg (\<alpha>_MST \<pi>i)"
    unfolding outer_loop_impl_def
    apply (rule while_rule[where
      P="\<lambda>(Qi,\<pi>i). prim_invar_impl Qi \<pi>i" and r="measure T_measure_impl"])
    apply (all \<open>clarsimp split: prod.splits simp: Q_\<alpha>_specs\<close>)
    apply (simp_all add: prim_invar_impl_init maintain_prim_invar_impl
                         prim_invar_impl_finish)
    done
  with assms show ?G1 ?G2
    unfolding rg_def prim_impl_def by (simp_all split: prod.splits)
qed

(*<*)
lemma prim_impl_correct_presentation:
  "invar_MST prim_impl
  \<and> is_MST (G_\<alpha>w g) (component_of (G_\<alpha>g g) r) (\<alpha>_MST prim_impl)"
  using prim_impl_correct by blast
(*>*)

end

subsection \<open>Instantiation with Actual Data Structures\label{sec:prim_inst_ds}\<close>

global_interpretation
  G: wgraph_by_map RBT_Set.empty RBT_Map.update RBT_Map.delete
        Lookup2.lookup RBT_Map.M.invar
  defines G_empty = G.empty
      and G_add_edge = G.add_edge
      and G_add_edge1 = G.add_edge1
      and G_adj = G.adj
      and G_from_list = G.from_list
      and G_valid_wgraph_repr = G.valid_wgraph_repr
  by unfold_locales

(* FIXME: Something is strange with generated constants. *)
lemma G_from_list_unfold:  "G_from_list = G.from_list"
  by (simp add: G_add_edge_def G_empty_def G_from_list_def)

(* FIXME: The interpretation does not generate a code theorem at all!? *)

global_interpretation P: Prim_Impl_Defs G.invar G.adj G.empty G.add_edge
  RBT_Set.empty RBT_Map.update RBT_Map.delete Lookup2.lookup RBT_Map.M.invar

  PST_RBT.empty PST_RBT.update PST_RBT.delete PST_RBT.PM.invar
  Lookup2.lookup PST_RBT.rbt_is_empty pst_getmin

  _ _ _ G.\<alpha>w G.\<alpha>g g r
  for g and r::"'a::linorder"
  defines prim_impl = P.prim_impl
      and outer_loop_impl = P.outer_loop_impl
      and foreach_impl = P.foreach_impl
      and foreach_impl_body = P.foreach_impl_body
  by unfold_locales

lemmas [code] = P.prim_impl_alt

context
  fixes g
  assumes [simp]: "G.invar g"
begin

interpretation AUX: Prim_Impl
  G.invar G.adj G.empty G.add_edge

  RBT_Set.empty RBT_Map.update RBT_Map.delete Lookup2.lookup RBT_Map.M.invar

  PST_RBT.empty PST_RBT.update PST_RBT.delete PST_RBT.PM.invar
  Lookup2.lookup PST_RBT.rbt_is_empty pst_getmin

  g r _ _ _ G.\<alpha>w G.\<alpha>g for r::"'a::linorder"
  by unfold_locales simp_all

lemmas prim_impl_correct = AUX.prim_impl_correct[folded prim_impl_def]

end

subsubsection \<open>Adding a Graph-From-List Parser\<close>

definition "prim_list_impl l r
  \<equiv> if G_valid_wgraph_repr l then Some (prim_impl (G_from_list l) r) else None"

subsection \<open>Main Correctness Theorem\<close>

text \<open>
  The @{const prim_list_impl} algorithm returns @{const None}, if the input was
  invalid. Otherwise it returns @{term \<open>Some (\<pi>i,Vi)\<close>}, which satisfy the
  map/set invariants and encode a minimum spanning tree of the component of the
  graph that contains \<open>r\<close>.

  Notes:
    \<^item> If \<open>r\<close> is n ot a node of the graph, \<open>component_of\<close> will return the graph
      with the only node \<open>r\<close>. (@{thm [source] component_of_not_node})
\<close>

theorem prim_list_impl_correct:
  shows "case prim_list_impl l r of
    None \<Rightarrow> \<not>G.valid_wgraph_repr l \<comment> \<open>Invalid input\<close>
  | Some \<pi>i \<Rightarrow>
        G.valid_wgraph_repr l \<and> (let Gi = G.from_list l in G.invar Gi \<comment> \<open>Valid input\<close>
        \<and> P.invar_MST \<pi>i \<comment> \<open>Output satisfies invariants\<close>
        \<and> is_MST (G.\<alpha>w Gi) (component_of (G.\<alpha>g Gi) r) (P.\<alpha>_MST r \<pi>i)) \<comment> \<open>and represents MST\<close>"
  unfolding prim_list_impl_def G_from_list_unfold
  using prim_impl_correct[of "G.from_list l" r] G.from_list_correct[of l]
  by (auto simp: Let_def)

theorem prim_list_impl_correct_presentation:
  shows "case prim_list_impl l r of
    None \<Rightarrow> \<not>G.valid_wgraph_repr l \<comment> \<open>Invalid input\<close>
  | Some \<pi>i \<Rightarrow> let
      g=G.\<alpha>g (G.from_list l);
      w=G.\<alpha>w (G.from_list l);
      rg=component_of g r;
      t=P.\<alpha>_MST r \<pi>i
    in
        G.valid_wgraph_repr l \<comment> \<open>Valid input\<close>
      \<and> P.invar_MST \<pi>i \<comment> \<open>Output satisfies invariants\<close>
      \<and> is_MST w rg t \<comment> \<open>and represents MST\<close>"
  using prim_list_impl_correct[of l r] unfolding Let_def
  by (auto split: option.splits)

subsection \<open>Code Generation and Test\label{sec:prim_exec}\<close>

definition prim_list_impl_int :: "_ \<Rightarrow> int \<Rightarrow> _"
  where "prim_list_impl_int \<equiv> prim_list_impl"

export_code prim_list_impl prim_list_impl_int checking SML

experiment begin

abbreviation "a \<equiv> 1"
abbreviation "b \<equiv> 2"
abbreviation "c \<equiv> 3"
abbreviation "d \<equiv> 4"
abbreviation "e \<equiv> 5"
abbreviation "f \<equiv> 6"
abbreviation "g \<equiv> 7"
abbreviation "h \<equiv> 8"
abbreviation "i \<equiv> 9"

value "(prim_list_impl_int [
  ((a,b),4),
  ((a,h),8),
  ((b,h),11),
  ((b,c),8),
  ((h,i),7),
  ((h,g),1),
  ((c,i),2),
  ((g,i),6),
  ((c,d),7),
  ((c,f),4),
  ((g,f),2),
  ((d,f),14),
  ((d,e),9),
  ((e,f),10)
] 1)"

end

end