# Theory State_Heap

theory State_Heap
```subsection ‹Relation Between the State and the Heap Monad›

theory State_Heap
imports
"HOL-Imperative_HOL.Imperative_HOL"
State_Heap_Misc
begin

definition lift_p :: "(heap ⇒ bool) ⇒ 'a Heap ⇒ bool" where
"lift_p P f =
(∀ heap. P heap ⟶ (case execute f heap of None ⇒ False | Some (_, heap) ⇒ P heap))"

context
fixes P f heap
assumes lift: "lift_p P f" and P: "P heap"
begin

lemma execute_cases:
"case execute f heap of None ⇒ False | Some (_, heap) ⇒ P heap"
using lift P unfolding lift_p_def by auto

lemma execute_cases':
"case execute f heap of Some (_, heap) ⇒ P heap"
using execute_cases by (auto split: option.split)

lemma lift_p_None[simp, dest]:
False if "execute f heap = None"
using that execute_cases by auto

lemma lift_p_P:
"case the (execute f heap) of (_, heap) ⇒ P heap"
using execute_cases by (auto split: option.split_asm)

lemma lift_p_P':
"P heap'" if "the (execute f heap) = (v, heap')"
using that lift_p_P by auto

lemma lift_p_P'':
"P heap'" if "execute f heap = Some (v, heap')"
using that lift_p_P by auto

lemma lift_p_the_Some[simp]:
"execute f heap = Some (v, heap')" if "the (execute f heap) = (v, heap')"
using that execute_cases by (auto split: option.split_asm)

lemma lift_p_E:
obtains v heap' where "execute f heap = Some (v, heap')" "P heap'"
using execute_cases by (cases "execute f heap") auto

end

definition "state_of s ≡ State (λ heap. the (execute s heap))"

locale heap_mem_defs =
fixes P :: "heap ⇒ bool"
and lookup :: "'k ⇒ 'v option Heap"
and update :: "'k ⇒ 'v ⇒ unit Heap"
begin

definition rel_state :: "('a ⇒ 'b ⇒ bool) ⇒ (heap, 'a) state ⇒ 'b Heap ⇒ bool" where
"rel_state R f g ≡
∀ heap. P heap ⟶
(case State_Monad.run_state f heap of (v1, heap1) ⇒ case execute g heap of
Some (v2, heap2) ⇒ R v1 v2 ∧ heap1 = heap2 ∧ P heap2 | None ⇒ False)"

definition "lookup' k ≡ State (λ heap. the (execute (lookup k) heap))"

definition "update' k v ≡ State (λ heap. the (execute (update k v) heap))"

definition "heap_get = Heap_Monad.Heap (λ heap. Some (heap, heap))"

definition checkmem :: "'k ⇒ 'v Heap ⇒ 'v Heap" where
"checkmem param calc ≡
case x of
Some x ⇒ return x
| None ⇒ Heap_Monad.bind calc (λ x.
Heap_Monad.bind (update param x) (λ _.
return x
)
)
)
"

definition checkmem' :: "'k ⇒ (unit ⇒ 'v Heap) ⇒ 'v Heap" where
"checkmem' param calc ≡
case x of
Some x ⇒ return x
| None ⇒ Heap_Monad.bind (calc ()) (λ x.
Heap_Monad.bind (update param x) (λ _.
return x
)
)
)
"

lemma checkmem_checkmem':
"checkmem' param (λ_. calc) = checkmem param calc"
unfolding checkmem'_def checkmem_def ..

definition map_of_heap where
"map_of_heap heap k = fst (the (execute (lookup k) heap))"

lemma rel_state_elim:
assumes "rel_state R f g" "P heap"
obtains heap' v v' where
"State_Monad.run_state f heap = (v, heap')" "execute g heap = Some (v', heap')" "R v v'" "P heap'"
apply atomize_elim
using assms unfolding rel_state_def
apply auto
apply auto
apply (auto split: option.split_asm)
done

lemma rel_state_intro:
assumes
"⋀ heap v heap'. P heap ⟹ State_Monad.run_state f heap = (v, heap')
⟹ ∃ v'. R v v' ∧ execute g heap = Some (v', heap')"
"⋀ heap v heap'. P heap ⟹ State_Monad.run_state f heap = (v, heap') ⟹ P heap'"
shows "rel_state R f g"
unfolding rel_state_def
apply auto
apply (frule assms(1)[rotated])
apply (auto intro: assms(2))
done

context
begin

lemma transfer_bind[transfer_rule]:
"(rel_state R ===> (R ===> rel_state Q) ===> rel_state Q) State_Monad.bind Heap_Monad.bind"
by (force elim!: rel_state_elim intro!: rel_state_intro)

lemma transfer_return[transfer_rule]:
by (fastforce intro: rel_state_intro elim: rel_state_elim simp: execute_heap)

lemma fun_app_lifted_transfer:
"(rel_state (R ===> rel_state Q) ===> rel_state R ===> rel_state Q)

lemma transfer_get[transfer_rule]:
unfolding State_Monad.get_def heap_get_def by (auto intro: rel_state_intro)

end (* Lifting Syntax *)

end (* Heap Mem Defs *)

locale heap_inv = heap_mem_defs _ lookup for lookup :: "'k ⇒ 'v option Heap"  +
assumes lookup_inv: "lift_p P (lookup k)"
assumes update_inv: "lift_p P (update k v)"
begin

lemma rel_state_lookup:
"rel_state (=) (lookup' k) (lookup k)"
unfolding rel_state_def lookup'_def using lookup_inv[of k] by (auto intro: lift_p_P')

lemma rel_state_update:
"rel_state (=) (update' k v) (update k v)"
unfolding rel_state_def update'_def using update_inv[of k v] by (auto intro: lift_p_P')

context
includes lifting_syntax
begin

lemma transfer_lookup:
"((=) ===> rel_state (=)) lookup' lookup"
unfolding rel_fun_def by (auto intro: rel_state_lookup)

lemma transfer_update:
"((=) ===> (=) ===> rel_state (=)) update' update"
unfolding rel_fun_def by (auto intro: rel_state_update)

lemma transfer_checkmem:
"((=) ===> rel_state (=) ===> rel_state (=))
(state_mem_defs.checkmem lookup' update') checkmem"
supply [transfer_rule] = transfer_lookup transfer_update
unfolding state_mem_defs.checkmem_def checkmem_def by transfer_prover

end (* Lifting Syntax *)

end (* Heap Invariant *)

locale heap_correct =
heap_inv +
assumes lookup_correct:
"P m ⟹ map_of_heap (snd (the (execute (lookup k) m))) ⊆⇩m (map_of_heap m)"
and update_correct:
"P m ⟹ map_of_heap (snd (the (execute (update k v) m))) ⊆⇩m (map_of_heap m)(k ↦ v)"
begin

lemma lookup'_correct:
"state_mem_defs.map_of lookup' (snd (State_Monad.run_state (lookup' k) m)) ⊆⇩m (state_mem_defs.map_of lookup' m)" if "P m"
using ‹P m› unfolding state_mem_defs.map_of_def map_le_def lookup'_def
by simp (metis (mono_tags, lifting) domIff lookup_correct map_le_def map_of_heap_def)

lemma update'_correct:
"state_mem_defs.map_of lookup' (snd (State_Monad.run_state (update' k v) m)) ⊆⇩m state_mem_defs.map_of lookup' m(k ↦ v)"
if "P m"
unfolding state_mem_defs.map_of_def map_le_def lookup'_def update'_def
using update_correct[of m k v] that by (auto split: if_split_asm simp: map_le_def map_of_heap_def)

lemma lookup'_inv:
"DP_CRelVS.lift_p P (lookup' k)"
unfolding DP_CRelVS.lift_p_def lookup'_def by (auto elim: lift_p_P'[OF lookup_inv])

lemma update'_inv:
"DP_CRelVS.lift_p P (update' k v)"
unfolding DP_CRelVS.lift_p_def update'_def by (auto elim: lift_p_P'[OF update_inv])

lemma mem_correct_heap: "mem_correct lookup' update' P"
by (intro mem_correct.intro lookup'_correct update'_correct lookup'_inv update'_inv)

end (* Heap correct *)

context heap_mem_defs
begin

context
includes lifting_syntax
begin

lemma mem_correct_heap_correct:
assumes correct: "mem_correct lookup⇩s update⇩s P"
and lookup: "((=) ===> rel_state (=)) lookup⇩s lookup"
and update: "((=) ===> (=) ===> rel_state (=)) update⇩s update"
shows "heap_correct P update lookup"
proof -
interpret mem: mem_correct lookup⇩s update⇩s P
by (rule correct)
have [simp]: "the (execute (lookup k) m) = run_state (lookup⇩s k) m" if "P m" for k m
using lookup[THEN rel_funD, OF HOL.refl, of k] ‹P m› by (auto elim: rel_state_elim)
have [simp]: "the (execute (update k v) m) = run_state (update⇩s k v) m" if "P m" for k v m
using update[THEN rel_funD, THEN rel_funD, OF HOL.refl HOL.refl, of k v] ‹P m›
by (auto elim: rel_state_elim)
have [simp]: "map_of_heap m = mem.map_of m" if "P m" for m
unfolding map_of_heap_def mem.map_of_def using ‹P m› by simp
show ?thesis
apply standard
subgoal for k
using mem.lookup_inv[of k] lookup[THEN rel_funD, OF HOL.refl, of k]
unfolding lift_p_def DP_CRelVS.lift_p_def
by (auto split: option.splits elim: rel_state_elim)
subgoal for k v
using mem.update_inv[of k] update[THEN rel_funD, THEN rel_funD, OF HOL.refl HOL.refl, of k v]
unfolding lift_p_def DP_CRelVS.lift_p_def
by (auto split: option.splits elim: rel_state_elim)
subgoal premises prems for m k
proof -
have "P (snd (run_state (lookup⇩s k) m))"
by (meson DP_CRelVS.lift_p_P mem.lookup_inv prems prod.exhaust_sel)
with mem.lookup_correct[OF ‹P m›, of k] ‹P m› show ?thesis
qed
subgoal premises prems for m k v
proof -
have "P (snd (run_state (update⇩s k v) m))"
by (meson DP_CRelVS.lift_p_P mem.update_inv prems prod.exhaust_sel)
with mem.update_correct[OF ‹P m›, of k] ‹P m› show ?thesis