(*  Title:      Doc/Tutorial/Protocol/Public.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Theory of Public Keys (common to all public-key protocols)

Private and public keys; initial states of agents
*)(*<*)
theory Public imports Event
begin
(*>*)

text \<open>
The function
\<open>pubK\<close> maps agents to their public keys.  The function
\<open>priK\<close> maps agents to their private keys.  It is merely
an abbreviation (cf.\ \S\ref{sec:abbreviations}) defined in terms of
\<open>invKey\<close> and \<open>pubK\<close>.
\<close>

consts pubK :: "agent \<Rightarrow> key"
abbreviation priK :: "agent \<Rightarrow> key"
where "priK x  \<equiv>  invKey(pubK x)"
(*<*)
overloading initState \<equiv> initState
begin

primrec initState where
        (*Agents know their private key and all public keys*)
  initState_Server:  "initState Server     =
                         insert (Key (priK Server)) (Key ` range pubK)"
| initState_Friend:  "initState (Friend i) =
                         insert (Key (priK (Friend i))) (Key ` range pubK)"
| initState_Spy:     "initState Spy        =
                         (Key`invKey`pubK`bad) \<union> (Key ` range pubK)"

end
(*>*)

text \<open>
\noindent
The set \<open>bad\<close> consists of those agents whose private keys are known to
the spy.

Two axioms are asserted about the public-key cryptosystem.
No two agents have the same public key, and no private key equals
any public key.
\<close>

axiomatization where
  inj_pubK:        "inj pubK" and
  priK_neq_pubK:   "priK A \<noteq> pubK B"
(*<*)
lemmas [iff] = inj_pubK [THEN inj_eq]

lemma priK_inj_eq[iff]: "(priK A = priK B) = (A=B)"
  apply safe
  apply (drule_tac f=invKey in arg_cong)
  apply simp
  done

lemmas [iff] = priK_neq_pubK priK_neq_pubK [THEN not_sym]

lemma not_symKeys_pubK[iff]: "pubK A \<notin> symKeys"
  by (simp add: symKeys_def)

lemma not_symKeys_priK[iff]: "priK A \<notin> symKeys"
  by (simp add: symKeys_def)

lemma symKeys_neq_imp_neq: "(K \<in> symKeys) \<noteq> (K' \<in> symKeys) \<Longrightarrow> K \<noteq> K'"
  by blast

lemma analz_symKeys_Decrypt: "[| Crypt K X \<in> analz H;  K \<in> symKeys;  Key K \<in> analz H |]
     ==> X \<in> analz H"
  by (auto simp add: symKeys_def)

(** "Image" equations that hold for injective functions **)

lemma invKey_image_eq[simp]: "(invKey x \<in> invKey`A) = (x\<in>A)"
  by auto

(*holds because invKey is injective*)
lemma pubK_image_eq[simp]: "(pubK x \<in> pubK`A) = (x\<in>A)"
  by auto

lemma priK_pubK_image_eq[simp]: "(priK x \<notin> pubK`A)"
  by auto

(** Rewrites should not refer to  initState(Friend i)
    -- not in normal form! **)

lemma keysFor_parts_initState[simp]: "keysFor (parts (initState C)) = {}"
  apply (unfold keysFor_def)
  apply (induct C)
  apply (auto intro: range_eqI)
  done

(*** Function "spies" ***)

(*Agents see their own private keys!*)
lemma priK_in_initState[iff]: "Key (priK A) \<in> initState A"
  by (induct A) auto

(*All public keys are visible*)
lemma spies_pubK[iff]: "Key (pubK A) \<in> spies evs"
  by (induct evs) (simp_all add: imageI knows_Cons split: event.split)

(*Spy sees private keys of bad agents!*)
lemma Spy_spies_bad[intro!]: "A \<in> bad \<Longrightarrow> Key (priK A) \<in> spies evs"
  by (induct evs) (simp_all add: imageI knows_Cons split: event.split)

lemmas [iff] = spies_pubK [THEN analz.Inj]

(*** Fresh nonces ***)

lemma Nonce_notin_initState[iff]: "Nonce N \<notin> parts (initState B)"
  by (induct B) auto

lemma Nonce_notin_used_empty[simp]: "Nonce N \<notin> used []"
  by (simp add: used_Nil)

(*** Supply fresh nonces for possibility theorems. ***)

(*In any trace, there is an upper bound N on the greatest nonce in use.*)
lemma Nonce_supply_lemma: "\<exists>N. \<forall>n. N\<le>n \<longrightarrow> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all (no_asm_simp) add: used_Cons split: event.split)
apply safe
apply (rule msg_Nonce_supply [THEN exE], blast elim!: add_leE)+
done

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
by (rule Nonce_supply_lemma [THEN exE], blast)

lemma Nonce_supply: "Nonce (SOME N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, fast)
done

(*** Specialized rewriting for the analz_image_... theorems ***)

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
  by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key ` (insert K KK) \<union> C"
  by blast

(*Specialized methods*)

(*Tactic for possibility theorems*)
ML \<open>
fun possibility_tac ctxt =
    REPEAT (*omit used_Says so that Nonces start from different traces!*)
    (ALLGOALS (simp_tac (ctxt delsimps [used_Says]))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}]));
\<close>

method_setup possibility = \<open>Scan.succeed (SIMPLE_METHOD o possibility_tac)\<close>
    "for proving possibility theorems"

end
(*>*)


(* Title: Refinement Component Based on KAT: Examples
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

subsubsection \<open>Refinement Examples\<close>

theory VC_RKAT_Examples
  imports VC_RKAT
begin

text \<open>Currently  there is only one example, and no tactic for automating refinement proofs is provided.\<close>

lemma var_swap_ref1:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref2:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''x'' ::= (\<lambda>s. s ''y'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref3:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''y'' ::= (\<lambda>s. s ''z'')); rel_R \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref_var:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); (''x'' ::= (\<lambda>s. s ''y'')); (''y'' ::= (\<lambda>s. s ''z''))"
  using var_swap_ref1 var_swap_ref2 var_swap_ref3 rel_rkat.R_skip by fastforce

end


(*  Title:      HOL/Auth/Guard/Extensions.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section \<open>Extensions to Standard Theories\<close>

theory Extensions
imports "../Event"
begin

subsection\<open>Extensions to Theory \<open>Set\<close>\<close>

lemma eq: "\<lbrakk>\<And>x. x\<in>A \<Longrightarrow> x\<in>B; \<And>x. x\<in>B \<Longrightarrow> x\<in>A\<rbrakk> \<Longrightarrow> A=B"
by auto

lemma insert_Un: "P ({x} \<union> A) \<Longrightarrow> P (insert x A)"
by simp

lemma in_sub: "x\<in>A \<Longrightarrow> {x}\<subseteq>A"
by auto

subsection\<open>Extensions to Theory \<open>List\<close>\<close>

subsubsection\<open>"remove l x" erase the first element of "l" equal to "x"\<close>

primrec remove :: "'a list => 'a => 'a list" where
"remove [] y = []" |
"remove (x#xs) y = (if x=y then xs else x # remove xs y)"

lemma set_remove: "set (remove l x) <= set l"
by (induct l, auto)

subsection\<open>Extensions to Theory \<open>Message\<close>\<close>

subsubsection\<open>declarations for tactics\<close>

declare analz_subset_parts [THEN subsetD, dest]
declare parts_insert2 [simp]
declare analz_cut [dest]
declare if_split_asm [split]
declare analz_insertI [intro]
declare Un_Diff [simp]

subsubsection\<open>extract the agent number of an Agent message\<close>

primrec agt_nb :: "msg => agent" where
"agt_nb (Agent A) = A"

subsubsection\<open>messages that are pairs\<close>

definition is_MPair :: "msg => bool" where
"is_MPair X == \<exists>Y Z. X = \<lbrace>Y,Z\<rbrace>"

declare is_MPair_def [simp]

lemma MPair_is_MPair [iff]: "is_MPair \<lbrace>X,Y\<rbrace>"
by simp

lemma Agent_isnt_MPair [iff]: "~ is_MPair (Agent A)"
by simp

lemma Number_isnt_MPair [iff]: "~ is_MPair (Number n)"
by simp

lemma Key_isnt_MPair [iff]: "~ is_MPair (Key K)"
by simp

lemma Nonce_isnt_MPair [iff]: "~ is_MPair (Nonce n)"
by simp

lemma Hash_isnt_MPair [iff]: "~ is_MPair (Hash X)"
by simp

lemma Crypt_isnt_MPair [iff]: "~ is_MPair (Crypt K X)"
by simp

abbreviation
  not_MPair :: "msg => bool" where
  "not_MPair X == ~ is_MPair X"

lemma is_MPairE: "\<lbrakk>is_MPair X \<Longrightarrow> P; not_MPair X \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by auto

declare is_MPair_def [simp del]

definition has_no_pair :: "msg set => bool" where
"has_no_pair H == \<forall>X Y. \<lbrace>X,Y\<rbrace> \<notin> H"

declare has_no_pair_def [simp]

subsubsection\<open>well-foundedness of messages\<close>

lemma wf_Crypt1 [iff]: "Crypt K X ~= X"
by (induct X, auto)

lemma wf_Crypt2 [iff]: "X ~= Crypt K X"
by (induct X, auto)

lemma parts_size: "X \<in> parts {Y} \<Longrightarrow> X=Y \<or> size X < size Y"
by (erule parts.induct, auto)

lemma wf_Crypt_parts [iff]: "Crypt K X \<notin> parts {X}"
by (auto dest: parts_size)

subsubsection\<open>lemmas on keysFor\<close>

definition usekeys :: "msg set => key set" where
"usekeys G \<equiv> {K. \<exists>Y. Crypt K Y \<in> G}"

lemma finite_keysFor [intro]: "finite G \<Longrightarrow> finite (keysFor G)"
apply (simp add: keysFor_def)
apply (rule finite_imageI)
apply (induct G rule: finite_induct)
apply auto
apply (case_tac "\<exists>K X. x = Crypt K X", clarsimp)
apply (subgoal_tac "{Ka. \<exists>Xa. (Ka=K \<and> Xa=X) \<or> Crypt Ka Xa \<in> F}
= insert K (usekeys F)", auto simp: usekeys_def)
by (subgoal_tac "{K. \<exists>X. Crypt K X = x \<or> Crypt K X \<in> F} = usekeys F",
auto simp: usekeys_def)

subsubsection\<open>lemmas on parts\<close>

lemma parts_sub: "\<lbrakk>X \<in> parts G; G \<subseteq> H\<rbrakk> \<Longrightarrow> X \<in> parts H"
by (auto dest: parts_mono)

lemma parts_Diff [dest]: "X \<in> parts (G - H) \<Longrightarrow> X \<in> parts G"
by (erule parts_sub, auto)

lemma parts_Diff_notin: "\<lbrakk>Y \<notin> H; Nonce n \<notin> parts (H - {Y})\<rbrakk>
\<Longrightarrow> Nonce n \<notin> parts H"
by simp

lemmas parts_insert_substI = parts_insert [THEN ssubst]
lemmas parts_insert_substD = parts_insert [THEN sym, THEN ssubst]

lemma finite_parts_msg [iff]: "finite (parts {X})"
by (induct X, auto)

lemma finite_parts [intro]: "finite H \<Longrightarrow> finite (parts H)"
apply (erule finite_induct, simp)
by (rule parts_insert_substI, simp)

lemma parts_parts: "\<lbrakk>X \<in> parts {Y}; Y \<in> parts G\<rbrakk> \<Longrightarrow> X \<in> parts G"
by (frule parts_cut, auto)

lemma parts_parts_parts: "\<lbrakk>X \<in> parts {Y}; Y \<in> parts {Z}; Z \<in> parts G\<rbrakk> \<Longrightarrow> X \<in> parts G"
by (auto dest: parts_parts)

lemma parts_parts_Crypt: "\<lbrakk>Crypt K X \<in> parts G; Nonce n \<in> parts {X}\<rbrakk>
\<Longrightarrow> Nonce n \<in> parts G"
by (blast intro: parts.Body dest: parts_parts)

subsubsection\<open>lemmas on synth\<close>

lemma synth_sub: "\<lbrakk>X \<in> synth G; G \<subseteq> H\<rbrakk> \<Longrightarrow> X \<in> synth H"
by (auto dest: synth_mono)

lemma Crypt_synth [rule_format]: "\<lbrakk>X \<in> synth G; Key K \<notin> G\<rbrakk> \<Longrightarrow>
Crypt K Y \<in> parts {X} \<longrightarrow> Crypt K Y \<in> parts G"
by (erule synth.induct, auto dest: parts_sub)

subsubsection\<open>lemmas on analz\<close>

lemma analz_UnI1 [intro]: "X \<in> analz G \<Longrightarrow> X \<in> analz (G \<union> H)"
  by (subgoal_tac "G <= G Un H") (blast dest: analz_mono)+

lemma analz_sub: "\<lbrakk>X \<in> analz G; G \<subseteq> H\<rbrakk> \<Longrightarrow> X \<in> analz H"
by (auto dest: analz_mono)

lemma analz_Diff [dest]: "X \<in> analz (G - H) \<Longrightarrow> X \<in> analz G"
by (erule analz.induct, auto)

lemmas in_analz_subset_cong = analz_subset_cong [THEN subsetD]

lemma analz_eq: "A=A' \<Longrightarrow> analz A = analz A'"
by auto

lemmas insert_commute_substI = insert_commute [THEN ssubst]

lemma analz_insertD:
     "\<lbrakk>Crypt K Y \<in> H; Key (invKey K) \<in> H\<rbrakk> \<Longrightarrow> analz (insert Y H) = analz H"
by (blast intro: analz.Decrypt analz_insert_eq)

lemma must_decrypt [rule_format,dest]: "\<lbrakk>X \<in> analz H; has_no_pair H\<rbrakk> \<Longrightarrow>
X \<notin> H \<longrightarrow> (\<exists>K Y. Crypt K Y \<in> H \<and> Key (invKey K) \<in> H)"
by (erule analz.induct, auto)

lemma analz_needs_only_finite: "X \<in> analz H \<Longrightarrow> \<exists>G. G \<subseteq> H \<and> finite G"
by (erule analz.induct, auto)

lemma notin_analz_insert: "X \<notin> analz (insert Y G) \<Longrightarrow> X \<notin> analz G"
by auto

subsubsection\<open>lemmas on parts, synth and analz\<close>

lemma parts_invKey [rule_format,dest]:"X \<in> parts {Y} \<Longrightarrow>
X \<in> analz (insert (Crypt K Y) H) \<longrightarrow> X \<notin> analz H \<longrightarrow> Key (invKey K) \<in> analz H"
by (erule parts.induct, auto dest: parts.Fst parts.Snd parts.Body)

lemma in_analz: "Y \<in> analz H \<Longrightarrow> \<exists>X. X \<in> H \<and> Y \<in> parts {X}"
by (erule analz.induct, auto intro: parts.Fst parts.Snd parts.Body)

lemmas in_analz_subset_parts = analz_subset_parts [THEN subsetD]

lemma Crypt_synth_insert: "\<lbrakk>Crypt K X \<in> parts (insert Y H);
Y \<in> synth (analz H); Key K \<notin> analz H\<rbrakk> \<Longrightarrow> Crypt K X \<in> parts H"
apply (drule parts_insert_substD, clarify)
apply (frule in_sub)
apply (frule parts_mono)
apply auto
done

subsubsection\<open>greatest nonce used in a message\<close>

fun greatest_msg :: "msg => nat"
where
  "greatest_msg (Nonce n) = n"
| "greatest_msg \<lbrace>X,Y\<rbrace> = max (greatest_msg X) (greatest_msg Y)"
| "greatest_msg (Crypt K X) = greatest_msg X"
| "greatest_msg other = 0"

lemma greatest_msg_is_greatest: "Nonce n \<in> parts {X} \<Longrightarrow> n \<le> greatest_msg X"
by (induct X, auto)

subsubsection\<open>sets of keys\<close>

definition keyset :: "msg set => bool" where
"keyset G \<equiv> \<forall>X. X \<in> G \<longrightarrow> (\<exists>K. X = Key K)"

lemma keyset_in [dest]: "\<lbrakk>keyset G; X \<in> G\<rbrakk> \<Longrightarrow> \<exists>K. X = Key K"
by (auto simp: keyset_def)

lemma MPair_notin_keyset [simp]: "keyset G \<Longrightarrow> \<lbrace>X,Y\<rbrace> \<notin> G"
by auto

lemma Crypt_notin_keyset [simp]: "keyset G \<Longrightarrow> Crypt K X \<notin> G"
by auto

lemma Nonce_notin_keyset [simp]: "keyset G \<Longrightarrow> Nonce n \<notin> G"
by auto

lemma parts_keyset [simp]: "keyset G \<Longrightarrow> parts G = G"
by (auto, erule parts.induct, auto)

subsubsection\<open>keys a priori necessary for decrypting the messages of G\<close>

definition keysfor :: "msg set => msg set" where
"keysfor G == Key ` keysFor (parts G)"

