# Theory VDM_OBJ

(*File: VDM_OBJ.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory VDM_OBJ imports OBJ begin

subsection‹Program logic›

text‹\label{sec:ObjLogic}Apart from the addition of proof rules for the three new
instructions, this section is essentially identical to Section
\ref{sec:VDM}.›

subsubsection ‹Assertions and their semantic validity›

text‹Assertions are binary state predicates, as before.›

type_synonym "Assn" = "State ⇒ State ⇒ bool"

definition VDM_validn :: "nat ⇒ OBJ ⇒ Assn ⇒ bool"
(" ⊨⇩_ _ : _ " 50)
where "(⊨⇩n c : A) = (∀ m . m ≤ n ⟶ (∀ s t . (s,c →⇩m t) ⟶ A s t))"

definition VDM_valid :: "OBJ ⇒ Assn ⇒ bool"
(" ⊨ _ : _ " 50)
where "(⊨ c : A) = (∀ s t . (s,c ⇓ t) ⟶ A s t)"

lemma VDM_valid_validn: "⊨ c:A ⟹ ⊨⇩n c:A"
(*<*)
by (simp add: VDM_valid_def VDM_validn_def Sem_def, fastforce)
(*>*)

lemma VDM_validn_valid: "(∀ n . ⊨⇩n c:A) ⟹ ⊨ c:A"
(*<*)
by (simp add: VDM_valid_def VDM_validn_def Sem_def, fastforce)
(*>*)

lemma VDM_lowerm: "⟦ ⊨⇩n c:A; m < n ⟧ ⟹ ⊨⇩m c:A"
(*<*)
apply (erule_tac x="ma" in allE, simp)
done
(*>*)

definition Ctxt_validn :: "nat ⇒ (Assn set) ⇒ bool"
(" ⊨⇩_ _  " 50)
where "(⊨⇩n G) = (∀ m . m ≤ n ⟶ (∀ A. A ∈ G ⟶ ⊨⇩n Call : A))"

definition Ctxt_valid :: "Assn set ⇒ bool" (" ⊨ _ " 50)
where "(⊨ G) = (∀ A . A ∈ G ⟶ ⊨ Call : A)"

lemma Ctxt_valid_validn: "⊨ G ⟹ ⊨⇩n G"
(*<*)
apply (simp add: Ctxt_valid_def Ctxt_validn_def, clarsimp)
apply (rule VDM_valid_validn) apply fast
done
(*>*)

lemma Ctxt_validn_valid: "(∀ n . ⊨⇩n G) ⟹ ⊨ G"
(*<*)
apply (simp add: Ctxt_valid_def Ctxt_validn_def, clarsimp)
apply (rule VDM_validn_valid) apply fast
done
(*>*)

lemma Ctxt_lowerm: "⟦ ⊨⇩n G; m < n ⟧ ⟹ ⊨⇩m G"
(*<*)
apply (rule VDM_lowerm) prefer 2 apply assumption apply fast
done
(*>*)

definition valid :: "(Assn set) ⇒ OBJ ⇒ Assn ⇒ bool"
("_ ⊨ _ : _ " 50)
where "(G ⊨ c : A) = (Ctxt_valid G ⟶ VDM_valid c A)"

definition validn :: "(Assn set) ⇒ nat ⇒ OBJ ⇒ Assn ⇒ bool"
("_ ⊨⇩_ _ : _" 50)
where "(G ⊨⇩n c : A) = (⊨⇩n G ⟶ ⊨⇩n c : A)"

lemma validn_valid: "(∀ n . G ⊨⇩n c : A) ⟹ G ⊨ c : A"
(*<*)
apply (simp add: valid_def validn_def, clarsimp)
apply (rule VDM_validn_valid, clarsimp)
apply (erule_tac x=n in allE, erule mp)
apply (erule Ctxt_valid_validn)
done
(*>*)

lemma ctxt_consn: "⟦ ⊨⇩n G;  ⊨⇩n Call:A ⟧ ⟹ ⊨⇩n {A} ∪ G"
(*<*)
(*>*)

subsubsection‹Proof system›

inductive_set VDM_proof :: "(Assn set × OBJ × Assn) set"
where
VDMSkip: "(G, Skip, λ s t . t=s):VDM_proof"

| VDMAssign:
"(G, Assign x e,
λ s t . t = (update (fst s) x (evalE e (fst s)), snd s)):VDM_proof"

