subsection \<open>Heap Memory Implementations\<close>

theory Memory_Heap
  imports State_Heap DP_CRelVH Pair_Memory "HOL-Eisbach.Eisbach" "../Indexing"
begin

text \<open>Move\<close>
abbreviation "result_of c h \<equiv> fst (the (execute c h))"
abbreviation "heap_of   c h \<equiv> snd (the (execute c h))"

lemma map_emptyI:
  "m \<subseteq>\<^sub>m Map.empty" if "\<And> x. m x = None"
  using that unfolding map_le_def by auto

lemma result_of_return[simp]:
  "result_of (Heap_Monad.return x) h = x"
  by (simp add: execute_simps)

lemma get_result_of_lookup:
  "result_of (!r) heap = x" if "Ref.get heap r = x"
  using that by (auto simp: execute_simps)

context
  fixes size :: nat
    and to_index :: "('k2 :: heap) \<Rightarrow> nat"
begin

definition
  "mem_empty = (Array.new size (None :: ('v :: heap) option))"

lemma success_empty[intro]:
  "success mem_empty heap"
  unfolding mem_empty_def by (auto intro: success_intros)

lemma length_mem_empty:
  "Array.length
    (heap_of (mem_empty:: (('b :: heap) option array) Heap) h)
    (result_of (mem_empty :: ('b option array) Heap) h) = size"
  unfolding mem_empty_def by (auto simp: execute_simps Array.length_alloc)

lemma nth_mem_empty:
  "result_of
    (Array.nth (result_of (mem_empty :: ('b option array) Heap) h) i)
    (heap_of (mem_empty :: (('b :: heap) option array) Heap) h) = None" if "i < size"
  apply (subst execute_nth(1))
  apply (simp add: length_mem_empty that)
  apply (simp add: execute_simps mem_empty_def Array.get_alloc that)
  done

context
  fixes mem :: "('v :: heap) option array"
begin

definition
  "mem_lookup k = (let i = to_index k in
    if i < size then Array.nth mem i else return None
  )"

definition
  "mem_update k v = (let i = to_index k in
    if i < size then (Array.upd i (Some v) mem \<bind> (\<lambda> _. return ()))
    else return ()
  )
  "

context assumes injective: "injective size to_index"
begin

interpretation heap_correct "\<lambda>heap. Array.length heap mem = size" mem_update mem_lookup
  apply standard
  subgoal lookup_inv
    unfolding State_Heap.lift_p_def mem_lookup_def by (simp add: Let_def execute_simps)
  subgoal update_inv
    unfolding State_Heap.lift_p_def mem_update_def by (simp add: Let_def execute_simps)
  subgoal for k heap
    unfolding heap_mem_defs.map_of_heap_def map_le_def mem_lookup_def
    by (auto simp: execute_simps Let_def split: if_split_asm)
  subgoal for heap k
    unfolding heap_mem_defs.map_of_heap_def map_le_def mem_lookup_def mem_update_def
    apply (auto simp: execute_simps Let_def length_def split: if_split_asm)
    apply (subst (asm) nth_list_update_neq)
    using injective[unfolded injective_def] apply auto
    done
  done

lemmas mem_heap_correct = heap_correct_axioms

context
  assumes [simp]: "mem = result_of mem_empty Heap.empty"
begin

interpretation heap_correct_empty
  "\<lambda>heap. Array.length heap mem = size" mem_update mem_lookup
  "heap_of (mem_empty :: 'v option array Heap) Heap.empty"
  apply standard
  subgoal
    apply (rule map_emptyI)
    unfolding map_of_heap_def mem_lookup_def by (auto simp: Let_def nth_mem_empty)
  subgoal
    by (simp add: length_mem_empty)
  done

lemmas array_heap_emptyI = heap_correct_empty_axioms

context
  fixes dp :: "'k2 \<Rightarrow> 'v"
begin

interpretation dp_consistency_heap_empty
  "\<lambda>heap. Array.length heap mem = size" mem_update mem_lookup dp
  "heap_of (mem_empty :: 'v option array Heap) Heap.empty"
  by standard

lemmas array_consistentI = dp_consistency_heap_empty_axioms

end

end (* Empty Memory *)

end (* Injectivity *)

end (* Fixed array *)

lemma execute_bind_success':
  assumes "success f h" "execute (f \<bind> g) h = Some (y, h'')"
  obtains x h' where "execute f h = Some (x, h')" "execute (g x) h' = Some (y, h'')"
  using assms by (auto simp: execute_simps elim: successE)

lemma success_bind_I:
  assumes "success f h"
    and "\<And> x h'. execute f h = Some (x, h') \<Longrightarrow> success (g x) h'"
  shows "success (f \<bind> g) h"
  by (rule successE[OF assms(1)]) (auto elim: assms(2) intro: success_bind_executeI)

definition
  "alloc_pair a b \<equiv> do {
    r1 \<leftarrow> ref a;
    r2 \<leftarrow> ref b;
    return (r1, r2)
  }"

lemma alloc_pair_alloc:
  "Ref.get heap' r1 = a" "Ref.get heap' r2 = b"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis Ref.get_alloc fst_conv get_alloc_neq next_present present_alloc_neq snd_conv)+

lemma alloc_pairD1:
  "r =!= r1 \<and> r =!= r2 \<and> Ref.present heap' r"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')" "Ref.present heap r"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis next_fresh noteq_I Ref.present_alloc snd_conv)+

lemma alloc_pairD2:
  "r1 =!= r2 \<and> Ref.present heap' r2 \<and> Ref.present heap' r1"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis next_fresh next_present noteq_I Ref.present_alloc snd_conv)+

lemma alloc_pairD3:
  "Array.present heap' r"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')" "Array.present heap r"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis array_present_alloc snd_conv)

lemma alloc_pairD4:
  "Ref.get heap' r = x"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
     "Ref.get heap r = x" "Ref.present heap r"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis Ref.not_present_alloc Ref.present_alloc get_alloc_neq noteq_I snd_conv)

lemma alloc_pair_array_get:
  "Array.get heap' r = x"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')" "Array.get heap r = x"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
 (metis array_get_alloc snd_conv)

lemma alloc_pair_array_length:
  "Array.length heap' r = Array.length heap r"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis Ref.length_alloc snd_conv)

lemma alloc_pair_nth:
  "result_of (Array.nth r i) heap' = result_of (Array.nth r i) heap"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
  using alloc_pair_array_get[OF that(1) HOL.refl, of r] alloc_pair_array_length[OF that(1), of r]
  by (cases "(\<lambda>h. i < Array.length h r) heap"; simp add: execute_simps Array.nth_def)

lemma succes_alloc_pair[intro]:
  "success (alloc_pair a b) heap"
  unfolding alloc_pair_def by (auto intro: success_intros success_bind_I)

definition
  "init_state_inner k1 k2 m1 m2 \<equiv>  do {
    (k_ref1, k_ref2) \<leftarrow> alloc_pair k1 k2;
    (m_ref1, m_ref2) \<leftarrow> alloc_pair m1 m2;
    return (k_ref1, k_ref2, m_ref1, m_ref2)
  }
  "

lemma init_state_inner_alloc:
  assumes
    "execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Ref.get heap' k_ref1 = k1" "Ref.get heap' k_ref2 = k2"
    "Ref.get heap' m_ref1 = m1" "Ref.get heap' m_ref2 = m2"
  using assms unfolding init_state_inner_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair])
     (auto intro: alloc_pair_alloc dest: alloc_pairD2 elim: alloc_pairD4)

lemma init_state_inner_distinct:
  assumes
    "execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "m_ref1 =!= m_ref2 \<and> m_ref1 =!= k_ref1 \<and> m_ref1 =!= k_ref2 \<and> m_ref2 =!= k_ref1
   \<and> m_ref2 =!= k_ref2 \<and> k_ref1 =!= k_ref2"
  using assms unfolding init_state_inner_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair])
     (blast dest: alloc_pairD1 alloc_pairD2 intro: noteq_sym)+

lemma init_state_inner_present:
  assumes
    "execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Ref.present heap' k_ref1" "Ref.present heap' k_ref2"
    "Ref.present heap' m_ref1" "Ref.present heap' m_ref2"
  using assms unfolding init_state_inner_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair])
     (blast dest: alloc_pairD1 alloc_pairD2)+

lemma inite_state_inner_present':
  assumes
    "execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
    "Array.present heap a"
  shows
    "Array.present heap' a"
    using assms unfolding init_state_inner_def
    by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair] alloc_pairD3)

lemma succes_init_state_inner[intro]:
  "success (init_state_inner k1 k2 m1 m2) heap"
  unfolding init_state_inner_def by (auto 4 3 intro: success_intros success_bind_I)

lemma init_state_inner_nth:
  "result_of (Array.nth r i) heap' = result_of (Array.nth r i) heap"
  if "execute (init_state_inner k1 k2 m1 m2) heap = Some ((r1, r2), heap')"
  using that unfolding init_state_inner_def
  by (auto simp: execute_simps alloc_pair_nth elim!: execute_bind_success'[OF succes_alloc_pair])

definition
  "init_state k1 k2 \<equiv> do {
    m1 \<leftarrow> mem_empty;
    m2 \<leftarrow> mem_empty;
    init_state_inner k1 k2 m1 m2
  }"

definition
  "inv_distinct k_ref1 k_ref2 m_ref1 m_ref2 \<equiv>
     m_ref1 =!= m_ref2 \<and> m_ref1 =!= k_ref1 \<and> m_ref1 =!= k_ref2 \<and> m_ref2 =!= k_ref1
   \<and> m_ref2 =!= k_ref2 \<and> k_ref1 =!= k_ref2
  "

