(*  Title:      ZF/Constructible/Reflection.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>The Reflection Theorem\<close>

theory Reflection imports Normal begin

lemma all_iff_not_ex_not: "(\<forall>x. P(x)) \<longleftrightarrow> (~ (\<exists>x. ~ P(x)))"
by blast

lemma ball_iff_not_bex_not: "(\<forall>x\<in>A. P(x)) \<longleftrightarrow> (~ (\<exists>x\<in>A. ~ P(x)))"
by blast

text\<open>From the notes of A. S. Kechris, page 6, and from
      Andrzej Mostowski, \emph{Constructible Sets with Applications},
      North-Holland, 1969, page 23.\<close>

subsection\<open>Basic Definitions\<close>

text\<open>First part: the cumulative hierarchy defining the class \<open>M\<close>.
To avoid handling multiple arguments, we assume that \<open>Mset(l)\<close> is
closed under ordered pairing provided \<open>l\<close> is limit.  Possibly this
could be avoided: the induction hypothesis \<^term>\<open>Cl_reflects\<close>
(in locale \<open>ex_reflection\<close>) could be weakened to
\<^term>\<open>\<forall>y\<in>Mset(a). \<forall>z\<in>Mset(a). P(<y,z>) \<longleftrightarrow> Q(a,<y,z>)\<close>, removing most
uses of \<^term>\<open>Pair_in_Mset\<close>.  But there isn't much point in doing so, since
ultimately the \<open>ex_reflection\<close> proof is packaged up using the
predicate \<open>Reflects\<close>.
\<close>
locale reflection =
  fixes Mset and M and Reflects
  assumes Mset_mono_le : "mono_le_subset(Mset)"
      and Mset_cont    : "cont_Ord(Mset)"
      and Pair_in_Mset : "[| x \<in> Mset(a); y \<in> Mset(a); Limit(a) |]
                          ==> <x,y> \<in> Mset(a)"
  defines "M(x) == \<exists>a. Ord(a) & x \<in> Mset(a)"
      and "Reflects(Cl,P,Q) == Closed_Unbounded(Cl) &
                              (\<forall>a. Cl(a) \<longrightarrow> (\<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x)))"
  fixes F0 \<comment> \<open>ordinal for a specific value \<^term>\<open>y\<close>\<close>
  fixes FF \<comment> \<open>sup over the whole level, \<^term>\<open>y\<in>Mset(a)\<close>\<close>
  fixes ClEx \<comment> \<open>Reflecting ordinals for the formula \<^term>\<open>\<exists>z. P\<close>\<close>
  defines "F0(P,y) == \<mu> b. (\<exists>z. M(z) & P(<y,z>)) \<longrightarrow>
                               (\<exists>z\<in>Mset(b). P(<y,z>))"
      and "FF(P)   == \<lambda>a. \<Union>y\<in>Mset(a). F0(P,y)"
      and "ClEx(P,a) == Limit(a) & normalize(FF(P),a) = a"

lemma (in reflection) Mset_mono: "i\<le>j ==> Mset(i) \<subseteq> Mset(j)"
apply (insert Mset_mono_le)
apply (simp add: mono_le_subset_def leI)
done

text\<open>Awkward: we need a version of \<open>ClEx_def\<close> as an equality
      at the level of classes, which do not really exist\<close>
lemma (in reflection) ClEx_eq:
     "ClEx(P) == \<lambda>a. Limit(a) & normalize(FF(P),a) = a"
by (simp add: ClEx_def [symmetric])

subsection\<open>Easy Cases of the Reflection Theorem\<close>

theorem (in reflection) Triv_reflection [intro]:
     "Reflects(Ord, P, \<lambda>a x. P(x))"
by (simp add: Reflects_def)

theorem (in reflection) Not_reflection [intro]:
     "Reflects(Cl,P,Q) ==> Reflects(Cl, \<lambda>x. ~P(x), \<lambda>a x. ~Q(a,x))"
by (simp add: Reflects_def)

theorem (in reflection) And_reflection [intro]:
     "[| Reflects(Cl,P,Q); Reflects(C',P',Q') |]
      ==> Reflects(\<lambda>a. Cl(a) & C'(a), \<lambda>x. P(x) & P'(x),
                                      \<lambda>a x. Q(a,x) & Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

theorem (in reflection) Or_reflection [intro]:
     "[| Reflects(Cl,P,Q); Reflects(C',P',Q') |]
      ==> Reflects(\<lambda>a. Cl(a) & C'(a), \<lambda>x. P(x) | P'(x),
                                      \<lambda>a x. Q(a,x) | Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

theorem (in reflection) Imp_reflection [intro]:
     "[| Reflects(Cl,P,Q); Reflects(C',P',Q') |]
      ==> Reflects(\<lambda>a. Cl(a) & C'(a),
                   \<lambda>x. P(x) \<longrightarrow> P'(x),
                   \<lambda>a x. Q(a,x) \<longrightarrow> Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

theorem (in reflection) Iff_reflection [intro]:
     "[| Reflects(Cl,P,Q); Reflects(C',P',Q') |]
      ==> Reflects(\<lambda>a. Cl(a) & C'(a),
                   \<lambda>x. P(x) \<longleftrightarrow> P'(x),
                   \<lambda>a x. Q(a,x) \<longleftrightarrow> Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

subsection\<open>Reflection for Existential Quantifiers\<close>

lemma (in reflection) F0_works:
     "[| y\<in>Mset(a); Ord(a); M(z); P(<y,z>) |] ==> \<exists>z\<in>Mset(F0(P,y)). P(<y,z>)"
apply (unfold F0_def M_def, clarify)
apply (rule LeastI2)
  apply (blast intro: Mset_mono [THEN subsetD])
 apply (blast intro: lt_Ord2, blast)
done

lemma (in reflection) Ord_F0 [intro,simp]: "Ord(F0(P,y))"
by (simp add: F0_def)

lemma (in reflection) Ord_FF [intro,simp]: "Ord(FF(P,y))"
by (simp add: FF_def)

lemma (in reflection) cont_Ord_FF: "cont_Ord(FF(P))"
apply (insert Mset_cont)
apply (simp add: cont_Ord_def FF_def, blast)
done

text\<open>Recall that \<^term>\<open>F0\<close> depends upon \<^term>\<open>y\<in>Mset(a)\<close>,
while \<^term>\<open>FF\<close> depends only upon \<^term>\<open>a\<close>.\<close>
lemma (in reflection) FF_works:
     "[| M(z); y\<in>Mset(a); P(<y,z>); Ord(a) |] ==> \<exists>z\<in>Mset(FF(P,a)). P(<y,z>)"
apply (simp add: FF_def)
apply (simp_all add: cont_Ord_Union [of concl: Mset]
                     Mset_cont Mset_mono_le not_emptyI)
apply (blast intro: F0_works)
done

lemma (in reflection) FFN_works:
     "[| M(z); y\<in>Mset(a); P(<y,z>); Ord(a) |]
      ==> \<exists>z\<in>Mset(normalize(FF(P),a)). P(<y,z>)"
apply (drule FF_works [of concl: P], assumption+)
apply (blast intro: cont_Ord_FF le_normalize [THEN Mset_mono, THEN subsetD])
done

text\<open>Locale for the induction hypothesis\<close>

locale ex_reflection = reflection +
  fixes P  \<comment> \<open>the original formula\<close>
  fixes Q  \<comment> \<open>the reflected formula\<close>
  fixes Cl \<comment> \<open>the class of reflecting ordinals\<close>
  assumes Cl_reflects: "[| Cl(a); Ord(a) |] ==> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x)"

lemma (in ex_reflection) ClEx_downward:
     "[| M(z); y\<in>Mset(a); P(<y,z>); Cl(a); ClEx(P,a) |]
      ==> \<exists>z\<in>Mset(a). Q(a,<y,z>)"
apply (simp add: ClEx_def, clarify)
apply (frule Limit_is_Ord)
apply (frule FFN_works [of concl: P], assumption+)
apply (drule Cl_reflects, assumption+)
apply (auto simp add: Limit_is_Ord Pair_in_Mset)
done

lemma (in ex_reflection) ClEx_upward:
     "[| z\<in>Mset(a); y\<in>Mset(a); Q(a,<y,z>); Cl(a); ClEx(P,a) |]
      ==> \<exists>z. M(z) & P(<y,z>)"
apply (simp add: ClEx_def M_def)
apply (blast dest: Cl_reflects
             intro: Limit_is_Ord Pair_in_Mset)
done

text\<open>Class \<open>ClEx\<close> indeed consists of reflecting ordinals...\<close>
lemma (in ex_reflection) ZF_ClEx_iff:
     "[| y\<in>Mset(a); Cl(a); ClEx(P,a) |]
      ==> (\<exists>z. M(z) & P(<y,z>)) \<longleftrightarrow> (\<exists>z\<in>Mset(a). Q(a,<y,z>))"
by (blast intro: dest: ClEx_downward ClEx_upward)

text\<open>...and it is closed and unbounded\<close>
lemma (in ex_reflection) ZF_Closed_Unbounded_ClEx:
     "Closed_Unbounded(ClEx(P))"
apply (simp add: ClEx_eq)
apply (fast intro: Closed_Unbounded_Int Normal_imp_fp_Closed_Unbounded
                   Closed_Unbounded_Limit Normal_normalize)
done

text\<open>The same two theorems, exported to locale \<open>reflection\<close>.\<close>

text\<open>Class \<open>ClEx\<close> indeed consists of reflecting ordinals...\<close>
lemma (in reflection) ClEx_iff:
     "[| y\<in>Mset(a); Cl(a); ClEx(P,a);
        !!a. [| Cl(a); Ord(a) |] ==> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x) |]
      ==> (\<exists>z. M(z) & P(<y,z>)) \<longleftrightarrow> (\<exists>z\<in>Mset(a). Q(a,<y,z>))"
apply (unfold ClEx_def FF_def F0_def M_def)
apply (rule ex_reflection.ZF_ClEx_iff
  [OF ex_reflection.intro, OF reflection.intro ex_reflection_axioms.intro,
    of Mset Cl])
apply (simp_all add: Mset_mono_le Mset_cont Pair_in_Mset)
done

(*Alternative proof, less unfolding:
apply (rule Reflection.ZF_ClEx_iff [of Mset _ _ Cl, folded M_def])
apply (fold ClEx_def FF_def F0_def)
apply (rule ex_reflection.intro, assumption)
apply (simp add: ex_reflection_axioms.intro, assumption+)
*)

lemma (in reflection) Closed_Unbounded_ClEx:
     "(!!a. [| Cl(a); Ord(a) |] ==> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x))
      ==> Closed_Unbounded(ClEx(P))"
apply (unfold ClEx_eq FF_def F0_def M_def)
apply (rule ex_reflection.ZF_Closed_Unbounded_ClEx [of Mset _ _ Cl])
apply (rule ex_reflection.intro, rule reflection_axioms)
apply (blast intro: ex_reflection_axioms.intro)
done

subsection\<open>Packaging the Quantifier Reflection Rules\<close>

lemma (in reflection) Ex_reflection_0:
     "Reflects(Cl,P0,Q0)
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(P0,a),
                   \<lambda>x. \<exists>z. M(z) & P0(<x,z>),
                   \<lambda>a x. \<exists>z\<in>Mset(a). Q0(a,<x,z>))"
apply (simp add: Reflects_def)
apply (intro conjI Closed_Unbounded_Int)
  apply blast
 apply (rule Closed_Unbounded_ClEx [of Cl P0 Q0], blast, clarify)
apply (rule_tac Cl=Cl in  ClEx_iff, assumption+, blast)
done

lemma (in reflection) All_reflection_0:
     "Reflects(Cl,P0,Q0)
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(\<lambda>x.~P0(x), a),
                   \<lambda>x. \<forall>z. M(z) \<longrightarrow> P0(<x,z>),
                   \<lambda>a x. \<forall>z\<in>Mset(a). Q0(a,<x,z>))"
apply (simp only: all_iff_not_ex_not ball_iff_not_bex_not)
apply (rule Not_reflection, drule Not_reflection, simp)
apply (erule Ex_reflection_0)
done

theorem (in reflection) Ex_reflection [intro]:
     "Reflects(Cl, \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(\<lambda>x. P(fst(x),snd(x)), a),
                   \<lambda>x. \<exists>z. M(z) & P(x,z),
                   \<lambda>a x. \<exists>z\<in>Mset(a). Q(a,x,z))"
by (rule Ex_reflection_0 [of _ " \<lambda>x. P(fst(x),snd(x))"
                               "\<lambda>a x. Q(a,fst(x),snd(x))", simplified])

theorem (in reflection) All_reflection [intro]:
     "Reflects(Cl,  \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(\<lambda>x. ~P(fst(x),snd(x)), a),
                   \<lambda>x. \<forall>z. M(z) \<longrightarrow> P(x,z),
                   \<lambda>a x. \<forall>z\<in>Mset(a). Q(a,x,z))"
by (rule All_reflection_0 [of _ "\<lambda>x. P(fst(x),snd(x))"
                                "\<lambda>a x. Q(a,fst(x),snd(x))", simplified])

text\<open>And again, this time using class-bounded quantifiers\<close>

theorem (in reflection) Rex_reflection [intro]:
     "Reflects(Cl, \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(\<lambda>x. P(fst(x),snd(x)), a),
                   \<lambda>x. \<exists>z[M]. P(x,z),
                   \<lambda>a x. \<exists>z\<in>Mset(a). Q(a,x,z))"
