(*  Title:      HOL/Imperative_HOL/Ref.thy
    Author:     John Matthews, Galois Connections; Alexander Krauss, Lukas Bulwahn & Florian Haftmann, TU Muenchen
*)

section \<open>Monadic references\<close>

theory Ref
imports Array
begin

text \<open>
  Imperative reference operations; modeled after their ML counterparts.
  See \<^url>\<open>http://caml.inria.fr/pub/docs/manual-caml-light/node14.15.html\<close>
  and \<^url>\<open>http://www.smlnj.org/doc/Conversion/top-level-comparison.html\<close>.
\<close>

subsection \<open>Primitives\<close>

definition present :: "heap \<Rightarrow> 'a::heap ref \<Rightarrow> bool" where
  "present h r \<longleftrightarrow> addr_of_ref r < lim h"

definition get :: "heap \<Rightarrow> 'a::heap ref \<Rightarrow> 'a" where
  "get h = from_nat \<circ> refs h TYPEREP('a) \<circ> addr_of_ref"

definition set :: "'a::heap ref \<Rightarrow> 'a \<Rightarrow> heap \<Rightarrow> heap" where
  "set r x = refs_update
    (\<lambda>h. h(TYPEREP('a) := ((h (TYPEREP('a))) (addr_of_ref r := to_nat x))))"

definition alloc :: "'a \<Rightarrow> heap \<Rightarrow> 'a::heap ref \<times> heap" where
  "alloc x h = (let
     l = lim h;
     r = Ref l
   in (r, set r x (h\<lparr>lim := l + 1\<rparr>)))"

definition noteq :: "'a::heap ref \<Rightarrow> 'b::heap ref \<Rightarrow> bool" (infix "=!=" 70) where
  "r =!= s \<longleftrightarrow> TYPEREP('a) \<noteq> TYPEREP('b) \<or> addr_of_ref r \<noteq> addr_of_ref s"

subsection \<open>Monad operations\<close>

definition ref :: "'a::heap \<Rightarrow> 'a ref Heap" where
  [code del]: "ref v = Heap_Monad.heap (alloc v)"

definition lookup :: "'a::heap ref \<Rightarrow> 'a Heap" ("!_" 61) where
  [code del]: "lookup r = Heap_Monad.tap (\<lambda>h. get h r)"

definition update :: "'a ref \<Rightarrow> 'a::heap \<Rightarrow> unit Heap" ("_ := _" 62) where
  [code del]: "update r v = Heap_Monad.heap (\<lambda>h. ((), set r v h))"

definition change :: "('a::heap \<Rightarrow> 'a) \<Rightarrow> 'a ref \<Rightarrow> 'a Heap" where
  "change f r = do {
     x \<leftarrow> ! r;
     let y = f x;
     r := y;
     return y
   }"

subsection \<open>Properties\<close>

text \<open>Primitives\<close>

lemma noteq_sym: "r =!= s \<Longrightarrow> s =!= r"
  and unequal [simp]: "r \<noteq> r' \<longleftrightarrow> r =!= r'" \<comment> "same types!"
  by (auto simp add: noteq_def)

lemma noteq_irrefl: "r =!= r \<Longrightarrow> False"
  by (auto simp add: noteq_def)

lemma present_alloc_neq: "present h r \<Longrightarrow> r =!= fst (alloc v h)"
  by (simp add: present_def alloc_def noteq_def Let_def)

lemma next_fresh [simp]:
  assumes "(r, h') = alloc x h"
  shows "\<not> present h r"
  using assms by (cases h) (auto simp add: alloc_def present_def Let_def)

lemma next_present [simp]:
  assumes "(r, h') = alloc x h"
  shows "present h' r"
  using assms by (cases h) (auto simp add: alloc_def set_def present_def Let_def)

lemma get_set_eq [simp]:
  "get (set r x h) r = x"
  by (simp add: get_def set_def)

lemma get_set_neq [simp]:
  "r =!= s \<Longrightarrow> get (set s x h) r = get h r"
  by (simp add: noteq_def get_def set_def)

lemma set_same [simp]:
  "set r x (set r y h) = set r x h"
  by (simp add: set_def)

lemma not_present_alloc [simp]:
  "\<not> present h (fst (alloc v h))"
  by (simp add: present_def alloc_def Let_def)

lemma set_set_swap:
  "r =!= r' \<Longrightarrow> set r x (set r' x' h) = set r' x' (set r x h)"
  by (simp add: noteq_def set_def fun_eq_iff)

lemma alloc_set:
  "fst (alloc x (set r x' h)) = fst (alloc x h)"
  by (simp add: alloc_def set_def Let_def)

lemma get_alloc [simp]:
  "get (snd (alloc x h)) (fst (alloc x' h)) = x"
  by (simp add: alloc_def Let_def)

lemma set_alloc [simp]:
  "set (fst (alloc v h)) v' (snd (alloc v h)) = snd (alloc v' h)"
  by (simp add: alloc_def Let_def)

lemma get_alloc_neq: "r =!= fst (alloc v h) \<Longrightarrow>
  get (snd (alloc v h)) r  = get h r"
  by (simp add: get_def set_def alloc_def Let_def noteq_def)

lemma lim_set [simp]:
  "lim (set r v h) = lim h"
  by (simp add: set_def)

lemma present_alloc [simp]:
  "present h r \<Longrightarrow> present (snd (alloc v h)) r"
  by (simp add: present_def alloc_def Let_def)

lemma present_set [simp]:
  "present (set r v h) = present h"
  by (simp add: present_def fun_eq_iff)

lemma noteq_I:
  "present h r \<Longrightarrow> \<not> present h r' \<Longrightarrow> r =!= r'"
  by (auto simp add: noteq_def present_def)

text \<open>Monad operations\<close>

lemma execute_ref [execute_simps]:
  "execute (ref v) h = Some (alloc v h)"
  by (simp add: ref_def execute_simps)

lemma success_refI [success_intros]:
  "success (ref v) h"
  by (auto intro: success_intros simp add: ref_def)

lemma effect_refI [effect_intros]:
  assumes "(r, h') = alloc v h"
  shows "effect (ref v) h h' r"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_refE [effect_elims]:
  assumes "effect (ref v) h h' r"
  obtains "get h' r = v" and "present h' r" and "\<not> present h r"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_lookup [execute_simps]:
  "Heap_Monad.execute (lookup r) h = Some (get h r, h)"
  by (simp add: lookup_def execute_simps)

lemma success_lookupI [success_intros]:
  "success (lookup r) h"
  by (auto intro: success_intros  simp add: lookup_def)

lemma effect_lookupI [effect_intros]:
  assumes "h' = h" "x = get h r"
  shows "effect (!r) h h' x"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_lookupE [effect_elims]:
  assumes "effect (!r) h h' x"
  obtains "h' = h" "x = get h r"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_update [execute_simps]:
  "Heap_Monad.execute (update r v) h = Some ((), set r v h)"
  by (simp add: update_def execute_simps)

lemma success_updateI [success_intros]:
  "success (update r v) h"
  by (auto intro: success_intros  simp add: update_def)

lemma effect_updateI [effect_intros]:
  assumes "h' = set r v h"
  shows "effect (r := v) h h' x"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_updateE [effect_elims]:
  assumes "effect (r' := v) h h' r"
  obtains "h' = set r' v h"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_change [execute_simps]:
  "Heap_Monad.execute (change f r) h = Some (f (get h r), set r (f (get h r)) h)"
  by (simp add: change_def bind_def Let_def execute_simps)

lemma success_changeI [success_intros]:
  "success (change f r) h"
  by (auto intro!: success_intros effect_intros simp add: change_def)

lemma effect_changeI [effect_intros]:
  assumes "h' = set r (f (get h r)) h" "x = f (get h r)"
  shows "effect (change f r) h h' x"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_changeE [effect_elims]:
  assumes "effect (change f r') h h' r"
  obtains "h' = set r' (f (get h r')) h" "r = f (get h r')"
  using assms by (rule effectE) (simp add: execute_simps)

lemma lookup_chain:
  "(!r \<then> f) = f"
  by (rule Heap_eqI) (auto simp add: lookup_def execute_simps intro: execute_bind)

lemma update_change [code]:
  "r := e = change (\<lambda>_. e) r \<then> return ()"
  by (rule Heap_eqI) (simp add: change_def lookup_chain)

text \<open>Non-interaction between imperative arrays and imperative references\<close>

lemma array_get_set [simp]:
  "Array.get (set r v h) = Array.get h"
  by (simp add: Array.get_def set_def fun_eq_iff)

