theory DDL imports Main            (* Christoph Benzmüller & Xavier Parent & Ali Farjami, 2018  *)

begin (* DDL: Dyadic Deontic Logic by Carmo and Jones *)
 typedecl i (*type for possible worlds*)
 type_synonym \<sigma> = "(i\<Rightarrow>bool)"
 type_synonym \<gamma> = "\<sigma>\<Rightarrow>\<sigma>"
 type_synonym \<rho> = "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>"

 consts av::"i\<Rightarrow>\<sigma>" pv::"i\<Rightarrow>\<sigma>" ob::"\<sigma>\<Rightarrow>(\<sigma>\<Rightarrow>bool)" (*accessibility relations*)
            cw::i (*current world*)

 axiomatization where
  ax_3a: "\<exists>x. av(w)(x)" and ax_4a: "\<forall>x. av(w)(x) \<longrightarrow> pv(w)(x)" and ax_4b: "pv(w)(w)" and
  ax_5a: "\<not>ob(X)(\<lambda>x. False)" and
  ax_5b: "(\<forall>w. ((Y(w) \<and> X(w)) \<longleftrightarrow> (Z(w) \<and> X(w)))) \<longrightarrow> (ob(X)(Y) \<longleftrightarrow> ob(X)(Z))" and
  ax_5c: "((\<forall>Z. \<beta>(Z) \<longrightarrow> ob(X)(Z)) \<and> (\<exists>Z. \<beta>(Z))) \<longrightarrow>
      (((\<exists>y. ((\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))(y) \<and> X(y))) \<longrightarrow> ob(X)(\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))))" and
  ax_5d: "((\<forall>w. Y(w) \<longrightarrow> X(w)) \<and> ob(X)(Y) \<and> (\<forall>w. X(w) \<longrightarrow> Z(w)))
                   \<longrightarrow> ob(Z)(\<lambda>w. (Z(w) \<and> \<not>X(w)) \<or> Y(w))" and
  ax_5e: "((\<forall>w. Y(w) \<longrightarrow> X(w)) \<and> ob(X)(Z) \<and> (\<exists>w. Y(w) \<and> Z(w))) \<longrightarrow> ob(Y)(Z)"

 abbreviation ddlneg::\<gamma> ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>A \<equiv> \<lambda>w. \<not>A(w)"
 abbreviation ddland::\<rho> (infixr"\<^bold>\<and>"51) where "A\<^bold>\<and>B \<equiv> \<lambda>w. A(w)\<and>B(w)"
 abbreviation ddlor::\<rho> (infixr"\<^bold>\<or>"50) where "A\<^bold>\<or>B \<equiv> \<lambda>w. A(w)\<or>B(w)"
 abbreviation ddlimp::\<rho> (infixr"\<^bold>\<rightarrow>"49) where "A\<^bold>\<rightarrow>B \<equiv> \<lambda>w. A(w)\<longrightarrow>B(w)"
 abbreviation ddlequiv::\<rho> (infixr"\<^bold>\<leftrightarrow>"48) where "A\<^bold>\<leftrightarrow>B \<equiv> \<lambda>w. A(w)\<longleftrightarrow>B(w)"
 abbreviation ddlbox::\<gamma> ("\<^bold>\<box>") where "\<^bold>\<box>A \<equiv> \<lambda>w.\<forall>v. A(v)"  (*A = (\<lambda>w. True)*)
 abbreviation ddlboxa::\<gamma> ("\<^bold>\<box>\<^sub>a") where "\<^bold>\<box>\<^sub>aA \<equiv> \<lambda>w. (\<forall>x. av(w)(x) \<longrightarrow> A(x))"  (*in all actual worlds*)
 abbreviation ddlboxp::\<gamma> ("\<^bold>\<box>\<^sub>p") where "\<^bold>\<box>\<^sub>pA \<equiv> \<lambda>w. (\<forall>x. pv(w)(x) \<longrightarrow> A(x))" (*in all potential worlds*)
 abbreviation ddldia::\<gamma> ("\<^bold>\<diamond>") where "\<^bold>\<diamond>A \<equiv> \<^bold>\<not>\<^bold>\<box>(\<^bold>\<not>A)"
 abbreviation ddldiaa::\<gamma> ("\<^bold>\<diamond>\<^sub>a") where "\<^bold>\<diamond>\<^sub>aA \<equiv> \<^bold>\<not>\<^bold>\<box>\<^sub>a(\<^bold>\<not>A)"
 abbreviation ddldiap::\<gamma> ("\<^bold>\<diamond>\<^sub>p") where "\<^bold>\<diamond>\<^sub>pA \<equiv> \<^bold>\<not>\<^bold>\<box>\<^sub>p(\<^bold>\<not>A)"
 abbreviation ddlo::\<rho> ("\<^bold>O\<^bold>\<langle>_\<^bold>|_\<^bold>\<rangle>"[52]53) where "\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<equiv> \<lambda>w. ob(A)(B)"  (*it ought to be \<psi>, given \<phi> *)
 abbreviation ddloa::\<gamma>  ("\<^bold>O\<^sub>a") where "\<^bold>O\<^sub>aA \<equiv> \<lambda>w. ob(av(w))(A) \<and> (\<exists>x. av(w)(x) \<and> \<not>A(x))" (*actual obligation*)
 abbreviation ddlop::\<gamma>  ("\<^bold>O\<^sub>p") where "\<^bold>O\<^sub>pA \<equiv> \<lambda>w. ob(pv(w))(A) \<and> (\<exists>x. pv(w)(x) \<and> \<not>A(x))"  (*primary obligation*)
 abbreviation ddltop::\<sigma> ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
 abbreviation ddlbot::\<sigma> ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"

(*Possibilist Quantification.*)
 abbreviation ddlforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
 abbreviation ddlforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
 abbreviation ddlexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
 abbreviation ddlexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

 abbreviation ddlvalid::"\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>"[7]105) where "\<lfloor>A\<rfloor> \<equiv> \<forall>w. A w"   (*Global validity*)
 abbreviation ddlvalidcw::"\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) where "\<lfloor>A\<rfloor>\<^sub>l \<equiv> A cw" (*Local validity (in cw)*)

(* A is obliagtory *)
 abbreviation ddlobl::\<gamma> ("\<^bold>\<circle><_>") where "\<^bold>\<circle><A> \<equiv>  \<^bold>O\<^bold>\<langle>A\<^bold>|\<^bold>\<top>\<^bold>\<rangle>"  (*New syntax: A is obligatory.*)

(* Consistency *)
 lemma True nitpick [satisfy] oops
end


theory Labeled_Hoare
imports
  "../../Case_Labeling"
  "HOL-Hoare.Hoare_Logic"
begin

subsection \<open>A labeling VCG for HOL/Hoare\<close>