by (unfold rex_def, blast)

theorem (in reflection) Rall_reflection [intro]:
     "Reflects(Cl,  \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      ==> Reflects(\<lambda>a. Cl(a) & ClEx(\<lambda>x. ~P(fst(x),snd(x)), a),
                   \<lambda>x. \<forall>z[M]. P(x,z),
                   \<lambda>a x. \<forall>z\<in>Mset(a). Q(a,x,z))"
by (unfold rall_def, blast)

text\<open>No point considering bounded quantifiers, where reflection is trivial.\<close>

subsection\<open>Simple Examples of Reflection\<close>

text\<open>Example 1: reflecting a simple formula.  The reflecting class is first
given as the variable \<open>?Cl\<close> and later retrieved from the final
proof state.\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & x \<in> y,
               \<lambda>a x. \<exists>y\<in>Mset(a). x \<in> y)"
by fast

text\<open>Problem here: there needs to be a conjunction (class intersection)
in the class of reflecting ordinals.  The \<^term>\<open>Ord(a)\<close> is redundant,
though harmless.\<close>
lemma (in reflection)
     "Reflects(\<lambda>a. Ord(a) & ClEx(\<lambda>x. fst(x) \<in> snd(x), a),
               \<lambda>x. \<exists>y. M(y) & x \<in> y,
               \<lambda>a x. \<exists>y\<in>Mset(a). x \<in> y)"
by fast

text\<open>Example 2\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
               \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
by fast

text\<open>Example 2'.  We give the reflecting class explicitly.\<close>
lemma (in reflection)
  "Reflects
    (\<lambda>a. (Ord(a) &
          ClEx(\<lambda>x. ~ (snd(x) \<subseteq> fst(fst(x)) \<longrightarrow> snd(x) \<in> snd(fst(x))), a)) &
          ClEx(\<lambda>x. \<forall>z. M(z) \<longrightarrow> z \<subseteq> fst(x) \<longrightarrow> z \<in> snd(x), a),
            \<lambda>x. \<exists>y. M(y) & (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
            \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
by fast

text\<open>Example 2''.  We expand the subset relation.\<close>
schematic_goal (in reflection)
  "Reflects(?Cl,
        \<lambda>x. \<exists>y. M(y) & (\<forall>z. M(z) \<longrightarrow> (\<forall>w. M(w) \<longrightarrow> w\<in>z \<longrightarrow> w\<in>x) \<longrightarrow> z\<in>y),
        \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). (\<forall>w\<in>Mset(a). w\<in>z \<longrightarrow> w\<in>x) \<longrightarrow> z\<in>y)"
by fast

