theory Lib_Word_toString
imports Lib_Numbers_toString
        Word_Lib.Word_Lemmas
begin

section\<open>Printing Machine Words\<close>

(*imitation of http://stackoverflow.com/questions/23864965/string-of-nat-in-isabelle*)
(*parameters:
    lc = lower-case
    w  = word to print*)
definition string_of_word_single :: "bool \<Rightarrow> 'a::len word \<Rightarrow> string" where
  "string_of_word_single lc w \<equiv>
    (if
       w < 10
     then
       [char_of (48 + unat w)]
     else if
       w < 36
     then
       [char_of ((if lc then 87 else 55) + unat w)]
     else
       undefined)"

text\<open>Example:\<close>
lemma "let word_upto = ((\<lambda> i j. map (of_nat \<circ> nat) [i .. j]) :: int \<Rightarrow> int \<Rightarrow> 32 word list)
       in map (string_of_word_single False) (word_upto 1 35) =
  [''1'', ''2'', ''3'', ''4'', ''5'', ''6'', ''7'', ''8'', ''9'',
   ''A'', ''B'', ''C'', ''D'', ''E'', ''F'', ''G'', ''H'', ''I'',
   ''J'', ''K'', ''L'', ''M'', ''N'', ''O'', ''P'', ''Q'', ''R'',
   ''S'', ''T'', ''U'', ''V'', ''W'', ''X'', ''Y'', ''Z'']" by eval

(* parameters: lowercase, base, minimum length - 1, to-be-serialized word *)
function string_of_word :: "bool \<Rightarrow> ('a :: len) word \<Rightarrow> nat \<Rightarrow> ('a :: len) word \<Rightarrow> string" where
  "string_of_word lc base ml w =
    (if
       base < 2 \<or> LENGTH('a) < 2
     then
       undefined
     else if
       w < base \<and> ml = 0
     then
       string_of_word_single lc w
     else
       string_of_word lc base (ml - 1) (w div base) @ string_of_word_single lc (w mod base)
     )"
by pat_completeness auto

definition "hex_string_of_word l \<equiv> string_of_word True (16 :: ('a::len) word) l"
definition "hex_string_of_word0 \<equiv> hex_string_of_word 0"
(* be careful though, these functions only make sense with words > length 4.
   With 4 bits, base 16 is not representable. *)
definition "dec_string_of_word0 \<equiv> string_of_word True 10 0"

termination string_of_word
	apply(relation "measure (\<lambda>(a,b,c,d). unat d + c)")
	 apply(rule wf_measure)
	apply(subst in_measure)
	apply(clarsimp)
	subgoal for base ml n
    apply(case_tac "ml \<noteq> 0")
     apply(simp add: less_eq_Suc_le unat_div)
    apply(simp)
    apply(subgoal_tac "(n div base) < n")
     apply(blast intro: unat_mono)
    apply(rule div_less_dividend_word)
     subgoal by(metis Word_Lemmas.power_not_zero linorder_neqE_nat numeral_less_iff
                      power_zero_numeral semiring_norm(76) word_neq_0_conv)
    apply(clarsimp)
    apply(thin_tac "n \<noteq> 0")
    subgoal by (metis One_nat_def mult.right_neutral power_0 power_Suc unat_1
                      unat_power_lower Suc_1 inc_induct le_def less_eq_Suc_le lt1_neq0
                      not_degenerate_imp_2_neq_0 word_le_less_eq)
  done
done

declare string_of_word.simps[simp del]

lemma "hex_string_of_word0 (0xdeadbeef42 :: 42 word) = ''deadbeef42''" by eval

lemma "hex_string_of_word 1 (0x1 :: 5 word) = ''01''" by eval
lemma "hex_string_of_word 8 (0xff::32 word) = ''0000000ff''" by eval

lemma "dec_string_of_word0 (8::32 word) = ''8''" by eval
lemma "dec_string_of_word0 (3::2 word) = ''11''" by eval
lemma "dec_string_of_word0 (-1::8 word) = ''255''" by eval

lemma string_of_word_single_atoi:
  "n < 10 \<Longrightarrow> string_of_word_single True n = [char_of (48 + unat n)]"
  by(simp add: string_of_word_single_def)

(*TODO: move!*)
lemma bintrunc_pos_eq: "x \<ge> 0 \<Longrightarrow> bintrunc n x = x \<longleftrightarrow> x < 2^n"
apply(rule iffI)
 subgoal using bintr_lt2p by metis
by (simp add: mod_pos_pos_trivial no_bintr_alt1; fail)

(*The following lemma [symmetric] as [code_unfold] may give some cool speedup*)
lemma string_of_word_base_ten_zeropad:
  fixes w ::"'a::len word"
  assumes lena: "LENGTH('a) \<ge> 5" (*word must be long enough to encode 10 = 0xA*)
  shows "base = 10 \<Longrightarrow> zero = 0 \<Longrightarrow> string_of_word True base zero w = string_of_nat (unat w)"
  proof(induction True base zero w rule: string_of_word.induct)
  case (1 base ml n)

  note  Word.word_less_no[simp del]
  note  Word.uint_bintrunc[simp del]

  have "5 \<le> n \<Longrightarrow> bintrunc n 10 = 10" for n
   apply(subst bintrunc_pos_eq)
    apply(simp; fail)
   apply(induction rule: Nat.dec_induct)
    by simp+
  with lena have unat_ten: "unat (0xA::'a::len word) = 10" by(simp)

  have "5 \<le> n \<Longrightarrow> bintrunc n 2 = 2" for n
   apply(subst bintrunc_pos_eq)
    apply(simp; fail)
   apply(induction rule: Nat.dec_induct)
    by simp+
  with lena have unat_two: "unat (2::'a::len word) = 2" by(simp)

  have unat_mod_ten: "unat (n mod 0xA) = unat n mod 10"
    apply(subst Word.unat_mod)
    apply(subst unat_ten)
    by(simp)

  have unat_div_ten: "(unat (n div 0xA)) = unat n div 10"
    apply(subst Word.unat_div)
    apply(subst unat_ten)
    by simp
  have n_less_ten_unat: "n < 0xA \<Longrightarrow> (unat n < 10)"
    apply(rule Word_Lemmas.unat_less_helper)
    by(simp)
  have "0xA \<le> n \<Longrightarrow> 10 \<le> unat n"
    apply(subst(asm) Word.word_le_nat_alt)
    apply(subst(asm) unat_ten)
    by(simp)
  hence n_less_ten_unat_not: "\<not> n < 0xA \<Longrightarrow> \<not> unat n < 10" by fastforce
  have not_wordlength_too_small: "\<not> LENGTH('a) < 2" using lena by fastforce
  have "2 \<le> (0xA::'a word)"
    apply(subst word_le_nat_alt)
    apply(subst unat_ten unat_two)
    apply(subst unat_two)
    by(simp)
  hence ten_not_less_two: "\<not> (0xA::'a word) < 2" by (simp add: Word.word_less_no Word.uint_bintrunc)
  with 1(2,3) have " \<not> (base < 2 \<or> LENGTH(32) < 2)"
    by(simp)
  with 1 not_wordlength_too_small have IH: "\<not> n < 0xA \<Longrightarrow> string_of_word True 0xA 0 (n div 0xA) = string_of_nat (unat (n div 0xA))"
    by(simp)
  show ?case
    apply(simp add: 1)
    apply(cases "n < 0xA")
     subgoal
     apply(subst(1) string_of_word.simps)
     apply(subst(1) string_of_nat.simps)
     apply(simp add: n_less_ten_unat)
     by(simp add: not_wordlength_too_small ten_not_less_two string_of_word_single_atoi)
    using sym[OF IH] apply(simp)
    apply(subst(1) string_of_word.simps)
    apply(simp)
    apply(subst(1) string_of_nat.simps)
    apply(simp)
    apply(simp add: not_wordlength_too_small ten_not_less_two)
    apply(subst string_of_word_single_atoi)
     apply(rule Word.word_mod_less_divisor)
     using unat_ten word_gt_0_no apply fastforce
    apply(simp add: unat_mod_ten)
    apply(rule sym)
    apply(drule n_less_ten_unat_not)
    apply(simp add: unat_div_ten)
    by (simp add: string_of_nat.simps)
qed

(*TODO: one for all words?*)
lemma dec_string_of_word0:
  "dec_string_of_word0 (w8:: 8 word) = string_of_nat (unat w8)"
  "dec_string_of_word0 (w16:: 16 word) = string_of_nat (unat w16)"
  "dec_string_of_word0 (w32:: 32 word) = string_of_nat (unat w32)"
  "dec_string_of_word0 (w64:: 64 word) = string_of_nat (unat w64)"
  "dec_string_of_word0 (w128:: 128 word) = string_of_nat (unat w128)"
  unfolding dec_string_of_word0_def
  using string_of_word_base_ten_zeropad by force+

end


theory Incredible_Propositional imports
  Abstract_Rules_To_Incredible
  Propositional_Formulas
  Stream_Ext
begin

text \<open>Our concrete interpretation with propositional logic will cover conjunction and implication
  as well as constant symbols. The type for variables will be @{typ string}.\<close>

datatype prop_funs = "and" | imp | Const "string"

text \<open>The rules are introduction and elimination of conjunction and implication.\<close>
datatype prop_rule = andI | andE | impI | impE

definition prop_rules :: "prop_rule stream"
  where "prop_rules = cycle [andI, andE, impI, impE]"

lemma iR_prop_rules [simp]: "sset prop_rules = {andI, andE, impI, impE}"
  unfolding prop_rules_def by simp

text \<open>Just some short notation.\<close>
abbreviation X :: "(string,'a) pform"
  where "X \<equiv> Var ''X''"
abbreviation Y :: "(string,'a) pform"
  where "Y \<equiv> Var ''Y''"

text \<open>Finally the right- and left-hand sides of the rules.\<close>

fun consequent :: "prop_rule \<Rightarrow> (string, prop_funs) pform list"
  where "consequent andI = [Fun and [X, Y]]"
  | "consequent andE = [X, Y]"
  | "consequent impI = [Fun imp [X, Y]]"
  | "consequent impE = [Y]"

fun antecedent :: "prop_rule \<Rightarrow> ((string,prop_funs) pform,string) antecedent list"
  where "antecedent andI = [plain_ant X, plain_ant Y]"
  | "antecedent andE = [plain_ant (Fun and [X, Y])]"
  | "antecedent impI = [Antecedent {|X|} Y {}]"
  | "antecedent impE = [plain_ant (Fun imp [X, Y]), plain_ant X]"

interpretation propositional: Abstract_Rules
  "curry (SOME f. bij f):: nat \<Rightarrow> string \<Rightarrow> string"
  "\<lambda>_. id"
  "\<lambda>_. {}"
  "closed :: (string, prop_funs) pform \<Rightarrow> bool"
  subst
  "\<lambda>_. {}"
  "\<lambda>_. id"
  "Var undefined"
  antecedent
  consequent
  prop_rules
proof
  show "\<forall>xs\<in>sset prop_rules. consequent xs \<noteq> []"
    unfolding prop_rules_def
    using consequent.elims by blast
next
  show "\<forall>xs\<in>sset prop_rules. \<Union>((\<lambda>_. {}) ` set (consequent xs)) = {}"
    by clarsimp
next
  fix i' r i ia
  assume "r \<in> sset prop_rules"
    and "ia < length (antecedent r)"
    and "i' < length (antecedent r)"
  then show "a_fresh (antecedent r ! ia) \<inter> a_fresh (antecedent r ! i') = {} \<or> ia = i'"
    by (cases i'; auto)
next
  fix p
  show "{} \<union> \<Union>((\<lambda>_. {}) ` fset (a_hyps p)) \<subseteq> a_fresh p"  by clarsimp
qed

end


(* Author: Tobias Nipkow and Gerwin Klein *)

section "Compiler for IMP"

theory Chapter8_1 imports "~~/src/HOL/IMP/Big_Step" "~~/src/HOL/IMP/Star"
begin

subsection "List setup"

text {*
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting @{typ nat}
  to @{typ int} explicitly, we tell Isabelle to coerce @{typ nat}
  automatically when necessary.
*}
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text {*
  Similarly, we will want to access the ith element of a list,
  where @{term i} is an @{typ int}.
*}
fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

text {*
  The only additional lemma we need about this function
  is indexing over append:
*}
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induction xs arbitrary: i) (auto simp: algebra_simps)

text{* We hide coercion @{const int} applied to @{const length}: *}

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

text_raw{*\snip{instrdef}{0}{1}{% *}
datatype instr =
  LOADI int | LOAD vname | ADD | STORE vname |
  JMP int | JMPLESS int | JMPGE int
text_raw{*}%endsnip*}

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk) |
  JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i+1+n else i+1,s,tl2 stk) |
  JMPGE n \<Rightarrow> (if hd2 stk >= hd stk then i+1+n else i+1,s,tl2 stk))"