context begin
  interpretation Labeling_Syntax .

  lemma LSeqRule:
    assumes "C\<langle>IC,CT,OC1: Valid P c1 Q\<rangle>"
      and "C\<langle>Suc OC1,CT,OC: Valid Q c2 R\<rangle>"
    shows "C\<langle>IC,CT,OC: Valid P (c1; c2) R\<rangle>"
    using assms unfolding LABEL_simps by (rule SeqRule)

  lemma LSkipRule:
    assumes "V\<langle>(''weaken'', IC, []),CT: p \<subseteq> q\<rangle>"
    shows "C\<langle>IC,CT,IC: Valid p SKIP q\<rangle>"
    using assms unfolding LABEL_simps  by (rule SkipRule)

  lemmas LAbortRule = LSkipRule  \<comment> \<open>dummy version\<close>

  lemma LBasicRule:
    assumes "V\<langle>(''basic'', IC, []),CT: p \<subseteq> {s. f s \<in> q}\<rangle>"
    shows "C\<langle>IC,CT,IC: Valid p (Basic f) q\<rangle>"
    using assms unfolding LABEL_simps  by (rule BasicRule)

  lemma LCondRule:
    fixes IC CT defines "CT' \<equiv> (''cond'', IC, []) # CT "
    assumes "V\<langle>(''vc'', IC, []),(''cond'', IC, []) # CT: p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}\<rangle>"
      and "C\<langle>Suc IC,(''then'', IC, []) # (''cond'', IC, []) # CT,OC1: Valid w c1 q\<rangle>"
      and "C\<langle>Suc OC1,(''else'', Suc OC1, []) # (''cond'', IC, []) # CT,OC: Valid w' c2 q\<rangle>"
    shows "C\<langle>IC,CT,OC: Valid p (IF b THEN c1  ELSE c2 FI) q\<rangle>"
    using assms(2-) unfolding LABEL_simps by (rule CondRule)

  lemma LWhileRule:
    fixes IC CT defines "CT' \<equiv> (''while'', IC, []) # CT"
    assumes "V\<langle>(''precondition'', IC, []),(''while'', IC, []) # CT: p \<subseteq> i\<rangle>"
      and "C\<langle>Suc IC,(''invariant'', Suc IC, []) # (''while'', IC, []) # CT,OC: Valid (i \<inter> b) c i\<rangle>"
      and "V\<langle>(''postcondition'', IC, []),(''while'', IC, []) # CT: i \<inter> - b \<subseteq> q\<rangle>"
    shows "C\<langle>IC,CT,OC: Valid p (While b i c) q\<rangle>"
    using assms(2-) unfolding LABEL_simps  by (rule WhileRule)

  lemma LABELs_to_prems:
    "(C\<langle>IC, CT, OC: True\<rangle> \<Longrightarrow> P) \<Longrightarrow> C\<langle>IC, CT, OC: P\<rangle>"
    "(V\<langle>x, ct: True\<rangle> \<Longrightarrow> P) \<Longrightarrow> V\<langle>x, ct: P\<rangle>"
    unfolding LABEL_simps by simp_all

  lemma LABELs_to_concl:
    "C\<langle>IC, CT, OC: True\<rangle> \<Longrightarrow> C\<langle>IC, CT, OC: P\<rangle> \<Longrightarrow> P"
    "V\<langle>x, ct: True\<rangle> \<Longrightarrow> V\<langle>x, ct: P\<rangle> \<Longrightarrow> P"
    unfolding LABEL_simps .

end

ML_file \<open>labeled_hoare_tac.ML\<close>

method_setup labeled_vcg = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Labeled_Hoare.hoare_tac ctxt (K all_tac)))\<close>
  "verification condition generator"

method_setup labeled_vcg_simp = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Labeled_Hoare.hoare_tac ctxt (asm_full_simp_tac ctxt)))\<close>
  "verification condition generator"

method_setup casified_vcg = \<open>
  Scan.lift (Casify.casify_options casify_defs) >>
    (fn opt => fn ctxt => Util.SIMPLE_METHOD_CASES (
      HEADGOAL (Labeled_Hoare.hoare_tac ctxt (K all_tac))
      THEN_CONTEXT Casify.casify_tac opt))
\<close>

method_setup casified_vcg_simp = \<open>
  Scan.lift (Casify.casify_options casify_defs) >>
    (fn opt => fn ctxt => Util.SIMPLE_METHOD_CASES (
      HEADGOAL (Labeled_Hoare.hoare_tac ctxt (asm_full_simp_tac ctxt))
      THEN_CONTEXT Casify.casify_tac opt))
\<close>

end


theory Prism
imports Iso
begin

locale prism =
  fixes get' :: "'s \<Rightarrow> 'a option" and "back" :: "'a \<Rightarrow> 's"
  assumes back_get'[simp]: "get' (back a) = Some a"
  assumes get'_back[simp]: "get' s = Some a \<Longrightarrow> back a = s"
begin

definition modify' :: "('a \<Rightarrow> 'a) \<Rightarrow> 's \<Rightarrow> 's option" where
[optics]: "modify' f s = map_option (back \<circ> f) (get' s)"

definition modify :: "('a \<Rightarrow> 'a) \<Rightarrow> 's \<Rightarrow> 's" where
[optics]: "modify f s = (case get' s of None \<Rightarrow> s | Some a \<Rightarrow> back (f a))"

lemma modify_id[simp]: "modify id = id"
unfolding modify_def[abs_def] id_def by (auto split: option.splits)

lemma modify_comp[simp]: "modify (f \<circ> g) = modify f \<circ> modify g"
unfolding modify_def[abs_def] comp_def by (auto split: option.splits)

end

context iso begin

definition [optics]: "get' = Some \<circ> get"