lemma init_state_distinct:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "inv_distinct k_ref1 k_ref2 m_ref1 m_ref2"
  using assms unfolding init_state_def inv_distinct_def
  by (elim execute_bind_success'[OF success_empty] init_state_inner_distinct)

lemma init_state_present:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Ref.present heap' k_ref1" "Ref.present heap' k_ref2"
    "Ref.present heap' m_ref1" "Ref.present heap' m_ref2"
  using assms unfolding init_state_def
  by (auto
        simp: execute_simps elim!: execute_bind_success'[OF success_empty]
        dest: init_state_inner_present
     )

lemma empty_present:
  "Array.present h' x" if "execute mem_empty heap = Some (x, h')"
  using that unfolding mem_empty_def
  by (auto simp: execute_simps) (metis Array.present_alloc fst_conv snd_conv)

lemma empty_present':
  "Array.present h' a" if "execute mem_empty heap = Some (x, h')" "Array.present heap a"
  using that unfolding mem_empty_def
  by (auto simp: execute_simps Array.present_def Array.alloc_def Array.set_def Let_def)

lemma init_state_present2:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Array.present heap' (Ref.get heap' m_ref1)" "Array.present heap' (Ref.get heap' m_ref2)"
  using assms unfolding init_state_def
  by (auto 4 3
        simp: execute_simps init_state_inner_alloc elim!: execute_bind_success'[OF success_empty]
        dest: inite_state_inner_present' empty_present empty_present'
     )

lemma init_state_neq:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Ref.get heap' m_ref1 =!!= Ref.get heap' m_ref2"
  using assms unfolding init_state_def
  by (auto 4 3
        simp: execute_simps init_state_inner_alloc elim!: execute_bind_success'[OF success_empty]
        dest: inite_state_inner_present' empty_present empty_present'
     )
    (metis empty_present execute_new fst_conv mem_empty_def option.inject present_alloc_noteq)

lemma present_alloc_get:
  "Array.get heap' a = Array.get heap a"
  if "Array.alloc xs heap = (a', heap')" "Array.present heap a"
  using that by (auto simp: Array.alloc_def Array.present_def Array.get_def Let_def Array.set_def)

lemma init_state_length:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Array.length heap' (Ref.get heap' m_ref1) = size"
    "Array.length heap' (Ref.get heap' m_ref2) = size"
  using assms unfolding init_state_def
  apply (auto
        simp: execute_simps init_state_inner_alloc elim!: execute_bind_success'[OF success_empty]
        dest: inite_state_inner_present' empty_present empty_present'
     )
   apply (auto
      simp: execute_simps init_state_inner_def alloc_pair_def mem_empty_def Array.length_def
      elim!: execute_bind_success'[OF success_refI]
     )
  apply (metis
      Array.alloc_def Array.get_set_eq Array.present_alloc array_get_alloc fst_conv length_replicate
      present_alloc_get snd_conv
     )+
  done

context
  fixes key1 :: "'k \<Rightarrow> ('k1 :: heap)" and key2 :: "'k \<Rightarrow> 'k2"
    and m_ref1 m_ref2 :: "('v :: heap) option array ref"
    and k_ref1 k_ref2 :: "('k1 :: heap) ref"
begin

text \<open>We assume that look-ups happen on the older row, so this is biased towards the second entry.\<close>
definition
  "lookup_pair k = do {
    let k' = key1 k;
    k2 \<leftarrow> !k_ref2;
    if k' = k2 then
      do {
        m2 \<leftarrow> !m_ref2;
        mem_lookup m2 (key2 k)
      }
    else
      do {
      k1 \<leftarrow> !k_ref1;
      if k' = k1 then
        do {
          m1 \<leftarrow> !m_ref1;
          mem_lookup m1 (key2 k)
        }
      else
        return None
    }
  }
   "

text \<open>We assume that updates happen on the newer row, so this is biased towards the first entry.\<close>
definition
  "update_pair k v = do {
    let k' = key1 k;
      k1 \<leftarrow> !k_ref1;
      if k' = k1 then do {
        m \<leftarrow> !m_ref1;
        mem_update m (key2 k) v
      }
      else do {
        k2 \<leftarrow> !k_ref2;
        if k' = k2 then do {
          m \<leftarrow> !m_ref2;
          mem_update m (key2 k) v
        }
        else do {
          do {
            k1 \<leftarrow> !k_ref1;
            m \<leftarrow> mem_empty;
            m1 \<leftarrow> !m_ref1;
            k_ref2 := k1;
            k_ref1 := k';
            m_ref2 := m1;
            m_ref1 := m
          }
        ;
        m \<leftarrow> !m_ref1;
        mem_update m (key2 k) v
      }
    }
   }
   "

definition
  "inv_pair_weak heap = (
    let
      m1 = Ref.get heap m_ref1;
      m2 = Ref.get heap m_ref2
    in Array.length heap m1 = size \<and> Array.length heap m2 = size
      \<and> Ref.present heap k_ref1 \<and> Ref.present heap k_ref2
      \<and> Ref.present heap m_ref1 \<and> Ref.present heap m_ref2
      \<and> Array.present heap m1 \<and> Array.present heap m2
      \<and> m1 =!!= m2
  )"

(* TODO: Remove? *)
definition
  "inv_pair heap \<equiv> inv_pair_weak heap \<and> inv_distinct k_ref1 k_ref2 m_ref1 m_ref2"

lemma init_state_inv:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows "inv_pair_weak heap'"
  using assms unfolding inv_pair_weak_def Let_def
  by (auto intro:
      init_state_present init_state_present2 init_state_neq init_state_length
      init_state_distinct
     )

lemma inv_pair_lengthD1:
  "Array.length heap (Ref.get heap m_ref1) = size" if "inv_pair_weak heap"
  using that unfolding inv_pair_weak_def by (auto simp: Let_def)

lemma inv_pair_lengthD2:
  "Array.length heap (Ref.get heap m_ref2) = size" if "inv_pair_weak heap"
  using that unfolding inv_pair_weak_def by (auto simp: Let_def)

lemma inv_pair_presentD:
  "Array.present heap (Ref.get heap m_ref1)" "Array.present heap (Ref.get heap m_ref2)"
  if "inv_pair_weak heap"
  using that unfolding inv_pair_weak_def by (auto simp: Let_def)

lemma inv_pair_presentD2:
  "Ref.present heap m_ref1" "Ref.present heap m_ref2"
  "Ref.present heap k_ref1" "Ref.present heap k_ref2"
  if "inv_pair_weak heap"
  using that unfolding inv_pair_weak_def by (auto simp: Let_def)

lemma inv_pair_not_eqD:
  "Ref.get heap m_ref1 =!!= Ref.get heap m_ref2" if "inv_pair_weak heap"
  using that unfolding inv_pair_weak_def by (auto simp: Let_def)

definition "lookup1 k \<equiv> state_of (do {m \<leftarrow> !m_ref1; mem_lookup m k})"

definition "lookup2 k \<equiv> state_of (do {m \<leftarrow> !m_ref2; mem_lookup m k})"

definition "update1 k v \<equiv> state_of (do {m \<leftarrow> !m_ref1; mem_update m k v})"

definition "update2 k v \<equiv> state_of (do {m \<leftarrow> !m_ref2; mem_update m k v})"

definition "move12 k \<equiv> state_of (do {
    k1 \<leftarrow> !k_ref1;
    m \<leftarrow> mem_empty;
    m1 \<leftarrow> !m_ref1;
    k_ref2 := k1;
    k_ref1 := k;
    m_ref2 := m1;
    m_ref1 := m
  })
  "

definition "get_k1 \<equiv> state_of (!k_ref1)"

definition "get_k2 \<equiv> state_of (!k_ref2)"

lemma run_state_state_of[simp]:
  "State_Monad.run_state (state_of p) m = the (execute p m)"
  unfolding state_of_def by simp

context assumes injective: "injective size to_index"
begin

context
  assumes inv_distinct: "inv_distinct k_ref1 k_ref2 m_ref1 m_ref2"
begin

lemma disjoint[simp]:
  "m_ref1 =!= m_ref2" "m_ref1 =!= k_ref1" "m_ref1 =!= k_ref2"
  "m_ref2 =!= k_ref1" "m_ref2 =!= k_ref2"
  "k_ref1 =!= k_ref2"
  using inv_distinct unfolding inv_distinct_def by auto

lemmas [simp] = disjoint[THEN noteq_sym]

lemma [simp]:
  "Ref.get (snd (Array.alloc xs heap)) r = Ref.get heap r" if "Ref.present heap r"
  using that unfolding Array.alloc_def Ref.present_def
  by (simp add: Let_def Ref.get_def Array.set_def)

lemma alloc_present':
  "Ref.present (snd (Array.alloc xs heap)) r" if "Ref.present heap r"
  using that unfolding Ref.present_def Array.alloc_def by (simp add: Let_def Array.set_def)

lemma length_get_upd[simp]:
  "length (Array.get (Array.update a i x heap) r) = length (Array.get heap r)"
  unfolding Array.get_def Array.update_def Array.set_def by simp

method solve1 =
  (frule inv_pair_lengthD1, frule inv_pair_lengthD2, frule inv_pair_not_eqD)?,
  auto split: if_split_asm dest: Array.noteq_sym

