\<^marker>\<open>creator Florian Keßler, adpated by Mohammad Abdulaziz\<close>

section \<open>IMP-- Subprograms\<close>

theory IMP_Minus_Subprograms imports "Small_StepT"
begin

text \<open>We give functions that enumerate all subprograms of an IMP-- program, that is, all
  computations that could be reached during the execution of an IMP-- program. Note that this is
  a purely syntactical definition, i.e. we also take into account executions that are actually
  impossible to reach due to the semantics of IMP--. We show completeness of this definition,
  i.e. if a IMP-- program can reach a certain computation, than that computation is contained in
  our definition. \<close>

fun all_subprograms :: "com \<Rightarrow> com list" where
"all_subprograms (SKIP) = [SKIP]" |
"all_subprograms (Assign v b) = [(Assign v b), SKIP]" |
"all_subprograms (c1 ;; c2) = (map (\<lambda> c. c ;; c2) (all_subprograms c1)) @ all_subprograms c1
  @ all_subprograms c2" |
"all_subprograms (If v c1 c2) = [(If v c1 c2)] @ all_subprograms c1 @ all_subprograms c2" |
"all_subprograms (While v c) = [(While v c), SKIP] @ all_subprograms c @
  (map (\<lambda> x. x ;; (While v c)) (all_subprograms c))"

definition enumerate_subprograms :: "com \<Rightarrow> com list" where
"enumerate_subprograms c = remdups (all_subprograms c)"

fun all_variables :: "com \<Rightarrow> vname list" where
"all_variables (SKIP) = []" |
"all_variables (Assign v _) = [ v ]" |
"all_variables (c1 ;; c2) = []" |
"all_variables (If v c1 c2) = [v]" |
"all_variables (While v c) = [v]"

definition enumerate_variables :: "com \<Rightarrow> vname list" where
"enumerate_variables c = remdups (concat (map all_variables (enumerate_subprograms c)))"

lemma enumerate_variables_distinct: "distinct (enumerate_variables c)"
  by (auto simp: enumerate_variables_def)

lemma set_enumerate_variables_seq: "set (enumerate_variables (c1 ;; c2)) =
  set (enumerate_variables c1) \<union> set (enumerate_variables c2)"
  by(auto simp: enumerate_variables_def enumerate_subprograms_def)

lemma set_enumerate_variables_if: "set (enumerate_variables (IF v\<noteq>0 THEN c1 ELSE c2))
  = {v} \<union> set (enumerate_variables c1) \<union> set (enumerate_variables c2)"
  by(auto simp: enumerate_variables_def enumerate_subprograms_def)

lemma set_enumerate_variables_while: "set (enumerate_variables (WHILE v\<noteq>0 DO c))
  = {v} \<union> set (enumerate_variables c)"
  by(auto simp: enumerate_variables_def enumerate_subprograms_def)

lemma enumerate_variables_assign[simp]: "enumerate_variables (x1 ::= x2) = [x1]"
  by(auto simp: enumerate_variables_def enumerate_subprograms_def)

lemma enumerate_variables_SKIP[simp]: "enumerate_variables SKIP = []"
  by(auto simp: enumerate_variables_def enumerate_subprograms_def)

declare enumerate_subprograms_def[simp]

lemma c_in_all_subprograms_c[simp]: "c \<in> set (enumerate_subprograms c)"
  by (induction c) auto

lemma enumerate_variables_all_variables[simp]: "x \<in> set (all_variables c) \<Longrightarrow> x \<in> set (enumerate_variables c)"
  using c_in_all_subprograms_c by (auto simp: enumerate_variables_def)

lemma enumerate_subprograms_complete_step: "(c1, s1) \<rightarrow> (c2, s2)
  \<Longrightarrow> c2 \<in> set (enumerate_subprograms c1)"
apply (induction c1 s1 c2 s2 rule: small_step_induct)
  using c_in_all_subprograms_c apply(auto)
done

lemma enumerate_subprograms_transitive: "c2 \<in> set (enumerate_subprograms c1) \<Longrightarrow>
  c3 \<in> set (enumerate_subprograms c2) \<Longrightarrow> c3 \<in> set (enumerate_subprograms c1)"
proof (induction c1 arbitrary: c2 c3 rule: all_subprograms.induct)
  case (4 v c4 c5)
  then have "(c2 = (If v c4 c5)) \<or> (c2 \<in> set (all_subprograms c4))
              \<or> (c2 \<in> set (all_subprograms c5))"
      by (metis Un_iff all_subprograms.simps append.simps append.simps enumerate_subprograms_def set_ConsD set_append set_remdups)
  then show ?case
  proof (elim disjE)
    assume "c2 \<in> set (all_subprograms c5)"
    then show ?thesis using 4 by auto
  next
    assume "c2 \<in> set (all_subprograms c4)"
    then show ?thesis using 4 by auto
  next
    assume "c2 = (If v c4 c5)"
    then show ?thesis using 4 by auto
  qed
next
  case (5 v c)
  then have "c2 \<in> set (all_subprograms (While v c))" by (metis enumerate_subprograms_def set_remdups)
  then have "c2 \<in> set ([While v c, SKIP] @ all_subprograms c @ map (\<lambda> x. x ;; (While v c)) (all_subprograms c))"
    by (metis all_subprograms.simps enumerate_subprograms_def map_eq_conv set_append set_remdups)
  then have "(c2 = (While v c)) \<or> c2 = SKIP \<or> (c2 \<in> set (all_subprograms c))
              \<or> (c2 \<in> set (map (\<lambda> x. x ;; (While v c)) (all_subprograms c)))" by simp
  then show ?case
  proof (elim disjE)
    assume "c2 = (While v c)"
    then show ?thesis using 5 by auto
  next
    assume "c2 = SKIP"
    then show ?thesis using 5 by auto
  next
    assume "c2 \<in> set (all_subprograms c)"
    then show ?thesis using 5
      by (metis Un_iff all_subprograms.simps enumerate_subprograms_def set_append set_remdups)
  next
    assume "c2 \<in> set (map (\<lambda> x. x ;; (While v c)) (all_subprograms c))"
    then obtain c' where *: "c2 = c' ;; (While v c) \<and> c' \<in> set (all_subprograms c)" by auto
    then have "c3 \<in> set (map (\<lambda> x. x ;; (While v c)) (all_subprograms c')) \<or> c3 \<in> set (all_subprograms c')
      \<or> c3 \<in> set (all_subprograms (While v c))" using 5 by auto
    then show ?thesis
    proof (elim disjE)
      assume "c3 \<in> set (map (\<lambda> x. x ;; (While v c)) (all_subprograms c'))"
      then have "c3 \<in> set (map (\<lambda> x. x ;; (While v c)) (all_subprograms c))" using * 5 by auto
      then show ?thesis by auto
    next
      assume "c3 \<in> set (all_subprograms c')"
      then have "c3 \<in> set (all_subprograms c)" using * 5 by auto
      then show ?thesis by auto
    next
      assume "c3 \<in> set (all_subprograms (While v c))"
      then show ?thesis using 5 by (metis enumerate_subprograms_def set_remdups)
    qed
  qed
qed auto

lemma enumerate_subprograms_complete: "(c1, s1)\<rightarrow>\<^bsup>t\<^esup> (c2, s2)
  \<Longrightarrow>  c2 \<in> set (enumerate_subprograms c1)"
proof(induction t arbitrary: c1 s1 c2 s2)
  case 0
  then show ?case using c_in_all_subprograms_c by auto
next
  case (Suc t)
  then obtain c1' s1' where "((c1, s1) \<rightarrow> (c1', s1')) \<and> ((c1', s1')\<rightarrow>\<^bsup>t\<^esup> (c2, s2))" by auto
  then show ?case using enumerate_subprograms_transitive Suc enumerate_subprograms_complete_step
    by blast
qed

lemma SKIP_in_enumerate_subprograms[simp]: "SKIP \<in> set (enumerate_subprograms c)"
  by (induction c rule: all_subprograms.induct) auto