definition
  exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
     ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)
where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size P
  \<Longrightarrow> P \<turnstile> (i,s,stk) \<rightarrow> c'"
by (simp add: exec1_def)

abbreviation
  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50)
where
  "exec P \<equiv> star (exec1 P)"

declare star.step[intro]

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [''x'',''y''],stk) | i t stk.
    [LOAD ''y'', STORE ''x''] \<turnstile>
    (0, <''x'' := 3, ''y'' := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection{* Verification infrastructure *}

text{* Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program. *}

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
by(auto split:instr.split)

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro!: exec1_appendL)+

text{* Now we specialise the above lemmas to enable automatic proofs of
@{prop "P \<turnstile> c \<rightarrow>* c'"} where @{text P} is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by @{text "@"} and @{text "#"}. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it: *}

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text{* Split the execution of a compound program up into the excution of its
parts: *}

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
"bcomp (Not b) f n = bcomp b (\<not>f) n" |
"bcomp (And b1 b2) f n =
 (let cb2 = bcomp b2 f n;
        m = if f then size cb2 else (size cb2::int)+n;
      cb1 = bcomp b1 False m
  in cb1 @ cb2)" |
"bcomp (Less a1 a2) f n =
 acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (if c\<^sub>2 = SKIP then
    (let cc\<^sub>1 = ccomp c\<^sub>1; cb = bcomp b False (size cc\<^sub>1) in cb @ cc\<^sub>1)
   else (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2))" |