interpretation pair: pair_mem lookup1 lookup2 update1 update2 move12 get_k1 get_k2 inv_pair_weak
  supply [simp] =
    mem_empty_def state_mem_defs.map_of_def map_le_def
    move12_def update1_def update2_def lookup1_def lookup2_def get_k1_def get_k2_def
    mem_update_def mem_lookup_def
    execute_bind_success[OF success_newI] execute_simps Let_def Array.get_alloc length_def
    inv_pair_presentD inv_pair_presentD2
    Memory_Heap.lookup1_def Memory_Heap.lookup2_def Memory_Heap.mem_lookup_def
  apply standard
                      apply (solve1; fail)+
  subgoal
    apply (rule lift_pI)
    unfolding inv_pair_weak_def
    apply (auto simp:
        intro: alloc_present alloc_present'
        elim: present_alloc_noteq[THEN Array.noteq_sym]
        )
    done
                     apply (rule lift_pI, unfold inv_pair_weak_def, auto split: if_split_asm; fail)+
                 apply (solve1; fail)+
  subgoal
    using injective[unfolded injective_def] by - (solve1, subst (asm) nth_list_update_neq, auto)
  subgoal
    using injective[unfolded injective_def] by - (solve1, subst (asm) nth_list_update_neq, auto)
   apply (solve1; fail)+
  done

lemmas mem_correct_pair = pair.mem_correct_pair

definition
  "mem_lookup1 k = do {m \<leftarrow> !m_ref1; mem_lookup m k}"

definition
  "mem_lookup2 k = do {m \<leftarrow> !m_ref2; mem_lookup m k}"

definition "get_k1' \<equiv> !k_ref1"

definition "get_k2' \<equiv> !k_ref2"

definition "update1' k v \<equiv> do {m \<leftarrow> !m_ref1; mem_update m k v}"

definition "update2' k v \<equiv> do {m \<leftarrow> !m_ref2; mem_update m k v}"

definition "move12' k \<equiv> do {
    k1 \<leftarrow> !k_ref1;
    m \<leftarrow> mem_empty;
    m1 \<leftarrow> !m_ref1;
    k_ref2 := k1;
    k_ref1 := k;
    m_ref2 := m1;
    m_ref1 := m
  }"

interpretation heap_mem_defs inv_pair_weak lookup_pair update_pair .

lemma rel_state_ofI:
  "rel_state (=) (state_of m) m" if
  "\<forall> heap. inv_pair_weak heap \<longrightarrow> success m heap"
  "lift_p inv_pair_weak m"
  using that unfolding rel_state_def
  by (auto split: option.split intro: lift_p_P'' simp: success_def)

lemma inv_pair_iff:
  "inv_pair_weak = inv_pair"
  unfolding inv_pair_def using inv_distinct by simp

lemma lift_p_inv_pairI:
  "State_Heap.lift_p inv_pair m" if "State_Heap.lift_p inv_pair_weak m"
  using that unfolding inv_pair_iff by simp

lemma lift_p_success:
  "State_Heap.lift_p inv_pair_weak m"
  if "DP_CRelVS.lift_p inv_pair_weak (state_of m)" "\<forall> heap. inv_pair_weak heap \<longrightarrow> success m heap"
  using that
  unfolding lift_p_def DP_CRelVS.lift_p_def
  by (auto simp: success_def split: option.split)

lemma rel_state_ofI2:
  "rel_state (=) (state_of m) m" if
  "\<forall> heap. inv_pair_weak heap \<longrightarrow> success m heap"
  "DP_CRelVS.lift_p inv_pair_weak (state_of m)"
  using that by (blast intro: rel_state_ofI lift_p_success)

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  "((=) ===> rel_state (rel_option (=))) lookup1 mem_lookup1"
  unfolding lookup1_def mem_lookup1_def
  apply (intro rel_funI)
  apply (simp add: option.rel_eq)
  apply (rule rel_state_ofI2)
  subgoal
    by (auto 4 4
        simp: mem_lookup_def inv_pair_lengthD1 execute_simps Let_def
        intro: success_bind_executeI success_returnI Array.success_nthI
       )
  subgoal
    using pair.lookup_inv(1) unfolding lookup1_def .
  done

lemma [transfer_rule]:
  "((=) ===> rel_state (rel_option (=))) lookup2 mem_lookup2"
  unfolding lookup2_def mem_lookup2_def
  apply (intro rel_funI)
  apply (simp add: option.rel_eq)
  apply (rule rel_state_ofI2)
  subgoal
    by (auto 4 3
        simp: mem_lookup_def inv_pair_lengthD2 execute_simps Let_def
        intro: success_intros intro!: success_bind_I
       )
  subgoal
    using pair.lookup_inv(2) unfolding lookup2_def .
  done

lemma [transfer_rule]:
  "rel_state (=) get_k1 get_k1'"
  unfolding get_k1_def get_k1'_def
  apply (rule rel_state_ofI2)
  subgoal
    by (auto intro: success_lookupI)
  subgoal
    unfolding get_k1_def[symmetric] by (auto dest: pair.get_state(1) intro: lift_pI)
  done

lemma [transfer_rule]:
  "rel_state (=) get_k2 get_k2'"
  unfolding get_k2_def get_k2'_def
  apply (rule rel_state_ofI2)
  subgoal
    by (auto intro: success_lookupI)
  subgoal
    unfolding get_k2_def[symmetric] by (auto dest: pair.get_state(2) intro: lift_pI)
  done

lemma [transfer_rule]:
  "((=) ===> (=) ===> rel_state (=)) update1 update1'"
  unfolding update1_def update1'_def
  apply (intro rel_funI)
  apply simp
  apply (rule rel_state_ofI2)
  subgoal
    by (auto 4 3
        simp: mem_update_def inv_pair_lengthD1 execute_simps Let_def
        intro: success_intros intro!: success_bind_I
       )
  subgoal
    using pair.update_inv(1) unfolding update1_def .
  done

lemma [transfer_rule]:
  "((=) ===> (=) ===> rel_state (=)) update2 update2'"
  unfolding update2_def update2'_def
  apply (intro rel_funI)
  apply simp
  apply (rule rel_state_ofI2)
  subgoal
    by (auto 4 3
        simp: mem_update_def inv_pair_lengthD2 execute_simps Let_def
        intro: success_intros intro!: success_bind_I
       )
  subgoal
    using pair.update_inv(2) unfolding update2_def .
  done

lemma [transfer_rule]:
  "((=) ===> rel_state (rel_option (=))) lookup1 mem_lookup1"
  unfolding lookup1_def mem_lookup1_def
  apply (intro rel_funI)
  apply (simp add: option.rel_eq)
  apply (rule rel_state_ofI2)
  subgoal
    by (auto 4 3
        simp: mem_lookup_def inv_pair_lengthD1 execute_simps Let_def
        intro: success_intros intro!: success_bind_I
       )
  subgoal
    using pair.lookup_inv(1) unfolding lookup1_def .
  done

lemma rel_state_lookup:
  "((=) ===> rel_state (=)) pair.lookup_pair lookup_pair"
  unfolding pair.lookup_pair_def lookup_pair_def
  unfolding
    mem_lookup1_def[symmetric] mem_lookup2_def[symmetric]
    get_k2_def[symmetric] get_k2'_def[symmetric]
    get_k1_def[symmetric] get_k1'_def[symmetric]
  by transfer_prover

lemma rel_state_update:
  "((=) ===> (=) ===> rel_state (=)) pair.update_pair update_pair"
  unfolding pair.update_pair_def update_pair_def
  unfolding move12'_def[symmetric]
  unfolding
    update1'_def[symmetric] update2'_def[symmetric]
    get_k2_def[symmetric] get_k2'_def[symmetric]
    get_k1_def[symmetric] get_k1'_def[symmetric]
  by transfer_prover

interpretation mem: heap_mem_defs pair.inv_pair lookup_pair update_pair .

lemma inv_pairD:
  "inv_pair_weak heap" if "pair.inv_pair heap"
  using that unfolding pair.inv_pair_def by (auto simp: Let_def)