lemma enumerate_subprograms_enumerate_variables: "c' \<in> set (enumerate_subprograms c)
  \<Longrightarrow> set (enumerate_variables c') \<subseteq> set (enumerate_variables c)"
 by (auto simp: enumerate_variables_def)
     (metis enumerate_subprograms_def enumerate_subprograms_transitive set_remdups)

end


section \<open>The Num Class\<close>

theory Num_Class
  imports
    Type_Classes
    Data_Integer
    Data_Tuple
begin

subsection \<open>Num class\<close>

(* TODO: Show class (jb) *)

class Num_syn =
  Eq +
  plus +
  minus +
  times +
  zero +
  one +
  fixes  negate :: "'a \<rightarrow> 'a"
  and   abs :: "'a \<rightarrow> 'a"
  and   signum :: "'a \<rightarrow> 'a"
  and   fromInteger :: "Integer \<rightarrow> 'a"

(* If I create this class in one step I get problems with Num_faithful... (jb) *)
class Num = Num_syn + plus_cpo + minus_cpo + times_cpo

class Num_strict = Num +
  assumes plus_strict[simp]:
    "x + \<bottom> = (\<bottom>::'a::Num)"
    "\<bottom> + x = \<bottom>"
  assumes minus_strict[simp]:
    "x - \<bottom> = \<bottom>"
    "\<bottom> - x = \<bottom>"
  assumes mult_strict[simp]:
    "x * \<bottom> = \<bottom>"
    "\<bottom> * x = \<bottom>"
  assumes negate_strict[simp]:
    "negate\<cdot>\<bottom> = \<bottom>"
  assumes abs_strict[simp]:
    "abs\<cdot>\<bottom> = \<bottom>"
  assumes signum_strict[simp]:
    "signum\<cdot>\<bottom> = \<bottom>"
  assumes fromInteger_strict[simp]:
    "fromInteger\<cdot>\<bottom> = \<bottom>"

(* TODO: How to name the type class that adds the reqiured relations? For Eq, we have Eq_equiv
resp. Eq_eq, but for Num I don't see a nice name. Also, a generic name might be nicer. (jb) *)

class Num_faithful =
  (* TODO: Why is it not possible to use Num here? I get
     Type unification failed: No type arity lift :: minus
     (jb)
  *)
  Num_syn +
  (* This is the only relation about Num required by the Haskell report. By using eq we leave it
  to the users choice of Eq_eq or Eq_equiv whether the relations should hold up to equivalence or
  syntactic equality. (jb) *)
  assumes abs_signum_eq: "(eq\<cdot>((abs\<cdot>x) * (signum\<cdot>x))\<cdot>(x::'a::{Num_syn})) \<sqsubseteq> TT"
  (* TODO: Should we add sensible relations on our own? (jb) *)

  (* The zero and one type class are "artificial", so we ensure they do what expected. *)
  (* Unfortunately, this is not working. Is isabelle trying to give all occurrences of 0
      the same type?
  assumes "0 = fromInteger\<cdot>0"
  assumes "1 = fromInteger\<cdot>1"
  *)

class Integral =
  Num +
  (* fixes quot rem  *)
  fixes div mod :: "'a \<rightarrow> 'a \<rightarrow> ('a::Num)"
  fixes toInteger :: "'a \<rightarrow> Integer"
begin
  (* fixrec quotRem :: "'a \<rightarrow> 'a \<rightarrow> \<langle>'a, 'a\<rangle>"  where "quotRem\<cdot>x\<cdot>y = \<langle>quot\<cdot>x\<cdot>y, (rem\<cdot>x\<cdot>y)\<rangle>" *)
  fixrec divMod :: "'a \<rightarrow> 'a \<rightarrow> \<langle>'a, 'a\<rangle>"  where "divMod\<cdot>x\<cdot>y = \<langle>div\<cdot>x\<cdot>y, mod\<cdot>x\<cdot>y\<rangle>"

  fixrec even :: "'a \<rightarrow> tr" where "even\<cdot>x = eq\<cdot>(div\<cdot>x\<cdot>(fromInteger\<cdot>2))\<cdot>0"
  fixrec odd :: "'a \<rightarrow> tr" where "odd\<cdot>x = neg\<cdot>(even\<cdot>x)"
end

class Integral_strict = Integral +
  assumes div_strict[simp]:
    "div\<cdot>x\<cdot>\<bottom> = (\<bottom>::'a::Integral)"
    "div\<cdot>\<bottom>\<cdot>x = \<bottom>"
  assumes mod_strict[simp]:
    "mod\<cdot>x\<cdot>\<bottom> = \<bottom>"
    "mod\<cdot>\<bottom>\<cdot>x = \<bottom>"
  assumes toInteger_strict[simp]:
    "toInteger\<cdot>\<bottom> = \<bottom>"

class Integral_faithful =
  Integral +
  Num_faithful +
  (* assumes "\<not>(eq\<cdot>y\<cdot>0 = TT) \<Longrightarrow> quot\<cdot>x\<cdot>y * y + rem\<cdot>x\<cdot>y = (x::'a::{Integral})" *)
  assumes "eq\<cdot>y\<cdot>0 = FF \<Longrightarrow> div\<cdot>x\<cdot>y * y + mod\<cdot>x\<cdot>y = (x::'a::{Integral})"

subsection \<open>Instances for Integer\<close>

instantiation Integer :: Num_syn
begin
  definition "negate = (\<Lambda> (MkI\<cdot>x). MkI\<cdot>(uminus x))"
  definition "abs = (\<Lambda> (MkI\<cdot>x) . MkI\<cdot>(\<bar>x\<bar>))"
  definition "signum = (\<Lambda> (MkI\<cdot>x) . MkI\<cdot>(sgn x))"
  definition "fromInteger = (\<Lambda> x. x)"
  instance..
end

instance Integer :: Num
  by standard

instance Integer :: Num_faithful
  apply standard
  apply (rename_tac x, case_tac x)
   apply simp
  apply (simp add: signum_Integer_def abs_Integer_def)
  apply (metis mult.commute mult_sgn_abs)
  done

instance Integer :: Num_strict
  apply standard
  unfolding signum_Integer_def abs_Integer_def negate_Integer_def fromInteger_Integer_def
  by simp_all

instantiation Integer :: Integral
begin
  definition "div = (\<Lambda> (MkI\<cdot>x) (MkI\<cdot>y). MkI\<cdot>(Rings.divide x y))"
  definition "mod = (\<Lambda> (MkI\<cdot>x) (MkI\<cdot>y). MkI\<cdot>(Rings.modulo x y))"
  definition "toInteger = (\<Lambda> x. x)"
  instance ..
end

instance Integer :: Integral_strict
  apply standard
  unfolding div_Integer_def mod_Integer_def toInteger_Integer_def
      apply simp_all
   apply (rename_tac x, case_tac x, simp, simp)+
  done

instance Integer :: Integral_faithful
  apply standard
  unfolding div_Integer_def mod_Integer_def
  apply (rename_tac y x)
  apply (case_tac y, simp)
  apply (case_tac x, simp)
  apply simp
  done

lemma Integer_Integral_simps[simp]:
  "div\<cdot>(MkI\<cdot>x)\<cdot>(MkI\<cdot>y) = MkI\<cdot>(Rings.divide x y)"
  "mod\<cdot>(MkI\<cdot>x)\<cdot>(MkI\<cdot>y) = MkI\<cdot>(Rings.modulo x y)"
  "fromInteger\<cdot>i = i"
  unfolding mod_Integer_def div_Integer_def fromInteger_Integer_def by simp_all

end


(* Title:      Capped Omega Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Capped Omega Algebras\<close>

theory Capped_Omega_Algebras

imports Omega_Algebras

begin

class capped_omega =
  fixes capped_omega :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_\<^sup>\<omega>\<^sub>_" [100,100] 100)

class capped_omega_algebra = bounded_left_zero_kleene_algebra + bounded_distrib_lattice + capped_omega +
  assumes capped_omega_unfold: "y\<^sup>\<omega>\<^sub>v = y * y\<^sup>\<omega>\<^sub>v \<sqinter> v"
  assumes capped_omega_induct: "x \<le> (y * x \<squnion> z) \<sqinter> v \<longrightarrow> x \<le> y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z"

text \<open>AACP Theorem 6.1\<close>

notation
  top ("\<top>")

sublocale capped_omega_algebra < capped: bounded_left_zero_omega_algebra where omega = "(\<lambda>y . y\<^sup>\<omega>\<^sub>\<top>)"
  apply unfold_locales
  apply (metis capped_omega_unfold inf_top_right)
  by (simp add: capped_omega_induct sup_commute)

context capped_omega_algebra
begin

text \<open>AACP Theorem 6.2\<close>

lemma capped_omega_below_omega:
  "y\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>\<top>"
  using capped.omega_induct_mult capped_omega_unfold order.eq_iff by force

text \<open>AACP Theorem 6.3\<close>

lemma capped_omega_below:
  "y\<^sup>\<omega>\<^sub>v \<le> v"
  using capped_omega_unfold order.eq_iff by force

text \<open>AACP Theorem 6.4\<close>

lemma capped_omega_one:
  "1\<^sup>\<omega>\<^sub>v = v"
proof -
  have "v \<le> (1 * v \<squnion> bot) \<sqinter> v"
    by simp
  hence "v \<le> 1\<^sup>\<omega>\<^sub>v \<squnion> 1\<^sup>\<star> * bot"
    by (simp add: capped_omega_induct)
  also have "... = 1\<^sup>\<omega>\<^sub>v"
    by (simp add: star_one)
  finally show ?thesis
    by (simp add: capped_omega_below order.antisym)
qed

text \<open>AACP Theorem 6.5\<close>

lemma capped_omega_zero:
  "bot\<^sup>\<omega>\<^sub>v = bot"
  by (metis capped_omega_below_omega bot_unique capped.omega_bot)

lemma star_below_cap:
  "y \<le> u \<Longrightarrow> z \<le> v \<Longrightarrow> u * v \<le> v \<Longrightarrow> y\<^sup>\<star> * z \<le> v"
  by (metis le_sup_iff order.trans mult_left_isotone star_left_induct)

lemma capped_fix:
  assumes "y \<le> u"
      and "z \<le> v"
      and "u * v \<le> v"
    shows "(y * (y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z) \<squnion> z) \<sqinter> v = y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z"
proof -
  have "(y * (y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z) \<squnion> z) \<sqinter> v = (y * y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z) \<sqinter> v"
    by (simp add: mult_left_dist_sup star.circ_loop_fixpoint sup_assoc)
  also have "... = (y * y\<^sup>\<omega>\<^sub>v \<sqinter> v) \<squnion> (y\<^sup>\<star> * z \<sqinter> v)"
    by (simp add: inf_sup_distrib2)
  also have "... = y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z"
    using assms capped_omega_unfold le_iff_inf star_below_cap by auto
  finally show ?thesis
    .
qed

lemma capped_fixpoint:
  "y \<le> u \<Longrightarrow> z \<le> v \<Longrightarrow> u * v \<le> v \<Longrightarrow> is_fixpoint (\<lambda>x . (y * x \<squnion> z) \<sqinter> v) (y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z)"
  by (simp add: capped_fix is_fixpoint_def)

lemma capped_greatest_fixpoint:
  "y \<le> u \<Longrightarrow> z \<le> v \<Longrightarrow> u * v \<le> v \<Longrightarrow> is_greatest_fixpoint (\<lambda>x . (y * x \<squnion> z) \<sqinter> v) (y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z)"
  by (smt capped_fix order_refl capped_omega_induct is_greatest_fixpoint_def)

lemma capped_postfixpoint:
  "y \<le> u \<Longrightarrow> z \<le> v \<Longrightarrow> u * v \<le> v \<Longrightarrow> is_postfixpoint (\<lambda>x . (y * x \<squnion> z) \<sqinter> v) (y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z)"
  using capped_fix inf.eq_refl is_postfixpoint_def by auto

lemma capped_greatest_postfixpoint:
  "y \<le> u \<Longrightarrow> z \<le> v \<Longrightarrow> u * v \<le> v \<Longrightarrow> is_greatest_postfixpoint (\<lambda>x . (y * x \<squnion> z) \<sqinter> v) (y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z)"
  by (smt capped_fix order_refl capped_omega_induct is_greatest_postfixpoint_def)

text \<open>AACP Theorem 6.6\<close>

lemma capped_nu:
  "y \<le> u \<Longrightarrow> z \<le> v \<Longrightarrow> u * v \<le> v \<Longrightarrow> \<nu>(\<lambda>x . (y * x \<squnion> z) \<sqinter> v) = y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z"
  by (metis capped_greatest_fixpoint greatest_fixpoint_same)

lemma capped_pnu:
  "y \<le> u \<Longrightarrow> z \<le> v \<Longrightarrow> u * v \<le> v \<Longrightarrow> p\<nu>(\<lambda>x . (y * x \<squnion> z) \<sqinter> v) = y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z"
  by (metis capped_greatest_postfixpoint greatest_postfixpoint_same)

text \<open>AACP Theorem 6.7\<close>

lemma unfold_capped_omega:
  "y \<le> u \<Longrightarrow> u * v \<le> v \<Longrightarrow> y * y\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
  by (smt (verit, ccfv_SIG) capped_omega_below capped_omega_unfold inf.order_lesseq_imp le_iff_inf mult_isotone)

text \<open>AACP Theorem 6.8\<close>

lemma star_mult_capped_omega:
  assumes "y \<le> u"
      and "u * v \<le> v"
    shows "y\<^sup>\<star> * y\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
proof -
  have "y * y\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
    using assms unfold_capped_omega by auto
  hence "y\<^sup>\<star> * y\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v"
    by (simp add: star_left_induct_mult)
  thus ?thesis
    by (metis sup_ge2 order.antisym star.circ_loop_fixpoint)
qed

text \<open>AACP Theorem 6.9\<close>

lemma star_zero_below_capped_omega_zero:
  assumes "y \<le> u"
      and "u * v \<le> v"
    shows "y\<^sup>\<star> * bot \<le> y\<^sup>\<omega>\<^sub>v * bot"
proof -
  have "y * y\<^sup>\<omega>\<^sub>v \<le> v"
    using assms capped_omega_below unfold_capped_omega by auto
  hence "y * y\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
    using assms unfold_capped_omega by auto
  thus ?thesis
    by (metis bot_least eq_refl mult_assoc star_below_cap)
qed

lemma star_zero_below_capped_omega:
  "y \<le> u \<Longrightarrow> u * v \<le> v \<Longrightarrow> y\<^sup>\<star> * bot \<le> y\<^sup>\<omega>\<^sub>v"
  by (simp add: star_loop_least_fixpoint unfold_capped_omega)

lemma capped_omega_induct_meet_zero:
  "x \<le> y * x \<sqinter> v \<Longrightarrow> x \<le> y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * bot"
  by (simp add: capped_omega_induct)

text \<open>AACP Theorem 6.10\<close>

lemma capped_omega_induct_meet:
  "y \<le> u \<Longrightarrow> u * v \<le> v \<Longrightarrow> x \<le> y * x \<sqinter> v \<Longrightarrow> x \<le> y\<^sup>\<omega>\<^sub>v"
  by (metis capped_omega_induct_meet_zero sup_commute le_iff_sup star_zero_below_capped_omega)

lemma capped_omega_induct_equal:
  "x = (y * x \<squnion> z) \<sqinter> v \<Longrightarrow> x \<le> y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * z"
  using capped_omega_induct inf.le_iff_sup by auto

text \<open>AACP Theorem 6.11\<close>

lemma capped_meet_nu:
  assumes "y \<le> u"
      and "u * v \<le> v"
    shows "\<nu>(\<lambda>x . y * x \<sqinter> v) = y\<^sup>\<omega>\<^sub>v"
proof -
  have "y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * bot = y\<^sup>\<omega>\<^sub>v"
    by (smt assms star_zero_below_capped_omega le_iff_sup sup_commute)
  hence "\<nu>(\<lambda>x . (y * x \<squnion> bot) \<sqinter> v) = y\<^sup>\<omega>\<^sub>v"
    by (metis assms capped_nu bot_least)
  thus ?thesis
    by simp
qed

lemma capped_meet_pnu:
  assumes "y \<le> u"
      and "u * v \<le> v"
    shows "p\<nu>(\<lambda>x . y * x \<sqinter> v) = y\<^sup>\<omega>\<^sub>v"
proof -
  have "y\<^sup>\<omega>\<^sub>v \<squnion> y\<^sup>\<star> * bot = y\<^sup>\<omega>\<^sub>v"
    by (smt assms star_zero_below_capped_omega le_iff_sup sup_commute)
  hence "p\<nu>(\<lambda>x . (y * x \<squnion> bot) \<sqinter> v) = y\<^sup>\<omega>\<^sub>v"
    by (metis assms capped_pnu bot_least)
  thus ?thesis
    by simp
qed

text \<open>AACP Theorem 6.12\<close>

lemma capped_omega_isotone:
  "y \<le> u \<Longrightarrow> u * v \<le> v \<Longrightarrow> t \<le> y \<Longrightarrow> t\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v"
  by (metis capped_omega_induct_meet capped_omega_unfold le_iff_sup inf.sup_left_isotone mult_right_sub_dist_sup_left)

text \<open>AACP Theorem 6.13\<close>

lemma capped_omega_simulation:
  assumes "y \<le> u"
      and "s \<le> u"
      and "u * v \<le> v"
      and "s * t \<le> y * s"
    shows "s * t\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v"
proof -
  have "s * t\<^sup>\<omega>\<^sub>v \<le> s * t * t\<^sup>\<omega>\<^sub>v \<sqinter> s * v"
    by (metis capped_omega_below capped_omega_unfold inf.boundedI inf.cobounded1 mult_right_isotone mult_assoc)
  also have "... \<le> s * t * t\<^sup>\<omega>\<^sub>v \<sqinter> v"
    using assms(2,3) inf.order_lesseq_imp inf.sup_right_isotone mult_left_isotone by blast
  also have "... \<le> y * s * t\<^sup>\<omega>\<^sub>v \<sqinter> v"
    using assms(4) inf.sup_left_isotone mult_left_isotone by auto
  finally show ?thesis
    using assms(1,3) capped_omega_induct_meet mult_assoc by auto
qed

lemma capped_omega_slide_sub:
  assumes "s \<le> u"
      and "y \<le> u"
      and "u * u \<le> u"
      and "u * v \<le> v"
    shows "s * (y * s)\<^sup>\<omega>\<^sub>v \<le> (s * y)\<^sup>\<omega>\<^sub>v"
proof -
  have "s * y \<le> u"
    by (meson assms(1-3) mult_isotone order_trans)
  thus ?thesis
    using assms(1,4) capped_omega_simulation mult_assoc by auto
qed

text \<open>AACP Theorem 6.14\<close>

lemma capped_omega_slide:
  "s \<le> u \<Longrightarrow> y \<le> u \<Longrightarrow> u * u \<le> u \<Longrightarrow> u * v \<le> v \<Longrightarrow> s * (y * s)\<^sup>\<omega>\<^sub>v = (s * y)\<^sup>\<omega>\<^sub>v"
  by (smt (verit) order.antisym mult_assoc mult_right_isotone capped_omega_unfold capped_omega_slide_sub inf.sup_ge1 order_trans)

lemma capped_omega_sub_dist:
  "s \<le> u \<Longrightarrow> y \<le> u \<Longrightarrow> u * v \<le> v \<Longrightarrow> s\<^sup>\<omega>\<^sub>v \<le> (s \<squnion> y)\<^sup>\<omega>\<^sub>v"
  by (simp add: capped_omega_isotone)

text \<open>AACP Theorem 6.15\<close>

lemma capped_omega_simulation_2:
  assumes "s \<le> u"
      and "y \<le> u"
      and "u * u \<le> u"
      and "u * v \<le> v"
      and "y * s \<le> s * y"
    shows "(s * y)\<^sup>\<omega>\<^sub>v \<le> s\<^sup>\<omega>\<^sub>v"
proof -
  have 1: "s * y \<le> u"
    using assms(1-3) inf.order_lesseq_imp mult_isotone by blast
  have 2: "s * (s * y)\<^sup>\<omega>\<^sub>v \<le> v"
    by (meson assms(1,4) capped_omega_below order.trans mult_isotone)
  have "(s * y)\<^sup>\<omega>\<^sub>v = s * (y * s)\<^sup>\<omega>\<^sub>v"
    using assms(1-4) capped_omega_slide by auto
  also have "... \<le> s * (s * y)\<^sup>\<omega>\<^sub>v"
    using 1 assms(4,5) capped_omega_isotone mult_right_isotone by blast
  also have "... = s * (s * y)\<^sup>\<omega>\<^sub>v \<sqinter> v"
    using 2 inf.order_iff by auto
  finally show ?thesis
    using assms(1,4) capped_omega_induct_meet by blast
qed

text \<open>AACP Theorem 6.16\<close>

lemma left_plus_capped_omega:
  assumes "y \<le> u"
      and "u * u \<le> u"
      and "u * v \<le> v"
    shows "(y * y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
proof -
  have 1: "y * y\<^sup>\<star> \<le> u"
    by (metis assms(1,2) star_plus star_below_cap)
  hence "y * y\<^sup>\<star> * (y * y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v \<le> v"
    using assms(3) capped_omega_below unfold_capped_omega by auto
  hence "y * y\<^sup>\<star> * (y * y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v = (y * y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v"
    using 1 assms(3) unfold_capped_omega by blast
  hence "(y * y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v"
    using 1 by (smt assms(1,3) capped_omega_simulation mult_assoc mult_semi_associative star.circ_transitive_equal star_simulation_right_equal)
  thus ?thesis
    using 1 by (meson assms(3) capped_omega_isotone order.antisym star.circ_mult_increasing)
qed

text \<open>AACP Theorem 6.17\<close>

lemma capped_omega_sub_vector:
  assumes "z \<le> v"
      and "y \<le> u"
      and "u * v \<le> v"
    shows "y\<^sup>\<omega>\<^sub>u * z \<le> y\<^sup>\<omega>\<^sub>v"
proof -
  have "y\<^sup>\<omega>\<^sub>u * z \<le> y * y\<^sup>\<omega>\<^sub>u * z \<sqinter> u * z"
    by (metis capped_omega_below capped_omega_unfold eq_refl inf.boundedI inf.cobounded1 mult_isotone)
  also have "... \<le> y * y\<^sup>\<omega>\<^sub>u * z \<sqinter> v"
    by (metis assms(1,3) inf.sup_left_isotone inf_commute mult_right_isotone order_trans)
  finally show ?thesis
    using assms(2,3) capped_omega_induct_meet mult_assoc by auto
qed

text \<open>AACP Theorem 6.18\<close>

lemma capped_omega_omega:
  "y \<le> u \<Longrightarrow> u * v \<le> v \<Longrightarrow> (y\<^sup>\<omega>\<^sub>u)\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v"
  by (metis capped_omega_below capped_omega_sub_vector unfold_capped_omega)

end

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Alignment With Definitions from HOL-Algebra\<close>
theory HOL_Algebra_Alignment_Galois
  imports
    "HOL-Algebra.Galois_Connection"
    HOL_Algebra_Alignment_Orders
    Galois
begin

named_theorems HOL_Algebra_galois_alignment

context galois_connection
begin

context
  fixes L R l r
  defines "L \<equiv> (\<sqsubseteq>\<^bsub>\<X>\<^esub>)\<restriction>\<^bsub>carrier \<X>\<^esub>\<upharpoonleft>\<^bsub>carrier \<X>\<^esub>" and "R \<equiv> (\<sqsubseteq>\<^bsub>\<Y>\<^esub>)\<restriction>\<^bsub>carrier \<Y>\<^esub>\<upharpoonleft>\<^bsub>carrier \<Y>\<^esub>"
    and "l \<equiv> \<pi>\<^sup>*" and "r \<equiv> \<pi>\<^sub>*"
  notes defs[simp] = L_def R_def l_def r_def and restrict_right_eq[simp]
    and restrict_leftI[intro!] restrict_leftE[elim!]
begin

interpretation galois L R l r .

lemma mono_wrt_rel_lower [HOL_Algebra_galois_alignment]: "(L \<Rrightarrow>\<^sub>m R) l"
  using lower_closed upper_closed by (fastforce intro: use_iso2[OF lower_iso])

lemma mono_wrt_rel_upper [HOL_Algebra_galois_alignment]: "(R \<Rrightarrow>\<^sub>m L) r"
  using lower_closed upper_closed by (fastforce intro: use_iso2[OF upper_iso])

lemma half_galois_prop_left [HOL_Algebra_galois_alignment]: "(L \<^sub>h\<unlhd> R) l r"
  using galois_property lower_closed by fastforce

lemma half_galois_prop_right [HOL_Algebra_galois_alignment]: "(L \<unlhd>\<^sub>h R) l r"
  using galois_property upper_closed by fastforce

lemma galois_prop [HOL_Algebra_galois_alignment]: "(L \<unlhd> R) l r"
  using half_galois_prop_left half_galois_prop_right by blast

lemma galois_connection [HOL_Algebra_galois_alignment]: "(L \<stileturn> R) l r"
  using mono_wrt_rel_lower mono_wrt_rel_upper galois_prop by blast

end
end

context galois_bijection
begin

context
  fixes L R l r
  defines "L \<equiv> (\<sqsubseteq>\<^bsub>\<X>\<^esub>)\<restriction>\<^bsub>carrier \<X>\<^esub>\<upharpoonleft>\<^bsub>carrier \<X>\<^esub>" and "R \<equiv> (\<sqsubseteq>\<^bsub>\<Y>\<^esub>)\<restriction>\<^bsub>carrier \<Y>\<^esub>\<upharpoonleft>\<^bsub>carrier \<Y>\<^esub>"
    and "l \<equiv> \<pi>\<^sup>*" and "r \<equiv> \<pi>\<^sub>*"
  notes defs[simp] = L_def R_def l_def r_def and restrict_right_eq[simp]
    and restrict_leftI[intro!] restrict_leftE[elim!]
begin

interpretation galois R L r l .

lemma half_galois_prop_left_right_left [HOL_Algebra_galois_alignment]:
  "(R \<^sub>h\<unlhd> L) r l"
  using gal_bij_conn.galois_property lower_inv_eq upper_inv_eq upper_closed
  by (intro half_galois_prop_leftI) (auto; metis)

lemma half_galois_prop_right_right_left [HOL_Algebra_galois_alignment]:
  "(R \<unlhd>\<^sub>h L) r l"
  using gal_bij_conn.galois_property lower_inv_eq upper_inv_eq lower_closed
  by (intro half_galois_prop_rightI) (auto elim!: in_codom_restrict_leftE; metis)

lemma prop_right_right_left [HOL_Algebra_galois_alignment]: "(R \<unlhd> L) r l"
  using half_galois_prop_left_right_left half_galois_prop_right_right_left by blast

lemma galois_equivalence [HOL_Algebra_galois_alignment]: "(L \<equiv>\<^sub>G R) l r"
  using gal_bij_conn.galois_connection prop_right_right_left
  by (intro galois.galois_equivalenceI) auto

end
end

end


\<^marker>\<open>creator Bilel Ghorbel, Florian Kessler\<close>

section "IMP-- An even more reduced imperative language"

theory IMP_Minus_Minus_Com imports Main begin

paragraph "Summary"
text\<open>Syntax definition for IMP--. Based on the syntax definition of IMP-. Compared to IMP-,
  we get rid of arithmetic expressions. Instead, we can only assign bit values to registers.
  For the IF and WHILE conditions, we add the possibility to specify a list of registers, such that
  the condition is considered True if at least one of the registers is non-zero. \<close>

datatype bit = Zero | One

fun nat_to_bit:: "nat \<Rightarrow> bit" where
"nat_to_bit 0 = Zero" |
"nat_to_bit _ = One"

lemma bit_neq_zero_iff[simp]: "x \<noteq> Zero \<longleftrightarrow> x = One" by (cases x) auto
lemma bit_neq_one_iff[simp]: "x \<noteq> One \<longleftrightarrow> x = Zero" by (cases x) auto

lemma nat_to_bit_eq_One_iff: "nat_to_bit x = One \<longleftrightarrow> x > 0"
  by (cases x) auto

lemma nat_to_bit_eq_One_iff': "One = nat_to_bit x \<longleftrightarrow> x > 0"
  by (cases x) auto

lemma nat_to_bit_eq_Zero_iff: "nat_to_bit x = Zero \<longleftrightarrow> x = 0"
  by (cases x) auto

lemma nat_to_bit_eq_Zero_iff': "Zero = nat_to_bit x \<longleftrightarrow> x = 0"
  by (cases x) auto

lemmas nat_to_bit_cases = nat_to_bit_eq_One_iff nat_to_bit_eq_One_iff' nat_to_bit_eq_Zero_iff
  nat_to_bit_eq_Zero_iff'

type_synonym vname = string

datatype
  com = SKIP
  | Assign vname bit
  | Seq com com
  | If "(vname list)" com com
  | While "(vname list)" com

bundle com_syntax
begin
notation Assign ("_ ::= _" [1000, 61] 61) and
         Seq ("_;;/ _"  [60, 61] 60) and
         If ("(IF _/\<noteq>0 THEN _/ ELSE _)"  [0, 0, 61] 61) and
         While ("(WHILE _/\<noteq>0 DO _)"  [0, 61] 61)
end

bundle no_com_syntax
begin
no_notation Assign ("_ ::= _" [1000, 61] 61) and
            Seq ("_;;/ _"  [60, 61] 60) and
            If ("(IF _/\<noteq>0 THEN _/ ELSE _)"  [0, 0, 61] 61) and
            While ("(WHILE _/\<noteq>0 DO _)"  [0, 61] 61)
end

unbundle com_syntax

end


(*  Title:       Inductive definition of Hoare logic
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

theory PHoare imports PLang begin

subsection{* Hoare logic for partial correctness *}

text{*Taking auxiliary variables seriously means that assertions must
now depend on them as well as on the state. Initially we do not fix
the type of auxiliary variables but parameterize the type of
assertions with a type variable @{typ 'a}:*}

type_synonym 'a assn = "'a \<Rightarrow> state \<Rightarrow> bool"

text{*
The second major change is the need to reason about Hoare
triples in a context: proofs about recursive procedures are conducted
by induction where we assume that all @{term CALL}s satisfy the given
pre/postconditions and have to show that the body does as well. The
assumption is stored in a context, which is a set of Hoare triples:*}

type_synonym 'a cntxt = "('a assn \<times> com \<times> 'a assn)set"

text{*\noindent In the presence of only a single procedure the context will
always be empty or a singleton set. With multiple procedures, larger
sets can arise.

Now that we have contexts, validity becomes more complicated. Ordinary
validity (w.r.t.\ partial correctness) is still what it used to be,
except that we have to take auxiliary variables into account as well:
*}

definition
 valid :: "'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
     "\<Turnstile> {P}c{Q} \<longleftrightarrow> (\<forall>s t. s -c\<rightarrow> t \<longrightarrow> (\<forall>z. P z s \<longrightarrow> Q z t))"

text{*\noindent Auxiliary variables are always denoted by @{term z}.

Validity of a context and validity of a Hoare triple in a context are defined
as follows:*}

definition
 valids :: "'a cntxt \<Rightarrow> bool" ("|\<Turnstile> _" 50) where
  [simp]: "|\<Turnstile> C \<equiv> (\<forall>(P,c,Q) \<in> C. \<Turnstile> {P}c{Q})"

definition
 cvalid :: "'a cntxt \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("_ \<Turnstile>/ {(1_)}/ (_)/ {(1_)}" 50) where
  "C \<Turnstile> {P}c{Q} \<longleftrightarrow> |\<Turnstile> C \<longrightarrow> \<Turnstile> {P}c{Q}"

text{*\noindent Note that @{prop"{} \<Turnstile> {P}c{Q}"} is equivalent to
@{prop"\<Turnstile> {P}c{Q}"}.

Unfortunately, this is not the end of it. As we have two
semantics, @{text"-c\<rightarrow>"} and @{text"-c-n\<rightarrow>"}, we also need a second notion
of validity parameterized with the recursion depth @{term n}:*}

definition
 nvalid :: "nat \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile>_ {(1_)}/ (_)/ {(1_)}" 50) where
  "\<Turnstile>n {P}c{Q} \<equiv> (\<forall>s t. s -c-n\<rightarrow> t \<longrightarrow> (\<forall>z. P z s \<longrightarrow> Q z t))"

definition
 nvalids :: "nat \<Rightarrow> 'a cntxt \<Rightarrow> bool" ("|\<Turnstile>'__/ _" 50) where
  "|\<Turnstile>_n C \<equiv> (\<forall>(P,c,Q) \<in> C. \<Turnstile>n {P}c{Q})"

definition
 cnvalid :: "'a cntxt \<Rightarrow> nat \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("_ \<Turnstile>_/ {(1_)}/ (_)/ {(1_)}" 50) where
  "C \<Turnstile>n {P}c{Q} \<longleftrightarrow> |\<Turnstile>_n C \<longrightarrow> \<Turnstile>n {P}c{Q}"

text{*Finally we come to the proof system for deriving triples in a context:*}

inductive
  hoare :: "'a cntxt \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("_ \<turnstile>/ ({(1_)}/ (_)/ {(1_)})" 50)
where
   (*<*)Do:(*>*)"C \<turnstile> {\<lambda>z s. \<forall>t \<in> f s . P z t} Do f {P}"

 | (*<*)Semi:(*>*)"\<lbrakk> C \<turnstile> {P}c1{Q}; C \<turnstile> {Q}c2{R} \<rbrakk> \<Longrightarrow> C \<turnstile> {P} c1;c2 {R}"

 | (*<*)If:(*>*)"\<lbrakk> C \<turnstile> {\<lambda>z s. P z s \<and> b s}c1{Q};  C \<turnstile> {\<lambda>z s. P z s \<and> \<not>b s}c2{Q}  \<rbrakk>
   \<Longrightarrow> C \<turnstile> {P} IF b THEN c1 ELSE c2 {Q}"

 | (*<*)While:(*>*)"C \<turnstile> {\<lambda>z s. P z s \<and> b s} c {P}
   \<Longrightarrow> C \<turnstile> {P} WHILE b DO c {\<lambda>z s. P z s \<and> \<not>b s}"

 | (*<*)Conseq:(*>*)"\<lbrakk> C \<turnstile> {P'}c{Q'};  \<forall>s t. (\<forall>z. P' z s \<longrightarrow> Q' z t) \<longrightarrow> (\<forall>z. P z s \<longrightarrow> Q z t) \<rbrakk>
   \<Longrightarrow> C \<turnstile> {P}c{Q}"

 | (*<*)Call:(*>*)"{(P,CALL,Q)} \<turnstile> {P}body{Q} \<Longrightarrow> {} \<turnstile> {P} CALL {Q}"

 | (*<*)Asm:(*>*)"{(P,CALL,Q)} \<turnstile> {P} CALL {Q}"
 | (*<*)Local:(*>*) "\<lbrakk> \<forall>s'. C \<turnstile> {\<lambda>z s. P z s' \<and> s = f s'} c {\<lambda>z t. Q z (g s' t)} \<rbrakk> \<Longrightarrow>
        C \<turnstile> {P} LOCAL f;c;g {Q}"

abbreviation hoare1 :: "'a cntxt \<Rightarrow> 'a assn \<times> com \<times> 'a assn \<Rightarrow> bool" ("_ \<turnstile> _") where
  "C \<turnstile> x \<equiv> C \<turnstile> {fst x}fst (snd x){snd (snd x)}"

text{*\noindent The first four rules are familiar, except for their adaptation
to auxiliary variables. The @{term CALL} rule embodies induction and
has already been motivated above. Note that it is only applicable if
the context is empty. This shows that we never need nested induction.
For the same reason the assumption rule (the last rule) is stated with
just a singleton context.

The rule of consequence is explained in the accompanying paper.
*}

lemmas valid_defs = valid_def valids_def cvalid_def
                    nvalid_def nvalids_def cnvalid_def

text{*
The completeness proof employs the notion of a \emph{most general triple} (or
\emph{most general formula}): *}

definition
  MGT :: "com \<Rightarrow> state assn \<times> com \<times> state assn" where
  "MGT c = (\<lambda>z s. z = s, c, \<lambda>z t. z -c\<rightarrow> t)"

declare MGT_def[simp]

text{*\noindent Note that the type of @{term z} has been identified with
@{typ state}.  This means that for every state variable there is an auxiliary
variable, which is simply there to record the value of the program variables
before execution of a command. This is exactly what, for example, VDM offers
by allowing you to refer to the pre-value of a variable in a
postcondition. The intuition behind @{term"MGT c"} is
that it completely describes the operational behaviour of @{term c}.  It is
easy to see that, in the presence of the new consequence rule,
\mbox{@{prop"{} \<turnstile> MGT c"}} implies completeness:*}

lemma MGT_implies_complete:
 "{} \<turnstile> MGT c  \<Longrightarrow>  {} \<Turnstile> {P}c{Q}  \<Longrightarrow>  {} \<turnstile> {P}c{Q::state assn}"
apply(simp add: MGT_def)
apply (erule hoare.Conseq)
apply(simp add: valid_defs)
done

text{* In order to discharge @{prop"{} \<turnstile> MGT c"} one proves*}

lemma MGT_lemma: "C \<turnstile> MGT CALL  \<Longrightarrow>  C \<turnstile> MGT c"
apply (simp)
apply(induct_tac c)
      apply (rule strengthen_pre[OF _ hoare.Do])
      apply blast
     apply(blast intro:hoare.Semi hoare.Conseq)
    apply(rule hoare.If)
    apply(erule hoare.Conseq)
     apply simp
    apply(erule hoare.Conseq)
    apply simp
   prefer 2
   apply simp
 apply(rename_tac b c)
 apply(rule hoare.Conseq)
  apply(rule_tac P = "\<lambda>z s. (z,s) \<in> ({(s,t). b s \<and> s -c\<rightarrow> t})^*"
        in hoare.While)
  apply(erule hoare.Conseq)
  apply(blast intro:rtrancl_into_rtrancl)
 apply clarsimp
 apply(rename_tac s t)
 apply(erule_tac x = s in allE)
 apply clarsimp
 apply(erule converse_rtrancl_induct)
  apply simp
 apply(fast elim:exec.WhileTrue)
apply(fastforce intro: hoare.Local elim!: hoare.Conseq)
done

text{*\noindent The proof is by induction on @{term c}. In the @{term
While}-case it is easy to show that @{term"\<lambda>z t. (z,t) \<in> ({(s,t). b
s \<and> s -c\<rightarrow> t})^*"} is invariant. The precondition \mbox{@{term[source]"\<lambda>z s. z=s"}}
establishes the invariant and a reflexive transitive closure
induction shows that the invariant conjoined with @{prop"\<not>b t"}
implies the postcondition \mbox{@{term"\<lambda>z t. z -WHILE b DO c\<rightarrow> t"}}. The
remaining cases are trivial.

Using the @{thm[source]MGT_lemma} (together with the @{text CALL} and the
assumption rule) one can easily derive *}

text{*\noindent Using the @{thm[source]MGT_lemma} once more we obtain
@{prop"{} \<turnstile> MGT c"} and thus by @{thm[source]MGT_implies_complete}
completeness.*}

theorem "{} \<Turnstile> {P}c{Q}  \<Longrightarrow>  {} \<turnstile> {P}c{Q::state assn}"
apply(erule MGT_implies_complete[OF MGT_lemma[OF MGT_CALL]])
done

end


(*<*)
theory Slicing
  imports Abstract_Monitor MFOTL
begin
(*>*)

section \<open>Slicing framework\<close>

text \<open>This section formalizes the abstract slicing framework and the joint data slicer
  presented in the article~\cite[Sections 4.2 and~4.3]{SchneiderBBKT-STTT20}.\<close>

subsection \<open>Abstract slicing\<close>

subsubsection \<open>Definition 1\<close>

text \<open>Corresponds to locale @{locale monitor} defined in theory
  @{theory MFOTL_Monitor_Devel.Abstract_Monitor}.\<close>

subsubsection \<open>Definition 2\<close>

locale slicer = monitor _ _ UNIV _ _ +
  fixes submonitor :: "'k :: finite \<Rightarrow> 'a prefix \<Rightarrow> (nat \<times> 'b option list) set"
  and   splitter :: "'a prefix \<Rightarrow> 'k \<Rightarrow> 'a prefix"
  and   joiner :: "('k \<Rightarrow> (nat \<times> 'b option list) set) \<Rightarrow> (nat \<times> 'b option list) set"
assumes mono_splitter: "\<pi> \<le> \<pi>' \<Longrightarrow> splitter \<pi> k \<le> splitter \<pi>' k"
  and   correct_slicer: "joiner (\<lambda>k. submonitor k (splitter \<pi> k)) = M \<pi>"
begin

lemmas sound_slicer = equalityD1[OF correct_slicer]
lemmas complete_slicer = equalityD2[OF correct_slicer]

end

locale self_slicer = slicer nfv fv sat M "\<lambda>_. M" splitter joiner for nfv fv sat M splitter joiner

subsubsection \<open>Definition 3\<close>

locale event_separable_splitter =
  fixes event_splitter :: "'a \<Rightarrow> 'k :: finite set"
begin

lift_definition splitter :: "'a prefix \<Rightarrow> 'k \<Rightarrow> 'a prefix" is
  "\<lambda>\<pi> k. map (\<lambda>(D, t). ({e \<in> D. k \<in> event_splitter e}, t)) \<pi>"
  by (auto simp: o_def split_beta)

subsubsection \<open>Lemma 1\<close>

lemma mono_splitter: "\<pi> \<le> \<pi>' \<Longrightarrow> splitter \<pi> k \<le> splitter \<pi>' k"
  by transfer auto

end

subsection \<open>Joint data slicer\<close>

abbreviation (input) "ok \<phi> v \<equiv> wf_tuple (MFOTL.nfv \<phi>) (MFOTL.fv \<phi>) v"

locale splitting_strategy =
  fixes \<phi> :: "'a MFOTL.formula"
  and strategy :: "'a option list \<Rightarrow> 'k :: finite set"
  assumes strategy_nonempty: "ok \<phi> v \<Longrightarrow> strategy v \<noteq> {}"
begin

abbreviation slice_set where
  "slice_set k \<equiv> {v. \<exists>v'. map the v' = v \<and> ok \<phi> v' \<and> k \<in> strategy v'}"

end

subsubsection \<open>Definition 4\<close>

locale MFOTL_monitor =
  monitor "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" UNIV "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>" M for \<phi> M

lemma (in MFOTL_monitor) prefixesI[simp, intro]: "\<pi> \<in> prefixes"
  by (simp add: prefixes_def ex_prefix_of)

locale joint_data_slicer = MFOTL_monitor \<phi> M + splitting_strategy \<phi> strategy
  for \<phi> M strategy
begin

definition event_splitter where
  "event_splitter e = (\<Union>(strategy ` {v. ok \<phi> v \<and> MFOTL.matches (map the v) \<phi> e}))"

sublocale event_separable_splitter where event_splitter = event_splitter .

definition joiner where
  "joiner = (\<lambda>s. \<Union>k. s k \<inter> (UNIV :: nat set) \<times> {v. k \<in> strategy v})"

lemma splitter_pslice: "splitter \<pi> k = MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>"
  by transfer (auto simp: event_splitter_def)

subsubsection \<open>Lemma 2\<close>

text \<open>Corresponds to the following theorem @{thm[source] sat_slice_strong} proved in theory
   @{theory MFOTL_Monitor_Devel.Abstract_Monitor}:

   @{thm sat_slice_strong[no_vars]}\<close>

subsubsection \<open>Theorem 1\<close>

sublocale joint_monitor: MFOTL_monitor \<phi> "\<lambda>\<pi>. joiner (\<lambda>k. M (splitter \<pi> k))"
proof (unfold_locales, goal_cases mono wf sound complete)
  case (mono \<pi> \<pi>')
  show ?case
    using mono_monitor[OF _ mono_splitter, OF _ mono(2)]
    by (auto simp: joiner_def)
next
  case (wf \<pi> i v)
  then obtain k where in_M: "(i, v) \<in> M (splitter \<pi> k)"  and k: "k \<in> strategy v"
    unfolding joiner_def by (auto split: if_splits)
  then show ?case
    using wf_monitor[OF _ in_M] by auto
next
  case (sound \<sigma> i v \<pi>)
  then obtain k where in_M: "(i, v) \<in> M (splitter \<pi> k)"  and k: "k \<in> strategy v"
    unfolding joiner_def by (auto split: if_splits)
  have wf: "ok \<phi> v" and sat: "\<And>\<sigma>. prefix_of (splitter \<pi> k) \<sigma> \<Longrightarrow> MFOTL.sat \<sigma> (map the v) i \<phi>"
    using sound_monitor[OF _ in_M] wf_monitor[OF _ in_M] by auto
  then have "MFOTL.sat \<sigma> (map the v) i \<phi>" if "prefix_of \<pi> \<sigma>" for \<sigma>
    using that k
    by (intro iffD2[OF sat_slice_iff[of "map the v" "slice_set k" \<sigma> i \<phi>]])
      (auto simp: wf_tuple_def fvi_less_nfv splitter_pslice intro!: exI[of _ v] prefix_of_pmap_\<Gamma>)
  then show ?case using sound(3) by blast
next
  case (complete \<sigma> \<pi> v i)
  with strategy_nonempty obtain k where k: "k \<in> strategy v" by blast
  have "MFOTL.sat \<sigma>' (map the v) i \<phi>" if "prefix_of (MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>) \<sigma>'" for \<sigma>'
  proof -
    have "MFOTL.sat \<sigma>' (map the v) i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>') (map the v) i \<phi>"
      using complete(3) k by (auto intro!: sat_slice_iff)
    also have "\<dots> = MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) (replace_prefix \<pi> \<sigma>')) (map the v) i \<phi>"
      using that complete k by (subst slice_replace_prefix[symmetric]; simp)
    also have "\<dots> = MFOTL.sat (replace_prefix \<pi> \<sigma>') (map the v) i \<phi>"
      using complete(3) k by (auto intro!: sat_slice_iff[symmetric])
    also have "\<dots>"
      by (rule complete(4)[OF UNIV_I, rule_format], rule prefix_of_replace_prefix[OF that])
    finally show ?thesis .
  qed
  with complete(1-3) obtain \<pi>' where \<pi>':
    "prefix_of \<pi>' (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>)" "(i, v) \<in> M \<pi>'"
    by (atomize_elim, intro complete_monitor[where \<pi>="MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>"])
      (auto simp: splitter_pslice intro!: prefix_of_pmap_\<Gamma>)
  from \<pi>'(1) obtain \<pi>'' where "\<pi>' = MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>''" "prefix_of \<pi>'' \<sigma>"
    by (atomize_elim, rule prefix_of_map_\<Gamma>_D)
  with \<pi>' k show ?case
    by (intro exI[of _ \<pi>'']) (auto simp: joiner_def splitter_pslice intro!: exI[of _ k])
qed

subsubsection \<open>Corollary 1\<close>

sublocale joint_slicer: slicer "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>"
  "\<lambda>\<pi>. joiner (\<lambda>k. M (splitter \<pi> k))" "\<lambda>_. M" splitter joiner
  by standard (auto simp: mono_splitter)

end

subsubsection \<open>Definition 5\<close>

text \<open>Corresponds to locale @{locale sliceable_monitor} defined in theory
  @{theory MFOTL_Monitor_Devel.Abstract_Monitor}.\<close>

locale slicable_joint_data_slicer =
  sliceable_monitor "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" UNIV "relevant_events \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>" M +
  joint_data_slicer \<phi> M strategy for \<phi> M strategy
begin

lemma monitor_split: "ok \<phi> v \<Longrightarrow> k \<in> strategy v \<Longrightarrow> (i, v) \<in> M (splitter \<pi> k) \<longleftrightarrow> (i, v) \<in> M \<pi>"
  unfolding splitter_pslice
  by (rule sliceable_M)
    (auto simp: wf_tuple_def fvi_less_nfv intro!: mem_restrI[rotated 2, where y="map the v"])

subsubsection \<open>Theorem 2\<close>

sublocale self_slicer "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>" M splitter joiner
proof (standard, erule mono_splitter, safe, goal_cases sound complete)
  case (sound \<pi> i v)
  have "ok \<phi> v" using joint_monitor.wf_monitor[OF _ sound] by auto
  from sound obtain k where "(i, v) \<in> M (splitter \<pi> k)" "k \<in> strategy v"
    unfolding joiner_def by blast
  with \<open>ok \<phi> v\<close> show ?case by (simp add: monitor_split)
next
  case (complete \<pi> i v)
  have "ok \<phi> v" using wf_monitor[OF _ complete] by auto
  with complete strategy_nonempty obtain k where k: "k \<in> strategy v" by blast
  then have "(i, v) \<in> M (splitter \<pi> k)" using complete \<open>ok \<phi> v\<close> by (simp add: monitor_split)
  with k show ?case unfolding joiner_def by blast
qed

end

subsubsection \<open>Towards Theorem 3\<close>

fun names :: "'a MFOTL.formula \<Rightarrow> MFOTL.name set" where
  "names (MFOTL.Pred e _) = {e}"
| "names (MFOTL.Eq _ _) = {}"
| "names (MFOTL.Neg \<psi>) = names \<psi>"
| "names (MFOTL.Or \<alpha> \<beta>) = names \<alpha> \<union> names \<beta>"
| "names (MFOTL.Exists \<psi>) = names \<psi>"
| "names (MFOTL.Prev I \<psi>) = names \<psi>"
| "names (MFOTL.Next I \<psi>) = names \<psi>"
| "names (MFOTL.Since \<alpha> I \<beta>) = names \<alpha> \<union> names \<beta>"
| "names (MFOTL.Until \<alpha> I \<beta>) = names \<alpha> \<union> names \<beta>"

fun gen_unique :: "'a MFOTL.formula \<Rightarrow> bool" where
  "gen_unique (MFOTL.Pred _ _) = True"
| "gen_unique (MFOTL.Eq (MFOTL.Var _) (MFOTL.Const _)) = False"
| "gen_unique (MFOTL.Eq (MFOTL.Const _) (MFOTL.Var _)) = False"
| "gen_unique (MFOTL.Eq _ _) = True"
| "gen_unique (MFOTL.Neg \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Or \<alpha> \<beta>) = (gen_unique \<alpha> \<and> gen_unique \<beta> \<and> names \<alpha> \<inter> names \<beta> = {})"
| "gen_unique (MFOTL.Exists \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Prev I \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Next I \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Since \<alpha> I \<beta>) = (gen_unique \<alpha> \<and> gen_unique \<beta> \<and> names \<alpha> \<inter> names \<beta> = {})"
| "gen_unique (MFOTL.Until \<alpha> I \<beta>) = (gen_unique \<alpha> \<and> gen_unique \<beta> \<and> names \<alpha> \<inter> names \<beta> = {})"

lemma sat_inter_names_cong: "(\<And>e. e \<in> names \<phi> \<Longrightarrow> {xs. (e, xs) \<in> E} = {xs. (e, xs) \<in> F}) \<Longrightarrow>
  MFOTL.sat (map_\<Gamma> (\<lambda>D. D \<inter> E) \<sigma>) v i \<phi> \<longleftrightarrow> MFOTL.sat (map_\<Gamma> (\<lambda>D. D \<inter> F) \<sigma>) v i \<phi>"
  by (induction \<phi> arbitrary: v i) (auto split: nat.splits)

lemma matches_in_names: "MFOTL.matches v \<phi> x \<Longrightarrow> fst x \<in> names \<phi>"
  by (induction \<phi> arbitrary: v) (auto)

lemma unique_names_matches_absorb: "fst x \<in> names \<alpha> \<Longrightarrow> names \<alpha> \<inter> names \<beta> = {} \<Longrightarrow>
    MFOTL.matches v \<alpha> x \<or> MFOTL.matches v \<beta> x \<longleftrightarrow> MFOTL.matches v \<alpha> x"
  "fst x \<in> names \<beta> \<Longrightarrow> names \<alpha> \<inter> names \<beta> = {} \<Longrightarrow>
    MFOTL.matches v \<alpha> x \<or> MFOTL.matches v \<beta> x \<longleftrightarrow> MFOTL.matches v \<beta> x"
  by (auto dest: matches_in_names)

definition mergeable_envs where
  "mergeable_envs n S \<longleftrightarrow> (\<forall>v1\<in>S. \<forall>v2\<in>S. (\<forall>A B f.
    (\<forall>x\<in>A. x < n \<and> v1 ! x = f x) \<and> (\<forall>x\<in>B. x < n \<and> v2 ! x = f x) \<longrightarrow>
    (\<exists>v\<in>S. \<forall>x\<in>A \<union> B. v ! x = f x)))"

lemma mergeable_envsI:
  assumes "\<And>v1 v2 v. v1 \<in> S \<Longrightarrow> v2 \<in> S \<Longrightarrow> length v = n \<Longrightarrow> \<forall>x < n. v ! x = v1 ! x \<or> v ! x = v2 ! x \<Longrightarrow> v \<in> S"
  shows "mergeable_envs n S"
  unfolding mergeable_envs_def
proof (safe, goal_cases mergeable)
  case [simp]: (mergeable v1 v2 A B f)
  let ?v = "tabulate (\<lambda>x. if x \<in> A \<union> B then f x else v1 ! x) 0 n"
  from assms[of v1 v2 ?v, simplified] show ?case
    by (auto intro!: bexI[of _ ?v])
qed

lemma in_listset_nth: "x \<in> listset As \<Longrightarrow> i < length As \<Longrightarrow> x ! i \<in> As ! i"
  by (induction As arbitrary: x i) (auto simp: set_Cons_def nth_Cons split: nat.split)

lemma all_nth_in_listset: "length x = length As \<Longrightarrow> (\<And>i. i < length As \<Longrightarrow> x ! i \<in> As ! i) \<Longrightarrow> x \<in> listset As"
  by (induction x As rule: list_induct2) (fastforce simp: set_Cons_def nth_Cons)+

lemma mergeable_envs_listset: "mergeable_envs (length As) (listset As)"
  by (rule mergeable_envsI) (auto intro!: all_nth_in_listset elim!: in_listset_nth)

lemma mergeable_envs_Ex: "mergeable_envs n S \<Longrightarrow> MFOTL.nfv \<alpha> \<le> n \<Longrightarrow> MFOTL.nfv \<beta> \<le> n \<Longrightarrow>
  (\<exists>v'\<in>S. \<forall>x\<in>fv \<alpha>. v' ! x = v ! x) \<Longrightarrow> (\<exists>v'\<in>S. \<forall>x\<in>fv \<beta>. v' ! x = v ! x) \<Longrightarrow>
  (\<exists>v'\<in>S. \<forall>x\<in>fv \<alpha> \<union> fv \<beta>. v' ! x = v ! x)"
proof (clarify, goal_cases mergeable)
  case (mergeable v1 v2)
  then show ?case
    by (auto intro: order.strict_trans2[OF fvi_less_nfv[rule_format]]
      elim!: mergeable_envs_def[THEN iffD1, rule_format, of _ _ v1 v2])
qed

lemma in_set_ConsE: "xs \<in> set_Cons A As \<Longrightarrow> (\<And>y ys. xs = y # ys \<Longrightarrow> y \<in> A \<Longrightarrow> ys \<in> As \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding set_Cons_def by blast

lemma mergeable_envs_set_Cons: "mergeable_envs n S \<Longrightarrow> mergeable_envs (Suc n) (set_Cons UNIV S)"
  unfolding mergeable_envs_def
proof (clarify, elim in_set_ConsE, goal_cases mergeable)
  case (mergeable v1 v2 A B f y1 ys1 y2 ys2)
  let ?A = "(\<lambda>x. x - 1) ` (A - {0})"
  let ?B = "(\<lambda>x. x - 1) ` (B - {0})"
  from mergeable(4-9) have "\<exists>v \<in> S. \<forall>x\<in>?A \<union> ?B. v ! x = f (Suc x)"
    by (auto dest!: mergeable(2,3)[rule_format] intro!: mergeable(1)[rule_format, of ys1 ys2])
  then obtain v where "v \<in> S" "\<forall>x\<in>?A \<union> ?B. v ! x = f (Suc x)" by blast
  then show ?case
    by (intro bexI[of _ "f 0 # v"]) (auto simp: nth_Cons' set_Cons_def)
qed

lemma slice_Exists: "MFOTL_slicer.slice (MFOTL.Exists \<phi>) S \<sigma> = MFOTL_slicer.slice \<phi> (set_Cons UNIV S) \<sigma>"
  by (auto simp: set_Cons_def intro: map_\<Gamma>_cong)

lemma image_Suc_fvi: "Suc ` MFOTL.fvi (Suc b) \<phi> = MFOTL.fvi b \<phi> - {0}"
  by (auto simp: image_def Bex_def MFOTL.fvi_Suc dest: gr0_implies_Suc)

lemma nfv_Exists: "MFOTL.nfv (MFOTL.Exists \<phi>) = MFOTL.nfv \<phi> - 1"
  unfolding MFOTL.nfv_def
  by (cases "fv \<phi> = {}") (auto simp add: image_Suc_fvi mono_Max_commute[symmetric] mono_def)

lemma set_Cons_empty_iff[simp]: "set_Cons A Xs = {} \<longleftrightarrow> A = {} \<or> Xs = {}"
  unfolding set_Cons_def by auto

lemma unique_sat_slice_mem: "safe_formula \<phi> \<Longrightarrow> gen_unique \<phi> \<Longrightarrow> S \<noteq> {} \<Longrightarrow>
  mergeable_envs n S \<Longrightarrow> MFOTL.nfv \<phi> \<le> n \<Longrightarrow>
  MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi> \<Longrightarrow> \<exists>v'\<in>S. \<forall>x\<in>fv \<phi>. v' ! x = v ! x"
proof (induction arbitrary: v i S n rule: safe_formula_induct)
  case (1 t1 t2)
  then show ?case by (cases "t2") (auto simp: MFOTL.is_Const_def)
next
  case (2 t1 t2)
  then show ?case by (cases "t1") (auto simp: MFOTL.is_Const_def)
next
  case (3 x y)
  then show ?case by auto
next
  case (4 x y)
  then show ?case by simp
next
  case (5 e ts)
  then obtain v' where "v' \<in> S" and eq: "\<forall>t\<in>set ts. MFOTL.eval_trm v' t = MFOTL.eval_trm v t"
    by auto
  have "\<forall>t\<in>set ts. \<forall>x\<in>fv_trm t. v' ! x = v ! x" proof
    fix t assume "t \<in> set ts"
    with eq have "MFOTL.eval_trm v' t = MFOTL.eval_trm v t" ..
    then show "\<forall>x\<in>fv_trm t. v' ! x = v ! x" by (cases t) (simp_all)
  qed
  with \<open>v' \<in> S\<close> show ?case by auto
next
  case (6 \<phi> \<psi>)
  from \<open>gen_unique (MFOTL.And \<phi> \<psi>)\<close>
  have
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.And \<phi> \<psi>) S \<sigma>) v i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.And \<phi> \<psi>) S \<sigma>) v i \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v i \<psi>"
    unfolding MFOTL.And_def
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)+
  with 6(1,4-) 6(2,3)[where S=S] show ?case
    unfolding MFOTL.And_def
    by (auto intro!: mergeable_envs_Ex)