sublocale prism: prism get' "back"
by unfold_locales (auto simp: get'_def)

lemma prism_modify_eq[simp]: "prism.modify = modify"
unfolding prism.modify_def[abs_def] modify_def[abs_def]
by (simp add: get'_def)

end

locale compose_prism_prism =
  one: prism f g + two: prism h i for f :: "'s \<Rightarrow> 'a option" and g and h :: "'a \<Rightarrow> 'b option" and i
begin

definition [optics]: "get' s = Option.bind (f s) h"
definition [optics]: "back = g \<circ> i"

sublocale prism get' "back"
proof
  fix s b
  assume "get' s = Some b"
  then obtain a where "f s = Some a" "h a = Some b"
    unfolding get'_def
    by (meson bind_eq_Some_conv)
  thus "back b = s"
    by (auto simp: get'_def back_def)
qed (auto simp: get'_def back_def)

end

context compose_iso_iso begin

sublocale prism_prism: compose_prism_prism "iso.get' f" g "iso.get' h" i ..

lemma get'_eq[simp]: "prism_prism.get' = get'"
unfolding prism_prism.get'_def[abs_def]
unfolding get'_def one.get'_def two.get'_def
by (auto simp: get_def)

lemma back_eq[simp]: "prism_prism.back = back"
unfolding back_def prism_prism.back_def ..

end

context type_definition begin

definition get' :: "'a \<Rightarrow> 'b option" where
[optics]: "get' a = (if a \<in> A then Some (Abs a) else None)"

definition set :: "'b \<Rightarrow> 'a" where
[optics]: "set = Rep"

sublocale prism: prism get' set
proof
  fix a
  show "get' (set a) = Some a"
    unfolding set_def get'_def
    using Rep Rep_inverse by auto
next
  fix s a
  assume "get' s = Some a"
  hence "s \<in> A" "a = Abs s"
    unfolding get'_def
    by - (cases "s \<in> A"; auto)+
  thus "set a = s"
    unfolding set_def using Abs_inverse by auto
qed

end

end


section {* The Single Mutator Case *}

theory Gar_Coll imports Graph OG_Syntax begin

declare psubsetE [rule del]

text {* Declaration of variables: *}

record gar_coll_state =
  M :: nodes
  E :: edges
  bc :: "nat set"
  obc :: "nat set"
  Ma :: nodes
  ind :: nat
  k :: nat
  z :: bool

subsection {* The Mutator *}

text {* The mutator first redirects an arbitrary edge @{text "R"} from
an arbitrary accessible node towards an arbitrary accessible node
@{text "T"}.  It then colors the new target @{text "T"} black.

We declare the arbitrarily selected node and edge as constants:*}

consts R :: nat  T :: nat

text {* \noindent The following predicate states, given a list of
nodes @{text "m"} and a list of edges @{text "e"}, the conditions
under which the selected edge @{text "R"} and node @{text "T"} are
valid: *}

definition Mut_init :: "gar_coll_state \<Rightarrow> bool" where
  "Mut_init \<equiv> \<guillemotleft> T \<in> Reach \<acute>E \<and> R < length \<acute>E \<and> T < length \<acute>M \<guillemotright>"

text {* \noindent For the mutator we
consider two modules, one for each action.  An auxiliary variable
@{text "\<acute>z"} is set to false if the mutator has already redirected an
edge but has not yet colored the new target.   *}

definition Redirect_Edge :: "gar_coll_state ann_com" where
  "Redirect_Edge \<equiv> \<lbrace>\<acute>Mut_init \<and> \<acute>z\<rbrace> \<langle>\<acute>E:=\<acute>E[R:=(fst(\<acute>E!R), T)],, \<acute>z:= (\<not>\<acute>z)\<rangle>"

definition Color_Target :: "gar_coll_state ann_com" where
  "Color_Target \<equiv> \<lbrace>\<acute>Mut_init \<and> \<not>\<acute>z\<rbrace> \<langle>\<acute>M:=\<acute>M[T:=Black],, \<acute>z:= (\<not>\<acute>z)\<rangle>"

definition Mutator :: "gar_coll_state ann_com" where
  "Mutator \<equiv>
  \<lbrace>\<acute>Mut_init \<and> \<acute>z\<rbrace>
  WHILE True INV \<lbrace>\<acute>Mut_init \<and> \<acute>z\<rbrace>
  DO  Redirect_Edge ;; Color_Target  OD"

subsubsection {* Correctness of the mutator *}

lemmas mutator_defs = Mut_init_def Redirect_Edge_def Color_Target_def

lemma Redirect_Edge:
  "\<turnstile> Redirect_Edge pre(Color_Target)"
apply (unfold mutator_defs)
apply annhoare
apply(simp_all)
apply(force elim:Graph2)
done

lemma Color_Target:
  "\<turnstile> Color_Target \<lbrace>\<acute>Mut_init \<and> \<acute>z\<rbrace>"
apply (unfold mutator_defs)
apply annhoare
apply(simp_all)
done

lemma Mutator:
 "\<turnstile> Mutator \<lbrace>False\<rbrace>"
apply(unfold Mutator_def)
apply annhoare
apply(simp_all add:Redirect_Edge Color_Target)
apply(simp add:mutator_defs)
done

subsection {* The Collector *}

text {* \noindent A constant @{text "M_init"} is used to give @{text "\<acute>Ma"} a
suitable first value, defined as a list of nodes where only the @{text
"Roots"} are black. *}

consts  M_init :: nodes

definition Proper_M_init :: "gar_coll_state \<Rightarrow> bool" where
  "Proper_M_init \<equiv>  \<guillemotleft> Blacks M_init=Roots \<and> length M_init=length \<acute>M \<guillemotright>"

definition Proper :: "gar_coll_state \<Rightarrow> bool" where
  "Proper \<equiv> \<guillemotleft> Proper_Roots \<acute>M \<and> Proper_Edges(\<acute>M, \<acute>E) \<and> \<acute>Proper_M_init \<guillemotright>"

definition Safe :: "gar_coll_state \<Rightarrow> bool" where
  "Safe \<equiv> \<guillemotleft> Reach \<acute>E \<subseteq> Blacks \<acute>M \<guillemotright>"

lemmas collector_defs = Proper_M_init_def Proper_def Safe_def

subsubsection {* Blackening the roots *}

definition Blacken_Roots :: " gar_coll_state ann_com" where
  "Blacken_Roots \<equiv>
  \<lbrace>\<acute>Proper\<rbrace>
  \<acute>ind:=0;;
  \<lbrace>\<acute>Proper \<and> \<acute>ind=0\<rbrace>
  WHILE \<acute>ind<length \<acute>M
   INV \<lbrace>\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind\<le>length \<acute>M\<rbrace>
  DO \<lbrace>\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M\<rbrace>
   IF \<acute>ind\<in>Roots THEN
   \<lbrace>\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<in>Roots\<rbrace>
    \<acute>M:=\<acute>M[\<acute>ind:=Black] FI;;
   \<lbrace>\<acute>Proper \<and> (\<forall>i<\<acute>ind+1. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M\<rbrace>
    \<acute>ind:=\<acute>ind+1
  OD"

lemma Blacken_Roots:
 "\<turnstile> Blacken_Roots \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M\<rbrace>"
apply (unfold Blacken_Roots_def)
apply annhoare
apply(simp_all add:collector_defs Graph_defs)
apply safe
apply(simp_all add:nth_list_update)
  apply (erule less_SucE)
   apply simp+
 apply force
apply force
done

subsubsection {* Propagating black *}

definition PBInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool" where
  "PBInv \<equiv> \<guillemotleft> \<lambda>ind. \<acute>obc < Blacks \<acute>M \<or> (\<forall>i <ind. \<not>BtoW (\<acute>E!i, \<acute>M) \<or>
   (\<not>\<acute>z \<and> i=R \<and> (snd(\<acute>E!R)) = T \<and> (\<exists>r. ind \<le> r \<and> r < length \<acute>E \<and> BtoW(\<acute>E!r,\<acute>M))))\<guillemotright>"

definition Propagate_Black_aux :: "gar_coll_state ann_com" where
  "Propagate_Black_aux \<equiv>
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M\<rbrace>
  \<acute>ind:=0;;
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> \<acute>ind=0\<rbrace>
  WHILE \<acute>ind<length \<acute>E
   INV \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
         \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>E\<rbrace>
  DO \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
       \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E\<rbrace>
   IF \<acute>M!(fst (\<acute>E!\<acute>ind)) = Black THEN
    \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
       \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> \<acute>M!fst(\<acute>E!\<acute>ind)=Black\<rbrace>
     \<acute>M:=\<acute>M[snd(\<acute>E!\<acute>ind):=Black];;
    \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
       \<and> \<acute>PBInv (\<acute>ind + 1) \<and> \<acute>ind<length \<acute>E\<rbrace>
     \<acute>ind:=\<acute>ind+1
   FI
  OD"

lemma Propagate_Black_aux:
  "\<turnstile>  Propagate_Black_aux
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
    \<and> ( \<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)\<rbrace>"
apply (unfold Propagate_Black_aux_def  PBInv_def collector_defs)
apply annhoare
apply(simp_all add:Graph6 Graph7 Graph8 Graph12)
      apply force
     apply force
    apply force
--{* 4 subgoals left *}
apply clarify
apply(simp add:Proper_Edges_def Proper_Roots_def Graph6 Graph7 Graph8 Graph12)
apply (erule disjE)
 apply(rule disjI1)
 apply(erule Graph13)
 apply force
apply (case_tac "M x ! snd (E x ! ind x)=Black")
 apply (simp add: Graph10 BtoW_def)
 apply (rule disjI2)
 apply clarify
 apply (erule less_SucE)
  apply (erule_tac x=i in allE , erule (1) notE impE)
  apply simp
  apply clarify
  apply (drule_tac y = r in le_imp_less_or_eq)
  apply (erule disjE)
   apply (subgoal_tac "Suc (ind x)\<le>r")
    apply fast
   apply arith
  apply fast
 apply fast
apply(rule disjI1)
apply(erule subset_psubset_trans)
apply(erule Graph11)
apply fast
--{* 3 subgoals left *}
apply force
apply force
--{* last *}
apply clarify
apply simp
apply(subgoal_tac "ind x = length (E x)")
 apply (simp)
 apply(drule Graph1)
   apply simp
  apply clarify
  apply(erule allE, erule impE, assumption)
  apply force
 apply force
apply arith
done

subsubsection {* Refining propagating black *}

definition Auxk :: "gar_coll_state \<Rightarrow> bool" where
  "Auxk \<equiv> \<guillemotleft>\<acute>k<length \<acute>M \<and> (\<acute>M!\<acute>k\<noteq>Black \<or> \<not>BtoW(\<acute>E!\<acute>ind, \<acute>M) \<or>
          \<acute>obc<Blacks \<acute>M \<or> (\<not>\<acute>z \<and> \<acute>ind=R \<and> snd(\<acute>E!R)=T
          \<and> (\<exists>r. \<acute>ind<r \<and> r<length \<acute>E \<and> BtoW(\<acute>E!r, \<acute>M))))\<guillemotright>"

definition Propagate_Black :: " gar_coll_state ann_com" where
  "Propagate_Black \<equiv>
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M\<rbrace>
  \<acute>ind:=0;;
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> \<acute>ind=0\<rbrace>
  WHILE \<acute>ind<length \<acute>E
   INV \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
         \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>E\<rbrace>
  DO \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
       \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E\<rbrace>
   IF (\<acute>M!(fst (\<acute>E!\<acute>ind)))=Black THEN
    \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
      \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black\<rbrace>
     \<acute>k:=(snd(\<acute>E!\<acute>ind));;
    \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
      \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black
      \<and> \<acute>Auxk\<rbrace>
     \<langle>\<acute>M:=\<acute>M[\<acute>k:=Black],, \<acute>ind:=\<acute>ind+1\<rangle>
   ELSE \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
          \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E\<rbrace>
         \<langle>IF (\<acute>M!(fst (\<acute>E!\<acute>ind)))\<noteq>Black THEN \<acute>ind:=\<acute>ind+1 FI\<rangle>
   FI
  OD"

lemma Propagate_Black:
  "\<turnstile>  Propagate_Black
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
    \<and> ( \<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)\<rbrace>"
apply (unfold Propagate_Black_def  PBInv_def Auxk_def collector_defs)
apply annhoare
apply(simp_all add: Graph6 Graph7 Graph8 Graph12)
       apply force
      apply force
     apply force
--{* 5 subgoals left *}
apply clarify
apply(simp add:BtoW_def Proper_Edges_def)
--{* 4 subgoals left *}
apply clarify
apply(simp add:Proper_Edges_def Graph6 Graph7 Graph8 Graph12)
apply (erule disjE)
 apply (rule disjI1)
 apply (erule psubset_subset_trans)
 apply (erule Graph9)
apply (case_tac "M x!k x=Black")
 apply (case_tac "M x ! snd (E x ! ind x)=Black")
  apply (simp add: Graph10 BtoW_def)
  apply (rule disjI2)
  apply clarify
  apply (erule less_SucE)
   apply (erule_tac x=i in allE , erule (1) notE impE)
   apply simp
   apply clarify
   apply (drule_tac y = r in le_imp_less_or_eq)
   apply (erule disjE)
    apply (subgoal_tac "Suc (ind x)\<le>r")
     apply fast
    apply arith
   apply fast
  apply fast
 apply (simp add: Graph10 BtoW_def)
 apply (erule disjE)
  apply (erule disjI1)
 apply clarify
 apply (erule less_SucE)
  apply force
 apply simp
 apply (subgoal_tac "Suc R\<le>r")
  apply fast
 apply arith
apply(rule disjI1)
apply(erule subset_psubset_trans)
apply(erule Graph11)
apply fast
--{* 2 subgoals left *}
apply clarify
apply(simp add:Proper_Edges_def Graph6 Graph7 Graph8 Graph12)
apply (erule disjE)
 apply fast
apply clarify
apply (erule less_SucE)
 apply (erule_tac x=i in allE , erule (1) notE impE)
 apply simp
 apply clarify
 apply (drule_tac y = r in le_imp_less_or_eq)
 apply (erule disjE)
  apply (subgoal_tac "Suc (ind x)\<le>r")
   apply fast
  apply arith
 apply (simp add: BtoW_def)
apply (simp add: BtoW_def)
--{* last *}
apply clarify
apply simp
apply(subgoal_tac "ind x = length (E x)")
 apply (simp)
 apply(drule Graph1)
   apply simp
  apply clarify
  apply(erule allE, erule impE, assumption)
  apply force
 apply force
apply arith
done

subsubsection {* Counting black nodes *}

definition CountInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool" where
  "CountInv \<equiv> \<guillemotleft> \<lambda>ind. {i. i<ind \<and> \<acute>Ma!i=Black}\<subseteq>\<acute>bc \<guillemotright>"

definition Count :: " gar_coll_state ann_com" where
  "Count \<equiv>
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
    \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
    \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>bc={}\<rbrace>
  \<acute>ind:=0;;
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
    \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
   \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>bc={}
   \<and> \<acute>ind=0\<rbrace>
   WHILE \<acute>ind<length \<acute>M
     INV \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
           \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
           \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
           \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind\<le>length \<acute>M\<rbrace>
   DO \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
         \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
         \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
         \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M\<rbrace>
       IF \<acute>M!\<acute>ind=Black
          THEN \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
                 \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
                 \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
                 \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black\<rbrace>
          \<acute>bc:=insert \<acute>ind \<acute>bc
       FI;;
      \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
        \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
        \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv (\<acute>ind+1)
        \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M\<rbrace>
      \<acute>ind:=\<acute>ind+1
   OD"

lemma Count:
  "\<turnstile> Count
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
   \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> length \<acute>Ma=length \<acute>M
   \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)\<rbrace>"
apply(unfold Count_def)
apply annhoare
apply(simp_all add:CountInv_def Graph6 Graph7 Graph8 Graph12 Blacks_def collector_defs)
      apply force
     apply force
    apply force
   apply clarify
   apply simp
   apply(fast elim:less_SucE)
  apply clarify
  apply simp
  apply(fast elim:less_SucE)
 apply force
apply force
done

subsubsection {* Appending garbage nodes to the free list *}

axiomatization Append_to_free :: "nat \<times> edges \<Rightarrow> edges"
where
  Append_to_free0: "length (Append_to_free (i, e)) = length e" and
  Append_to_free1: "Proper_Edges (m, e)
                   \<Longrightarrow> Proper_Edges (m, Append_to_free(i, e))" and
  Append_to_free2: "i \<notin> Reach e
     \<Longrightarrow> n \<in> Reach (Append_to_free(i, e)) = ( n = i \<or> n \<in> Reach e)"

definition AppendInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool" where
  "AppendInv \<equiv> \<guillemotleft>\<lambda>ind. \<forall>i<length \<acute>M. ind\<le>i \<longrightarrow> i\<in>Reach \<acute>E \<longrightarrow> \<acute>M!i=Black\<guillemotright>"

definition Append :: "gar_coll_state ann_com" where
   "Append \<equiv>
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe\<rbrace>
  \<acute>ind:=0;;
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe \<and> \<acute>ind=0\<rbrace>
    WHILE \<acute>ind<length \<acute>M
      INV \<lbrace>\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>M\<rbrace>
    DO \<lbrace>\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M\<rbrace>
       IF \<acute>M!\<acute>ind=Black THEN
          \<lbrace>\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black\<rbrace>
          \<acute>M:=\<acute>M[\<acute>ind:=White]
       ELSE \<lbrace>\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<notin>Reach \<acute>E\<rbrace>
              \<acute>E:=Append_to_free(\<acute>ind,\<acute>E)
       FI;;
     \<lbrace>\<acute>Proper \<and> \<acute>AppendInv (\<acute>ind+1) \<and> \<acute>ind<length \<acute>M\<rbrace>
       \<acute>ind:=\<acute>ind+1
    OD"

lemma Append:
  "\<turnstile> Append \<lbrace>\<acute>Proper\<rbrace>"
apply(unfold Append_def AppendInv_def)
apply annhoare
apply(simp_all add:collector_defs Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
       apply(force simp:Blacks_def nth_list_update)
      apply force
     apply force
    apply(force simp add:Graph_defs)
   apply force
  apply clarify
  apply simp
  apply(rule conjI)
   apply (erule Append_to_free1)
  apply clarify
  apply (drule_tac n = "i" in Append_to_free2)
  apply force
 apply force
apply force
done

subsubsection {* Correctness of the Collector *}

definition Collector :: " gar_coll_state ann_com" where
  "Collector \<equiv>
\<lbrace>\<acute>Proper\<rbrace>
 WHILE True INV \<lbrace>\<acute>Proper\<rbrace>
 DO
  Blacken_Roots;;
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M\<rbrace>
   \<acute>obc:={};;
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={}\<rbrace>
   \<acute>bc:=Roots;;
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots\<rbrace>
   \<acute>Ma:=M_init;;
  \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots \<and> \<acute>Ma=M_init\<rbrace>
   WHILE \<acute>obc\<noteq>\<acute>bc
     INV \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
           \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc \<and> \<acute>bc\<subseteq>Blacks \<acute>M
           \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)\<rbrace>
   DO \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M\<rbrace>
       \<acute>obc:=\<acute>bc;;
       Propagate_Black;;
      \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
        \<and> (\<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)\<rbrace>
       \<acute>Ma:=\<acute>M;;
      \<lbrace>\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma
        \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> length \<acute>Ma=length \<acute>M
        \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)\<rbrace>
       \<acute>bc:={};;
       Count
   OD;;
  Append
 OD"

lemma Collector:
  "\<turnstile> Collector \<lbrace>False\<rbrace>"
apply(unfold Collector_def)
apply annhoare
apply(simp_all add: Blacken_Roots Propagate_Black Count Append)
apply(simp_all add:Blacken_Roots_def Propagate_Black_def Count_def Append_def collector_defs)
   apply (force simp add: Proper_Roots_def)
  apply force
 apply force
apply clarify
apply (erule disjE)
apply(simp add:psubsetI)
 apply(force dest:subset_antisym)
done

subsection {* Interference Freedom *}

lemmas modules = Redirect_Edge_def Color_Target_def Blacken_Roots_def
                 Propagate_Black_def Count_def Append_def
lemmas Invariants = PBInv_def Auxk_def CountInv_def AppendInv_def
lemmas abbrev = collector_defs mutator_defs Invariants

lemma interfree_Blacken_Roots_Redirect_Edge:
 "interfree_aux (Some Blacken_Roots, {}, Some Redirect_Edge)"
apply (unfold modules)
apply interfree_aux
apply safe
apply (simp_all add:Graph6 Graph12 abbrev)
done

lemma interfree_Redirect_Edge_Blacken_Roots:
  "interfree_aux (Some Redirect_Edge, {}, Some Blacken_Roots)"
apply (unfold modules)
apply interfree_aux
apply safe
apply(simp add:abbrev)+
done

lemma interfree_Blacken_Roots_Color_Target:
  "interfree_aux (Some Blacken_Roots, {}, Some Color_Target)"
apply (unfold modules)
apply interfree_aux
apply safe
apply(simp_all add:Graph7 Graph8 nth_list_update abbrev)
done

lemma interfree_Color_Target_Blacken_Roots:
  "interfree_aux (Some Color_Target, {}, Some Blacken_Roots)"
apply (unfold modules )
apply interfree_aux
apply safe
apply(simp add:abbrev)+
done

lemma interfree_Propagate_Black_Redirect_Edge:
  "interfree_aux (Some Propagate_Black, {}, Some Redirect_Edge)"
apply (unfold modules )
apply interfree_aux
--{* 11 subgoals left *}
apply(clarify, simp add:abbrev Graph6 Graph12)
apply(clarify, simp add:abbrev Graph6 Graph12)
apply(clarify, simp add:abbrev Graph6 Graph12)
apply(clarify, simp add:abbrev Graph6 Graph12)
apply(erule conjE)+
apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
 apply(erule Graph4)
   apply(simp)+
  apply (simp add:BtoW_def)
 apply (simp add:BtoW_def)
apply(rule conjI)
 apply (force simp add:BtoW_def)
apply(erule Graph4)
   apply simp+
--{* 7 subgoals left *}
apply(clarify, simp add:abbrev Graph6 Graph12)
apply(erule conjE)+
apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
 apply(erule Graph4)
   apply(simp)+
  apply (simp add:BtoW_def)
 apply (simp add:BtoW_def)
apply(rule conjI)
 apply (force simp add:BtoW_def)
apply(erule Graph4)
   apply simp+
--{* 6 subgoals left *}
apply(clarify, simp add:abbrev Graph6 Graph12)
apply(erule conjE)+
apply(rule conjI)
 apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
  apply(erule Graph4)
    apply(simp)+
   apply (simp add:BtoW_def)
  apply (simp add:BtoW_def)
 apply(rule conjI)
  apply (force simp add:BtoW_def)
 apply(erule Graph4)
    apply simp+
apply(simp add:BtoW_def nth_list_update)
apply force
--{* 5 subgoals left *}
apply(clarify, simp add:abbrev Graph6 Graph12)
--{* 4 subgoals left *}
apply(clarify, simp add:abbrev Graph6 Graph12)
apply(rule conjI)
 apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
  apply(erule Graph4)
    apply(simp)+
   apply (simp add:BtoW_def)
  apply (simp add:BtoW_def)
 apply(rule conjI)
  apply (force simp add:BtoW_def)
 apply(erule Graph4)
    apply simp+
apply(rule conjI)
 apply(simp add:nth_list_update)
 apply force
apply(rule impI, rule impI, erule disjE, erule disjI1, case_tac "R = (ind x)" ,case_tac "M x ! T = Black")
  apply(force simp add:BtoW_def)
 apply(case_tac "M x !snd (E x ! ind x)=Black")
  apply(rule disjI2)
  apply simp
  apply (erule Graph5)
  apply simp+
 apply(force simp add:BtoW_def)
apply(force simp add:BtoW_def)
--{* 3 subgoals left *}
apply(clarify, simp add:abbrev Graph6 Graph12)
--{* 2 subgoals left *}
apply(clarify, simp add:abbrev Graph6 Graph12)
apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
 apply clarify
 apply(erule Graph4)
   apply(simp)+
  apply (simp add:BtoW_def)
 apply (simp add:BtoW_def)
apply(rule conjI)
 apply (force simp add:BtoW_def)
apply(erule Graph4)
   apply simp+
done

lemma interfree_Redirect_Edge_Propagate_Black:
  "interfree_aux (Some Redirect_Edge, {}, Some Propagate_Black)"
apply (unfold modules )
apply interfree_aux
apply(clarify, simp add:abbrev)+
done

lemma interfree_Propagate_Black_Color_Target:
  "interfree_aux (Some Propagate_Black, {}, Some Color_Target)"
apply (unfold modules )
apply interfree_aux
--{* 11 subgoals left *}
apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)+
apply(erule conjE)+
apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
      case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
      erule allE, erule impE, assumption, erule impE, assumption,
      simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