text\<open>Example 2'''.  Single-step version, to reveal the reflecting class.\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
               \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
apply (rule Ex_reflection)
txt\<open>
@{goals[display,indent=0,margin=60]}
\<close>
apply (rule All_reflection)
txt\<open>
@{goals[display,indent=0,margin=60]}
\<close>
apply (rule Triv_reflection)
txt\<open>
@{goals[display,indent=0,margin=60]}
\<close>
done

text\<open>Example 3.  Warning: the following examples make sense only
if \<^term>\<open>P\<close> is quantifier-free, since it is not being relativized.\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & (\<forall>z. M(z) \<longrightarrow> z \<in> y \<longleftrightarrow> z \<in> x & P(z)),
               \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<in> y \<longleftrightarrow> z \<in> x & P(z))"
by fast

text\<open>Example 3'\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & y = Collect(x,P),
               \<lambda>a x. \<exists>y\<in>Mset(a). y = Collect(x,P))"
by fast

text\<open>Example 3''\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) & y = Replace(x,P),
               \<lambda>a x. \<exists>y\<in>Mset(a). y = Replace(x,P))"
by fast

text\<open>Example 4: Axiom of Choice.  Possibly wrong, since \<open>\<Pi>\<close> needs
to be relativized.\<close>
schematic_goal (in reflection)
     "Reflects(?Cl,
               \<lambda>A. 0\<notin>A \<longrightarrow> (\<exists>f. M(f) & f \<in> (\<Prod>X \<in> A. X)),
               \<lambda>a A. 0\<notin>A \<longrightarrow> (\<exists>f\<in>Mset(a). f \<in> (\<Prod>X \<in> A. X)))"
by fast

end


section \<open>Soundness theorem for the STRIPS semantics\<close>
text \<open>We prove the soundness theorem according to ~\<^cite>\<open>"lifschitz1987semantics"\<close>.\<close>

theory Lifschitz_Consistency
imports PDDL_STRIPS_Semantics
begin

text \<open>States are modeled as valuations of our underlying predicate logic.\<close>
type_synonym state = "(predicate\<times>object list) valuation"

context ast_domain begin
  text \<open>An action is a partial function from states to states. \<close>
  type_synonym action = "state \<rightharpoonup> state"

  text \<open>The Isabelle/HOL formula @{prop \<open>f s = Some s'\<close>} means
    that \<open>f\<close> is applicable in state \<open>s\<close>, and the result is \<open>s'\<close>. \<close>

  text \<open>Definition B (i)--(iv) in Lifschitz's paper~\<^cite>\<open>"lifschitz1987semantics"\<close>\<close>

  fun is_NegPredAtom where
    "is_NegPredAtom (Not x) = is_predAtom x" | "is_NegPredAtom _ = False"

  definition "close_eq s = (\<lambda>predAtm p xs \<Rightarrow> s (p,xs) | Eq a b \<Rightarrow> a=b)"

  lemma close_eq_predAtm[simp]: "close_eq s (predAtm p xs) \<longleftrightarrow> s (p,xs)"
    by (auto simp: close_eq_def)

  lemma close_eq_Eq[simp]: "close_eq s (Eq a b) \<longleftrightarrow> a=b"
    by (auto simp: close_eq_def)

  abbreviation entail_eq :: "state \<Rightarrow> object atom formula \<Rightarrow> bool" (infix "\<Turnstile>\<^sub>=" 55)
    where "entail_eq s f \<equiv> close_eq s \<Turnstile> f"

  fun sound_opr :: "ground_action \<Rightarrow> action \<Rightarrow> bool" where
    "sound_opr (Ground_Action pre (Effect add del)) f \<longleftrightarrow>
      (\<forall>s. s \<Turnstile>\<^sub>= pre \<longrightarrow>
        (\<exists>s'. f s = Some s' \<and> (\<forall>atm. is_predAtom atm \<and> atm \<notin> set del \<and> s \<Turnstile>\<^sub>= atm \<longrightarrow> s' \<Turnstile>\<^sub>= atm)
              \<and>  (\<forall>atm. is_predAtom atm \<and> atm \<notin> set add \<and> s \<Turnstile>\<^sub>= Not atm \<longrightarrow> s' \<Turnstile>\<^sub>= Not atm)
              \<and> (\<forall>fmla. fmla \<in> set add \<longrightarrow> s' \<Turnstile>\<^sub>= fmla)
              \<and> (\<forall>fmla. fmla \<in> set del \<and> fmla \<notin> set add \<longrightarrow> s' \<Turnstile>\<^sub>= (Not fmla))
              ))
        \<and> (\<forall>fmla\<in>set add. is_predAtom fmla)"

  lemma sound_opr_alt:
    "sound_opr opr f =
      ((\<forall>s. s \<Turnstile>\<^sub>= (precondition opr) \<longrightarrow>
          (\<exists>s'. f s = (Some s')
                \<and> (\<forall>atm. is_predAtom atm \<and> atm \<notin> set(dels (effect opr)) \<and> s \<Turnstile>\<^sub>= atm \<longrightarrow> s' \<Turnstile>\<^sub>= atm)
                \<and> (\<forall>atm. is_predAtom atm \<and> atm \<notin> set (adds (effect opr)) \<and> s \<Turnstile>\<^sub>= Not atm \<longrightarrow> s' \<Turnstile>\<^sub>= Not atm)
                \<and> (\<forall>atm. atm \<in> set(adds (effect opr)) \<longrightarrow> s' \<Turnstile>\<^sub>= atm)
                \<and> (\<forall>fmla. fmla \<in> set (dels (effect opr)) \<and> fmla \<notin> set(adds (effect opr)) \<longrightarrow> s' \<Turnstile>\<^sub>= (Not fmla))
                \<and> (\<forall>a b. s \<Turnstile>\<^sub>= Atom (Eq a b) \<longrightarrow> s' \<Turnstile>\<^sub>= Atom (Eq a b))
                \<and> (\<forall>a b. s \<Turnstile>\<^sub>= Not (Atom (Eq a b)) \<longrightarrow> s' \<Turnstile>\<^sub>= Not (Atom (Eq a b)))
                ))
        \<and> (\<forall>fmla\<in>set(adds (effect opr)). is_predAtom fmla))"
    by (cases "(opr,f)" rule: sound_opr.cases) auto

  text \<open>Definition B (v)--(vii) in  Lifschitz's paper~\<^cite>\<open>"lifschitz1987semantics"\<close>\<close>
definition sound_system
    :: "ground_action set
      \<Rightarrow> world_model
      \<Rightarrow> state
      \<Rightarrow> (ground_action \<Rightarrow> action)
      \<Rightarrow> bool"
    where
    "sound_system \<Sigma> M\<^sub>0 s\<^sub>0 f \<longleftrightarrow>
      ((\<forall>fmla\<in>close_world M\<^sub>0. s\<^sub>0  \<Turnstile>\<^sub>= fmla)
      \<and> wm_basic M\<^sub>0
      \<and> (\<forall>\<alpha>\<in>\<Sigma>. sound_opr \<alpha> (f \<alpha>)))"

  text \<open>Composing two actions\<close>
  definition compose_action :: "action \<Rightarrow> action \<Rightarrow> action" where
    "compose_action f1 f2 x = (case f2 x of Some y \<Rightarrow> f1 y | None \<Rightarrow> None)"

  text \<open>Composing a list of actions\<close>
  definition compose_actions :: "action list \<Rightarrow> action" where
    "compose_actions fs \<equiv> fold compose_action fs Some"

  text \<open>Composing a list of actions satisfies some natural lemmas: \<close>
  lemma compose_actions_Nil[simp]:
    "compose_actions [] = Some" unfolding compose_actions_def by auto

  lemma compose_actions_Cons[simp]:
    "f s = Some s' \<Longrightarrow> compose_actions (f#fs) s = compose_actions fs s'"
  proof -
    interpret monoid_add compose_action Some
      apply unfold_locales
      unfolding compose_action_def
      by (auto split: option.split)
    assume "f s = Some s'"
    then show ?thesis
      unfolding compose_actions_def
      by (simp add: compose_action_def fold_plus_sum_list_rev)
  qed

  text \<open>Soundness Theorem in Lifschitz's paper~\<^cite>\<open>"lifschitz1987semantics"\<close>.\<close>
theorem STRIPS_sema_sound:
  assumes "sound_system \<Sigma> M\<^sub>0 s\<^sub>0 f"
    \<comment> \<open>For a sound system \<open>\<Sigma>\<close>\<close>
  assumes "set \<alpha>s \<subseteq> \<Sigma>"
    \<comment> \<open>And a plan \<open>\<alpha>s\<close>\<close>
  assumes "ground_action_path M\<^sub>0 \<alpha>s M'"
    \<comment> \<open>Which is accepted by the system, yielding result \<open>M'\<close>
          (called \<open>R(\<alpha>s)\<close> in Lifschitz's paper~\cite{lifschitz1987semantics}.)\<close>
  obtains s'
    \<comment> \<open>We have that \<open>f(\<alpha>s)\<close> is applicable
          in initial state, yielding state \<open>s'\<close> (called \<open>f\<^sub>\<alpha>\<^sub>s(s\<^sub>0)\<close> in Lifschitz's paper~\cite{lifschitz1987semantics}.)\<close>
  where "compose_actions (map f \<alpha>s) s\<^sub>0 = Some s'"
    \<comment> \<open>The result world model \<open>M'\<close> is satisfied in state \<open>s'\<close>\<close>
    and "\<forall>fmla\<in>close_world M'. s' \<Turnstile>\<^sub>= fmla"
proof -
  have "(valuation M' \<Turnstile> fmla)" if "wm_basic M'" "fmla\<in>M'" for fmla
    using that apply (induction fmla)
    by (auto simp: valuation_def wm_basic_def split: atom.split)
  have "\<exists>s'. compose_actions (map f \<alpha>s) s\<^sub>0 = Some s' \<and> (\<forall>fmla\<in>close_world M'. s' \<Turnstile>\<^sub>= fmla)"
    using assms
  proof(induction \<alpha>s arbitrary: s\<^sub>0 M\<^sub>0 )
    case Nil
    then show ?case by (auto simp add: close_world_def compose_action_def sound_system_def)
  next
    case ass: (Cons \<alpha> \<alpha>s)
    then obtain pre add del where a: "\<alpha> = Ground_Action pre (Effect add del)"
      using ground_action.exhaust ast_effect.exhaust by metis
    let ?M\<^sub>1 = "execute_ground_action \<alpha> M\<^sub>0"
    have "close_world M\<^sub>0 \<TTurnstile> precondition \<alpha>"
      using ass(4)
      by auto
    moreover have s0_ent_cwM0: "\<forall>fmla\<in>(close_world M\<^sub>0). close_eq s\<^sub>0 \<Turnstile> fmla"
      using ass(2)
      unfolding sound_system_def
      by auto
    ultimately have s0_ent_alpha_precond: "close_eq s\<^sub>0 \<Turnstile> precondition \<alpha>"
      unfolding entailment_def
      by auto
    then obtain s\<^sub>1 where s1: "(f \<alpha>) s\<^sub>0 = Some s\<^sub>1"
      "(\<forall>atm. is_predAtom atm \<longrightarrow> atm \<notin> set(dels (effect \<alpha>))
                                            \<longrightarrow> close_eq s\<^sub>0 \<Turnstile> atm
                                            \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> atm)"
      "(\<forall>fmla. fmla \<in> set(adds (effect \<alpha>))
                                            \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> fmla)"
      "(\<forall>atm. is_predAtom atm \<and> atm \<notin> set (adds (effect \<alpha>)) \<and> close_eq s\<^sub>0 \<Turnstile> Not atm \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> Not atm)"
      "(\<forall>fmla. fmla \<in> set (dels (effect \<alpha>)) \<and> fmla \<notin> set(adds (effect \<alpha>)) \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> (Not fmla))"
      "(\<forall>a b. close_eq s\<^sub>0 \<Turnstile> Atom (Eq a b) \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> Atom (Eq a b))"
      "(\<forall>a b. close_eq s\<^sub>0 \<Turnstile> Not (Atom (Eq a b)) \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> Not (Atom (Eq a b)))"
      using ass(2-4)
      unfolding sound_system_def sound_opr_alt by force
    have "close_eq s\<^sub>1 \<Turnstile> fmla" if "fmla\<in>close_world ?M\<^sub>1" for fmla
      using ass(2)
      using that s1 s0_ent_cwM0
      unfolding sound_system_def execute_ground_action_def wm_basic_def
      apply (auto simp: in_close_world_conv)
      subgoal
        by (metis (no_types, lifting) DiffE UnE a apply_effect.simps ground_action.sel(2) ast_effect.sel(1) ast_effect.sel(2) close_world_extensive subsetCE)
      subgoal
        by (metis Diff_iff Un_iff a ground_action.sel(2) ast_domain.apply_effect.simps ast_domain.close_eq_predAtm ast_effect.sel(1) ast_effect.sel(2) formula_semantics.simps(1) formula_semantics.simps(3) in_close_world_conv is_predAtom.simps(1))
      done
    moreover have "(\<forall>atm. fmla \<noteq> formula.Atom atm) \<longrightarrow> s \<Turnstile> fmla" if "fmla\<in>?M\<^sub>1" for fmla s
    proof-
      have alpha: "(\<forall>s.\<forall>fmla\<in>set(adds (effect \<alpha>)). \<not> is_predAtom fmla \<longrightarrow> s \<Turnstile> fmla)"
        using ass(2,3)
        unfolding sound_system_def ast_domain.sound_opr_alt
        by auto
      then show ?thesis
        using that
        unfolding a execute_ground_action_def
        using ass.prems(1)[unfolded sound_system_def]
        by(cases fmla; fastforce simp: wm_basic_def)

    qed
    moreover have "(\<forall>opr\<in>\<Sigma>. sound_opr opr (f opr))"
      using ass(2) unfolding sound_system_def
      by (auto simp add:)
    moreover have "wm_basic ?M\<^sub>1"
      using ass(2,3)
      unfolding sound_system_def execute_ground_action_def
      thm sound_opr.cases
      apply (cases "(\<alpha>,f \<alpha>)" rule: sound_opr.cases)
      apply (auto simp: wm_basic_def)
      done
    ultimately have "sound_system \<Sigma> ?M\<^sub>1 s\<^sub>1 f"
      unfolding sound_system_def
      by (auto simp: wm_basic_def)
    from ass.IH[OF this] ass.prems obtain s' where
      "compose_actions (map f \<alpha>s) s\<^sub>1 = Some s' \<and> (\<forall>a\<in>close_world M'. s' \<Turnstile>\<^sub>= a)"
      by auto
    thus ?case by (auto simp: s1(1))
  qed
  with that show ?thesis by blast
qed

  text \<open>More compact notation of the soundness theorem.\<close>
  theorem STRIPS_sema_sound_compact_version:
    "sound_system \<Sigma> M\<^sub>0 s\<^sub>0 f \<Longrightarrow> set \<alpha>s \<subseteq> \<Sigma>
    \<Longrightarrow> ground_action_path M\<^sub>0 \<alpha>s M'
    \<Longrightarrow> \<exists>s'. compose_actions (map f \<alpha>s) s\<^sub>0 = Some s'
          \<and> (\<forall>fmla\<in>close_world M'. s' \<Turnstile>\<^sub>= fmla)"
    using STRIPS_sema_sound by metis

end \<comment> \<open>Context of \<open>ast_domain\<close>\<close>

subsection \<open>Soundness Theorem for PDDL\<close>

context wf_ast_problem begin

  text \<open>Mapping world models to states\<close>
  definition state_to_wm :: "state \<Rightarrow> world_model"
    where "state_to_wm s = ({formula.Atom (predAtm p xs) | p xs. s (p,xs)})"
  definition wm_to_state :: "world_model \<Rightarrow> state"
    where "wm_to_state M = (\<lambda>(p,xs). (formula.Atom (predAtm p xs)) \<in> M)"

  lemma wm_to_state_inv[simp]: "wm_to_state (state_to_wm s) = s"
    by (auto simp: wm_to_state_def
      state_to_wm_def image_def)

  text \<open>Mapping AST action instances to actions\<close>
  definition "pddl_opr_to_act g_opr s = (
    let M = state_to_wm s in
    if (wm_to_state (close_world M)) \<Turnstile>\<^sub>= (precondition g_opr) then
      Some (wm_to_state (apply_effect (effect g_opr) M))
    else
      None)"

definition "close_eq_M M = (M \<inter> {Atom (predAtm p xs) | p xs. True }) \<union> {Atom (Eq a a) | a. True} \<union> {\<^bold>\<not>(Atom (Eq a b)) | a b. a\<noteq>b}"

  lemma atom_in_wm_eq:
    "s \<Turnstile>\<^sub>= (formula.Atom atm)
      \<longleftrightarrow> ((formula.Atom atm) \<in> close_eq_M (state_to_wm s))"
    by (auto simp: wm_to_state_def
      state_to_wm_def image_def close_eq_M_def close_eq_def split: atom.splits)

lemma atom_in_wm_2_eq:
    "close_eq (wm_to_state M) \<Turnstile> (formula.Atom atm)
      \<longleftrightarrow> ((formula.Atom atm) \<in> close_eq_M M)"
    by (auto simp: wm_to_state_def
      state_to_wm_def image_def close_eq_def close_eq_M_def split:atom.splits)

  lemma not_dels_preserved:
    assumes "f \<notin> (set d)" " f \<in> M"
    shows "f \<in> apply_effect (Effect a d) M"
    using assms
    by auto

  lemma adds_satisfied:
    assumes "f \<in> (set a)"
    shows "f \<in> apply_effect (Effect a d) M"
    using assms
    by auto

  lemma dels_unsatisfied:
    assumes "f \<in> (set d)" "f \<notin> set a"
    shows "f \<notin> apply_effect (Effect a d) M"
    using assms
    by auto

  lemma dels_unsatisfied_2:
    assumes "f \<in> set (dels eff)" "f \<notin> set (adds eff)"
    shows "f \<notin> apply_effect eff M"
    using assms
    by (cases eff; auto)

  lemma wf_fmla_atm_is_atom: "wf_fmla_atom objT f \<Longrightarrow> is_predAtom f"
    by (cases f rule: wf_fmla_atom.cases) auto

  lemma wf_act_adds_are_atoms:
    assumes "wf_effect_inst effs" "ae \<in> set (adds effs)"
    shows "is_predAtom ae"
    using assms
    by (cases effs) (auto simp: wf_fmla_atom_alt)

  lemma wf_act_adds_dels_atoms:
    assumes "wf_effect_inst effs" "ae \<in> set (dels effs)"
    shows "is_predAtom ae"
    using assms
    by (cases effs) (auto simp: wf_fmla_atom_alt)

  lemma to_state_close_from_state_eq[simp]: "wm_to_state (close_world (state_to_wm s)) = s"
    by (auto simp: wm_to_state_def close_world_def
      state_to_wm_def image_def)

lemma wf_eff_pddl_ground_act_is_sound_opr:
  assumes "wf_effect_inst (effect g_opr)"
  shows "sound_opr g_opr ((pddl_opr_to_act g_opr))"
  unfolding sound_opr_alt
  apply(cases g_opr; safe)
  subgoal for pre eff s
    apply (rule exI[where x="wm_to_state(apply_effect eff (state_to_wm s))"])
    apply (auto simp: pddl_opr_to_act_def Let_def split:if_splits)
    subgoal for atm
      by (cases eff; cases atm; auto simp: close_eq_def wm_to_state_def state_to_wm_def split: atom.splits)
    subgoal for atm
      by (cases eff; cases atm; auto simp: close_eq_def wm_to_state_def state_to_wm_def split: atom.splits)
    subgoal for atm
      using assms
      by (cases eff; cases atm; force simp: close_eq_def wm_to_state_def state_to_wm_def split: atom.splits)
    subgoal for fmla
      using assms
      by (cases eff; cases fmla rule: wf_fmla_atom.cases; force simp: close_eq_def wm_to_state_def state_to_wm_def split: atom.splits)
    done
  subgoal for pre eff fmla
    using assms
    by (cases eff; cases fmla rule: wf_fmla_atom.cases; force)
  done

  lemma wf_eff_impt_wf_eff_inst: "wf_effect objT eff \<Longrightarrow> wf_effect_inst eff"
    by (cases eff; auto simp add: wf_fmla_atom_alt)

  lemma wf_action_schema_sound_inst:
    assumes "action_params_match act args" "wf_action_schema act"
    shows "sound_opr
      (instantiate_action_schema act args)
      ((pddl_opr_to_act (instantiate_action_schema act args)))"
    using
      wf_pddl_ground_act_is_sound_opr[
        OF wf_instantiate_action_schema[OF assms]]
      by blast

  lemma wf_plan_act_is_sound:
    assumes "wf_plan_action (PAction n args)"
    shows "sound_opr
      (instantiate_action_schema (the (resolve_action_schema n)) args)
      ((pddl_opr_to_act
        (instantiate_action_schema (the (resolve_action_schema n)) args)))"
    using assms
    using wf_action_schema_sound_inst wf_eff_pddl_ground_act_is_sound_opr
    by (auto split: option.splits)

  lemma wf_plan_act_is_sound':
    assumes "wf_plan_action \<pi>"
    shows "sound_opr
      (resolve_instantiate \<pi>)
      ((pddl_opr_to_act (resolve_instantiate \<pi>)))"
    using assms wf_plan_act_is_sound
    by (cases \<pi>; auto )

  lemma wf_world_model_has_atoms: "f\<in>M \<Longrightarrow> wf_world_model M \<Longrightarrow> is_predAtom f"
    using wf_fmla_atm_is_atom
    unfolding wf_world_model_def
    by auto

  lemma wm_to_state_works_for_wf_wm_closed:
    "wf_world_model M \<Longrightarrow> fmla\<in>close_world M \<Longrightarrow> close_eq (wm_to_state M) \<Turnstile> fmla"
    apply (cases fmla rule: wf_fmla_atom.cases)
    by (auto simp: wf_world_model_def close_eq_def wm_to_state_def close_world_def)

  lemma wm_to_state_works_for_wf_wm: "wf_world_model M \<Longrightarrow> fmla\<in>M \<Longrightarrow> close_eq (wm_to_state M) \<Turnstile> fmla"
    apply (cases fmla rule: wf_fmla_atom.cases)
    by (auto simp: wf_world_model_def close_eq_def wm_to_state_def)

  lemma wm_to_state_works_for_I_closed:
    assumes "x \<in> close_world I"
    shows "close_eq (wm_to_state I) \<Turnstile> x"
    apply (rule wm_to_state_works_for_wf_wm_closed)
    using assms wf_I by auto

  lemma wf_wm_imp_basic: "wf_world_model M \<Longrightarrow> wm_basic M"
    by (auto simp: wf_world_model_def wm_basic_def wf_fmla_atm_is_atom)

theorem wf_plan_sound_system:
  assumes "\<forall>\<pi>\<in> set \<pi>s. wf_plan_action \<pi>"
  shows "sound_system
      (set (map resolve_instantiate \<pi>s))
      I
      (wm_to_state I)
      ((\<lambda>\<alpha>. pddl_opr_to_act \<alpha>))"
  unfolding sound_system_def
proof(intro conjI ballI)
  show "close_eq(wm_to_state I) \<Turnstile> x" if "x \<in> close_world I" for x
    using that[unfolded in_close_world_conv]
      wm_to_state_works_for_I_closed wm_to_state_works_for_wf_wm
    by (auto simp: wf_I)

  show "wm_basic I" using wf_wm_imp_basic[OF wf_I] .

  show "sound_opr \<alpha> (pddl_opr_to_act \<alpha>)" if "\<alpha> \<in> set (map resolve_instantiate \<pi>s)" for \<alpha>
    using that
    using wf_plan_act_is_sound' assms
    by auto
qed

theorem wf_plan_soundness_theorem:
    assumes "plan_action_path I \<pi>s M"
    defines "\<alpha>s \<equiv> map (pddl_opr_to_act \<circ> resolve_instantiate) \<pi>s"
    defines "s\<^sub>0 \<equiv> wm_to_state I"
    shows "\<exists>s'. compose_actions \<alpha>s s\<^sub>0 = Some s' \<and> (\<forall>\<phi>\<in>close_world M. s' \<Turnstile>\<^sub>= \<phi>)"
    apply (rule STRIPS_sema_sound)
    apply (rule wf_plan_sound_system)
    using assms
    unfolding plan_action_path_def
    by (auto simp add: image_def)

end \<comment> \<open>Context of \<open>wf_ast_problem\<close>\<close>

end


section \<open>Cpo for Numerals\<close>

theory Numeral_Cpo
  imports HOLCF_Main
begin

class plus_cpo = plus + cpo +
  assumes cont_plus1: "cont (\<lambda>x::'a::{plus,cpo}. x + y)"
  assumes cont_plus2: "cont (\<lambda>y::'a::{plus,cpo}. x + y)"
begin

abbreviation plus_section :: "'a \<rightarrow> 'a \<rightarrow> 'a" ("'(+')") where
  "(+) \<equiv> \<Lambda> x y. x + y"

abbreviation plus_section_left :: "'a \<Rightarrow> 'a \<rightarrow> 'a" ("'(_+')") where
  "(x+) \<equiv> \<Lambda> y. x + y"

abbreviation plus_section_right :: "'a \<Rightarrow> 'a \<rightarrow> 'a" ("'(+_')") where
  "(+y) \<equiv> \<Lambda> x. x + y"

end

class minus_cpo = minus + cpo +
  assumes cont_minus1: "cont (\<lambda>x::'a::{minus,cpo}. x - y)"
  assumes cont_minus2: "cont (\<lambda>y::'a::{minus,cpo}. x - y)"
begin

abbreviation minus_section :: "'a \<rightarrow> 'a \<rightarrow> 'a" ("'(-')") where
  "(-) \<equiv> \<Lambda> x y. x - y"

abbreviation minus_section_left :: "'a \<Rightarrow> 'a \<rightarrow> 'a" ("'(_-')") where
  "(x-) \<equiv> \<Lambda> y. x - y"

abbreviation minus_section_right :: "'a \<Rightarrow> 'a \<rightarrow> 'a" ("'(-_')") where
  "(-y) \<equiv> \<Lambda> x. x - y"

end

class times_cpo = times + cpo +
  assumes cont_times1: "cont (\<lambda>x::'a::{times,cpo}. x * y)"
  assumes cont_times2: "cont (\<lambda>y::'a::{times,cpo}. x * y)"
begin

(*
This clashes with comment syntax
abbreviation times_section :: "'a \<rightarrow> 'a \<rightarrow> 'a" ("'(?')") where
  "(?) \<equiv> \<Lambda> x y. x * y"

abbreviation times_section_left :: "'a \<Rightarrow> 'a \<rightarrow> 'a" ("'(_?')") where
  "(x?) \<equiv> \<Lambda> y. x * y"

abbreviation times_section_right :: "'a \<Rightarrow> 'a \<rightarrow> 'a" ("'(?_')") where
  "(?y) \<equiv> \<Lambda> x. x - y"
*)
end

lemma cont2cont_plus [simp, cont2cont]:
  assumes "cont (\<lambda>x. f x)" and "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x + g x :: 'a::plus_cpo)"
  apply (rule cont_apply [OF assms(1) cont_plus1])
  apply (rule cont_apply [OF assms(2) cont_plus2])
  apply (rule cont_const)
  done

lemma cont2cont_minus [simp, cont2cont]:
  assumes "cont (\<lambda>x. f x)" and "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x - g x :: 'a::minus_cpo)"
  apply (rule cont_apply [OF assms(1) cont_minus1])
  apply (rule cont_apply [OF assms(2) cont_minus2])
  apply (rule cont_const)
  done

lemma cont2cont_times [simp, cont2cont]:
  assumes "cont (\<lambda>x. f x)" and "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x * g x :: 'a::times_cpo)"
  apply (rule cont_apply [OF assms(1) cont_times1])
  apply (rule cont_apply [OF assms(2) cont_times2])
  apply (rule cont_const)
  done

instantiation u :: ("{zero,cpo}") zero
begin
  definition "zero_u = up\<cdot>(0::'a)"
  instance ..
end

instantiation u :: ("{one,cpo}") one
begin
  definition "one_u = up\<cdot>(1::'a)"
  instance ..
end

instantiation u :: (plus_cpo) plus
begin
  definition "plus_u x y = (\<Lambda>(up\<cdot>a) (up\<cdot>b). up\<cdot>(a + b))\<cdot>x\<cdot>y" for x y :: "'a\<^sub>\<bottom>"
  instance ..
end

instantiation u :: (minus_cpo) minus
begin
  definition "minus_u x y = (\<Lambda>(up\<cdot>a) (up\<cdot>b). up\<cdot>(a - b))\<cdot>x\<cdot>y" for x y :: "'a\<^sub>\<bottom>"
  instance ..
end

instantiation u :: (times_cpo) times
begin
  definition "times_u x y = (\<Lambda>(up\<cdot>a) (up\<cdot>b). up\<cdot>(a * b))\<cdot>x\<cdot>y" for x y :: "'a\<^sub>\<bottom>"
  instance ..
end

lemma plus_u_strict [simp]:
  fixes x :: "_ u" shows "x + \<bottom> = \<bottom>" and "\<bottom> + x = \<bottom>"
  unfolding plus_u_def by (cases x, simp, simp)+

lemma minus_u_strict [simp]:
  fixes x :: "_ u" shows "x - \<bottom> = \<bottom>" and "\<bottom> - x = \<bottom>"
  unfolding minus_u_def by (cases x, simp_all)+

lemma times_u_strict [simp]:
  fixes x :: "_ u" shows "x * \<bottom> = \<bottom>" and "\<bottom> * x = \<bottom>"
  unfolding times_u_def by (cases x, simp_all)+

lemma plus_up_up [simp]: "up\<cdot>x + up\<cdot>y = up\<cdot>(x + y)"
  unfolding plus_u_def by simp

lemma minus_up_up [simp]: "up\<cdot>x - up\<cdot>y = up\<cdot>(x - y)"
  unfolding minus_u_def by simp

lemma times_up_up [simp]: "up\<cdot>x * up\<cdot>y = up\<cdot>(x * y)"
  unfolding times_u_def by simp

instance u :: (plus_cpo) plus_cpo
  by standard (simp_all add: plus_u_def)

instance u :: (minus_cpo) minus_cpo
  by standard (simp_all add: minus_u_def)

instance u :: (times_cpo) times_cpo
  by standard (simp_all add: times_u_def)

instance u :: ("{semigroup_add,plus_cpo}") semigroup_add
proof
  fix a b c :: "'a u"
  show "(a + b) + c = a + (b + c)"
    unfolding plus_u_def
    by (cases a; cases b; cases c) (simp_all add: add.assoc)
qed

instance u :: ("{ab_semigroup_add,plus_cpo}") ab_semigroup_add
proof
  fix a b :: "'a u"
  show "a + b = b + a"
    by (cases a; cases b) (simp_all add: add.commute)
qed

instance u :: ("{monoid_add,plus_cpo}") monoid_add
proof
  fix a :: "'a u"
  show "0 + a = a"
    unfolding zero_u_def by (cases a) simp_all
  show "a + 0 = a"
    unfolding zero_u_def by (cases a) simp_all
qed

instance u :: ("{comm_monoid_add,plus_cpo}") comm_monoid_add
proof
  fix a :: "'a u"
  show "0 + a = a"
    unfolding zero_u_def by (cases a) simp_all
qed

instance u :: ("{numeral, plus_cpo}") numeral ..

instance int :: plus_cpo
  by standard simp_all

instance int :: minus_cpo
  by standard simp_all

end


(* Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>Monoid\<close>

theory Applicative_Monoid imports
  Applicative
  "~~/src/Tools/Adhoc_Overloading"
begin

datatype ('a, 'b) monoid_ap = Monoid_ap 'a 'b

definition (in zero) pure_monoid_add :: "'b \<Rightarrow> ('a, 'b) monoid_ap"
where "pure_monoid_add = Monoid_ap 0"

fun (in plus) ap_monoid_add :: "('a, 'b \<Rightarrow> 'c) monoid_ap \<Rightarrow> ('a, 'b) monoid_ap \<Rightarrow> ('a, 'c) monoid_ap"
where "ap_monoid_add (Monoid_ap a1 f) (Monoid_ap a2 x) = Monoid_ap (a1 + a2) (f x)"

setup \<open>
  fold Sign.add_const_constraint
   [(@{const_name pure_monoid_add}, SOME (@{typ "'b \<Rightarrow> ('a :: monoid_add, 'b) monoid_ap"})),
    (@{const_name ap_monoid_add}, SOME (@{typ "('a :: monoid_add, 'b \<Rightarrow> 'c) monoid_ap \<Rightarrow> ('a, 'b) monoid_ap \<Rightarrow> ('a, 'c) monoid_ap"}))]
\<close>

adhoc_overloading Applicative.pure pure_monoid_add
adhoc_overloading Applicative.ap ap_monoid_add

applicative monoid_add
  for pure: pure_monoid_add
      ap: ap_monoid_add
subgoal by(simp add: pure_monoid_add_def)
subgoal for g f x by(cases g f x rule: monoid_ap.exhaust[case_product monoid_ap.exhaust, case_product monoid_ap.exhaust])(simp add: pure_monoid_add_def add.assoc)
subgoal for x by(cases x)(simp add: pure_monoid_add_def)
subgoal for f x by(cases f)(simp add: pure_monoid_add_def)
done

applicative comm_monoid_add (C)
  for pure: "pure_monoid_add :: _ \<Rightarrow> (_ :: comm_monoid_add, _) monoid_ap"
      ap: "ap_monoid_add :: (_ :: comm_monoid_add, _) monoid_ap \<Rightarrow> _"
apply(rule monoid_add.homomorphism monoid_add.pure_B_conv monoid_add.interchange)+
subgoal for f x y by(cases f x y rule: monoid_ap.exhaust[case_product monoid_ap.exhaust, case_product monoid_ap.exhaust])(simp add: pure_monoid_add_def add_ac)
apply(rule monoid_add.pure_I_conv)
done

class idemp_monoid_add = monoid_add +
  assumes add_idemp: "x + x = x"

applicative idemp_monoid_add (W)
  for pure: "pure_monoid_add :: _ \<Rightarrow> (_ :: idemp_monoid_add, _) monoid_ap"
      ap: "ap_monoid_add :: (_ :: idemp_monoid_add, _) monoid_ap \<Rightarrow> _"
apply(rule monoid_add.homomorphism monoid_add.pure_B_conv monoid_add.pure_I_conv)+
subgoal for f x by(cases f x rule: monoid_ap.exhaust[case_product monoid_ap.exhaust])(simp add: pure_monoid_add_def add.assoc add_idemp)
apply(rule monoid_add.interchange)
done

text \<open>Test case\<close>
context begin interpretation applicative_syntax .
private lemma "pure_monoid_add op + \<diamondop> (x :: (nat, int) monoid_ap) \<diamondop> y = pure op + \<diamondop> y \<diamondop> x"
by(applicative_lifting comm_monoid_add) simp
end

end


(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Language_Composition
imports WHATWHERE_Secure_Skip_Assign
begin

context WHATWHERE_Secure_Programs
begin

theorem Compositionality_Seq:
  assumes WWs_part1: "WHATWHERE_Secure [c1]"
  assumes WWs_part2: "WHATWHERE_Secure [c2]"
  assumes uniPPc1c2: "unique_PPc (c1;c2)"
  shows "WHATWHERE_Secure [c1;c2]"
proof (simp add: WHATWHERE_Secure_def, auto)
  fix d PP

  from uniPPc1c2 have nocommonPP: "set (PPc c1) \<inter> set (PPc c2) = {}"
    by (simp add: unique_PPV_def unique_PPc_def)

  from WWs_part1 obtain R1' where R1'assump:
    "SdlHPPB d PP R1' \<and> ([c1],[c1]) \<in> R1'"
    by (simp add: WHATWHERE_Secure_def, auto)

  def R1 \<equiv> "{(V,V'). (V,V') \<in> R1' \<and> set (PPV V) \<subseteq> set (PPc c1)
    \<and> set (PPV V') \<subseteq> set (PPc c1)}"

  from R1'assump R1_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPR1: "SdlHPPB d PP R1"
    by force

  from WWs_part2 obtain R2' where R2'assump:
    "SdlHPPB d PP R2' \<and> ([c2],[c2]) \<in> R2'"
    by (simp add: WHATWHERE_Secure_def, auto)

  def R2 \<equiv> "{(V,V'). (V,V') \<in> R2' \<and> set (PPV V) \<subseteq> set (PPc c2)
    \<and> set (PPV V') \<subseteq> set (PPc c2)}"

  from R2'assump R2_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPR2: "SdlHPPB d PP R2"
    by force

  from nocommonPP have nocommonDomain: "Domain R1 \<inter> Domain R2 \<subseteq> {[]}"
    by (simp add: R1_def R2_def, auto,
      metis inf_greatest inf_idem le_bot unique_V_uneq)

  with commonArefl_subset_commonDomain
  have Areflassump1: "Arefl R1 \<inter> Arefl R2 \<subseteq> {[]}"
    by force

  def R0 \<equiv> "{(s1,s2). \<exists>c1 c1' c2 c2'. s1 = [c1;c2] \<and> s2 = [c1';c2'] \<and>
    ([c1],[c1']) \<in> R1 \<and> ([c2],[c2']) \<in> R2}"

  with R1_def R1'assump R2_def R2'assump
  have inR0: "([c1;c2],[c1;c2]) \<in> R0"
    by auto

  have "Domain R0 \<inter> Domain (R1 \<union> R2) = {}"
    by (simp add: R0_def R1_def R2_def, auto, metis Int_absorb1 Int_assoc Int_empty_left
      nocommonPP unique_c_uneq, metis Int_absorb Int_absorb1
      Int_assoc Int_empty_left nocommonPP unique_c_uneq)

  with commonArefl_subset_commonDomain
  have Areflassump2: "Arefl R0 \<inter> Arefl (R1 \<union> R2) \<subseteq> {[]}"
    by force

  have disjuptoR0:
    "disj_dlHPP_Bisimulation_Up_To_R' d PP (R1 \<union> R2) R0"
    proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def, auto)
        from Areflassump1 SdlHPPR1 SdlHPPR2 Union_Strong_dlHPP_Bisim
        show "SdlHPPB d PP (R1 \<union> R2)"
          by metis
      next
        from SdlHPPR1 have symR1: "sym R1"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        from SdlHPPR2 have symR2: "sym R2"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        with symR1 R0_def show "sym R0"
          by (simp add: sym_def, auto)
      next
        from SdlHPPR1 have transR1: "trans R1"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        from SdlHPPR2 have transR2: "trans R2"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        show "trans R0"
          proof -
            {
            fix V V' V''
            assume p1: "(V,V') \<in> R0"
            assume p2: "(V',V'') \<in> R0"
            have "(V,V'') \<in> R0"
              proof -
                from p1 R0_def obtain c1 c2 c1' c2' where p1assump:
                  "V = [c1;c2] \<and> V' = [c1';c2'] \<and>
                  ([c1],[c1']) \<in> R1 \<and> ([c2],[c2']) \<in> R2"
                  by auto
                with p2 R0_def obtain c1'' c2'' where p2assump:
                  "V'' = [c1'';c2''] \<and>
                  ([c1'],[c1'']) \<in> R1 \<and> ([c2'],[c2'']) \<in> R2"
                  by auto
                with p1assump transR1 transR2 have
                  trans_assump: "([c1],[c1'']) \<in> R1 \<and> ([c2],[c2'']) \<in> R2"
                  by (simp add: trans_def, blast)
                with p1assump p2assump R0_def show ?thesis
                  by auto
              qed
             }
            thus ?thesis unfolding trans_def by blast
          qed
      next
        fix V V'
        assume "(V,V') \<in> R0"
        with R0_def show "length V = length V'"
          by auto
      next
        fix V V' i
        assume inR0: "(V,V') \<in> R0"
        assume irange: "i < length V"
        assume notIDC: "\<not> IDC d (V!i) (htchLoc (pp (V!i)))"
        from inR0 R0_def obtain c1 c2 c1' c2' where VV'assump:
          "V = [c1;c2] \<and> V' = [c1';c2'] \<and>
          ([c1],[c1']) \<in> R1 \<and> ([c2],[c2']) \<in> R2"
          by auto
        have eqnextmem: "\<And>m. \<lbrakk>c1;c2\<rbrakk>(m) = \<lbrakk>c1\<rbrakk>(m)"
          proof -
            fix m
            from nextmem_exists_and_unique obtain m' where c1nextmem:
              "\<exists>p \<alpha>. \<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m')"
              by force

            hence eqdir1: "\<lbrakk>c1\<rbrakk>(m) = m'"
              by (simp add: NextMem_def, auto)

            from c1nextmem obtain p \<alpha> where "\<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>"
              by auto

            with c1nextmem have "\<exists>p \<alpha>. \<langle>c1;c2,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>c1;c2,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m')"
              by (auto, metis MWLsSteps_det.seq1 MWLsSteps_det.seq2
                option.exhaust, metis MWLsSteps_det_cases(3))

            hence eqdir2: "\<lbrakk>c1;c2\<rbrakk>(m) = m'"
              by (simp add: NextMem_def, auto)

            with eqdir1 show "\<lbrakk>c1;c2\<rbrakk>(m) = \<lbrakk>c1\<rbrakk>(m)"
              by auto
          qed

        have eqpp: "pp (c1;c2) = pp c1"
          by simp
        from VV'assump SdlHPPR1 have "IDC d c1 (htchLoc (pp c1))
          \<or> NDC d c1"
          by (simp add: Strong_dlHPP_Bisimulation_def, auto)
        with eqnextmem eqpp have "IDC d (c1;c2)
          (htchLoc (pp (c1;c2))) \<or> NDC d (c1;c2)"
          by (simp add: IDC_def NDC_def)
        with inR0 irange notIDC VV'assump
        show "NDC d (V!i)"
          by (simp add: IDC_def, auto)
      next
        fix V V' m1 m1' m2 \<alpha> p i
        assume inR0: "(V,V') \<in> R0"
        assume irange: "i < length V"
        assume step: "\<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
        assume dhequal: "m1 \<sim>\<^bsub>d,htchLocSet PP\<^esub> m1'"

        from inR0 R0_def obtain c1 c1' c2 c2' where R0pair:
          "V = [c1;c2] \<and> V' = [c1';c2'] \<and> ([c1],[c1']) \<in> R1
          \<and> ([c2],[c2']) \<in> R2"
          by auto

       from R0pair irange have i0: "i = 0" by simp

       have eqpp: "pp (c1;c2) = pp c1"
         by simp

        --"get the two different cases:"
        from R0pair step i0 obtain c3 where case_distinction:
          "(p = Some c2 \<and> \<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>None,m2\<rangle>)
          \<or> (p = Some (c3;c2) \<and> \<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c3,m2\<rangle>)"
          by (simp, insert MWLsSteps_det.simps[of "c1;c2" "m1"],
            auto)
        moreover
        --"Case 1: first command terminates"
        {
          assume passump: "p = Some c2"
          assume StepAssump: "\<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>None,m2\<rangle>"
          hence Vstep_case1:
            "\<langle>c1;c2,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c2,m2\<rangle>"
            by (simp add: MWLsSteps_det.seq1)

          from SdlHPPR1 StepAssump R0pair dhequal
            strongdlHPPB_aux[of "d" "PP"
            "R1" "0" "[c1]" "[c1']" "m1" "\<alpha>" "None" "m2" "m1'"]
          obtain p' \<alpha>' m2' where c1c1'reason:
            "p' = None \<and> \<langle>c1',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and> (\<alpha>,\<alpha>') \<in> R1 \<and>
            dhequality_alternative d PP (pp c1) m2 m2'"
            by (simp add: stepResultsinR_def, fastforce)

          with eqpp c1c1'reason have conclpart:
            "\<langle>c1';c2',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>Some c2',m2'\<rangle> \<and>
            dhequality_alternative d PP (pp (c1;c2)) m2 m2'"
            by (auto, simp add: MWLsSteps_det.seq1)

          with passump R0pair c1c1'reason i0
          have case1_concl:
          "\<exists>p' \<alpha>' m2'.
             \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
             stepResultsinR p p' (R0 \<union> (R1 \<union> R2)) \<and>
             ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R1 \<or> (\<alpha>,\<alpha>') \<in> R2) \<and>
             dhequality_alternative d PP (pp (V!i)) m2 m2'"
          by (simp add: stepResultsinR_def, auto)
        }
        moreover
        --"Case 2: first command does not terminate"
        {
          assume passump: "p = Some (c3;c2)"
          assume StepAssump: "\<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c3,m2\<rangle>"

          hence Vstep_case2:  "\<langle>c1;c2,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some (c3;c2),m2\<rangle>"
            by (simp add: MWLsSteps_det.seq2)

          from SdlHPPR1 StepAssump R0pair dhequal
            strongdlHPPB_aux[of "d" "PP"
            "R1" "0" "[c1]" "[c1']" "m1" "\<alpha>" "Some c3" "m2" "m1'"]
          obtain p' c3' \<alpha>' m2' where c1c1'reason:
            "p' = Some c3' \<and> \<langle>c1',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
            ([c3],[c3']) \<in> R1 \<and> (\<alpha>,\<alpha>') \<in> R1 \<and>
            dhequality_alternative d PP (pp c1) m2 m2'"
            by (simp add: stepResultsinR_def, fastforce)

          with eqpp c1c1'reason have conclpart:
            "\<langle>c1';c2',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>Some (c3';c2'),m2'\<rangle> \<and>
            dhequality_alternative d PP (pp (c1;c2)) m2 m2'"
            by (auto, simp add: MWLsSteps_det.seq2)

          from c1c1'reason R0pair R0_def have
            "([c3;c2],[c3';c2']) \<in> R0"
            by auto

          with R0pair conclpart passump c1c1'reason i0
          have case1_concl:
            "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
            stepResultsinR p p' (R0 \<union> (R1 \<union> R2)) \<and>
            ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R1 \<or> (\<alpha>,\<alpha>') \<in> R2) \<and>
            dhequality_alternative d PP (pp (V!i)) m2 m2'"
            by (simp add: stepResultsinR_def, auto)
        }
        ultimately
        show "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
             stepResultsinR p p' (R0 \<union> (R1 \<union> R2)) \<and>
             ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R1 \<or> (\<alpha>,\<alpha>') \<in> R2) \<and>
             dhequality_alternative d PP (pp (V!i)) m2 m2'"
          by blast
      qed

  with inR0 Areflassump2 Up_To_Technique
  have "SdlHPPB d PP (R0 \<union> (R1 \<union> R2))"
    by auto

  with inR0 show "\<exists>R. SdlHPPB d PP R \<and> ([c1;c2],[c1;c2]) \<in> R"
    by auto

qed

theorem Compositionality_Spawn:
  assumes WWs_threads: "WHATWHERE_Secure V"
  assumes uniPPspawn: "unique_PPc (spawn\<^bsub>\<iota>\<^esub> V)"
  shows "WHATWHERE_Secure [spawn\<^bsub>\<iota>\<^esub> V]"
proof (simp add: WHATWHERE_Secure_def, auto)
  fix d PP

  from uniPPspawn have pp_difference: "\<iota> \<notin> set (PPV V)"
    by (simp add: unique_PPc_def)

  --"Step 1"
  from WWs_threads obtain R' where R'assump:
    "SdlHPPB d PP R' \<and> (V,V) \<in> R'"
    by (simp add: WHATWHERE_Secure_def, auto)

  def R \<equiv> "{(V',V''). (V',V'') \<in> R' \<and> set (PPV V') \<subseteq> set (PPV V)
    \<and> set (PPV V'') \<subseteq> set (PPV V)}"

  from R'assump R_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPR: "SdlHPPB d PP R"
    by force

  -- "Step 2"
  def R0 \<equiv> "{(sp1,sp2). \<exists>\<iota>' \<iota>'' V' V''.
    sp1 = [spawn\<^bsub>\<iota>'\<^esub> V'] \<and> sp2 = [spawn\<^bsub>\<iota>''\<^esub> V'']
    \<and> \<iota>' \<notin> set (PPV V) \<and> \<iota>'' \<notin> set (PPV V) \<and> (V',V'') \<in> R}"

  with R_def R'assump pp_difference have inR0:
    "([spawn\<^bsub>\<iota>\<^esub> V],[spawn\<^bsub>\<iota>\<^esub> V]) \<in> R0"
    by auto

  --"Step 3"
  from R0_def R_def R'assump have "Domain R0 \<inter> Domain R = {}"
    by auto

  with commonArefl_subset_commonDomain
  have Areflassump: "Arefl R0 \<inter> Arefl R \<subseteq> {[]}"
    by force

  --"Step 4"
  have disjuptoR0:
    "disj_dlHPP_Bisimulation_Up_To_R' d PP R R0"
    proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def, auto)
      from SdlHPPR show "SdlHPPB d PP R"
        by auto
    next
      from SdlHPPR have symR: "sym R"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      with R0_def show "sym R0"
        by (simp add: sym_def, auto)
    next
      from SdlHPPR have transR: "trans R"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      with R0_def show "trans R0"
        proof -
          {
          fix V1 V2 V3
          assume inR1: "(V1,V2) \<in> R0"
          assume inR2: "(V2,V3) \<in> R0"
          from inR1 R0_def obtain W W' \<iota> \<iota>' where p1: "V1 = [spawn\<^bsub>\<iota>\<^esub> W]
            \<and> V2 = [spawn\<^bsub>\<iota>'\<^esub> W'] \<and> \<iota> \<notin> set (PPV V) \<and> \<iota>' \<notin> set (PPV V)
            \<and> (W,W') \<in> R"
            by auto
          with inR2 R0_def obtain W'' \<iota>'' where p2: "V3 = [spawn\<^bsub>\<iota>''\<^esub> W'']
            \<and> \<iota>'' \<notin> set (PPV V) \<and> (W',W'') \<in> R"
            by auto
          from p1 p2 transR have "(W,W'') \<in> R"
            by (simp add: trans_def, auto)
          with p1 p2 R0_def have "(V1,V3) \<in> R0"
            by auto
          }
          thus ?thesis unfolding trans_def by blast
        qed
    next
      fix V' V''
      from SdlHPPR have eqlenR: "(V',V'') \<in> R \<Longrightarrow> length V' = length V''"
        by (simp add: Strong_dlHPP_Bisimulation_def, auto)
      with R0_def show "(V',V'') \<in> R0 \<Longrightarrow> length V' = length V''"
        by auto
    next
      fix V' V'' i
      assume inR0: "(V',V'') \<in> R0"
      assume irange: "i < length V'"
      from inR0 R0_def obtain \<iota>' \<iota>'' W' W''
        where R0pair: "V' = [spawn\<^bsub>\<iota>'\<^esub> W'] \<and> V'' = [spawn\<^bsub>\<iota>''\<^esub> W'']"
        by auto
      {
        fix m
        from nextmem_exists_and_unique obtain m' where spawnnextmem:
          "\<exists>p \<alpha>. \<langle>spawn\<^bsub>\<iota>'\<^esub> W',m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
          \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>spawn\<^bsub>\<iota>'\<^esub> W',m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m')"
          by force

        hence "m = m'"
          by (metis MWLsSteps_det.spawn)

        with spawnnextmem have eqnextmem:
          "\<lbrakk>spawn\<^bsub>\<iota>'\<^esub> W'\<rbrakk>(m) = m"
          by (simp add: NextMem_def, auto)
      }

      with R0pair irange show "NDC d (V'!i)"
        by (simp add: NDC_def)
    next
      fix V' V'' i m1 m1' m2 \<alpha> p
      assume inR0: "(V',V'') \<in> R0"
      assume irange: "i < length V'"
      assume step: "\<langle>V'!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
      assume dhequal: "m1 \<sim>\<^bsub>d,htchLocSet PP\<^esub> m1'"

      from inR0 R0_def obtain \<iota>' \<iota>'' W' W''
        where R0pair: "V' = [spawn\<^bsub>\<iota>'\<^esub> W']
        \<and> V'' = [spawn\<^bsub>\<iota>''\<^esub> W''] \<and> (W',W'') \<in> R"
        by auto

      with step irange
      have conc_step1: "\<alpha> = W' \<and> p = None \<and> m2 = m1"
        by (simp, metis MWLsSteps_det_cases(6))

      from R0pair irange
      obtain p' \<alpha>' m2' where conc_step2: "\<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle>
        \<and> p' = None \<and> \<alpha>' = W'' \<and> m2' = m1'"
        by (simp, metis MWLsSteps_det.spawn)

      with R0pair conc_step1 dhequal irange
      show "\<exists>p' \<alpha>' m2'. \<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and>
        ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V'!i)) m2 m2'"
        by (simp add: stepResultsinR_def
          dhequality_alternative_def, auto)
    qed
  --"Step 5"
  with Areflassump Up_To_Technique
  have "SdlHPPB d PP (R0 \<union> R)"
    by auto

  with inR0 show "\<exists>R. SdlHPPB d PP R \<and>
    ([spawn\<^bsub>\<iota>\<^esub> V],[spawn\<^bsub>\<iota>\<^esub> V]) \<in> R"
    by auto
qed

theorem Compositionality_If:
  assumes dind: "\<forall>d. b \<equiv>\<^bsub>d\<^esub> b"
  assumes WWs_branch1: "WHATWHERE_Secure [c1]"
  assumes WWs_branch2: "WHATWHERE_Secure [c2]"
  assumes uniPPif: "unique_PPc (if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi)"
  shows "WHATWHERE_Secure [if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi]"
proof (simp add: WHATWHERE_Secure_def, auto)
  fix d PP
  from uniPPif have nocommonPP: "set (PPc c1) \<inter> set (PPc c2) = {}"
    by (simp add: unique_PPc_def)

  from uniPPif have pp_difference: "\<iota> \<notin> set (PPc c1) \<union> set (PPc c2)"
    by (simp add: unique_PPc_def)

  from WWs_branch1 obtain R1' where R1'assump:
    "SdlHPPB d PP R1' \<and> ([c1],[c1]) \<in> R1'"
    by (simp add: WHATWHERE_Secure_def, auto)

  def R1 \<equiv> "{(V,V'). (V,V') \<in> R1' \<and> set (PPV V) \<subseteq> set (PPc c1)
    \<and> set (PPV V') \<subseteq> set (PPc c1)}"

  from R1'assump R1_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPR1: "SdlHPPB d PP R1"
    by force

  from WWs_branch2 obtain R2' where R2'assump:
    "SdlHPPB d PP R2' \<and> ([c2],[c2]) \<in> R2'"
    by (simp add: WHATWHERE_Secure_def, auto)

  def R2 \<equiv> "{(V,V'). (V,V') \<in> R2' \<and> set (PPV V) \<subseteq> set (PPc c2)
    \<and> set (PPV V') \<subseteq> set (PPc c2)}"

  from R2'assump R2_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPR2: "SdlHPPB d PP R2"
    by force

  from nocommonPP have "Domain R1 \<inter> Domain R2 \<subseteq> {[]}"

    by (simp add: R1_def R2_def, auto,
      metis empty_subsetI inf_idem inf_mono set_eq_subset unique_V_uneq)

  with commonArefl_subset_commonDomain
  have Areflassump1: "Arefl R1 \<inter> Arefl R2 \<subseteq> {[]}"
    by force

  with SdlHPPR1 SdlHPPR2 Union_Strong_dlHPP_Bisim have SdlHPPR1R2:
    "SdlHPPB d PP (R1 \<union> R2)"
    by force

  def R \<equiv> "(R1 \<union> R2) \<union> {([],[])}"

  def R0 \<equiv> "{(i1,i2). \<exists>\<iota>' \<iota>'' b' b'' c1' c1'' c2' c2''.
    i1 = [if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi]
    \<and> i2 = [if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi]
    \<and> \<iota>' \<notin> (set (PPc c1) \<union> set (PPc c2))
    \<and> \<iota>'' \<notin> (set (PPc c1) \<union> set (PPc c2)) \<and> ([c1'],[c1'']) \<in> R1
    \<and> ([c2'],[c2'']) \<in> R2 \<and> b' \<equiv>\<^bsub>d\<^esub> b''}"

  with R_def R1_def R1'assump R2_def R2'assump pp_difference dind
  have inR0: "([if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi],[if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi]) \<in> R0"
    by auto

  from R0_def R_def R1_def R2_def
  have "Domain R0 \<inter> Domain R = {}"
    by auto

  with commonArefl_subset_commonDomain
  have Areflassump2: "Arefl R0 \<inter> Arefl R \<subseteq> {[]}"
    by force

  have disjuptoR0:
    "disj_dlHPP_Bisimulation_Up_To_R' d PP R R0"
    proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def, auto)
      from SdlHPPR1R2 adding_emptypair_keeps_SdlHPPB
      show "SdlHPPB d PP R"
        by (simp add: R_def)
    next
      from SdlHPPR1 have symR1: "sym R1"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      from SdlHPPR2 have symR2: "sym R2"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      from symR1 symR2 d_indistinguishable_sym R0_def show "sym R0"
        by (simp add: sym_def, fastforce)
    next
      from SdlHPPR1 have transR1: "trans R1"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      from SdlHPPR2 have transR2: "trans R2"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      show "trans R0"
        proof  -
          {
            fix V' V'' V'''
            assume p1: "(V',V'') \<in> R0"
            assume p2: "(V'',V''') \<in> R0"

            from p1 R0_def obtain \<iota>' \<iota>'' b' b'' c1' c1'' c2' c2'' where
              passump1: "V' = [if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi]
              \<and> V'' = [if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi]
              \<and> \<iota>' \<notin> (set (PPc c1) \<union> set (PPc c2))
              \<and> \<iota>'' \<notin> (set (PPc c1) \<union> set (PPc c2))
              \<and> ([c1'],[c1'']) \<in> R1 \<and> ([c2'],[c2'']) \<in> R2
              \<and> b' \<equiv>\<^bsub>d\<^esub> b''"
              by force

            with p2 R0_def obtain \<iota>''' b''' c1''' c2''' where
              passump2: "V''' = [if\<^bsub>\<iota>'''\<^esub> b''' then c1''' else c2''' fi]
              \<and> \<iota>''' \<notin> (set (PPc c1) \<union> set (PPc c2))
              \<and> ([c1''],[c1''']) \<in> R1 \<and> ([c2''],[c2''']) \<in> R2
              \<and> b'' \<equiv>\<^bsub>d\<^esub> b'''"
              by force

            with passump1 transR1 transR2 d_indistinguishable_trans
            have "([c1'],[c1''']) \<in> R1 \<and> ([c2'],[c2''']) \<in> R2
              \<and> b' \<equiv>\<^bsub>d\<^esub> b'''"
              by (metis transD)

            with passump1 passump2 R0_def have "(V',V''') \<in> R0"
              by auto
          }
          thus ?thesis unfolding trans_def by blast
        qed
    next
      fix V V'
      assume inR0: "(V,V') \<in> R0"
      with R0_def show "length V = length V'" by auto
    next
      fix V' V'' i
      assume inR0: "(V',V'') \<in> R0"
      assume irange: "i < length V'"
      assume notIDC: "\<not> IDC d (V'!i) (htchLoc (pp (V'!i)))"

      from inR0 R0_def obtain \<iota>' \<iota>'' b' b'' c1' c1'' c2' c2''
        where R0pair: "V' = [if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi]
        \<and> V'' = [if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi]
        \<and> \<iota>' \<notin> set (PPc c1) \<union> set (PPc c2)
        \<and> \<iota>'' \<notin> set (PPc c1) \<union> set (PPc c2)
        \<and> ([c1'],[c1'']) \<in> R1 \<and> ([c2'],[c2'']) \<in> R2
        \<and> b' \<equiv>\<^bsub>d\<^esub> b''"
        by force

      have "NDC d (if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi)"
        proof -
          {
            fix m
            from nextmem_exists_and_unique obtain m' p \<alpha> where ifnextmem:
              "\<langle>if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''.(\<exists>p \<alpha>.\<langle>if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>)
              \<longrightarrow> m'' = m')"
              by blast

            hence "m = m'"
              by (metis MWLsSteps_det.iffalse MWLsSteps_det.iftrue)

            with ifnextmem have eqnextmem:
              "\<lbrakk>if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi\<rbrakk>(m) = m"
              by (simp add: NextMem_def, auto)
          }
          thus ?thesis
            by (simp add: NDC_def)
        qed

      with R0pair irange show "NDC d (V'!i)"
        by simp
    next
      fix V' V'' i m1 m1' m2 \<alpha> p
      assume inR0: "(V',V'') \<in> R0"
      assume irange: "i < length V'"
      assume step: "\<langle>V'!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
      assume dhequal: "m1 \<sim>\<^bsub>d,htchLocSet PP\<^esub> m1'"

      from inR0 R0_def obtain \<iota>' \<iota>'' b' b'' c1' c1'' c2' c2''
        where R0pair: "V' = [if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi]
        \<and> V'' = [if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi]
        \<and> \<iota>' \<notin> set (PPc c1) \<union> set (PPc c2)
        \<and> \<iota>'' \<notin> set (PPc c1) \<union> set (PPc c2)
        \<and> ([c1'],[c1'']) \<in> R1 \<and> ([c2'],[c2'']) \<in> R2
        \<and> b' \<equiv>\<^bsub>d\<^esub> b''"
        by force

      with R0pair irange step have case_distinction:
        "(p = Some c1' \<and> BMap (E b' m1) = True)
        \<or> (p = Some c2' \<and> BMap (E b' m1) = False)"
        by (simp, metis MWLsSteps_det_cases(4))
      moreover
      --"Case 1: b evaluates to True"
      {
        assume passump: "p = Some c1'"
        assume eval: "BMap (E b' m1) = True"

        from R0pair step irange have stepconcl: "\<alpha> = [] \<and> m2 = m1"
          by (simp, metis MWLs_semantics.MWLsSteps_det_cases(4))

        from eval R0pair dhequal have eval': "BMap (E b'' m1') = True"
          by (simp add: d_indistinguishable_def dH_equal_def, auto)

        hence step': "\<langle>if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi,m1'\<rangle> \<rightarrow>\<lhd>[]\<rhd>
          \<langle>Some c1'',m1'\<rangle>"
          by (simp add: MWLsSteps_det.iftrue)

        with passump R0pair R_def dhequal stepconcl irange
        have "\<exists>p' \<alpha>' m2'. \<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and>
        ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V'!i)) m2 m2'"
          by (simp add: stepResultsinR_def dhequality_alternative_def,
            auto)
      }
      moreover
      --"Case 2: b evaluates to False"
      {
        assume passump: "p = Some c2'"
        assume eval: "BMap (E b' m1) = False"

        from R0pair step irange have stepconcl: "\<alpha> = [] \<and> m2 = m1"
          by (simp, metis MWLs_semantics.MWLsSteps_det_cases(4))

        from eval R0pair dhequal have eval': "BMap (E b'' m1') = False"
          by (simp add: d_indistinguishable_def dH_equal_def, auto)

        hence step': "\<langle>if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi,m1'\<rangle> \<rightarrow>\<lhd>[]\<rhd>
          \<langle>Some c2'',m1'\<rangle>"
          by (simp add: MWLsSteps_det.iffalse)

        with passump R0pair R_def dhequal stepconcl irange
        have "\<exists>p' \<alpha>' m2'. \<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and>
        ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V'!i)) m2 m2'"
          by (simp add: stepResultsinR_def dhequality_alternative_def,
            auto)
      }
      ultimately
      show "\<exists>p' \<alpha>' m2'. \<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and>
        ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V'!i)) m2 m2'"
        by auto
    qed

  with Areflassump2 Up_To_Technique
  have "SdlHPPB d PP (R0 \<union> R)"
    by auto

  with inR0 show "\<exists>R. SdlHPPB d PP R
    \<and> ([if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi],[if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi]) \<in> R"
    by auto