"ccomp (WHILE b DO c) =
 (let cc = ccomp c; cb = bcomp b False (size cc + 1)
  in cb @ cc @ [JMP (-(size cb + size cc + 1))])"

value "ccomp
 (IF Less (V ''u'') (N 1) THEN ''u'' ::= Plus (V ''u'') (N 1)
  ELSE ''v'' ::= V ''u'')"

value "ccomp (WHILE Less (V ''u'') (N 1) DO (''u'' ::= Plus (V ''u'') (N 1)))"

subsection "Preservation of semantics"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using `bval b s1` by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
qed fastforce+

end


(*  Title:      ZF/Induct/Acc.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>The accessible part of a relation\<close>

theory Acc imports Main begin

text \<open>
  Inductive definition of \<open>acc(r)\<close>; see @{cite "paulin-tlca"}.
\<close>

consts
  acc :: "i => i"

inductive
  domains "acc(r)" \<subseteq> "field(r)"
  intros
    vimage:  "[| r-``{a}: Pow(acc(r)); a \<in> field(r) |] ==> a \<in> acc(r)"
  monos      Pow_mono

text \<open>
  The introduction rule must require @{prop "a \<in> field(r)"},
  otherwise \<open>acc(r)\<close> would be a proper class!

  \medskip
  The intended introduction rule:
\<close>

lemma accI: "[| !!b. <b,a>:r ==> b \<in> acc(r);  a \<in> field(r) |] ==> a \<in> acc(r)"
  by (blast intro: acc.intros)

lemma acc_downward: "[| b \<in> acc(r);  <a,b>: r |] ==> a \<in> acc(r)"
  by (erule acc.cases) blast

lemma acc_induct [consumes 1, case_names vimage, induct set: acc]:
    "[| a \<in> acc(r);
        !!x. [| x \<in> acc(r);  \<forall>y. <y,x>:r \<longrightarrow> P(y) |] ==> P(x)
     |] ==> P(a)"
  by (erule acc.induct) (blast intro: acc.intros)