| VDMNew:
"(G, New x C,
λ s t . ∃ l . l ∉ Dom (snd s) ∧
t = (update (fst s) x (RVal (Loc l)),
(l,(C,[])) # (snd s))):VDM_proof"

| VDMGet:
"(G, Get x y F,
λ s t . ∃ l C Flds v. (fst s) y = RVal(Loc l) ∧
lookup (snd s) l = Some(C,Flds) ∧
lookup Flds F = Some v ∧
t = (update (fst s) x v, snd s)):VDM_proof"

| VDMPut:
"(G, Put x F e,
λ s t . ∃ l C Flds. (fst s) x = RVal(Loc l) ∧
lookup (snd s) l = Some(C,Flds) ∧
t = (fst s,
(l,(C,(F,evalE e (fst s)) # Flds))
# (snd s))):VDM_proof"

| VDMComp:
"⟦ (G, c, A):VDM_proof; (G, d, B):VDM_proof⟧ ⟹
(G, Comp c d, λ s t . ∃ r . A s r ∧ B r t):VDM_proof"

| VDMIff:
"⟦ (G, c, A):VDM_proof; (G, d, B):VDM_proof⟧ ⟹
(G, Iff b c d,
λ s t . (((evalB b (fst s)) ⟶ A s t) ∧
((¬ (evalB b (fst s))) ⟶ B s t))):VDM_proof"
(*VDMWhile:  "⟦⊳ c : (λ s t . (evalB b s ⟶ I s t)); Trans I; Refl I⟧
⟹ ⊳ (While b c) : (λ s t . I s t ∧ ¬ (evalB b t))"*)

| VDMWhile:
"⟦ (G,c,B):VDM_proof;
∀ s . (¬ evalB b (fst s)) ⟶ A s s;
∀ s r t. evalB b (fst s) ⟶ B s r ⟶ A r t ⟶ A s t ⟧
⟹ (G, While b c, λ s t . A s t ∧ ¬ (evalB b (fst t))):VDM_proof"

| VDMCall:
"({A} ∪ G, body, A):VDM_proof ⟹ (G, Call, A):VDM_proof"

| VDMAx: "A ∈ G ⟹  (G, Call, A):VDM_proof"

| VDMConseq:
"⟦ (G, c,A):VDM_proof; ∀ s t. A s t ⟶ B s t⟧ ⟹
(G, c, B):VDM_proof"

abbreviation VDM_deriv :: "[Assn set, OBJ, Assn] ⇒ bool"
("_ ⊳ _ : _" [100,100] 50)
where "G ⊳ c : A == (G,c,A) ∈ VDM_proof"

text‹The while-rule is in fact inter-derivable with the following rule.›
lemma Hoare_While:
"G ⊳ c : (λ s t . ∀ r . evalB b (fst s) ⟶ I s r ⟶ I t r) ⟹
G ⊳ While b c : (λ s t. ∀ r . I s r ⟶ (I t r ∧ ¬ evalB b (fst t)))"
apply (subgoal_tac "G ⊳ (While b c) :
(λ s t . (λ s t . ∀r. I s r ⟶ I t r) s t ∧ ¬ (evalB b (fst t)))")
apply (erule VDMConseq)
apply simp
apply (rule VDMWhile) apply assumption apply simp apply simp
done

text‹Here's the proof in the opposite direction.›

lemma VDMWhile_derivable:
"⟦ G ⊳ c : B; ∀ s . (¬ evalB b (fst s)) ⟶ A s s;
∀ s r t. evalB b (fst s) ⟶ B s r ⟶ A r t ⟶ A s t ⟧
⟹ G ⊳ (While b c) : (λ s t . A s t ∧ ¬ (evalB b (fst t)))"
apply (rule VDMConseq)
apply (rule Hoare_While [of G c b "λ s r . ∀ t . A s t ⟶ A r t"])
apply (erule VDMConseq) apply clarsimp
apply fast
done

subsubsection‹Soundness›
(*<*)
lemma MAX:"Suc (max k m) ≤ n ⟹ k ≤ n ∧ m ≤ n"
by (simp add: max_def, case_tac "k ≤ m", simp+)
(*>*)

text‹The following auxiliary lemma for loops is proven by induction
on $n$.›

lemma SoundWhile[rule_format]:
"(∀n. G ⊨⇩n c : B)
⟶ (∀s. (¬ evalB b (fst s)) ⟶ A s s)
⟶ (∀s. evalB b (fst s)
⟶ (∀r. B s r ⟶ (∀t. A r t ⟶ A s t)))
⟶ G ⊨⇩n (While b c) : (λs t. A s t ∧ ¬ evalB b (fst t))"
(*<*)
apply (induct n)
apply clarsimp apply (simp add: validn_def VDM_validn_def, clarsimp)
apply (drule Sem_no_zero_height_derivs) apply simp
apply clarsimp apply (simp add: validn_def VDM_validn_def, clarsimp)
apply (erule Sem_eval_cases)
prefer 2 apply clarsimp
apply clarsimp
apply (erule_tac x=n in allE, erule impE) apply (erule Ctxt_lowerm) apply simp
apply (rotate_tac -1)
apply (erule_tac x=ma in allE, clarsimp)
apply(erule impE) apply (erule Ctxt_lowerm) apply simp
apply (erule_tac x=na in allE, clarsimp) apply fast
done
(*>*)

lemma SoundCall[rule_format]:
"⟦∀n. ⊨⇩n ({A} ∪ G) ⟶ ⊨⇩n body : A⟧ ⟹ ⊨⇩n G ⟶ ⊨⇩n Call : A"
(*<*)
apply (induct_tac n)
apply (drule Sem_no_zero_height_derivs) apply simp
apply clarsimp
apply (drule Ctxt_lowerm) apply (subgoal_tac "n < Suc n", assumption) apply simp apply clarsimp
apply (drule ctxt_consn) apply assumption
apply (erule Sem_eval_cases, clarsimp)
done
(*>*)

lemma VDM_Sound_n: "G ⊳ c: A ⟹ (∀ n. G ⊨⇩n c:A)"
(*<*)
apply (erule VDM_proof.induct)
apply(clarsimp, erule Sem_eval_cases, simp)
apply(clarsimp, erule Sem_eval_cases, simp)
apply(clarsimp, erule Sem_eval_cases, simp)
apply(clarsimp, erule Sem_eval_cases, simp)
apply(clarsimp, erule Sem_eval_cases, simp)
apply(clarsimp, erule Sem_eval_cases, clarsimp)
apply (drule MAX, clarsimp)
apply (erule_tac x=n in allE, clarsimp, rotate_tac -1, erule_tac x=na in allE, clarsimp)
apply (erule_tac x=n in allE, clarsimp, rotate_tac -1, erule_tac x=ma in allE, clarsimp)
apply (rule_tac x=ab in exI, rule_tac x=bb in exI, fast)
apply(clarsimp, erule Sem_eval_cases, clarsimp)
apply (erule thin_rl, rotate_tac 1, erule thin_rl, erule thin_rl)
apply (erule_tac x=n in allE, clarsimp, erule_tac x=na in allE, clarsimp)
apply (erule thin_rl, erule thin_rl)
apply (erule_tac x=n in allE, clarsimp, erule_tac x=na in allE, clarsimp)
apply clarsimp
apply (rule SoundWhile) apply fast
apply (case_tac s, clarsimp)
apply (case_tac s, clarsimp)
apply (rule SoundCall) prefer 2 apply assumption apply fastforce
apply (simp add: Ctxt_validn_def validn_def) apply fast
done
(*>*)

theorem VDM_Sound: "G ⊳ c: A ⟹ G ⊨ c:A"
(*<*)
by (drule VDM_Sound_n, erule validn_valid)
(*>*)

text‹A simple corollary is soundness w.r.t.~an empty context.›

lemma VDM_Sound_emptyCtxt:"{} ⊳ c : A ⟹  ⊨ c : A"
(*<*)
apply (drule VDM_Sound)
apply (simp add: valid_def, erule mp)
done
(*>*)

subsubsection‹Derived rules›

lemma WEAK[rule_format]:
"G ⊳ c : A ⟹ (∀ H . G ⊆ H ⟶ H ⊳ c :A)"
(*<*)
apply (erule VDM_proof.induct)
apply clarsimp apply (rule VDMSkip)
apply clarsimp apply (rule VDMAssign)
apply clarsimp apply (rule VDMNew)
apply (rule, rule) apply (rule VDMGet)
apply (rule, rule) apply (rule VDMPut)
apply (rule, rule) apply (rule VDMComp) apply (erule_tac x=H in allE, simp) apply (erule_tac x=H in allE, simp)
apply (rule,rule) apply (rule VDMIff)  apply (erule_tac x=H in allE, simp) apply (erule_tac x=H in allE, simp)
apply (rule,rule) apply (rule VDMWhile) apply (erule_tac x=H in allE, simp)  apply (assumption) apply simp
apply (rule,rule) apply (rule VDMCall) apply (erule_tac x="({A} ∪ H)" in allE, simp) apply fast
apply (rule,rule) apply (rule VDMAx) apply fast
apply (rule,rule) apply (rule VDMConseq) apply (erule_tac x=H in allE, clarsimp) apply assumption apply assumption
done
(*>*)

lemma CutAux:
"(H ⊳ c : A) ⟹
(∀ G P D . (H = (insert P D) ⟶ G ⊳ Call :P ⟶ (G ⊆ D)
⟶ D ⊳ c:A))"
(*<*)
apply (erule VDM_proof.induct)
apply clarify
apply (fast intro: VDMSkip)
apply (fast intro: VDMAssign)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (rule VDMNew)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (rule VDMGet)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (rule VDMPut)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (erule_tac x=Ga in allE) apply (erule_tac x=Ga in allE)
apply (erule_tac x=P in allE) apply (erule_tac x=P in allE)
apply (erule_tac x=D in allE, erule impE, assumption)
apply (erule_tac x=D in allE, erule impE, assumption)
apply (rule VDMComp) apply simp apply simp
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (erule_tac x=Ga in allE) apply (erule_tac x=Ga in allE)
apply (erule_tac x=P in allE) apply (erule_tac x=P in allE)
apply (erule_tac x=D in allE, erule impE, assumption)
apply (erule_tac x=D in allE, erule impE, assumption)
apply (rule VDMIff) apply simp apply simp
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (erule_tac x=Ga in allE)
apply (erule_tac x=P in allE)
apply (erule_tac x=D in allE, erule impE, assumption)
apply (rule VDMWhile) apply simp apply simp
apply simp
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (erule_tac x=Ga in allE)
apply (erule_tac x=P in allE)
apply (erule_tac x="insert A D" in allE, erule impE, simp)
apply (rule VDMCall) apply fastforce
apply clarsimp
apply (erule disjE)
apply clarsimp apply (erule WEAK) apply assumption
apply (erule VDMAx)
apply clarsimp
apply (subgoal_tac "D ⊳  c : A")
apply (erule VDMConseq) apply simp
apply simp
done
(*>*)

lemma Cut:"⟦ G ⊳ Call : P ; (insert P G) ⊳ c : A ⟧ ⟹ G ⊳ c : A"
(*<*)by (drule CutAux , simp)(*>*)

definition verified::"Assn set ⇒ bool"
where "verified G = (∀ A . A:G ⟶ G ⊳ body : A)"

lemma verified_preserved: "⟦verified G; A:G⟧ ⟹ verified (G - {A})"
(*<*)
apply (simp add: verified_def, (rule allI)+, rule)
apply (subgoal_tac "(G - {A}) ⊳ Call:A")
(*now use the subgoal (G - {A}) ⊳ Call:A to prove the goal*)
apply (subgoal_tac "G = insert A (G - {A})") prefer 2 apply fast
apply (erule_tac x=Aa in allE)
apply (erule impE, simp)
apply (erule Cut)  apply simp
(* now prove the subgoal (G - {A}) ⊳  Call : A *)
apply (erule_tac x=A in allE, clarsimp)
apply (rule VDMCall) apply simp apply (erule WEAK) apply fast
done
(*>*)

(*<*)
lemma SetNonSingleton:
"⟦G ≠ {A}; A ∈ G⟧ ⟹ ∃B. B ≠ A ∧ B ∈ G"
by auto

lemma MutrecAux[rule_format]:
"∀ G . ((finite G ∧ card G = n ∧ verified G ∧ A : G) ⟶ {} ⊳ Call:A)"
apply (induct n)
(*case n=0*)
apply clarsimp
(*Case n>0*)
apply clarsimp
apply (case_tac "G = {A}")
apply clarsimp
apply (erule_tac x="{A}" in allE)
apply (rule VDMCall, clarsimp)
(*Case G has more entries than A*)
apply (drule SetNonSingleton, assumption)
(* use the fact that there is another entry B:G*)
apply clarsimp
apply (subgoal_tac "(G - {B}) ⊳ Call : B")
apply (erule_tac x="G - {B}" in allE)
apply (erule impE) apply (simp add: verified_preserved)
apply (erule impE) apply (simp add: card_Diff_singleton)
apply simp
(*the proof for (G - {B}) ⊳  Call : B *)
apply (rotate_tac 3) apply (erule_tac x=B in allE, simp)
apply (rule VDMCall) apply simp apply (erule WEAK) apply fast
done
(*>*)

theorem Mutrec:
"⟦ finite G; card G = n; verified G; A : G ⟧ ⟹ {} ⊳ Call:A"
(*<*)
by (rule MutrecAux, fast)
(*>*)

subsubsection‹Completeness›
definition SSpec::"OBJ ⇒ Assn"
where "SSpec c s t = (s,c ⇓ t)"

lemma SSpec_valid: "⊨ c : (SSpec c)"

lemma SSpec_strong: "⊨ c :A ⟹ ∀ s t . SSpec c s t ⟶ A s t"

lemma SSpec_derivable:"G ⊳ Call : SSpec Call ⟹ G ⊳ c : SSpec c"
(*<*)
apply (induct c)
apply (rule VDMConseq)
apply (rule VDMSkip) apply (simp add: SSpec_def Sem_def, rule, rule, rule) apply (rule SemSkip) apply simp
apply (rule VDMConseq)
apply (rule VDMAssign) apply (simp add: SSpec_def Sem_def, rule, rule, rule) apply (rule SemAssign) apply simp
apply (rule VDMConseq)
apply (rule VDMNew) apply (simp only: SSpec_def Sem_def, rule, rule, rule, rule)
apply (erule exE, erule conjE)
apply (rule SemNew) apply assumption apply assumption
apply (rule VDMConseq)
apply (rule VDMGet) apply (simp only: SSpec_def Sem_def, rule, rule, rule, rule)
apply (erule exE)+
apply (erule conjE)+
apply (rule SemGet) apply assumption apply assumption apply assumption apply assumption
apply (rule VDMConseq)
apply (rule VDMPut) apply (simp only: SSpec_def Sem_def, rule, rule, rule, rule)
apply (erule exE)+
apply (erule conjE)+
apply (rule SemPut) apply assumption apply assumption apply assumption
apply clarsimp
apply (rule VDMConseq)
apply (rule VDMComp) apply assumption+ apply (simp add: SSpec_def Sem_def, clarsimp)
apply rule apply (rule SemComp) apply assumption+ apply simp
apply clarsimp
apply (rule VDMConseq)
apply (erule VDMWhile)
prefer 3
apply (rename_tac BExpr c)
apply (subgoal_tac "∀s t. SSpec (While BExpr c) s t ∧ ¬ evalB BExpr (fst t) ⟶ SSpec (While BExpr c) s t", assumption)
apply simp
apply (simp only: SSpec_def Sem_def) apply (rule, rule, rule) apply (erule SemWhileF) apply simp
apply (simp only: SSpec_def Sem_def) apply (rule, rule, rule)
apply (rule, rule, rule) apply (erule exE)+ apply (rule, erule SemWhileT) apply assumption+ apply simp
apply clarsimp
apply (rule VDMConseq)
apply (rule VDMIff) apply assumption+ apply (simp only: SSpec_def Sem_def)
apply (erule thin_rl, erule thin_rl)
apply (rule, rule, rule)
apply (erule conjE)
apply (rename_tac BExpr c1 c2 s t)
apply (case_tac "evalB BExpr (fst s)")
apply (erule impE, assumption) apply (erule exE) apply (rule, rule SemTrue) apply assumption+
apply (rotate_tac 2, erule impE, assumption) apply (erule exE) apply (rule, rule SemFalse) apply assumption+
done
(*>*)

definition StrongG :: "Assn set"
where "StrongG = {SSpec Call}"

lemma StrongG_Body: "StrongG ⊳ body : SSpec Call"
(*<*)
apply (subgoal_tac "StrongG ⊳ body : SSpec body")
apply (erule VDMConseq) apply (simp add: SSpec_def Sem_def, clarsimp)
apply (rule, erule SemCall)
apply (rule SSpec_derivable) apply (rule VDMAx) apply (simp add: StrongG_def)
done
(*>*)

lemma StrongG_verified: "verified StrongG"
(*<*)
apply (rule allI)+
apply rule
apply (subgoal_tac "StrongG ⊳ body : SSpec Call")
apply (rule StrongG_Body)
done
(*>*)

lemma SSpec_derivable_empty:"{} ⊳ c : SSpec c"
(*<*)
apply (rule Cut)
apply (rule Mutrec) apply (subgoal_tac "finite StrongG", assumption)
apply (rule StrongG_verified)
apply (rule SSpec_derivable) apply (rule VDMAx) apply simp
done
(*>*)

theorem VDM_Complete: "⊨ c : A ⟹ {} ⊳ c : A"
(*<*)
apply (rule VDMConseq)
apply (rule SSpec_derivable_empty)
apply (erule SSpec_strong)
done
(*>*)

(*<*)

lemma Ctxt_valid_verified: "⊨ G ⟹ verified G"
(*<*)
apply (simp add: Ctxt_valid_def verified_def, clarsimp)
apply (erule_tac x=A in allE, simp)
apply (subgoal_tac "⊨ body : A")
apply (rotate_tac 1, erule thin_rl, drule VDM_Complete) apply (erule WEAK) apply fast
apply (simp only: VDM_valid_def Sem_def)
apply (rule, rule, rule)
apply (erule exE)
apply (erule_tac x=s in allE, erule_tac x=t in allE, erule mp)
apply (rule, erule SemCall)
done
(*>*)

lemma Ctxt_verified_valid: "⟦verified G; finite G⟧ ⟹ ⊨ G"
(*<*)
apply (subgoal_tac "(∀ A . A:G ⟶ G ⊳ body : A)")
prefer 2 apply (simp add: verified_def)