--{* 7 subgoals left *}
apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
apply(erule conjE)+
apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
      case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
      erule allE, erule impE, assumption, erule impE, assumption,
      simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
--{* 6 subgoals left *}
apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
apply clarify
apply (rule conjI)
 apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
      case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
      erule allE, erule impE, assumption, erule impE, assumption,
      simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
apply(simp add:nth_list_update)
--{* 5 subgoals left *}
apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
--{* 4 subgoals left *}
apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
apply (rule conjI)
 apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
      case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
      erule allE, erule impE, assumption, erule impE, assumption,
      simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
apply(rule conjI)
apply(simp add:nth_list_update)
apply(rule impI,rule impI, case_tac "M x!T=Black",rotate_tac -1, force simp add: BtoW_def Graph10,
      erule subset_psubset_trans, erule Graph11, force)
--{* 3 subgoals left *}
apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
--{* 2 subgoals left *}
apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
      case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
      erule allE, erule impE, assumption, erule impE, assumption,
      simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
--{* 3 subgoals left *}
apply(simp add:abbrev)
done

lemma interfree_Color_Target_Propagate_Black:
  "interfree_aux (Some Color_Target, {}, Some Propagate_Black)"
apply (unfold modules )
apply interfree_aux
apply(clarify, simp add:abbrev)+
done