lemma wf_on_acc: "wf[acc(r)](r)"
  apply (rule wf_onI2)
  apply (erule acc_induct)
  apply fast
  done

lemma acc_wfI: "field(r) \<subseteq> acc(r) \<Longrightarrow> wf(r)"
  by (erule wf_on_acc [THEN wf_on_subset_A, THEN wf_on_field_imp_wf])

lemma acc_wfD: "wf(r) ==> field(r) \<subseteq> acc(r)"
  apply (rule subsetI)
  apply (erule wf_induct2, assumption)
   apply (blast intro: accI)+
  done

lemma wf_acc_iff: "wf(r) \<longleftrightarrow> field(r) \<subseteq> acc(r)"
  by (rule iffI, erule acc_wfD, erule acc_wfI)

end


(*  Title:       Proving the Correctness of Disk Paxos

    Author:      Mauro J. Jaskelioff, Stephan Merz, 2005
    Maintainer:  Mauro J. Jaskelioff <mauro at fceia.unr.edu.ar>
*)

theory DiskPaxos_Inv3 imports DiskPaxos_Inv2  begin

subsection {* Invariant 3 *}

text {*
  This invariant says that if two processes have read each other's block
  from disk $d$ during their current phases, then at least one of them
  has read the other's current block.
*}

definition HInv3_L :: "state \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "HInv3_L s p q d =  (phase s p \<in> {1,2}
                     \<and> phase s q \<in> {1,2}
                     \<and> hasRead s p d q
                     \<and> hasRead s q d p)"