next
  case (7 \<phi> \<psi>)
  from \<open>gen_unique (MFOTL.And_Not \<phi> \<psi>)\<close>
  have "MFOTL.sat (MFOTL_slicer.slice (MFOTL.And_Not \<phi> \<psi>) S \<sigma>) v i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    unfolding MFOTL.And_Not_def
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  with 7(1,2,5-) 7(3)[where S=S] have "\<exists>v'\<in>S. \<forall>x\<in>fv \<phi>. v' ! x = v ! x"
    unfolding MFOTL.And_Not_def by auto
  with \<open>fv \<psi> \<subseteq> fv \<phi>\<close> show ?case by (auto simp: MFOTL.fvi_And_Not)
next
  case (8 \<phi> \<psi>)
  from \<open>gen_unique (MFOTL.Or \<phi> \<psi>)\<close>
  have
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Or \<phi> \<psi>) S \<sigma>) v i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Or \<phi> \<psi>) S \<sigma>) v i \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v i \<psi>"
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)+
  with 8(1,4-) 8(2,3)[where S=S] have "\<exists>v'\<in>S. \<forall>x\<in>fv \<phi>. v' ! x = v ! x"
    by (auto simp: \<open>fv \<psi> = fv \<phi>\<close>)
  then show ?case by (auto simp: \<open>fv \<psi> = fv \<phi>\<close>)
