section \<open>Interpreted Transition Systems and Traces\<close>

theory Transition_System_Interpreted_Traces
imports
  Transition_System_Traces
  "Basics/Stuttering"
begin

  locale transition_system_interpreted_traces =
    transition_system_interpreted ex en int +
    transition_system_traces ex en ind
    for ex :: "'action \<Rightarrow> 'state \<Rightarrow> 'state"
    and en :: "'action \<Rightarrow> 'state \<Rightarrow> bool"
    and int :: "'state \<Rightarrow> 'interpretation"
    and ind :: "'action \<Rightarrow> 'action \<Rightarrow> bool"
    +
    assumes independence_invisible: "a \<in> visible \<Longrightarrow> b \<in> visible \<Longrightarrow> \<not> ind a b"
  begin

    lemma eq_swap_lproject_visible:
      assumes "u =\<^sub>S v"
      shows "lproject visible (llist_of u) = lproject visible (llist_of v)"
      using assms independence_invisible by (induct, auto)
    lemma eq_fin_lproject_visible:
      assumes "u =\<^sub>F v"
      shows "lproject visible (llist_of u) = lproject visible (llist_of v)"
      using assms eq_swap_lproject_visible by (induct, auto)
    lemma le_fin_lproject_visible:
      assumes "u \<preceq>\<^sub>F v"
      shows "lproject visible (llist_of u) \<le> lproject visible (llist_of v)"
    proof -
      obtain w where 1: "u @ w =\<^sub>F v" using assms by rule
      have "lproject visible (llist_of u) \<le>
        lproject visible (llist_of u) $ lproject visible (llist_of w)" by auto
      also have "\<dots> = lproject visible (llist_of (u @ w))" using lappend_llist_of_llist_of by auto
      also have "\<dots> = lproject visible (llist_of v)" using eq_fin_lproject_visible 1 by this
      finally show ?thesis by this
    qed
    lemma le_fininf_lproject_visible:
      assumes "u \<preceq>\<^sub>F\<^sub>I v"
      shows "lproject visible (llist_of u) \<le> lproject visible (llist_of_stream v)"
    proof -
      obtain w where 1: "w \<le>\<^sub>F\<^sub>I v" "u \<preceq>\<^sub>F w" using assms by rule
      have "lproject visible (llist_of u) \<le> lproject visible (llist_of w)"
        using le_fin_lproject_visible 1(2) by this
      also have "\<dots> \<le> lproject visible (llist_of_stream v)" using 1(1) by blast
      finally show ?thesis by this
    qed
    lemma le_inf_lproject_visible:
      assumes "u \<preceq>\<^sub>I v"
      shows "lproject visible (llist_of_stream u) \<le> lproject visible (llist_of_stream v)"
    proof (rule lproject_prefix_limit)
      fix w
      assume 1: "w \<le> llist_of_stream u" "lfinite w"
      have 2: "list_of w \<le>\<^sub>F\<^sub>I stream_of_llist (llist_of_stream u)" using 1 by blast
      have 3: "list_of w \<preceq>\<^sub>F\<^sub>I v" using assms 2 by auto
      have "lproject visible w = lproject visible (llist_of (list_of w))" using 1(2) by simp
      also have "\<dots> \<le> lproject visible (llist_of_stream v)" using le_fininf_lproject_visible 3 by this
      finally show "lproject visible w \<le> lproject visible (llist_of_stream v)" by this
    qed
    lemma eq_inf_lproject_visible:
      assumes "u =\<^sub>I v"
      shows "lproject visible (llist_of_stream u) = lproject visible (llist_of_stream v)"
      using le_inf_lproject_visible assms by (metis antisym eq_infE)

    lemma stutter_selection_lproject_visible:
      assumes "run u p"
      shows "stutter_selection (lift (liset visible (llist_of_stream u)))
        (llist_of_stream (smap int (p ## trace u p)))"
    proof
      show "0 \<in> lift (liset visible (llist_of_stream u))" by auto
    next
      fix k i
      assume 3: "enat (Suc k) < esize (lift (liset visible (llist_of_stream u)))"
      assume 4: "nth_least (lift (liset visible (llist_of_stream u))) k < i"
      assume 5: "i < nth_least (lift (liset visible (llist_of_stream u))) (Suc k)"
      have 6: "int ((p ## trace u p) !! nth_least (lift (liset visible (llist_of_stream u))) k) =
        int ((p ## trace u p) !! i)"
      proof (rule execute_inf_word_invisible)
        show "run u p" using assms by this
        show "nth_least (lift (liset visible (llist_of_stream u))) k \<le> i" using 4 by auto
      next
        fix j
        assume 6: "nth_least (lift (liset visible (llist_of_stream u))) k \<le> j"
        assume 7: "j < i"
        have 8: "Suc j \<notin> lift (liset visible (llist_of_stream u))"
        proof (rule nth_least_not_contains)
          show "enat (Suc k) < esize (lift (liset visible (llist_of_stream u)))" using 3 by this
          show "nth_least (lift (liset visible (llist_of_stream u))) k < Suc j" using 6 by auto
          show "Suc j < nth_least (lift (liset visible (llist_of_stream u))) (Suc k)" using 5 7 by simp
        qed
        have 9: "j \<notin> liset visible (llist_of_stream u)" using 8 by auto
        show "u !! j \<notin> visible" using 9 by auto
      qed
      show "llist_of_stream (smap int (p ## trace u p)) ?! i = llist_of_stream (smap int (p ## trace u p)) ?!
        nth_least (lift (liset visible (llist_of_stream u))) k"
        using 6 by (metis lnth_list_of_stream snth_smap)
    next
      fix i
      assume 1: "finite (lift (liset visible (llist_of_stream u)))"
      assume 3: "Max (lift (liset visible (llist_of_stream u))) < i"
      have 4: "int ((p ## trace u p) !! Max (lift (liset visible (llist_of_stream u)))) =
        int ((p ## trace u p) !! i)"
      proof (rule execute_inf_word_invisible)
        show "run u p" using assms by this
        show "Max (lift (liset visible (llist_of_stream u))) \<le> i" using 3 by auto
      next
        fix j
        assume 6: "Max (lift (liset visible (llist_of_stream u))) \<le> j"
        assume 7: "j < i"
        have 8: "Suc j \<notin> lift (liset visible (llist_of_stream u))"
        proof (rule ccontr)
          assume 9: "\<not> Suc j \<notin> lift (liset visible (llist_of_stream u))"
          have 10: "Suc j \<in> lift (liset visible (llist_of_stream u))" using 9 by simp
          have 11: "Suc j \<le> Max (lift (liset visible (llist_of_stream u)))" using Max_ge 1 10 by this
          show "False" using 6 11 by auto
        qed
        have 9: "j \<notin> liset visible (llist_of_stream u)" using 8 by auto
        show "u !! j \<notin> visible" using 9 by auto
      qed
      show "llist_of_stream (smap int (p ## trace u p)) ?! i = llist_of_stream (smap int (p ## trace u p)) ?!
        Max (lift (liset visible (llist_of_stream u)))" using 4 by (metis lnth_list_of_stream snth_smap)
    qed

    lemma execute_fin_visible:
      assumes "path u q" "path v q" "u \<preceq>\<^sub>F\<^sub>I w" "v \<preceq>\<^sub>F\<^sub>I w"
      assumes "project visible u = project visible v"
      shows "int (target u q) = int (target v q)"
    proof -
      obtain w' where 1: "u \<preceq>\<^sub>F w'" "v \<preceq>\<^sub>F w'" using subsume_fin assms(3, 4) by this
      obtain u' v' where 2: "u @ u' =\<^sub>F w'" "v @ v' =\<^sub>F w'" using 1 by blast
      have "u @ u' =\<^sub>F w'" using 2(1) by this
      also have "\<dots> =\<^sub>F v @ v'" using 2(2) by blast
      finally have 3: "u @ u' =\<^sub>F v @ v'" by this
      obtain s\<^sub>1 s\<^sub>2 s\<^sub>3 where 4: "u =\<^sub>F s\<^sub>1 @ s\<^sub>2" "v =\<^sub>F s\<^sub>1 @ s\<^sub>3" "Ind (set s\<^sub>2) (set s\<^sub>3)"
        using levi_lemma 3 by this
      have 5: "project visible (s\<^sub>1 @ s\<^sub>2) = project visible (s\<^sub>1 @ s\<^sub>3)"
        using eq_fin_lproject_visible assms(5) 4(1, 2) by auto
      have 6: "project visible s\<^sub>2 = project visible s\<^sub>3" using 5 by simp
      have 7: "set (project visible s\<^sub>2) = set (project visible s\<^sub>3)" using 6 by simp
      have 8: "set s\<^sub>2 \<inter> visible = set s\<^sub>3 \<inter> visible" using 7 by auto
      have 9: "set s\<^sub>2 \<subseteq> invisible \<or> set s\<^sub>3 \<subseteq> invisible" using independence_invisible 4(3) by auto
      have 10: "set s\<^sub>2 \<subseteq> invisible" "set s\<^sub>3 \<subseteq> invisible" using 8 9 by auto
      have 11: "path s\<^sub>2 (target s\<^sub>1 q)" using eq_fin_word 4(1) assms(1) by auto
      have 12: "path s\<^sub>3 (target s\<^sub>1 q)" using eq_fin_word 4(2) assms(2) by auto
      have "int (fold ex u q) = int (fold ex (s\<^sub>1 @ s\<^sub>2) q)" using eq_fin_execute assms(1) 4(1) by simp
      also have "\<dots> = int (fold ex s\<^sub>1 q)" using execute_fin_word_invisible 11 10(1) by simp
      also have "\<dots> = int (fold ex (s\<^sub>1 @ s\<^sub>3) q)" using execute_fin_word_invisible 12 10(2) by simp
      also have "\<dots> = int (fold ex v q)" using eq_fin_execute assms(2) 4(2) by simp
      finally show ?thesis by this
    qed
    lemma execute_inf_visible:
      assumes "run u q" "run v q" "u \<preceq>\<^sub>I w" "v \<preceq>\<^sub>I w"
      assumes "lproject visible (llist_of_stream u) = lproject visible (llist_of_stream v)"
      shows "snth (smap int (q ## trace u q)) \<approx> snth (smap int (q ## trace v q))"
    proof -
      have 1: "lnth (llist_of_stream (smap int (q ## trace u q))) \<approx>
        lnth (llist_of_stream (smap int (q ## trace v q)))"
      proof
        show "linfinite (llist_of_stream (smap int (q ## trace u q)))" by simp
        show "linfinite (llist_of_stream (smap int (q ## trace v q)))" by simp
        show "stutter_selection (lift (liset visible (llist_of_stream u))) (llist_of_stream (smap int (q ## trace u q)))"
          using stutter_selection_lproject_visible assms(1) by this
        show "stutter_selection (lift (liset visible (llist_of_stream v))) (llist_of_stream (smap int (q ## trace v q)))"
          using stutter_selection_lproject_visible assms(2) by this
        show "lselect (lift (liset visible (llist_of_stream u))) (llist_of_stream (smap int (q ## trace u q))) =
          lselect (lift (liset visible (llist_of_stream v))) (llist_of_stream (smap int (q ## trace v q)))"
        proof
          have "llength (lselect (lift (liset visible (llist_of_stream u)))
            (llist_of_stream (smap int (q ## trace u q)))) = eSuc (llength (lproject visible (llist_of_stream u)))"
            by (simp add: lselect_llength)
          also have "\<dots> = eSuc (llength (lproject visible (llist_of_stream v)))"
            unfolding assms(5) by rule
          also have "\<dots> = llength (lselect (lift (liset visible (llist_of_stream v)))
            (llist_of_stream (smap int (q ## trace v q))))" by (simp add: lselect_llength)
          finally show "llength (lselect (lift (liset visible (llist_of_stream u)))
            (llist_of_stream (smap int (q ## trace u q)))) = llength (lselect (lift (liset visible (llist_of_stream v)))
            (llist_of_stream (smap int (q ## trace v q))))" by this
        next
          fix i
          assume 1:
            "enat i < llength (lselect (lift (liset visible (llist_of_stream u)))
              (llist_of_stream (smap int (q ## trace u q))))"
            "enat i < llength (lselect (lift (liset visible (llist_of_stream v)))
              (llist_of_stream (smap int (q ## trace v q))))"
          have 2:
            "enat i \<le> llength (lproject visible (llist_of_stream u))"
            "enat i \<le> llength (lproject visible (llist_of_stream v))"
            using 1 by (simp add: lselect_llength)+
          define k where "k \<equiv> nth_least (lift (liset visible (llist_of_stream u))) i"
          define l where "l \<equiv> nth_least (lift (liset visible (llist_of_stream v))) i"
          have "lselect (lift (liset visible (llist_of_stream u))) (llist_of_stream (smap int (q ## trace u q))) ?! i =
            int ((q ## trace u q) !! nth_least (lift (liset visible (llist_of_stream u))) i)"
            by (metis 1(1) lnth_list_of_stream lselect_lnth snth_smap)
          also have "\<dots> = int ((q ## trace u q) !! k)" unfolding k_def by rule
          also have "\<dots> = int ((q ## trace v q) !! l)"
          unfolding sscan_scons_snth
          proof (rule execute_fin_visible)
            show "path (stake k u) q" using assms(1) by (metis run_shift_elim stake_sdrop)
            show "path (stake l v) q" using assms(2) by (metis run_shift_elim stake_sdrop)
            show "stake k u \<preceq>\<^sub>F\<^sub>I w" "stake l v \<preceq>\<^sub>F\<^sub>I w" using assms(3, 4) by auto
            have "project visible (stake k u) =
              list_of (lproject visible (llist_of (stake k u)))" by simp
            also have "\<dots> = list_of (lproject visible (ltake (enat k) (llist_of_stream u)))"
              by (metis length_stake llength_llist_of llist_of_inf_llist_prefix lprefix_ltake prefix_fininf_prefix)
            also have "\<dots> = list_of (ltake (enat i) (lproject visible (llist_of_stream u)))"
              unfolding k_def lproject_ltake[OF 2(1)] by rule
            also have "\<dots> = list_of (ltake (enat i) (lproject visible (llist_of_stream v)))"
              unfolding assms(5) by rule
            also have "\<dots> = list_of (lproject visible (ltake (enat l) (llist_of_stream v)))"
              unfolding l_def lproject_ltake[OF 2(2)] by rule
            also have "\<dots> = project visible (stake l v)"
              by (metis length_stake lfilter_llist_of list_of_llist_of llength_llist_of
                llist_of_inf_llist_prefix lprefix_ltake prefix_fininf_prefix)
            finally show "project visible (stake k u) = project visible (stake l v)" by this
          qed
          also have "\<dots> = int ((q ## trace v q) !! nth_least (lift (liset visible (llist_of_stream v))) i)"
            unfolding l_def by simp
          also have "\<dots> = lselect (lift (liset visible (llist_of_stream v)))
            (llist_of_stream (smap int (q ## trace v q))) ?! i"
            using 1 by (metis lnth_list_of_stream lselect_lnth snth_smap)
          finally show "lselect (lift (liset visible (llist_of_stream u)))
            (llist_of_stream (smap int (q ## trace u q))) ?! i = lselect (lift (liset visible (llist_of_stream v)))
            (llist_of_stream (smap int (q ## trace v q))) ?! i" by this
        qed
      qed
      show ?thesis using 1 by simp
    qed

  end

end


(*  Author: Tobias Nipkow, Dmitriy Traytel *)

section "Framework Instantiations using (Partial) Derivatives"

(*<*)
theory Deriv_Autos
imports
  Automaton
  "Regular-Sets.NDerivative"
  Deriv_PDeriv
begin
(*>*)

subsection \<open>Brzozowski Derivatives Modulo ACI\<close>

lemma ACI_norm_derivs_alt: "\<guillemotleft>derivs w r\<guillemotright> = fold (\<lambda>a r. \<guillemotleft>deriv a r\<guillemotright>) w \<guillemotleft>r\<guillemotright>"
  by (induct w arbitrary: r) (auto simp: ACI_norm_deriv)

global_interpretation brzozowski: rexp_DFA "\<lambda>r. \<guillemotleft>r\<guillemotright>" "\<lambda>a r. \<guillemotleft>deriv a r\<guillemotright>" nullable lang
  defines brzozowski_closure = brzozowski.closure
    and check_eqv_brz = brzozowski.check_eqv
    and reachable_brz = brzozowski.reachable
    and automaton_brz = brzozowski.automaton
    and match_brz = brzozowski.match
proof (unfold_locales, goal_cases)
  case 1 show ?case by (rule lang_ACI_norm)
next
  case 2 show ?case by (rule trans[OF lang_ACI_norm lang_deriv])
next
  case 3 show ?case by (rule nullable_iff)
next
  case 4 show ?case by (simp only: ACI_norm_derivs_alt[symmetric] finite_derivs)
qed

subsection \<open>Brzozowski Derivatives Modulo ACI Operating on the Quotient Type\<close>

lemma derivs_alt: "derivs = fold deriv"
proof
  fix w :: "'a list" show "derivs w = fold deriv w" by (induct w) auto
qed

functor map_rexp by (simp_all only: o_def id_def map_map_rexp map_rexp_ident)

quotient_type 'a ACI_rexp = "'a rexp" / ACI
  morphisms rep_ACI_rexp ACI_class
  by (intro equivpI reflpI sympI transpI) (blast intro: ACI_refl ACI_sym ACI_trans)+

instantiation ACI_rexp :: ("{equal, linorder}") "{equal, linorder}"
begin
lift_definition less_eq_ACI_rexp :: "'a ACI_rexp \<Rightarrow> 'a ACI_rexp \<Rightarrow> bool" is "\<lambda>r s. less_eq \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>"
   by (simp add: ACI_decidable)
lift_definition less_ACI_rexp :: "'a ACI_rexp \<Rightarrow> 'a ACI_rexp \<Rightarrow> bool" is "\<lambda>r s. less \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>"
   by (simp add: ACI_decidable)
lift_definition equal_ACI_rexp :: "'a ACI_rexp \<Rightarrow> 'a ACI_rexp \<Rightarrow> bool" is "\<lambda>r s. \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>"
   by (simp add: ACI_decidable)
instance by intro_classes (transfer, force simp: ACI_decidable)+
end

lift_definition ACI_deriv :: "'a :: linorder \<Rightarrow> 'a ACI_rexp \<Rightarrow> 'a ACI_rexp" is deriv
  by (rule ACI_deriv)
lift_definition ACI_nullable :: "'a :: linorder ACI_rexp \<Rightarrow> bool" is nullable
  by (rule ACI_nullable)
lift_definition ACI_lang :: "'a :: linorder ACI_rexp \<Rightarrow> 'a lang" is lang
  by (rule ACI_lang)

global_interpretation brzozowski_quotient: rexp_DFA ACI_class ACI_deriv ACI_nullable ACI_lang
  defines brzozowski_quotient_closure = brzozowski_quotient.closure
    and check_eqv_brzq = brzozowski_quotient.check_eqv
    and reachable_brzq = brzozowski_quotient.reachable
    and automaton_brzq = brzozowski_quotient.automaton
    and match_brzq = brzozowski_quotient.match
proof (unfold_locales, goal_cases)
  case 1 show ?case by transfer (rule refl)
next
  case 2 show ?case by transfer (rule lang_deriv)
next
  case 3 show ?case by transfer (rule nullable_iff)
next
  case 4 show ?case by transfer
    (auto simp: ACI_decidable derivs_alt intro!: finite_subset[OF _ finite_derivs])
qed

subsection \<open>Brzozowski Derivatives Modulo ACI++ (Only Soundness)\<close>

global_interpretation nderiv: rexp_DA "\<lambda>x. norm x" nderiv nullable lang
  defines nderiv_closure = nderiv.closure
    and check_eqv_n = nderiv.check_eqv
    and reachable_n = nderiv.reachable
    and automaton_n = nderiv.automaton
    and match_n = nderiv.match
proof (unfold_locales, goal_cases)
  case 1 show ?case by simp
next
  case 2 show ?case by (rule lang_nderiv)
next
  case 3 show ?case by (rule nullable_iff)
qed

subsection \<open>Partial Derivatives\<close>

global_interpretation pderiv: rexp_DFA "\<lambda>r. {r}" pderiv_set "\<lambda>P. \<exists>p\<in>P. nullable p" "\<lambda>P. \<Union>(lang ` P)"
  defines pderiv_closure = pderiv.closure
    and check_eqv_p = pderiv.check_eqv
    and reachable_p = pderiv.reachable
    and automaton_p = pderiv.automaton
    and match_p = pderiv.match
proof (unfold_locales, goal_cases)
  case 1 show ?case by simp
next
  case 2 show ?case by (simp add: Deriv_pderiv)
next
  case 3 show ?case by (simp add: nullable_iff)
next
  case (4 s) note pderivs_lang_def[simp]
  { fix w :: "'a list"
    have "fold pderiv_set w = Union o image (pderivs_lang {w})" by (induct w) auto
  }
  hence "{fold pderiv_set w {s} |w. True} \<subseteq> Pow (pderivs_lang UNIV s)" by auto
  then show ?case by (rule finite_subset) (auto simp only: finite_pderivs_lang)
qed

global_interpretation pnderiv: rexp_DFA "\<lambda>r. r" pnderiv nullable lang
  defines pnderiv_closure = pnderiv.closure
    and check_eqv_pn = pnderiv.check_eqv
    and reachable_pn = pnderiv.reachable
    and automaton_pn = pnderiv.automaton
    and match_pn = pnderiv.match
proof (unfold_locales, goal_cases)
  case 1 show ?case by simp
next
  case 2 show ?case by (simp add: pnorm_def pset_deriv Deriv_pderiv pnderiv_alt)
next
  case 3 show ?case by (simp add: nullable_iff)
next
  case (4 s)
  then show ?case unfolding pnderiv_alt[abs_def]
    by (rule finite_surj[OF pderiv.fin, of _ "flatten PLUS" s]) (auto simp: fold_pnorm_deriv)
qed

subsection \<open>Languages as States\<close>

text \<open>Not executable but still instructive.\<close>

lemma Derivs_alt_def: "Derivs w L = fold Deriv w L"
  by (induct w arbitrary: L) simp_all

interpretation language: rexp_DFA lang Deriv "\<lambda>L. [] \<in> L" id
proof (unfold_locales, goal_cases)
  case (4 s)
  have "{fold Deriv w (lang s) |w. True} \<subseteq> (\<lambda>X. \<Union>(lang ` X)) ` Pow (pderivs_lang UNIV s)"
    by (auto simp: sym[OF Derivs_alt_def] Derivs_pderivs pderivs_lang_def)
  then show ?case by (rule finite_surj[OF iffD2[OF finite_Pow_iff finite_pderivs_lang_UNIV]])
qed simp_all

definition str_eq :: "'a lang => ('a list \<times> 'a list) set" ("\<approx>_" [100] 100)
where "\<approx>A \<equiv> {(x, y).  (\<forall>z. x @ z \<in> A \<longleftrightarrow> y @ z \<in> A)}"

lemma str_eq_alt: "\<approx>A = {(x, y). fold Deriv x A = fold Deriv y A}"
  unfolding str_eq_def set_eq_iff in_fold_Deriv by simp

lemma Myhill_Nerode2: "finite (UNIV // \<approx>lang r)"
  unfolding str_eq_alt quotient_def Image_def
  by (rule finite_surj[OF language.fin, of _ "\<lambda>X. {y. X = fold Deriv y (lang r)}" r]) auto

(*<*)
end
(*>*)


theory Check_Connected_Verification
imports Vcg Check_Connected_Impl
begin

definition no_loops :: "('a, 'b) pre_digraph \<Rightarrow> bool" where
  "no_loops G \<equiv> \<forall>e \<in> arcs G. tail G e \<noteq> head G e"

definition abs_IGraph :: "IGraph \<Rightarrow> (nat, nat) pre_digraph" where
  "abs_IGraph G \<equiv> \<lparr> verts = {0..<ivertex_cnt G}, arcs = {0..<iedge_cnt G},
    tail = fst o iedges G, head = snd o iedges G \<rparr>"

lemma verts_absI[simp]: "verts (abs_IGraph G) = {0..<ivertex_cnt G}"
  and arcs_absI[simp]: "arcs (abs_IGraph G) = {0..<iedge_cnt G}"
  and tail_absI[simp]: "tail (abs_IGraph G) e = fst (iedges G e)"
  and head_absI[simp]: "head (abs_IGraph G) e = snd (iedges G e)"
  by (auto simp: abs_IGraph_def)

lemma is_wellformed_inv_step:
  "is_wellformed_inv G (Suc i) \<longleftrightarrow> is_wellformed_inv G i
      \<and> fst (iedges G i) < ivertex_cnt G \<and> snd (iedges G i) < ivertex_cnt G"
  by (auto simp add: is_wellformed_inv_def less_Suc_eq)

lemma (in is_wellformed_impl) is_wellformed_spec:
  "\<forall>G. \<Gamma> \<turnstile>\<^sub>t \<lbrace>\<acute>G = G\<rbrace> \<acute>R :== PROC is_wellformed(\<acute>G) \<lbrace>\<acute>R = is_wellformed_inv G (iedge_cnt G)\<rbrace>"
  apply vcg
  apply (auto simp: is_wellformed_inv_step)
  apply (auto simp: is_wellformed_inv_def)
  done

lemma parent_num_assms_inv_step:
  "parent_num_assms_inv G r p n (Suc i) \<longleftrightarrow> parent_num_assms_inv G r p n i
    \<and> (i \<noteq> r \<longrightarrow> (case p i of
      None \<Rightarrow> False
    | Some x \<Rightarrow> x < iedge_cnt G \<and> snd (iedges G x) = i \<and> n i = n (fst (iedges G x)) + 1))"
  by (auto simp: parent_num_assms_inv_def less_Suc_eq)

lemma (in parent_num_assms_impl) parent_num_assms_spec:
  "\<forall>G r p n. \<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>r = r \<and> \<acute>parent_edge = p \<and> \<acute>num = n\<rbrace>
    \<acute>R :== PROC parent_num_assms(\<acute>G, \<acute>r, \<acute>parent_edge, \<acute>num)
    \<lbrace> \<acute>R = parent_num_assms_inv G r p n (ivertex_cnt G)\<rbrace>"
  apply vcg
  apply (simp_all add: parent_num_assms_inv_step)
  apply (auto simp: parent_num_assms_inv_def)
  done

lemma connected_components_locale_eq_invariants:
"\<And>G r p n.
  connected_components_locale (abs_IGraph G) n p r =
    (is_wellformed_inv G (iedge_cnt G) \<and>
    r < ivertex_cnt G \<and> n r = 0 \<and> p r = None \<and>
    parent_num_assms_inv G r p n (ivertex_cnt G))"
proof -
  fix G r p n
  let ?aG = "abs_IGraph G"
  have "is_wellformed_inv G (iedge_cnt G) = fin_digraph ?aG"
    unfolding is_wellformed_inv_def fin_digraph_def fin_digraph_axioms_def
      wf_digraph_def
      by auto
moreover
  have "(\<forall>v \<in> verts ?aG. v \<noteq> r \<longrightarrow>
    (\<exists>e \<in> arcs ?aG. p v = Some e \<and>
    head ?aG e = v \<and>
    n v =  n (tail ?aG e) + 1))
    = parent_num_assms_inv G r p n (ivertex_cnt G)"
  proof -
    { fix i assume "(case p i of None \<Rightarrow> False
        | Some x \<Rightarrow> x < iedge_cnt G \<and> snd (iedges G x) = i \<and> n i = n (fst (iedges G x)) + 1)"
      then have "\<exists>x\<in>{0..<iedge_cnt G}. p i = Some x \<and> snd (iedges G x) = i \<and> n i = n (fst (iedges G x)) + 1"
      by (case_tac "p i") auto }
    then show ?thesis
      by (auto simp: parent_num_assms_inv_def)
  qed
ultimately
show  "?thesis G r p n"
  unfolding connected_components_locale_def
  connected_components_locale_axioms_def by auto
qed

theorem (in check_connected_impl) check_connected_eq_locale:
  "\<forall>G r p n. \<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>r = r \<and> \<acute>parent_edge = p \<and> \<acute>num = n \<rbrace>
    \<acute>R :== PROC check_connected (\<acute>G, \<acute>r, \<acute>parent_edge, \<acute>num)
    \<lbrace> \<acute>R = connected_components_locale (abs_IGraph G) n p r\<rbrace>"
by vcg (auto simp: connected_components_locale_eq_invariants)

lemma connected_components_locale_imp_correct:
  assumes "connected_components_locale (abs_IGraph G)n p r"
  assumes "u \<in> pverts (mk_symmetric (abs_IGraph G))"
  assumes "v \<in> pverts (mk_symmetric (abs_IGraph G))"
  shows "\<exists>p. pre_digraph.apath (mk_symmetric (abs_IGraph G)) u p v"
proof -
  interpret S: pair_wf_digraph "mk_symmetric (abs_IGraph G)"
    by (intro wf_digraph.wellformed_mk_symmetric
        connected_components_locale.ccl_wellformed[OF assms(1)])
  show ?thesis
    using connected_components_locale.connected_by_path[OF assms]
    by (simp only: S.reachable_apath)
qed

theorem (in check_connected_impl) check_connected_spec:
  "\<And>G r p n. \<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>r = r \<and> \<acute>parent_edge = p \<and> \<acute>num = n \<rbrace>
    \<acute>R :== PROC check_connected(\<acute>G, \<acute>r, \<acute>parent_edge, \<acute>num)
    \<lbrace> \<acute>R \<longrightarrow>
        (\<forall>u \<in> pverts (mk_symmetric (abs_IGraph G)).
          \<forall>v \<in> pverts (mk_symmetric (abs_IGraph G)).
          \<exists>p. pre_digraph.apath (mk_symmetric (abs_IGraph G)) u p v)\<rbrace>"
using connected_components_locale_eq_invariants
      connected_components_locale_imp_correct
by vcg metis

end


\<^marker>\<open>creator Florian Keßler\<close>

section "IMP-- to SAS++ State Translations"

theory IMP_Minus_Minus_To_SAS_Plus_Plus_State_Translations
  imports SAS_Plus_Plus IMP_Minus_Minus_Small_StepT
begin

text \<open> We define a translation between IMP-- states and SAS++ states. For this purpose, it is useful
      to think of IMP-- states as not only a map from registers to bits, but rather a pair of a
      computation and such a map. The translated SAS++ states is a map assigning the computation
      to the special variable PC, and otherwise mapping register names to the bit values they
      had in the original IMP-- state. \<close>

datatype domain_element = EV bit | PCV com

datatype variable = VN vname | PC

type_synonym sas_state = "(variable, domain_element) State_Variable_Representation.state"
type_synonym imp_state = state

definition imp_minus_state_to_sas_plus :: "(com \<times> imp_state) \<Rightarrow> sas_state" where
"imp_minus_state_to_sas_plus ci = ((\<lambda>x. Some (EV x)) \<circ>\<^sub>m (snd ci)
  \<circ>\<^sub>m (\<lambda>x. (case x of VN v \<Rightarrow> Some v)))
  (PC \<mapsto> PCV (fst ci))"

definition sas_plus_state_to_imp_minus:: "sas_state \<Rightarrow> (com \<times> imp_state)" where
"sas_plus_state_to_imp_minus ss = ((case (the (ss PC)) of (PCV c) \<Rightarrow> c),
  (\<lambda>x. (case x of EV y \<Rightarrow> Some y | _ \<Rightarrow> None)) \<circ>\<^sub>m ss \<circ>\<^sub>m (\<lambda>x. Some (VN x)))"

definition sane_sas_plus_state:: "sas_state \<Rightarrow> bool" where
"sane_sas_plus_state ss \<equiv> (\<exists>x. ss PC = Some (PCV x)) \<and>
  (\<forall>v. VN v \<in> dom ss \<longrightarrow> (\<exists>x. ss (VN v) = Some (EV x)))"

lemma sas_plus_state_to_imp_minus_imp_minus_state_to_sas_plus[simp]:
  "sas_plus_state_to_imp_minus (imp_minus_state_to_sas_plus (c, is)) = (c, is)"
proof -
  have "(snd (sas_plus_state_to_imp_minus (imp_minus_state_to_sas_plus (c, is)))) x = is x" for x
    by (auto simp: imp_minus_state_to_sas_plus_def sas_plus_state_to_imp_minus_def
        map_comp_def option.case_eq_if)
  then show ?thesis
    by (auto simp: imp_minus_state_to_sas_plus_def sas_plus_state_to_imp_minus_def)
qed

lemma imp_minus_state_to_sas_plus_sas_plus_state_to_imp_minus[simp]:
  assumes "sane_sas_plus_state ss "
  shows "imp_minus_state_to_sas_plus (sas_plus_state_to_imp_minus ss) = ss"
proof -
  have "(imp_minus_state_to_sas_plus (sas_plus_state_to_imp_minus ss)) x = ss x" for x using assms
    by (fastforce simp: imp_minus_state_to_sas_plus_def sas_plus_state_to_imp_minus_def
        sane_sas_plus_state_def option.case_eq_if map_comp_def split: variable.splits)
  then show ?thesis by (auto simp: imp_minus_state_to_sas_plus_def sas_plus_state_to_imp_minus_def)
qed

lemma imp_minus_state_to_sas_plus_of_same_c_eq_iff[simp]:
  "(imp_minus_state_to_sas_plus (c, s1) = imp_minus_state_to_sas_plus (c, s2))
  \<longleftrightarrow> s1 = s2"
proof
  assume a: "imp_minus_state_to_sas_plus (c, s1) = imp_minus_state_to_sas_plus (c, s2)"
  have "\<forall>v. (s1 v = s2 v)"
  proof (rule ccontr)
    assume "\<not> (\<forall>v. s1 v = s2 v)"
    then obtain v where "s1 v \<noteq> s2 v" by blast
    then have "imp_minus_state_to_sas_plus (c, s1) (VN v) \<noteq> imp_minus_state_to_sas_plus (c, s2) (VN v)"
      by (auto simp: imp_minus_state_to_sas_plus_def map_comp_def domD domIff split: option.splits)
    then show "False" using a by simp
  qed
  then show "s1 = s2" by auto
qed auto

lemma snd_sas_plus_state_to_imp_minus_updated[simp]:
  "snd (sas_plus_state_to_imp_minus
                (imp_minus_state_to_sas_plus (c, is)(VN x \<mapsto> y)))
    = is(x := (case y of EV y' \<Rightarrow> Some y' | _ \<Rightarrow> None))"
  by (auto simp: imp_minus_state_to_sas_plus_def sas_plus_state_to_imp_minus_def
       Let_def map_comp_def option.case_eq_if)

lemma imp_minus_state_to_sas_plus_PC[simp]:
  "(imp_minus_state_to_sas_plus (c1, is)) PC = Some (PCV c1)"
  by (simp add: imp_minus_state_to_sas_plus_def)

lemma imp_minus_state_to_sas_plus_VN_Some_iff[simp]:
  "(imp_minus_state_to_sas_plus (c, is) (VN x) = Some (EV y))
  \<longleftrightarrow> (is x = Some y)"
  by(auto simp: imp_minus_state_to_sas_plus_def map_comp_Some_iff)

lemma imp_minus_state_to_sas_plus_eq_Some_non_zero_iff[simp]:
  "imp_minus_state_to_sas_plus (c, is) (VN x) = Some y \<Longrightarrow>
       (y \<noteq> EV (Num 0)) \<longleftrightarrow> (is x \<noteq> Some (Num 0))"
  by(auto simp: imp_minus_state_to_sas_plus_def map_comp_Some_iff)

lemma imp_minus_state_to_sas_plus_map_le_then: "imp_minus_state_to_sas_plus (c, I) \<subseteq>\<^sub>m I'
  \<Longrightarrow> I \<subseteq>\<^sub>m snd (sas_plus_state_to_imp_minus I')"
  apply(auto simp: imp_minus_state_to_sas_plus_def sas_plus_state_to_imp_minus_def)
   apply(simp add: map_le_def map_comp_def)
   apply(auto split: option.splits domain_element.splits)
     apply (metis domIff option.distinct option.simps variable.simps)
   apply (metis domI domain_element.inject option.inject option.simps variable.distinct variable.simps)
  by (metis (mono_tags, lifting) domI domain_element.distinct option.inject option.simps
      variable.distinct variable.simps)

lemma map_of_map_VN_EV: "map_of (map (\<lambda>v. (VN v, EV y)) vs) (VN a) =
  map_option EV (map_of (map (\<lambda>v. (v, y)) vs) a)"
  apply(induction vs) by auto

lemma map_leq_imp_minus_state_to_sas_plus_iff:
  "map_of (map (\<lambda>v. (VN v, EV y)) vs)(PC \<mapsto> PCV c) \<subseteq>\<^sub>m imp_minus_state_to_sas_plus (c, is)
  \<longleftrightarrow> map_of (map (\<lambda>v. (v, y)) vs) \<subseteq>\<^sub>m is"
  by(auto simp: imp_minus_state_to_sas_plus_def map_le_def map_comp_def map_of_SomeD
      dom_map_of_conv_image_fst map_of_map_VN_EV split: option.splits)

lemma dom_snd_sas_plus_state_to_imp_minus:  "sane_sas_plus_state ss
  \<Longrightarrow> dom (snd (sas_plus_state_to_imp_minus ss))
  = { v |v. VN v \<in> dom ss }"
  by(fastforce simp: sane_sas_plus_state_def sas_plus_state_to_imp_minus_def map_comp_Some_iff
      split: option.splits)

end


theory  Refinement

imports
  ARMv7A_Flush_Ref

begin

datatype mem_op_typ = translate     vaddr
                | memread       "vaddr \<times> nat"
                | memwrite      "bool list \<times> vaddr \<times> nat"

datatype mmu_op_typ = root_update  paddr
                    | asid_update  asid
                    | flush_addr        flush_type

datatype res_typ = PA paddr
                 | BL "bool list"
                 | UT unit

fun
  mem_op :: "mem_op_typ \<Rightarrow> 'a::mmu state_scheme \<Rightarrow> _"
  where
  "mem_op (translate va) s             = (PA (fst (mmu_translate va s)),            snd (mmu_translate va s))"
| "mem_op (memread (va, sz)) s         = (BL (fst (mmu_read_size (va, sz) s)),      snd (mmu_read_size (va, sz) s))"
| "mem_op (memwrite (bl, va, sz)) s    = (UT (fst (mmu_write_size (bl, va, sz) s)), snd (mmu_write_size (bl, va, sz) s))"

fun
  mmu_op :: "mmu_op_typ \<Rightarrow> 'a::mmu state_scheme \<Rightarrow> _"
  where
  "mmu_op (root_update rt) s    = update_TTBR0 rt s"
| "mmu_op (asid_update a) s     = update_ASID a s"
| "mmu_op (flush_addr f) s      = flush f s"

fun
  consistent_sat :: "mem_op_typ \<Rightarrow> 'a::mmu sat_tlb_state_scheme \<Rightarrow> bool"
where
  "consistent_sat (translate va) s             =  consistent ( typ_sat_tlb s) va"
| "consistent_sat (memread (va, sz)) s         =  consistent ( typ_sat_tlb s) va"
| "consistent_sat (memwrite (bl, va, sz)) s    =  consistent ( typ_sat_tlb s) va"

lemma  addr_trans_sat:
  "\<lbrakk> mmu_translate va s = (pa, s');  mmu_translate va t = (pa', t');
consistent (typ_sat_tlb t) va; tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t)  \<rbrakk> \<Longrightarrow>
      pa' = pa \<and> tlb_rel_sat (typ_non_det_tlb s') (typ_sat_tlb t')"
  using mmu_translate_non_det_sat_refine [simplified split_def Let_def, rotated 2]  by force

lemma read_trans_sat:
  "\<lbrakk>mmu_read_size (va, sz) s = (val, s');  mmu_read_size (va, sz) t = (val', t'); consistent (typ_sat_tlb t) va;
              tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t)\<rbrakk> \<Longrightarrow>
                     val' = val \<and> tlb_rel_sat (typ_non_det_tlb s') (typ_sat_tlb t') "
  using mmu_read_non_det_sat_refine by blast

lemma mem_refine_sat:
    "\<lbrakk> mem_op f s = (res, s') ; mem_op f t = (res', t');
          consistent_sat f t ; tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t) \<rbrakk> \<Longrightarrow>
                 res' = res \<and> tlb_rel_sat (typ_non_det_tlb s') (typ_sat_tlb t')"
  apply (cases f; clarsimp)
    apply (rename_tac va)
    apply (rule_tac va = va and s = s and t = t in  addr_trans_sat; clarsimp?)
   apply (rename_tac va sz)
   apply (rule_tac read_trans_sat; force?)
  apply (rename_tac bl va sz)
  apply (rule_tac val = bl and va = va and sz = sz and s = s and t = t in mmu_write_non_det_sat_refine; force?)
   apply (metis eq_snd_iff old.unit.exhaust)
  by (metis eq_snd_iff old.unit.exhaust)

lemma mmu_refine_sat:
    "\<lbrakk> mmu_op f s = ((), s') ; mmu_op f t = ((), t');
           tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t) \<rbrakk> \<Longrightarrow>
               tlb_rel_sat (typ_non_det_tlb s') (typ_sat_tlb t')"
  apply (cases f; clarsimp)
     apply (rename_tac rt)
     apply (rule_tac r = rt and s = s and t= t in update_root_non_det_sat_refine;  clarsimp simp: eq_snd_iff)
    apply (rename_tac a)
    apply (rule_tac a = a and s = s and t= t in update_asid_non_det_sat_refine;  clarsimp simp: eq_snd_iff)
   apply (rename_tac ft)
  by (rule_tac f = ft and s = s and t= t in flush_det_sat_refine;  clarsimp simp: eq_snd_iff)

fun
  consistent_set :: "mem_op_typ \<Rightarrow> _"
where
  "consistent_set (translate va) s             =  (va \<notin> iset(set_tlb s))"
| "consistent_set (memread (va, sz)) s         =  (va \<notin> iset(set_tlb s))"
| "consistent_set (memwrite (bl, va, sz)) s    =  (va \<notin> iset(set_tlb s))"

lemma  addr_trans_set:
  "\<lbrakk> mmu_translate va s = (pa, s');  mmu_translate va t = (pa', t');
    va \<notin> iset(set_tlb t); tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t)  \<rbrakk> \<Longrightarrow>
      pa' = pa \<and> tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t')"
  using mmu_translate_sat_incon_refine [simplified split_def Let_def, rotated 2]  apply auto by blast+

lemma read_trans_set:
  "\<lbrakk>mmu_read_size (va, sz) s = (val, s');  mmu_read_size (va, sz) t = (val', t'); va \<notin> iset(set_tlb t);
              tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t)\<rbrakk> \<Longrightarrow>
                     val' = val \<and> tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t') "
  using mmu_read_sat_incon_refine by blast

lemma mem_refine_set:
    "\<lbrakk> mem_op f s = (res, s') ; mem_op f t = (res', t');
          consistent_set f t ; tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                 res' = res \<and> tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t')"
  apply (cases f; clarsimp)
    apply (rename_tac va)
    apply (rule_tac va = va and s = s and t = t in  addr_trans_set; clarsimp?)
   apply (rename_tac va sz)
   apply (rule_tac read_trans_set; force?)
  apply (rename_tac bl va sz)
  apply (rule_tac val = bl and va = va and sz = sz and s = s and t = t in mmu_write_sat_incon_refine; force?)
   apply (metis eq_snd_iff old.unit.exhaust)
  by (metis eq_snd_iff old.unit.exhaust)

lemma mmu_refine_set:
    "\<lbrakk> mmu_op f s = ((), s') ; mmu_op f t = ((), t');
           tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
               tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t')"
  apply (cases f; clarsimp)
     apply (rename_tac rt)
     apply (rule_tac r = rt and s = s and t= t in update_root_sat_incon_refine;  clarsimp simp: eq_snd_iff)
    apply (rename_tac a)
    apply (rule_tac a = a and s = s and t= t in update_asid_sat_incon_refine;  clarsimp simp: eq_snd_iff)
   apply (rename_tac ft)
  by (rule_tac f = ft and s = s and t= t in flush_sat_incon_refine;  clarsimp simp: eq_snd_iff)

definition
  tlb_rel :: "_"
where
  "tlb_rel r t \<equiv> \<exists>(s:: unit sat_tlb_state_scheme).
                    tlb_rel_sat r (typ_sat_tlb s) \<and>
                           tlb_rel_abs (typ_sat_tlb s) t"

lemmas  abc =  mmu_translate_non_det_sat_refine [simplified split_def Let_def, rotated 2]

lemma address_refinement:
  "\<lbrakk> mmu_translate va r = (pa, r');  mmu_translate va t = (pa', t') ;
           va \<notin> iset(set_tlb t) ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                               pa = pa' \<and>   tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s and pa = "fst(mmu_translate va s)" and s' = "snd(mmu_translate va s)" in
      mmu_translate_sat_incon_refine [rotated]; clarsimp?)
  apply (frule_tac va = va and pa =  "fst(mmu_translate va r)" and s' = "snd(mmu_translate va r)"in  abc; clarsimp?)
  using tlb_rel_abs_consistent apply force
  by force

lemma read_refinement:
  "\<lbrakk> mmu_read_size (va, sz) r = (val, r');  mmu_read_size (va, sz) t = (val', t');
           va \<notin> iset(set_tlb t) ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                               val = val' \<and>  tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s and val = "fst(mmu_read_size (va, sz) s)" and s' = "snd(mmu_read_size (va, sz) s)" in
      mmu_read_sat_incon_refine [rotated]; clarsimp?)
  apply (frule_tac va = va and sz= sz and val =  "fst(mmu_read_size (va, sz)r)" and s' = "snd(mmu_read_size (va, sz) r)" and
      val' =  "fst(mmu_read_size (va, sz)s)"  and t' = "snd(mmu_read_size (va, sz) s)" in  mmu_read_non_det_sat_refine [rotated 2]; clarsimp?)
  using tlb_rel_abs_consistent apply force
  using  tlb_rel_sat_consistent by fastforce

lemma write_refinement:
  "\<lbrakk> mmu_write_size (val,va, sz) r = ((), r');  mmu_write_size (val,va, sz)  t = ((), t');
            va \<notin> iset(set_tlb t) ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                              tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s and s' = "snd(mmu_write_size (val,va, sz) s)" in
      mmu_write_sat_incon_refine [rotated]; clarsimp?)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (frule_tac va = va and sz= sz  and s' = "snd(mmu_write_size (val,va, sz)  r)" and t' = "snd(mmu_write_size (val,va, sz)  s)" and val = val in
      mmu_write_non_det_sat_refine [rotated]; clarsimp?)
  using tlb_rel_abs_consistent apply force
    apply (metis eq_snd_iff old.unit.exhaust)
  by (metis eq_snd_iff old.unit.exhaust)

lemma mem_refine:
    "\<lbrakk> mem_op f r = (res, r') ; mem_op f t = (res', t');
          consistent_set f t ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                 res = res' \<and> tlb_rel (typ_non_det_tlb r') (typ_set_tlb t')"
  apply (cases f; clarsimp)
    apply (rename_tac va)
    apply (rule_tac  va = va and  r = r and t = t in address_refinement; force?)
   apply (rename_tac va sz)
   apply (rule_tac read_refinement; force?)
  apply (rename_tac bl va sz)
  apply (rule_tac val = bl and va = va and sz = sz and r = r and t = t in write_refinement; force?)
   apply (metis eq_snd_iff old.unit.exhaust)
  by (metis eq_snd_iff old.unit.exhaust)

lemma root_refinement:
  "\<lbrakk> update_TTBR0 rt r = ((), r');  update_TTBR0 rt t = ((), t') ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                               tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s  and s' = "snd (update_TTBR0 rt s)"  in update_root_sat_incon_refine [rotated]; clarsimp?)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (frule_tac  r = rt and s' ="snd ( update_TTBR0 rt r) " and t' = "snd (update_TTBR0 rt s)" in update_root_non_det_sat_refine [rotated 2]; clarsimp?)
    apply (metis eq_snd_iff old.unit.exhaust)
  by (metis eq_snd_iff old.unit.exhaust)

lemma asid_refinement:
  "\<lbrakk> update_ASID a r = ((), r');  update_ASID a t = ((), t') ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                               tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s  and s' = "snd (update_ASID a s)"  in update_asid_sat_incon_refine [rotated]; clarsimp?)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (frule_tac  a = a and s' ="snd ( update_ASID a r) " and t' = "snd (update_ASID a s)" in update_asid_non_det_sat_refine [rotated 2]; clarsimp?)
    apply (metis eq_snd_iff old.unit.exhaust)
   by (metis eq_snd_iff old.unit.exhaust)

lemma flush_refinement:
  "\<lbrakk> flush f r = ((), r');  flush f t = ((), t') ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                               tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s  and s' = "snd (flush f s)"  in flush_sat_incon_refine [rotated]; clarsimp?)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (frule_tac f= f and s' ="snd ( flush f r) " and t' = "snd (flush f s)" in flush_det_sat_refine [rotated 2]; clarsimp?)
    apply (metis eq_snd_iff old.unit.exhaust)
  by (metis eq_snd_iff old.unit.exhaust)

lemma mmu_refine:
    "\<lbrakk> mmu_op f r = ((), r') ; mmu_op f t = ((), t');
         tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel (typ_non_det_tlb r') (typ_set_tlb t')"
  apply (cases f; clarsimp)
     apply (rename_tac rt)
     apply (rule_tac  rt = rt and  r = r and t = t in root_refinement; force?)
    apply (simp add: asid_refinement)
  using flush_refinement by blast

end


(* Author: Tobias Nipkow *)

theory ACom
imports Com
begin

subsection "Annotated Commands"

datatype 'a acom =
  SKIP 'a                           ("SKIP {_}" 61) |
  Assign vname aexp 'a              ("(_ ::= _/ {_})" [1000, 61, 0] 61) |
  Seq "('a acom)" "('a acom)"       ("_;;//_"  [60, 61] 60) |
  If bexp 'a "('a acom)" 'a "('a acom)" 'a
    ("(IF _/ THEN ({_}/ _)/ ELSE ({_}/ _)//{_})"  [0, 0, 0, 61, 0, 0] 61) |
  While 'a bexp 'a "('a acom)" 'a
    ("({_}//WHILE _//DO ({_}//_)//{_})"  [0, 0, 0, 61, 0] 61)

notation com.SKIP ("SKIP")

text_raw{*\snip{stripdef}{1}{1}{% *}
fun strip :: "'a acom \<Rightarrow> com" where
"strip (SKIP {P}) = SKIP" |
"strip (x ::= e {P}) = x ::= e" |
"strip (C\<^sub>1;;C\<^sub>2) = strip C\<^sub>1;; strip C\<^sub>2" |
"strip (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {P}) =
  IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2" |
"strip ({I} WHILE b DO {P} C {Q}) = WHILE b DO strip C"
text_raw{*}%endsnip*}

text_raw{*\snip{asizedef}{1}{1}{% *}
fun asize :: "com \<Rightarrow> nat" where
"asize SKIP = 1" |
"asize (x ::= e) = 1" |
"asize (C\<^sub>1;;C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2" |
"asize (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2 + 3" |
"asize (WHILE b DO C) = asize C + 3"
text_raw{*}%endsnip*}

text_raw{*\snip{annotatedef}{1}{1}{% *}
definition shift :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
"shift f n = (\<lambda>p. f(p+n))"

fun annotate :: "(nat \<Rightarrow> 'a) \<Rightarrow> com \<Rightarrow> 'a acom" where
"annotate f SKIP = SKIP {f 0}" |
"annotate f (x ::= e) = x ::= e {f 0}" |
"annotate f (c\<^sub>1;;c\<^sub>2) = annotate f c\<^sub>1;; annotate (shift f (asize c\<^sub>1)) c\<^sub>2" |
"annotate f (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  IF b THEN {f 0} annotate (shift f 1) c\<^sub>1
  ELSE {f(asize c\<^sub>1 + 1)} annotate (shift f (asize c\<^sub>1 + 2)) c\<^sub>2
  {f(asize c\<^sub>1 + asize c\<^sub>2 + 2)}" |
"annotate f (WHILE b DO c) =
  {f 0} WHILE b DO {f 1} annotate (shift f 2) c {f(asize c + 2)}"
text_raw{*}%endsnip*}

text_raw{*\snip{annosdef}{1}{1}{% *}
fun annos :: "'a acom \<Rightarrow> 'a list" where
"annos (SKIP {P}) = [P]" |
"annos (x ::= e {P}) = [P]" |
"annos (C\<^sub>1;;C\<^sub>2) = annos C\<^sub>1 @ annos C\<^sub>2" |
"annos (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
  P\<^sub>1 # annos C\<^sub>1 @  P\<^sub>2 # annos C\<^sub>2 @ [Q]" |
"annos ({I} WHILE b DO {P} C {Q}) = I # P # annos C @ [Q]"
text_raw{*}%endsnip*}

definition anno :: "'a acom \<Rightarrow> nat \<Rightarrow> 'a" where
"anno C p = annos C ! p"

definition post :: "'a acom \<Rightarrow>'a" where
"post C = last(annos C)"

text_raw{*\snip{mapacomdef}{1}{2}{% *}
fun map_acom :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a acom \<Rightarrow> 'b acom" where
"map_acom f (SKIP {P}) = SKIP {f P}" |
"map_acom f (x ::= e {P}) = x ::= e {f P}" |
"map_acom f (C\<^sub>1;;C\<^sub>2) = map_acom f C\<^sub>1;; map_acom f C\<^sub>2" |
"map_acom f (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
  IF b THEN {f P\<^sub>1} map_acom f C\<^sub>1 ELSE {f P\<^sub>2} map_acom f C\<^sub>2
  {f Q}" |
"map_acom f ({I} WHILE b DO {P} C {Q}) =
  {f I} WHILE b DO {f P} map_acom f C {f Q}"
text_raw{*}%endsnip*}

lemma annos_ne: "annos C \<noteq> []"
by(induction C) auto

lemma strip_annotate[simp]: "strip(annotate f c) = c"
by(induction c arbitrary: f) auto

lemma length_annos_annotate[simp]: "length (annos (annotate f c)) = asize c"
by(induction c arbitrary: f) auto

lemma size_annos: "size(annos C) = asize(strip C)"
by(induction C)(auto)

lemma size_annos_same: "strip C1 = strip C2 \<Longrightarrow> size(annos C1) = size(annos C2)"
apply(induct C2 arbitrary: C1)
apply(case_tac C1, simp_all)+
done

lemmas size_annos_same2 = eqTrueI[OF size_annos_same]

lemma anno_annotate[simp]: "p < asize c \<Longrightarrow> anno (annotate f c) p = f p"
apply(induction c arbitrary: f p)
apply (auto simp: anno_def nth_append nth_Cons numeral_eq_Suc shift_def
            split: nat.split)
  apply (metis add_Suc_right add_diff_inverse add.commute)
 apply(rule_tac f=f in arg_cong)
 apply arith
apply (metis less_Suc_eq)
done

lemma eq_acom_iff_strip_annos:
  "C1 = C2 \<longleftrightarrow> strip C1 = strip C2 \<and> annos C1 = annos C2"
apply(induction C1 arbitrary: C2)
apply(case_tac C2, auto simp: size_annos_same2)+
done

lemma eq_acom_iff_strip_anno:
  "C1=C2 \<longleftrightarrow> strip C1 = strip C2 \<and> (\<forall>p<size(annos C1). anno C1 p = anno C2 p)"
by(auto simp add: eq_acom_iff_strip_annos anno_def
     list_eq_iff_nth_eq size_annos_same2)

lemma post_map_acom[simp]: "post(map_acom f C) = f(post C)"
by (induction C) (auto simp: post_def last_append annos_ne)

lemma strip_map_acom[simp]: "strip (map_acom f C) = strip C"
by (induction C) auto

lemma anno_map_acom: "p < size(annos C) \<Longrightarrow> anno (map_acom f C) p = f(anno C p)"
apply(induction C arbitrary: p)
apply(auto simp: anno_def nth_append nth_Cons' size_annos)
done

lemma strip_eq_SKIP:
  "strip C = SKIP \<longleftrightarrow> (EX P. C = SKIP {P})"
by (cases C) simp_all

lemma strip_eq_Assign:
  "strip C = x::=e \<longleftrightarrow> (EX P. C = x::=e {P})"
by (cases C) simp_all

lemma strip_eq_Seq:
  "strip C = c1;;c2 \<longleftrightarrow> (EX C1 C2. C = C1;;C2 & strip C1 = c1 & strip C2 = c2)"
by (cases C) simp_all

lemma strip_eq_If:
  "strip C = IF b THEN c1 ELSE c2 \<longleftrightarrow>
  (EX P1 P2 C1 C2 Q. C = IF b THEN {P1} C1 ELSE {P2} C2 {Q} & strip C1 = c1 & strip C2 = c2)"
by (cases C) simp_all

lemma strip_eq_While:
  "strip C = WHILE b DO c1 \<longleftrightarrow>
  (EX I P C1 Q. C = {I} WHILE b DO {P} C1 {Q} & strip C1 = c1)"
by (cases C) simp_all

lemma set_annos_anno[simp]: "set (annos (annotate (\<lambda>p. a) c)) = {a}"
by(induction c) simp_all

lemma post_in_annos: "post C \<in> set(annos C)"
by(auto simp: post_def annos_ne)

lemma post_anno_asize: "post C = anno C (size(annos C) - 1)"
by(simp add: post_def last_conv_nth[OF annos_ne] anno_def)

end


(* Author: Tobias Nipkow *)

theory VCG imports Hoare begin

subsection "Verification Conditions"

text{* Annotated commands: commands where loops are annotated with
invariants. *}

datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile assn bexp acom  ("({_}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

text{* Strip annotations: *}

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_} WHILE b DO C) = (WHILE b DO strip C)"

text{* Weakest precondition from annotated commands: *}

fun pre :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
"pre SKIP Q = Q" |
"pre (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>s. if bval b s then pre C\<^sub>1 Q s else pre C\<^sub>2 Q s)" |
"pre ({I} WHILE b DO C) Q = I"

text{* Verification condition: *}

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1;; C\<^sub>2) Q = (vc C\<^sub>1 (pre C\<^sub>2 Q) \<and> vc C\<^sub>2 Q)" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
"vc ({I} WHILE b DO C) Q =
  ((\<forall>s. (I s \<and> bval b s \<longrightarrow> pre C I s) \<and>
        (I s \<and> \<not> bval b s \<longrightarrow> Q s)) \<and>
    vc C I)"

text {* Soundness: *}

lemma vc_sound: "vc C Q \<Longrightarrow> \<turnstile> {pre C Q} strip C {Q}"
proof(induction C arbitrary: Q)
  case (Awhile I b C)
  show ?case
  proof(simp, rule While')
    from `vc (Awhile I b C) Q`
    have vc: "vc C I" and IQ: "\<forall>s. I s \<and> \<not> bval b s \<longrightarrow> Q s" and
         pre: "\<forall>s. I s \<and> bval b s \<longrightarrow> pre C I s" by simp_all
    have "\<turnstile> {pre C I} strip C {I}" by(rule Awhile.IH[OF vc])
    with pre show "\<turnstile> {\<lambda>s. I s \<and> bval b s} strip C {I}"
      by(rule strengthen_pre)
    show "\<forall>s. I s \<and> \<not>bval b s \<longrightarrow> Q s" by(rule IQ)
  qed
qed (auto intro: hoare.conseq)

corollary vc_sound':
  "\<lbrakk> vc C Q; \<forall>s. P s \<longrightarrow> pre C Q s \<rbrakk> \<Longrightarrow> \<turnstile> {P} strip C {Q}"
by (metis strengthen_pre vc_sound)

text{* Completeness: *}

lemma pre_mono:
  "\<forall>s. P s \<longrightarrow> P' s \<Longrightarrow> pre C P s \<Longrightarrow> pre C P' s"
proof (induction C arbitrary: P P' s)
  case Aseq thus ?case by simp metis
qed simp_all

lemma vc_mono:
  "\<forall>s. P s \<longrightarrow> P' s \<Longrightarrow> vc C P \<Longrightarrow> vc C P'"
proof(induction C arbitrary: P P')
  case Aseq thus ?case by simp (metis pre_mono)
qed simp_all

lemma vc_complete:
 "\<turnstile> {P}c{Q} \<Longrightarrow> \<exists>C. strip C = c \<and> vc C Q \<and> (\<forall>s. P s \<longrightarrow> pre C Q s)"
  (is "_ \<Longrightarrow> \<exists>C. ?G P c Q C")
proof (induction rule: hoare.induct)
  case Skip
  show ?case (is "\<exists>C. ?C C")
  proof show "?C Askip" by simp qed
next
  case (Assign P a x)
  show ?case (is "\<exists>C. ?C C")
  proof show "?C(Aassign x a)" by simp qed
next
  case (Seq P c1 Q c2 R)
  from Seq.IH obtain C1 where ih1: "?G P c1 Q C1" by blast
  from Seq.IH obtain C2 where ih2: "?G Q c2 R C2" by blast
  show ?case (is "\<exists>C. ?C C")
  proof
    show "?C(Aseq C1 C2)"
      using ih1 ih2 by (fastforce elim!: pre_mono vc_mono)
  qed
next
  case (If P b c1 Q c2)
  from If.IH obtain C1 where ih1: "?G (\<lambda>s. P s \<and> bval b s) c1 Q C1"
    by blast
  from If.IH obtain C2 where ih2: "?G (\<lambda>s. P s \<and> \<not>bval b s) c2 Q C2"
    by blast
  show ?case (is "\<exists>C. ?C C")
  proof
    show "?C(Aif b C1 C2)" using ih1 ih2 by simp
  qed
next
  case (While P b c)
  from While.IH obtain C where ih: "?G (\<lambda>s. P s \<and> bval b s) c P C" by blast
  show ?case (is "\<exists>C. ?C C")
  proof show "?C(Awhile P b C)" using ih by simp qed
next
  case conseq thus ?case by(fast elim!: pre_mono vc_mono)
qed

end