lemma interfree_Count_Redirect_Edge:
  "interfree_aux (Some Count, {}, Some Redirect_Edge)"
apply (unfold modules)
apply interfree_aux
--{* 9 subgoals left *}
apply(simp_all add:abbrev Graph6 Graph12)
--{* 6 subgoals left *}
apply(clarify, simp add:abbrev Graph6 Graph12,
      erule disjE,erule disjI1,rule disjI2,rule subset_trans, erule Graph3,force,force)+
done

lemma interfree_Redirect_Edge_Count:
  "interfree_aux (Some Redirect_Edge, {}, Some Count)"
apply (unfold modules )
apply interfree_aux
apply(clarify,simp add:abbrev)+
apply(simp add:abbrev)
done

lemma interfree_Count_Color_Target:
  "interfree_aux (Some Count, {}, Some Color_Target)"
apply (unfold modules )
apply interfree_aux
--{* 9 subgoals left *}
apply(simp_all add:abbrev Graph7 Graph8 Graph12)
--{* 6 subgoals left *}
apply(clarify,simp add:abbrev Graph7 Graph8 Graph12,
      erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)+
--{* 2 subgoals left *}
apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
apply(rule conjI)
 apply(erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)
apply(simp add:nth_list_update)
--{* 1 subgoal left *}
apply(clarify, simp add:abbrev Graph7 Graph8 Graph12,
      erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)