next
  case (9 \<phi>)
  then obtain z where sat_\<phi>: "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Exists \<phi>) S \<sigma>) (z # v) i \<phi>"
    by auto
  from "9.prems" sat_\<phi> have "\<exists>v'\<in>set_Cons UNIV S. \<forall>x\<in>fv \<phi>. v' ! x = (z # v) ! x"
    unfolding slice_Exists
    by (intro "9.IH") (auto simp: nfv_Exists intro!: mergeable_envs_set_Cons)
  then show ?case
    by (auto simp: set_Cons_def fvi_Suc Ball_def nth_Cons split: nat.splits)
next
  case (10 I \<phi>)
  then obtain j where "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v j \<phi>"
    by (auto split: nat.splits)
  with 10 show ?case by simp
next
  case (11 I \<phi>)
  then obtain j where "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v j \<phi>"
    by (auto split: nat.splits)
  with 11 show ?case by simp
next
  case (12 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Since \<phi> I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since \<phi> I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 12 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since \<phi> I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 12 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv \<phi> \<subseteq> fv \<psi>\<close> show ?case by auto
next
  case (13 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Since (MFOTL.Neg \<phi>) I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 13 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 13 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv (MFOTL.Neg \<phi>) \<subseteq> fv \<psi>\<close> show ?case by auto
next
  case (14 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Until \<phi> I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until \<phi> I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 14 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until \<phi> I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 14 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv \<phi> \<subseteq> fv \<psi>\<close> show ?case by auto
next
  case (15 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Until (MFOTL.Neg \<phi>) I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 15 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 15 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv (MFOTL.Neg \<phi>) \<subseteq> fv \<psi>\<close> show ?case by auto
qed

lemma unique_sat_slice:
  assumes formula: "safe_formula \<phi>" "gen_unique \<phi>"
      and restr: "S \<noteq> {}" "mergeable_envs (MFOTL.nfv \<phi>) S"
      and sat_slice: "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    shows "MFOTL.sat \<sigma> v i \<phi>"
proof -
  obtain v' where "v' \<in> S" and fv_eq: "\<forall>x\<in>fv \<phi>. v' ! x = v ! x"
    using unique_sat_slice_mem[OF formula restr order_refl sat_slice] ..
  with sat_slice have "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v' i \<phi>"
    by (auto iff: sat_fvi_cong)
  then have "MFOTL.sat \<sigma> v' i \<phi>"
    unfolding sat_slice_iff[OF \<open>v' \<in> S\<close>, symmetric] .
  with fv_eq show ?thesis by (auto iff: sat_fvi_cong)
qed

subsubsection \<open>Lemma 3\<close>

lemma (in splitting_strategy) unique_sat_strategy:
  "safe_formula \<phi> \<Longrightarrow> gen_unique \<phi> \<Longrightarrow> slice_set k \<noteq> {} \<Longrightarrow>
  mergeable_envs (MFOTL.nfv \<phi>) (slice_set k) \<Longrightarrow>
  MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>) (map the v) i \<phi> \<Longrightarrow>
  ok \<phi> v \<Longrightarrow> k \<in> strategy v"
  by (drule (3) unique_sat_slice_mem) (auto dest: wf_tuple_cong)

locale skip_inter = joint_data_slicer +
  assumes nonempty: "slice_set k \<noteq> {}"
  and mergeable: "mergeable_envs (MFOTL.nfv \<phi>) (slice_set k)"
begin

subsubsection \<open>Definition of J'\<close>

definition "skip_joiner = (\<lambda>s. \<Union>k. s k)"

subsubsection \<open>Theorem 3\<close>

lemma skip_joiner:
  assumes "safe_formula \<phi>" "gen_unique \<phi>"
  shows "joiner (\<lambda>k. M (splitter \<pi> k)) = skip_joiner (\<lambda>k. M (splitter \<pi> k))"
  (is "?L = ?R")
proof safe
  fix i v
  assume "(i, v) \<in> ?R"
  then obtain k where in_M: "(i, v) \<in> M (splitter \<pi> k)"
  unfolding skip_joiner_def by blast
  from ex_prefix_of obtain \<sigma> where "prefix_of \<pi> \<sigma>" by blast
  with wf_monitor[OF _ in_M] sound_monitor[OF _ in_M] have
    "MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>) (map the v) i \<phi>" "ok \<phi> v"
    by (auto simp: splitter_pslice intro!: prefix_of_pmap_\<Gamma>)
  note unique_sat_strategy[OF assms nonempty mergeable this]
  with in_M show "(i, v) \<in> ?L" unfolding joiner_def by blast
qed (auto simp: joiner_def skip_joiner_def)

sublocale skip_joint_monitor: MFOTL_monitor \<phi>
  "\<lambda>\<pi>. (if safe_formula \<phi> \<and> gen_unique \<phi> then skip_joiner else joiner) (\<lambda>k. M (splitter \<pi> k))"
  using joint_monitor.mono_monitor joint_monitor.wf_monitor joint_monitor.sound_monitor joint_monitor.complete_monitor
  by unfold_locales (auto simp: skip_joiner[symmetric] split: if_splits)

end

(*<*)
end
(*>*)


theory Submission
  imports Defs
begin

inductive ls :: "com \<Rightarrow> state \<Rightarrow> state list \<Rightarrow> state \<Rightarrow> bool" where
  Skip: "ls SKIP s [] s" |
  Assign: "ls (v ::= e) s [s(v := aval e s)] (s(v := aval e s))" |
  Seq: "\<lbrakk>ls c1 s xs t'; ls c2 t' ys t\<rbrakk> \<Longrightarrow> ls (c1 ;; c2) s (xs@t'#ys) t" |
  IfTrue: "\<lbrakk>bval b s; ls c1 s xs t\<rbrakk> \<Longrightarrow> ls (IF b THEN c1 ELSE c2) s (s#xs) t" |
  IfFalse: "\<lbrakk>\<not>bval b s; ls c2 s xs t\<rbrakk> \<Longrightarrow> ls (IF b THEN c1 ELSE c2) s (s#xs) t" |
  WhileTrue: "\<lbrakk>bval b s1; ls c s1 xs s2 ; ls (WHILE b DO c) s2 ys s3\<rbrakk> \<Longrightarrow> ls (WHILE b DO c) s1 (s1#s1#xs@s2#ys) s3" |
  WhileFalse: "\<not>bval b s \<Longrightarrow> ls (WHILE b DO c) s [s, s] s"

declare ls.intros[intro]
declare ls.cases[elim]
code_pred ls .

theorem big_ls: "(c,s) \<Rightarrow> t \<Longrightarrow> \<exists>sts. ls c s sts t"
proof(induction c s t rule: big_step_induct)
  case (Assign x a s)
  then show ?case by blast
qed auto

theorem ls_big: "ls c s ss t \<Longrightarrow> (c,s) \<Rightarrow> t"
  by(induction c s ss t rule: ls.induct, blast+)

abbreviation "ss_x c s \<equiv> {map (\<lambda>s. s ''x'') ss |ss t . ls c s ss t}"
values "ss_x (IF Bc True THEN ''x'' ::= N 3 ELSE ''x'' ::= N 1) <>" \<comment>\<open>[0, 3]\<close>
values "ss_x (WHILE Less (V ''x'') (N 1) DO ''x'' ::= Plus (V ''x'') (N 1)) <>" \<comment>\<open>[0, 0, 1, 1, 1, 1]\<close>

lemma ls_step: "\<lbrakk>ls c s ss t; c \<noteq> SKIP\<rbrakk> \<Longrightarrow> (case ss of
  [] \<Rightarrow> (c,s) \<rightarrow> (SKIP,t)
| (x#_) \<Rightarrow> \<exists>c'. (c,s) \<rightarrow> (c',x))"
proof(induction c s ss t rule: ls.induct)
  case (Seq c1 s xs t' c2 ys t)
  then show ?case
  proof(cases "xs = Nil")
    case True
    then show ?thesis
      using Seq.hyps(1) by auto
  next
    case False
    then have c1_not_SKIP: "c1 \<noteq> SKIP"
      using Seq.hyps(1) by auto
    from False obtain z zs where zzs_def: "xs = z#zs"
      using list.exhaust_sel by auto
    with c1_not_SKIP  have "\<exists>c'. (c1, s) \<rightarrow> (c', z)"
      using Seq.IH(1) by auto
    then show ?thesis
      using zzs_def by auto
  qed
next
qed auto

lemma ls_ls: "\<lbrakk>ls c s\<^sub>1 (s\<^sub>2#ss) s\<^sub>3; (c,s\<^sub>1) \<rightarrow> (c',s\<^sub>2)\<rbrakk> \<Longrightarrow> ls c' s\<^sub>2 ss s\<^sub>3"
proof(induction c s\<^sub>1 "(s\<^sub>2#ss)" s\<^sub>3 arbitrary: ss c' s\<^sub>2 rule: ls.induct)
  case (Seq c1 s xs t' c2 ys t)
  then show ?case
  proof(cases "xs = Nil")
    case True
    then have c1_is_SKIP: "c1 = SKIP"
      using Seq.hyps(1) by auto
    then have "(c1;;c2,s) \<rightarrow> (c2,s)"
      by simp
    then have "c' = c2"
      using Seq.prems deterministic by blast
    then show ?thesis
      using Seq.hyps(3) Seq.hyps(5) True by fastforce
  next
    case False
    then have c1_not_SKIP: "c1 \<noteq> SKIP"
      using Seq.hyps(1) by auto
    then obtain c1' where c1_step: "(c1, s) \<rightarrow> (c1', s\<^sub>2)"
      using Seq.prems by auto
    have step: "(c1;;c2 ,s) \<rightarrow> (c1';;c2 ,s\<^sub>2)"
      by (simp add: c1_step)
    from False obtain z zs where zzs_def: "xs = z#zs"
      using list.exhaust_sel by auto
    then have "ls c1' s\<^sub>2 zs t'"
      using c1_step Seq.hyps(2) Seq.hyps(5) by force
    then have "ls (c1';;c2) s\<^sub>2 (zs@t'#ys) t"
      by (simp add: Seq.hyps(3) ls.Seq)
    moreover
    have "c' = (c1';;c2)"
      using Seq.prems deterministic step by fastforce
    ultimately show ?thesis
      using Seq.hyps(5) zzs_def by fastforce
  qed
next
  case (WhileTrue b c xs s2 ys s3)
  then show ?case
    using ls.IfTrue ls.Seq by fastforce
qed auto

lemma interstate_not_SKIP: "ls c s (x#xs) t \<Longrightarrow> c \<noteq> SKIP"
  by(induction c s "(x#xs)" t rule: ls.induct, auto)

theorem ls_steps: "ls c s\<^sub>1 (ss\<^sub>1@[s\<^sub>2]@ss\<^sub>2) t \<Longrightarrow> \<exists>c'. (c,s\<^sub>1) \<rightarrow>* (c',s\<^sub>2)"
proof(induction ss\<^sub>1 arbitrary: s\<^sub>1 c)
  case Nil
  then have ls_simp: "ls c s\<^sub>1 ([s\<^sub>2]@ss\<^sub>2) t"
    by simp
  moreover
  from ls_simp have "c \<noteq> SKIP"
    by (simp add: interstate_not_SKIP)
  ultimately have "\<exists>c'. (c,s\<^sub>1) \<rightarrow> (c',s\<^sub>2)"
    using ls_step by fastforce
  then show ?case
    by blast
next
  case (Cons a ss\<^sub>1)
  then have "c \<noteq> SKIP"
    by (simp add: interstate_not_SKIP)
  have first_step_ex: "\<exists>c'. (c,s\<^sub>1) \<rightarrow> (c',a)"
    using Cons.prems ls_step by fastforce
  then obtain c' where first_step: "(c,s\<^sub>1) \<rightarrow> (c',a)"
    by blast
  then have "ls c' a (ss\<^sub>1 @ [s\<^sub>2] @ ss\<^sub>2) t"
    using Cons.prems ls_ls
    by simp
  then have "\<exists>c''. (c', a) \<rightarrow>* (c'', s\<^sub>2)"
    by (simp add: Cons.IH)
  then show ?case
    using first_step star.step by meson
qed

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Monotonicity\<close>
theory Transport_Functions_Monotone
  imports
    Transport_Functions_Base
begin

paragraph \<open>Dependent Function Relator\<close>

context transport_Dep_Fun_Rel
begin

interpretation flip : transport_Dep_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

lemma mono_wrt_rel_leftI:
  assumes mono_r1: "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and mono_l2: "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow>
    ((\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub>)) (l2\<^bsub>x2' (r1 x1')\<^esub>)"
  and R2_le1: "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and R2_l2_le1: "\<And>x1' x2' y. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> in_dom (\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>) y \<Longrightarrow>
    (\<le>\<^bsub>R2 x1' x2'\<^esub>) (l2\<^bsub>x2' (r1 x1')\<^esub> y) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>) (l2\<^bsub>x1' (r1 x1')\<^esub> y)"
  and ge_R2_l2_le2: "\<And>x1' x2' y. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> in_codom (\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>) y \<Longrightarrow>
    (\<ge>\<^bsub>R2 x1' x2'\<^esub>) (l2\<^bsub>x2' (r1 x1')\<^esub> y) \<le> (\<ge>\<^bsub>R2 x1' x2'\<^esub>) (l2\<^bsub>x2' (r1 x2')\<^esub> y)"
  shows "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
