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

section \<open>Slicing framework\<close>

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

subsection \<open>Abstract slicing\<close>

subsubsection \<open>Definition 1\<close>

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

subsubsection \<open>Definition 2\<close>

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

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

end

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

subsubsection \<open>Definition 3\<close>

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

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

subsubsection \<open>Lemma 1\<close>

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

end

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

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

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

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

end

subsubsection \<open>Definition 4\<close>

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

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

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

sublocale event_separable_splitter where event_splitter = event_splitter .

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

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

subsubsection \<open>Lemma 2\<close>

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

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

subsubsection \<open>Theorem 1\<close>

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

subsubsection \<open>Corollary 1\<close>

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

end

subsubsection \<open>Definition 5\<close>

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

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

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

subsubsection \<open>Theorem 2\<close>

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

end

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

subsubsection \<open>Lemma 3\<close>

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

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

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

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

subsubsection \<open>Theorem 3\<close>

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

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

end

(*<*)
end
(*>*)


section \<open>Semantics\<close>

theory Semantics imports Labels Com begin

subsection \<open>Small Step Semantics\<close>

inductive red :: "cmd * state \<Rightarrow> cmd * state \<Rightarrow> bool"
and red' :: "cmd \<Rightarrow> state \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> bool"
  ("((1\<langle>_,/_\<rangle>) \<rightarrow>/ (1\<langle>_,/_\<rangle>))" [0,0,0,0] 81)
where
   "\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle> == red (c,s) (c',s')"
  | RedLAss:
   "\<langle>V:=e,s\<rangle> \<rightarrow> \<langle>Skip,s(V:=(interpret e s))\<rangle>"

  | SeqRed:
  "\<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s'\<rangle> \<Longrightarrow> \<langle>c\<^sub>1;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>1';;c\<^sub>2,s'\<rangle>"

  | RedSeq:
  "\<langle>Skip;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>2,s\<rangle>"

  | RedCondTrue:
  "interpret b s = Some true \<Longrightarrow> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>1,s\<rangle>"

  | RedCondFalse:
  "interpret b s = Some false \<Longrightarrow> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>2,s\<rangle>"

  | RedWhileTrue:
  "interpret b s = Some true \<Longrightarrow> \<langle>while (b) c,s\<rangle> \<rightarrow> \<langle>c;;while (b) c,s\<rangle>"

  | RedWhileFalse:
  "interpret b s = Some false \<Longrightarrow> \<langle>while (b) c,s\<rangle> \<rightarrow> \<langle>Skip,s\<rangle>"

lemmas red_induct = red.induct[split_format (complete)]

abbreviation reds ::"cmd \<Rightarrow> state \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> bool"
   ("((1\<langle>_,/_\<rangle>) \<rightarrow>*/ (1\<langle>_,/_\<rangle>))" [0,0,0,0] 81) where
  "\<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle> == red\<^sup>*\<^sup>* (c,s) (c',s')"

subsection\<open>Label Semantics\<close>

inductive step :: "cmd \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> bool"
   ("(_ \<turnstile> (1\<langle>_,/_,/_\<rangle>) \<leadsto>/ (1\<langle>_,/_,/_\<rangle>))" [51,0,0,0,0,0,0] 81)
where

StepLAss:
  "V:=e \<turnstile> \<langle>V:=e,s,0\<rangle> \<leadsto> \<langle>Skip,s(V:=(interpret e s)),1\<rangle>"

| StepSeq:
  "\<lbrakk>labels (c\<^sub>1;;c\<^sub>2) l (Skip;;c\<^sub>2); labels (c\<^sub>1;;c\<^sub>2) #:c\<^sub>1 c\<^sub>2; l < #:c\<^sub>1\<rbrakk>
  \<Longrightarrow> c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>Skip;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1\<rangle>"

| StepSeqWhile:
  "labels (while (b) c') l (Skip;;while (b) c')
  \<Longrightarrow> while (b) c' \<turnstile> \<langle>Skip;;while (b) c',s,l\<rangle> \<leadsto> \<langle>while (b) c',s,0\<rangle>"

| StepCondTrue:
  "interpret b s = Some true
     \<Longrightarrow> if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1,s,1\<rangle>"

| StepCondFalse:
  "interpret b s = Some false
  \<Longrightarrow> if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1 + 1\<rangle>"

| StepWhileTrue:
  "interpret b s = Some true
     \<Longrightarrow> while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>c;;while (b) c,s,2\<rangle>"

| StepWhileFalse:
  "interpret b s = Some false \<Longrightarrow> while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>Skip,s,1\<rangle>"

| StepRecSeq1:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>
  \<Longrightarrow> prog;;c\<^sub>2 \<turnstile> \<langle>c;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c';;c\<^sub>2,s',l'\<rangle>"

| StepRecSeq2:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>
  \<Longrightarrow> c\<^sub>1;;prog \<turnstile> \<langle>c,s,l + #:c\<^sub>1\<rangle> \<leadsto> \<langle>c',s',l' + #:c\<^sub>1\<rangle>"

| StepRecCond1:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>
  \<Longrightarrow> if (b) prog else c\<^sub>2 \<turnstile> \<langle>c,s,l + 1\<rangle> \<leadsto> \<langle>c',s',l' + 1\<rangle>"

| StepRecCond2:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>
  \<Longrightarrow> if (b) c\<^sub>1 else prog \<turnstile> \<langle>c,s,l + #:c\<^sub>1 + 1\<rangle> \<leadsto> \<langle>c',s',l' + #:c\<^sub>1 + 1\<rangle>"

| StepRecWhile:
  "cx \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>
  \<Longrightarrow> while (b) cx \<turnstile> \<langle>c;;while (b) cx,s,l + 2\<rangle> \<leadsto> \<langle>c';;while (b) cx,s',l' + 2\<rangle>"

lemma step_label_less:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<Longrightarrow> l < #:prog \<and> l' < #:prog"
proof(induct rule:step.induct)
  case (StepSeq c\<^sub>1 c\<^sub>2 l s)
  from \<open>labels (c\<^sub>1;;c\<^sub>2) l (Skip;;c\<^sub>2)\<close>
  have "l < #:(c\<^sub>1;; c\<^sub>2)" by(rule label_less_num_inner_nodes)
  thus ?case by(simp add:num_inner_nodes_gr_0)