definition HInv3_R :: "state \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "HInv3_R s p q d =  (\<lparr>block= dblock s q, proc= q\<rparr> \<in> blocksRead s p d
                     \<or> \<lparr>block= dblock s p, proc= p\<rparr> \<in> blocksRead s q d)"

definition HInv3_inner :: "state \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
  where "HInv3_inner s p q d = (HInv3_L s p q d \<longrightarrow> HInv3_R s p q d)"

definition HInv3 :: "state \<Rightarrow> bool"
  where "HInv3 s = (\<forall>p q d. HInv3_inner s p q d)"

subsubsection{* Proofs of Invariant 3 *}

theorem HInit_HInv3: "HInit s \<Longrightarrow> HInv3 s"
  by(simp add: HInit_def Init_def HInv3_def
               HInv3_inner_def HInv3_L_def HInv3_R_def)

lemma InitPhase_HInv3_p:
  "\<lbrakk> InitializePhase s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: InitializePhase_def HInv3_inner_def
                    hasRead_def HInv3_L_def HInv3_R_def)

lemma InitPhase_HInv3_q:
  "\<lbrakk> InitializePhase s s' q ; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: InitializePhase_def HInv3_inner_def
                    hasRead_def HInv3_L_def HInv3_R_def)

lemma HInv3_L_sym: "HInv3_L s p q d \<Longrightarrow> HInv3_L s q p d"
  by(auto simp add: HInv3_L_def)