lemma mem_rel_state_ofI:
  "mem.rel_state (=) m' m" if
  "rel_state (=) m' m"
  "\<And> heap. pair.inv_pair heap \<Longrightarrow>
    (case State_Monad.run_state m' heap of (_, heap) \<Rightarrow> inv_pair_weak heap \<longrightarrow> pair.inv_pair heap)"
proof -
  show ?thesis
    apply (rule mem.rel_state_intro)
    subgoal for heap v heap'
      by (auto elim: rel_state_elim[OF that(1)] dest!: inv_pairD)
    subgoal premises prems for heap v heap'
    proof -
      from prems that(1) have "inv_pair_weak heap'"
        by (fastforce elim: rel_state_elim dest: inv_pairD)
      with prems show ?thesis
        by (auto dest: that(2))
    qed
    done
qed

lemma mem_rel_state_ofI':
  "mem.rel_state (=) m' m" if
  "rel_state (=) m' m"
  "DP_CRelVS.lift_p pair.inv_pair m'"
  using that by (auto elim: DP_CRelVS.lift_p_P intro: mem_rel_state_ofI)

context
  assumes keys: "\<forall>k k'. key1 k = key1 k' \<and> key2 k = key2 k' \<longrightarrow> k = k'"
begin

interpretation mem_correct pair.lookup_pair pair.update_pair pair.inv_pair
  by (rule mem_correct_pair[OF keys])

lemma rel_state_lookup':
  "((=) ===> mem.rel_state (=)) pair.lookup_pair lookup_pair"
  apply (intro rel_funI)
  apply simp
  apply (rule mem_rel_state_ofI')
  using rel_state_lookup apply (rule rel_funD) apply (rule refl)
  apply (rule lookup_inv)
  done

lemma rel_state_update':
  "((=) ===> (=) ===> mem.rel_state (=)) pair.update_pair update_pair"
  apply (intro rel_funI)
  apply simp
  apply (rule mem_rel_state_ofI')
  subgoal for x y a b
    using rel_state_update by (blast dest: rel_funD)
  by (rule update_inv)

interpretation heap_correct pair.inv_pair update_pair lookup_pair
  by (rule mem.mem_correct_heap_correct[OF _ rel_state_lookup' rel_state_update']) standard

lemmas heap_correct_pairI = heap_correct_axioms

(* TODO: Generalize *)
lemma mem_rel_state_resultD:
  "result_of m heap = fst (run_state m' heap)" if "mem.rel_state (=) m' m" "pair.inv_pair heap"
  by (metis (mono_tags, lifting) mem.rel_state_elim option.sel that)

lemma map_of_heap_eq:
  "mem.map_of_heap heap = pair.pair.map_of heap" if "pair.inv_pair heap"
  unfolding mem.map_of_heap_def pair.pair.map_of_def
  using that by (simp add: mem_rel_state_resultD[OF rel_state_lookup'[THEN rel_funD]])

context
  fixes k1 k2 heap heap'
  assumes init: "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
begin

lemma init_state_empty1:
  "pair.mem1.map_of heap' k = None"
  using init
  unfolding pair.mem1.map_of_def lookup1_def mem_lookup_def init_state_def
  by (auto
        simp: init_state_inner_nth init_state_inner_alloc(3) execute_simps Let_def
        elim!: execute_bind_success'[OF success_empty])
     (metis
        Array.present_alloc Memory_Heap.length_mem_empty execute_new execute_nth(1) fst_conv
        length_def mem_empty_def nth_mem_empty option.sel present_alloc_get snd_conv
     )

lemma init_state_empty2:
  "pair.mem2.map_of heap' k = None"
  using init
  unfolding pair.mem2.map_of_def lookup2_def mem_lookup_def init_state_def
  by (auto
        simp: execute_simps init_state_inner_nth init_state_inner_alloc(4) Let_def
        elim!: execute_bind_success'[OF success_empty]
     )
     (metis fst_conv nth_mem_empty option.sel snd_conv)

lemma
  shows init_state_k1: "result_of (!k_ref1) heap' = k1"
    and init_state_k2: "result_of (!k_ref2) heap' = k2"
  using init init_state_inner_alloc
  by (auto simp: execute_simps init_state_def elim!: execute_bind_success'[OF success_empty])

context
  assumes neq: "k1 \<noteq> k2"
begin

lemma init_state_inv':
  "pair.inv_pair heap'"
  unfolding pair.inv_pair_def
  apply (auto simp: Let_def)
  subgoal
    using init_state_empty1 by simp
  subgoal
    using init_state_empty2 by simp
  subgoal
    using neq init by (simp add: get_k1_def get_k2_def init_state_k1 init_state_k2)
  subgoal
    by (rule init_state_inv[OF init])
  done

lemma init_state_empty:
  "pair.pair.map_of heap' \<subseteq>\<^sub>m Map.empty"
  using neq by (intro pair.emptyI init_state_inv' map_emptyI init_state_empty1 init_state_empty2)

interpretation heap_correct_empty pair.inv_pair update_pair lookup_pair heap'
  apply (rule heap_correct_empty.intro)
   apply (rule heap_correct_pairI)
  apply standard
  subgoal
    by (subst map_of_heap_eq; intro init_state_inv' init_state_empty)
  subgoal
    by (rule init_state_inv')
  done

lemmas heap_correct_empty_pairI = heap_correct_empty_axioms

context
  fixes dp :: "'k \<Rightarrow> 'v"
begin

interpretation dp_consistency_heap_empty
  pair.inv_pair update_pair lookup_pair dp heap'
  by standard

lemmas consistent_empty_pairI = dp_consistency_heap_empty_axioms

end (* DP *)

end (* Unequal Keys *)

end (* Init State *)

end (* Keys injective *)

end (* Lifting Syntax *)

end (* Disjoint *)

end (* Injectivity *)

end (* Refs *)

end (* Key functions & Size *)

end (* Theory *)


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section \<open>\isaheader{Additions to RB-Trees}\<close>
theory RBT_add
imports
  "HOL-Library.RBT_Impl"
  "../Iterator/Iterator"
begin
text_raw \<open>\label{thy:RBT_add}\<close>

lemma tlt_trans: "\<lbrakk>l |\<guillemotleft> u; u\<le>v\<rbrakk> \<Longrightarrow> l |\<guillemotleft> v"
  by (induct l) auto

lemma trt_trans: "\<lbrakk> u\<le>v; v\<guillemotleft>|r \<rbrakk> \<Longrightarrow> u\<guillemotleft>|r"
  by (induct r) auto

lemmas tlt_trans' = tlt_trans[OF _ less_imp_le]
lemmas trt_trans' = trt_trans[OF less_imp_le]

primrec rm_iterateoi
  :: "('k,'v) RBT_Impl.rbt \<Rightarrow> ('k \<times> 'v, '\<sigma>) set_iterator"
  where
  "rm_iterateoi RBT_Impl.Empty c f \<sigma> = \<sigma>" |
  "rm_iterateoi (RBT_Impl.Branch col l k v r) c f \<sigma> = (
    if (c \<sigma>) then
      let \<sigma>' = rm_iterateoi l c f \<sigma> in
        if (c \<sigma>') then
          rm_iterateoi r c f (f (k, v) \<sigma>')
        else \<sigma>'
    else
      \<sigma>
  )"

lemma rm_iterateoi_abort :
  "\<not>(c \<sigma>) \<Longrightarrow> rm_iterateoi t c f \<sigma> = \<sigma>"
by (cases t) auto

lemma rm_iterateoi_alt_def :
  "rm_iterateoi RBT_Impl.Empty = set_iterator_emp"
  "rm_iterateoi (RBT_Impl.Branch col l k v r) =
   set_iterator_union (rm_iterateoi l)
     (set_iterator_union (set_iterator_sng (k, v)) (rm_iterateoi r))"
by (simp_all add: fun_eq_iff set_iterator_emp_def rm_iterateoi_abort
                  set_iterator_union_def set_iterator_sng_def Let_def)
declare rm_iterateoi.simps[simp del]

primrec rm_reverse_iterateoi
  :: "('k,'v) RBT_Impl.rbt \<Rightarrow> ('k \<times> 'v, '\<sigma>) set_iterator"
  where
  "rm_reverse_iterateoi RBT_Impl.Empty c f \<sigma> = \<sigma>" |
  "rm_reverse_iterateoi (Branch col l k v r) c f \<sigma> = (
    if (c \<sigma>) then
      let \<sigma>' = rm_reverse_iterateoi r c f \<sigma> in
        if (c \<sigma>') then
          rm_reverse_iterateoi l c f (f (k, v) \<sigma>')
        else \<sigma>'
    else
      \<sigma>
  )"

lemma rm_reverse_iterateoi_abort :
  "\<not>(c \<sigma>) \<Longrightarrow> rm_reverse_iterateoi t c f \<sigma> = \<sigma>"
by (cases t) auto

lemma rm_reverse_iterateoi_alt_def :
  "rm_reverse_iterateoi RBT_Impl.Empty = set_iterator_emp"
  "rm_reverse_iterateoi (RBT_Impl.Branch col l k v r) =
   set_iterator_union (rm_reverse_iterateoi r)
     (set_iterator_union (set_iterator_sng (k, v)) (rm_reverse_iterateoi l))"
by (simp_all add: fun_eq_iff set_iterator_emp_def rm_reverse_iterateoi_abort
                  set_iterator_union_def set_iterator_sng_def Let_def)
declare rm_reverse_iterateoi.simps[simp del]

(*
lemma finite_dom_lookup [simp, intro!]: "finite (dom (RBT.lookup t))"
by(simp add: RBT.lookup_def)

instantiation rbt :: ("{equal, linorder}", equal) equal begin

definition "equal_class.equal (r :: ('a, 'b) rbt) r' == RBT.impl_of r = RBT.impl_of r'"

instance
proof
qed (simp add: equal_rbt_def RBT.impl_of_inject)

end
*)

lemma (in linorder) map_to_set_lookup_entries:
   "rbt_sorted t \<Longrightarrow> map_to_set (rbt_lookup t) = set (RBT_Impl.entries t)"
  using map_of_entries[symmetric,of t]
  by (simp add: distinct_entries map_to_set_map_of)

lemma (in linorder) rm_iterateoi_correct:
  fixes t::"('a, 'v) RBT_Impl.rbt"
  assumes is_sort: "rbt_sorted t"
  defines "it \<equiv>
  RBT_add.rm_iterateoi::(('a, 'v) RBT_Impl.rbt \<Rightarrow> ('a \<times> 'v, '\<sigma>) set_iterator)"
  shows "map_iterator_linord (it t) (rbt_lookup t)"
  using is_sort
proof (induct t)
  case Empty
  show ?case unfolding it_def
    by (simp add: rm_iterateoi_alt_def
      map_iterator_linord_emp_correct rbt_lookup_Empty)
next
  case (Branch c l k v r)
  note is_sort_t = Branch(3)

  from Branch(1) is_sort_t have
    l_it: "map_iterator_linord (it l) (rbt_lookup l)" by simp
  from Branch(2) is_sort_t have
    r_it: "map_iterator_linord (it r) (rbt_lookup r)" by simp
  note kv_it = map_iterator_linord_sng_correct[of k v]

  have kv_r_it : "set_iterator_map_linord
     (set_iterator_union (set_iterator_sng (k, v)) (it r))
     (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r))"
  proof (rule map_iterator_linord_union_correct [OF kv_it r_it])
    fix kv kv'
    assume pre: "kv \<in> map_to_set [k \<mapsto> v]" "kv' \<in> map_to_set (rbt_lookup r)"
    obtain k' v' where kv'_eq[simp]: "kv' = (k', v')" by (rule prod.exhaust)

    from pre is_sort_t show "fst kv < fst kv'"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      apply (metis entry_in_tree_keys rbt_greater_prop)
      done
  qed

  have l_kv_r_it : "set_iterator_map_linord (it (Branch c l k v r))
     (map_to_set (rbt_lookup l)
      \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r)))"
    unfolding it_def rm_iterateoi_alt_def
    unfolding it_def[symmetric]
  proof (rule map_iterator_linord_union_correct [OF l_it kv_r_it])
    fix kv1 kv2
    assume pre: "kv1 \<in> map_to_set (rbt_lookup l)"
                "kv2 \<in> map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r)"

    obtain k1 v1 where kv1_eq[simp]: "kv1 = (k1, v1)" by (rule prod.exhaust)
    obtain k2 v2 where kv2_eq[simp]: "kv2 = (k2, v2)" by (rule prod.exhaust)

    from pre is_sort_t show "fst kv1 < fst kv2"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      by (metis (lifting) map_of_entries neqE option.simps(3)
        ord.rbt_lookup_rbt_greater ord.rbt_lookup_rbt_less rbt_greater_trans
        rbt_less_trans weak_map_of_SomeI)
  qed

  from is_sort_t
  have map_eq: "map_to_set (rbt_lookup l)
    \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r)) =
        map_to_set (rbt_lookup (Branch c l k v r))"
    by (simp add: set_eq_iff map_to_set_lookup_entries)

  from l_kv_r_it[unfolded map_eq]
  show ?case .
qed

lemma (in linorder) rm_reverse_iterateoi_correct:
  fixes t::"('a, 'v) RBT_Impl.rbt"
  assumes is_sort: "rbt_sorted t"
  defines "it \<equiv> RBT_add.rm_reverse_iterateoi
    ::(('a, 'v) RBT_Impl.rbt \<Rightarrow> ('a \<times> 'v, '\<sigma>) set_iterator)"
  shows "map_iterator_rev_linord (it t) (rbt_lookup t)"
  using is_sort
proof (induct t)
  case Empty
  show ?case unfolding it_def
    by (simp add: rm_reverse_iterateoi_alt_def
      map_iterator_rev_linord_emp_correct rbt_lookup_Empty)
next
  case (Branch c l k v r)
  note is_sort_t = Branch(3)

  from Branch(1) is_sort_t have
    l_it: "map_iterator_rev_linord (it l) (rbt_lookup l)" by simp
  from Branch(2) is_sort_t have
    r_it: "map_iterator_rev_linord (it r) (rbt_lookup r)" by simp
  note kv_it = map_iterator_rev_linord_sng_correct[of k v]

  have kv_l_it : "set_iterator_map_rev_linord
     (set_iterator_union (set_iterator_sng (k, v)) (it l))
     (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l))"
  proof (rule map_iterator_rev_linord_union_correct [OF kv_it l_it])
    fix kv kv'
    assume pre: "kv \<in> map_to_set [k \<mapsto> v]" "kv' \<in> map_to_set (rbt_lookup l)"
    obtain k' v' where kv'_eq[simp]: "kv' = (k', v')" by (rule prod.exhaust)

    from pre is_sort_t show "fst kv > fst kv'"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      apply (metis entry_in_tree_keys rbt_less_prop)
   done
  qed

  have r_kv_l_it : "set_iterator_map_rev_linord (it (Branch c l k v r))
     (map_to_set (rbt_lookup r)
      \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l)))"
    unfolding it_def rm_reverse_iterateoi_alt_def
    unfolding it_def[symmetric]
  proof (rule map_iterator_rev_linord_union_correct [OF r_it kv_l_it])
    fix kv1 kv2
    assume pre: "kv1 \<in> map_to_set (rbt_lookup r)"
                "kv2 \<in> map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l)"

    obtain k1 v1 where kv1_eq[simp]: "kv1 = (k1, v1)" by (rule prod.exhaust)
    obtain k2 v2 where kv2_eq[simp]: "kv2 = (k2, v2)" by (rule prod.exhaust)

    from pre is_sort_t show "fst kv1 > fst kv2"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      by (metis (mono_tags) entry_in_tree_keys neq_iff option.simps(3)
        ord.rbt_greater_prop ord.rbt_lookup_rbt_less rbt_less_trans
        rbt_lookup_in_tree)
  qed

  from is_sort_t
  have map_eq: "map_to_set (rbt_lookup r)
    \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l)) =
        map_to_set (rbt_lookup (Branch c l k v r))"
    by (auto simp add: set_eq_iff map_to_set_lookup_entries)

  from r_kv_l_it[unfolded map_eq]
  show ?case .
qed

lemma pi_rm[icf_proper_iteratorI]:
  "proper_it (RBT_add.rm_iterateoi t) (RBT_add.rm_iterateoi t)"
  by (induct t) (simp_all add: rm_iterateoi_alt_def icf_proper_iteratorI)

lemma pi_rm_rev[icf_proper_iteratorI]:
  "proper_it (RBT_add.rm_reverse_iterateoi t) (RBT_add.rm_reverse_iterateoi t)"
  by (induct t) (simp_all add: rm_reverse_iterateoi_alt_def
    icf_proper_iteratorI)

primrec bheight_aux :: "('a,'b) RBT_Impl.rbt \<Rightarrow> nat \<Rightarrow> nat"
where
  "\<And>acc. bheight_aux RBT_Impl.Empty acc = acc"
| "\<And>acc. bheight_aux (RBT_Impl.Branch c lt k v rt) acc =
     bheight_aux lt (case c of RBT_Impl.B \<Rightarrow> Suc acc | RBT_Impl.R \<Rightarrow> acc)"

lemma bheight_aux_eq: "bheight_aux t a = bheight t + a"
  by (induct t arbitrary: a) (auto split: RBT_Impl.color.split)

definition [code_unfold]: "rbt_bheight t \<equiv> bheight_aux t 0"
lemma "rbt_bheight t = bheight t"
  unfolding rbt_bheight_def by (simp add: bheight_aux_eq)

(*definition "black_height t \<equiv> rbt_bheight (RBT.impl_of t)"*)

end


theory Chapter10_4
imports "HOL-IMP.Live_True" "HOL-IMP.Vars"
begin

lemma "(let b = Less (N 0) (V ''x''); c = ''x'' ::= V ''y'';; ''y'' ::= V ''z''
  in L (WHILE b DO c) {}) = {''x'', ''y'', ''z''}"
by eval

text \<open>That there are live variables before the loop is not weird, even though
there are no live variables after the loop; the fixpoint adds in the vars including those in
the loop that are needed in the computation of the test (vars b) to the set of live variables.
For checking termination before the first loop, pre-loop value of x from before is needed,
for check inf just after the first loop, pre-loop value of y decides, and after that value of
z is needed\<close>

text \<open>Ex 10.12 WHILE b (relying on e\<^sub>1) DO e\<^sub>1 ::= e\<^sub>2;; e\<^sub>2 ::= e\<^sub>3 ...\<close>

text\<open>
\exercise
In the context of ordinary live variable analysis, elimination of dead variables
(@{text bury}) is not idempotent (Exercise~\ref{exe:bury-not-idemp}).
Now define the textually identical function @{text bury} in the context
of true liveness analysis (theory @{theory "HOL-IMP.Live_True"})
and prove that it is idempotent.
\<close>

fun bury :: "com \<Rightarrow> vname set \<Rightarrow> com" where
"bury SKIP X = SKIP" |
"bury (x ::= a) X = (if x \<in> X then x ::= a else SKIP)" |
"bury (c\<^sub>1;; c\<^sub>2) X = (bury c\<^sub>1 (L c\<^sub>2 X);; bury c\<^sub>2 X)" |
"bury (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = IF b THEN bury c\<^sub>1 X ELSE bury c\<^sub>2 X" |
"bury (WHILE b DO c) X = WHILE b DO bury c (L (WHILE b DO c) X)"

text\<open> The following two tweaks improve proof automation: \<close>

declare L.simps(5)[simp]
lemmas L_mono2 = L_mono[unfolded mono_def]

text\<open> To show that @{const bury} is idempotent we need a key lemma: \<close>

lemma L_bury: "X \<subseteq> Y \<Longrightarrow> L (bury c Y) X = L c X"
proof (induct c arbitrary: X Y)
  case (Seq c1 c2)
  from Seq(3) have "(L c2 X) \<subseteq> (L c2 Y)" by (simp add: L_mono2)
  with Seq(1) have "L (bury c1 (L c2 Y)) (L c2 X) = L c1 (L c2 X)" by simp
  moreover from Seq(2, 3) have "L (bury c2 Y) X = L c2 X" by simp
  ultimately have "L (bury c1 (L c2 Y)) (L (bury c2 Y) X) = L c1 (L c2 X)" by simp
  then show ?case by simp
next
  case (While x1 c)
  let ?x = "\<lambda>U. vars x1 \<union> X \<union> L c U" and ?y = "\<lambda>V. vars x1 \<union> Y \<union> L c V"
  let ?xb = "\<lambda>U. vars x1 \<union> X \<union> L (bury c (lfp ?y)) U"
  have "mono ?x" and "mono ?xb" by (auto intro: mono_union_L)
  then have fpx: "?x (lfp ?x) = lfp ?x" and fpxb: "?xb (lfp ?xb) = lfp ?xb" by (auto intro!: lfp_fixpoint)
  from While(2) have x_s_y: "lfp ?x \<subseteq> lfp ?y" by (auto intro!: lfp_mono)
  with While(1) have "L (bury c (lfp ?y)) (lfp ?x) = L c (lfp ?x)" by simp
  with fpx have "?xb (lfp ?x) = lfp ?x" by simp
  then have xb_s_x: "lfp ?xb \<subseteq> lfp ?x" by (auto intro!: lfp_lowerbound)
  with x_s_y have "lfp ?xb \<subseteq> lfp ?y" by simp
  with While(1) have "L (bury c (lfp ?y)) (lfp ?xb) = L c (lfp ?xb)" by simp
  with fpxb have "?x (lfp ?xb) = lfp ?xb" by simp
  then have x_s_xb: "lfp ?x \<subseteq> lfp ?xb" by (auto intro!: lfp_lowerbound)
  with xb_s_x show ?case by simp
qed auto

text\<open> The proof is straightforward except for the case
\noquotes{@{term[source] "While b c"}} where reasoning about @{const lfp}
is required. Sledgehammer should help with the details.

Now we can prove idempotence of @{const bury}, again by induction on @{text c}:
\<close>

theorem bury_idemp: "bury (bury c X) X = bury c X"
proof (induct c arbitrary: X)
  case (Seq c1 c2)
  show ?case
  proof (simp, intro conjI)
    from Seq(2) show "bury (bury c2 X) X = bury c2 X" .
    have "bury (bury c1 (L c2 X)) (L (bury c2 X) X) = bury (bury c1 (L c2 X)) (L c2 X)" by (simp add: L_bury)
    also from Seq(1) have "\<dots> = bury c1 (L c2 X)" by simp
    finally show "bury (bury c1 (L c2 X)) (L (bury c2 X) X) = bury c1 (L c2 X)" .
  qed
next
case (While x1 c)
  let ?x = "\<lambda>Y. vars x1 \<union> X \<union> L c Y"
  let ?xb = "\<lambda>Y. vars x1 \<union> X \<union> L (bury c (lfp ?x)) Y"
  have "mono ?x" and "mono ?xb" by (simp add: mono_union_L)+
  then have fpx: "?x (lfp ?x) = lfp ?x" and fpxb: "?xb (lfp ?xb) = lfp ?xb" by (auto intro!: lfp_fixpoint)
  then have "?xb (lfp ?x) = lfp ?x" by (simp add: L_bury)
  then have xb_s_x: "lfp ?xb \<subseteq> lfp ?x" by (auto intro!: lfp_lowerbound)
  then have "L (bury c (lfp ?x)) (lfp ?xb) = L c (lfp ?xb)" by (simp add: L_bury)
  then have "?xb (lfp ?xb) = ?x (lfp ?xb)" by simp
  with fpxb have "?x (lfp ?xb) = lfp ?xb" by simp
  then have x_s_xb: "lfp ?x \<subseteq> lfp ?xb" by (auto intro!: lfp_lowerbound)
  with xb_s_x have "lfp ?x = lfp ?xb" by simp
  moreover from While have "bury (bury c (lfp ?x)) (lfp ?x) = bury c (lfp ?x)" by simp
  ultimately have "bury (bury c (lfp ?x)) (lfp ?xb) = bury c (lfp ?x)" by simp
  then show ?case by simp
qed auto
(* your definition/proof here *)

text\<open>
Due to lemma @{thm[source] L_bury}, even the @{text While} case should be easy.
\endexercise
\<close>

end


subsection \<open>Create Consistent\label{sec:create_consistent}\<close>

theory CreateConsistent
  imports CreateAlgorithms Consistency
begin

lemma nth_visible_eff:
  assumes "nth_visible s n = Inr i"
  shows "extended_to_set i \<subseteq> I ` set s"
proof -
  have "i \<in> set (ext_ids (filter is_visible s))"
    apply (cases "n < length (ext_ids (filter is_visible s))")
    using assms by auto
  thus ?thesis
    apply (simp add: ext_ids_def)
    using extended.inject by auto
qed

lemma subset_mono:
  assumes "N \<subseteq> M"
  shows "I ` insert_messages N \<subseteq> I ` insert_messages M"
proof -
  have "insert_messages N \<subseteq> insert_messages M" using assms
    by (metis (no_types, lifting) Collect_mono_iff insert_messages_def subsetCE)
  thus ?thesis by (simp add: image_mono)
qed

lemma deps_insert:
  assumes "\<Union> (deps ` M) \<subseteq> (I ` insert_messages M)"
  assumes "deps m \<subseteq> I ` insert_messages M"
  shows "\<Union> (deps ` (M \<union> {m})) \<subseteq> (I ` insert_messages (M \<union> {m}))"
proof -
  have "deps m \<subseteq> I ` insert_messages (M \<union> {m})" using assms(2) subset_mono
    by (metis Un_upper1 order_trans)
  thus ?thesis using assms(1) apply (simp)
    by (meson rev_subsetD subsetI subset_insertI subset_mono)
qed

lemma wf_add:
  fixes m :: "('a,'b) insert_message"
  assumes "wfP (depends_on M)"
  assumes "\<And>n. n \<in> (M \<union> {m}) \<Longrightarrow> I m \<notin> deps (Insert n)"
  assumes "m \<notin> M"
  shows "wfP (depends_on (M \<union> {m}))"
proof -
  have "\<And>Q. Q \<noteq> {} \<Longrightarrow> (\<exists>z\<in>Q. \<forall>y. (y \<in> M \<union> {m}) \<and> (z \<in> M \<union> {m}) \<and>
           I y \<in> deps (Insert z) \<longrightarrow> y \<notin> Q)"
  proof -
    fix Q :: "('a, 'b) insert_message set"
    assume b:"Q \<noteq> {}"
    show "\<exists>z\<in>Q. \<forall>y. (y \<in> M \<union> {m}) \<and> (z \<in> M \<union> {m}) \<and> I y \<in> deps (Insert z)
           \<longrightarrow> y \<notin> Q"
    proof (cases "\<exists>x. x \<in> Q - {m}")
      case True
      hence "\<exists>z\<in> Q - {m}. \<forall>y. (y \<in> M) \<and> (z \<in> M) \<and> I y \<in> deps (Insert z)
             \<longrightarrow> y \<notin> Q - {m}"
        by (metis depends_on.simps assms(1) wfP_eq_minimal)
      then show ?thesis using assms(2) DiffD2 by auto
    next
      case False
      hence "Q = {m}" using b by blast
      thus ?thesis using assms(2) by blast
    qed
  qed
  thus ?thesis by (simp add:wfP_eq_minimal, blast)
qed

lemma create_insert_p_s_ordered:
  assumes "is_associated_string N s"
  assumes "a_conditions (insert_messages N) a"
  assumes "Inr (Insert m) = create_insert s n \<sigma> new_id"
  shows "a (P m) < a (S m)"
proof -
  obtain p q where pq_def:
    "create_insert s n \<sigma> new_id = Inr (Insert (InsertMessage p new_id q \<sigma>))"
    by (metis (no_types, lifting) One_nat_def add.right_neutral add_Suc_right
        create_insert.elims sum.case_eq_if sum.simps(4) assms(3) bind_def)
  have "Inr p = nth_visible s n" using pq_def Error_Monad.bindE by fastforce
  moreover have "Inr q = nth_visible s (Suc n)"
    using pq_def Error_Monad.bindE by fastforce
  ultimately have "a p < a q"
    using assms by (metis is_associated_string_def nth_visible_inc')
  moreover have "m = InsertMessage p new_id q \<sigma>"
    using assms(3) pq_def by auto
  ultimately show ?thesis by (simp add: pq_def)
qed

lemma create_insert_consistent:
  assumes "consistent M"
  assumes "is_associated_string N s"
  assumes "N \<subseteq> M"
  assumes "Inr m = create_insert s n \<sigma> new_id"
  assumes "new_id \<notin> I ` insert_messages M"
  shows "consistent (M \<union> {m})"
proof -
  obtain p q where pq_def:
    "create_insert s n \<sigma> new_id = Inr (Insert (InsertMessage p new_id q \<sigma>))"
    by (metis (no_types, lifting) One_nat_def add.right_neutral add_Suc_right
        create_insert.elims assms(4) sum.case_eq_if sum.simps(4) bind_def)
  define m' where "m' = InsertMessage p new_id q \<sigma>"
  hence a:"m = Insert m'" using pq_def assms(4) by auto
  hence d: "create_insert s n \<sigma> new_id = Inr (Insert m')"
    using pq_def assms by simp
  have b:"I m' = new_id" using m'_def by (simp add:I_def)
  hence "inj_on I (insert_messages M \<union> {m'})" using assms(5) assms(1)
    using consistent_def by fastforce
  hence "inj_on I (insert_messages (M \<union> {m}))" using assms(4) pq_def m'_def
    by (metis Inr_inject insert_insert_message)
  moreover
  have p:"extended_to_set p \<subseteq> I ` set s" using pq_def nth_visible_eff by fastforce
  have q: "extended_to_set q \<subseteq> I ` set s"
    using pq_def apply (simp add:bind_def del:nth_visible.simps)
    apply (cases "nth_visible s n", simp)
    by (cases "nth_visible s (Suc n)", simp, simp add: nth_visible_eff)
  have "extended_to_set p \<union> extended_to_set q \<subseteq> I ` set s" using p q by simp
  hence "extended_to_set p \<union> extended_to_set q \<subseteq> I ` insert_messages N"
    by (metis assms(2) is_associated_string_def to_woot_character_keeps_i_lifted)
  hence "extended_to_set p \<union> extended_to_set q \<subseteq> I ` insert_messages M"
    using assms(3) subset_mono by blast
  hence c:"deps m \<subseteq> I ` insert_messages M" using pq_def assms(4) by auto
  hence "\<Union> (deps ` (M \<union> {m})) \<subseteq> (I ` insert_messages (M \<union> {m}))"
    by (metis consistent_def assms(1) deps_insert)
  moreover have w:
    "\<forall>n \<in> insert_messages M \<union> {m'}. deps (Insert n) \<subseteq> I ` insert_messages M"
    by (metis a c consistent_def assms(1) Sup_le_iff imageI insert_iff
        insert_is_Un insert_messages_def mem_Collect_eq sup.commute)
  hence "\<forall>n \<in> insert_messages M \<union> {m'}. I m' \<notin> deps (Insert n)"
    using b assms(5) by blast
  hence "wfP (depends_on (insert_messages M \<union> {m'}))"
    by (metis Un_insert_right insert_absorb wf_add assms(1)
        consistent_def sup_bot.right_neutral)
  moreover obtain a where a_def: "a_conditions (insert_messages M) a"
    using consistent_def  assms(1) by blast
  define a' where
    "a' = (\<lambda>i. if i = \<lbrakk> new_id \<rbrakk> then \<lbrakk>\<Psi> (a (P m'), a(S m')) new_id\<rbrakk> else a i)"
  hence "a_conditions (insert_messages (M \<union> {m})) a'"
  proof -
    have "a' \<turnstile> < a' \<stileturn>" using a'_def a_conditions_def a_def by auto
    moreover have
      "\<And>m''. m'' \<in> (insert_messages M \<union> {m'}) \<longrightarrow>
          a'(P m'') < a'(S m'')  \<and>
          a' \<lbrakk>I m''\<rbrakk> = \<lbrakk>\<Psi> (a'(P m''), a'(S m'')) (I m'')\<rbrakk>"
    proof
      fix m''
      assume e:" m'' \<in> (insert_messages M \<union> {m'})"
      show "a'(P m'') < a'(S m'') \<and> a' \<lbrakk> I m''\<rbrakk> =
            \<lbrakk>\<Psi> (a'(P m''), a'(S m'')) (I m'')\<rbrakk>"
      proof (cases "m'' \<in> insert_messages M")
        case True
        moreover have "deps (Insert m'') \<subseteq> I ` insert_messages M"
          using e w by blast
        hence "P m'' \<noteq> \<lbrakk> new_id \<rbrakk> \<and> S m'' \<noteq> \<lbrakk> new_id \<rbrakk>"
          by (meson assms(5) contra_subsetD pred_is_dep succ_is_dep)
        moreover have "I m'' \<noteq> new_id"
          using assms(5) True by blast
        ultimately show ?thesis using a_def True
          by (simp add: a_conditions_def a'_def)
      next
        case False
        moreover have "I m'' = new_id" using False b e by blast
        moreover have "deps (Insert m'') \<subseteq> I ` insert_messages M"
          using False a c e by blast
        hence "P m'' \<noteq> \<lbrakk> new_id \<rbrakk> \<and> S m'' \<noteq> \<lbrakk> new_id \<rbrakk>"
          by (meson assms(5) contra_subsetD pred_is_dep succ_is_dep)
        moreover have "a_conditions (insert_messages N) a"
          using a_def a_subset assms is_associated_string_def by blast
        hence "a (P m') < a (S m')"
          by (metis assms(2) d create_insert_p_s_ordered)
        hence "a' (P m'') < a' (S m'')" using calculation a'_def False e by auto
        ultimately show ?thesis using e a'_def by auto
      qed
    qed
    ultimately show "?thesis" using a_conditions_def
      by (metis a insert_insert_message)
  qed
  ultimately show "?thesis" using consistent_def a by (metis insert_insert_message)
qed

lemma bind_simp: "(x \<bind> (\<lambda>l. y l) = Inr r) \<Longrightarrow> (y (projr x) = Inr r)"
  using isOK_I by force

end


theory NP4_Struct_Action_Values
  imports
  NP4_Struct_Action_Syntax
  "~~/src/HOL/Word/Word"
  "~~/src/HOL/Word/Word_Bitwise"
(*  These files contain a minimalistic semantics of P4's action constructs. These files
    specifically extend the previously implemented simple semantics with more complex
    datastructures, in this case the struct datastructure. P4 knows structs, headers,
    enums, header unions and stacks, and tuples. The struct type however is the most
    general of these. Showing that structs are verifiable thus also shows that headers
    (and thus header unions and header stacks), enums, and tuples can be verified using
    Isabelle/HOL. *)
begin

(* ============================================================================================================== *)
(*                                              VALUE MAPPINGS                                                    *)
(* ============================================================================================================== *)

(* Mapping to concrete value *)
datatype val = UINT nat
  | SINT int
  | IINT int
  | VINT nat
  | BOOL bool
  | STRING string
  | ERROR "identifier list"
  | MATCH "identifier list"
  | STRUCT "(identifier * vname * val option) list" (* Heterogeneous named struct *)

(* State is a mapping from variable names to values *)
type_synonym state = "vname \<Rightarrow> val"

(* ============================================================================================================== *)
(*                                         BASE CONVERSION FUNCTIONS                                              *)
(* ============================================================================================================== *)

fun
  (* Structs have base types in them, so convert the contents of a struct to vals recursively *)
  structEntryToVal :: "(identifier * vname * basicType option) \<Rightarrow> (identifier * vname * val option)"
and
  baseToVal :: "basicType \<Rightarrow> val"
  where
    (* Map a single struct entry (containing basic types) to vals *)
    "structEntryToVal (tName, vName, None)      = (tName, vName, None)"
  | "structEntryToVal (tName, vName, Some bVal) = (tName, vName, Some (baseToVal bVal))"
    (* Map the remaining basic types to vals *)
  | "baseToVal (BBOOL b)         = (BOOL b)"
  | "baseToVal (BIINT n)         = (IINT n)"
  | "baseToVal (BUINT n)         = (UINT n)"
  | "baseToVal (BSINT n)         = (SINT n)"
  | "baseToVal (BVINT n)         = (VINT n)"
  | "baseToVal (BERROR e)        = (ERROR e)"
  | "baseToVal (BMATCH m)        = (MATCH m)"
  | "baseToVal (BSTRING s)       = (STRING s)"
  | "baseToVal (DSTRUCT entries) = (STRUCT (map structEntryToVal entries))" (* Recurse on structs *)

fun
  (* Helper function to go the other way from above (back to base type from val for struct entries) *)
  structEntryToBase :: "(identifier * vname * val option) \<Rightarrow> (identifier * vname * basicType option)"
and
  valToBase :: "val \<Rightarrow> basicType"
  where
    (* Map a single struct entry (containing a val) to basic types *)
    "structEntryToBase (tName, vName, None)       = (tName, vName, None)"
  | "structEntryToBase (tName, vName, Some vVal) = (tName, vName, Some (valToBase vVal))"
    (* Map the remaining vals to basic types *)
  | "valToBase (BOOL b)         = (BBOOL b)"
  | "valToBase (IINT n)         = (BIINT n)"
  | "valToBase (UINT n)         = (BUINT n)"
  | "valToBase (SINT n)         = (BSINT n)"
  | "valToBase (VINT n)         = (BVINT n)"
  | "valToBase (ERROR e)        = (BERROR e)"
  | "valToBase (MATCH m)        = (BMATCH m)"
  | "valToBase (STRING s)       = (BSTRING s)"
  | "valToBase (STRUCT entries) = (DSTRUCT (map structEntryToBase entries))" (* Recurse on structs *)

(* ============================================================================================================== *)
(*                                         STRUCT EQUIVALENCE PROOFS                                              *)
(* ============================================================================================================== *)

(* Converting to val and back to base is the same *)
lemma equiv1: "valToBase (baseToVal b) = b"
proof (induction b)
  case (DSTRUCT x)
  note ih = this(1)
  then show ?case
    apply (simp)
    apply (rule list.map_cong[of _ _ _ id, simplified])
     apply (rule refl)
    using ih
    by (smt comp_def option.set_intros snd_conv snds.intros structEntryToBase.simps(1) structEntryToBase.simps(2) structEntryToVal.elims)
qed simp+

(* Converting to base and back to val is the same *)
lemma equiv2: "baseToVal (valToBase v) = v"
proof (induction v)
  case (STRUCT x)
  note ih = this(1)
  then show ?case
    apply (simp)
    apply (rule list.map_cong[of _ _ _ id, simplified])
     apply (rule refl)
    using ih
    by (smt comp_apply option.set_intros prod_set_simps(2) singletonI structEntryToBase.cases structEntryToBase.simps(1) structEntryToBase.simps(2) structEntryToVal.simps(1) structEntryToVal.simps(2))
qed simp+

(* ============================================================================================================== *)
(*                                       STRUCT MEMBER ACCESS FUNCTIONS                                           *)
(* ============================================================================================================== *)

(* Update the named member field of a struct. Iterates through fields of enum and stores the already-seen values
   in the buildup field. When field is found will combine buildup and remainder after updating and return. *)
fun updateStruct :: "val \<Rightarrow> val \<Rightarrow> ((identifier * vname * (val option)) list) \<Rightarrow> identifier \<Rightarrow> val option" where
    "updateStruct (STRUCT struct) newVal buildup valName = (case struct of
        ([])                    \<Rightarrow> None
      | ((tp, nm, vl) # remain) \<Rightarrow> if (nm = valName) then Some (STRUCT (buildup @ ((tp, nm, Some newVal) # remain))) else (updateStruct (STRUCT remain) newVal ((tp, nm, vl) # buildup) valName))"
  | "updateStruct _ _ _ _ = None"

(* Will retrieve named member field's value of a struct or enum (all datatypes with named member fields) *)
fun getStructMem :: "val \<Rightarrow> vname \<Rightarrow> val option" where
    "getStructMem (STRUCT []) vName = None"
  | "getStructMem (STRUCT ((tp, nm, None) # rst)) vName = (getStructMem (STRUCT rst) vName)"
  | "getStructMem (STRUCT ((tp, nm, Some vl) # rst)) vName = (if nm = vName then (Some vl) else (getStructMem (STRUCT rst) vName))"
  | "getStructMem _ vName = None"

lemma struct_mem_determ: "getStructMem strct vName = v \<Longrightarrow> getStructMem strct vName = v' \<Longrightarrow> v' = v"
  by simp

(* ============================================================================================================== *)
(*                                   CONCRETE VALUE EVALUATION FUNCTIONS                                          *)
(* ============================================================================================================== *)

inductive eval :: "expression \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
(* =============== Base types =============== *)
    RBASE: "eval (BASE b) s (baseToVal b)"
(* =============== Miscellaneous expressions =============== *)
  | TERNTRUE:  "eval e1 s (BOOL b) \<Longrightarrow> b = True \<Longrightarrow> eval e2 s v \<Longrightarrow> eval (TernExpr e1 e2 e3) s v"
  | TERNFALSE: "eval e1 s (BOOL b) \<Longrightarrow> b = False \<Longrightarrow> eval e3 s v \<Longrightarrow> eval (TernExpr e1 e2 e3) s v"
  | STRUCTMEM: "eval e1 s (STRUCT entries) \<Longrightarrow> getStructMem (STRUCT entries) varName = (Some v) \<Longrightarrow> eval (ExprMem e1 varName) s v"
(* =============== Variable mapping  =============== *)
  | NAMEDVAR: "eval (NamedVar varName) s (s varName)"
(* =============== Operations that yield a single bit (SBIT)  =============== *)
          (* Empty for now *)
(* =============== Operations that yield a boolean (BOOL)  =============== *)
  | ULNEB: "eval e1 s (BOOL b) \<Longrightarrow> eval (UNA_LNE e1) s (BOOL (\<not>b))"
    (* Boolean operations *)
  | BEQUB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (b1 = b2))"
(* Very strange but boolean inequality breaks code generation? *)
(*  | BNEQB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (b1 \<noteq> b2))" *)
  | BFANB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_FAN e1 e2) s (BOOL (b1 \<and> b2))"
  | BFORB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_FOR e1 e2) s (BOOL (b1 \<or> b2))"
    (* Signed integer opreations *)
  | BEQUS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
  | BLEQS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_LEQ e1 e2) s (BOOL (n1 \<le> n2))"
  | BGEQS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_GEQ e1 e2) s (BOOL (n1 \<ge> n2))"
  | BLESS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_LES e1 e2) s (BOOL (n1 < n2))"
  | BGRES: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_GRE e1 e2) s (BOOL (n1 > n2))"
    (* Unsigned integer opreations *)
  | BEQUU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
  | BLEQU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_LEQ e1 e2) s (BOOL (n1 \<le> n2))"
  | BGEQU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_GEQ e1 e2) s (BOOL (n1 \<ge> n2))"
  | BLESU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_LES e1 e2) s (BOOL (n1 < n2))"
  | BGREU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_GRE e1 e2) s (BOOL (n1 > n2))"
    (* Infinite precision integer opreations *)
  | BEQUI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
  | BLEQI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_LEQ e1 e2) s (BOOL (n1 \<le> n2))"
  | BGEQI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_GEQ e1 e2) s (BOOL (n1 \<ge> n2))"
  | BLESI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_LES e1 e2) s (BOOL (n1 < n2))"
  | BGREI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_GRE e1 e2) s (BOOL (n1 > n2))"
    (* Variable size bitstring opreations *)
  | BEQUV: "eval e1 s (VINT n1) \<Longrightarrow> eval e2 s (VINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQV: "eval e1 s (VINT n1) \<Longrightarrow> eval e2 s (VINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
(* =============== Operations that yield an unsigned integer (UINT)  =============== *)
  | UNEGU: "eval e1 s (UINT n1) \<Longrightarrow> eval (UNA_NEG e1) s (UINT n1)" (* Incorrect but w/e for now *)
  | UPOSU: "eval e1 s (UINT n1) \<Longrightarrow> eval (UNA_POS e1) s (UINT n1)"
  | UCOMU: "eval e1 s (UINT n1) \<Longrightarrow> eval (UNA_COM e1) s (UINT n1)" (* (nat (NOT (int n1))))" Incorrect but w/e *)
  | BADDU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_ADD e1 e2) s (UINT (n1 + n2))"
  | BMINU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_MIN e1 e2) s (UINT (n1 - n2))"
  | BANDU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_AND e1 e2) s (UINT (nat ((int n1) AND (int n2))))"
  | BXORU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_XOR e1 e2) s (UINT (nat ((int n1) XOR (int n2))))"
  | BLORU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_LOR e1 e2) s (UINT (nat ((int n1) OR (int n2))))"