proof (intro dep_mono_wrt_relI flip.left_relI)
  fix f1 f2 x1' x2' assume [iff]: "x1' \<le>\<^bsub>R1\<^esub> x2'"
  with mono_r1 have "r1 x1' \<le>\<^bsub>L1\<^esub> r1 x2'" (is "?x1 \<le>\<^bsub>L1\<^esub> ?x2") by blast
  moreover assume "f1 \<le>\<^bsub>L\<^esub> f2"
  ultimately have "f1 ?x1 \<le>\<^bsub>L2 ?x1 ?x2\<^esub> f2 ?x2" (is "?y1 \<le>\<^bsub>L2 ?x1 ?x2\<^esub> ?y2") by blast
  with mono_l2 have "l2\<^bsub>x2' ?x1\<^esub> ?y1 \<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub> l2\<^bsub>x2' ?x1\<^esub> ?y2" by blast
  with R2_le1 have "l2\<^bsub>x2' ?x1\<^esub> ?y1 \<le>\<^bsub>R2 x1' x2'\<^esub> l2\<^bsub>x2' ?x1\<^esub> ?y2" by blast
  with R2_l2_le1 have "l2\<^bsub>x1' ?x1\<^esub> ?y1 \<le>\<^bsub>R2 x1' x2'\<^esub> l2\<^bsub>x2' ?x1\<^esub> ?y2"
    using \<open>?y1 \<le>\<^bsub>L2 ?x1 ?x2\<^esub> _\<close>  by blast
  with ge_R2_l2_le2 have "l2\<^bsub>x1' ?x1\<^esub> ?y1 \<le>\<^bsub>R2 x1' x2'\<^esub> l2\<^bsub>x2' ?x2\<^esub> ?y2"
    using \<open>_ \<le>\<^bsub>L2 ?x1 ?x2\<^esub> ?y2\<close>  by blast
  then show "l f1 x1' \<le>\<^bsub>R2 x1' x2'\<^esub> l f2 x2'" by simp