lemma keyset_keysfor [iff]: "keyset (keysfor G)"
by (simp add: keyset_def keysfor_def, blast)

lemma keyset_Diff_keysfor [simp]: "keyset H \<Longrightarrow> keyset (H - keysfor G)"
by (auto simp: keyset_def)

lemma keysfor_Crypt: "Crypt K X \<in> parts G \<Longrightarrow> Key (invKey K) \<in> keysfor G"
by (auto simp: keysfor_def Crypt_imp_invKey_keysFor)

lemma no_key_no_Crypt: "Key K \<notin> keysfor G \<Longrightarrow> Crypt (invKey K) X \<notin> parts G"
by (auto dest: keysfor_Crypt)

lemma finite_keysfor [intro]: "finite G \<Longrightarrow> finite (keysfor G)"
by (auto simp: keysfor_def intro: finite_UN_I)

subsubsection\<open>only the keys necessary for G are useful in analz\<close>

lemma analz_keyset: "keyset H \<Longrightarrow>
analz (G Un H) = H - keysfor G Un (analz (G Un (H Int keysfor G)))"
apply (rule eq)
apply (erule analz.induct, blast)
apply (simp, blast)
apply (simp, blast)
apply (case_tac "Key (invKey K) \<in> H - keysfor G", clarsimp)
apply (drule_tac X=X in no_key_no_Crypt)
by (auto intro: analz_sub)

lemmas analz_keyset_substD = analz_keyset [THEN sym, THEN ssubst]

subsection\<open>Extensions to Theory \<open>Event\<close>\<close>

subsubsection\<open>general protocol properties\<close>

definition is_Says :: "event => bool" where
"is_Says ev == (\<exists>A B X. ev = Says A B X)"

lemma is_Says_Says [iff]: "is_Says (Says A B X)"
by (simp add: is_Says_def)

(* one could also require that Gets occurs after Says
but this is sufficient for our purpose *)
definition Gets_correct :: "event list set => bool" where
"Gets_correct p == \<forall>evs B X. evs \<in> p \<longrightarrow> Gets B X \<in> set evs
\<longrightarrow> (\<exists>A. Says A B X \<in> set evs)"

lemma Gets_correct_Says: "\<lbrakk>Gets_correct p; Gets B X # evs \<in> p\<rbrakk>
\<Longrightarrow> \<exists>A. Says A B X \<in> set evs"
apply (simp add: Gets_correct_def)
by (drule_tac x="Gets B X # evs" in spec, auto)

definition one_step :: "event list set => bool" where
"one_step p == \<forall>evs ev. ev#evs \<in> p \<longrightarrow> evs \<in> p"

lemma one_step_Cons [dest]: "\<lbrakk>one_step p; ev#evs \<in> p\<rbrakk> \<Longrightarrow> evs \<in> p"
  unfolding one_step_def by blast

lemma one_step_app: "\<lbrakk>evs@evs' \<in> p; one_step p; [] \<in> p\<rbrakk> \<Longrightarrow> evs' \<in> p"
by (induct evs, auto)

lemma trunc: "\<lbrakk>evs @ evs' \<in> p; one_step p\<rbrakk> \<Longrightarrow> evs' \<in> p"
by (induct evs, auto)

definition has_only_Says :: "event list set => bool" where
"has_only_Says p \<equiv> \<forall>evs ev. evs \<in> p \<longrightarrow> ev \<in> set evs
\<longrightarrow> (\<exists>A B X. ev = Says A B X)"

lemma has_only_SaysD: "\<lbrakk>ev \<in> set evs; evs \<in> p; has_only_Says p\<rbrakk>
\<Longrightarrow> \<exists>A B X. ev = Says A B X"
  unfolding has_only_Says_def by blast

lemma in_has_only_Says [dest]: "\<lbrakk>has_only_Says p; evs \<in> p; ev \<in> set evs\<rbrakk>
\<Longrightarrow> \<exists>A B X. ev = Says A B X"
by (auto simp: has_only_Says_def)

lemma has_only_Says_imp_Gets_correct [simp]: "has_only_Says p
\<Longrightarrow> Gets_correct p"
by (auto simp: has_only_Says_def Gets_correct_def)

subsubsection\<open>lemma on knows\<close>

lemma Says_imp_spies2: "Says A B \<lbrace>X,Y\<rbrace> \<in> set evs \<Longrightarrow> Y \<in> parts (spies evs)"
by (drule Says_imp_spies, drule parts.Inj, drule parts.Snd, simp)

lemma Says_not_parts: "\<lbrakk>Says A B X \<in> set evs; Y \<notin> parts (spies evs)\<rbrakk>
\<Longrightarrow> Y \<notin> parts {X}"
by (auto dest: Says_imp_spies parts_parts)

subsubsection\<open>knows without initState\<close>