done

lemma interfree_Color_Target_Count:
  "interfree_aux (Some Color_Target, {}, Some Count)"
apply (unfold modules )
apply interfree_aux
apply(clarify, simp add:abbrev)+
apply(simp add:abbrev)
done

lemma interfree_Append_Redirect_Edge:
  "interfree_aux (Some Append, {}, Some Redirect_Edge)"
apply (unfold modules )
apply interfree_aux
apply( simp_all add:abbrev Graph6 Append_to_free0 Append_to_free1 Graph12)
apply(clarify, simp add:abbrev Graph6 Append_to_free0 Append_to_free1 Graph12, force dest:Graph3)+
done

lemma interfree_Redirect_Edge_Append:
  "interfree_aux (Some Redirect_Edge, {}, Some Append)"
apply (unfold modules )
apply interfree_aux
apply(clarify, simp add:abbrev Append_to_free0)+
apply (force simp add: Append_to_free2)
apply(clarify, simp add:abbrev Append_to_free0)+
done

lemma interfree_Append_Color_Target:
  "interfree_aux (Some Append, {}, Some Color_Target)"
apply (unfold modules )
apply interfree_aux
apply(clarify, simp add:abbrev Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12 nth_list_update)+
apply(simp add:abbrev Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12 nth_list_update)
done

lemma interfree_Color_Target_Append:
  "interfree_aux (Some Color_Target, {}, Some Append)"
apply (unfold modules )
apply interfree_aux
apply(clarify, simp add:abbrev Append_to_free0)+
apply (force simp add: Append_to_free2)
apply(clarify,simp add:abbrev Append_to_free0)+
done

lemmas collector_mutator_interfree =
 interfree_Blacken_Roots_Redirect_Edge interfree_Blacken_Roots_Color_Target
 interfree_Propagate_Black_Redirect_Edge interfree_Propagate_Black_Color_Target
 interfree_Count_Redirect_Edge interfree_Count_Color_Target
 interfree_Append_Redirect_Edge interfree_Append_Color_Target
 interfree_Redirect_Edge_Blacken_Roots interfree_Color_Target_Blacken_Roots
 interfree_Redirect_Edge_Propagate_Black interfree_Color_Target_Propagate_Black
 interfree_Redirect_Edge_Count interfree_Color_Target_Count
 interfree_Redirect_Edge_Append interfree_Color_Target_Append

subsubsection {* Interference freedom Collector-Mutator *}

lemma interfree_Collector_Mutator:
 "interfree_aux (Some Collector, {}, Some Mutator)"