qed

lemma mono_wrt_rel_left_in_dom_mono_left_assm:
  assumes "([in_dom (\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 x1' x2'\<^esub>))
    (l2\<^bsub>x1' (r1 x1')\<^esub>) (l2\<^bsub>x2' (r1 x1')\<^esub>)"
  and "transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "x1' \<le>\<^bsub>R1\<^esub> x2'"
  and "in_dom (\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>) y"
  shows "(\<le>\<^bsub>R2 x1' x2'\<^esub>) (l2\<^bsub>x2' (r1 x1')\<^esub> y) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>) (l2\<^bsub>x1' (r1 x1')\<^esub> y)"
  using assms by blast

lemma mono_wrt_rel_left_in_codom_mono_left_assm:
  assumes "([in_codom (\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 x1' x2'\<^esub>))
    (l2\<^bsub>x2' (r1 x1')\<^esub>) (l2\<^bsub>x2' (r1 x2')\<^esub>)"
  and "transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "x1' \<le>\<^bsub>R1\<^esub> x2'"
  and "in_codom (\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>) y"
  shows "(\<ge>\<^bsub>R2 x1' x2'\<^esub>) (l2\<^bsub>x2' (r1 x1')\<^esub> y) \<le> (\<ge>\<^bsub>R2 x1' x2'\<^esub>) (l2\<^bsub>x2' (r1 x2')\<^esub> y)"
  using assms by blast

lemma mono_wrt_rel_left_if_transitiveI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow>
    ((\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub>)) (l2\<^bsub>x2' (r1 x1')\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow>
    ([in_dom (\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 x1' x2'\<^esub>)) (l2\<^bsub>x1' (r1 x1')\<^esub>) (l2\<^bsub>x2' (r1 x1')\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow>
    ([in_codom (\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 x1' x2'\<^esub>)) (l2\<^bsub>x2' (r1 x1')\<^esub>) (l2\<^bsub>x2' (r1 x2')\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  using assms by (intro mono_wrt_rel_leftI
    mono_wrt_rel_left_in_dom_mono_left_assm
    mono_wrt_rel_left_in_codom_mono_left_assm)
  auto