(* =============== Operations that yield a signed integer (SINT)  =============== *)
  | UNEGS: "eval e1 s (SINT n1) \<Longrightarrow> eval (UNA_NEG e1) s (SINT (-n1))"
  | UPOSS: "eval e1 s (SINT n1) \<Longrightarrow> eval (UNA_POS e1) s (SINT n1)"
  | BADDS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_ADD e1 e2) s (SINT (n1 + n2))"
  | BMINS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_MIN e1 e2) s (SINT (n1 - n2))"
(* =============== Operations that yield an infinite-precision integer (IINT)  =============== *)
  | UNEGI: "eval e1 s (IINT n1) \<Longrightarrow> eval (UNA_NEG e1) s (IINT (-n1))"
  | UPOSI: "eval e1 s (IINT n1) \<Longrightarrow> eval (UNA_POS e1) s (IINT n1)"
  | BADDI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_ADD e1 e2) s (IINT (n1 + n2))"
  | BMINI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_MIN e1 e2) s (IINT (n1 - n2))"
  | BMULI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_MUL e1 e2) s (IINT (n1 * n2))"
  | BDIVI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_DIV e1 e2) s (IINT (n1 div n2))"
  | BMODI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_MOD e1 e2) s (IINT (n1 mod n2))"
(* =============== Operations that yield a variable-width integer (VINT)  =============== *)
      (* Empty for now *)