lemma HInv3_R_sym: "HInv3_R s p q d \<Longrightarrow> HInv3_R s q p d"
  by(auto simp add: HInv3_R_def)

lemma Phase1or2ReadThen_HInv3_pq:
  assumes act:  "Phase1or2ReadThen s s' p d q"
  and  inv_L':  "HInv3_L s' p q d"
  and      pq:  "p\<noteq>q"
  and   inv2b:  "Inv2b s"
  shows   "HInv3_R s' p q d"
proof -
  from inv_L' act pq
  have "phase s q \<in> {1,2} \<and> hasRead s q d p"
    by(auto simp add: Phase1or2ReadThen_def HInv3_L_def
            hasRead_def split: split_if_asm)
  with inv2b
  have "disk s d q = dblock s q"
    by(auto simp add: Inv2b_def Inv2b_inner_def
             hasRead_def)
  with act
  show ?thesis
    by(auto simp add: Phase1or2ReadThen_def HInv3_def
                       HInv3_inner_def HInv3_R_def)
qed

lemma Phase1or2ReadThen_HInv3_hasRead:
  "\<lbrakk> \<not>hasRead s pp dd qq;
     Phase1or2ReadThen s s' p d q;
     pp\<noteq>p \<or> qq\<noteq>q \<or> dd\<noteq>d\<rbrakk>
  \<Longrightarrow> \<not>hasRead s' pp dd qq"
  by(auto simp add: hasRead_def Phase1or2ReadThen_def)

theorem HPhase1or2ReadThen_HInv3:
  assumes act:  "HPhase1or2ReadThen s s' p d q"
  and     inv:  "HInv3 s"
  and      pq:  "p\<noteq>q"
  and   inv2b:  "Inv2b s"
  shows   "HInv3 s'"
proof(clarsimp simp add: HInv3_def HInv3_inner_def)
  fix pp qq dd
  assume h3l': "HInv3_L s' pp qq dd"
  show  "HInv3_R s' pp qq dd"
  proof(cases "HInv3_L s pp qq dd")
    case True
    with inv
    have "HInv3_R s pp qq dd"
      by(auto simp add: HInv3_def HInv3_inner_def)
    with act h3l'
    show ?thesis
      by(auto simp add: HInv3_R_def HInv3_L_def
                          Phase1or2ReadThen_def)
  next
    case False
    assume nh3l: "\<not> HInv3_L s pp qq dd"
    show " HInv3_R s' pp qq dd"
    proof(cases "((pp=p \<and> qq=q) \<or> (pp=q \<and> qq=p)) \<and> dd=d")
      case True
      with act pq inv2b h3l' HInv3_L_sym[OF h3l']
      show ?thesis
        by(auto dest: Phase1or2ReadThen_HInv3_pq HInv3_R_sym)
    next
      case False
      from nh3l h3l' act
      have "(\<not>hasRead s pp dd qq \<or> \<not>hasRead s qq dd pp)
            \<and> hasRead s' pp dd qq \<and> hasRead s' qq dd pp"
        by(auto simp add: HInv3_L_def Phase1or2ReadThen_def)
      with act False
      show ?thesis
        by(auto dest: Phase1or2ReadThen_HInv3_hasRead)
    qed
  qed
qed

lemma StartBallot_HInv3_p:
  "\<lbrakk> StartBallot s s' p; HInv3_L s' p q d \<rbrakk>
          \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: StartBallot_def dest: InitPhase_HInv3_p)

lemma StartBallot_HInv3_q:
  "\<lbrakk> StartBallot s s' q; HInv3_L s' p q d \<rbrakk>
           \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: StartBallot_def dest: InitPhase_HInv3_q)