lemma get_update [simp]:
  "get (Array.update a i v h) r = get h r"
  by (simp add: get_def Array.update_def Array.set_def)

lemma alloc_update:
  "fst (alloc v (Array.update a i v' h)) = fst (alloc v h)"
  by (simp add: Array.update_def Array.get_def Array.set_def alloc_def Let_def)

lemma update_set_swap:
  "Array.update a i v (set r v' h) = set r v' (Array.update a i v h)"
  by (simp add: Array.update_def Array.get_def Array.set_def set_def)

lemma length_alloc [simp]:
  "Array.length (snd (alloc v h)) a = Array.length h a"
  by (simp add: Array.length_def Array.get_def alloc_def set_def Let_def)

lemma array_get_alloc [simp]:
  "Array.get (snd (alloc v h)) = Array.get h"
  by (simp add: Array.get_def alloc_def set_def Let_def fun_eq_iff)

lemma present_update [simp]:
  "present (Array.update a i v h) = present h"
  by (simp add: Array.update_def Array.set_def fun_eq_iff present_def)

lemma array_present_set [simp]:
  "Array.present (set r v h) = Array.present h"
  by (simp add: Array.present_def set_def fun_eq_iff)

lemma array_present_alloc [simp]:
  "Array.present h a \<Longrightarrow> Array.present (snd (alloc v h)) a"
  by (simp add: Array.present_def alloc_def Let_def)

lemma set_array_set_swap:
  "Array.set a xs (set r x' h) = set r x' (Array.set a xs h)"
  by (simp add: Array.set_def set_def)

hide_const (open) present get set alloc noteq lookup update change

subsection \<open>Code generator setup\<close>

text \<open>Intermediate operation avoids invariance problem in \<open>Scala\<close> (similar to value restriction)\<close>

definition ref' where
  [code del]: "ref' = ref"

text \<open>SML / Eval\<close>

code_printing type_constructor ref \<rightharpoonup> (SML) "_/ ref"
code_printing type_constructor ref \<rightharpoonup> (Eval) "_/ Unsynchronized.ref"
code_printing constant Ref \<rightharpoonup> (SML) "raise/ (Fail/ \"bare Ref\")"
code_printing constant ref' \<rightharpoonup> (SML) "(fn/ ()/ =>/ ref/ _)"
code_printing constant ref' \<rightharpoonup> (Eval) "(fn/ ()/ =>/ Unsynchronized.ref/ _)"
code_printing constant Ref.lookup \<rightharpoonup> (SML) "(fn/ ()/ =>/ !/ _)"
code_printing constant Ref.update \<rightharpoonup> (SML) "(fn/ ()/ =>/ _/ :=/ _)"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (SML) infixl 6 "="

code_reserved Eval Unsynchronized

text \<open>OCaml\<close>

code_printing type_constructor ref \<rightharpoonup> (OCaml) "_/ ref"
code_printing constant Ref \<rightharpoonup> (OCaml) "failwith/ \"bare Ref\""
code_printing constant ref' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ ref/ _)"
code_printing constant Ref.lookup \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ !/ _)"
code_printing constant Ref.update \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ _/ :=/ _)"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (OCaml) infixl 4 "="

code_reserved OCaml ref

text \<open>Haskell\<close>

code_printing type_constructor ref \<rightharpoonup> (Haskell) "Heap.STRef/ Heap.RealWorld/ _"
code_printing constant Ref \<rightharpoonup> (Haskell) "error/ \"bare Ref\""
code_printing constant ref' \<rightharpoonup> (Haskell) "Heap.newSTRef"
code_printing constant Ref.lookup \<rightharpoonup> (Haskell) "Heap.readSTRef"
code_printing constant Ref.update \<rightharpoonup> (Haskell) "Heap.writeSTRef"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (Haskell) infix 4 "=="
code_printing class_instance ref :: HOL.equal \<rightharpoonup> (Haskell) -

text \<open>Scala\<close>

code_printing type_constructor ref \<rightharpoonup> (Scala) "!Ref[_]"
code_printing constant Ref \<rightharpoonup> (Scala) "!sys.error(\"bare Ref\")"
code_printing constant ref' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref((_))"
code_printing constant Ref.lookup \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref.lookup((_))"
code_printing constant Ref.update \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref.update((_), (_))"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (Scala) infixl 5 "=="

end


theory Linked_List_Insert imports
 "/home/dacosta/development/rockwellcollins/l4v/tools/autocorres/AutoCorres"
 "/home/dacosta/development/rockwellcollins/l4v/tools/autocorres/DataStructures"
begin

text{*

Author: Dan DaCosta
Description: Work towards a correctness proof of an order preserving linked list insert. Insertion
relies on the function, find_insertion, to find the correct placement for the new node. Currently,
there is a proof that find_insertion finds the insertion point according to the following
statements:

  - find_insertion does not alter the heap

  - if find_insertion returns a non-null node n, then all ancestors of n and n have values less than
  or equal to the value find_insertion was called with.

  - if find_insertion returns a non-null node n and n's direct descendant is not null than n's
  direct descendant has a value greater than the value of what find_insertion was called with.

  - if find_insertion returns null then either the list find_insertion was called with is null or
  the first element of the list is greater than the value find_insertion was called with.

TODO:

 - Requires significant cleanup.

 - A proof that insert uses find_insertion to insert a new element into a linked list preserving
 ascending order must be given.

*}

install_C_file linked_list.c
autocorres [ heap_abs_syntax, ts_rules = nondet] linked_list.c
context linked_list begin

interpretation DataStructures.linked_list next_C NULL
done

text{*

Both of these lemma seem like poor candidates for simplification rules; they both have the
potential for looping.

*}

declare list_split [simp del]
declare path_split [simp del]

definition lkup :: "lifted_globals \<Rightarrow> ll_C ptr \<Rightarrow> ll_C option" where
"lkup s a \<equiv> (if is_valid_ll_C s a then Some (s[a]) else None)"

text{*

A useful lemma when using DataStructures.thy. It connects the lkup function to the structure
notations generated by AutoCorres.

*}

lemma lkup_conv[simp]: "lkup s i = Some j \<Longrightarrow> is_valid_ll_C s i \<and> s[i] = j \<and> next_C j = s[i]\<rightarrow>next \<and> val_C j = s[i]\<rightarrow>val"
by
  (metis
    linked_list.get_ll_next_def
    linked_list.get_ll_val_def
    linked_list.lkup_def
    option.distinct(1)
    option.sel)

lemma list_null_free: "list (lkup s') xs i \<Longrightarrow> NULL \<notin> set xs"
 apply (induction xs arbitrary: i) by auto

lemma list_member_not_null:"\<lbrakk>list (lkup s') xs i; j \<in> set xs\<rbrakk> \<Longrightarrow> j \<noteq> NULL"
 apply (rule ccontr)
 apply (simp add: list_null_free)
 done

lemma list_non_empty_recursive: "list (lkup s) (x # xs) i \<Longrightarrow> list (lkup s) xs s[i]\<rightarrow>next" by auto

lemma list_non_empty_member:
"\<lbrakk>list (lkup s) (x # xs) i; j \<in> set (x # xs)\<rbrakk>
  \<Longrightarrow> j = x \<or> (list (lkup s) xs s[i]\<rightarrow>next \<and> j \<in> set xs)" by auto

(* Take a bit longer. *)
lemma list_next:"\<lbrakk>list (lkup s) xs i; j \<in> set xs; s[j]\<rightarrow>next \<noteq> NULL\<rbrakk> \<Longrightarrow> s[j]\<rightarrow>next \<in> set xs"
 apply (induction xs arbitrary: i j) using list_mem by auto

lemma list_all_valid:"\<lbrakk>list (lkup s) xs i; j \<in> set xs\<rbrakk> \<Longrightarrow> is_valid_ll_C s j"
 apply (induction xs arbitrary: i j) by auto

lemma the_list_next_is_smaller:"\<lbrakk>list (lkup s) xs i; j \<in> set xs\<rbrakk>
       \<Longrightarrow> length (the_list (lkup s) s[j]\<rightarrow>next) < length (the_list (lkup s) j)"
 apply (induction xs arbitrary: i j)
 apply auto
 by (simp add: is_list_non_NULL linked_list.list_is_list the_list_non_NULL)

(* Awkward. Can this be generalized into something more intuitive? *)
lemma the_list_absurd:
  "\<lbrakk>is_valid_ll_C s x; x \<noteq> NULL; s[x]\<rightarrow>next = NULL; the_list (lkup s) x = []\<rbrakk> \<Longrightarrow> False"