declare eval.intros[simp, intro]
lemmas eval_induct = eval.induct[split_format(complete)]

inductive_cases [elim!]: "eval (BASE b) s v" "eval (TernExpr e1 e2 e3) s v" "eval (NamedVar i) s v"
"eval (UNA_LNE e) s v" "eval (UNA_COM e) s v" "eval (UNA_NEG e) s v" "eval (UNA_POS e) s v" "eval (BIN_MUL e1 e2) s v"
"eval (BIN_DIV e1 e2) s v" "eval (BIN_MOD e1 e2) s v" "eval (BIN_ADD e1 e2) s v" "eval (BIN_MIN e1 e2) s v" "eval (BIN_AND e1 e2) s v"
"eval (BIN_XOR e1 e2) s v" "eval (BIN_LOR e1 e2) s v" "eval (BIN_LEQ e1 e2) s v" "eval (BIN_GEQ e1 e2) s v" "eval (BIN_LES e1 e2) s v"
"eval (BIN_GRE e1 e2) s v" "eval (BIN_NEQ e1 e2) s v" "eval (BIN_EQU e1 e2) s v" "eval (BIN_FAN e1 e2) s v" "eval (BIN_FOR e1 e2) s v"
"eval (ExprMem e i) s v"

lemma eval_deterministic: "(eval e s v) \<Longrightarrow> (eval e s v') \<Longrightarrow> (v' = v)"
proof (induction arbitrary: v' rule: eval_induct)
  case (STRUCTMEM e1 s entries varName v)
  note th = this(4)
  then show ?case
    using STRUCTMEM.IH STRUCTMEM.hyps(2) by auto
qed blast+

lemma if_mem_exprMem: "eval expr s strct \<Longrightarrow> getStructMem strct vName = Some v \<Longrightarrow> eval (ExprMem expr vName) s v"
  by (smt STRUCTMEM getStructMem.elims option.distinct(1))

code_pred eval .

(* ============================================================================================================== *)
(*                                                 STATE MAPPING                                                  *)
(* ============================================================================================================== *)

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. (UINT 0)"
syntax
  "_State" :: "updbinds \<Rightarrow> 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

end