primrec knows' :: "agent => event list => msg set" where
  knows'_Nil: "knows' A [] = {}" |
  knows'_Cons0:
 "knows' A (ev # evs) = (
   if A = Spy then (
     case ev of
       Says A' B X => insert X (knows' A evs)
     | Gets A' X => knows' A evs
     | Notes A' X => if A' \<in> bad then insert X (knows' A evs) else knows' A evs
   ) else (
     case ev of
       Says A' B X => if A=A' then insert X (knows' A evs) else knows' A evs
     | Gets A' X => if A=A' then insert X (knows' A evs) else knows' A evs
     | Notes A' X => if A=A' then insert X (knows' A evs) else knows' A evs
   ))"

abbreviation
  spies' :: "event list => msg set" where
  "spies' == knows' Spy"

subsubsection\<open>decomposition of knows into knows' and initState\<close>

lemma knows_decomp: "knows A evs = knows' A evs Un (initState A)"
by (induct evs, auto split: event.split simp: knows.simps)

lemmas knows_decomp_substI = knows_decomp [THEN ssubst]
lemmas knows_decomp_substD = knows_decomp [THEN sym, THEN ssubst]

lemma knows'_sub_knows: "knows' A evs <= knows A evs"
by (auto simp: knows_decomp)

lemma knows'_Cons: "knows' A (ev#evs) = knows' A [ev] Un knows' A evs"
by (induct ev, auto)

lemmas knows'_Cons_substI = knows'_Cons [THEN ssubst]
lemmas knows'_Cons_substD = knows'_Cons [THEN sym, THEN ssubst]

lemma knows_Cons: "knows A (ev#evs) = initState A Un knows' A [ev]
Un knows A evs"
apply (simp only: knows_decomp)
apply (rule_tac s="(knows' A [ev] Un knows' A evs) Un initState A" in trans)
apply (simp only: knows'_Cons [of A ev evs] Un_ac)
apply blast
done

lemmas knows_Cons_substI = knows_Cons [THEN ssubst]
lemmas knows_Cons_substD = knows_Cons [THEN sym, THEN ssubst]

lemma knows'_sub_spies': "\<lbrakk>evs \<in> p; has_only_Says p; one_step p\<rbrakk>
\<Longrightarrow> knows' A evs \<subseteq> spies' evs"
by (induct evs, auto split: event.splits)

subsubsection\<open>knows' is finite\<close>

lemma finite_knows' [iff]: "finite (knows' A evs)"
by (induct evs, auto split: event.split simp: knows.simps)

subsubsection\<open>monotonicity of knows\<close>

lemma knows_sub_Cons: "knows A evs <= knows A (ev#evs)"
by(cases A, induct evs, auto simp: knows.simps split:event.split)

lemma knows_ConsI: "X \<in> knows A evs \<Longrightarrow> X \<in> knows A (ev#evs)"
by (auto dest: knows_sub_Cons [THEN subsetD])

lemma knows_sub_app: "knows A evs <= knows A (evs @ evs')"
apply (induct evs, auto)
apply (simp add: knows_decomp)
apply (rename_tac a b c)
by (case_tac a, auto simp: knows.simps)

subsubsection\<open>maximum knowledge an agent can have
includes messages sent to the agent\<close>

primrec knows_max' :: "agent => event list => msg set" where
knows_max'_def_Nil: "knows_max' A [] = {}" |
knows_max'_def_Cons: "knows_max' A (ev # evs) = (
  if A=Spy then (
    case ev of
      Says A' B X => insert X (knows_max' A evs)
    | Gets A' X => knows_max' A evs
    | Notes A' X =>
      if A' \<in> bad then insert X (knows_max' A evs) else knows_max' A evs
  ) else (
    case ev of
      Says A' B X =>
      if A=A' | A=B then insert X (knows_max' A evs) else knows_max' A evs
    | Gets A' X =>
      if A=A' then insert X (knows_max' A evs) else knows_max' A evs
    | Notes A' X =>
      if A=A' then insert X (knows_max' A evs) else knows_max' A evs
  ))"

definition knows_max :: "agent => event list => msg set" where
"knows_max A evs == knows_max' A evs Un initState A"

abbreviation
  spies_max :: "event list => msg set" where
  "spies_max evs == knows_max Spy evs"

subsubsection\<open>basic facts about \<^term>\<open>knows_max\<close>\<close>

lemma spies_max_spies [iff]: "spies_max evs = spies evs"
by (induct evs, auto simp: knows_max_def split: event.splits)