by
  (metis
    is_list_non_NULL
    linked_list.get_ll_next_def
    linked_list.is_list_empty
    linked_list.lkup_def
    the_list_empty')

lemma path_null_list_imp: "list s xs i \<Longrightarrow> path s i xs NULL"
 using path_null_list by auto

lemma list_singleton: "\<lbrakk>list (lkup s) xs i; i \<noteq> NULL; s[i]\<rightarrow>next = NULL\<rbrakk> \<Longrightarrow> xs = [i]"
 by (cases xs, auto)

lemma list_non_empty:
"list (lkup s) (x # xs) i
  \<Longrightarrow> i \<noteq> NULL \<and> x = i \<and> is_valid_ll_C s i \<and> list (lkup s) xs s[i]\<rightarrow>next"
 by auto

lemma list_member_has_sublist:"\<lbrakk>list (lkup s) xs i; j \<in> set xs\<rbrakk> \<Longrightarrow> \<exists> xs1 xs2. xs = xs1 @ xs2 \<and> list (lkup s) xs2 j"
 apply (induction xs arbitrary: i)
 apply auto
 using list_non_NULL apply auto[1]
 by (metis append_Cons)

lemma list_is_two_paths:"\<lbrakk>list (lkup s) xs i; j \<in> set xs \<rbrakk> \<Longrightarrow>  \<exists> xs1 xs2. xs = xs1 @ xs2 \<and> path (lkup s) i xs1 j \<and> path (lkup s) j xs2 NULL"
proof(induction xs arbitrary: i j)
  case Nil
  thus ?case by auto
next
  case (Cons x xs)
  have "s[i]\<rightarrow>next = NULL \<or> s[i]\<rightarrow>next \<noteq> NULL" by auto
  thus ?case
  proof
    assume "s[i]\<rightarrow>next = NULL"
    thus ?case using Cons by (metis append_Nil empty_iff linked_list.list_singleton linked_list.path.simps(1) linked_list.path_null_list list.set(1) local.list.simps(2) set_ConsD)
  next
    assume a1:"s[i]\<rightarrow>next \<noteq> NULL"
    have "x = j \<or> x \<noteq> j" by auto
    thus ?case
    proof
      assume a2:"x = j"
      thus ?case using a1 a2 Cons by (metis (no_types, hide_lams) append_Nil linked_list.list.simps(2) linked_list.path.simps(1) linked_list.path_null_list)
    next
      assume a2:"x \<noteq> j"
      then have h1:"list (lkup s) xs s[i]\<rightarrow>next" using Cons by auto
      then have h2:"j \<in> set xs" using a2 Cons by auto
      then obtain xs1 xs2 where "xs = xs1 @ xs2 \<and> path (lkup s) s[i]\<rightarrow>next xs1 j \<and> path (lkup s) j xs2 NULL" using Cons(1)[OF h1 h2] by auto
      then have "i # xs = i # xs1 @ xs2 \<and> path (lkup s) i (i # xs1) j \<and> path (lkup s) j xs2 NULL" using Cons by (metis linked_list.get_ll_next_def linked_list.list_non_empty linked_list.lkup_def path.simps(2))
      thus ?case by (metis Cons(2) append_Cons linked_list.list.simps(2))
    qed
  qed
qed

lemma list_hd_non_member_tail:"\<lbrakk>list (lkup s) xs i; xs \<noteq> []\<rbrakk> \<Longrightarrow> xs = [] \<or> hd xs \<notin> set (tl xs)"
apply (induction xs arbitrary: i)
apply auto
by
  (metis
    linked_list.get_ll_next_def
    linked_list.list_all_valid
    linked_list.list_head_not_in_list
    linked_list.lkup_def)

lemma path_non_empty_non_null_start:"\<lbrakk>path (lkup s) i xs j; xs \<noteq> []\<rbrakk> \<Longrightarrow> i \<noteq> NULL" by auto

lemma path_extend:
"\<lbrakk>path (lkup s) i xs a; a \<noteq> NULL; is_valid_ll_C s a\<rbrakk> \<Longrightarrow> path (lkup s) i (xs@[a]) s[a]\<rightarrow>next"
proof(induction xs arbitrary:i)
  case Nil
  thus ?case by (metis append_Nil linked_list.get_ll_next_def path.simps lkup_def)
next
  case (Cons x xs)
  then have "i \<noteq> NULL \<and> is_valid_ll_C s a \<and> i = x \<and> path (lkup s) s[i]\<rightarrow>next xs a"
    using lkup_def
    by (metis linked_list.get_ll_next_def option.distinct(1) option.sel path.simps(2))
  then have h1:"i = x" and h2:"path (lkup s) s[i]\<rightarrow>next xs a" and h3:"i \<noteq> NULL" and h4:"is_valid_ll_C s a" by auto
  then have "path (lkup s) s[i]\<rightarrow>next (xs @ [a]) s[a]\<rightarrow>next" using Cons(1)[OF h2 Cons(3) Cons(4)] by auto
  thus ?case
    using h3 h4 h1 Cons.prems(1) append_Cons linked_list.get_ll_next_def
    by (metis lkup_def option.simps(3) path.simps(2))
qed

lemma path_equal_endpoints:"path (lkup s) j [] j" by (meson linked_list.path.simps(1))

lemma list_path_no_cycles:"\<lbrakk>list (lkup s) xs i; j \<in> set xs; path (lkup s) j ys j\<rbrakk> \<Longrightarrow> ys = []"
proof (induction xs arbitrary: i)
  case Nil
  thus ?case by auto
next
  case (Cons x xs)
  have "j = i \<or> j \<noteq> i" using Cons by auto
  thus ?case
  proof
    assume "j = i"
    thus ?case using Cons by (meson append_self_conv2 list_split list_unique)
  next
    assume a:"j \<noteq> i"
    then have "x = i \<and> list (lkup s) xs (s[i]\<rightarrow>next)" using Cons list_non_empty by blast
    then have h1:"x = i" and h2:"list (lkup s) xs (s[i]\<rightarrow>next)" by auto
    thus ?case using Cons Cons(1)[OF h2 _ Cons(4)] a by auto
  qed
qed

lemma paths_preserve_list:
"\<lbrakk>list (lkup s) xs i; j \<in> set xs; path (lkup s) i xs1 j; path (lkup s) j xs2 NULL\<rbrakk>
  \<Longrightarrow> xs = xs1 @ xs2"
proof (induction xs arbitrary: i)
  case Nil
  thus ?case by auto
next
  case (Cons x xs)
  have "j = i \<or> j \<noteq> i" using Cons by auto
  thus ?case
  proof
    assume "j = i"
    thus ?case using Cons list_path_no_cycles
      by (metis append_self_conv2 list_unique path_null_list)
  next
    assume a:"j \<noteq> i"
    then have "x = i \<and> list (lkup s) xs (s[i]\<rightarrow>next)" using list_non_empty Cons by blast
    then have h1:"x = i" and h2:"list (lkup s) xs (s[i]\<rightarrow>next)" by auto
    thus ?case
      using Cons(1)[OF h2 _ _ Cons(5)] Cons a by (meson list_split list_unique path_null_list)
  qed
qed

lemma path_shorten:"\<lbrakk>path (lkup s) i xs NULL; i \<noteq> NULL\<rbrakk> \<Longrightarrow> path (lkup s) s[i]\<rightarrow>next (tl xs) NULL"
proof -
  assume a1:"path (lkup s) i xs NULL"
  and a2:"i \<noteq> NULL"
  have "s[i]\<rightarrow>next = NULL \<or> s[i]\<rightarrow>next \<noteq> NULL" by simp
  thus ?thesis
  proof
    assume "s[i]\<rightarrow>next = NULL"
    thus ?thesis
      using a1 a2 linked_list.path.simps(1) linked_list.path_null_list
            linked_list.list_singleton list.sel(3)
      by fastforce
  next
    assume "s[i]\<rightarrow>next \<noteq> NULL"
    thus ?thesis by (metis a1 a2 linked_list.path_null_list list.sel(3) list_non_empty path_next)
  qed
qed

lemma find_insertion_1_loop_step:
assumes a1:"list (lkup s) xs i"
and a2:"path (lkup s) i xs1 a"
and a3:"\<forall>x\<in>set xs1. sint s[x]\<rightarrow>val \<le> v"
and a4:"path (lkup s) a xs2 NULL"
and a5:"a \<noteq> NULL"
and a6:"sint s[a]\<rightarrow>val \<le> v"
and a7:"a \<in> set xs"
shows "\<exists>xs1. path (lkup s) i xs1 s[a]\<rightarrow>next
       \<and> (\<exists>xs2. path (lkup s) s[a]\<rightarrow>next xs2 NULL)
       \<and> (\<forall>x\<in>set xs1. sint s[x]\<rightarrow>val \<le> v)"
proof -
  have h1:"path (lkup s) i (xs1 @ [a]) s[a]\<rightarrow>next" using path_extend[OF a2 a5 list_all_valid[OF a1 a7]] by simp
  then have h2:"path (lkup s) s[a]\<rightarrow>next (tl xs2) NULL" using path_shorten[OF a4 a5] by simp
  then have h3:"\<forall>x\<in>set (xs1@[a]). sint s[x]\<rightarrow>val \<le> v" using a3 a6 by simp
  thus ?thesis using h1 h2 h3 by metis
qed

text{*

Correctness of find_insertion when the input list is not null and the head of the list is less
than or equal to value supplied.

*}

lemma find_insertion_1:
"\<lbrace> \<lambda> (s::lifted_globals).
  s' = s
  \<and> i \<noteq> NULL
  \<and> sint s'[i]\<rightarrow>val \<le> v
  \<and> list (lkup s) xs i \<rbrace>
  find_insertion' v i
\<lbrace> \<lambda> r s.
  s' = s
  \<and> r \<in> set xs
  \<and> (s[r]\<rightarrow>next = NULL \<or> (s[r]\<rightarrow>next \<noteq> NULL \<and>  v < sint s[s[r]\<rightarrow>next]\<rightarrow>val))
  \<and> (\<exists> xs1 xs2.
       path (lkup s) i xs1 s[r]\<rightarrow>next
       \<and> path (lkup s) s[r]\<rightarrow>next xs2 NULL
       \<and> (\<forall> x \<in> set xs1. sint s[x]\<rightarrow>val \<le> v))
\<rbrace>!"
 apply (rule validNF_assume_pre)
 apply (unfold find_insertion'_def)
 apply (subst whileLoop_add_inv [where
  I = " \<lambda> (it,last,cond) s.
       s = s'
       \<and> (cond \<noteq> 0 \<longrightarrow> it \<noteq> NULL \<and> sint s[it]\<rightarrow>val \<le> v \<and> it \<in> set xs)
       \<and> (cond = 0 \<longrightarrow> last \<noteq> NULL \<and> (it = NULL \<or> v < sint s[it]\<rightarrow>val))
       \<and> (last \<noteq> NULL \<longrightarrow> s[last]\<rightarrow>next = it \<and> last \<in> set xs)
       \<and> (\<exists> xs1 xs2. path (lkup s) i xs1 it \<and> path (lkup s) it xs2 NULL \<and> (\<forall> x \<in> set xs1. sint s[x]\<rightarrow>val \<le> v))
"
  and M = "\<lambda>((it,r,_),s). length (the_list (lkup s) it)"])
 apply wp
    apply (clarsimp,auto intro: list_all_valid list_next list_mem the_list_next_is_smaller path_null_list_imp the_list_absurd find_insertion_1_loop_step)[1]
   apply (clarsimp, auto)
  apply wp
 apply (auto intro: list_mem list_all_valid)
 apply (metis empty_iff linked_list.path.simps(1) linked_list.path_null_list list.set(1))
done

text{*

Correctness of find_insertion when the input list is null.

*}

lemma find_insertion_2:
"\<lbrace> \<lambda> (s::lifted_globals).
  s' = s
  \<and> i = NULL
  \<and> list (lkup s) xs i \<rbrace>
  find_insertion' v i
\<lbrace> \<lambda> r s.
  s' = s
  \<and> r = NULL
\<rbrace>!"
 apply (unfold find_insertion'_def)
 apply (subst whileLoop_unroll)
 apply wp
    apply (rule validNF_false_pre)
   apply (rule validNF_false_pre)
  apply wp
 apply auto
done

text{*

Correctness of find_insertion when the input list is not null and the head of the list is greater
than the value supplied to find_insertion.

*}

lemma find_insertion_3:
"\<lbrace> \<lambda> (s::lifted_globals).
  s' = s
  \<and> i \<noteq> NULL
  \<and> v < sint s'[i]\<rightarrow>val
  \<and> list (lkup s) xs i \<rbrace>
  find_insertion' v i
\<lbrace> \<lambda> r s.
  s' = s
  \<and> r = NULL
  \<and> v < sint s'[i]\<rightarrow>val
\<rbrace>!"
 apply (unfold find_insertion'_def)
 apply (subst whileLoop_unroll)
 apply wp
    apply (rule validNF_false_pre)
   apply (rule validNF_false_pre)
  apply wp
 apply (auto intro: list_all_valid list_mem)
done

lemma find_insertion_pre_part:
"\<And>s. s' = s \<and> list (lkup s) xs i
 \<Longrightarrow> ((s' = s \<and> i \<noteq> NULL \<and> sint s'[i]\<rightarrow>val \<le> v \<and> list (lkup s) xs i)
     \<or> (s' = s \<and> i = NULL \<and> list (lkup s) xs i)
     \<or> (s' = s \<and> i \<noteq> NULL \<and> v < sint s'[i]\<rightarrow>val \<and> list (lkup s) xs i))"
by auto

lemma find_insertion:
"
\<lbrace> \<lambda> (s::lifted_globals).
  s' = s
  \<and> list (lkup s) xs i \<rbrace>
  find_insertion' v i
\<lbrace> \<lambda> r s.
  (s' = s \<and> r \<in> set xs \<and>
                     (s[r]\<rightarrow>next = NULL \<or> s[r]\<rightarrow>next \<noteq> NULL \<and> v < sint s[s[r]\<rightarrow>next]\<rightarrow>val) \<and>
                     (\<exists>xs1 xs2. path (lkup s) i xs1 s[r]\<rightarrow>next \<and> path (lkup s) s[r]\<rightarrow>next xs2 NULL \<and> (\<forall>x\<in>set xs1. sint s[x]\<rightarrow>val \<le> v)) \<or>
            s' = s \<and> r = NULL) \<or>
           s' = s \<and> r = NULL \<and> v < sint s'[i]\<rightarrow>val
\<rbrace>!"
using validNF_weaken_pre[OF
        validNF_vcg_disj_lift[OF
          validNF_vcg_disj_lift[OF find_insertion_1 find_insertion_2]
          find_insertion_3,
          of s' i v xs s' xs s' xs],
        of "\<lambda> s . s' = s \<and> list (lkup s) xs i"] find_insertion_pre_part by simp

lemma else_branch:"\<not> C \<Longrightarrow> Q \<Longrightarrow> if C then P else Q"
 by auto

lemma next_update_preserve_validity:"is_valid_ll_C s i = is_valid_ll_C s[j\<rightarrow>next := x] i"
  by auto

lemma next_update_preserve_untouched_state:"x \<noteq> y \<Longrightarrow> lkup s x = lkup s[y\<rightarrow>next := v] x"
 apply(unfold lkup_def) by (simp add: linked_list.update_ll_next_def)

lemma next_update_preserve_path:"\<lbrakk>i \<notin> set xs; path (lkup s) j xs k\<rbrakk> \<Longrightarrow> path (lkup s[i\<rightarrow>next := l]) j xs k"
  apply(induction xs arbitrary: j)
  apply auto
  using linked_list.next_update_preserve_untouched_state by auto

lemma non_member_next_update_preserves_list:"\<lbrakk>list (lkup s) xs i; n \<notin> set xs\<rbrakk> \<Longrightarrow> list (lkup s[n\<rightarrow>next := j]) xs i"
proof (induction xs arbitrary: i)
  case Nil
  thus ?case by auto
next
  case (Cons x xs)
  then have h1:"list (lkup s) xs s[i]\<rightarrow>next" and h2:"x = i" by auto
  have h3:"n \<notin> set xs" using Cons by auto
  have h4:"i \<noteq> n" using Cons h2 by auto
  have h5:"is_valid_ll_C s[n\<rightarrow>next := j] i" using next_update_preserve_validity Cons by auto
  have h6:"i \<noteq> NULL" using Cons by auto
  obtain di where h7:"lkup s i = Some di" using Cons by auto
  have h8:"lkup s[n\<rightarrow>next := j] i = Some di" using next_update_preserve_untouched_state[OF h4,of s x] h7 using h4 linked_list.next_update_preserve_untouched_state by presburger
  have h9:"s[n\<rightarrow>next := j][i]\<rightarrow>next = next_C di" using h8 by auto
  have h10:"s[i]\<rightarrow>next = s[n\<rightarrow>next := j][i]\<rightarrow>next" using h4 by simp
  have h11:"list (lkup s[n\<rightarrow>next := j]) xs s[n\<rightarrow>next := j][i]\<rightarrow>next" using Cons(1)[OF h1 h3] h10 by auto
  thus ?case using h2 h6 h8 h11 h9 by auto
qed

lemma path_one_step:"\<lbrakk>path (lkup s) i xs j; i\<noteq> NULL; xs \<noteq> []\<rbrakk> \<Longrightarrow> path (lkup s) s[i]\<rightarrow>next (tl xs) j"
 apply(induction xs arbitrary: i) by auto
(*
lemma path_cannot_cycle:"\<lbrakk>list (lkup s) xs i; j \<in> set xs; path (lkup s) i ys s[j]\<rightarrow>next\<rbrakk> \<Longrightarrow> ys \<noteq> []"
sorry
*)

lemma lkup_valid_eval:"is_valid_ll_C s i \<Longrightarrow> lkup s i = Some s[i]"
  using lkup_def by metis

lemma list_last_element:"\<lbrakk>list (lkup s) xs i; n \<notin> set xs;  r \<in> set xs; s[r]\<rightarrow>next = NULL\<rbrakk> \<Longrightarrow> last xs = r"
  apply(induction xs arbitrary: i) by auto

lemma hd_last_not_equal_if_distinct:"\<lbrakk>distinct xs; length xs > 1\<rbrakk> \<Longrightarrow> hd xs \<noteq> last xs"
  apply(induction xs) by auto

lemma insert_front:
"\<lbrakk>n \<noteq> NULL; is_valid_ll_C s n; list (lkup s) xs i; n \<notin> set xs\<rbrakk>
   \<Longrightarrow> list (lkup s[n\<rightarrow>next := i]) (n # xs) n"
proof -
  assume a1:"n \<noteq> NULL"
  assume a2:"is_valid_ll_C s n"
  assume a3:"list (lkup s) xs i"
  assume a4:"n \<notin> set xs"
  have h1:"is_valid_ll_C s[n\<rightarrow>next := i] n" using next_update_preserve_validity a2 by auto
  have h2:"list (lkup s[n\<rightarrow>next := i]) xs i" using non_member_next_update_preserves_list[OF a3 a4, of i] by auto
  obtain dn where h3:"lkup s[n\<rightarrow>next := i] n = Some dn" by (metis h1 lkup_def)
  have h4:"next_C dn = i" using lkup_conv[OF h3] by simp
  thus ?thesis using a1 h3 h2 h4 by auto
qed

lemma insert_back:
"\<lbrakk>n \<noteq> NULL; is_valid_ll_C s n; list (lkup s) xs i; n \<notin> set xs;  last xs = r; xs \<noteq> []\<rbrakk>
   \<Longrightarrow> list (lkup s[n\<rightarrow>next := NULL][r\<rightarrow>next := n]) (xs@[n]) i  \<and> insert n (set xs) = set (xs@[n])"
proof (induction xs arbitrary: i)
  case Nil
  thus ?case by auto
next
  case (Cons x xs)
  have h2:"list (lkup s) xs s[i]\<rightarrow>next" and h3:"x = i" and h4:"i \<noteq> NULL" using Cons by auto
  have h5:"(last xs = r \<and> xs \<noteq> []) \<or> xs = []" using Cons by auto
  thus ?case
  proof
    assume a:"last xs = r \<and> xs \<noteq> []"
    have "length (x # xs) > 1" using a Cons by auto
    then have "r \<noteq> i" by (metis Cons.prems(3) Cons.prems(5) h3 list.sel(1) hd_last_not_equal_if_distinct list_distinct)
    then have h6:"lkup s i = lkup s[n\<rightarrow>next := NULL][r\<rightarrow>next := n] i" by (metis List.list.simps(15) h3 insert_iff Cons next_update_preserve_untouched_state )
    have "is_valid_ll_C s[n\<rightarrow>next := NULL][r\<rightarrow>next := n] i" using Cons next_update_preserve_validity linked_list.list_non_empty by presburger
    thus ?case using Cons h2 h3 h4 a h6 by auto
  next
    assume "xs = []"
    then have "list (lkup s[n\<rightarrow>next := NULL][r\<rightarrow>next := n]) ((x # xs) @ [n]) i" using Cons
    by (metis (no_types, hide_lams) append.simps(1) append.simps(2) empty_iff insert_front last_in_set linked_list.heap_abs_simps(36) linked_list.list_empty list.set(1) list_non_empty set_ConsD)
    thus ?case using Cons by auto
  qed
qed

lemma insert_middle:" \<lbrakk>n \<noteq> NULL; is_valid_ll_C s n; list (lkup s) xs i; n \<notin> set xs; r \<in> set xs; path (lkup s) i xs1 s[r]\<rightarrow>next; path (lkup s) s[r]\<rightarrow>next xs2 NULL\<rbrakk>
       \<Longrightarrow> list (lkup s[n\<rightarrow>next := s[r]\<rightarrow>next][r\<rightarrow>next := n]) (xs1@[n]@xs2) i \<and> insert n (set xs) = set (xs1@[n]@xs2)"
proof (induction xs arbitrary: i xs1)
  case Nil
  thus ?case by auto
next
  case (Cons x xs)
  then have h1:"x = i" by auto
  then have "r = x \<or> r \<in> set xs" using Cons by auto
  thus ?case
  proof
    assume a:"r = x"
    then have h2:"r = i" using h1 by auto
    then have h3:"r \<notin> set xs2" using a Cons list_distinct by (metis linked_list.get_ll_next_def linked_list.list_head_not_in_list linked_list.path_null_list list_non_empty lkup_def)
    then have "xs1 @ xs = i # xs"
      by (metis (no_types) Cons h2 h1 linked_list.list_non_empty_recursive linked_list.list_split linked_list.list_unique)
    then have h4:"xs1 = [r]" using h2 by auto
    then have "path (lkup s) i [r] s[r]\<rightarrow>next" using Cons by auto
    then have h5:"path (lkup s[n\<rightarrow>next := s[r]\<rightarrow>next]) i [r] s[n\<rightarrow>next := s[r]\<rightarrow>next][i]\<rightarrow>next" using Cons by (metis h2 fun_upd_apply linked_list.heap_abs_simps(16) linked_list.next_update_preserve_path singleton_set)
    then have h6:"n \<notin> set xs2" using Cons by (metis List.list.simps(15) h2 insert_iff linked_list.list_non_empty_recursive linked_list.list_the_list path_null_list)
    then have h7:"path (lkup s[n\<rightarrow>next := s[r]\<rightarrow>next]) s[n\<rightarrow>next := s[r]\<rightarrow>next][r]\<rightarrow>next xs2 NULL" using next_update_preserve_path[OF h6 Cons(8)] Cons by auto
    then have h8:"path (lkup s[n\<rightarrow>next := s[r]\<rightarrow>next][r\<rightarrow>next := n]) n (n#xs2) NULL" using Cons by (metis h3 h6 linked_list.insert_front linked_list.non_member_next_update_preserves_list linked_list.path_null_list set_ConsD)
    then have h9:"x = i" using a h2 by auto
    then have h10:"i \<noteq> NULL" using Cons by auto
    have h11:"lkup s[n\<rightarrow>next := s[r]\<rightarrow>next] r \<noteq> None \<or> [] = xs1" using h5 by auto
    then have h12:"list (lkup s[n\<rightarrow>next := s[r]\<rightarrow>next][r\<rightarrow>next := n]) (xs1@[n]@xs2) i" using h11 h10 h9 h4 h7 h2 h4
    by (metis Cons.prems(1) Cons.prems(2) Cons.prems(4) Cons.prems(7) List.list.simps(15) append_Cons append_Nil h3 h6 insert_iff linked_list.insert_front linked_list.lkup_def linked_list.path_null_list)
    thus ?thesis using Cons by (metis (mono_tags, hide_lams) List.list.simps(15) a append_Cons append_Nil h4 h9 insert_commute linked_list.list_non_empty_recursive linked_list.list_the_list path_null_list)
  next
    assume a:"r \<in> set xs"
    then have h1:"list (lkup s) xs s[i]\<rightarrow>next" using Cons by auto
    then have h2:"path (lkup s) s[i]\<rightarrow>next (tl xs1) s[r]\<rightarrow>next" using path_one_step[OF Cons(7)]
       Cons.prems(3) Cons.prems(5) Cons.prems(6) linked_list.list_non_empty by (metis Linked_List_Insert.linked_list.list_next a distinct.simps(2) linked_list.list_distinct linked_list.path.simps(1))
    then have h3:"n \<notin> set xs" using Cons by auto
    then have h4:"list (lkup s[n\<rightarrow>next := s[r]\<rightarrow>next][r\<rightarrow>next := n]) (tl xs1 @ [n] @ xs2) s[i]\<rightarrow>next" and h45:"insert n (set xs) = set (tl xs1 @ [n] @ xs2)"
    using Cons(1)[OF Cons(2) Cons(3) h1 h3 a h2 Cons(8)] by auto
    then have h5:"list (lkup s[n\<rightarrow>next := s[r]\<rightarrow>next][r\<rightarrow>next := n]) (tl xs1 @ [n] @ xs2) s[n\<rightarrow>next := s[r]\<rightarrow>next][r\<rightarrow>next := n][i]\<rightarrow>next"
    by (metis a append.simps(1) distinct.simps(2) fun_upd_apply in_set_conv_decomp linked_list.heap_abs_simps(16) linked_list.list_distinct local.Cons(4) local.Cons(5) local.list.simps(2))
    then have h6:"i = x" using Cons by (meson linked_list.list.simps(2))
    then have h7:"x \<noteq> NULL" using Cons using linked_list.list_non_empty by blast
    then obtain a where  h8:"lkup s[n\<rightarrow>next := s[r]\<rightarrow>next][r\<rightarrow>next := n] i = Some a" by (meson Cons.prems(3) linked_list.heap_abs_simps(36) linked_list.list_non_empty linked_list.lkup_def)
    then obtain h9:"list (lkup s[n\<rightarrow>next := s[r]\<rightarrow>next][r\<rightarrow>next := n]) (tl xs1 @ [n] @ xs2) (next_C a)"
    by (metis Cons.prems(3) Cons.prems(4) a append_Nil distinct.simps(2) h4 in_set_conv_decomp linked_list.get_ll_next_def linked_list.list_distinct linked_list.list_non_empty linked_list.lkup_def linked_list.next_update_preserve_untouched_state option.sel)
    then have h11:"list (lkup s[n\<rightarrow>next := s[r]\<rightarrow>next][r\<rightarrow>next := n]) ((x # tl xs1) @ [n] @ xs2) i" using h6 h7 h8 h9 by auto
    then have h12:"xs1 = x # tl xs1" using path_one_step[OF Cons(7)] h7 h6
    by (metis Cons.prems(1) Cons.prems(6) append_Cons append_Nil h1 h3 h4 linked_list.list.simps(2) linked_list.path.simps(2) list.sel(2) list.sel(3) list_mem neq_Nil_conv)
    then have h13:"list (lkup s[n\<rightarrow>next := s[r]\<rightarrow>next][r\<rightarrow>next := n]) (xs1 @ [n] @ xs2) i" using h11 h12 by auto
    thus ?thesis using h13 h45 by (metis List.list.simps(15) append_Cons h12 insert_commute)
  qed
qed

lemma gets_maintains_state:
"
\<lbrace>\<lambda>s. s' = s
  \<and> n \<noteq> NULL
  \<and> is_valid_ll_C s n \<and> s[n]\<rightarrow>next = NULL
  \<and> list (lkup s) xs' i
  \<and> n \<notin> set xs' \<rbrace>
guard (\<lambda> s.  is_valid_ll_C s n)
\<lbrace>\<lambda> _ s. s' = s\<rbrace>!"
 by (simp add: guard_def validNF_alt_def validNF_state_assert state_assert_def validNF_weaken_pre)

lemma "\<lbrace> \<lambda> (s::lifted_globals).
  s' = s
  \<and> n \<noteq> NULL
  \<and> is_valid_ll_C s n
  \<and> s[n]\<rightarrow>next = NULL
  \<and> list (lkup s) xs' i
  \<and> n \<notin> set xs'\<rbrace>
  insert' n i
\<lbrace> \<lambda> r s. (\<exists> xs . list (lkup s) xs r \<and> set (n # xs') = set xs)\<rbrace>!"
 apply (rule validNF_assume_pre)
 apply (unfold insert'_def)
 apply wp
   apply (rule validNF_chain[OF find_insertion,of "\<lambda> s. s' = s" s' xs'],simp)
   apply safe
      apply (rule else_branch)
       apply (simp add: list_member_not_null)
      apply (auto intro: list_all_valid)[1]
      using insert_back apply (metis linked_list.list_last_element list.distinct(1) list.set_cases)
     apply (rule else_branch)
      apply (simp add: list_member_not_null)
     apply (auto intro: list_all_valid, metis insert_middle)[1]
    apply (auto intro: list_all_valid insert_front)[1]
   apply (auto intro: list_all_valid insert_front)[1]
  apply (rule validNF_gets)
 apply (rule gets_maintains_state)
done

end


theory Global
  imports "HOL-Library.Library" Result Env List_util Option_Extra Map_Extra AList_Extra
begin

sledgehammer_params [timeout = 30]
sledgehammer_params [provers = "cvc4 e spass vampire z3 zipperposition"]

declare K_record_comp[simp]

lemma if_then_Some_else_None_eq[simp]:
  "(if a then Some b else None) = Some c \<longleftrightarrow> a \<and> b = c"
  "(if a then Some b else None) = None \<longleftrightarrow> \<not> a"
  by (cases a) simp_all

lemma if_then_else_distributive: "(if a then f b else f c) = f (if a then b else c)"
  by simp

section \<open>Rest\<close>

lemma map_ofD:
  fixes xs k opt
  assumes "map_of xs k = opt"
  shows "opt = None \<or> (\<exists>n < length xs. opt = Some (snd (xs ! n)))"
  using assms
  by (metis in_set_conv_nth map_of_SomeD not_Some_eq snd_conv)

lemma list_all2_assoc_map_rel_get:
  assumes "list_all2 (=) (map fst xs) (map fst ys)" and "list_all2 R (map snd xs) (map snd ys)"
  shows "rel_option R (map_of xs k) (map_of ys k)"
  using assms[unfolded list.rel_map]
proof (induction xs ys rule: list.rel_induct)
  case Nil
  thus ?case by simp
next
  case (Cons x xs y ys)
  thus ?case by (cases "k = fst x") auto
qed

subsection \<open>Function definition\<close>

datatype ('label, 'instr) fundef =
  Fundef (body: "('label \<times> 'instr list) list") (arity: nat) (return: nat) (fundef_locals: nat)

lemma rel_fundef_arities: "rel_fundef r1 r2 gd1 gd2 \<Longrightarrow> arity gd1 = arity gd2"
  by (simp add: fundef.rel_sel)

lemma rel_fundef_return: "rel_fundef R1 R2 gd1 gd2 \<Longrightarrow> return gd1 = return gd2"
  by (simp add: fundef.rel_sel)

lemma rel_fundef_locals: "rel_fundef R1 R2 gd1 gd2 \<Longrightarrow> fundef_locals gd1 = fundef_locals gd2"
  by (simp add: fundef.rel_sel)

lemma rel_fundef_body_length[simp]:
  "rel_fundef r1 r2 fd1 fd2 \<Longrightarrow> length (body fd1) = length (body fd2)"
  by (auto intro: list_all2_lengthD simp add: fundef.rel_sel)

definition funtype where
  "funtype fd \<equiv> (arity fd, return fd)"

lemma rel_fundef_funtype[simp]: "rel_fundef R1 R2 fd1 fd2 \<Longrightarrow> funtype fd1 = funtype fd2"
  by (simp add: fundef.rel_sel funtype_def)

lemma rel_fundef_rel_fst_hd_bodies:
  assumes "rel_fundef R1 R2 fd1 fd2" and "body fd1 \<noteq> [] \<or> body fd2 \<noteq> []"
  shows "R1 (fst (hd (body fd1))) (fst (hd (body fd2)))"
  using assms
  unfolding fundef.rel_sel
  by (auto intro: list_all2_rel_prod_fst_hd[THEN conjunct1])

lemma map_option_comp_conv:
  assumes
    "\<And>x. rel_option R (f x) (g x)"
    "\<And>fd1 fd2. fd1 \<in> ran f \<Longrightarrow> fd2 \<in> ran g \<Longrightarrow> R fd1 fd2 \<Longrightarrow> h fd1 = i fd2"
  shows "map_option h \<circ> f = map_option i \<circ> g"
proof (intro ext)
  fix x
  show "(map_option h \<circ> f) x = (map_option i \<circ> g) x"
    using assms(1)[of x]
    by (cases rule: option.rel_cases) (auto intro: ranI assms(2))
qed

lemma map_option_arity_comp_conv:
  assumes "(\<And>x. rel_option (rel_fundef R S) (f x) (g x))"
  shows "map_option arity \<circ> f = map_option arity \<circ> g"
proof (rule map_option_comp_conv)
  fix x show "rel_option (rel_fundef R S) (f x) (g x)"
    by (rule assms(1))
next
  fix fd1 fd2
  show "rel_fundef R S fd1 fd2 \<Longrightarrow> arity fd1 = arity fd2 "
    by (rule rel_fundef_arities)
qed

definition wf_fundef where
  "wf_fundef fd \<longleftrightarrow> body fd \<noteq> []"

lemma wf_fundef_non_empty_bodyD[dest,intro]: "wf_fundef fd \<Longrightarrow> body fd \<noteq> []"
  by (simp add: wf_fundef_def)

definition wf_fundefs where
  "wf_fundefs F \<longleftrightarrow> (\<forall>f fd. F f = Some fd \<longrightarrow> wf_fundef fd)"

lemma wf_fundefsI:
  assumes "\<And>f fd. F f = Some fd \<Longrightarrow> wf_fundef fd"
  shows "wf_fundefs F"
  using assms by (simp add: wf_fundefs_def)

lemma wf_fundefsI':
  assumes "\<And>f. pred_option wf_fundef (F f)"
  shows "wf_fundefs F"
  using assms unfolding wf_fundefs_def
  by (metis option.pred_inject(2))

lemma wf_fundefs_imp_wf_fundef:
  assumes "wf_fundefs F" and "F f = Some fd"
  shows "wf_fundef fd"
  using assms by (simp add: wf_fundefs_def)

hide_fact wf_fundefs_def

subsection \<open>Program\<close>

datatype ('fenv, 'henv, 'fun) prog =
  Prog (prog_fundefs: 'fenv) (heap: 'henv) (main_fun: 'fun)

definition wf_prog where
  "wf_prog Get p \<longleftrightarrow> wf_fundefs (Get (prog_fundefs p))"

subsection \<open>Stack frame\<close>

datatype ('fun, 'label, 'operand) frame =
  Frame 'fun 'label (prog_counter: nat) (regs: "'operand list") (operand_stack: "'operand list")

definition instr_at where
  "instr_at fd label pc =
    (case map_of (body fd) label of
      Some instrs \<Rightarrow>
        if pc < length instrs then
          Some (instrs ! pc)
        else
          None
    | None \<Rightarrow> None)"

lemma instr_atD:
  assumes "instr_at fd l pc = Some instr"
  shows "\<exists>instrs. map_of (body fd) l = Some instrs \<and> pc < length instrs \<and> instrs ! pc = instr"
  using assms
  by (cases "map_of (body fd) l") (auto simp: instr_at_def)

lemma rel_fundef_imp_rel_option_instr_at:
  assumes "rel_fundef (=) R fd1 fd2"
  shows "rel_option R (instr_at fd1 l pc) (instr_at fd2 l pc)"
  using assms
proof (cases rule: fundef.rel_cases)
  case (Fundef bblocks1 _ _ bblocks2 )
  then show ?thesis
    by (auto simp: instr_at_def list_all2_lengthD
        intro: list_all2_nthD2 elim!: option.rel_cases dest!: rel_option_map_of[of _ _ _ l])
qed

definition next_instr where
  "next_instr F f label pc \<equiv> do {
    fd \<leftarrow> F f;
    instr_at fd label pc
  }"

lemma next_instr_eq_Some_conv:
  "next_instr F f l pc = Some instr \<longleftrightarrow> (\<exists>fd. F f = Some fd \<and> instr_at fd l pc = Some instr)"
  by (simp add: next_instr_def bind_eq_Some_conv)

lemma next_instrD:
  assumes "next_instr F f l pc = Some instr"
  shows "\<exists>fd. F f = Some fd \<and> instr_at fd l pc = Some instr"
  using assms unfolding next_instr_def
  by (cases "F f"; simp)

lemma next_instr_pc_lt_length_instrsI:
  assumes
    "next_instr F f l pc = Some instr" and
    "F f = Some fd" and
    "map_of (body fd) l = Some instrs"
  shows "pc < length instrs"
  using assms
  by (auto dest!: next_instrD instr_atD)

lemma next_instr_get_map_ofD:
  assumes
    "next_instr F f l pc = Some instr" and
    "F f = Some fd" and
    "map_of (body fd) l = Some instrs"
  shows "pc < length instrs" and "instrs ! pc = instr"
  using assms
  by (auto dest!: next_instrD instr_atD)

lemma next_instr_length_instrs:
  assumes
    "F f = Some fd" and
    "map_of (body fd) label = Some instrs"
  shows "next_instr F f label (length instrs) = None"
  by (simp add: assms next_instr_def instr_at_def)

lemma next_instr_take_Suc_conv:
  assumes "next_instr F f l pc = Some instr" and
    "F f = Some fd" and
    "map_of (body fd) l = Some instrs"
  shows "take (Suc pc) instrs = take pc instrs @ [instr]"
  using assms
  by (auto simp: take_Suc_conv_app_nth dest!: next_instrD instr_atD)

subsection \<open>Dynamic state\<close>

datatype ('fenv, 'henv, 'frame) state =
  State (state_fundefs: 'fenv) (heap: 'henv) (callstack: "'frame list")

definition state_ok where
  "state_ok Get s \<longleftrightarrow> wf_fundefs (Get (state_fundefs s))"

inductive final for F_get Return where
  finalI: "next_instr (F_get F) f l pc = Some Return \<Longrightarrow>
    final F_get Return (State F H [Frame f l pc R \<Sigma>])"

definition allocate_frame where
  "allocate_frame f fd args uninitialized \<equiv>
    Frame f (fst (hd (body fd))) 0 (args @ replicate (fundef_locals fd) uninitialized) []"

inductive load for F_get Uninitialized where
  "F_get F main = Some fd \<Longrightarrow> arity fd = 0 \<Longrightarrow> body fd \<noteq> [] \<Longrightarrow>
  load F_get Uninitialized (Prog F H main) (State F H [allocate_frame main fd [] Uninitialized])"

lemma length_neq_imp_not_list_all2:
  assumes "length xs \<noteq> length ys"
  shows "\<not> list_all2 R xs ys"
proof (rule notI)
  assume "list_all2 R xs ys"
  hence "length xs = length ys"
    by (rule list_all2_lengthD)
  thus False
    using assms by contradiction
qed

lemma list_all2_rel_prod_conv:
  "list_all2 (rel_prod R S) xs ys \<longleftrightarrow>
    list_all2 R (map fst xs) (map fst ys) \<and> list_all2 S (map snd xs) (map snd ys)"
proof (cases "length xs = length ys")
  case True
  then show ?thesis
    by (induction xs ys rule: list_induct2) (auto simp: rel_prod_sel)
next
  case False
  hence neq_length_maps:
      "length (map fst xs) \<noteq> length (map fst ys)"
      "length (map snd xs) \<noteq> length (map snd ys)"
    by simp_all
  show ?thesis
    using length_neq_imp_not_list_all2[OF False]
    using neq_length_maps[THEN length_neq_imp_not_list_all2]
    by simp
qed

definition rewrite_fundef_body ::
  "('label, 'instr) fundef \<Rightarrow> 'label \<Rightarrow> nat \<Rightarrow> 'instr \<Rightarrow> ('label, 'instr) fundef" where
  "rewrite_fundef_body fd l n instr =
    (case fd of Fundef bblocks ar ret locals \<Rightarrow>
      Fundef (AList.map_entry l (\<lambda>instrs. instrs[n := instr]) bblocks) ar ret locals)"

lemma rewrite_fundef_body_cases[case_names invalid_label valid_label]:
  assumes
    "\<And>bs ar ret locals. fd = Fundef bs ar ret locals \<Longrightarrow> map_of bs l = None \<Longrightarrow> P"
    "\<And>bs ar ret locals instrs. fd = Fundef bs ar ret locals \<Longrightarrow> map_of bs l = Some instrs \<Longrightarrow> P"
  shows "P"
  using assms
  by (cases fd; cases "map_of (body fd) l") auto

lemma arity_rewrite_fundef_body[simp]: "arity (rewrite_fundef_body fd l pc instr) = arity fd"
  by (cases fd; simp add: rewrite_fundef_body_def option.case_eq_if)

lemma return_rewrite_fundef_body[simp]: "return (rewrite_fundef_body fd l pc instr) = return fd"
  by (cases fd) (simp add: rewrite_fundef_body_def option.case_eq_if)

lemma funtype_rewrite_fundef_body[simp]: "funtype (rewrite_fundef_body fd l pc instr') = funtype fd"
  by (simp add: funtype_def)

lemma length_body_rewrite_fundef_body[simp]:
  "length (body (rewrite_fundef_body fd l pc instr)) = length (body fd)"
  by (cases fd) (simp add: rewrite_fundef_body_def)

lemma prod_in_set_fst_image_conv: "(x, y) \<in> set xys \<Longrightarrow> x \<in> fst ` set xys"
  by (metis fstI image_eqI)

lemma map_of_body_rewrite_fundef_body_conv_neq[simp]:
  assumes "l \<noteq> l'"
  shows "map_of (body (rewrite_fundef_body fd l pc instr)) l' = map_of (body fd) l'"
  using assms
  by (cases fd) (simp add: rewrite_fundef_body_def map_of_map_entry)

lemma map_of_body_rewrite_fundef_body_conv_eq[simp]:
  "map_of (body (rewrite_fundef_body fd l pc instr)) l =
   map_option (\<lambda>xs. xs[pc := instr]) (map_of (body fd) l)"
  by (cases fd) (simp add: rewrite_fundef_body_def map_of_map_entry map_option_case)

lemma instr_at_rewrite_fundef_body_conv:
  "instr_at (rewrite_fundef_body fd l' pc' instr') l pc =
    map_option (\<lambda>instr. if l = l' \<and> pc = pc' then instr' else instr) (instr_at fd l pc)"
proof (cases fd)
  case (Fundef bblocks ar ret locals)
  then show ?thesis
  proof (cases "instr_at fd l pc")
    case None
    then show ?thesis
      by (cases "map_of bblocks l")
        (auto simp add: Fundef rewrite_fundef_body_def instr_at_def map_of_map_entry)
  next
    case (Some instrs)
    then show ?thesis
      by (cases "map_of bblocks l")
        (auto simp add: Fundef rewrite_fundef_body_def instr_at_def map_of_map_entry)
  qed
qed

lemma fundef_locals_rewrite_fundef_body[simp]:
  "fundef_locals (rewrite_fundef_body fd l pc instr) = fundef_locals fd"
  by (cases fd; simp add: rewrite_fundef_body_def option.case_eq_if)

lemma rel_fundef_rewrite_body1:
  assumes
    rel_fd1_fd2: "rel_fundef (=) R fd1 fd2" and
    instr_at_l_pc: "instr_at fd1 l pc = Some instr" and
    R_iff: "\<And>x. R instr x \<longleftrightarrow> R instr' x"
  shows "rel_fundef (=) R (rewrite_fundef_body fd1 l pc instr') fd2"
  using assms(1)
proof (cases rule: fundef.rel_cases)
  case (Fundef xs ar' ret' locals' ys ar ret locals)
  show ?thesis
    using Fundef(3,3,1,2,4-) instr_at_l_pc
  proof (induction xs ys arbitrary: fd1 fd2 rule: list.rel_induct)
    case Nil
    then show ?case by (simp add: rewrite_fundef_body_def)
  next
    case (Cons x xs y ys)
    then show ?case
      apply (simp add: rewrite_fundef_body_def)
      apply safe
      using assms(3)
       apply (smt (verit, ccfv_SIG) fun_upd_apply fundef.sel(1) instr_atD list_all2_lengthD
          list_all2_nthD2 list_all2_update1_cong map_of.simps(2) option.simps(1) prod.sel(1,2)
          rel_prod_sel)
      by (simp add: instr_at_def)
  qed
qed

lemma rel_fundef_rewrite_body:
  assumes rel_fd1_fd2: "rel_fundef (=) R fd1 fd2" and R_i1_i2: "R i1 i2"
  shows "rel_fundef (=) R (rewrite_fundef_body fd1 l pc i1) (rewrite_fundef_body fd2 l pc i2)"
  using assms(1)
proof (cases rule: fundef.rel_cases)
  case (Fundef bblocks1 ar1 ret1 locals1 bblocks2 ar2 ret2 locals2)
  then show ?thesis
    using R_i1_i2
    by (auto simp: rewrite_fundef_body_def
      intro!: list_all2_update_cong
      intro!: list_all2_rel_prod_map_entry
      dest: rel_option_map_of[of _ _ _ l])
qed

lemma rewrite_fundef_body_triv:
  "instr_at fd l pc = Some instr \<Longrightarrow> rewrite_fundef_body fd l pc instr = fd"
  by (cases fd)
    (auto simp add: rewrite_fundef_body_def map_entry_map_of_Some_conv update_triv dest: instr_atD)

lemma rel_fundef_rewrite_body2:
  assumes
    rel_fd1_fd2: "rel_fundef (=) R fd1 fd2" and
    instr_at_l_pc: "instr_at fd2 l pc = Some instr" and
    R_iff: "\<And>x. R x instr \<longleftrightarrow> R x instr'"
  shows "rel_fundef (=) R fd1 (rewrite_fundef_body fd2 l pc instr')"
  using assms(1)
proof (cases rule: fundef.rel_cases)
  case (Fundef xs ar' ret' locals' ys ar ret locals)
  moreover obtain instrs2 where
    "map_of (body fd2) l = Some instrs2" and "pc < length instrs2" and "instrs2 ! pc = instr"
    using instr_atD[OF instr_at_l_pc] by auto
  moreover then obtain instrs1 instr1 where
    "map_of (body fd1) l = Some instrs1" and "pc < length instrs1" and "instrs1 ! pc = instr1"
    using rel_fundef_imp_rel_option_instr_at[OF rel_fd1_fd2, of l pc]
    apply (auto simp add: instr_at_def option_rel_Some2)
    by (metis instr_atD instr_at_def)
  moreover have "list_all2 R instrs1 instrs2"
    using Fundef \<open>map_of (body fd2) l = Some instrs2\<close> \<open>map_of (body fd1) l = Some instrs1\<close>
    by (auto dest: rel_option_map_of[of _ _ _ l])
  moreover hence "R (instrs1 ! pc) (instrs2 ! pc)"
    using \<open>pc < length instrs1\<close>
    by (auto intro: list_all2_nthD)
  ultimately show ?thesis
    by (auto simp: rewrite_fundef_body_def R_iff
          intro!: list_all2_rel_prod_map_entry2
          intro: list_all2_update2_cong)
qed

lemma rel_fundef_rewrite_body2':
  assumes
    rel_fd1_fd2: "rel_fundef (=) R fd1 fd2" and
    instr_at1: "instr_at fd1 l pc = Some instr1" and
    R_instr1_instr2: "R instr1 instr2'"
  shows "rel_fundef (=) R fd1 (rewrite_fundef_body fd2 l pc instr2')"
  using assms(1)
proof (cases rule: fundef.rel_cases)
  case (Fundef bblocks1 ar1 ret1 locals1 bblocks2 ar2 ret2 locals2)
  moreover obtain instrs1 where
    "map_of bblocks1 l = Some instrs1" and "pc < length instrs1" and "instrs1 ! pc = instr1"
    using Fundef instr_at1[THEN instr_atD] by auto

  moreover then obtain instrs2 instr2 where
    "map_of (body fd2) l = Some instrs2" and "pc < length instrs2" and "instrs2 ! pc = instr2"
    using Fundef rel_fd1_fd2
    apply (auto simp: option_rel_Some1 dest!: rel_option_map_of[where l = l])
    by (metis list_all2_lengthD)
  ultimately show ?thesis
    using R_instr1_instr2
    by (auto simp: rewrite_fundef_body_def
          intro!: list_all2_update2_cong list_all2_rel_prod_map_entry2
          dest: rel_option_map_of[of _ _ _ l])
qed

thm rel_fundef_rewrite_body

lemma if_eq_const_conv: "(if x then y else z) = w \<longleftrightarrow> x \<and> y = w \<or> \<not> x \<and> z = w"
  by simp

lemma const_eq_if_conv: "w = (if x then y else z) \<longleftrightarrow> x \<and> w = y \<or> \<not> x \<and> w = z"
  by auto

end