lemma mono_wrt_rel_left2_if_mono_wrt_rel_left2_if_GaloisI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>)"
  shows "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow>
    ((\<le>\<^bsub>L2 (r1 x1') (r1 x2')\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub>)) (l2\<^bsub>x2' (r1 x1')\<^esub>)"
  using assms by (intro dep_mono_wrt_relI) fastforce

interpretation flip_inv :
  transport_Dep_Fun_Rel "(\<ge>\<^bsub>R1\<^esub>)" "(\<ge>\<^bsub>L1\<^esub>)" r1 l1 "flip2 R2" "flip2 L2" r2 l2
  rewrites "flip_inv.R \<equiv> (\<ge>\<^bsub>L\<^esub>)" and "flip_inv.L \<equiv> (\<ge>\<^bsub>R\<^esub>)"
  and "flip_inv.t1.counit \<equiv> \<eta>\<^sub>1"
  and "\<And>R x y. (flip2 R x y)\<inverse> \<equiv> R y x"
  and "\<And>R x1 x2. in_dom (flip2 R x1 x2) \<equiv> in_codom (R x2 x1)"
  and "\<And>R x1 x2. in_codom (flip2 R x1 x2) \<equiv> in_dom (R x2 x1)"
  and "\<And>R S. (R\<inverse> \<Rrightarrow>\<^sub>m S\<inverse>) \<equiv> (R \<Rrightarrow>\<^sub>m S)"
  and "\<And>x1 x2 x1' x2'. (flip2 R2 x1' x2' \<Rrightarrow>\<^sub>m flip2 L2 x1 x2) \<equiv>
    ((\<le>\<^bsub>R2 x2' x1'\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L2 x2 x1\<^esub>))"
  and "\<And>x1 x2 x3 x4. flip2 L2 x1 x2 \<le> flip2 L2 x3 x4 \<equiv> (\<le>\<^bsub>L2 x2 x1\<^esub>) \<le> (\<le>\<^bsub>L2 x4 x3\<^esub>)"
  and "\<And>x1' x2' y1 y2.
    flip_inv.dfro2.right_infix y1 x1' x2' \<le> flip_inv.dfro2.right_infix y2 x1' x2' \<equiv>
      (\<ge>\<^bsub>L2 x2' x1'\<^esub>) y1 \<le> (\<ge>\<^bsub>L2 x2' x1'\<^esub>) y2"
  and "\<And>P x1 x2. ([P] \<Rrightarrow> flip2 L2 x1 x2) \<equiv> ([P] \<Rrightarrow> (\<ge>\<^bsub>L2 x2 x1\<^esub>))"
  and "\<And>P R. ([P] \<Rrightarrow> R\<inverse>) \<equiv> ([P] \<Rrightarrow> R)\<inverse>"
  and "\<And>x1 x2. transitive (flip2 L2 x1 x2) \<equiv> transitive (\<le>\<^bsub>L2 x2 x1\<^esub>)"
  by (simp_all add: flip_inv_left_eq_ge_right flip_inv_right_eq_ge_left
    t1.flip_counit_eq_unit del: rel_inv_iff_rel)

lemma mono_wrt_rel_rightI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> ((\<le>\<^bsub>R2 (l1 x1) (l1 x2)\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>)) (r2\<^bsub>x1 (l1 x2)\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x1 x2 y'. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> in_codom (\<le>\<^bsub>R2 (l1 x1) (l1 x2)\<^esub>) y' \<Longrightarrow>
    (\<ge>\<^bsub>L2 x1 x2\<^esub>) (r2\<^bsub>x1 (l1 x2)\<^esub> y') \<le> (\<ge>\<^bsub>L2 x1 x2\<^esub>) (r2\<^bsub>x2 (l1 x2)\<^esub> y')"
  and "\<And>x1 x2 y'. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> in_dom (\<le>\<^bsub>R2 (l1 x1) (l1 x2)\<^esub>) y' \<Longrightarrow>
    (\<le>\<^bsub>L2 x1 x2\<^esub>) (r2\<^bsub>x1 (l1 x2)\<^esub> y') \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>) (r2\<^bsub>x1 (l1 x1)\<^esub> y')"
  shows "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  using assms by (intro flip_inv.mono_wrt_rel_leftI[simplified rel_inv_iff_rel])

lemma mono_wrt_rel_right_if_transitiveI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> ((\<le>\<^bsub>R2 (l1 x1) (l1 x2)\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>)) (r2\<^bsub>x1 (l1 x2)\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow>
    ([in_codom (\<le>\<^bsub>R2 (l1 x1) (l1 x2)\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 x1 x2\<^esub>)) (r2\<^bsub>x1 (l1 x2)\<^esub>) (r2\<^bsub>x2 (l1 x2)\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow>
    ([in_dom (\<le>\<^bsub>R2 (l1 x1) (l1 x2)\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 x1 x2\<^esub>)) (r2\<^bsub>x1 (l1 x1)\<^esub>) (r2\<^bsub>x1 (l1 x2)\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  shows "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  using assms by (intro flip_inv.mono_wrt_rel_left_if_transitiveI
    [simplified rel_inv_iff_rel])

lemma mono_wrt_rel_right2_if_mono_wrt_rel_right2_if_GaloisI:
  assumes assms1: "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1" "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and mono_r2: "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>R2 (l1 x) x'\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L2 x (r1 x')\<^esub>)) (r2\<^bsub>x x'\<^esub>)"
  shows "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> ((\<le>\<^bsub>R2 (l1 x1) (l1 x2)\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>)) (r2\<^bsub>x1 (l1 x2)\<^esub>)"
proof -
  show "((\<le>\<^bsub>R2 (l1 x1) (l1 x2)\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>)) (r2\<^bsub>x1 (l1 x2)\<^esub>)" if "x1 \<le>\<^bsub>L1\<^esub> x2" for x1 x2
  proof -
    from \<open>x1 \<le>\<^bsub>L1\<^esub> x2\<close> have "x1 \<^bsub>L1\<^esub>\<lessapprox> l1 x2"
      using assms1 by (intro t1.Galois_left_if_left_relI) blast
    with mono_r2 show ?thesis by auto
  qed
qed

end

paragraph \<open>Function Relator\<close>

context transport_Fun_Rel
begin

lemma mono_wrt_rel_leftI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  shows "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  using assms by (intro tdfr.mono_wrt_rel_leftI) simp_all

end

paragraph \<open>Monotone Dependent Function Relator\<close>

context transport_Mono_Dep_Fun_Rel
begin

lemmas mono_wrt_rel_leftI = mono_wrt_rel_Refl_Rel_Refl_Rel_if_mono_wrt_rel
  [of tdfr.L tdfr.R l, folded transport_defs]

end

paragraph \<open>Monotone Function Relator\<close>

context transport_Mono_Fun_Rel
begin

lemmas mono_wrt_rel_leftI = tpdfr.mono_wrt_rel_leftI[OF tfr.mono_wrt_rel_leftI]

end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |                 August 2007               |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_MF_MT
imports CSP_F_law_fp
begin

(*********************************************************
            MT = fstF o MF if fixed points exist
 *********************************************************)

(*--------------*
 |      cms     |
 *--------------*)

(*** fixed point ***)

lemma fstF_MF_fixed_point_cms:
      "[| Pf = PNfun; guardedfun Pf ; FPmode = CMSmode|]
        ==> [[Pf]]Tfun (fstF o MF) = (fstF o MF)"
apply (simp (no_asm) add: fun_eq_iff)
apply (simp add: semTfun_def)
apply (rule)
apply (subgoal_tac "$x =F Pf x")
apply (simp add: cspF_cspT_semantics)
apply (simp add: eqT_def)
apply (simp add: semTf_def)
apply (simp add: traces.simps)
apply (simp add: cspF_unwind)
done

(*** fstF o MF = MT ***)

lemma fstF_MF_MT_cms:
      "[| (Pf::'p=>('p,'a) proc) = PNfun; guardedfun Pf ; FPmode = CMSmode|]
        ==> (fstF o MF) = (MT::'p => 'a domT)"
apply (rule hasUFP_unique_solution[of "[[Pf]]Tfun"])
apply (simp add: semT_hasUFP_cms)
apply (simp add: fstF_MF_fixed_point_cms)
apply (simp add: MT_fixed_point_cms)
done

(*--------------*
 |    least     |
 *--------------*)

(*** fixed point ***)

lemma fstF_MF_fixed_point_cpo:
      "[| Pf = PNfun; FPmode = CPOmode | FPmode = MIXmode |]
        ==> [[Pf]]Tfun (fstF o MF) = (fstF o MF)"
apply (simp (no_asm) add: fun_eq_iff)
apply (simp add: semTfun_def)
apply (rule)
apply (subgoal_tac "$x =F Pf x")
apply (simp add: cspF_cspT_semantics)
apply (simp add: eqT_def)
apply (simp add: semTf_def)
apply (simp add: traces.simps)
apply (rule cspF_unwind)
apply (auto)
done

(*** fstF o MF = MT ***)

lemma MT_LFP_UnionT_cpo_lm:
  "(EX x. (EX n. x = ([[PNfun]]Tfun ^^ n) Bot) & y = x p)
  = (EX n. y = ([[PNfun]]Tfun ^^ n) Bot p)"
by (auto)

lemma MT_LFP_UnionT_cpo:
  "Pf = PNfun
   ==> LFP ([[Pf]]Tfun) p = UnionT {y. EX n. y = ([[Pf]]Tfun ^^ n) Bot p}"
apply (subgoal_tac
  "LFP ([[Pf]]Tfun) isLUB {x. EX n. x = ([[Pf]]Tfun^^n) Bot}")
apply (simp add: prod_LUB_decompo)
apply (drule_tac x="p" in spec)
apply (simp add: proj_fun_def)
apply (subgoal_tac "(%x. x p) ` {x. EX n. x = ([[Pf]]Tfun ^^ n) Bot} ~= {}")
apply (simp add: isLUB_UnionT)
apply (simp add: image_def)
apply (simp add: MT_LFP_UnionT_cpo_lm)
apply (force)

apply (simp add: Tarski_thm continuous_semTfun)
done

lemma fstF_MF_LFP_UnionT_cpo_lm1:
  "(EX b x.
        (EX xa. (EX n. xa = ([[Pf]]Ffun ^^ n) Bot) & x = xa p) &
        (y, b) = Rep_domF x) =
    (EX n. y = fstF (([[Pf]]Ffun ^^ n) Bot p))"
apply (auto)

apply (rule_tac x="n" in exI)
apply (simp add: pair_eq_decompo)
apply (simp add: fstF_def)

apply (rule_tac x="(sndF (([[Pf]]Ffun ^^ n) Bot p))" in exI)
apply (rule_tac x="([[Pf]]Ffun ^^ n) Bot p" in exI)
apply (rule conjI)
apply (force)

apply (subgoal_tac
 "Rep_domF(Abs_domF(fstF (([[Pf]]Ffun ^^ n) Bot p),
                    sndF (([[Pf]]Ffun ^^ n) Bot p)))
  = Rep_domF (([[Pf]]Ffun ^^ n) Bot p)")
apply (simp add: Abs_domF_inverse)
apply (simp add: Rep_domF_inject)
apply (fold pairF_def)
apply (simp)
done

lemma fstF_MF_LFP_UnionT_cpo_lm2:
  "LFP ([[Pf]]Ffun) p =
   LUB_domF ((%x. x p) ` {x. EX n. x = ([[Pf]]Ffun ^^ n) Bot})"
apply (subgoal_tac "LFP ([[Pf]]Ffun) isLUB {x. EX n. x = ([[Pf]]Ffun ^^n) Bot}")
apply (rule isLUB_LUB_domF_only_if)
apply (force)
apply (simp add: prod_LUB_decompo)
apply (drule_tac x="p" in spec)
apply (simp add: proj_fun_def)
apply (simp add: Tarski_thm continuous_semFfun)
done

lemma fstF_MF_LFP_UnionT_cpo:
  "Pf = PNfun
   ==> fstF (LFP ([[Pf]]Ffun) p) =
       UnionT {y. EX n. y = fstF (([[Pf]]Ffun ^^ n) Bot p)}"
apply (subgoal_tac
  "fstF (LFP ([[Pf]]Ffun) p) =
   fstF (LUB_domF ((%x. x p) ` {x. EX n. x = ([[Pf]]Ffun ^^ n) Bot}))")
apply (simp add: LUB_domF_def)
apply (simp add: fstF_def)
apply (subgoal_tac "(%x. x p) ` {x. EX n. x = ([[Pf]]Ffun ^^ n) Bot} ~= {}")
apply (simp add: LUB_TF_in_Rep Abs_domF_inverse)
apply (simp add: LUB_TF_def)
apply (simp add: image_def)
apply (simp add: fstF_MF_LFP_UnionT_cpo_lm1)
apply (simp add: fstF_def)
apply (force)
apply (simp add: fstF_MF_LFP_UnionT_cpo_lm2)
done

(* Tfun and fst Ffun *)

lemma iterative_fstF_semFfun_semFfun:
  "ALL p. (fstF (([[Pf]]Ffun ^^ n) Bot p)) = (([[Pf]]Tfun ^^ n) Bot p)"
apply (induct_tac n)

(* base *)
 apply (simp add: prod_Bot_def)
 apply (simp add: bottom_domF_def)
 apply (simp add: pairF)
 apply (simp add: bottom_domT_def)

(* step *)
 apply (simp add: semFfun_def)
 apply (simp add: comp_def)
 apply (simp add: semTfun_def)
 apply (simp add: semTf_def)
done

(*** fstF o MF = MT ***)

lemma fstF_MF_MT_cpo_lm:
  "Pf = PNfun
   ==> fstF (LFP ([[Pf]]Ffun) p) = LFP ([[Pf]]Tfun) p"
apply (simp add: MT_LFP_UnionT_cpo)
apply (simp add: fstF_MF_LFP_UnionT_cpo)
apply (simp add: iterative_fstF_semFfun_semFfun)
done