lemma knows_max'_Cons: "knows_max' A (ev#evs)
= knows_max' A [ev] Un knows_max' A evs"
by (auto split: event.splits)

lemmas knows_max'_Cons_substI = knows_max'_Cons [THEN ssubst]
lemmas knows_max'_Cons_substD = knows_max'_Cons [THEN sym, THEN ssubst]

lemma knows_max_Cons: "knows_max A (ev#evs)
= knows_max' A [ev] Un knows_max A evs"
apply (simp add: knows_max_def del: knows_max'_def_Cons)
apply (rule_tac evs=evs in knows_max'_Cons_substI)
by blast

lemmas knows_max_Cons_substI = knows_max_Cons [THEN ssubst]
lemmas knows_max_Cons_substD = knows_max_Cons [THEN sym, THEN ssubst]

lemma finite_knows_max' [iff]: "finite (knows_max' A evs)"
by (induct evs, auto split: event.split)

lemma knows_max'_sub_spies': "\<lbrakk>evs \<in> p; has_only_Says p; one_step p\<rbrakk>
\<Longrightarrow> knows_max' A evs \<subseteq> spies' evs"
by (induct evs, auto split: event.splits)

lemma knows_max'_in_spies' [dest]: "\<lbrakk>evs \<in> p; X \<in> knows_max' A evs;
has_only_Says p; one_step p\<rbrakk> \<Longrightarrow> X \<in> spies' evs"
by (rule knows_max'_sub_spies' [THEN subsetD], auto)

lemma knows_max'_app: "knows_max' A (evs @ evs')
= knows_max' A evs Un knows_max' A evs'"
by (induct evs, auto split: event.splits)

lemma Says_to_knows_max': "Says A B X \<in> set evs \<Longrightarrow> X \<in> knows_max' B evs"
by (simp add: in_set_conv_decomp, clarify, simp add: knows_max'_app)

lemma Says_from_knows_max': "Says A B X \<in> set evs \<Longrightarrow> X \<in> knows_max' A evs"
by (simp add: in_set_conv_decomp, clarify, simp add: knows_max'_app)

subsubsection\<open>used without initState\<close>

primrec used' :: "event list => msg set" where
"used' [] = {}" |
"used' (ev # evs) = (
  case ev of
    Says A B X => parts {X} Un used' evs
    | Gets A X => used' evs
    | Notes A X => parts {X} Un used' evs
  )"

definition init :: "msg set" where
"init == used []"

lemma used_decomp: "used evs = init Un used' evs"
by (induct evs, auto simp: init_def split: event.split)

lemma used'_sub_app: "used' evs \<subseteq> used' (evs@evs')"
by (induct evs, auto split: event.split)

lemma used'_parts [rule_format]: "X \<in> used' evs \<Longrightarrow> Y \<in> parts {X} \<longrightarrow> Y \<in> used' evs"
apply (induct evs, simp)
apply (rename_tac a b)
apply (case_tac a, simp_all)
apply (blast dest: parts_trans)+
done

subsubsection\<open>monotonicity of used\<close>

lemma used_sub_Cons: "used evs <= used (ev#evs)"
by (induct evs, (induct ev, auto)+)

lemma used_ConsI: "X \<in> used evs \<Longrightarrow> X \<in> used (ev#evs)"
by (auto dest: used_sub_Cons [THEN subsetD])

lemma notin_used_ConsD: "X \<notin> used (ev#evs) \<Longrightarrow> X \<notin> used evs"
by (auto dest: used_sub_Cons [THEN subsetD])

lemma used_appD [dest]: "X \<in> used (evs @ evs') \<Longrightarrow> X \<in> used evs \<or> X \<in> used evs'"
by (induct evs, auto, rename_tac a b, case_tac a, auto)

lemma used_ConsD: "X \<in> used (ev#evs) \<Longrightarrow> X \<in> used [ev] \<or> X \<in> used evs"
by (case_tac ev, auto)

lemma used_sub_app: "used evs <= used (evs@evs')"
by (auto simp: used_decomp dest: used'_sub_app [THEN subsetD])

lemma used_appIL: "X \<in> used evs \<Longrightarrow> X \<in> used (evs' @ evs)"
by (induct evs', auto intro: used_ConsI)

lemma used_appIR: "X \<in> used evs \<Longrightarrow> X \<in> used (evs @ evs')"
by (erule used_sub_app [THEN subsetD])

lemma used_parts: "\<lbrakk>X \<in> parts {Y}; Y \<in> used evs\<rbrakk> \<Longrightarrow> X \<in> used evs"
apply (auto simp: used_decomp dest: used'_parts)
by (auto simp: init_def used_Nil dest: parts_trans)

lemma parts_Says_used: "\<lbrakk>Says A B X \<in> set evs; Y \<in> parts {X}\<rbrakk> \<Longrightarrow> Y \<in> used evs"
by (induct evs, simp_all, safe, auto intro: used_ConsI)

lemma parts_used_app: "X \<in> parts {Y} \<Longrightarrow> X \<in> used (evs @ Says A B Y # evs')"
apply (drule_tac evs="[Says A B Y]" in used_parts, simp, blast)
apply (drule_tac evs'=evs' in used_appIR)
apply (drule_tac evs'=evs in used_appIL)
by simp

subsubsection\<open>lemmas on used and knows\<close>

lemma initState_used: "X \<in> parts (initState A) \<Longrightarrow> X \<in> used evs"
by (induct evs, auto simp: used.simps split: event.split)

lemma Says_imp_used: "Says A B X \<in> set evs \<Longrightarrow> parts {X} \<subseteq> used evs"
by (induct evs, auto intro: used_ConsI)

lemma not_used_not_spied: "X \<notin> used evs \<Longrightarrow> X \<notin> parts (spies evs)"
by (induct evs, auto simp: used_Nil)

lemma not_used_not_parts: "\<lbrakk>Y \<notin> used evs; Says A B X \<in> set evs\<rbrakk>
\<Longrightarrow> Y \<notin> parts {X}"
by (induct evs, auto intro: used_ConsI)

lemma not_used_parts_false: "\<lbrakk>X \<notin> used evs; Y \<in> parts (spies evs)\<rbrakk>
\<Longrightarrow> X \<notin> parts {Y}"
by (auto dest: parts_parts)

lemma known_used [rule_format]: "\<lbrakk>evs \<in> p; Gets_correct p; one_step p\<rbrakk>
\<Longrightarrow> X \<in> parts (knows A evs) \<longrightarrow> X \<in> used evs"
apply (case_tac "A=Spy", blast)
apply (induct evs)
apply (simp add: used.simps, blast)
apply (rename_tac a evs)
apply (frule_tac ev=a and evs=evs in one_step_Cons, simp, clarify)
apply (drule_tac P="\<lambda>G. X \<in> parts G" in knows_Cons_substD, safe)
apply (erule initState_used)
apply (case_tac a, auto)
apply (rename_tac msg)
apply (drule_tac B=A and X=msg and evs=evs in Gets_correct_Says)
by (auto dest: Says_imp_used intro: used_ConsI)

lemma known_max_used [rule_format]: "\<lbrakk>evs \<in> p; Gets_correct p; one_step p\<rbrakk>
\<Longrightarrow> X \<in> parts (knows_max A evs) \<longrightarrow> X \<in> used evs"
apply (case_tac "A=Spy")
apply force
apply (induct evs)
apply (simp add: knows_max_def used.simps, blast)
apply (rename_tac a evs)
apply (frule_tac ev=a and evs=evs in one_step_Cons, simp, clarify)
apply (drule_tac P="\<lambda>G. X \<in> parts G" in knows_max_Cons_substD, safe)
apply (case_tac a, auto)
apply (rename_tac msg)
apply (drule_tac B=A and X=msg and evs=evs in Gets_correct_Says)
by (auto simp: knows_max'_Cons dest: Says_imp_used intro: used_ConsI)

lemma not_used_not_known: "\<lbrakk>evs \<in> p; X \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> X \<notin> parts (knows A evs)"
by (case_tac "A=Spy", auto dest: not_used_not_spied known_used)

lemma not_used_not_known_max: "\<lbrakk>evs \<in> p; X \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> X \<notin> parts (knows_max A evs)"
by (case_tac "A=Spy", auto dest: not_used_not_spied known_max_used)

subsubsection\<open>a nonce or key in a message cannot equal a fresh nonce or key\<close>

lemma Nonce_neq [dest]: "\<lbrakk>Nonce n' \<notin> used evs;
Says A B X \<in> set evs; Nonce n \<in> parts {X}\<rbrakk> \<Longrightarrow> n \<noteq> n'"
by (drule not_used_not_spied, auto dest: Says_imp_knows_Spy parts_sub)

lemma Key_neq [dest]: "\<lbrakk>Key n' \<notin> used evs;
Says A B X \<in> set evs; Key n \<in> parts {X}\<rbrakk> \<Longrightarrow> n ~= n'"
by (drule not_used_not_spied, auto dest: Says_imp_knows_Spy parts_sub)

subsubsection\<open>message of an event\<close>

primrec msg :: "event => msg"
where
  "msg (Says A B X) = X"
| "msg (Gets A X) = X"
| "msg (Notes A X) = X"

lemma used_sub_parts_used: "X \<in> used (ev # evs) \<Longrightarrow> X \<in> parts {msg ev} \<union> used evs"
by (induct ev, auto)

end


(*  Title:      HOL/Hoare/SchorrWaite.thy
    Author:     Farhad Mehta
    Copyright   2003 TUM
*)

section \<open>Proof of the Schorr-Waite graph marking algorithm\<close>

theory SchorrWaite
  imports HeapSyntax
begin

subsection \<open>Machinery for the Schorr-Waite proof\<close>

definition
  \<comment> \<open>Relations induced by a mapping\<close>
  rel :: "('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<times> 'a) set"
  where "rel m = {(x,y). m x = Ref y}"

definition
  relS :: "('a \<Rightarrow> 'a ref) set \<Rightarrow> ('a \<times> 'a) set"
  where "relS M = (\<Union>m \<in> M. rel m)"

definition
  addrs :: "'a ref set \<Rightarrow> 'a set"
  where "addrs P = {a. Ref a \<in> P}"

definition
  reachable :: "('a \<times> 'a) set \<Rightarrow> 'a ref set \<Rightarrow> 'a set"
  where "reachable r P = (r\<^sup>* `` addrs P)"

lemmas rel_defs = relS_def rel_def

text \<open>Rewrite rules for relations induced by a mapping\<close>

lemma self_reachable: "b \<in> B \<Longrightarrow> b \<in> R\<^sup>* `` B"
apply blast
done

lemma oneStep_reachable: "b \<in> R``B \<Longrightarrow> b \<in> R\<^sup>* `` B"
apply blast
done

lemma still_reachable: "\<lbrakk>B\<subseteq>Ra\<^sup>*``A; \<forall> (x,y) \<in> Rb-Ra. y\<in> (Ra\<^sup>*``A)\<rbrakk> \<Longrightarrow> Rb\<^sup>* `` B \<subseteq> Ra\<^sup>* `` A "
apply (clarsimp simp only:Image_iff)
apply (erule rtrancl_induct)
 apply blast
apply (subgoal_tac "(y, z) \<in> Ra\<union>(Rb-Ra)")
 apply (erule UnE)
 apply (auto intro:rtrancl_into_rtrancl)
apply blast
done

lemma still_reachable_eq: "\<lbrakk> A\<subseteq>Rb\<^sup>*``B; B\<subseteq>Ra\<^sup>*``A; \<forall> (x,y) \<in> Ra-Rb. y \<in>(Rb\<^sup>*``B); \<forall> (x,y) \<in> Rb-Ra. y\<in> (Ra\<^sup>*``A)\<rbrakk> \<Longrightarrow> Ra\<^sup>*``A =  Rb\<^sup>*``B "
apply (rule equalityI)
 apply (erule still_reachable ,assumption)+
done

lemma reachable_null: "reachable mS {Null} = {}"
apply (simp add: reachable_def addrs_def)
done

lemma reachable_empty: "reachable mS {} = {}"
apply (simp add: reachable_def addrs_def)
done

lemma reachable_union: "(reachable mS aS \<union> reachable mS bS) = reachable mS (aS \<union> bS)"
apply (simp add: reachable_def rel_defs addrs_def)
apply blast
done

lemma reachable_union_sym: "reachable r (insert a aS) = (r\<^sup>* `` addrs {a}) \<union> reachable r aS"
apply (simp add: reachable_def rel_defs addrs_def)
apply blast
done

lemma rel_upd1: "(a,b) \<notin> rel (r(q:=t)) \<Longrightarrow> (a,b) \<in> rel r \<Longrightarrow> a=q"
apply (rule classical)
apply (simp add:rel_defs fun_upd_apply)
done

lemma rel_upd2: "(a,b)  \<notin> rel r \<Longrightarrow> (a,b) \<in> rel (r(q:=t)) \<Longrightarrow> a=q"
apply (rule classical)
apply (simp add:rel_defs fun_upd_apply)
done

definition
  \<comment> \<open>Restriction of a relation\<close>
  restr ::"('a \<times> 'a) set \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'a) set"       ("(_/ | _)" [50, 51] 50)
  where "restr r m = {(x,y). (x,y) \<in> r \<and> \<not> m x}"

text \<open>Rewrite rules for the restriction of a relation\<close>

lemma restr_identity[simp]:
 " (\<forall>x. \<not> m x) \<Longrightarrow> (R |m) = R"
by (auto simp add:restr_def)

lemma restr_rtrancl[simp]: " \<lbrakk>m l\<rbrakk> \<Longrightarrow> (R | m)\<^sup>* `` {l} = {l}"
by (auto simp add:restr_def elim:converse_rtranclE)

lemma restr_upd: "((rel (r (q := t)))|(m(q := True))) = ((rel (r))|(m(q := True))) "
apply (auto simp:restr_def rel_def fun_upd_apply)
apply (rename_tac a b)
apply (case_tac "a=q")
 apply auto
done

lemma restr_un: "((r \<union> s)|m) = (r|m) \<union> (s|m)"
  by (auto simp add:restr_def)

lemma rel_upd3: "(a, b) \<notin> (r|(m(q := t))) \<Longrightarrow> (a,b) \<in> (r|m) \<Longrightarrow> a = q "
apply (rule classical)
apply (simp add:restr_def fun_upd_apply)
done

definition
  \<comment> \<open>A short form for the stack mapping function for List\<close>
  S :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref)"
  where "S c l r = (\<lambda>x. if c x then r x else l x)"

text \<open>Rewrite rules for Lists using S as their mapping\<close>

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S c l r) p stack = List (S (c(a:=x)) (l(a:=y)) (r(a:=z))) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S c l (r(a:=z))) p stack = List (S c l r) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S c (l(a:=z)) r) p stack = List (S c l r) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S (c(a:=z)) l r) p stack = List (S c l r) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

primrec
  \<comment> \<open>Recursive definition of what is means for a the graph/stack structure to be reconstructible\<close>
  stkOk :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow>'a list \<Rightarrow>  bool"
where
  stkOk_nil:  "stkOk c l r iL iR t [] = True"
| stkOk_cons:
    "stkOk c l r iL iR t (p#stk) = (stkOk c l r iL iR (Ref p) (stk) \<and>
      iL p = (if c p then l p else t) \<and>
      iR p = (if c p then t else r p))"

text \<open>Rewrite rules for stkOk\<close>

lemma [simp]: "\<And>t. \<lbrakk> x \<notin> set xs; Ref x\<noteq>t \<rbrakk> \<Longrightarrow>
  stkOk (c(x := f)) l r iL iR t xs = stkOk c l r iL iR t xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>t. \<lbrakk> x \<notin> set xs; Ref x\<noteq>t \<rbrakk> \<Longrightarrow>
 stkOk c (l(x := g)) r iL iR t xs = stkOk c l r iL iR t xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>t. \<lbrakk> x \<notin> set xs; Ref x\<noteq>t \<rbrakk> \<Longrightarrow>
 stkOk c l (r(x := g)) iL iR t xs = stkOk c l r iL iR t xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma stkOk_r_rewrite [simp]: "\<And>x. x \<notin> set xs \<Longrightarrow>
  stkOk c l (r(x := g)) iL iR (Ref x) xs = stkOk c l r iL iR (Ref x) xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>x. x \<notin> set xs \<Longrightarrow>
 stkOk c (l(x := g)) r iL iR (Ref x) xs = stkOk c l r iL iR (Ref x) xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>x. x \<notin> set xs \<Longrightarrow>
 stkOk (c(x := g)) l r iL iR (Ref x) xs = stkOk c l r iL iR (Ref x) xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

subsection \<open>The Schorr-Waite algorithm\<close>

theorem SchorrWaiteAlgorithm:
"VARS c m l r t p q root
 {R = reachable (relS {l, r}) {root} \<and> (\<forall>x. \<not> m x) \<and> iR = r \<and> iL = l}
 t := root; p := Null;
 WHILE p \<noteq> Null \<or> t \<noteq> Null \<and> \<not> t^.m
 INV {\<exists>stack.
          List (S c l r) p stack \<and>                                      \<comment> \<open>\<open>i1\<close>\<close>
          (\<forall>x \<in> set stack. m x) \<and>                                       \<comment> \<open>\<open>i2\<close>\<close>
          R = reachable (relS{l, r}) {t,p} \<and>                            \<comment> \<open>\<open>i3\<close>\<close>
          (\<forall>x. x \<in> R \<and> \<not>m x \<longrightarrow>                                         \<comment> \<open>\<open>i4\<close>\<close>
                 x \<in> reachable (relS{l,r}|m) ({t}\<union>set(map r stack))) \<and>
          (\<forall>x. m x \<longrightarrow> x \<in> R) \<and>                                         \<comment> \<open>\<open>i5\<close>\<close>
          (\<forall>x. x \<notin> set stack \<longrightarrow> r x = iR x \<and> l x = iL x) \<and>             \<comment> \<open>\<open>i6\<close>\<close>
          (stkOk c l r iL iR t stack)                                   \<comment> \<open>\<open>i7\<close>\<close>}
 DO IF t = Null \<or> t^.m
      THEN IF p^.c
               THEN q := t; t := p; p := p^.r; t^.r := q                \<comment> \<open>\<open>pop\<close>\<close>
               ELSE q := t; t := p^.r; p^.r := p^.l;                    \<comment> \<open>\<open>swing\<close>\<close>
                        p^.l := q; p^.c := True          FI
      ELSE q := p; p := t; t := t^.l; p^.l := q;                        \<comment> \<open>\<open>push\<close>\<close>
               p^.m := True; p^.c := False            FI       OD
 {(\<forall>x. (x \<in> R) = m x) \<and> (r = iR \<and> l = iL) }"
  (is "Valid
         {(c, m, l, r, t, p, q, root). ?Pre c m l r root}
         (Seq _ (Seq _ (While {(c, m, l, r, t, p, q, root). ?whileB m t p} _)))
         (Aseq _ (Aseq _ (Awhile {(c, m, l, r, t, p, q, root). ?inv c m l r t p} _ _))) _")
proof (vcg)
  {

    fix c m l r t p q root
    assume "?Pre c m l r root"
    thus "?inv c m l r root Null"  by (auto simp add: reachable_def addrs_def)
  next

    fix c m l r t p q
    let "\<exists>stack. ?Inv stack"  =  "?inv c m l r t p"
    assume a: "?inv c m l r t p \<and> \<not>(p \<noteq> Null \<or> t \<noteq> Null \<and> \<not> t^.m)"
    then obtain stack where inv: "?Inv stack" by blast
    from a have pNull: "p = Null" and tDisj: "t=Null \<or> (t\<noteq>Null \<and> t^.m )" by auto
    let "?I1 \<and> _ \<and> _ \<and> ?I4 \<and> ?I5 \<and> ?I6 \<and> _"  =  "?Inv stack"
    from inv have i1: "?I1" and i4: "?I4" and i5: "?I5" and i6: "?I6" by simp+
    from pNull i1 have stackEmpty: "stack = []" by simp
    from tDisj i4 have RisMarked[rule_format]: "\<forall>x.  x \<in> R \<longrightarrow> m x"  by(auto simp: reachable_def addrs_def stackEmpty)
    from i5 i6 show "(\<forall>x.(x \<in> R) = m x) \<and> r = iR \<and> l = iL"  by(auto simp: stackEmpty fun_eq_iff intro:RisMarked)

  next
      fix c m l r t p q root
      let "\<exists>stack. ?Inv stack"  =  "?inv c m l r t p"
      let "\<exists>stack. ?popInv stack"  =  "?inv c m l (r(p \<rightarrow> t)) p (p^.r)"
      let "\<exists>stack. ?swInv stack"  =
        "?inv (c(p \<rightarrow> True)) m (l(p \<rightarrow> t)) (r(p \<rightarrow> p^.l)) (p^.r) p"
      let "\<exists>stack. ?puInv stack"  =
        "?inv (c(t \<rightarrow> False)) (m(t \<rightarrow> True)) (l(t \<rightarrow> p)) r (t^.l) t"
      let "?ifB1"  =  "(t = Null \<or> t^.m)"
      let "?ifB2"  =  "p^.c"

      assume "(\<exists>stack.?Inv stack) \<and> ?whileB m t p"
      then obtain stack where inv: "?Inv stack" and whileB: "?whileB m t p" by blast
      let "?I1 \<and> ?I2 \<and> ?I3 \<and> ?I4 \<and> ?I5 \<and> ?I6 \<and> ?I7" = "?Inv stack"
      from inv have i1: "?I1" and i2: "?I2" and i3: "?I3" and i4: "?I4"
                  and i5: "?I5" and i6: "?I6" and i7: "?I7" by simp+
      have stackDist: "distinct (stack)" using i1 by (rule List_distinct)

      show "(?ifB1 \<longrightarrow> (?ifB2 \<longrightarrow> (\<exists>stack.?popInv stack)) \<and>
                            (\<not>?ifB2 \<longrightarrow> (\<exists>stack.?swInv stack)) ) \<and>
              (\<not>?ifB1 \<longrightarrow> (\<exists>stack.?puInv stack))"
      proof -
        {
          assume ifB1: "t = Null \<or> t^.m" and ifB2: "p^.c"
          from ifB1 whileB have pNotNull: "p \<noteq> Null" by auto
          then obtain addr_p where addr_p_eq: "p = Ref addr_p" by auto
          with i1 obtain stack_tl where stack_eq: "stack = (addr p) # stack_tl"
            by auto
          with i2 have m_addr_p: "p^.m" by auto
          have stackDist: "distinct (stack)" using i1 by (rule List_distinct)
          from stack_eq stackDist have p_notin_stack_tl: "addr p \<notin> set stack_tl" by simp
          let "?poI1\<and> ?poI2\<and> ?poI3\<and> ?poI4\<and> ?poI5\<and> ?poI6\<and> ?poI7" = "?popInv stack_tl"
          have "?popInv stack_tl"
          proof -

            \<comment> \<open>List property is maintained:\<close>
            from i1 p_notin_stack_tl ifB2
            have poI1: "List (S c l (r(p \<rightarrow> t))) (p^.r) stack_tl"
              by(simp add: addr_p_eq stack_eq, simp add: S_def)

            moreover
            \<comment> \<open>Everything on the stack is marked:\<close>
            from i2 have poI2: "\<forall> x \<in> set stack_tl. m x" by (simp add:stack_eq)
            moreover

            \<comment> \<open>Everything is still reachable:\<close>
            let "(R = reachable ?Ra ?A)" = "?I3"
            let "?Rb" = "(relS {l, r(p \<rightarrow> t)})"
            let "?B" = "{p, p^.r}"
            \<comment> \<open>Our goal is \<open>R = reachable ?Rb ?B\<close>.\<close>
            have "?Ra\<^sup>* `` addrs ?A = ?Rb\<^sup>* `` addrs ?B" (is "?L = ?R")
            proof
              show "?L \<subseteq> ?R"
              proof (rule still_reachable)
                show "addrs ?A \<subseteq> ?Rb\<^sup>* `` addrs ?B" by(fastforce simp:addrs_def relS_def rel_def addr_p_eq
                     intro:oneStep_reachable Image_iff[THEN iffD2])
                show "\<forall>(x,y) \<in> ?Ra-?Rb. y \<in> (?Rb\<^sup>* `` addrs ?B)" by (clarsimp simp:relS_def)
                     (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd1)
              qed
              show "?R \<subseteq> ?L"
              proof (rule still_reachable)
                show "addrs ?B \<subseteq> ?Ra\<^sup>* `` addrs ?A"
                  by(fastforce simp:addrs_def rel_defs addr_p_eq
                      intro:oneStep_reachable Image_iff[THEN iffD2])
              next
                show "\<forall>(x, y)\<in>?Rb-?Ra. y\<in>(?Ra\<^sup>*``addrs ?A)"
                  by (clarsimp simp:relS_def)
                     (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd2)
              qed
            qed
            with i3 have poI3: "R = reachable ?Rb ?B"  by (simp add:reachable_def)
            moreover

            \<comment> \<open>If it is reachable and not marked, it is still reachable using...\<close>
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Ra ?A"  =  ?I4
            let "?Rb" = "relS {l, r(p \<rightarrow> t)} | m"
            let "?B" = "{p} \<union> set (map (r(p \<rightarrow> t)) stack_tl)"
            \<comment> \<open>Our goal is \<open>\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Rb ?B\<close>.\<close>
            let ?T = "{t, p^.r}"

            have "?Ra\<^sup>* `` addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
            proof (rule still_reachable)
              have rewrite: "\<forall>s\<in>set stack_tl. (r(p \<rightarrow> t)) s = r s"
                by (auto simp add:p_notin_stack_tl intro:fun_upd_other)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
                by (fastforce cong:map_cong simp:stack_eq addrs_def rewrite intro:self_reachable)
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``(addrs ?B \<union> addrs ?T))"
                by (clarsimp simp:restr_def relS_def)
                  (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd1)
            qed
            \<comment> \<open>We now bring a term from the right to the left of the subset relation.\<close>
            hence subset: "?Ra\<^sup>* `` addrs ?A - ?Rb\<^sup>* `` addrs ?T \<subseteq> ?Rb\<^sup>* `` addrs ?B"
              by blast
            have poI4: "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Rb ?B"
            proof (rule allI, rule impI)
              fix x
              assume a: "x \<in> R \<and> \<not> m x"
              \<comment> \<open>First, a disjunction on \<^term>\<open>p^.r\<close> used later in the proof\<close>
              have pDisj:"p^.r = Null \<or> (p^.r \<noteq> Null \<and> p^.r^.m)" using poI1 poI2
                by auto
              \<comment> \<open>\<^term>\<open>x\<close> belongs to the left hand side of @{thm[source] subset}:\<close>
              have incl: "x \<in> ?Ra\<^sup>*``addrs ?A" using  a i4 by (simp only:reachable_def, clarsimp)
              have excl: "x \<notin> ?Rb\<^sup>*`` addrs ?T" using pDisj ifB1 a by (auto simp add:addrs_def)
              \<comment> \<open>And therefore also belongs to the right hand side of @{thm[source]subset},\<close>
              \<comment> \<open>which corresponds to our goal.\<close>
              from incl excl subset  show "x \<in> reachable ?Rb ?B" by (auto simp add:reachable_def)
            qed
            moreover

            \<comment> \<open>If it is marked, then it is reachable\<close>
            from i5 have poI5: "\<forall>x. m x \<longrightarrow> x \<in> R" .
            moreover

            \<comment> \<open>If it is not on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields are unchanged\<close>
            from i7 i6 ifB2
            have poI6: "\<forall>x. x \<notin> set stack_tl \<longrightarrow> (r(p \<rightarrow> t)) x = iR x \<and> l x = iL x"
              by(auto simp: addr_p_eq stack_eq fun_upd_apply)

            moreover

            \<comment> \<open>If it is on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields can be reconstructed\<close>
            from p_notin_stack_tl i7 have poI7: "stkOk c l (r(p \<rightarrow> t)) iL iR p stack_tl"
              by (clarsimp simp:stack_eq addr_p_eq)

            ultimately show "?popInv stack_tl" by simp
          qed
          hence "\<exists>stack. ?popInv stack" ..
        }
        moreover

        \<comment> \<open>Proofs of the Swing and Push arm follow.\<close>
        \<comment> \<open>Since they are in principle simmilar to the Pop arm proof,\<close>
        \<comment> \<open>we show fewer comments and use frequent pattern matching.\<close>
        {
          \<comment> \<open>Swing arm\<close>
          assume ifB1: "?ifB1" and nifB2: "\<not>?ifB2"
          from ifB1 whileB have pNotNull: "p \<noteq> Null" by clarsimp
          then obtain addr_p where addr_p_eq: "p = Ref addr_p" by clarsimp
          with i1 obtain stack_tl where stack_eq: "stack = (addr p) # stack_tl" by clarsimp
          with i2 have m_addr_p: "p^.m" by clarsimp
          from stack_eq stackDist have p_notin_stack_tl: "(addr p) \<notin> set stack_tl"
            by simp
          let "?swI1\<and>?swI2\<and>?swI3\<and>?swI4\<and>?swI5\<and>?swI6\<and>?swI7" = "?swInv stack"
          have "?swInv stack"
          proof -

            \<comment> \<open>List property is maintained:\<close>
            from i1 p_notin_stack_tl nifB2
            have swI1: "?swI1"
              by (simp add:addr_p_eq stack_eq, simp add:S_def)
            moreover

            \<comment> \<open>Everything on the stack is marked:\<close>
            from i2
            have swI2: "?swI2" .
            moreover

            \<comment> \<open>Everything is still reachable:\<close>
            let "R = reachable ?Ra ?A" = "?I3"
            let "R = reachable ?Rb ?B" = "?swI3"
            have "?Ra\<^sup>* `` addrs ?A = ?Rb\<^sup>* `` addrs ?B"
            proof (rule still_reachable_eq)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` addrs ?B"
                by(fastforce simp:addrs_def rel_defs addr_p_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "addrs ?B \<subseteq> ?Ra\<^sup>* `` addrs ?A"
                by(fastforce simp:addrs_def rel_defs addr_p_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``addrs ?B)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd1)
            next
              show "\<forall>(x, y)\<in>?Rb-?Ra. y\<in>(?Ra\<^sup>*``addrs ?A)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd2)
            qed
            with i3
            have swI3: "?swI3" by (simp add:reachable_def)
            moreover

            \<comment> \<open>If it is reachable and not marked, it is still reachable using...\<close>
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Ra ?A" = ?I4
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Rb ?B" = ?swI4
            let ?T = "{t}"
            have "?Ra\<^sup>*``addrs ?A \<subseteq> ?Rb\<^sup>*``(addrs ?B \<union> addrs ?T)"
            proof (rule still_reachable)
              have rewrite: "(\<forall>s\<in>set stack_tl. (r(addr p := l(addr p))) s = r s)"
                by (auto simp add:p_notin_stack_tl intro:fun_upd_other)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
                by (fastforce cong:map_cong simp:stack_eq addrs_def rewrite intro:self_reachable)
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``(addrs ?B \<union> addrs ?T))"
                by (clarsimp simp:relS_def restr_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd1)
            qed
            then have subset: "?Ra\<^sup>*``addrs ?A - ?Rb\<^sup>*``addrs ?T \<subseteq> ?Rb\<^sup>*``addrs ?B"
              by blast
            have ?swI4
            proof (rule allI, rule impI)
              fix x
              assume a: "x \<in> R \<and>\<not> m x"
              with i4 addr_p_eq stack_eq  have inc: "x \<in> ?Ra\<^sup>*``addrs ?A"
                by (simp only:reachable_def, clarsimp)
              with ifB1 a
              have exc: "x \<notin> ?Rb\<^sup>*`` addrs ?T"
                by (auto simp add:addrs_def)
              from inc exc subset  show "x \<in> reachable ?Rb ?B"
                by (auto simp add:reachable_def)
            qed
            moreover

            \<comment> \<open>If it is marked, then it is reachable\<close>
            from i5
            have "?swI5" .
            moreover

            \<comment> \<open>If it is not on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields are unchanged\<close>
            from i6 stack_eq
            have "?swI6"
              by clarsimp
            moreover

            \<comment> \<open>If it is on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields can be reconstructed\<close>
            from stackDist i7 nifB2
            have "?swI7"
              by (clarsimp simp:addr_p_eq stack_eq)

            ultimately show ?thesis by auto
          qed
          then have "\<exists>stack. ?swInv stack" by blast
        }
        moreover

        {
          \<comment> \<open>Push arm\<close>
          assume nifB1: "\<not>?ifB1"
          from nifB1 whileB have tNotNull: "t \<noteq> Null" by clarsimp
          then obtain addr_t where addr_t_eq: "t = Ref addr_t" by clarsimp
          with i1 obtain new_stack where new_stack_eq: "new_stack = (addr t) # stack" by clarsimp
          from tNotNull nifB1 have n_m_addr_t: "\<not> (t^.m)" by clarsimp
          with i2 have t_notin_stack: "(addr t) \<notin> set stack" by blast
          let "?puI1\<and>?puI2\<and>?puI3\<and>?puI4\<and>?puI5\<and>?puI6\<and>?puI7" = "?puInv new_stack"
          have "?puInv new_stack"
          proof -

            \<comment> \<open>List property is maintained:\<close>
            from i1 t_notin_stack
            have puI1: "?puI1"
              by (simp add:addr_t_eq new_stack_eq, simp add:S_def)
            moreover

            \<comment> \<open>Everything on the stack is marked:\<close>
            from i2
            have puI2: "?puI2"
              by (simp add:new_stack_eq fun_upd_apply)
            moreover

            \<comment> \<open>Everything is still reachable:\<close>
            let "R = reachable ?Ra ?A" = "?I3"
            let "R = reachable ?Rb ?B" = "?puI3"
            have "?Ra\<^sup>* `` addrs ?A = ?Rb\<^sup>* `` addrs ?B"
            proof (rule still_reachable_eq)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` addrs ?B"
                by(fastforce simp:addrs_def rel_defs addr_t_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "addrs ?B \<subseteq> ?Ra\<^sup>* `` addrs ?A"
                by(fastforce simp:addrs_def rel_defs addr_t_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``addrs ?B)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd1)
            next
              show "\<forall>(x, y)\<in>?Rb-?Ra. y\<in>(?Ra\<^sup>*``addrs ?A)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd2)
            qed
            with i3
            have puI3: "?puI3" by (simp add:reachable_def)
            moreover

            \<comment> \<open>If it is reachable and not marked, it is still reachable using...\<close>
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Ra ?A" = ?I4
            let "\<forall>x. x \<in> R \<and> \<not> ?new_m x \<longrightarrow> x \<in> reachable ?Rb ?B" = ?puI4
            let ?T = "{t}"
            have "?Ra\<^sup>*``addrs ?A \<subseteq> ?Rb\<^sup>*``(addrs ?B \<union> addrs ?T)"
            proof (rule still_reachable)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
                by (fastforce simp:new_stack_eq addrs_def intro:self_reachable)
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``(addrs ?B \<union> addrs ?T))"
                by (clarsimp simp:relS_def new_stack_eq restr_un restr_upd)
                   (fastforce simp add:rel_def Image_iff restr_def addrs_def fun_upd_apply addr_t_eq dest:rel_upd3)
            qed
            then have subset: "?Ra\<^sup>*``addrs ?A - ?Rb\<^sup>*``addrs ?T \<subseteq> ?Rb\<^sup>*``addrs ?B"
              by blast
            have ?puI4
            proof (rule allI, rule impI)
              fix x
              assume a: "x \<in> R \<and> \<not> ?new_m x"
              have xDisj: "x=(addr t) \<or> x\<noteq>(addr t)" by simp
              with i4 a have inc: "x \<in> ?Ra\<^sup>*``addrs ?A"
                by (fastforce simp:addr_t_eq addrs_def reachable_def intro:self_reachable)
              have exc: "x \<notin> ?Rb\<^sup>*`` addrs ?T"
                using xDisj a n_m_addr_t
                by (clarsimp simp add:addrs_def addr_t_eq)
              from inc exc subset  show "x \<in> reachable ?Rb ?B"
                by (auto simp add:reachable_def)
            qed
            moreover

            \<comment> \<open>If it is marked, then it is reachable\<close>
            from i5
            have "?puI5"
              by (auto simp:addrs_def i3 reachable_def addr_t_eq fun_upd_apply intro:self_reachable)
            moreover

            \<comment> \<open>If it is not on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields are unchanged\<close>
            from i6
            have "?puI6"
              by (simp add:new_stack_eq)
            moreover

            \<comment> \<open>If it is on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields can be reconstructed\<close>
            from stackDist i6 t_notin_stack i7
            have "?puI7" by (clarsimp simp:addr_t_eq new_stack_eq)

            ultimately show ?thesis by auto
          qed
          then have "\<exists>stack. ?puInv stack" by blast

        }
        ultimately show ?thesis by blast
      qed
    }
  qed