next
  case (StepSeqWhile b cx l s)
  from \<open>labels (while (b) cx) l (Skip;;while (b) cx)\<close>
  have "l < #:(while (b) cx)" by(rule label_less_num_inner_nodes)
  thus ?case by simp
qed (auto intro:num_inner_nodes_gr_0)

abbreviation steps :: "cmd \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> bool"
   ("(_ \<turnstile> (1\<langle>_,/_,/_\<rangle>) \<leadsto>*/ (1\<langle>_,/_,/_\<rangle>))" [51,0,0,0,0,0,0] 81) where
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle> ==
     (\<lambda>(c,s,l) (c',s',l'). prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>)\<^sup>*\<^sup>* (c,s,l) (c',s',l')"

subsection\<open>Proof of bisimulation of @{term "\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>"}\\
  and @{term "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle>"} via @{term "labels"}\<close>

(*<*)
lemmas converse_rtranclp_induct3 =
  converse_rtranclp_induct[of _ "(ax,ay,az)" "(bx,by,bz)", split_rule,
                 consumes 1, case_names refl step]
(*>*)

subsubsection \<open>From @{term "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle>"} to
  @{term "\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>"}\<close>

lemma step_red:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<Longrightarrow> \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>"
by(induct rule:step.induct,rule RedLAss,auto intro:red.intros)

lemma steps_reds:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle> \<Longrightarrow> \<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>"
proof(induct rule:converse_rtranclp_induct3)
  case refl thus ?case by simp
next
  case (step c s l c'' s'' l'')
  then have "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s'',l''\<rangle>"
    and "\<langle>c'',s''\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>" by simp_all
  from \<open>prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s'',l''\<rangle>\<close> have "\<langle>c,s\<rangle> \<rightarrow> \<langle>c'',s''\<rangle>"
    by(fastforce intro:step_red)
  with \<open>\<langle>c'',s''\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>\<close> show ?case
    by(fastforce intro:converse_rtranclp_into_rtranclp)
qed

(*<*)declare fun_upd_apply [simp del] One_nat_def [simp del](*>*)

subsubsection \<open>From @{term "\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>"} and @{term labels} to
  @{term "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle>"}\<close>

lemma red_step:
  "\<lbrakk>labels prog l c; \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<rbrakk>
  \<Longrightarrow> \<exists>l'. prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels prog l' c'"
proof(induct arbitrary:c' rule:labels.induct)
  case (Labels_Base c)
  from \<open>\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<close> show ?case
  proof(induct rule:red_induct)
    case (RedLAss V e s)
    have "V:=e \<turnstile> \<langle>V:=e,s,0\<rangle> \<leadsto> \<langle>Skip,s(V:=(interpret e s)),1\<rangle>" by(rule StepLAss)
    have "labels (V:=e) 1 Skip" by(fastforce intro:Labels_LAss)
    with \<open>V:=e \<turnstile> \<langle>V:=e,s,0\<rangle> \<leadsto> \<langle>Skip,s(V:=(interpret e s)),1\<rangle>\<close> show ?case by blast
  next
    case (SeqRed c\<^sub>1 s c\<^sub>1' s' c\<^sub>2)
    from \<open>\<exists>l'. c\<^sub>1 \<turnstile> \<langle>c\<^sub>1,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1',s',l'\<rangle> \<and> labels c\<^sub>1 l' c\<^sub>1'\<close>
    obtain l' where "c\<^sub>1 \<turnstile> \<langle>c\<^sub>1,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1',s',l'\<rangle>" and "labels c\<^sub>1 l' c\<^sub>1'" by blast
    from \<open>c\<^sub>1 \<turnstile> \<langle>c\<^sub>1,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1',s',l'\<rangle>\<close> have "c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>c\<^sub>1;;c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1';;c\<^sub>2,s',l'\<rangle>"
      by(rule StepRecSeq1)
    moreover
    from \<open>labels c\<^sub>1 l' c\<^sub>1'\<close> have "labels (c\<^sub>1;;c\<^sub>2) l' (c\<^sub>1';;c\<^sub>2)" by(rule Labels_Seq1)
    ultimately show ?case by blast
  next
    case (RedSeq c\<^sub>2 s)
    have "labels c\<^sub>2 0 c\<^sub>2" by(rule Labels.Labels_Base)
    hence "labels (Skip;;c\<^sub>2) (0 + #:Skip) c\<^sub>2" by(rule Labels_Seq2)
    have "labels (Skip;;c\<^sub>2) 0 (Skip;;c\<^sub>2)" by(rule Labels.Labels_Base)
    with \<open>labels (Skip;;c\<^sub>2) (0 + #:Skip) c\<^sub>2\<close>
    have "Skip;;c\<^sub>2 \<turnstile> \<langle>Skip;;c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:Skip\<rangle>"
      by(fastforce intro:StepSeq)
    with \<open>labels (Skip;;c\<^sub>2) (0 + #:Skip) c\<^sub>2\<close> show ?case by auto
  next
    case (RedCondTrue b s c\<^sub>1 c\<^sub>2)
    from \<open>interpret b s = Some true\<close>
    have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1,s,1\<rangle>"
      by(rule StepCondTrue)
    have "labels (if (b) c\<^sub>1 else c\<^sub>2) (0 + 1) c\<^sub>1"
      by(rule Labels_CondTrue,rule Labels.Labels_Base)
    with \<open>if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1,s,1\<rangle>\<close> show ?case by auto
  next
    case (RedCondFalse b s c\<^sub>1 c\<^sub>2)
    from \<open>interpret b s = Some false\<close>
    have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1 + 1\<rangle>"
      by(rule StepCondFalse)
    have "labels (if (b) c\<^sub>1 else c\<^sub>2) (0 + #:c\<^sub>1 + 1) c\<^sub>2"
      by(rule Labels_CondFalse,rule Labels.Labels_Base)
    with \<open>if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1 + 1\<rangle>\<close>
    show ?case by auto
  next
    case (RedWhileTrue b s c)
    from \<open>interpret b s = Some true\<close>
    have "while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>c;; while (b) c,s,2\<rangle>"
      by(rule StepWhileTrue)
    have "labels (while (b) c) (0 + 2) (c;; while (b) c)"
      by(rule Labels_WhileBody,rule Labels.Labels_Base)
    with \<open>while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>c;; while (b) c,s,2\<rangle>\<close>
    show ?case by(auto simp del:add_2_eq_Suc')
  next
    case (RedWhileFalse b s c)
    from \<open>interpret b s = Some false\<close>
    have "while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>Skip,s,1\<rangle>"
      by(rule StepWhileFalse)
    have "labels (while (b) c) 1 Skip" by(rule Labels_WhileExit)
    with \<open>while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>Skip,s,1\<rangle>\<close> show ?case by auto
  qed
next
  case (Labels_LAss V e)
  from \<open>\<langle>Skip,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<close> have False by(auto elim:red.cases)
  thus ?case by simp
next
  case (Labels_Seq1 c\<^sub>1 l c c\<^sub>2)
  note IH = \<open>\<And>c'. \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle> \<Longrightarrow>
        \<exists>l'. c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>1 l' c'\<close>
  from \<open>\<langle>c;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<close>
  have "(c = Skip \<and> c' = c\<^sub>2 \<and> s = s') \<or> (\<exists>c''. c' = c'';;c\<^sub>2)"
    by -(erule red.cases,auto)
  thus ?case
  proof
    assume [simp]:"c = Skip \<and> c' = c\<^sub>2 \<and> s = s'"
    from \<open>labels c\<^sub>1 l c\<close> have "l < #:c\<^sub>1"
      by(rule label_less_num_inner_nodes[simplified])
    have "labels (c\<^sub>1;;c\<^sub>2) (0 + #:c\<^sub>1) c\<^sub>2"
      by(rule Labels_Seq2,rule Labels_Base)
    from \<open>labels c\<^sub>1 l c\<close> have "labels (c\<^sub>1;; c\<^sub>2) l (Skip;;c\<^sub>2)"
      by(fastforce intro:Labels.Labels_Seq1)
    with \<open>labels (c\<^sub>1;;c\<^sub>2) (0 + #:c\<^sub>1) c\<^sub>2\<close> \<open>l < #:c\<^sub>1\<close>
    have "c\<^sub>1;; c\<^sub>2 \<turnstile> \<langle>Skip;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1\<rangle>"
      by(fastforce intro:StepSeq)
    with \<open>labels (c\<^sub>1;;c\<^sub>2) (0 + #:c\<^sub>1) c\<^sub>2\<close> show ?case by auto
  next
    assume "\<exists>c''. c' = c'';;c\<^sub>2"
    then obtain c'' where [simp]:"c' = c'';;c\<^sub>2" by blast
    with \<open>\<langle>c;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<close> have "\<langle>c,s\<rangle> \<rightarrow> \<langle>c'',s'\<rangle>"
      by(auto elim!:red.cases,induct c\<^sub>2,auto)
    from IH[OF this] obtain l' where "c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s',l'\<rangle>"
      and "labels c\<^sub>1 l' c''" by blast
    from \<open>c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s',l'\<rangle>\<close> have "c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>c;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c'';;c\<^sub>2,s',l'\<rangle>"
      by(rule StepRecSeq1)
    from \<open>labels c\<^sub>1 l' c''\<close> have "labels (c\<^sub>1;;c\<^sub>2) l' (c'';;c\<^sub>2)"
      by(rule Labels.Labels_Seq1)
    with \<open>c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>c;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c'';;c\<^sub>2,s',l'\<rangle>\<close> show ?case by auto
  qed
next
  case (Labels_Seq2 c\<^sub>2 l c c\<^sub>1 c')
  note IH = \<open>\<And>c'. \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle> \<Longrightarrow>
            \<exists>l'. c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>2 l' c'\<close>
  from IH[OF \<open>\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<close>] obtain l' where "c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    and "labels c\<^sub>2 l' c'" by blast
  from \<open>c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>\<close> have "c\<^sub>1;; c\<^sub>2 \<turnstile> \<langle>c,s,l + #:c\<^sub>1\<rangle> \<leadsto> \<langle>c',s',l' + #:c\<^sub>1\<rangle>"
    by(rule StepRecSeq2)
  moreover
  from \<open>labels c\<^sub>2 l' c'\<close> have "labels (c\<^sub>1;;c\<^sub>2) (l' + #:c\<^sub>1) c'"
    by(rule Labels.Labels_Seq2)
  ultimately show ?case by blast
next
  case (Labels_CondTrue c\<^sub>1 l c b c\<^sub>2 c')
  note label = \<open>labels c\<^sub>1 l c\<close> and red = \<open>\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<close>
    and IH = \<open>\<And>c'. \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle> \<Longrightarrow>
                   \<exists>l'. c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>1 l' c'\<close>
  from IH[OF \<open>\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<close>] obtain l' where "c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    and "labels c\<^sub>1 l' c'" by blast
  from \<open>c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>\<close>
  have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>c,s,l + 1\<rangle> \<leadsto> \<langle>c',s',l' + 1\<rangle>"
    by(rule StepRecCond1)
  moreover
  from \<open>labels c\<^sub>1 l' c'\<close> have "labels (if (b) c\<^sub>1 else c\<^sub>2) (l' + 1) c'"
    by(rule Labels.Labels_CondTrue)
  ultimately show ?case by blast
next
  case (Labels_CondFalse c\<^sub>2 l c b c\<^sub>1 c')
  note IH = \<open>\<And>c'. \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle> \<Longrightarrow>
            \<exists>l'. c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>2 l' c'\<close>
  from IH[OF \<open>\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<close>] obtain l' where "c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    and "labels c\<^sub>2 l' c'" by blast
  from \<open>c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>\<close>
  have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>c,s,l + #:c\<^sub>1 + 1\<rangle> \<leadsto> \<langle>c',s',l' + #:c\<^sub>1 + 1\<rangle>"
    by(rule StepRecCond2)
  moreover
  from \<open>labels c\<^sub>2 l' c'\<close> have "labels (if (b) c\<^sub>1 else c\<^sub>2) (l' + #:c\<^sub>1 + 1) c'"
    by(rule Labels.Labels_CondFalse)
  ultimately show ?case by blast
next
  case (Labels_WhileBody c' l c b cx)
  note IH = \<open>\<And>c''. \<langle>c,s\<rangle> \<rightarrow> \<langle>c'',s'\<rangle> \<Longrightarrow>
            \<exists>l'. c' \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s',l'\<rangle> \<and> labels c' l' c''\<close>
  from \<open>\<langle>c;;while (b) c',s\<rangle> \<rightarrow> \<langle>cx,s'\<rangle>\<close>
  have "(c = Skip \<and> cx = while (b) c' \<and> s = s') \<or> (\<exists>c''. cx = c'';;while (b) c')"
    by -(erule red.cases,auto)
  thus ?case
  proof
    assume [simp]:"c = Skip \<and> cx = while (b) c' \<and> s = s'"
    have "labels (while (b) c') 0 (while (b) c')"
      by(fastforce intro:Labels_Base)
    from \<open>labels c' l c\<close> have "labels (while (b) c') (l + 2) (Skip;;while (b) c')"
      by(fastforce intro:Labels.Labels_WhileBody simp del:add_2_eq_Suc')
    hence "while (b) c' \<turnstile> \<langle>Skip;;while (b) c',s,l + 2\<rangle> \<leadsto> \<langle>while (b) c',s,0\<rangle>"
      by(rule StepSeqWhile)
    with \<open>labels (while (b) c') 0 (while (b) c')\<close> show ?case by simp blast
  next
    assume "\<exists>c''. cx = c'';;while (b) c'"
    then obtain c'' where [simp]:"cx = c'';;while (b) c'" by blast
    with \<open>\<langle>c;;while (b) c',s\<rangle> \<rightarrow> \<langle>cx,s'\<rangle>\<close> have "\<langle>c,s\<rangle> \<rightarrow> \<langle>c'',s'\<rangle>"
      by(auto elim:red.cases)
    from IH[OF this] obtain l' where "c' \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s',l'\<rangle>"
      and "labels c' l' c''" by blast
    from \<open>c' \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s',l'\<rangle>\<close>
    have "while (b) c' \<turnstile> \<langle>c;;while (b) c',s,l + 2\<rangle> \<leadsto> \<langle>c'';;while (b) c',s',l' + 2\<rangle>"
      by(rule StepRecWhile)
    moreover
    from \<open>labels c' l' c''\<close> have "labels (while (b) c') (l' + 2) (c'';;while (b) c')"
      by(rule Labels.Labels_WhileBody)
    ultimately show ?case by simp blast
  qed
next
  case (Labels_WhileExit b c' c'')
  from \<open>\<langle>Skip,s\<rangle> \<rightarrow> \<langle>c'',s'\<rangle>\<close> have False by(auto elim:red.cases)
  thus ?case by simp
qed

lemma reds_steps:
  "\<lbrakk>\<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>; labels prog l c\<rbrakk>
  \<Longrightarrow> \<exists>l'. prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle> \<and> labels prog l' c'"
proof(induct rule:rtranclp_induct2)
  case refl
  from \<open>labels prog l c\<close> show ?case by blast
next
  case (step c'' s'' c' s')
  note IH = \<open>labels prog l c \<Longrightarrow>
    \<exists>l'. prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c'',s'',l'\<rangle> \<and> labels prog l' c''\<close>
  from IH[OF \<open>labels prog l c\<close>] obtain l'' where "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c'',s'',l''\<rangle>"
    and "labels prog l'' c''" by blast
  from \<open>labels prog l'' c''\<close> \<open>\<langle>c'',s''\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<close> obtain l'
    where "prog \<turnstile> \<langle>c'',s'',l''\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    and "labels prog l' c'" by(auto dest:red_step)
  from \<open>prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c'',s'',l''\<rangle>\<close> \<open>prog \<turnstile> \<langle>c'',s'',l''\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>\<close>
  have "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle>"
    by(fastforce elim:rtranclp_trans)
  with \<open>labels prog l' c'\<close> show ?case by blast
qed

subsubsection \<open>The bisimulation theorem\<close>

theorem reds_steps_bisimulation:
  "labels prog l c \<Longrightarrow> (\<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>) =
     (\<exists>l'. prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle> \<and> labels prog l' c')"
  by(fastforce intro:reds_steps elim:steps_reds)

end


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

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

context begin
  interpretation Labeling_Syntax .

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

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

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

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

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

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

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

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

end

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

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

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

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

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

end


text_raw \<open>\section[Identity Through Permutability]{Identity Through Permutability\isalabel{sec:identifiability}}\<close>

text \<^marker>\<open>tag bodyonly\<close> \<open>
  In this section, we describe the formal characterization of the
  identity of particulars in UFO through the notion of permutability
  introduced in \autoref{cha:particular-structures}. We also present
  a characterization based on the existence of an identifying predicate
  and prove its logical equivalence to the definition based on
  permutability.
\<close>
text_raw \<open>\par\<close>
text_raw \<open>\subsection[Isomorphically-Invariant Identity Predicates]{Isomorphically-Invariant Identity Predicates\isalabel{subsec:isomorphically-invariant}}\<close>

theory IdentityPredicate
  imports
    "../ParticularStructures/ParticularStructureMorphisms"
    "HOL-ZF.MainZF"
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Before we present the characterization of identity through the structural
  notion of permutability, we first characterize the usual notion of
  the identifiability of a particular, as the existence of a predicate,
  here called an identity predicate, that satisfies some requirements.

  Given a particular structure \<open>\<Gamma>\<close> and a particular \<open>x\<close> of \<open>\<Gamma>\<close>, we say
  that a binary predicate \<open>P\<close> over the set of particular structures and
  the set of particulars is an identity predicate for \<open>x\<close> of \<open>\<Gamma>\<close>
  if it satisfies the following conditions:

  \begin{enumerate}
  \item it identifies \<open>x\<close> in \<open>\<Gamma>\<close>, i.e., it is only satisfied by \<open>x\<close> in \<open>\<Gamma>\<close>;
  \item even if we change the representation of particulars in \<open>\<Gamma>\<close>, i.e.
        by an isomorphism to another structure \<open>\<Gamma>'\<close>, the particular that
        corresponds to \<open>x\<close> in \<open>\<Gamma>'\<close> is still identifiable by \<open>P\<close>.
  \end{enumerate}

  The reason we require invariance under isomorphisms (or change of representation) is that the predicate should rely only on the structure
  of \<open>\<Gamma>\<close> and not in the particularities of whatever representation is being
  used for particulars in \<open>\<Gamma>\<close>. For example, suppose we represent particulars
  as integers and suppose \<open>x\<close> is represented as the integer \<open>12\<close>. A predicate
  defined as \<open>P \<Gamma> y \<equiv> y = 12\<close> would surely identify \<open>x\<close> in \<open>\<Gamma>\<close>. Furthermore,
  it identifies \<open>x\<close> without using any properties or relations provided by the
  UFO theory of particulars (inherence, quale association, towardness). However,
  this predicate would fail in case we change the representation by using, for example, the morphism \<open>\<phi> x = x + 1\<close>.

  However, if the predicate ``fixes'' \<open>x\<close>'s identity by using only the
  properties and relations provided by the UFO theory of particulars, which
  compose the UFO particular structure, then it is invariant under isomorphisms.
  For example, suppose the same \<open>x\<close> in the previous example bears a moment \<open>m\<close>
  associated with a certain quale \<open>q\<close>. Suppose also that \<open>x\<close> is the only
  particular in \<open>\<Gamma>\<close> that bears a moment associated to \<open>q\<close>. In that case, the
  predicate \<open>P \<Gamma> y \<equiv> \<exists>z. z \<triangleleft>\<^bsub>\<Gamma>\<^esub> y \<and> z \<longlongrightarrow> q\<close> is an (isomorphically invariant)
  identifying predicate for \<open>x\<close> of \<open>\<Gamma>\<close>.

  To express this definition in Isabelle/HOL we face a challenge due to
  the limited polymorphism provided by the Isabelle/HOL type system, which
  does not allow us to quantify over types (and thus, over representations
  for particulars). Instead, we require the predicate to be invariant
  under isomorphisms from \<open>\<Gamma>\<close> to particular structures built with
  Zermelo-Fraenkel sets as particular representations. We do so assuming
  that the Isabelle/HOL type of ZF sets is sufficiently large to include
  an infinite number of sets that are isomorphic to the set of particulars
  of \<open>\<Gamma>\<close>.

  Formally, we have an identity predicate defined as:
\<close>
text_raw \<open>\par\<close>
definition identity_pred ::
  \<open>('p,'q) particular_struct \<Rightarrow>
   ((ZF,'q) particular_struct \<Rightarrow> ZF \<Rightarrow> bool) \<Rightarrow> 'p \<Rightarrow> bool\<close>
  where \<open>
    identity_pred \<Gamma> P x \<longleftrightarrow> x \<in> particulars \<Gamma> \<and>
      BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> \<noteq> \<emptyset> \<and>
      (\<forall>\<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>.
        \<forall>\<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>.
        \<forall>y. P \<Gamma>' y \<longleftrightarrow>
          (\<forall>z \<in> particulars \<Gamma>. y = \<phi> z \<longleftrightarrow> z = x))\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> identity_pred_I:
  assumes
    \<open>BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> \<noteq> \<emptyset>\<close>
    \<open>\<And>\<Gamma>' \<phi> y. \<lbrakk>
          \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ;
          \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>
         \<rbrakk> \<Longrightarrow>  P \<Gamma>' y \<longleftrightarrow> (\<forall>z \<in> particulars \<Gamma>. y = \<phi> z \<longleftrightarrow> z = x)\<close>
    \<open>x \<in> particulars \<Gamma>\<close>
  shows \<open>identity_pred \<Gamma> P x\<close>
  using assms
  by (auto simp: identity_pred_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> identity_pred_I':
  assumes
    \<open>x \<in> particulars \<Gamma>\<close>
    \<open>BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> \<noteq> \<emptyset>\<close>
        \<open>\<And>\<Gamma>' \<phi> y. \<lbrakk>
          \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ;
          \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>
         \<rbrakk> \<Longrightarrow>  P \<Gamma>' y \<longleftrightarrow> (\<forall>z \<in> particulars \<Gamma>. y = \<phi> z \<longleftrightarrow> z = x)\<close>
  shows \<open>identity_pred \<Gamma> P x\<close>
  using assms
  by (auto simp: identity_pred_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> identity_pred_E:
  assumes
    \<open>identity_pred \<Gamma> P x\<close>
  obtains \<phi> where
    \<open>particular_struct \<Gamma>\<close>
    \<open>x \<in> particulars \<Gamma>\<close>
    \<open>\<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    \<open>\<And>\<Gamma>' \<phi> y. \<lbrakk>
          \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ;
          \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>
         \<rbrakk> \<Longrightarrow>  P \<Gamma>' y \<longleftrightarrow> (\<forall>z \<in> particulars \<Gamma>. y = \<phi> z \<longleftrightarrow> z = x)\<close>
proof -
  obtain \<phi> where A:
    \<open>\<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    using assms
    by (auto simp: identity_pred_def)
  have B: \<open>particular_struct \<Gamma>\<close> using A(1)
    by (meson bijections1_are_morphisms morphs_D
              particular_struct_morphism.axioms(1)
              pre_particular_struct_morphism_def)
  show \<open>?thesis\<close>
    using B assms that
    by (auto simp: identity_pred_def)
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> identity_pred_E':
  assumes \<open>identity_pred \<Gamma> P x\<close>
  obtains
    \<open>BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> \<noteq> \<emptyset>\<close>
    \<open>x \<in> particulars \<Gamma>\<close>
    \<open>\<And>\<Gamma>' \<phi> y. \<lbrakk>
          \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ;
          \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>
         \<rbrakk> \<Longrightarrow>  P \<Gamma>' y \<longleftrightarrow> (\<forall>z \<in> particulars \<Gamma>. y = \<phi> z \<longleftrightarrow> z = x)\<close>
  using assms
  by (simp add: identity_pred_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> id_is_unique_1:
  fixes \<Gamma> :: \<open>('p,'q) particular_struct\<close> and \<sigma> :: \<open>'p \<Rightarrow> ZF\<close>
  assumes
    \<open>identity_pred \<Gamma> P\<^sub>1 x\<close>
    \<open>identity_pred \<Gamma> P\<^sub>2 x\<close>
    \<open>particular_struct_bijection \<Gamma> \<Gamma>' \<phi>\<close>
    and \<sigma>: \<open>inj \<sigma>\<close>
  shows \<open>P\<^sub>1 (MorphImg \<sigma> \<Gamma>') y = P\<^sub>2 (MorphImg \<sigma> \<Gamma>') y\<close>
proof -
  have sigma[dest!,simp]: \<open>\<sigma> x = \<sigma> y \<Longrightarrow> x = y\<close> for x y
    using injD \<sigma> by metis
  have Gamma1[simp]: \<open>\<Gamma>' = MorphImg \<phi> \<Gamma>\<close>
    using assms(3)
    by (meson isomorphism_iff_isomorphism_to_morphimg)
  interpret I1: particular_struct_bijection_1 \<open>\<Gamma>\<close> \<open>\<phi>\<close>
    using assms(3)
    by (simp add:
          particular_struct_bijection_iff_particular_struct_bijection_1)
  have I1_src_gamma[simp]: \<open>I1.src.\<Gamma> = \<Gamma>\<close>  by simp
  interpret IS2:  particular_struct \<open>MorphImg (\<sigma> \<circ> \<phi>) I1.src.\<Gamma>\<close>
    apply (intro I1.src.inj_morph_img_valid_structure)
    subgoal G1
      apply (intro comp_inj_on)
      subgoal G1_1 by simp
      subgoal G2_2
        apply (auto simp: possible_worlds_sig.\<P>_def)
        by (intro inj_onI ; simp)
      done
    subgoal G2
      by (rule exI[of _ \<open>id\<close>] ; simp)
    done
  have simp1[simp]: \<open>particular_struct (MorphImg \<sigma> (MorphImg \<phi> \<Gamma>))\<close>
    using IS2.particular_struct_axioms
    by (simp add: fcomp_def)
  have simp_worlds_img_img:
      \<open>(\<sigma> ` \<phi> ` w\<^sub>1 = \<sigma> ` \<phi> ` w\<^sub>2) \<longleftrightarrow> (w\<^sub>1 = w\<^sub>2)\<close>
      if \<open>w\<^sub>1 \<in> I1.src.\<W>\<close> \<open>w\<^sub>2 \<in> I1.src.\<W>\<close> for w\<^sub>1 w\<^sub>2
    by (metis I1.phi_inv_phi_world \<sigma> inj_image_eq_iff that(1) that(2))
  have I1_tgt_gamma: \<open>I1.tgt.\<Gamma> = MorphImg \<phi> \<Gamma>\<close>
    using I1.tgt_Gamma_eq_Morph_img by auto
  interpret sigma: particular_struct_bijection_1 \<open>MorphImg \<phi> \<Gamma>\<close> \<sigma>
    apply (intro I1.tgt.inj_morph_img_isomorphism[simplified I1_tgt_gamma])
    subgoal by (simp add: inj_onI)
    by (simp add: IS2.injection_to_ZF_exist)

  have sigma_phi: \<open>\<sigma> \<circ> \<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    by (intro bijections_I particular_struct_bijection_1_comp
        I1.particular_struct_bijection_1_axioms
        sigma.particular_struct_bijection_1_axioms
          )

  have sigma_phi_img: \<open>MorphImg (\<sigma> \<circ> \<phi>) \<Gamma> \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    using sigma_phi by blast

  have sigma_phi_morph: \<open>\<sigma> \<circ> \<phi> \<in> Morphs\<^bsub>\<Gamma>,MorphImg (\<sigma> \<circ> \<phi>) \<Gamma>\<^esub>\<close>
    by (meson bijections1_are_morphisms sigma_phi)

  show \<open>?thesis\<close>
  proof (simp)
    fix y
    obtain P\<^sub>1:
              \<open>\<And>\<Gamma>' \<phi> y. \<lbrakk>
          \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ;
          \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>
         \<rbrakk> \<Longrightarrow>  P\<^sub>1 \<Gamma>' y \<longleftrightarrow> (\<forall>z \<in> particulars \<Gamma>. y = \<phi> z \<longleftrightarrow> z = x)\<close>
      using identity_pred_E[OF assms(1)] by metis
    obtain P\<^sub>2:
              \<open>\<And>\<Gamma>' \<phi> y. \<lbrakk>
          \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ;
          \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>
         \<rbrakk> \<Longrightarrow>  P\<^sub>2 \<Gamma>' y \<longleftrightarrow> (\<forall>z \<in> particulars \<Gamma>. y = \<phi> z \<longleftrightarrow> z = x)\<close>
      using identity_pred_E[OF assms(2)] by metis
    note Q1 = P\<^sub>1[OF sigma_phi_img,of \<open>\<sigma> \<circ> \<phi>\<close>,OF sigma_phi_morph]
    note Q2 = P\<^sub>2[OF sigma_phi_img,of \<open>\<sigma> \<circ> \<phi>\<close>,OF sigma_phi_morph]
    show \<open>P\<^sub>1 (MorphImg \<sigma> (MorphImg \<phi> \<Gamma>)) y = P\<^sub>2 (MorphImg \<sigma> (MorphImg \<phi> \<Gamma>)) y\<close>
      apply (intro iffI)
      subgoal using Q1[of \<open>y\<close>] Q2(1) by simp
      subgoal using Q2[of \<open>y\<close>] Q1(1) by simp
      done
  qed
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_img_comp_1[simp]:
  \<open>MorphImg \<phi>\<^sub>1 \<circ> MorphImg \<phi>\<^sub>2 = MorphImg (\<phi>\<^sub>1 \<circ> \<phi>\<^sub>2)\<close>
  by (intro ext ; simp)

context ufo_particular_theory
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  As expected, an identity predicate is capable of ``picking'' the
  correspondent of \<open>x\<close> under an isomorphism:
  \<close>
text_raw \<open>\par\<close>
lemma identity_respects_isomorphisms:
  assumes
    \<open>identity_pred \<Gamma> P x\<close>
    \<open>\<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE('p\<^sub>1)\<^esub>\<close>
  shows \<open>identity_pred (MorphImg \<phi> \<Gamma>) P (\<phi> x)\<close>
proof -
  obtain \<phi>\<^sub>1 where
      A: \<open>particular_struct \<Gamma>\<close>
        \<open>\<phi>\<^sub>1 \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    \<open>\<And>\<Gamma>' \<phi> y. \<lbrakk>
          \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ;
          \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>
         \<rbrakk> \<Longrightarrow>  P \<Gamma>' y \<longleftrightarrow> (\<forall>z \<in> particulars \<Gamma>. y = \<phi> z \<longleftrightarrow> z = x)\<close>
      \<open>x \<in> particulars \<Gamma>\<close>
    using identity_pred_E[OF assms(1)] by metis
  have x_E[simp,intro!]: \<open>x \<in> \<E>\<close> using A(4) by simp
  interpret I1: particular_struct \<open>\<Gamma>\<close> using A(1) by simp
  interpret I2: particular_struct_bijection_1 \<open>\<Gamma>\<close> \<open>\<phi>\<close>
    using assms(2) by blast
  have B: \<open>I2.tgt.\<Gamma> = MorphImg \<phi> \<Gamma>\<close>
    apply (intro particular_struct_eqI)
    by (simp_all only: I2.tgt.\<Gamma>_def particular_struct.simps)
  obtain f :: \<open>'p\<^sub>1 \<Rightarrow> ZF\<close> where f: \<open>inj f\<close>
    using I2.tgt.injection_to_ZF_exist by blast
  have \<open>f \<in> BijMorphs1\<^bsub>MorphImg \<phi> \<Gamma>,TYPE(ZF)\<^esub>\<close>
    apply (auto)
    apply (intro I2.tgt.inj_morph_img_isomorphism[simplified B])
    subgoal by (meson f injD inj_onI)
    using inj_on_id by blast
  then have C: \<open>BijMorphs1\<^bsub>MorphImg \<phi> \<Gamma>,TYPE(ZF)\<^esub> \<noteq> \<emptyset>\<close> by blast
  have D: \<open>\<phi>' \<circ> \<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close> if
    as: \<open>\<phi>' \<in> BijMorphs1\<^bsub>MorphImg \<phi> \<Gamma>,TYPE(ZF)\<^esub>\<close> for \<phi>'
  proof -
    interpret II1: particular_struct_bijection_1 \<open>MorphImg \<phi> \<Gamma>\<close> \<open>\<phi>'\<close>
      using as by blast
    show \<open>?thesis\<close>
      apply (intro bijections_I)
      apply (rule particular_struct_bijection_1_comp)
      subgoal
        by (simp only: I2.particular_struct_bijection_1_axioms)
      using II1.particular_struct_bijection_1_axioms by blast
  qed
  show \<open>?thesis\<close>
  proof (intro identity_pred_I C)
    show \<open>\<phi> x \<in> I2.tgt.endurants\<close>
      using A(4) by blast
    fix \<Gamma>' \<phi>' y'
    assume as3: \<open>\<Gamma>' \<in> IsoModels\<^bsub>MorphImg \<phi> \<Gamma>,TYPE(ZF)\<^esub>\<close>
                \<open>\<phi>' \<in> Morphs\<^bsub>MorphImg \<phi> \<Gamma>,\<Gamma>'\<^esub>\<close>
    then have AA: \<open>\<phi>' \<circ> \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>\<close>
      using I2.particular_struct_morphism_axioms
            particular_struct_morphism_comp
      by blast
    interpret phi'_phi: particular_struct_morphism \<open>\<Gamma>\<close> \<open>\<Gamma>'\<close> \<open>\<phi>' \<circ> \<phi>\<close>
      using AA[THEN morphs_D] by simp

    obtain \<phi>\<^sub>1 where
      phi1: \<open>\<phi>\<^sub>1 \<in> BijMorphs1\<^bsub>MorphImg \<phi> \<Gamma>,TYPE(ZF)\<^esub>\<close>
            \<open>\<Gamma>' = MorphImg \<phi>\<^sub>1 (MorphImg \<phi> \<Gamma>)\<close>
      using as3(1) by blast
    have BB: \<open>\<Gamma>' = MorphImg (\<phi>\<^sub>1 \<circ> \<phi>) \<Gamma>\<close> using phi1(2) by simp
    have CC: \<open>\<phi>\<^sub>1 \<circ> \<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
      apply (simp ; safe)
      subgoal
        apply (rule comp_inj_on)
        subgoal using I2.morph_is_injective by auto
        by (metis I2.morph_is_surjective particular_struct_bijection_1_def
                  particular_struct_injection.morph_is_injective
                  bijections_D
                  phi1(1) ufo_particular_theory_sig.\<Gamma>_simps(2))
      using inj_on_id by blast
    interpret phi1_phi: particular_struct_bijection_1 \<Gamma> \<open>\<phi>\<^sub>1 \<circ> \<phi>\<close>
      using CC by blast

    have Gamma'_isomodel: \<open>\<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
      by (intro isomorphic_models_I[of \<open>\<phi>\<^sub>1 \<circ> \<phi>\<close>] BB CC)

    have phi1_comp_phi_morphs[simp,intro!]: \<open>\<phi>\<^sub>1 \<circ> \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>\<close>
      using BB CC bijections1_are_morphisms by fastforce

    have ex_morph: \<open>\<exists>\<phi>\<in>BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>. \<Gamma>' = MorphImg \<phi> \<Gamma>\<close>
      using BB CC by blast

    show \<open>P \<Gamma>' y' = (\<forall>z \<in> I2.tgt.endurants. (y' = \<phi>' z) = (z = \<phi> x))\<close>
    proof (intro iffI ballI  ; simp?)
      fix z
      assume as4: \<open>P \<Gamma>' (\<phi>' z)\<close> \<open>z \<in> I2.tgt.\<P>\<close> \<open>y' = \<phi>' z\<close>

      have inv_z_dom[simp]: \<open>I2.inv_morph z \<in> \<E>\<close>
        using I2.phi_inv_scope as4(2) by auto
      have inv_z[simp]: \<open>\<phi> (I2.inv_morph z) = z\<close>
        by (simp add: as4(2))
      note R1= A(3)[THEN iffD1, rule_format,OF _ phi1_comp_phi_morphs
                  ,where z=\<open>I2.inv_morph z\<close>,simplified
                  ,OF ex_morph as4(1),simplified]

      note R2= A(3)[THEN iffD1, rule_format,OF _ AA,simplified
                , OF ex_morph as4(1),of \<open>I2.inv_morph z\<close>,
                   simplified]
      have R3: \<open>\<phi>' z = \<phi>\<^sub>1 z\<close>  using R1 R2 by simp
      note as4_1 =  as4[simplified R3]
      show \<open>z = \<phi> x\<close>
        using as4_1 A(3)[THEN iffD1,OF _ _ as4_1(1),rule_format
              , simplified,OF ex_morph,of _ ]
        using R2 by auto
    next
      fix z
      assume as4: \<open>P \<Gamma>' y'\<close> \<open>\<phi> x \<in> I2.tgt.\<P>\<close> \<open>z = \<phi> x\<close>
      note R1 = A(3)[simplified,THEN iffD1,OF ex_morph,rule_format
                  ,OF _ as4(1)]
      show \<open>y' = \<phi>' (\<phi> x)\<close>
        using R1 A(3)
        using AA Gamma'_isomodel as4(1) by auto
    next
      assume \<open>\<forall>z \<in> I2.tgt.\<P>. y' = \<phi>' z \<longleftrightarrow> z = \<phi> x\<close>
      then have as4: \<open>y' = \<phi>' z \<longleftrightarrow> z = \<phi> x\<close> if \<open>z \<in> I2.tgt.\<P>\<close> for z
        using that by metis
      note R1 = A(3)[THEN iffD2,of \<Gamma>' _ y',rule_format,simplified,
                OF ex_morph,of \<open>\<phi>' \<circ> \<phi>\<close>,simplified,
                OF phi'_phi.particular_struct_morphism_axioms]
      note R2 = A(3)[THEN iffD2,of \<Gamma>' _ y',rule_format,simplified,
                OF ex_morph,of \<open>\<phi>\<^sub>1 \<circ> \<phi>\<close>,simplified
                , simplified
                 phi1_phi.particular_struct_morphism_axioms[simplified,
                   simplified phi1(2)[symmetric]],
                 simplified]
      note R3 = as4[simplified  I2.morph_is_surjective[symmetric]]
      note R1 R2 R3[of \<open>\<phi> z\<close>,simplified]

      note I2.morph_is_surjective[symmetric]
      have R5: \<open>\<phi> z = \<phi> x \<longleftrightarrow> z = x\<close> if \<open>z \<in> \<E>\<close> for z
        using that \<open>x \<in> \<E>\<close> I2.morph_is_injective inj_onD
        by (metis \<Gamma>_simps(2))
      show \<open>P \<Gamma>' y'\<close>
        apply (intro R1 )
        subgoal premises P for z
          apply (rule as4[of \<open>\<phi> z\<close>,simplified R5[OF P]])
          using P
          by (simp add: I2.morph_preserves_particulars)
        done
    qed
  qed
qed

end

context ufo_particular_theory
begin

lemma \<^marker>\<open>tag (proof) aponly\<close> identity_pred:
  fixes
     P x and \<phi> :: \<open>'p \<Rightarrow> ZF\<close>
  assumes \<open>identity_pred \<Gamma> P x\<close> \<open>inj_on \<phi> \<P>\<close>
  shows \<open>P (MorphImg \<phi> \<Gamma>) y \<longleftrightarrow> y = \<phi> x\<close>
proof -
  obtain A:
    \<open>\<And>\<Gamma>' \<phi> y.
      \<lbrakk> \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ;
        \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub> \<rbrakk> \<Longrightarrow>
       P \<Gamma>' y \<longleftrightarrow> (\<forall>z\<in>particulars \<Gamma>. (y = \<phi> z) = (z = x))\<close>
    \<open>x \<in> particulars \<Gamma>\<close>
    using identity_pred_E[OF assms(1)] by metis
  have B: \<open>\<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    apply (simp ; intro conjI)
    subgoal using assms(2)[THEN inj_on_subset,simplified] by simp
    using inj_on_id by blast
  then interpret I: particular_struct_bijection_1 \<open>\<Gamma>\<close> \<open>\<phi>\<close> by simp
  have C: \<open>MorphImg \<phi> \<Gamma> \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    by (intro isomorphic_models_I[of \<open>\<phi>\<close>] B ; simp)
  have D: \<open>\<phi> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<phi> \<Gamma>\<^esub>\<close>
    using I.particular_struct_morphism_axioms by blast
  show \<open>?thesis\<close>
    apply (intro iffI ; simp add: A(1)[OF C D,of y])
    subgoal
      using assms(1) identity_pred_E' by fastforce
    subgoal
      by (metis C D I.morph_is_injective A inj_onD)
    done
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> identity_pred_I1:
  fixes P and x
  assumes
    \<open>x \<in> \<E>\<close>
    \<open>\<And>\<Gamma>' \<phi> y. \<lbrakk>
          \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ;
          \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>
         \<rbrakk> \<Longrightarrow>  P \<Gamma>' y \<longleftrightarrow> (\<forall>z \<in> \<E>. y = \<phi> z \<longleftrightarrow> z = x)\<close>
  shows \<open>identity_pred \<Gamma> P x\<close>
proof -
  have A: \<open>BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> \<noteq> \<emptyset>\<close>
  proof -
    obtain \<phi> :: \<open>'p \<Rightarrow> ZF\<close> where \<open>inj \<phi>\<close>
      using injection_to_ZF_exist by blast
    then have \<open>inj_on \<phi> \<P>\<close>
      using inj_on_subset \<open>inj \<phi>\<close> by blast
    have \<open>\<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
      apply (intro \<open>inj_on \<phi> \<P>\<close> inj_morph_img_BijMorphs)
      using  inj_on_id by blast
    then show \<open>?thesis\<close> by blast
  qed

  show \<open>?thesis\<close>
    apply (intro identity_pred_I[OF A])
    using assms by auto
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> identity_pred_eqI:
  assumes
    \<open>identity_pred \<Gamma> P x\<close>
    \<open>\<sigma> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    \<open>\<phi> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<sigma> \<Gamma>\<^esub>\<close>
  shows \<open>P (MorphImg \<sigma> \<Gamma>) y \<longleftrightarrow> (\<forall>z \<in> \<E>. y = \<phi> z \<longleftrightarrow> z = x)\<close>
proof -
  have ps[simp]: \<open>particulars \<Gamma> = \<E>\<close> by simp
  obtain A: \<open>x \<in> \<E>\<close>
    \<open>\<And>\<Gamma>' \<phi> y. \<lbrakk>
          \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ;
          \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>
         \<rbrakk> \<Longrightarrow>  P \<Gamma>' y \<longleftrightarrow> (\<forall>z \<in> \<E>. y = \<phi> z \<longleftrightarrow> z = x)\<close>
    using assms(1)[THEN identity_pred_E,simplified ps]
    by metis
  have B: \<open>MorphImg \<sigma> \<Gamma> \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    using assms(2) by blast
  show \<open>?thesis\<close>
    using A B assms(3)
    by blast
qed

end

end