apply(unfold Collector_def Mutator_def)
apply interfree_aux
apply(simp_all add:collector_mutator_interfree)
apply(unfold modules collector_defs Mut_init_def)
apply(tactic  {* TRYALL (interfree_aux_tac @{context}) *})
--{* 32 subgoals left *}
apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
--{* 20 subgoals left *}
apply(tactic{* TRYALL (clarify_tac @{context}) *})
apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
apply(tactic {* TRYALL (etac disjE) *})
apply simp_all
apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac subset_trans,etac @{thm Graph3},force_tac @{context}, assume_tac @{context}]) *})
apply(tactic {* TRYALL(EVERY'[rtac disjI2,etac subset_trans,rtac @{thm Graph9},force_tac @{context}]) *})
apply(tactic {* TRYALL(EVERY'[rtac disjI1,etac @{thm psubset_subset_trans},rtac @{thm Graph9},force_tac @{context}]) *})
done

subsubsection {* Interference freedom Mutator-Collector *}

lemma interfree_Mutator_Collector:
 "interfree_aux (Some Mutator, {}, Some Collector)"
apply(unfold Collector_def Mutator_def)
apply interfree_aux
apply(simp_all add:collector_mutator_interfree)
apply(unfold modules collector_defs Mut_init_def)
apply(tactic  {* TRYALL (interfree_aux_tac @{context}) *})
--{* 64 subgoals left *}
apply(simp_all add:nth_list_update Invariants Append_to_free0)+
apply(tactic{* TRYALL (clarify_tac @{context}) *})
--{* 4 subgoals left *}
apply force
apply(simp add:Append_to_free2)
apply force
apply(simp add:Append_to_free2)
done

subsubsection {* The Garbage Collection algorithm *}

text {* In total there are 289 verification conditions.  *}

lemma Gar_Coll:
  "\<parallel>- \<lbrace>\<acute>Proper \<and> \<acute>Mut_init \<and> \<acute>z\<rbrace>
  COBEGIN
   Collector
  \<lbrace>False\<rbrace>
 \<parallel>
   Mutator
  \<lbrace>False\<rbrace>
 COEND
  \<lbrace>False\<rbrace>"
apply oghoare
apply(force simp add: Mutator_def Collector_def modules)
apply(rule Collector)
apply(rule Mutator)
apply(simp add:interfree_Collector_Mutator)
apply(simp add:interfree_Mutator_Collector)
apply force
done

end


theory escape_NoSpecial
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Token = A | B | C | D | ESC | P | Q | R

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun isSpecial :: "Token => bool" where
"isSpecial x =
   case x of
     | other => False
     | ESC => True
     | P => True
     | Q => True
     | R => True
   end"

fun isEsc :: "Token => bool" where
"isEsc x =
   case x of
     | other => False
     | ESC => True
   end"

fun ok :: "Token => bool" where
"ok x = or2 (~ (isSpecial x)) (isEsc x)"

fun code :: "Token => Token" where
"code x =
   case x of
     | other => x
     | ESC => x
     | P => A
     | Q => B
     | R => C
   end"

fun escape :: "Token list => Token list" where
"escape (Nil2) = Nil2"
| "escape (Cons2 y xs) =
     (if isSpecial y then Cons2 ESC (Cons2 (code y) (escape xs)) else
        Cons2 y (escape xs))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun all :: "('a => bool) => 'a list => bool" where
"all x (Nil2) = True"
| "all x (Cons2 z xs) = and2 (x z) (all x xs)"

(*hipster or2 isSpecial isEsc ok code escape and2 all *)

theorem x0 :
  "!! (xs :: Token list) . all (% (x :: Token) => ok x) (escape xs)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*  Title:      WhileGraphSSA.thy
    Author:     Denis Lohner, Sebastian Ullrich
*)

subsubsection \<open>Instantiation for a Simple While Language\<close>

theory WhileGraphSSA imports
Generic_Interpretation
Disjoin_Transform
"HOL-Library.List_Lexorder"
"HOL-Library.Char_ord"
begin

instantiation w_node :: ord
begin

fun less_eq_w_node where
  "(_Entry_) \<le> x = True"
| "(_ n _) \<le> x = (case x of
     (_Entry_) \<Rightarrow> False
   | (_ m _) \<Rightarrow> n \<le> m
   | (_Exit_) \<Rightarrow> True)"
| "(_Exit_) \<le> x = (x = (_Exit_))"

fun less_w_node where
  "(_Entry_) < x = (x \<noteq> (_Entry_))"
| "(_ n _) < x = (case x of
     (_Entry_) \<Rightarrow> False
   | (_ m _) \<Rightarrow> n < m
   | (_Exit_) \<Rightarrow> True)"
| "(_Exit_) < x = False"

instance ..
end

instance w_node :: linorder proof
  fix x y z :: w_node

  show "x \<le> x" by (cases x) auto
  show "x \<le> y \<or> y \<le> x" by (cases x) (cases y, auto)+
  show "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x" by (cases x) (cases y, auto)+

  assume "x \<le> y" and "y \<le> z"
  thus "x \<le> z" by (cases x, cases y, cases z) auto

  assume "x \<le> y" and "y \<le> x"
  thus "x = y" by (cases x) (cases y, auto)+
qed

declare Defs.simps [simp del]
declare Uses.simps [simp del]
declare Let_def [simp]

declare finite_valid_nodes [simp, intro!]

lemma finite_valid_edge [simp, intro!]: "finite (Collect (valid_edge c))"
  unfolding valid_edge_def [abs_def]
apply (rule inj_on_finite [where f="\<lambda>(f,d,t). (f,t)" and B="Collect (valid_node c) \<times> Collect (valid_node c)"])
  apply (rule inj_onI)
  apply (auto intro: WCFG_edge_det)[1]
 apply (force simp: valid_node_def valid_edge_def)[1]
by auto

lemma uses_expr_finite: "finite (rhs_aux e)"
  by (induction e) auto

lemma uses_cmd_finite: "finite (rhs c)"
  by (induction c) (auto intro: uses_expr_finite)

lemma defs_cmd_finite: "finite (lhs c)"
  by (induction c) auto

lemma finite_labels': "finite {(l,c). labels prog l c}"
proof -
  have "{l. \<exists>c. labels prog l c} = fst ` {(l,c). labels prog l c}"
    by auto
  with finite_labels [of prog] labels_det [of prog] show ?thesis
    by (auto 4 4 intro: inj_onI dest: finite_imageD)
qed

lemma finite_Uses [simp, intro!]: "finite (Uses c n)"
  unfolding Uses.simps
apply clarsimp
apply (rule_tac B="\<Union>(rhs ` snd ` {(l,c'). labels c l c'})" in finite_subset)
 apply fastforce
apply (rule finite_Union)
 apply (rule finite_imageI)+
 apply (rule finite_labels')
by (clarsimp simp: uses_cmd_finite)

definition "while_cfg_\<alpha>e c = Collect (valid_edge (transform c))"
definition "while_cfg_\<alpha>n c = sorted_list_of_set (Collect (valid_node (transform c)))"
definition "while_cfg_invar c = True"
definition "while_cfg_inEdges' c t = (SOME ls. distinct ls \<and> set ls = {(sourcenode e, kind e)| e. valid_edge (transform c) e \<and> targetnode e = t})"
definition "while_cfg_Entry c = (_Entry_)"
definition "while_cfg_defs c = (Defs (transform c))((_Entry_) := {v. \<exists>n. v \<in> Uses (transform c) n})"
definition "while_cfg_uses c = Uses (transform c)"

abbreviation "while_cfg_inEdges c t \<equiv> map (\<lambda>(f,d). (f,d,t)) (while_cfg_inEdges' c t)"

lemmas while_cfg_defs = while_cfg_\<alpha>e_def while_cfg_\<alpha>n_def
  while_cfg_invar_def while_cfg_inEdges'_def
  while_cfg_Entry_def while_cfg_defs_def
  while_cfg_uses_def

interpretation while: graph_path while_cfg_\<alpha>e while_cfg_\<alpha>n while_cfg_invar while_cfg_inEdges'
apply unfold_locales
apply (simp_all add: while_cfg_defs)
   apply (force simp: valid_node_def)[1]
  apply (force simp: valid_node_def)[1]
 apply (rule set_iterator_I)
   prefer 3 apply (simp add: foldri_def)
  apply simp
 apply simp
apply (clarsimp simp: Graph_path.pred_def)
apply (subgoal_tac "finite {(v', w). valid_edge (transform g) (v', w, v)}")
 apply (drule finite_distinct_list)
 apply clarsimp
 apply (rule_tac a=xs in someI2)
  apply simp
 apply clarsimp
 apply (metis set_iterator_foldri_correct)
apply (rule_tac f="\<lambda>(f,d,t). (f,d)" in finite_surj [OF finite_valid_edge])
by (auto intro: rev_image_eqI)

lemma right_total_const: "right_total (\<lambda>x y. x = c)"
  by (rule right_totalI) simp

lemma const_transfer: "rel_fun (\<lambda>x y. x = c) (=) f (\<lambda>_. f c)"
  by (clarsimp simp: rel_fun_def)

interpretation while_ign: graph_path "\<lambda>_. while_cfg_\<alpha>e cmd" "\<lambda>_. while_cfg_\<alpha>n cmd" "\<lambda>_. while_cfg_invar cmd" "\<lambda>_. while_cfg_inEdges' cmd"
by (rule graph_path_transfer [OF right_total_const const_transfer const_transfer const_transfer const_transfer, rule_format])
  unfold_locales

definition "gen_while_cfg g \<equiv> \<lparr>
  gen_\<alpha>e = while_cfg_\<alpha>e g,
  gen_\<alpha>n = while_cfg_\<alpha>n g,
  gen_inEdges = while_cfg_inEdges g,
  gen_Entry = while_cfg_Entry g,
  gen_defs = while_cfg_defs g ,
  gen_uses = while_cfg_uses g
\<rparr>"

lemma  while_path_graph_pathD: "While_CFG.path (transform c) n es m \<Longrightarrow> while.path2 c n (n#map targetnode es) m"
  unfolding while.path2_def
apply (induction n es m rule: While_CFG.path.induct)
 apply clarsimp
 apply (rule while.path.intros)
  apply (auto simp: while_cfg_defs valid_node_def While_CFG.valid_node_def)[1]
 apply (simp add: while_cfg_defs)
apply clarsimp
apply (rule while.path.intros)
 apply assumption
apply (clarsimp simp: while.predecessors_def)
apply (rename_tac n ed m)
apply (rule_tac x="(n,ed,m)" in image_eqI)
 apply simp
apply (clarsimp simp: while.inEdges_def)
apply (rule_tac x="(n,ed)" in image_eqI)
 apply simp
apply (clarsimp simp: while_cfg_inEdges'_def)
apply (subgoal_tac "finite {(aa, a). valid_edge (transform c) (aa, a, m)}")
 prefer 2
 apply (rule_tac f="\<lambda>(f,d,t). (f,d)" in finite_surj [OF finite_valid_edge])
 apply (auto intro: rev_image_eqI)[1]
apply (drule finite_distinct_list)
apply clarsimp
by (rule_tac a=xs in someI2; simp)

lemma Uses_Entry [simp]: "Uses c (_Entry_) = {}"
  unfolding Uses.simps by auto

lemma in_Uses_valid_node: "V \<in> Uses c n \<Longrightarrow> valid_node c n"
  by (auto dest!: label_less_num_inner_nodes less_num_nodes_edge
    simp: Uses.simps valid_node_def valid_edge_def)

lemma while_cfg_CFG_wf_impl:
  "SSA_CFG.CFG_wf (\<lambda>_. gen_\<alpha>e (gen_while_cfg cmd)) (\<lambda>_. gen_\<alpha>n (gen_while_cfg cmd))
            (\<lambda>_. while_cfg_invar cmd) (\<lambda>_. gen_inEdges' (gen_while_cfg cmd))
            (\<lambda>_. gen_Entry (gen_while_cfg cmd)) (\<lambda>_. gen_defs (gen_while_cfg cmd))
            (\<lambda>_. gen_uses (gen_while_cfg cmd))"
apply (simp add: gen_while_cfg_def o_def split_beta)
unfolding SSA_CFG.CFG_wf_def
apply (rule conjI)
apply (rule CFG_transfer [OF right_total_const const_transfer const_transfer const_transfer const_transfer const_transfer const_transfer const_transfer, rule_format])
apply unfold_locales[1]
        apply (auto simp: while_cfg_defs valid_node_def valid_edge_def intro: While_CFG.intros)[1]
       apply (clarsimp simp: while.inEdges_def)
       apply (clarsimp simp: while_cfg_defs valid_edge_def)
       apply (subgoal_tac "{(aa, a). transform g \<turnstile> aa -a\<rightarrow> (_Entry_)} = {}")
        apply clarsimp
        apply (rule_tac a="[]" in someI2; simp)
       apply auto[1]
      apply (subst(asm) while_cfg_\<alpha>n_def)
      apply simp
      apply (drule valid_node_Entry_path)
      apply clarsimp
      apply (drule while_path_graph_pathD)
      apply (auto simp: while_cfg_Entry_def)[1]
     apply (clarsimp simp: while_cfg_defs)
    apply (clarsimp simp: while_cfg_defs)
    apply (subgoal_tac "{v. \<exists>n. v \<in> Uses (transform g) n} = (\<Union>n \<in> Collect (valid_node (transform g)). Uses (transform g) n)")
     apply simp
    apply (auto dest: in_Uses_valid_node)[1]
   apply (auto dest!: label_less_num_inner_nodes less_num_nodes_edge
     simp: Uses.simps valid_node_def valid_edge_def while_cfg_defs)[1]
  apply (clarsimp simp: while_cfg_defs)
 apply (clarsimp simp: while_cfg_defs)
apply (clarsimp simp: SSA_CFG.CFG_wf_axioms_def CFG_base.defAss'_def)
apply (rule_tac x="(_Entry_)" in bexI)
 apply (auto simp: while_cfg_defs)[1]
by (auto elim: graph_path_base.path.cases simp: graph_path_base.path2_def while_cfg_Entry_def)

lift_definition gen_while_cfg_wf :: "cmd \<Rightarrow> (w_node, vname, state edge_kind) gen_cfg_wf"
  is gen_while_cfg
using while_cfg_CFG_wf_impl
  by (auto simp: gen_while_cfg_def o_def split_beta while_cfg_invar_def)

definition "build_ssa cmd = gen_ssa_wf_notriv_substAll (gen_ssa_cfg_wf (gen_while_cfg_wf cmd))"

end