lemma StartBallot_HInv3_nL:
  "\<lbrakk> StartBallot s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
           \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: StartBallot_def InitializePhase_def
                      HInv3_L_def hasRead_def)

lemma StartBallot_HInv3_R:
  "\<lbrakk> StartBallot s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
              \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: StartBallot_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma StartBallot_HInv3_t:
  "\<lbrakk> StartBallot s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
        dest: StartBallot_HInv3_nL StartBallot_HInv3_R)

lemma StartBallot_HInv3:
  assumes act: "StartBallot s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
         dest: StartBallot_HInv3_p StartBallot_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: StartBallot_HInv3_t)
qed

theorem HStartBallot_HInv3:
  "\<lbrakk> HStartBallot s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: StartBallot_HInv3)

theorem HPhase1or2ReadElse_HInv3:
  "\<lbrakk> HPhase1or2ReadElse s s' p d q; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: Phase1or2ReadElse_def HInv3_def
              dest: StartBallot_HInv3)

theorem HPhase1or2Write_HInv3:
  assumes act: "HPhase1or2Write s s' p d"
  and inv: "HInv3 s"
  shows "HInv3 s'"
proof(auto simp add: HInv3_def)
  fix pp qq dd
  show " HInv3_inner s' pp qq dd"
  proof(cases "HInv3_L s pp qq dd")
    case True
    with inv
    have "HInv3_R s pp qq dd"
      by(simp add: HInv3_def HInv3_inner_def)
    with act
    show ?thesis
      by(auto simp add: HInv3_inner_def HInv3_R_def
                      Phase1or2Write_def)
  next
    case False
    with act
    have "\<not>HInv3_L s' pp qq dd"
      by(auto simp add: HInv3_L_def hasRead_def Phase1or2Write_def)
    thus ?thesis
      by(simp add: HInv3_inner_def)
  qed
qed

lemma EndPhase1_HInv3_p:
  "\<lbrakk> EndPhase1 s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: EndPhase1_def dest: InitPhase_HInv3_p)

lemma EndPhase1_HInv3_q:
  "\<lbrakk> EndPhase1 s s' q; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase1_def dest: InitPhase_HInv3_q)

lemma EndPhase1_HInv3_nL:
  "\<lbrakk> EndPhase1 s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                    \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: EndPhase1_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma EndPhase1_HInv3_R:
  "\<lbrakk> EndPhase1 s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                      \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase1_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma EndPhase1_HInv3_t:
  "\<lbrakk> EndPhase1 s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def dest: EndPhase1_HInv3_nL
                   EndPhase1_HInv3_R)

lemma EndPhase1_HInv3:
  assumes act: "EndPhase1 s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: EndPhase1_HInv3_p EndPhase1_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: EndPhase1_HInv3_t)
qed

theorem HEndPhase1_HInv3:
  "\<lbrakk> HEndPhase1 s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: EndPhase1_HInv3)

lemma EndPhase2_HInv3_p:
  "\<lbrakk> EndPhase2 s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: EndPhase2_def dest: InitPhase_HInv3_p)

lemma EndPhase2_HInv3_q:
  "\<lbrakk> EndPhase2 s s' q; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase2_def dest: InitPhase_HInv3_q)

lemma EndPhase2_HInv3_nL:
  "\<lbrakk> EndPhase2 s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                     \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: EndPhase2_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma EndPhase2_HInv3_R:
  "\<lbrakk> EndPhase2 s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                     \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase2_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma EndPhase2_HInv3_t:
  "\<lbrakk> EndPhase2 s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                    \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
              dest: EndPhase2_HInv3_nL EndPhase2_HInv3_R)

lemma EndPhase2_HInv3:
  assumes act: "EndPhase2 s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: EndPhase2_HInv3_p EndPhase2_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: EndPhase2_HInv3_t)
qed