lemma fstF_MF_MT_cpo:
 "[| (Pf::'p=>('p,'a) proc) = PNfun; FPmode = CPOmode | FPmode = MIXmode |]
  ==> (fstF o MF) = (MT::'p => 'a domT)"
apply (simp add: MF_def MT_def)
apply (simp add: semTfix_def semFfix_def)
apply (auto)
apply (simp_all add: fun_eq_iff)
apply (simp_all add: fstF_MF_MT_cpo_lm)
done

(*===================================*
              conclusion
 *===================================*)

lemma fstF_MF_MT:
 "[| (Pf::'p=>('p,'a) proc) = PNfun;
       FPmode = CPOmode
     | FPmode = CMSmode & guardedfun Pf
     | FPmode = MIXmode |]
  ==> (fstF o MF) = (MT::'p => 'a domT)"
apply (elim conjE disjE)
apply (simp add: fstF_MF_MT_cpo)
apply (simp add: fstF_MF_MT_cms)
apply (simp add: fstF_MF_MT_cpo)
done

end


header {* Assertions, commands, and separation logic proof rules *}

theory Ribbons_Basic imports
  Main
begin

text {* We define a command language, assertions, and the rules of separation
  logic, plus some derived rules that are used by our tool. This is the only
  theory file that is loaded by the tool. We keep it as small as possible.
*}

subsection {* Assertions *}

text {* The language of assertions includes (at least) an emp constant,
  a star-operator, and existentially-quantified logical variables. *}

typedecl assertion

axiomatization
  Emp :: "assertion"

axiomatization
  Star :: "assertion \<Rightarrow> assertion \<Rightarrow> assertion" (infixr "\<star>" 55)
where
  star_comm: "p \<star> q = q \<star> p" and
  star_assoc: "(p \<star> q) \<star> r = p \<star> (q \<star> r)" and
  star_emp: "p \<star> Emp = p" and
  emp_star: "Emp \<star> p = p"

lemma star_rot:
  "q \<star> p \<star> r = p \<star> q \<star> r"
using star_assoc star_comm by auto

axiomatization
  Exists :: "string \<Rightarrow> assertion \<Rightarrow> assertion"

text {* Extracting the set of program variables mentioned in an assertion. *}
axiomatization
  rd_ass :: "assertion \<Rightarrow> string set"
where rd_emp: "rd_ass Emp = {}"
  and rd_star: "rd_ass (p \<star> q) = rd_ass p \<union> rd_ass q"
  and rd_exists: "rd_ass (Exists x p) = rd_ass p"

subsection {* Commands *}

text {* The language of commands comprises (at least) non-deterministic
  choice, non-deterministic looping, skip and sequencing. *}

typedecl command

axiomatization
  Choose :: "command \<Rightarrow> command \<Rightarrow> command"

axiomatization
  Loop :: "command \<Rightarrow> command"

axiomatization
  Skip :: "command"

axiomatization
  Seq :: "command \<Rightarrow> command \<Rightarrow> command" (infixr ";;" 55)
where seq_assoc: "c1 ;; (c2 ;; c3) = (c1 ;; c2) ;; c3"
  and seq_skip: "c ;; Skip = c"
  and skip_seq: "Skip ;; c = c"

text {* Extracting the set of program variables read by a command. *}
axiomatization
  rd_com :: "command \<Rightarrow> string set"
where rd_com_choose: "rd_com (Choose c1 c2) = rd_com c1 \<union> rd_com c2"
  and rd_com_loop: "rd_com (Loop c) = rd_com c"
  and rd_com_skip: "rd_com (Skip) = {}"
  and rd_com_seq: "rd_com (c1 ;; c2) = rd_com c1 \<union> rd_com c2"

text {* Extracting the set of program variables written by a command. *}
axiomatization
  wr_com :: "command \<Rightarrow> string set"
where wr_com_choose: "wr_com (Choose c1 c2) = wr_com c1 \<union> wr_com c2"
  and wr_com_loop: "wr_com (Loop c) = wr_com c"
  and wr_com_skip: "wr_com (Skip) = {}"
  and wr_com_seq: "wr_com (c1 ;; c2) = wr_com c1 \<union> wr_com c2"

subsection {* Separation logic proof rules *}

text {* Note that the frame rule has a side-condition concerning program
  variables. When proving the soundness of our graphical formalisation of
  ribbon proofs, we shall omit this side-condition. *}

inductive
  prov_triple :: "assertion \<times> command \<times> assertion \<Rightarrow> bool"
where
  exists: "prov_triple (p, c, q) \<Longrightarrow> prov_triple (Exists x p, c, Exists x q)"
| choose: "\<lbrakk> prov_triple (p, c1, q); prov_triple (p, c2, q) \<rbrakk>
  \<Longrightarrow> prov_triple (p, Choose c1 c2, q)"
| loop: "prov_triple (p, c, p) \<Longrightarrow> prov_triple (p, Loop c, p)"
| frame: "\<lbrakk> prov_triple (p, c, q); wr_com(c) \<inter> rd_ass(r) = {} \<rbrakk>
  \<Longrightarrow> prov_triple (p \<star> r, c, q \<star> r)"
| skip: "prov_triple (p, Skip, p)"
| seq: "\<lbrakk> prov_triple (p, c1, q); prov_triple (q, c2, r) \<rbrakk>
  \<Longrightarrow> prov_triple (p, c1 ;; c2, r)"

text {* Here are some derived proof rules, which are used in our
  ribbon-checking tool. *}

lemma choice_lemma:
  assumes "prov_triple (p1, c1, q1)" and "prov_triple (p2, c2, q2)"
    and "p = p1" and "p1 = p2" and "q = q1" and "q1 = q2"
  shows "prov_triple (p, Choose c1 c2, q)"
using assms prov_triple.choose by auto

lemma loop_lemma:
  assumes "prov_triple (p1, c, q1)" and "p = p1" and "p1 = q1" and "q1 = q"
  shows "prov_triple (p, Loop c, q)"
using assms prov_triple.loop by auto

lemma seq_lemma:
  assumes "prov_triple (p1, c1, q1)" and "prov_triple (p2, c2, q2)"
    and "q1 = p2"
  shows "prov_triple (p1, c1 ;; c2, q2)"
using assms prov_triple.seq by auto

end


(*  Title:      HOL/MicroJava/DFA/Typing_Framework_err.thy
    Author:     Gerwin Klein
    Copyright   2000 TUM
*)

section \<open>Lifting the Typing Framework to err, app, and eff\<close>

theory Typing_Framework_err
imports Typing_Framework SemilatAlg
begin

definition wt_err_step :: "'s ord \<Rightarrow> 's err step_type \<Rightarrow> 's err list \<Rightarrow> bool" where
"wt_err_step r step ts \<equiv> wt_step (Err.le r) Err step ts"

definition wt_app_eff :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool" where
"wt_app_eff r app step ts \<equiv>
  \<forall>p < size ts. app p (ts!p) \<and> (\<forall>(q,t) \<in> set (step p (ts!p)). t <=_r ts!q)"

definition map_snd :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'c) list" where
"map_snd f \<equiv> map (\<lambda>(x,y). (x, f y))"

definition error :: "nat \<Rightarrow> (nat \<times> 'a err) list" where
"error n \<equiv> map (\<lambda>x. (x,Err)) [0..<n]"

definition err_step :: "nat \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's err step_type" where
"err_step n app step p t \<equiv>
  case t of
    Err   \<Rightarrow> error n
  | OK t' \<Rightarrow> if app p t' then map_snd OK (step p t') else error n"

definition app_mono :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool" where
"app_mono r app n A \<equiv>
 \<forall>s p t. s \<in> A \<and> p < n \<and> s <=_r t \<longrightarrow> app p t \<longrightarrow> app p s"

lemmas err_step_defs = err_step_def map_snd_def error_def

lemma bounded_err_stepD:
  "bounded (err_step n app step) n \<Longrightarrow>
  p < n \<Longrightarrow>  app p a \<Longrightarrow> (q,b) \<in> set (step p a) \<Longrightarrow>
  q < n"
  apply (simp add: bounded_def err_step_def)
  apply (erule allE, erule impE, assumption)
  apply (erule_tac x = "OK a" in allE, drule bspec)
   apply (simp add: map_snd_def)
   apply fast
  apply simp
  done

lemma in_map_sndD: "(a,b) \<in> set (map_snd f xs) \<Longrightarrow> \<exists>b'. (a,b') \<in> set xs"
  apply (induct xs)
  apply (auto simp add: map_snd_def)
  done

lemma bounded_err_stepI:
  "\<forall>p. p < n \<longrightarrow> (\<forall>s. ap p s \<longrightarrow> (\<forall>(q,s') \<in> set (step p s). q < n))
  \<Longrightarrow> bounded (err_step n ap step) n"
apply (clarsimp simp: bounded_def err_step_def split: err.splits)
apply (simp add: error_def image_def)
apply (blast dest: in_map_sndD)
done

lemma bounded_lift:
  "bounded step n \<Longrightarrow> bounded (err_step n app step) n"
  apply (unfold bounded_def err_step_def error_def)
  apply clarify
  apply (erule allE, erule impE, assumption)
  apply (case_tac s)
  apply (auto simp add: map_snd_def split: if_split_asm)
  done

lemma le_list_map_OK [simp]:
  "\<And>b. map OK a <=[Err.le r] map OK b = (a <=[r] b)"
  apply (induct a)
   apply simp
  apply simp
  apply (case_tac b)
   apply simp
  apply simp
  done

lemma map_snd_lessI:
  "x \<le>|r| y \<Longrightarrow> map_snd OK x \<le>|Err.le r| map_snd OK y"
  apply (induct x)
  apply (unfold lesubstep_type_def map_snd_def)
  apply auto
  done

lemma mono_lift:
  "order r \<Longrightarrow> app_mono r app n A \<Longrightarrow> bounded (err_step n app step) n \<Longrightarrow>
  \<forall>s p t. s \<in> A \<and> p < n \<and> s <=_r t \<longrightarrow> app p t \<longrightarrow> step p s \<le>|r| step p t \<Longrightarrow>
  mono (Err.le r) (err_step n app step) n (err A)"
apply (simp only: app_mono_def mono_def err_step_def)
apply clarify
apply (case_tac s)
 apply simp
apply simp
apply (case_tac t)
 apply simp
 apply clarify
 apply (simp add: lesubstep_type_def error_def)
 apply clarify
 apply (drule in_map_sndD)
 apply clarify
 apply (drule bounded_err_stepD, assumption+)
 apply (rule exI [of _ Err])
 apply simp
apply simp
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (rule conjI)
apply clarify
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (erule impE, assumption)
apply (rule map_snd_lessI, assumption)
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
done

lemma in_errorD:
  "(x,y) \<in> set (error n) \<Longrightarrow> y = Err"
  by (auto simp add: error_def)

lemma pres_type_lift:
  "\<forall>s\<in>A. \<forall>p. p < n \<longrightarrow> app p s \<longrightarrow> (\<forall>(q, s')\<in>set (step p s). s' \<in> A)
  \<Longrightarrow> pres_type (err_step n app step) n (err A)"
apply (unfold pres_type_def err_step_def)
apply clarify
apply (case_tac b)
 apply simp
apply (case_tac s)
 apply simp
 apply (drule in_errorD)
 apply simp
apply (simp add: map_snd_def split: if_split_asm)
 apply fast
apply (drule in_errorD)
apply simp
done

text \<open>
  There used to be a condition here that each instruction must have a
  successor. This is not needed any more, because the definition of
  \<^term>\<open>error\<close> trivially ensures that there is a successor for
  the critical case where \<^term>\<open>app\<close> does not hold.
\<close>
lemma wt_err_imp_wt_app_eff:
  assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
  assumes b:  "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_app_eff r app step (map ok_val ts)"
proof (unfold wt_app_eff_def, intro strip, rule conjI)
  fix p assume "p < size (map ok_val ts)"
  hence lp: "p < size ts" by simp
  hence ts: "0 < size ts" by (cases p) auto
  hence err: "(0,Err) \<in> set (error (size ts))" by (simp add: error_def)

  from wt lp
  have [intro?]: "\<And>p. p < size ts \<Longrightarrow> ts ! p \<noteq> Err"
    by (unfold wt_err_step_def wt_step_def) simp

  show app: "app p (map ok_val ts ! p)"
  proof (rule ccontr)
    from wt lp obtain s where
      OKp:  "ts ! p = OK s" and
      less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def)
         (auto iff: not_Err_eq)
    assume "\<not> app p (map ok_val ts ! p)"
    with OKp lp have "\<not> app p s" by simp
    with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)"
      by (simp add: err_step_def)
    with err ts obtain q where
      "(q,Err) \<in> set (err_step (size ts) app step p (ts!p))" and
      q: "q < size ts" by auto
    with less have "ts!q = Err" by auto
    moreover from q have "ts!q \<noteq> Err" ..
    ultimately show False by blast
  qed

  show "\<forall>(q,t)\<in>set(step p (map ok_val ts ! p)). t <=_r map ok_val ts ! q"
  proof clarify
    fix q t assume q: "(q,t) \<in> set (step p (map ok_val ts ! p))"

    from wt lp q
    obtain s where
      OKp:  "ts ! p = OK s" and
      less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def)
         (auto iff: not_Err_eq)

    from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
    hence "ts!q \<noteq> Err" ..
    then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)

    from lp lq OKp OKq app less q
    show "t <=_r map ok_val ts ! q"
      by (auto simp add: err_step_def map_snd_def)
  qed
qed

lemma wt_app_eff_imp_wt_err:
  assumes app_eff: "wt_app_eff r app step ts"
  assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
  fix p assume "p < size (map OK ts)"
  hence p: "p < size ts" by simp
  thus "map OK ts ! p \<noteq> Err" by simp
  { fix q t
    assume q: "(q,t) \<in> set (err_step (size ts) app step p (map OK ts ! p))"
    with p app_eff obtain
      "app p (ts ! p)" "\<forall>(q,t) \<in> set (step p (ts!p)). t <=_r ts!q"
      by (unfold wt_app_eff_def) blast
    moreover
    from q p bounded have "q < size ts"
      by - (rule boundedD)
    hence "map OK ts ! q = OK (ts!q)" by simp
    moreover
    have "p < size ts" by (rule p)
    moreover note q
    ultimately
    have "t <=_(Err.le r) map OK ts ! q"
      by (auto simp add: err_step_def map_snd_def)
  }
  thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
    by (unfold stable_def) blast
qed

end