qed

theorem Compositionality_While:
  assumes dind: "\<forall>d. b \<equiv>\<^bsub>d\<^esub> b"
  assumes WWs_body: "WHATWHERE_Secure [c]"
  assumes uniPPwhile: "unique_PPc (while\<^bsub>\<iota>\<^esub> b do c od)"
  shows "WHATWHERE_Secure [while\<^bsub>\<iota>\<^esub> b do c od]"
proof (simp add: WHATWHERE_Secure_def, auto)
  fix d PP

  from uniPPwhile have pp_difference: "\<iota> \<notin> set (PPc c)"
    by (simp add: unique_PPc_def)

  from WWs_body obtain R' where R'assump:
    "SdlHPPB d PP R' \<and> ([c],[c]) \<in> R'"
    by (simp add: WHATWHERE_Secure_def, auto)

  --"add the empty pair because it is needed later in the proof"
  def R \<equiv> "{(V,V'). (V,V') \<in> R' \<and> set (PPV V) \<subseteq> set (PPc c) \<and>
    set (PPV V') \<subseteq> set (PPc c)} \<union> {([],[])}"

  with R'assump SdlHPPB_restricted_on_PP_is_SdlHPPB
    adding_emptypair_keeps_SdlHPPB
  have SdlHPPR: "SdlHPPB d PP R"
    proof -
      from R'assump SdlHPPB_restricted_on_PP_is_SdlHPPB have
        "SdlHPPB d PP
          {(V,V'). (V,V') \<in> R' \<and> set (PPV V) \<subseteq> set (PPc c) \<and>
          set (PPV V') \<subseteq> set (PPc c)}"
        by force

      with adding_emptypair_keeps_SdlHPPB have
        "SdlHPPB d PP
          ({(V,V'). (V,V') \<in> R' \<and> set (PPV V) \<subseteq> set (PPc c) \<and>
          set (PPV V') \<subseteq> set (PPc c)} \<union> {([],[])})"
        by auto

      with R_def show ?thesis
        by auto
    qed

  def R1 \<equiv> "{(w1,w2). \<exists>\<iota> \<iota>' b b' c1 c1' c2 c2'.
    w1 = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)]
    \<and> w2 = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)]
    \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c)
    \<and> ([c1],[c1']) \<in> R \<and> ([c2],[c2']) \<in> R
    \<and> b \<equiv>\<^bsub>d\<^esub> b'}"

  def R2 \<equiv> "{(w1,w2). \<exists>\<iota> \<iota>' b b' c1 c1'.
    w1 = [while\<^bsub>\<iota>\<^esub> b do c1 od]
    \<and> w2 = [while\<^bsub>\<iota>'\<^esub> b' do c1' od]
    \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c) \<and>
    ([c1],[c1']) \<in> R \<and> b \<equiv>\<^bsub>d\<^esub> b'}"

  def R0 \<equiv> "R1 \<union> R2"

  from R2_def R_def R'assump pp_difference dind
  have inR2: "([while\<^bsub>\<iota>\<^esub> b do c od],[while\<^bsub>\<iota>\<^esub> b do c od]) \<in> R2"
    by auto

  from R0_def R1_def R2_def R_def R'assump have
    "Domain R0 \<inter> Domain R = {}"
    by auto

  with commonArefl_subset_commonDomain
  have Areflassump: "Arefl R0 \<inter> Arefl R \<subseteq> {[]}"
    by force

  --"show some facts about R1 and R2 needed later in the proof at several positions"
  from SdlHPPR have symR: "sym R"
    by (simp add: Strong_dlHPP_Bisimulation_def)
  from symR R1_def d_indistinguishable_sym have symR1: "sym R1"
    by (simp add: sym_def, fastforce)
  from symR R2_def d_indistinguishable_sym have symR2: "sym R2"
    by (simp add: sym_def, fastforce)

  have disjuptoR1R2:
    "disj_dlHPP_Bisimulation_Up_To_R' d PP R R0"
  proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def, auto)
      from SdlHPPR show "SdlHPPB d PP R"
        by auto
    next
      from symR1 symR2 R0_def show "sym R0"
        by (simp add: sym_def)
    next
      from SdlHPPR have transR: "trans R"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      have transR1: "trans R1"
        proof -
          {
            fix V V' V''
            assume p1: "(V,V') \<in> R1"
            assume p2: "(V',V'') \<in> R1"

            from p1 R1_def obtain \<iota> \<iota>' b b' c1 c1' c2 c2' where passump1:
              "V = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)]
              \<and> V' = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)]
              \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c)
              \<and> ([c1],[c1']) \<in> R \<and> ([c2],[c2']) \<in> R
              \<and> b \<equiv>\<^bsub>d\<^esub> b'"
              by force

            with p2 R1_def obtain \<iota>'' b'' c1'' c2'' where passump2:
              "V'' = [c1'';(while\<^bsub>\<iota>''\<^esub> b'' do c2'' od)] \<and> \<iota>'' \<notin> set (PPc c)
              \<and> ([c1'],[c1'']) \<in> R \<and> ([c2'],[c2'']) \<in> R
              \<and> b' \<equiv>\<^bsub>d\<^esub> b''"
              by force

            with passump1 transR d_indistinguishable_trans
            have "([c1],[c1'']) \<in> R \<and> ([c2],[c2'']) \<in> R \<and> b \<equiv>\<^bsub>d\<^esub> b''"
              by (metis trans_def)

            with passump1 passump2 R1_def have "(V,V'') \<in> R1"
              by auto
          }
          thus ?thesis unfolding trans_def by blast
        qed

        have transR2: "trans R2"
         proof -
          {
            fix V V' V''
            assume p1: "(V,V') \<in> R2"
            assume p2: "(V',V'') \<in> R2"

            from p1 R2_def obtain \<iota> \<iota>' b b' c1 c1' where passump1:
              "V = [while\<^bsub>\<iota>\<^esub> b do c1 od]
              \<and> V' = [while\<^bsub>\<iota>'\<^esub> b' do c1' od]
              \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c)
              \<and> ([c1],[c1']) \<in> R \<and> b \<equiv>\<^bsub>d\<^esub> b'"
              by force

            with p2 R2_def obtain \<iota>'' b'' c1'' where passump2:
              "V'' = [while\<^bsub>\<iota>''\<^esub> b'' do c1'' od] \<and> \<iota>'' \<notin> set (PPc c)
              \<and> ([c1'],[c1'']) \<in> R \<and> b' \<equiv>\<^bsub>d\<^esub> b''"
              by force

            with passump1 transR d_indistinguishable_trans
            have "([c1],[c1'']) \<in> R \<and> b \<equiv>\<^bsub>d\<^esub> b''"
              by (metis trans_def)

            with passump1 passump2 R2_def have "(V,V'') \<in> R2"
              by auto
          }
          thus ?thesis unfolding trans_def by blast
        qed

      from SdlHPPR have eqlenR: "\<forall>(V,V')\<in>R. length V = length V'"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      from R1_def eqlenR have eqlenR1: "\<forall>(V,V')\<in>R1. length V = length V'"
        by auto
      from R2_def eqlenR have eqlenR2: "\<forall>(V,V')\<in>R2. length V = length V'"
        by auto

      from R1_def R2_def have "Domain R1 \<inter> Domain R2 = {}"
        by auto

      with commonArefl_subset_commonDomain have Arefl_a:
        "Arefl R1 \<inter> Arefl R2 = {}"
        by force

      with symR1 symR2 transR1 transR2 eqlenR1 eqlenR2 trans_RuR'
      have "trans (R1 \<union> R2)"
        by force
      with R0_def show "trans R0" by auto
    next
      fix V V'
      assume inR0: "(V,V') \<in> R0"
      with R0_def R1_def R2_def show "length V = length V'" by auto
    next
      fix V V' i
      assume inR0: "(V,V') \<in> R0"
      assume irange: "i < length V"
      assume notIDC: "\<not> IDC d (V!i)
        (htchLoc (pp (V!i)))"

      from inR0 R0_def R1_def R2_def obtain \<iota> \<iota>' b b' c1 c1' c2 c2'
        where R0pair: "((V = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)]
        \<and> V' = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)])
        \<or> (V = [while\<^bsub>\<iota>\<^esub> b do c1 od] \<and> V' = [while\<^bsub>\<iota>'\<^esub> b' do c1' od]))
        \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c)
        \<and> ([c1],[c1']) \<in> R \<and> ([c2],[c2']) \<in> R
        \<and> b \<equiv>\<^bsub>d\<^esub> b'"
        by force

      with irange SdlHPPR strongdlHPPB_NDCIDCaux
      [of "d" "PP" "R" "[c1]" "[c1']" "i"]
      have c1NDCIDC:
        "NDC d c1 \<or> IDC d c1 (htchLoc (pp c1))"
        by auto

      -- "first alternative for V and V'"
      have case1: "NDC d (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)) \<or>
        IDC d (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od))
        (htchLoc (pp (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od))))"
        proof -
          have eqnextmem: "\<And>m. \<lbrakk>c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)\<rbrakk>(m) = \<lbrakk>c1\<rbrakk>(m)"
          proof -
            fix m
            from nextmem_exists_and_unique obtain m' where c1nextmem:
              "\<exists>p \<alpha>. \<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m')"
              by force

            hence eqdir1: "\<lbrakk>c1\<rbrakk>(m) = m'"
              by (simp add: NextMem_def, auto)

            from c1nextmem obtain p \<alpha> where "\<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>"
              by auto

            with c1nextmem have
              "\<exists>p \<alpha>. \<langle>c1;(while\<^bsub>\<iota>\<^esub> b do c2 od),m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>c1;(while\<^bsub>\<iota>\<^esub> b do c2 od),m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>)
              \<longrightarrow> m'' = m')"
              by (auto, metis MWLsSteps_det.seq1 MWLsSteps_det.seq2
                option.exhaust, metis MWLsSteps_det_cases(3))

            hence eqdir2: "\<lbrakk>c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)\<rbrakk>(m) = m'"
              by (simp add: NextMem_def, auto)

            with eqdir1 show "\<lbrakk>c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)\<rbrakk>(m) = \<lbrakk>c1\<rbrakk>(m)"
              by auto
          qed

          have eqpp: "pp (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)) = pp c1"
            by simp

          with c1NDCIDC eqnextmem show
            "NDC d (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)) \<or>
            IDC d (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od))
            (htchLoc (pp (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od))))"
            by (simp add: IDC_def NDC_def)
        qed

      -- "second alternative for V V'"
      have case2: "NDC d (while\<^bsub>\<iota>\<^esub> b do c1 od)"
        proof -
          {
            fix m
            from nextmem_exists_and_unique obtain m' p \<alpha>
              where whilenextmem: "\<langle>while\<^bsub>\<iota>\<^esub> b do c1 od,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>while\<^bsub>\<iota>\<^esub> b do c1 od,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>)
              \<longrightarrow> m'' = m')"
              by blast

            hence "m = m'"
              by (metis MWLsSteps_det.whilefalse MWLsSteps_det.whiletrue)

            with whilenextmem have eqnextmem:
              "\<lbrakk>while\<^bsub>\<iota>\<^esub> b do c1 od\<rbrakk>(m) = m"
              by (simp add: NextMem_def, auto)
          }
          thus "NDC d (while\<^bsub>\<iota>\<^esub> b do c1 od)"
            by (simp add: NDC_def)
        qed

      from R0pair case1 case2 irange notIDC
      show "NDC d (V!i)"
        by force
    next
      fix V V' i m1 m1' m2 \<alpha> p
      assume inR0: "(V,V') \<in> R0"
      assume irange: "i < length V"
      assume step: "\<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
      assume dhequal: "m1 \<sim>\<^bsub>d,htchLocSet PP\<^esub> m1'"

      from inR0 R0_def R1_def R2_def obtain \<iota> \<iota>' b b' c1 c1' c2 c2'
        where R0pair: "((V = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)]
        \<and> V' = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)])
        \<or> (V = [while\<^bsub>\<iota>\<^esub> b do c1 od] \<and> V' = [while\<^bsub>\<iota>'\<^esub> b' do c1' od]))
        \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c)
        \<and> ([c1],[c1']) \<in> R \<and> ([c2],[c2']) \<in> R
        \<and> b \<equiv>\<^bsub>d\<^esub> b'"
        by force

      -- "Case 1: V and V' are sequential commands"
      have case1: "\<lbrakk> V = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)];
        V' = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)] \<rbrakk>
        \<Longrightarrow> \<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V!i)) m2 m2'"
        proof -
          assume Vassump: "V = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)]"
          assume V'assump: "V' = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)]"

          have eqpp: "pp (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)) = pp c1"
            by simp

          from Vassump irange step irange obtain c3
            where case_distinction:
            "(p = Some (while\<^bsub>\<iota>\<^esub> b do c2 od) \<and> \<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>None,m2\<rangle>)
            \<or> (p = Some (c3;(while\<^bsub>\<iota>\<^esub> b do c2 od))
            \<and> \<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c3,m2\<rangle>)"
            by (simp, metis MWLsSteps_det_cases(3))
          moreover
          -- "Case 1a: first command terminates"
          {
            assume passump: "p = Some (while\<^bsub>\<iota>\<^esub> b do c2 od)"
            assume stepassump: "\<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>None,m2\<rangle>"

            with R0pair SdlHPPR dhequal
            strongdlHPPB_aux[of "d" "PP" "R"
            _ "[c1]" "[c1']" "m1" "\<alpha>" "None" "m2" "m1'"]
            obtain p' \<alpha>' m2' where c1c1'reason:
              "p' = None \<and> \<langle>c1',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and> (\<alpha>,\<alpha>') \<in> R \<and>
              dhequality_alternative d PP (pp c1) m2 m2'"
              by (simp add: stepResultsinR_def, fastforce)

            hence conclpart:
            "\<langle>c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od),m1'\<rangle>
              \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>Some (while\<^bsub>\<iota>'\<^esub> b' do c2' od),m2'\<rangle>"
              by (auto, simp add: MWLsSteps_det.seq1)

            from R0pair R0_def R2_def have
              "([while\<^bsub>\<iota>\<^esub> b do c2 od],[while\<^bsub>\<iota>'\<^esub> b' do c2' od]) \<in> R0"
              by simp

            with passump V'assump Vassump eqpp conclpart
              c1c1'reason irange
            have "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
              stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or>
              (\<alpha>,\<alpha>') \<in> R) \<and>
              dhequality_alternative d PP (pp (V!i)) m2 m2'"
              by (simp add: stepResultsinR_def, auto)
          }
          moreover
          -- "Case 1b: first command does not terminate"
          {
            assume passump: "p = Some (c3;(while\<^bsub>\<iota>\<^esub> b do c2 od))"
            assume stepassump: "\<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c3,m2\<rangle>"

            with R0pair SdlHPPR dhequal
            strongdlHPPB_aux[of "d" "PP" "R"
            _ "[c1]" "[c1']" "m1" "\<alpha>" "Some c3" "m2" "m1'"]
            obtain p' c3' \<alpha>' m2' where c1c1'reason:
              "p' = Some c3' \<and> \<langle>c1',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
              ([c3],[c3']) \<in> R \<and> (\<alpha>,\<alpha>') \<in> R \<and>
              dhequality_alternative d PP (pp c1) m2 m2'"
              by (simp add: stepResultsinR_def, fastforce)

            hence conclpart:
            "\<langle>c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od),m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd>
              \<langle>Some (c3';while\<^bsub>\<iota>'\<^esub> b' do c2' od),m2'\<rangle>"
              by (auto, simp add: MWLsSteps_det.seq2)

            from c1c1'reason R0pair R0_def R1_def have
              "([c3;while\<^bsub>\<iota>\<^esub> b do c2 od],[c3';while\<^bsub>\<iota>'\<^esub> b' do c2' od]) \<in> R0"
              by simp

            with passump V'assump Vassump eqpp conclpart c1c1'reason irange
            have "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
              stepResultsinR p p' (R0 \<union> R) \<and>
              ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
              dhequality_alternative d PP (pp (V!i)) m2 m2'"
              by (simp add: stepResultsinR_def, auto)
          }
          ultimately show "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
              stepResultsinR p p' (R0 \<union> R) \<and>
            ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
              dhequality_alternative d PP (pp (V!i)) m2 m2'"
            by auto
        qed

      -- "Case 2: V and V' are while commands"
      have case2: "\<lbrakk> V = [while\<^bsub>\<iota>\<^esub> b do c1 od]; V' = [while\<^bsub>\<iota>'\<^esub> b' do c1' od] \<rbrakk>
        \<Longrightarrow> \<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V!i)) m2 m2'"
        proof -
          assume Vassump: "V = [while\<^bsub>\<iota>\<^esub> b do c1 od]"
          assume V'assump: "V' = [while\<^bsub>\<iota>'\<^esub> b' do c1' od]"

          from Vassump irange step have case_distinction:
            "(p = None \<and> BMap (E b m1) = False)
            \<or> p = (Some (c1;while\<^bsub>\<iota>\<^esub> b do c1 od)) \<and> BMap (E b m1) = True"
            by (simp, metis MWLsSteps_det_cases(5) option.simps(2))
          moreover
          --"Case 2a: b evaluates to False"
          {
            assume passump: "p = None"
            assume eval: "BMap (E b m1) = False"

            with Vassump step irange have stepconcl: "\<alpha> = [] \<and> m2 = m1"
              by (simp, metis (no_types) MWLsSteps_det_cases(5))

            from eval R0pair dhequal have eval': "BMap (E b' m1') = False"
              by (simp add: d_indistinguishable_def dH_equal_def, auto)

            hence "\<langle>while\<^bsub>\<iota>'\<^esub> b' do c1' od,m1'\<rangle> \<rightarrow>\<lhd>[]\<rhd> \<langle>None,m1'\<rangle>"
              by (simp add: MWLsSteps_det.whilefalse)

            with passump R_def Vassump V'assump stepconcl dhequal irange
            have "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
            stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
            dhequality_alternative d PP (pp (V!i)) m2 m2'"
              by (simp add: stepResultsinR_def dhequality_alternative_def,
                auto)
          }
          moreover
          -- "Case 2b: b evaluates to True"
          {
            assume passump: "p = (Some (c1;while\<^bsub>\<iota>\<^esub> b do c1 od))"
            assume eval: "BMap (E b m1) = True"

            with Vassump step irange have stepconcl: "\<alpha> = [] \<and> m2 = m1"
              by (simp, metis (no_types) MWLsSteps_det_cases(5))

            from eval R0pair dhequal have eval':
              "BMap (E b' m1') = True"
              by (simp add: d_indistinguishable_def dH_equal_def, auto)

            hence step': "\<langle>while\<^bsub>\<iota>'\<^esub> b' do c1' od,m1'\<rangle> \<rightarrow>\<lhd>[]\<rhd>
              \<langle>Some (c1';while\<^bsub>\<iota>'\<^esub> b' do c1' od),m1'\<rangle>"
              by (simp add: MWLsSteps_det.whiletrue)

            from R1_def R0pair have inR1:
              "([c1;while\<^bsub>\<iota>\<^esub> b do c1 od],[c1';while\<^bsub>\<iota>'\<^esub> b' do c1' od]) \<in> R1"
              by auto

            with step' R0_def passump R_def Vassump V'assump
              stepconcl dhequal irange
            have "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
            stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
            dhequality_alternative d PP (pp (V!i)) m2 m2'"
              by (simp add: stepResultsinR_def dhequality_alternative_def,
                auto)
          }
          ultimately
          show "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
            stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
            dhequality_alternative d PP (pp (V!i)) m2 m2'"
            by auto
        qed

      with case1 R0pair show "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V!i)) m2 m2'"
        by auto
    qed

  with Areflassump Up_To_Technique
  have "SdlHPPB d PP (R0 \<union> R)"
    by auto

  with inR2 R0_def show "\<exists>R. SdlHPPB d PP R \<and>
    ([while\<^bsub>\<iota>\<^esub> b do c od], [while\<^bsub>\<iota>\<^esub> b do c od]) \<in> R"
    by auto
qed

end

end


(*  Title:      ZF/Coind/Map.thy
    Author:     Jacob Frost, Cambridge University Computer Laboratory
    Copyright   1995  University of Cambridge

Some sample proofs of inclusions for the final coalgebra "U" (by lcp).
*)

theory Map imports Main begin

definition
  TMap :: "[i,i] => i"  where
   "TMap(A,B) == {m \<in> Pow(A*\<Union>(B)).\<forall>a \<in> A. m``{a} \<in> B}"

definition
  PMap :: "[i,i] => i"  where
   "PMap(A,B) == TMap(A,cons(0,B))"

(* Note: 0 \<in> B ==> TMap(A,B) = PMap(A,B) *)

definition
  map_emp :: i  where
   "map_emp == 0"

definition
  map_owr :: "[i,i,i]=>i"  where
   "map_owr(m,a,b) == \<Sigma> x \<in> {a} \<union> domain(m). if x=a then b else m``{x}"

definition
  map_app :: "[i,i]=>i"  where
   "map_app(m,a) == m``{a}"

lemma "{0,1} \<subseteq> {1} \<union> TMap(I, {0,1})"
by (unfold TMap_def, blast)

lemma "{0} \<union> TMap(I,1) \<subseteq> {1} \<union> TMap(I, {0} \<union> TMap(I,1))"
by (unfold TMap_def, blast)

lemma "{0,1} \<union> TMap(I,2) \<subseteq> {1} \<union> TMap(I, {0,1} \<union> TMap(I,2))"
by (unfold TMap_def, blast)

(*A bit too slow.
lemma "{0,1} \<union> TMap(I,TMap(I,2)) \<union> TMap(I,2) \<subseteq>
       {1} \<union> TMap(I, {0,1} \<union> TMap(I,TMap(I,2)) \<union> TMap(I,2))"
by (unfold TMap_def, blast)
*)

(* ############################################################ *)
(* Lemmas                                                       *)
(* ############################################################ *)

lemma qbeta_if: "Sigma(A,B)``{a} = (if a \<in> A then B(a) else 0)"
by auto

lemma qbeta: "a \<in> A ==> Sigma(A,B)``{a} = B(a)"
by fast

lemma qbeta_emp: "a\<notin>A ==> Sigma(A,B)``{a} = 0"
by fast

lemma image_Sigma1: "a \<notin> A ==> Sigma(A,B)``{a}=0"
by fast

(* ############################################################ *)
(* Inclusion in Quine Universes                                 *)
(* ############################################################ *)

(* Lemmas *)

lemma MapQU_lemma:
    "A \<subseteq> univ(X) ==> Pow(A * \<Union>(quniv(X))) \<subseteq> quniv(X)"
apply (unfold quniv_def)
apply (rule Pow_mono)
apply (rule subset_trans [OF Sigma_mono product_univ])
apply (erule subset_trans)
apply (rule arg_subset_eclose [THEN univ_mono])
apply (simp add: Union_Pow_eq)
done

(* Theorems *)

lemma mapQU:
  "[| m \<in> PMap(A,quniv(B)); !!x. x \<in> A ==> x \<in> univ(B) |] ==> m \<in> quniv(B)"
apply (unfold PMap_def TMap_def)
apply (blast intro!: MapQU_lemma [THEN subsetD])
done

(* ############################################################ *)
(* Monotonicity                                                 *)
(* ############################################################ *)

lemma PMap_mono: "B \<subseteq> C ==> PMap(A,B)<=PMap(A,C)"
by (unfold PMap_def TMap_def, blast)

(* ############################################################ *)
(* Introduction Rules                                           *)
(* ############################################################ *)

(** map_emp **)

lemma pmap_empI: "map_emp \<in> PMap(A,B)"
by (unfold map_emp_def PMap_def TMap_def, auto)

(** map_owr **)

lemma pmap_owrI:
  "[| m \<in> PMap(A,B); a \<in> A; b \<in> B |]  ==> map_owr(m,a,b):PMap(A,B)"
apply (unfold map_owr_def PMap_def TMap_def, safe)
apply (simp_all add: if_iff, auto)
(*Remaining subgoal*)
apply (rule excluded_middle [THEN disjE])
apply (erule image_Sigma1)
apply (drule_tac psi = "?uu \<notin> B" in asm_rl)
apply (auto simp add: qbeta)
done

(** map_app **)

lemma tmap_app_notempty:
  "[| m \<in> TMap(A,B); a \<in> domain(m) |] ==> map_app(m,a) \<noteq>0"
by (unfold TMap_def map_app_def, blast)

lemma tmap_appI:
  "[| m \<in> TMap(A,B); a \<in> domain(m) |] ==> map_app(m,a):B"
by (unfold TMap_def map_app_def domain_def, blast)

lemma pmap_appI:
  "[| m \<in> PMap(A,B); a \<in> domain(m) |] ==> map_app(m,a):B"
apply (unfold PMap_def)
apply (frule tmap_app_notempty, assumption)
apply (drule tmap_appI, auto)
done

(** domain **)

lemma tmap_domainD:
  "[| m \<in> TMap(A,B); a \<in> domain(m) |] ==> a \<in> A"
by (unfold TMap_def, blast)

lemma pmap_domainD:
  "[| m \<in> PMap(A,B); a \<in> domain(m) |] ==> a \<in> A"
by (unfold PMap_def TMap_def, blast)

(* ############################################################ *)
(* Equalities                                                   *)
(* ############################################################ *)

(** Domain **)

(* Lemmas *)

lemma domain_UN: "domain(\<Union>x \<in> A. B(x)) = (\<Union>x \<in> A. domain(B(x)))"
by fast

lemma domain_Sigma: "domain(Sigma(A,B)) = {x \<in> A. \<exists>y. y \<in> B(x)}"
by blast

(* Theorems *)

lemma map_domain_emp: "domain(map_emp) = 0"
by (unfold map_emp_def, blast)

lemma map_domain_owr:
  "b \<noteq> 0 ==> domain(map_owr(f,a,b)) = {a} \<union> domain(f)"
apply (unfold map_owr_def)
apply (auto simp add: domain_Sigma)
done

(** Application **)

lemma map_app_owr:
  "map_app(map_owr(f,a,b),c) = (if c=a then b else map_app(f,c))"
by (simp add: qbeta_if  map_app_def map_owr_def, blast)

lemma map_app_owr1: "map_app(map_owr(f,a,b),a) = b"
by (simp add: map_app_owr)

lemma map_app_owr2: "c \<noteq> a ==> map_app(map_owr(f,a,b),c)= map_app(f,c)"
by (simp add: map_app_owr)

end