theorem HEndPhase2_HInv3:
  "\<lbrakk> HEndPhase2 s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: EndPhase2_HInv3)

lemma Fail_HInv3_p:
  "\<lbrakk> Fail s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: Fail_def dest: InitPhase_HInv3_p)

lemma Fail_HInv3_q:
  "\<lbrakk> Fail s s' q; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: Fail_def dest: InitPhase_HInv3_q)

lemma Fail_HInv3_nL:
  "\<lbrakk> Fail s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
             \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: Fail_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma Fail_HInv3_R:
  "\<lbrakk> Fail s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
             \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: Fail_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma Fail_HInv3_t:
  "\<lbrakk> Fail s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
              \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
              dest: Fail_HInv3_nL Fail_HInv3_R)

lemma Fail_HInv3:
  assumes act: "Fail s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: Fail_HInv3_p Fail_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: Fail_HInv3_t)
qed

theorem HFail_HInv3:
  "\<lbrakk> HFail s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: Fail_HInv3)

theorem HPhase0Read_HInv3:
  assumes act: "HPhase0Read s s' p d"
  and inv: "HInv3 s"
  shows "HInv3 s'"
proof(auto simp add: HInv3_def)
  fix pp qq dd
  show " HInv3_inner s' pp qq dd"
  proof(cases "HInv3_L s pp qq dd")
    case True
    with inv
    have "HInv3_R s pp qq dd"
      by(simp add: HInv3_def HInv3_inner_def)
    with act
    show ?thesis
      by(auto simp add: HInv3_inner_def HInv3_R_def Phase0Read_def)
  next
    case False
    with act
    have "\<not>HInv3_L s' pp qq dd"
      by(auto simp add: HInv3_L_def hasRead_def Phase0Read_def)
    thus ?thesis
      by(simp add: HInv3_inner_def)
  qed
qed

lemma EndPhase0_HInv3_p:
  "\<lbrakk> EndPhase0 s s' p; HInv3_L s' p q d \<rbrakk>
              \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: EndPhase0_def dest: InitPhase_HInv3_p)

lemma EndPhase0_HInv3_q:
  "\<lbrakk> EndPhase0 s s' q; HInv3_L s' p q d \<rbrakk>
              \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase0_def dest: InitPhase_HInv3_q)

lemma EndPhase0_HInv3_nL:
  "\<lbrakk> EndPhase0 s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
               \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: EndPhase0_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma EndPhase0_HInv3_R:
  "\<lbrakk> EndPhase0 s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase0_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma EndPhase0_HInv3_t:
  "\<lbrakk> EndPhase0 s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                 \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
              dest: EndPhase0_HInv3_nL EndPhase0_HInv3_R)

lemma EndPhase0_HInv3:
  assumes act: "EndPhase0 s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: EndPhase0_HInv3_p EndPhase0_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: EndPhase0_HInv3_t)
qed

theorem HEndPhase0_HInv3:
  "\<lbrakk> HEndPhase0 s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: EndPhase0_HInv3)

text{* $HInv1 \wedge HInv2 \wedge HInv3$ is an invariant of $HNext$. *}

lemma I2c:
  assumes nxt: "HNext s s'"
  and inv: "HInv1 s \<and> HInv2 s \<and> HInv3 s"
  shows "HInv3 s'" using assms
  by(auto simp add: HNext_def Next_def,
     auto intro: HStartBallot_HInv3,
     auto intro: HPhase0Read_HInv3,
     auto intro: HPhase1or2Write_HInv3,
     auto simp add: Phase1or2Read_def HInv2_def
          intro: HPhase1or2ReadThen_HInv3
                 HPhase1or2ReadElse_HInv3,
     auto simp add: EndPhase1or2_def
          intro: HEndPhase1_HInv3
                 HEndPhase2_HInv3,
     auto intro: HFail_HInv3,
     auto intro: HEndPhase0_HInv3)

end