end


theory ex3_02 imports Main "~~/src/IMP/AExp" begin

(*
 full_asymp (Plus a b) returns (Plus x c) where c is summed up value.
 This is ugly but I do not have a better idea :-(
*)
fun full_asymp :: "aexp \<Rightarrow> aexp" where
"full_asymp (N n) = N n" |
"full_asymp (V v) = V v" |
"full_asymp (Plus a b) =
 (case (full_asymp a, full_asymp b) of
  (Plus ll (N m), Plus rl (N n)) \<Rightarrow> Plus (Plus ll rl) (N (m+n)) |
  (Plus ll (N m), N n)           \<Rightarrow> Plus ll (N (m+n)) |
  (Plus ll (N m), r)             \<Rightarrow> Plus (Plus ll r) (N m) |
  (Plus ll lr   , Plus rl (N n)) \<Rightarrow> Plus (Plus (Plus ll lr) rl) (N n) |
  (Plus ll lr   , N n) \<Rightarrow> Plus (Plus ll lr) (N n) |
  (N m, N n) \<Rightarrow> N (m+n) |
  (N m, Plus l (N n)) \<Rightarrow> Plus l (N (m+n)) |
  (N m, r) \<Rightarrow> Plus r (N m) |
  (l, Plus rl rr) \<Rightarrow> Plus (Plus l rl) rr |
  (l, r) \<Rightarrow> Plus l r
 )"

(** 1+(x+2) **)
value "full_asymp (Plus (N 1) (Plus (V x) (N 2)))"
(** (y+(1+z))+(2+(x+4)) **)
value "full_asymp (Plus (Plus (V y) (Plus (N 1) (V z))) (Plus (N 2) (Plus (V x) (N 4))))"

theorem "aval (full_asymp a) s = aval a s"
apply(induction a arbitrary: s rule: full_asymp.induct)
apply (auto split: aexp.split)
apply(auto simp add: algebra_simps)
done

end


(*  Title:      FOL/FOL.thy
    Author:     Lawrence C Paulson and Markus Wenzel
*)

section {* Classical first-order logic *}

theory FOL
imports IFOL
keywords "print_claset" "print_induct_rules" :: diag
begin

ML_file "~~/src/Provers/classical.ML"
ML_file "~~/src/Provers/blast.ML"
ML_file "~~/src/Provers/clasimp.ML"

subsection {* The classical axiom *}

axiomatization where
  classical: "(~P ==> P) ==> P"

subsection {* Lemmas and proof tools *}

lemma ccontr: "(\<not> P \<Longrightarrow> False) \<Longrightarrow> P"
  by (erule FalseE [THEN classical])

(*** Classical introduction rules for | and EX ***)

lemma disjCI: "(~Q ==> P) ==> P|Q"
  apply (rule classical)
  apply (assumption | erule meta_mp | rule disjI1 notI)+
  apply (erule notE disjI2)+
  done

(*introduction rule involving only EX*)
lemma ex_classical:
  assumes r: "~(EX x. P(x)) ==> P(a)"
  shows "EX x. P(x)"
  apply (rule classical)
  apply (rule exI, erule r)
  done

(*version of above, simplifying ~EX to ALL~ *)
lemma exCI:
  assumes r: "ALL x. ~P(x) ==> P(a)"
  shows "EX x. P(x)"
  apply (rule ex_classical)
  apply (rule notI [THEN allI, THEN r])
  apply (erule notE)
  apply (erule exI)
  done

lemma excluded_middle: "~P | P"
  apply (rule disjCI)
  apply assumption
  done

lemma case_split [case_names True False]:
  assumes r1: "P ==> Q"
    and r2: "~P ==> Q"
  shows Q
  apply (rule excluded_middle [THEN disjE])
  apply (erule r2)
  apply (erule r1)
  done

ML {*
  fun case_tac ctxt a = res_inst_tac ctxt [(("P", 0), a)] @{thm case_split}
*}

method_setup case_tac = {*
  Args.goal_spec -- Scan.lift Args.name_inner_syntax >>
    (fn (quant, s) => fn ctxt => SIMPLE_METHOD'' quant (case_tac ctxt s))
*} "case_tac emulation (dynamic instantiation!)"

(*** Special elimination rules *)

(*Classical implies (-->) elimination. *)
lemma impCE:
  assumes major: "P-->Q"
    and r1: "~P ==> R"
    and r2: "Q ==> R"
  shows R
  apply (rule excluded_middle [THEN disjE])
   apply (erule r1)
  apply (rule r2)
  apply (erule major [THEN mp])
  done

(*This version of --> elimination works on Q before P.  It works best for
  those cases in which P holds "almost everywhere".  Can't install as
  default: would break old proofs.*)
lemma impCE':
  assumes major: "P-->Q"
    and r1: "Q ==> R"
    and r2: "~P ==> R"
  shows R
  apply (rule excluded_middle [THEN disjE])
   apply (erule r2)
  apply (rule r1)
  apply (erule major [THEN mp])
  done

(*Double negation law*)
lemma notnotD: "~~P ==> P"
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma contrapos2:  "[| Q; ~ P ==> ~ Q |] ==> P"
  apply (rule classical)
  apply (drule (1) meta_mp)
  apply (erule (1) notE)
  done

(*** Tactics for implication and contradiction ***)

(*Classical <-> elimination.  Proof substitutes P=Q in
    ~P ==> ~Q    and    P ==> Q  *)
lemma iffCE:
  assumes major: "P<->Q"
    and r1: "[| P; Q |] ==> R"
    and r2: "[| ~P; ~Q |] ==> R"
  shows R
  apply (rule major [unfolded iff_def, THEN conjE])
  apply (elim impCE)
     apply (erule (1) r2)
    apply (erule (1) notE)+
  apply (erule (1) r1)
  done

(*Better for fast_tac: needs no quantifier duplication!*)
lemma alt_ex1E:
  assumes major: "EX! x. P(x)"
    and r: "!!x. [| P(x);  ALL y y'. P(y) & P(y') --> y=y' |] ==> R"
  shows R
  using major
proof (rule ex1E)
  fix x
  assume * : "\<forall>y. P(y) \<longrightarrow> y = x"
  assume "P(x)"
  then show R
  proof (rule r)
    { fix y y'
      assume "P(y)" and "P(y')"
      with * have "x = y" and "x = y'" by - (tactic "IntPr.fast_tac @{context} 1")+
      then have "y = y'" by (rule subst)
    } note r' = this
    show "\<forall>y y'. P(y) \<and> P(y') \<longrightarrow> y = y'" by (intro strip, elim conjE) (rule r')
  qed
qed

lemma imp_elim: "P --> Q ==> (~ R ==> P) ==> (Q ==> R) ==> R"
  by (rule classical) iprover

lemma swap: "~ P ==> (~ R ==> P) ==> R"
  by (rule classical) iprover

section {* Classical Reasoner *}

ML {*
structure Cla = Classical
(
  val imp_elim = @{thm imp_elim}
  val not_elim = @{thm notE}
  val swap = @{thm swap}
  val classical = @{thm classical}
  val sizef = size_of_thm
  val hyp_subst_tacs = [hyp_subst_tac]
);

structure Basic_Classical: BASIC_CLASSICAL = Cla;
open Basic_Classical;
*}

(*Propositional rules*)
lemmas [intro!] = refl TrueI conjI disjCI impI notI iffI
  and [elim!] = conjE disjE impCE FalseE iffCE
ML {* val prop_cs = claset_of @{context} *}

(*Quantifier rules*)
lemmas [intro!] = allI ex_ex1I
  and [intro] = exI
  and [elim!] = exE alt_ex1E
  and [elim] = allE
ML {* val FOL_cs = claset_of @{context} *}

ML {*
  structure Blast = Blast
  (
    structure Classical = Cla
    val Trueprop_const = dest_Const @{const Trueprop}
    val equality_name = @{const_name eq}
    val not_name = @{const_name Not}
    val notE = @{thm notE}
    val ccontr = @{thm ccontr}
    val hyp_subst_tac = Hypsubst.blast_hyp_subst_tac
  );
  val blast_tac = Blast.blast_tac;
*}

lemma ex1_functional: "[| EX! z. P(a,z);  P(a,b);  P(a,c) |] ==> b = c"
  by blast

(* Elimination of True from asumptions: *)
lemma True_implies_equals: "(True ==> PROP P) == PROP P"
proof
  assume "True \<Longrightarrow> PROP P"
  from this and TrueI show "PROP P" .
next
  assume "PROP P"
  then show "PROP P" .
qed

lemma uncurry: "P --> Q --> R ==> P & Q --> R"
  by blast

lemma iff_allI: "(!!x. P(x) <-> Q(x)) ==> (ALL x. P(x)) <-> (ALL x. Q(x))"
  by blast

lemma iff_exI: "(!!x. P(x) <-> Q(x)) ==> (EX x. P(x)) <-> (EX x. Q(x))"
  by blast

lemma all_comm: "(ALL x y. P(x,y)) <-> (ALL y x. P(x,y))" by blast

lemma ex_comm: "(EX x y. P(x,y)) <-> (EX y x. P(x,y))" by blast

(*** Classical simplification rules ***)

(*Avoids duplication of subgoals after expand_if, when the true and false
  cases boil down to the same thing.*)
lemma cases_simp: "(P --> Q) & (~P --> Q) <-> Q" by blast

(*** Miniscoping: pushing quantifiers in
     We do NOT distribute of ALL over &, or dually that of EX over |
     Baaz and Leitsch, On Skolemization and Proof Complexity (1994)
     show that this step can increase proof length!
***)

(*existential miniscoping*)
lemma int_ex_simps:
  "!!P Q. (EX x. P(x) & Q) <-> (EX x. P(x)) & Q"
  "!!P Q. (EX x. P & Q(x)) <-> P & (EX x. Q(x))"
  "!!P Q. (EX x. P(x) | Q) <-> (EX x. P(x)) | Q"
  "!!P Q. (EX x. P | Q(x)) <-> P | (EX x. Q(x))"
  by iprover+

(*classical rules*)
lemma cla_ex_simps:
  "!!P Q. (EX x. P(x) --> Q) <-> (ALL x. P(x)) --> Q"
  "!!P Q. (EX x. P --> Q(x)) <-> P --> (EX x. Q(x))"
  by blast+

lemmas ex_simps = int_ex_simps cla_ex_simps

(*universal miniscoping*)
lemma int_all_simps:
  "!!P Q. (ALL x. P(x) & Q) <-> (ALL x. P(x)) & Q"
  "!!P Q. (ALL x. P & Q(x)) <-> P & (ALL x. Q(x))"
  "!!P Q. (ALL x. P(x) --> Q) <-> (EX x. P(x)) --> Q"
  "!!P Q. (ALL x. P --> Q(x)) <-> P --> (ALL x. Q(x))"
  by iprover+

(*classical rules*)
lemma cla_all_simps:
  "!!P Q. (ALL x. P(x) | Q) <-> (ALL x. P(x)) | Q"
  "!!P Q. (ALL x. P | Q(x)) <-> P | (ALL x. Q(x))"
  by blast+

lemmas all_simps = int_all_simps cla_all_simps

(*** Named rewrite rules proved for IFOL ***)

lemma imp_disj1: "(P-->Q) | R <-> (P-->Q | R)" by blast
lemma imp_disj2: "Q | (P-->R) <-> (P-->Q | R)" by blast

lemma de_Morgan_conj: "(~(P & Q)) <-> (~P | ~Q)" by blast

lemma not_imp: "~(P --> Q) <-> (P & ~Q)" by blast
lemma not_iff: "~(P <-> Q) <-> (P <-> ~Q)" by blast

lemma not_all: "(~ (ALL x. P(x))) <-> (EX x.~P(x))" by blast
lemma imp_all: "((ALL x. P(x)) --> Q) <-> (EX x. P(x) --> Q)" by blast

lemmas meta_simps =
  triv_forall_equality (* prunes params *)
  True_implies_equals  (* prune asms `True' *)

lemmas IFOL_simps =
  refl [THEN P_iff_T] conj_simps disj_simps not_simps
  imp_simps iff_simps quant_simps

lemma notFalseI: "~False" by iprover

lemma cla_simps_misc:
  "~(P&Q) <-> ~P | ~Q"
  "P | ~P"
  "~P | P"
  "~ ~ P <-> P"
  "(~P --> P) <-> P"
  "(~P <-> ~Q) <-> (P<->Q)" by blast+

lemmas cla_simps =
  de_Morgan_conj de_Morgan_disj imp_disj1 imp_disj2
  not_imp not_all not_ex cases_simp cla_simps_misc

ML_file "simpdata.ML"

simproc_setup defined_Ex ("EX x. P(x)") = {* fn _ => Quantifier1.rearrange_ex *}
simproc_setup defined_All ("ALL x. P(x)") = {* fn _ => Quantifier1.rearrange_all *}

ML {*
(*intuitionistic simprules only*)
val IFOL_ss =
  put_simpset FOL_basic_ss @{context}
  addsimps @{thms meta_simps IFOL_simps int_ex_simps int_all_simps}
  addsimprocs [@{simproc defined_All}, @{simproc defined_Ex}]
  |> Simplifier.add_cong @{thm imp_cong}
  |> simpset_of;

(*classical simprules too*)
val FOL_ss =
  put_simpset IFOL_ss @{context}
  addsimps @{thms cla_simps cla_ex_simps cla_all_simps}
  |> simpset_of;
*}

setup {*
  map_theory_simpset (put_simpset FOL_ss) #>
  Simplifier.method_setup Splitter.split_modifiers
*}

ML_file "~~/src/Tools/eqsubst.ML"

subsection {* Other simple lemmas *}

lemma [simp]: "((P-->Q) <-> (P-->R)) <-> (P --> (Q<->R))"
by blast

lemma not_disj_iff_imp: "~P | Q <-> (P-->Q)"
by blast

(** Monotonicity of implications **)

lemma conj_mono: "[| P1-->Q1; P2-->Q2 |] ==> (P1&P2) --> (Q1&Q2)"
by fast (*or (IntPr.fast_tac 1)*)

lemma disj_mono: "[| P1-->Q1; P2-->Q2 |] ==> (P1|P2) --> (Q1|Q2)"
by fast (*or (IntPr.fast_tac 1)*)

lemma imp_mono: "[| Q1-->P1; P2-->Q2 |] ==> (P1-->P2)-->(Q1-->Q2)"
by fast (*or (IntPr.fast_tac 1)*)

lemma imp_refl: "P-->P"
by (rule impI, assumption)

(*The quantifier monotonicity rules are also intuitionistically valid*)
lemma ex_mono: "(!!x. P(x) --> Q(x)) ==> (EX x. P(x)) --> (EX x. Q(x))"
by blast

lemma all_mono: "(!!x. P(x) --> Q(x)) ==> (ALL x. P(x)) --> (ALL x. Q(x))"
by blast

subsection {* Proof by cases and induction *}

text {* Proper handling of non-atomic rule statements. *}

definition "induct_forall(P) == \<forall>x. P(x)"
definition "induct_implies(A, B) == A \<longrightarrow> B"
definition "induct_equal(x, y) == x = y"
definition "induct_conj(A, B) == A \<and> B"

lemma induct_forall_eq: "(!!x. P(x)) == Trueprop(induct_forall(\<lambda>x. P(x)))"
  unfolding atomize_all induct_forall_def .

lemma induct_implies_eq: "(A ==> B) == Trueprop(induct_implies(A, B))"
  unfolding atomize_imp induct_implies_def .

lemma induct_equal_eq: "(x == y) == Trueprop(induct_equal(x, y))"
  unfolding atomize_eq induct_equal_def .

lemma induct_conj_eq: "(A &&& B) == Trueprop(induct_conj(A, B))"
  unfolding atomize_conj induct_conj_def .

lemmas induct_atomize = induct_forall_eq induct_implies_eq induct_equal_eq induct_conj_eq
lemmas induct_rulify [symmetric] = induct_atomize
lemmas induct_rulify_fallback =
  induct_forall_def induct_implies_def induct_equal_def induct_conj_def

hide_const induct_forall induct_implies induct_equal induct_conj

text {* Method setup. *}

ML_file "~~/src/Tools/induct.ML"
ML {*
  structure Induct = Induct
  (
    val cases_default = @{thm case_split}
    val atomize = @{thms induct_atomize}
    val rulify = @{thms induct_rulify}
    val rulify_fallback = @{thms induct_rulify_fallback}
    val equal_def = @{thm induct_equal_def}
    fun dest_def _ = NONE
    fun trivial_tac _ _ = no_tac
  );
*}

declare case_split [cases type: o]

ML_file "~~/src/Tools/case_product.ML"

hide_const (open) eq

end


theory weird_nat_add3acc_assoc3
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

(*hipster add3acc *)

theorem x0 :
  "!! (x1 :: Nat) (x2 :: Nat) (x3 :: Nat) (x4 :: Nat) (x5 :: Nat) .
     (add3acc x1 (add3acc x2 x3 x4) x5) =
       (add3acc x1 x2 (add3acc x3 x4 x5))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_add3acc_comm23
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

theorem property0 :
  "((add3acc x y z) = (add3acc x z y))"
  oops

end


theory equal
imports Main

begin

lemma lemma_a [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes prop_50.count.simps prop_50.equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 Z x2 = equal2 x2 Z"
by (hipster_induct_schemes prop_50.count.simps prop_50.equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes prop_50.count.simps prop_50.equal2.simps)

lemma lemma_ac [thy_expl]: "equal2 (S x2) x2 = False"
by (hipster_induct_schemes prop_50.count.simps prop_50.equal2.simps)

lemma lemma_ad [thy_expl]: "equal2 (S Z) x2 = equal2 x2 (S Z)"
by (hipster_induct_schemes prop_50.count.simps prop_50.equal2.simps)

lemma lemma_ae [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
by (hipster_induct_schemes prop_50.count.simps prop_50.equal2.simps)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_regexp_PlusIdempotent
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Plus p p) s) = (recognise p s))"
  oops

end


theory prop_48
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun null :: "'a list => bool" where
  "null (Nil2) = True"
  | "null (Cons2 y z) = False"
  fun last :: "Nat list => Nat" where
  "last (Nil2) = Z"
  | "last (Cons2 y (Nil2)) = y"
  | "last (Cons2 y (Cons2 x2 x3)) = last (Cons2 x2 x3)"
  fun butlast :: "'a list => 'a list" where
  "butlast (Nil2) = Nil2"
  | "butlast (Cons2 y (Nil2)) = Nil2"
  | "butlast (Cons2 y (Cons2 x2 x3)) =
       Cons2 y (butlast (Cons2 x2 x3))"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster null last butlast append *)
  theorem x0 :
    "(~ (null xs)) ==>
       ((append (butlast xs) (Cons2 (last xs) (Nil2))) = xs)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_add3acc_rrot
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

theorem property0 :
  "((add3acc x y z) = (add3acc z x y))"
  oops

end


section \<open>Concrete example\<close>

theory Refinement_Example
imports Refinement
begin

text \<open>In this section, we present a concrete example ofthe use of our environment.
We define two Circus processes FIG and DFIG, using our syntax. we give the proof of refinement
(simulation) of the first processby the second one using the simulation function $Sim$.\<close>

subsection \<open>Process definitions\<close>

circus_process FIG =
  alphabet = [v::nat, x::nat]
  state = [idS::"nat set"]
  channel = [out nat , req , ret nat]
  schema Init = "idS' = {}"
  schema Out = "\<exists> a. v' = a \<and> a \<notin> idS \<and> idS' = idS \<union> {v'}"
  schema Remove = "x \<in> idS \<and> idS' = idS - {x}"
  where "var v \<bullet> (Schema FIG.Init`;`
         \<mu> X \<bullet> (((((req \<rightarrow> (Schema FIG.Out))`;` out`!`(hd o v) \<rightarrow> Skip))
               \<box> (ret`?`x \<rightarrow> (Schema FIG.Remove)))`;` X))"

circus_process DFIG =
  alphabet = [v::nat, x::nat]
  state = [retidS::"nat set", max::nat]
  channel = FIG_channels
  schema Init = "retidS' = {} \<and> max' = 0"
  schema Out = "v' = max \<and> max' = (max + 1) \<and> retidS' = retidS - {v'}"
  schema Remove = "x < max \<and> retidS' = retidS \<union> {x} \<and> max' = max"
  where "var v \<bullet> (Schema DFIG.Init`;`
         \<mu> X \<bullet> ((((req \<rightarrow> (Schema DFIG.Out))`;` (out`!`(hd o v) \<rightarrow> Skip))
               \<box> (ret`?`x \<rightarrow> (Schema DFIG.Remove)))`;` X))"

definition Sim where
  "Sim A = FIG_alphabet.make (DFIG_alphabet.v A) (DFIG_alphabet.x A)
   ({a. a < (DFIG_alphabet.max A) \<and> a \<notin> (DFIG_alphabet.retidS A)})"

subsection \<open>Simulation proofs\<close>

text \<open>For the simulation proof, we give first proofs for simulation over the schema expressions.
The proof is then given over the main actions of the processes.\<close>

lemma SimInit: "(Schema FIG.Init) \<preceq>Sim (Schema DFIG.Init)"
  apply (auto simp: Sim_def Pre_def design_defs DFIG.Init_def FIG.Init_def rp_defs  alpha_rp.defs
                    DFIG_alphabet.defs FIG_alphabet.defs intro!: Schema_Sim)
  apply (rule_tac x="A\<lparr>max := 0, retidS := {}\<rparr>" in exI, simp)
done

lemma SimOut: "(Schema FIG.Out) \<preceq>Sim (Schema DFIG.Out)"
  apply (rule Schema_Sim)
  apply (auto simp: Pre_def DFIG_alphabet.defs FIG_alphabet.defs
                     alpha_rp.defs Sim_def FIG.Out_def DFIG.Out_def)
  apply (rule_tac x="a\<lparr>v := [DFIG_alphabet.max a], max := (Suc (DFIG_alphabet.max a)),
                     retidS := retidS a - {DFIG_alphabet.max a}\<rparr>" in exI, simp)
  apply (rule_tac x="a\<lparr>v := [DFIG_alphabet.max a], max := (Suc (DFIG_alphabet.max a)),
                     retidS := retidS a - {DFIG_alphabet.max a}\<rparr>" in exI, simp)
done

lemma SimRemove: "(Schema FIG.Remove) \<preceq>Sim (Schema DFIG.Remove)"
  apply (rule Schema_Sim)
  apply (auto simp: Pre_def DFIG_alphabet.defs FIG_alphabet.defs alpha_rp.defs Sim_def)
  apply (clarsimp simp add: DFIG.Remove_def FIG.Remove_def)
  apply (rule_tac x="a\<lparr>retidS := insert (hd (DFIG_alphabet.x a)) (retidS a)\<rparr>" in exI, simp)
  apply (auto simp add: DFIG.Remove_def FIG.Remove_def)
done

lemma "FIG.FIG \<preceq>Sim DFIG.DFIG"
by (auto simp: DFIG.DFIG_def FIG.FIG_def mono_Seq SimRemove SimOut SimInit Sim_def FIG_alphabet.defs
         intro!:Var_Sim Seq_Sim Mu_Sim Det_Sim Write0_Sim Write_Sim Read_Sim Skip_Sim)

end


(* Author: Gerwin Klein, Tobias Nipkow *)

subsection "Big-Step Semantics of Commands"

theory Big_Step imports "./Com" begin

text \<open>
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first parameter is a tuple,
so the syntax becomes \<open>(c,s) \<Rightarrow> s'\<close>.
\<close>

text_raw\<open>\snip{BigStepdef}{0}{1}{%\<close>
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
OrL: "(l, s1) \<Rightarrow> s2 \<Longrightarrow> (l OR r, s1) \<Rightarrow> s2" |
OrR: "(r, s1) \<Rightarrow> s2 \<Longrightarrow> (l OR r, s1) \<Rightarrow> s2"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{BigStepEx}{1}{2}{%\<close>
schematic_goal ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq)
apply(rule Assign)
apply simp
apply(rule Assign)
done
text_raw\<open>}%endsnip\<close>

thm ex[simplified]

text\<open>We want to execute the big-step rules:\<close>

code_pred big_step .

text\<open>For inductive definitions we need command
       \texttt{values} instead of \texttt{value}.\<close>

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

text\<open>We need to translate the result state into a list
to display it.\<close>

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

text\<open>Proof automation:\<close>

text \<open>The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules.\<close>
declare big_step.intros [intro]

text\<open>The standard induction rule
@{thm [display] big_step.induct [no_vars]}\<close>

thm big_step.induct

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

subsection "Rule inversion"

text\<open>What can we deduce from \<^prop>\<open>(SKIP,s) \<Rightarrow> t\<close> ?
That \<^prop>\<open>s = t\<close>. This is how we can automatically prove it:\<close>

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text\<open>This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands:\<close>

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text\<open>Only [elim]: [elim!] would not terminate.\<close>

inductive_cases OrE[elim]: "(l OR r, s) \<Rightarrow> t"
thm OrE

text\<open>An automatic example:\<close>

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

text\<open>Rule inversion by hand via the ``cases'' method:\<close>

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  \<comment> \<open>inverting assms\<close>
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text \<open>An example combining rule inversion and derivations\<close>
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  \<comment> \<open>The other direction is analogous\<close>
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text \<open>
  We call two statements \<open>c\<close> and \<open>c'\<close> equivalent wrt.\ the
  big-step semantics when \emph{\<open>c\<close> started in \<open>s\<close> terminates
  in \<open>s'\<close> iff \<open>c'\<close> started in the same \<open>s\<close> also terminates
  in the same \<open>s'\<close>}. Formally:
\<close>
text_raw\<open>\snip{BigStepEquiv}{0}{1}{%\<close>
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw\<open>}%endsnip\<close>

text \<open>
Warning: \<open>\<sim>\<close> is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
\<close>
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  \<comment> \<open>to show the equivalence, we look at the derivation tree for\<close>
  \<comment> \<open>each side and from that construct a derivation tree for the other side\<close>
  have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases \<comment> \<open>rule inversion on \<open>(?w, s) \<Rightarrow> t\<close>\<close>
      case WhileFalse
      thus ?thesis by blast
    next
      case WhileTrue
      from \<open>bval b s\<close> \<open>(?w, s) \<Rightarrow> t\<close> obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      \<comment> \<open>now we can build a derivation tree for the \<^text>\<open>IF\<close>\<close>
      \<comment> \<open>first, the body of the True-branch:\<close>
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      \<comment> \<open>then the whole \<^text>\<open>IF\<close>\<close>
      with \<open>bval b s\<close> show ?thesis by (rule IfTrue)
    qed
  qed
  moreover
  \<comment> \<open>now the other direction:\<close>
  have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases \<comment> \<open>rule inversion on \<open>(?iw, s) \<Rightarrow> t\<close>\<close>
      case IfFalse
      hence "s = t" using \<open>(?iw, s) \<Rightarrow> t\<close> by blast
      thus ?thesis using \<open>\<not>bval b s\<close> by blast
    next
      case IfTrue
      \<comment> \<open>and for this, only the Seq-rule is applicable:\<close>
      from \<open>(c;; ?w, s) \<Rightarrow> t\<close> obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      \<comment> \<open>with this information, we can build a derivation tree for \<^text>\<open>WHILE\<close>\<close>
      with \<open>bval b s\<close> show ?thesis by (rule WhileTrue)
    qed
  qed
  ultimately
  show ?thesis by blast
qed

text \<open>Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.\<close>

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

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
 apply blast
apply blast
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

lemma sim_or: "(c1 OR c2) \<sim> (c2 OR c1)" by auto

text \<open>Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically.\<close>

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

subsection "Execution is deterministic"

text \<open>This proof is automatic.\<close>

(*
以下の定理はOrによって成り立たなくなる。
theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  by (induction arbitrary: u rule: big_step.induct) blast+ *)

text \<open>
  This is the proof as you might present it in a lecture. The remaining
  cases are simple enough to be proved automatically:
\<close>
text_raw\<open>\snip{BigStepDetLong}{0}{2}{%\<close>
(*
以下の定理はOrによって成り立たなくなる。
theorem
  "(c,s) \<Rightarrow> t  \<Longrightarrow>  (c,s) \<Rightarrow> t'  \<Longrightarrow>  t' = t"
proof (induction arbitrary: t' rule: big_step.induct)
  \<comment> \<open>the only interesting case, \<^text>\<open>WhileTrue\<close>:\<close>
  fix b c s s\<^sub>1 t t'
  \<comment> \<open>The assumptions of the rule:\<close>
  assume "bval b s" and "(c,s) \<Rightarrow> s\<^sub>1" and "(WHILE b DO c,s\<^sub>1) \<Rightarrow> t"
  \<comment> \<open>Ind.Hyp; note the \<^text>\<open>\<And>\<close> because of arbitrary:\<close>
  assume IHc: "\<And>t'. (c,s) \<Rightarrow> t' \<Longrightarrow> t' = s\<^sub>1"
  assume IHw: "\<And>t'. (WHILE b DO c,s\<^sub>1) \<Rightarrow> t' \<Longrightarrow> t' = t"
  \<comment> \<open>Premise of implication:\<close>
  assume "(WHILE b DO c,s) \<Rightarrow> t'"
  with \<open>bval b s\<close> obtain s\<^sub>1' where
      c: "(c,s) \<Rightarrow> s\<^sub>1'" and
      w: "(WHILE b DO c,s\<^sub>1') \<Rightarrow> t'"
    by auto
  from c IHc have "s\<^sub>1' = s\<^sub>1" by blast
  with w IHw show "t' = t" by blast
qed blast+ \<comment> \<open>prove the rest automatically\<close>
text_raw\<open>}%endsnip\<close> *)

end