theory Universals
  imports Common
begin

record 'u universal_structure =
  universals :: "'u set" ("\<U>\<index>")
  characterized_by :: "'u \<Rightarrow> 'u \<Rightarrow> bool" ("char'_by\<index>")
  moment_subsumption :: "'u \<Rightarrow> 'u \<Rightarrow> bool" (infix "\<preceq>\<^sub>m\<index>" 75)

(* UNUSED lemma universal_structure_eq_I:
  fixes X :: "'u universal_structure" and
        Y :: "'u universal_structure"
  assumes "\<U>\<^bsub>X\<^esub> = \<U>\<^bsub>Y\<^esub>"
          "char_by\<^bsub>X\<^esub> = char_by\<^bsub>Y\<^esub>"
          "(\<preceq>\<^sub>m\<^bsub>X\<^esub>) = (\<preceq>\<^sub>m\<^bsub>Y\<^esub>)"
        shows "X = Y"
  using assms
  by simp *)

definition moment_universals  ("\<U>\<^sub>m\<index>") where
  "\<U>\<^sub>m \<equiv> { U | U U' . char_by U' U }"
  for US (structure)

definition substantial_universals  ("\<U>\<^sub>s\<index>") where
  "\<U>\<^sub>s \<equiv> { U . U \<in> \<U> \<and> (\<forall>U' . \<not> char_by U' U) }"
  for US (structure)

lemma  subst_moment_univs_disj: "\<U>\<^sub>s \<inter> \<U>\<^sub>m = {}"
  for US (structure)
  by (auto simp: substantial_universals_def moment_universals_def)

lemma  subst_moment_univs_disj_2: "\<lbrakk> x \<in> \<U>\<^sub>s ; x \<in> \<U>\<^sub>m \<rbrakk> \<Longrightarrow> False"
  for US (structure)
  using subst_moment_univs_disj
  by fastforce

definition substantial_subsumption (infix "\<preceq>\<^sub>s\<index>" 75) where
  "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2 \<equiv> U\<^sub>1 \<in> \<U>\<^sub>s \<and> U\<^sub>2 \<in> \<U>\<^sub>s \<and>
      (\<forall>u\<^sub>2. char_by U\<^sub>2 u\<^sub>2 \<longrightarrow> (\<exists>u\<^sub>1. char_by U\<^sub>1 u\<^sub>1 \<and> u\<^sub>1 \<preceq>\<^sub>m u\<^sub>2))"
  for US (structure)

definition subsumption (infix "\<preceq>\<index>" 75) where
  "U\<^sub>1 \<preceq> U\<^sub>2 \<equiv> U\<^sub>1 \<in> \<U>\<^sub>m \<and> U\<^sub>2 \<in> \<U>\<^sub>m \<and> U\<^sub>1 \<preceq>\<^sub>m U\<^sub>2 \<or>
             U\<^sub>1 \<in> \<U>\<^sub>s \<and> U\<^sub>2 \<in> \<U>\<^sub>s \<and> U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2"
  for US (structure)

definition top_subst_univ ("\<top>\<^sub>s\<index>") where
  "\<top>\<^sub>s \<equiv> THE U. \<forall>U' \<in> \<U>\<^sub>s. U' \<preceq>\<^sub>s U"
  for US (structure)

definition characterizing_set ("char'_set\<index>")
   where "char_set U \<equiv> { u . char_by U u }"
   for US (structure)

lemma char_set_iff[simp]: "u \<in> char_set U \<longleftrightarrow> char_by U u"
  for US (structure)
  by (auto simp: characterizing_set_def)

lemma char_set_D: "u \<in> char_set U \<Longrightarrow> char_by U u"
  for US (structure)
  by (auto simp: characterizing_set_def)

lemma char_set_E[elim!]:
  fixes US (structure)
  assumes "u \<in> char_set U"
  obtains "char_by U u"
  using assms by (auto simp: characterizing_set_def)

lemma char_set_I[intro!]: "char_by U u \<Longrightarrow> u \<in> char_set U"
  for US (structure)
  by (auto simp: characterizing_set_def)

lemma substantial_subsumption_I[intro!]:
  fixes US (structure)
  assumes "U\<^sub>1 \<in> \<U>\<^sub>s" "U\<^sub>2 \<in> \<U>\<^sub>s" "\<forall>u. char_by U\<^sub>2 u \<longrightarrow> (\<exists>u'. char_by U\<^sub>1 u' \<and> u' \<preceq>\<^sub>m u)"
  shows "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2"
  by (auto simp: substantial_subsumption_def assms)

lemma substantial_subsumption_E[elim!]:
  fixes US (structure)
  assumes "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2"
  obtains "U\<^sub>1 \<in> \<U>\<^sub>s" "U\<^sub>2 \<in> \<U>\<^sub>s" "\<forall>u. char_by U\<^sub>2 u \<longrightarrow> (\<exists>u'. char_by U\<^sub>1 u' \<and> u' \<preceq>\<^sub>m u)"
  using assms by (auto simp: substantial_subsumption_def)

locale universal_structure =
  fixes US :: "'u universal_structure" (structure)
  assumes
    finite_univs: "finite \<U>" and
    characterized_by_scope: "char_by Us Um \<Longrightarrow> Us \<in> \<U>\<^sub>s \<and> Um \<in> \<U>"  and
    characterization_respects_subsumption: "\<lbrakk> char_by U u\<^sub>1 ; u\<^sub>1 \<preceq>\<^sub>m u\<^sub>2 \<rbrakk> \<Longrightarrow> char_by U u\<^sub>2" and
    unique_characterization: "\<forall>U\<^sub>1 U\<^sub>2. U\<^sub>1 \<in> \<U>\<^sub>s \<and> U\<^sub>2 \<in> \<U>\<^sub>s \<and> (\<forall>u. char_by U\<^sub>1 u \<longleftrightarrow> char_by U\<^sub>2 u) \<longrightarrow> U\<^sub>1 = U\<^sub>2" and
    every_moment_univ_characterizes: "\<forall>u \<in> \<U>\<^sub>m. \<exists>U \<in> \<U>\<^sub>s. char_by U u" and
    no_moment_univ_is_characterized: "\<forall>u u'. u \<in> \<U>\<^sub>m \<longrightarrow> \<not> char_by u u'" and
    unique_characterization_introduction:
        "\<forall>u U\<^sub>1 U\<^sub>2. char_by U\<^sub>1 u \<and> char_by U\<^sub>2 u \<longrightarrow> (\<exists>U. char_by U u \<and> U\<^sub>1 \<preceq>\<^sub>s U \<and> U\<^sub>2 \<preceq>\<^sub>s U)" and
    top_substantial_ex: "\<exists>U \<in> \<U>\<^sub>s. \<forall>U' \<in> \<U>\<^sub>s. U' \<preceq>\<^sub>s U"  and
    moment_subsumes_scope: "U \<preceq>\<^sub>m U' \<Longrightarrow> U \<in> \<U>\<^sub>m \<and> U' \<in> \<U>\<^sub>m" and
    moment_subsumes_refl: "U \<in> \<U>\<^sub>m \<Longrightarrow> U \<preceq>\<^sub>m U" and
    moment_subsumes_antisym: "\<lbrakk> U \<preceq>\<^sub>m U' ; U' \<preceq>\<^sub>m U \<rbrakk> \<Longrightarrow> U = U'" and
    moment_subsumes_trans: "\<lbrakk> U\<^sub>1 \<preceq>\<^sub>m U\<^sub>2 ; U\<^sub>2 \<preceq>\<^sub>m U\<^sub>3 \<rbrakk> \<Longrightarrow> U\<^sub>1 \<preceq>\<^sub>m U\<^sub>3"

begin

lemma characterized_by_scope_E:
  assumes "char_by Us Um"
  obtains "Us \<in> \<U>\<^sub>s" "Um \<in> \<U>\<^sub>m"
  using characterized_by_scope assms
        moment_universals_def
  by fastforce

lemma characterized_by_scope_D:
  assumes "char_by Us Um"
  shows "Us \<in> \<U>\<^sub>s" "Um \<in> \<U>\<^sub>m"
  using characterized_by_scope_E assms by metis+

lemma universals_eq_un: "\<U> = \<U>\<^sub>m \<union> \<U>\<^sub>s"
  by (auto simp: substantial_universals_def
        moment_universals_def characterized_by_scope)

lemma universal_exhaust[cases set]:
  assumes "u \<in> \<U>"
  obtains (moment) "u \<in> \<U>\<^sub>m" "u \<notin> \<U>\<^sub>s" |
          (substantial) "u \<in> \<U>\<^sub>s" "u \<notin> \<U>\<^sub>m"
  using assms subst_moment_univs_disj_2 universals_eq_un by fastforce

lemma universal_I: "u \<in> \<U>\<^sub>m \<or> u \<in> \<U>\<^sub>s \<Longrightarrow> u \<in> \<U>"
  by (simp add: universals_eq_un)

lemma subst_subsumes_by_char_set:
  assumes "U\<^sub>1 \<in> \<U>\<^sub>s" "U\<^sub>2 \<in> \<U>\<^sub>s"
  shows "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2 \<longleftrightarrow> char_set U\<^sub>2 \<subseteq> char_set U\<^sub>1"
proof (intro iffI subsetI ; (simp add: subset_iff)?)
  fix u
  assume as: "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2" "char_by U\<^sub>2 u"
  obtain u\<^sub>1 where A: "char_by U\<^sub>1 u\<^sub>1" "u\<^sub>1 \<preceq>\<^sub>m u"
    using assms as substantial_subsumption_def by metis
  show "char_by U\<^sub>1 u"
    using characterization_respects_subsumption A by simp
next
  assume "\<forall>u. char_by U\<^sub>2 u \<longrightarrow> char_by U\<^sub>1 u"
  note as = this[rule_format]
  show "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2"
    using moment_subsumes_refl characterized_by_scope_E as
      substantial_subsumption_def assms
    by metis
qed

lemma subsumesI[intro]:
  assumes "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2 \<or> U\<^sub>1 \<preceq>\<^sub>m U\<^sub>2"
  shows "U\<^sub>1 \<preceq> U\<^sub>2"
  using subsumption_def moment_subsumes_scope substantial_subsumption_def
      assms by metis

lemma subsumesI_S[intro]:
  assumes "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2"
  shows "U\<^sub>1 \<preceq> U\<^sub>2"
  using subsumption_def moment_subsumes_scope substantial_subsumption_def
      assms by metis

lemma subsumesI_M[intro]:
  assumes "U\<^sub>1 \<preceq>\<^sub>m U\<^sub>2"
  shows "U\<^sub>1 \<preceq> U\<^sub>2"
  using subsumption_def moment_subsumes_scope
      assms by metis

lemma subst_univ_eq_char_set:
  assumes "U\<^sub>1 \<in> \<U>\<^sub>s" "U\<^sub>2 \<in> \<U>\<^sub>s" "char_set U\<^sub>1 = char_set U\<^sub>2"
  shows "U\<^sub>1 = U\<^sub>2"
  using assms unique_characterization char_set_iff
  by auto

lemma substantial_subsumption_scope:
  assumes "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2"
  shows "U\<^sub>1 \<in> \<U>\<^sub>s" "U\<^sub>2 \<in> \<U>\<^sub>s"
  using assms substantial_subsumption_E by auto

lemma substantial_subsumption_antisym:
  assumes "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2" "U\<^sub>2 \<preceq>\<^sub>s U\<^sub>1"
  shows "U\<^sub>1 = U\<^sub>2"
  supply A = substantial_subsumption_scope[OF assms(1)]
  supply B = subst_subsumes_by_char_set[THEN iffD1, OF A assms(1)]
            subst_subsumes_by_char_set[THEN iffD1, OF A(2,1) assms(2)]
  supply C = equalityI[OF B]
  using C
  by (simp add: A(1) A(2) subst_univ_eq_char_set)

(* UNUSED lemma substantial_subsumption_trans:
  assumes "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2" "U\<^sub>2 \<preceq>\<^sub>s U\<^sub>3"
  shows "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>3"
  supply A = assms[THEN substantial_subsumption_E]
  apply (intro substantial_subsumption_I ; rule A(1) ; rule A(2) ; simp)
  using characterization_respects_subsumption by blast *)

(* UNUSED lemma substantial_subsumption_refl:
  assumes "U \<in> \<U>\<^sub>s"
  shows "U \<preceq>\<^sub>s U"
  by (intro subst_subsumes_by_char_set[THEN iffD2] assms ; simp) *)

(* UNUSED lemma moment_char_set_empty:  "u \<in> \<U>\<^sub>m \<Longrightarrow> char_set u = {}"
  by (simp add: characterizing_set_def no_moment_univ_is_characterized) *)

lemma moment_univs_are_univs: "\<U>\<^sub>m \<subseteq> \<U>"
  using characterized_by_scope
        every_moment_univ_characterizes
  by auto

lemma substantial_univs_are_univs: "\<U>\<^sub>s \<subseteq> \<U>"
  by (auto simp: substantial_universals_def)

lemma subsumesE[elim]:
  assumes "U\<^sub>1 \<preceq> U\<^sub>2"
  obtains (are_substantials) "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2" |
          (are_moments) "U\<^sub>1 \<preceq>\<^sub>m U\<^sub>2"
  using subsumption_def moment_subsumes_scope assms
  by metis

lemma at_least_one_subst_univ: "\<U>\<^sub>s \<noteq> {}"
  using top_substantial_ex by auto

lemma top_ex1: "\<exists>!U. \<forall>U'\<in>\<U>\<^sub>s. U' \<preceq>\<^sub>s U"
  apply (intro ex_ex1I)
proof -
  show "\<exists>U. \<forall>U'\<in>\<U>\<^sub>s. U' \<preceq>\<^sub>s U"
    using top_substantial_ex by metis
  fix U\<^sub>1 U\<^sub>2
  assume as: "\<forall>U'\<in>\<U>\<^sub>s. U' \<preceq>\<^sub>s U\<^sub>1" "\<forall>U'\<in>\<U>\<^sub>s. U' \<preceq>\<^sub>s U\<^sub>2"
  then obtain A[simp,intro!]: "U\<^sub>1 \<in> \<U>\<^sub>s" "U\<^sub>2 \<in> \<U>\<^sub>s"
    using at_least_one_subst_univ
    by blast
  { fix U'
    assume as2: "U' \<in> \<U>\<^sub>s"
    obtain B: "U' \<preceq>\<^sub>s U\<^sub>1" "U' \<preceq>\<^sub>s U\<^sub>2" using as as2 by metis
    then obtain D:"char_set U\<^sub>1 \<subseteq> char_set U'" "char_set U\<^sub>2 \<subseteq> char_set U'"
      using subst_subsumes_by_char_set A as2 by metis }
  note R = this(1)[OF A(2)] this(2)[OF A(1)]
  show "U\<^sub>1 = U\<^sub>2"
    by (intro subst_univ_eq_char_set A equalityI R)
qed

lemma subsumes_disjointD:
  "\<lbrakk> U \<preceq>\<^sub>s U\<^sub>1 ; U \<preceq>\<^sub>m U\<^sub>2 \<rbrakk> \<Longrightarrow> False"
  "\<lbrakk> U \<preceq>\<^sub>s U\<^sub>1 ; U\<^sub>2 \<preceq>\<^sub>m U \<rbrakk> \<Longrightarrow> False"
  by (meson moment_subsumes_scope subst_moment_univs_disj_2 substantial_subsumption_def)+

(* UNUSED lemma top_ex1_2: "\<exists>!U. \<forall>U'\<in>\<U>\<^sub>s. U' \<preceq> U"
  using top_ex1
  by (metis subsumesE subsumesI subsumes_disjointD(1)) *)

lemma top_eq:
  assumes "\<And>U'. U' \<in> \<U>\<^sub>s \<Longrightarrow> U' \<preceq> U"
  shows "\<top>\<^sub>s = U"
  apply (simp only: top_subst_univ_def ; intro the1_equality top_ex1)
   by (meson moment_subsumes_scope subst_moment_univs_disj_2 subsumesE assms)

lemma top_char_set:
  assumes "U \<in> \<U>\<^sub>s" "char_set U = {}"
  shows "\<top>\<^sub>s = U"
  apply (intro top_eq)
  using assms by blast

lemma top_susbtantial_univ[intro!,simp]: "\<top>\<^sub>s \<in> \<U>\<^sub>s"
  apply (simp add: top_subst_univ_def ; rule the1I2; (intro top_ex1)?)
  using top_substantial_ex by blast

lemma subst_universal_iff: "u \<in> \<U>\<^sub>s \<longleftrightarrow> u = \<top>\<^sub>s \<or> (\<exists>u'. char_by u u')"
proof (cases "u \<in> \<U>\<^sub>s")
  assume B: "u \<in> \<U>\<^sub>s"
  have B1: "u = \<top>\<^sub>s \<or> (\<exists>u'. char_by u u')"
  proof (intro disjCI ; simp)
    assume "\<forall>U. \<not> char_by u U"
    then have C: "False" if "char_by u U" for U
      using that by simp
    then have "char_set u = {}" by blast
    then show "u = \<top>\<^sub>s"  using B top_char_set by auto
  qed
  then show ?thesis using B by metis
next
  assume B: "u \<notin> \<U>\<^sub>s"
  then show ?thesis
    apply simp
    by (metis characterized_by_scope subsumesI top_eq top_substantial_ex)
qed

lemma moment_universal_iff: "u \<in> \<U>\<^sub>m \<longleftrightarrow> (\<exists>u'. char_by u' u)"
  using every_moment_univ_characterizes universal_I
        characterized_by_scope_E by auto

(* UNUSED lemma universal_iff: "u \<in> \<U> \<longleftrightarrow> u = \<top>\<^sub>s \<or> (\<exists>u'. char_by u u') \<or> (\<exists>u'. char_by u' u)"
  using universal_exhaust subst_universal_iff moment_universal_iff
        universal_I by metis *)

lemma finite_subst_univs[intro!]: "finite \<U>\<^sub>s"
  using finite_univs finite_subset substantial_univs_are_univs by blast

(* UNUSED lemma finite_moment_univs[intro!]: "finite \<U>\<^sub>m"
  using finite_univs finite_subset moment_univs_are_univs by blast *)

lemma subsumes_scope:
  assumes "U \<preceq> U'"
  obtains (are_substantials) "U \<in> \<U>\<^sub>s" "U' \<in> \<U>\<^sub>s" |
          (are_moments) "U \<in> \<U>\<^sub>m" "U' \<in> \<U>\<^sub>m"
  using assms every_moment_univ_characterizes characterized_by_scope
  by (meson subsumption_def)

lemma universals_case[cases set]:
  assumes "U \<in> \<U>"
  obtains (is_a_substantial) "U \<in> \<U>\<^sub>s" |
          (is_a_moment) "U \<in> \<U>\<^sub>m"
  using moment_universals_def substantial_universals_def characterized_by_scope assms
  by fastforce

lemma subst_subsumes_refl:
  assumes "U \<in> \<U>\<^sub>s"
  shows "U \<preceq>\<^sub>s U"
    apply (clarsimp simp: substantial_subsumption_def assms)
    subgoal for u\<^sub>2
      apply (intro exI[of _ u\<^sub>2])
      using moment_subsumes_refl characterized_by_scope_E by metis
    done

lemma subst_subsumes_antisym:
  assumes "U \<preceq>\<^sub>s U'" "U' \<preceq>\<^sub>s U"
  shows "U = U'"
proof -
  obtain A: "U \<in> \<U>\<^sub>s" "U' \<in> \<U>\<^sub>s" using assms by auto
  then show ?thesis
    using assms apply (simp add: subst_subsumes_by_char_set A)
    apply (intro unique_characterization[rule_format,of U U',simplified char_set_iff[symmetric] A,
          simplified])
    by (auto simp add: characterizing_set_def)
qed

lemma subst_subsumes_trans:
  assumes "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>2" "U\<^sub>2 \<preceq>\<^sub>s U\<^sub>3"
  shows "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>3"
proof -
  obtain as: "U\<^sub>1 \<in> \<U>\<^sub>s" "U\<^sub>2 \<in> \<U>\<^sub>s" "U\<^sub>3 \<in> \<U>\<^sub>s" using assms by auto
  then show "U\<^sub>1 \<preceq>\<^sub>s U\<^sub>3"
    using subst_subsumes_by_char_set assms by blast
qed

lemma subsumes_refl:
  assumes "U \<in> \<U>"
  shows "U \<preceq> U"
  using assms apply (cases U ; intro subsumesI)
  subgoal by (intro disjI1 ; clarsimp simp: subst_subsumes_refl)
  using moment_subsumes_refl by simp

(* UNUSED lemma subsumes_antisym:
  assumes "U \<preceq> U'" "U' \<preceq> U"
  shows "U = U'"
proof -
  consider (c1) "U \<preceq>\<^sub>s U'" "U' \<preceq>\<^sub>s U" |
           (c2) "U \<preceq>\<^sub>m U'" "U' \<preceq>\<^sub>m U"
    using assms
    by (meson subsumesE subsumes_disjointD(2))
  then show ?thesis
    using moment_subsumes_antisym subst_subsumes_antisym by metis
qed *)

(* UNUSED

lemma top_I:
  assumes "\<And>U. \<forall>U' \<in> \<U>\<^sub>s. U' \<preceq> U \<Longrightarrow> P U"
  shows "P \<top>\<^sub>s"
  apply (simp add: top_subst_univ_def ; rule the1I2 ; (intro top_ex1)? )
  using assms by blast

lemma top_subsumes: "U \<in> \<U>\<^sub>s \<Longrightarrow> U \<preceq> \<top>\<^sub>s" using top_I by blast

(* UNUSED lemma top_subst_univ: "\<top>\<^sub>s \<in> \<U>\<^sub>s"
  using top_I at_least_one_subst_univ
  by (metis disjoint_iff_not_equal ex_in_conv subst_moment_univs_disj subsumes_scope) *)

lemma unique_introduction_2:
  assumes "u \<in> \<U>\<^sub>m"
  shows "\<exists>!U. char_by U u \<and> (\<forall>U'. char_by U' u \<longrightarrow> U' \<preceq>\<^sub>s U)" (is "\<exists>!U. ?P U")
proof (intro ex_ex1I)
  show "\<exists>U. char_by U u \<and> (\<forall>U'. char_by U' u \<longrightarrow> U' \<preceq>\<^sub>s U)"
  proof (rule ccontr ; simp)
    assume as: "\<forall>U. char_by U u \<longrightarrow> (\<exists>U'. char_by U' u \<and> \<not> U' \<preceq>\<^sub>s U)"
    then have A: "P" if "char_by U u" "\<And>U'. \<lbrakk> char_by U' u ; \<not> U' \<preceq>\<^sub>s U \<rbrakk> \<Longrightarrow> P" for U P
      using that by auto
    define f where "f U \<equiv> SOME U'. char_by U' u \<and> \<not> U' \<preceq>\<^sub>s U" (is "f U \<equiv> SOME U'. ?P U U'") for U
    have f: "char_by (f U) u" if "char_by U u" for U
      apply (simp add: f_def)
      apply (intro someI_ex[of "?P U",THEN conjunct1])
       using A[OF that] by metis
    have f_2: "\<not> f U \<preceq>\<^sub>s U" if "char_by U u" for U
      apply (simp add: f_def)
      apply (intro someI_ex[of "?P U",THEN conjunct2])
      using A[OF that] by metis
    define g where "g U \<equiv> SOME U'. char_by U' u \<and> U \<preceq>\<^sub>s U' \<and> f U \<preceq>\<^sub>s U'" (is "g U \<equiv> SOME U'. ?P U U'") for U
    have g_E: "P"
      if as[simp,intro!]: "char_by U u" and P: "\<lbrakk> char_by (g U) u ; U \<preceq>\<^sub>s g U ; f U \<preceq>\<^sub>s g U ; U \<noteq> g U \<rbrakk> \<Longrightarrow> P"
      for U P
    proof -
     have g_1: "U \<preceq>\<^sub>s g U"
        apply (simp add: g_def)
        apply (intro someI_ex[of "?P U", THEN conjunct2,THEN conjunct1])
        using f f_2 unique_characterization_introduction[rule_format,of U u "f U"] as by metis
      have g_2: "char_by (g U) u"
        apply (simp add: g_def)
        using someI_ex[of "?P U", THEN conjunct1]
        using f f_2 unique_characterization_introduction[rule_format,of U u "f U"] as by metis
      have g_3: "f U \<preceq>\<^sub>s g U"
        apply (simp add: g_def)
        apply (intro someI_ex[of "?P U", THEN conjunct2, THEN conjunct2])
        using f f_2 unique_characterization_introduction[rule_format,of U u "f U"] as by metis
      have g_4: "U \<noteq> g U"
        using g_1 g_3 f f_2 as by fastforce
      show P using g_1 g_2 g_3 g_4 P by blast
    qed
    have f1: "char_by (g U) u" if "char_by U u" for U using that g_E by metis
    have f2: "(g ^^ (Suc n)) x = g ((g ^^ n) x)" for n x by simp
    have f3: "U \<preceq>\<^sub>s g U" if "char_by U u" for U using that g_E by metis
    have f4: "U \<noteq> g U" if "char_by U u" for U using that g_E by metis
    have g_n_char_by: "char_by ((g ^^ (Suc n)) x) u" if aas: "char_by x u" for x n
      apply (induct n)
      subgoal using f1 aas by simp
      subgoal premises P for n
        apply (subst f2)
        by (intro f1 P)
      done
    have g_n_char_by': "char_by ((g ^^ n) x) u" if aas: "char_by x u" for x n
      apply (induct n)
      subgoal using f1 aas by simp
      subgoal premises P for n
        apply (subst f2)
        by (intro f1 P)
      done
    have g_n_subs: "x \<preceq>\<^sub>s ((g ^^ (Suc n)) x)" if aas: "char_by x u" for x n
      apply (induct n)
      subgoal using f3 aas by (simp ; metis)
      using subst_subsumes_trans f3 g_n_char_by aas f2 by metis
    have g_n_diff: "(g ^^ (Suc n)) x \<noteq> x" if aas: "char_by x u" for x n
      apply (induct n)
      subgoal  by (rule g_E[OF aas] ; simp)
    proof
      fix n
      assume aas2: "(g ^^ Suc n) x \<noteq> x" "(g ^^ Suc (Suc n)) x = x"
      have A: "x \<preceq>\<^sub>s (g ^^ Suc n) x" using aas g_n_subs by auto
      have "(g ^^ Suc n) x \<preceq>\<^sub>s (g ^^ Suc (Suc n)) x"
        by (subst f2[of  "Suc n"] ; intro f3 g_n_char_by aas)
      then have "(g ^^ Suc n) x \<preceq>\<^sub>s x" using aas2(2) by simp
      then have "(g ^^ Suc n) x = x" using A subst_subsumes_antisym by simp
      then show False using aas2(1) by simp
    qed

    define uChar where "uChar \<equiv> { U . char_by U u }"
    have uChar_ne: "uChar \<noteq> {}" using every_moment_univ_characterizes assms by (auto simp: uChar_def)
    have uChar_g_closed: "g x \<in> uChar" if "x \<in> uChar" for x
      using that g_E by (auto simp: uChar_def)

    define G where "G x \<equiv> { (g^^n) x | n . n \<in> (UNIV :: nat set)  }" for x
    have G_ins: "G x = insert x { (g^^(Suc n)) x | n . n \<in> (UNIV :: nat set)  }" for x
      apply (auto simp: G_def)
      subgoal premises P for n
        using P apply (induct n ; simp)
        by blast
      subgoal by (intro exI[of _ 0] ; simp)
      subgoal for n by (intro exI[of _ "Suc n"] ; simp)
      done
    have "0 < n \<Longrightarrow> (\<And>n. P (Suc n)) \<Longrightarrow> P n" for P and n
      by (metis Suc_pred')
    note Suc_pred'
    have G_subset_uChar: "G x \<subseteq> uChar" if "char_by x u" for x
      apply (simp add: G_ins ; auto)
      subgoal G1 using that uChar_def by auto
      subgoal for n
        apply (simp only: f2[symmetric]  uChar_def mem_Collect_eq)
        by (intro g_n_char_by that)
      done
    have uChar_subset_Us: "uChar \<subseteq> \<U>\<^sub>s"
      apply (auto simp: uChar_def)
      using characterized_by_scope_E by blast
    then have uChar_finite: "finite uChar" using finite_subst_univs finite_subset by auto
    define G_idx where "G_idx x n \<equiv> (g ^^ n) x" for n x
    have G_idx_plus: "G_idx x (n + m) = G_idx ((g ^^ n) x) m" for x n m
      apply (auto simp: G_idx_def)
      by (metis add.commute comp_eq_dest_lhs funpow_add)
    have G_idx_inj: "inj (G_idx x)" if "char_by x u" for x
    proof (intro injI ; rule ccontr)
      fix y z
      assume Z: "G_idx x y = G_idx x z" "y \<noteq> z"
      consider (c1) m where "y = Suc m + z"   |
               (c2) m where "z = Suc m + y"
        using Z(2)
        by (metis add.commute add_Suc_right less_imp_Suc_add linorder_neqE_nat)
      then show False
      proof (cases)
        case c1
        have "((g ^^ Suc m) ((g ^^ z) x)) = (g ^^ z) x"
          using c1 by (metis G_idx_def G_idx_plus Z(1) add.commute)
        then show ?thesis using g_n_diff g_n_char_by' that by metis
      next
        case c2
        have "((g ^^ Suc m) ((g ^^ y) x)) = (g ^^ y) x"
          using c2 by (metis G_idx_def G_idx_plus Z(1) add.commute)
        then show ?thesis using g_n_diff g_n_char_by' that by metis
      qed
    qed
    have "G_idx x ` UNIV = G x" if "char_by x u" for x
      using G_def G_idx_def by auto
    then have G_idx_bij: "bij_betw (G_idx x) UNIV (G x)" if "char_by x u" for x
      using G_idx_inj that by (simp add: bij_betw_imageI)
    have "infinite (UNIV :: nat set)" by simp
    then have W1: "infinite (G x)" if "char_by x u" for x
      using G_idx_bij[OF that] bij_betw_finite by blast
    have W2: "finite (G x)" if "char_by x u" for x
      using uChar_finite G_subset_uChar that finite_subset by metis
    obtain x where "char_by x u" using assms every_moment_univ_characterizes by auto
    then show False using W1 W2 by simp
  qed
  fix U\<^sub>1 U\<^sub>2
  assume "char_by U\<^sub>1 u \<and> (\<forall>U'. char_by U' u \<longrightarrow> U' \<preceq>\<^sub>s U\<^sub>1)" "char_by U\<^sub>2 u \<and> (\<forall>U'. char_by U' u \<longrightarrow> U' \<preceq>\<^sub>s U\<^sub>2)"
  then show "U\<^sub>1 = U\<^sub>2"
    using assms by (simp add: subst_subsumes_antisym)
qed

definition int_univ :: "'u \<Rightarrow> 'u" where
  "int_univ u \<equiv> THE U. char_by U u \<and> (\<forall>U'. char_by U' u \<longrightarrow> U' \<preceq>\<^sub>s U)"

(* UNUSED lemma init_univ_eq:
  assumes "char_by U u" "\<And>U'. char_by U' u \<Longrightarrow> U' \<preceq>\<^sub>s U"
  shows "int_univ u = U"
  apply (simp only: int_univ_def ; intro the1_equality unique_introduction_2 conjI assms(1) ; clarify?)
  using assms characterized_by_scope_E[OF assms(1)] by metis+ *)

lemma init_univ_I:
  assumes "u \<in> \<U>\<^sub>m"
    "\<And>U. \<lbrakk> char_by U u ; \<And>U'. char_by U' u \<Longrightarrow> U' \<preceq>\<^sub>s U \<rbrakk> \<Longrightarrow> P U"
  shows "P (int_univ u)"
  apply (simp add: int_univ_def ; rule the1I2 , intro unique_introduction_2 assms(1) , elim conjE)
  subgoal premises Q for U
    by (metis assms (2) Q)
  done

(* UNUSED lemma init_univ_char_by[intro!]:
  assumes "u \<in> \<U>\<^sub>m"
  shows "char_by (int_univ u) u"
  by (rule init_univ_I[OF assms] ; simp)+ *)

(* UNUSED lemma init_univ_subsumes[intro!]:
  assumes "char_by U u"
  shows "U \<preceq>\<^sub>s (int_univ u)"
  apply (rule init_univ_I )
  subgoal using assms characterized_by_scope_E by metis
  using assms by simp  *)

(* lemma char_by_subsumes:
  assumes "char_by U\<^sub>1 U\<^sub>2" "U\<^sub>2 \<preceq> U\<^sub>3"
  shows "char_by U\<^sub>1 U\<^sub>3"
proof -
  obtain A: "U\<^sub>1 \<in> \<U>\<^sub>s" "U\<^sub>2 \<in> \<U>\<^sub>m" using assms(1)
    using characterized_by_scope_E by blast
  then obtain B: "U\<^sub>3 \<in> \<U>\<^sub>m" "U\<^sub>2 \<preceq>\<^sub>m U\<^sub>3"
    using assms(2) by (meson subst_moment_univs_disj_2 subsumption_def)
  then show ?thesis
    using assms characterization_respects_subsumption by metis
qed *)

end

definition terminal_universals :: "'u universal_structure \<Rightarrow> 'u set" ("\<U>\<^sub>\<bottom>\<index>") where
  "\<U>\<^sub>\<bottom> \<equiv> { u . u \<in> \<U>\<^sub>s \<and> (\<forall>u'. u' \<preceq>\<^sub>s u \<longrightarrow> u' = u) }"
  for US (structure)

lemma terminal_universal_E:
  fixes US (structure)
  assumes "u \<in> \<U>\<^sub>\<bottom>"
  obtains "u \<in> \<U>\<^sub>s" "\<And>u'. u' \<preceq>\<^sub>s u \<Longrightarrow> u' = u'"
  using assms by (simp add: terminal_universals_def assms(1))

lemma (in universal_structure) terminal_universal_I :
  assumes "u \<in> \<U>\<^sub>s" "\<And>u'. u' \<preceq>\<^sub>s u \<Longrightarrow> u \<preceq>\<^sub>s u'"
  shows "u \<in> \<U>\<^sub>\<bottom>"
  apply (simp add: terminal_universals_def assms(1) ; intro allI impI)
  by (intro substantial_subsumption_antisym assms(2) ; simp)

lemma terminal_universal_subset: "\<U>\<^sub>\<bottom> \<subseteq> \<U>\<^sub>s"
  for US (structure)
  using terminal_universal_E
  by force

(* UNUSED lemma (in universal_structure) terminal_universal_top:
  assumes "\<top>\<^sub>s \<in> \<U>\<^sub>\<bottom>"
  shows "\<U>\<^sub>s = {\<top>\<^sub>s}"
  apply (intro equalityI subsetI ; simp)
  subgoal premises P for U
    apply (intro top_eq[symmetric])
    subgoal premises Q for U'
    proof -
      have f1: "U \<notin> \<U>\<^sub>m"
    by (meson P subst_moment_univs_disj_2)
    have f2: "U \<preceq> \<top>\<^sub>s"
    using P top_subsumes by blast
    have "\<top>\<^sub>s \<in> {u \<in> \<U>\<^sub>s. \<forall>ua. ua \<preceq>\<^sub>s u \<longrightarrow> ua = u}"
      by (metis assms terminal_universals_def)
      then have "U = \<top>\<^sub>s"
        using f2 f1 by (simp add: subsumption_def)
      then show ?thesis
        using Q top_subsumes by presburger
    qed
    done
  done *)

(* UNUSED lemma (in universal_structure) terminal_universal_iff:
    "\<U>\<^sub>s = {\<top>\<^sub>s} \<longleftrightarrow> \<U>\<^sub>\<bottom> = {\<top>\<^sub>s}"
  using terminal_universal_top
  by (metis empty_iff insert_iff subset_singleton_iff substantial_subsumption_scope(1) terminal_universal_I terminal_universal_subset) *)

end


(*  Title:      HOL/HOLCF/Sprod.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section \<open>The type of strict products\<close>

theory Sprod
  imports Cfun
begin

default_sort pcpo

subsection \<open>Definition of strict product type\<close>

definition "sprod = {p::'a \<times> 'b. p = \<bottom> \<or> (fst p \<noteq> \<bottom> \<and> snd p \<noteq> \<bottom>)}"

pcpodef ('a, 'b) sprod  ("(_ \<otimes>/ _)" [21,20] 20) = "sprod :: ('a \<times> 'b) set"
  by (simp_all add: sprod_def)

instance sprod :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
  by (rule typedef_chfin [OF type_definition_sprod below_sprod_def])

type_notation (ASCII)
  sprod  (infixr "**" 20)

subsection \<open>Definitions of constants\<close>

definition sfst :: "('a ** 'b) \<rightarrow> 'a"
  where "sfst = (\<Lambda> p. fst (Rep_sprod p))"

definition ssnd :: "('a ** 'b) \<rightarrow> 'b"
  where "ssnd = (\<Lambda> p. snd (Rep_sprod p))"

definition spair :: "'a \<rightarrow> 'b \<rightarrow> ('a ** 'b)"
  where "spair = (\<Lambda> a b. Abs_sprod (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b))"

definition ssplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a ** 'b) \<rightarrow> 'c"
  where "ssplit = (\<Lambda> f p. seq\<cdot>p\<cdot>(f\<cdot>(sfst\<cdot>p)\<cdot>(ssnd\<cdot>p)))"

syntax "_stuple" :: "[logic, args] \<Rightarrow> logic"  ("(1'(:_,/ _:'))")
translations
  "(:x, y, z:)" \<rightleftharpoons> "(:x, (:y, z:):)"
  "(:x, y:)" \<rightleftharpoons> "CONST spair\<cdot>x\<cdot>y"

translations
  "\<Lambda>(CONST spair\<cdot>x\<cdot>y). t" \<rightleftharpoons> "CONST ssplit\<cdot>(\<Lambda> x y. t)"

subsection \<open>Case analysis\<close>

lemma spair_sprod: "(seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b) \<in> sprod"
  by (simp add: sprod_def seq_conv_if)

lemma Rep_sprod_spair: "Rep_sprod (:a, b:) = (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b)"
  by (simp add: spair_def cont_Abs_sprod Abs_sprod_inverse spair_sprod)

lemmas Rep_sprod_simps =
  Rep_sprod_inject [symmetric] below_sprod_def
  prod_eq_iff below_prod_def
  Rep_sprod_strict Rep_sprod_spair

lemma sprodE [case_names bottom spair, cases type: sprod]:
  obtains "p = \<bottom>" | x y where "p = (:x, y:)" and "x \<noteq> \<bottom>" and "y \<noteq> \<bottom>"
  using Rep_sprod [of p] by (auto simp add: sprod_def Rep_sprod_simps)

lemma sprod_induct [case_names bottom spair, induct type: sprod]:
  "\<lbrakk>P \<bottom>; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> P (:x, y:)\<rbrakk> \<Longrightarrow> P x"
  by (cases x) simp_all

subsection \<open>Properties of \emph{spair}\<close>

lemma spair_strict1 [simp]: "(:\<bottom>, y:) = \<bottom>"
  by (simp add: Rep_sprod_simps)

lemma spair_strict2 [simp]: "(:x, \<bottom>:) = \<bottom>"
  by (simp add: Rep_sprod_simps)

lemma spair_bottom_iff [simp]: "(:x, y:) = \<bottom> \<longleftrightarrow> x = \<bottom> \<or> y = \<bottom>"
  by (simp add: Rep_sprod_simps seq_conv_if)

lemma spair_below_iff: "(:a, b:) \<sqsubseteq> (:c, d:) \<longleftrightarrow> a = \<bottom> \<or> b = \<bottom> \<or> (a \<sqsubseteq> c \<and> b \<sqsubseteq> d)"
  by (simp add: Rep_sprod_simps seq_conv_if)

lemma spair_eq_iff: "(:a, b:) = (:c, d:) \<longleftrightarrow> a = c \<and> b = d \<or> (a = \<bottom> \<or> b = \<bottom>) \<and> (c = \<bottom> \<or> d = \<bottom>)"
  by (simp add: Rep_sprod_simps seq_conv_if)

lemma spair_strict: "x = \<bottom> \<or> y = \<bottom> \<Longrightarrow> (:x, y:) = \<bottom>"
  by simp

lemma spair_strict_rev: "(:x, y:) \<noteq> \<bottom> \<Longrightarrow> x \<noteq> \<bottom> \<and> y \<noteq> \<bottom>"
  by simp

lemma spair_defined: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<noteq> \<bottom>"
  by simp

lemma spair_defined_rev: "(:x, y:) = \<bottom> \<Longrightarrow> x = \<bottom> \<or> y = \<bottom>"
  by simp

lemma spair_below: "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> (:x, y:) \<sqsubseteq> (:a, b:) \<longleftrightarrow> x \<sqsubseteq> a \<and> y \<sqsubseteq> b"
  by (simp add: spair_below_iff)

lemma spair_eq: "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> (:x, y:) = (:a, b:) \<longleftrightarrow> x = a \<and> y = b"
  by (simp add: spair_eq_iff)

lemma spair_inject: "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> (:x, y:) = (:a, b:) \<Longrightarrow> x = a \<and> y = b"
  by (rule spair_eq [THEN iffD1])

lemma inst_sprod_pcpo2: "\<bottom> = (:\<bottom>, \<bottom>:)"
  by simp

lemma sprodE2: "(\<And>x y. p = (:x, y:) \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (cases p) (simp only: inst_sprod_pcpo2, simp)

subsection \<open>Properties of \emph{sfst} and \emph{ssnd}\<close>

lemma sfst_strict [simp]: "sfst\<cdot>\<bottom> = \<bottom>"
  by (simp add: sfst_def cont_Rep_sprod Rep_sprod_strict)

lemma ssnd_strict [simp]: "ssnd\<cdot>\<bottom> = \<bottom>"
  by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_strict)

lemma sfst_spair [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>(:x, y:) = x"
  by (simp add: sfst_def cont_Rep_sprod Rep_sprod_spair)

lemma ssnd_spair [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>(:x, y:) = y"
  by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_spair)

lemma sfst_bottom_iff [simp]: "sfst\<cdot>p = \<bottom> \<longleftrightarrow> p = \<bottom>"
  by (cases p) simp_all

lemma ssnd_bottom_iff [simp]: "ssnd\<cdot>p = \<bottom> \<longleftrightarrow> p = \<bottom>"
  by (cases p) simp_all

lemma sfst_defined: "p \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>p \<noteq> \<bottom>"
  by simp

lemma ssnd_defined: "p \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>p \<noteq> \<bottom>"
  by simp

lemma spair_sfst_ssnd: "(:sfst\<cdot>p, ssnd\<cdot>p:) = p"
  by (cases p) simp_all

lemma below_sprod: "x \<sqsubseteq> y \<longleftrightarrow> sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y"
  by (simp add: Rep_sprod_simps sfst_def ssnd_def cont_Rep_sprod)

lemma eq_sprod: "x = y \<longleftrightarrow> sfst\<cdot>x = sfst\<cdot>y \<and> ssnd\<cdot>x = ssnd\<cdot>y"
  by (auto simp add: po_eq_conv below_sprod)

lemma sfst_below_iff: "sfst\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
  by (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp, simp add: below_sprod)

lemma ssnd_below_iff: "ssnd\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:sfst\<cdot>x, y:)"
  by (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp, simp add: below_sprod)

subsection \<open>Compactness\<close>

lemma compact_sfst: "compact x \<Longrightarrow> compact (sfst\<cdot>x)"
  by (rule compactI) (simp add: sfst_below_iff)

lemma compact_ssnd: "compact x \<Longrightarrow> compact (ssnd\<cdot>x)"
  by (rule compactI) (simp add: ssnd_below_iff)

lemma compact_spair: "compact x \<Longrightarrow> compact y \<Longrightarrow> compact (:x, y:)"
  by (rule compact_sprod) (simp add: Rep_sprod_spair seq_conv_if)

lemma compact_spair_iff: "compact (:x, y:) \<longleftrightarrow> x = \<bottom> \<or> y = \<bottom> \<or> (compact x \<and> compact y)"
  apply (safe elim!: compact_spair)
     apply (drule compact_sfst, simp)
    apply (drule compact_ssnd, simp)
   apply simp
  apply simp
  done

subsection \<open>Properties of \emph{ssplit}\<close>

lemma ssplit1 [simp]: "ssplit\<cdot>f\<cdot>\<bottom> = \<bottom>"
  by (simp add: ssplit_def)

lemma ssplit2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> ssplit\<cdot>f\<cdot>(:x, y:) = f\<cdot>x\<cdot>y"
  by (simp add: ssplit_def)

lemma ssplit3 [simp]: "ssplit\<cdot>spair\<cdot>z = z"
  by (cases z) simp_all

subsection \<open>Strict product preserves flatness\<close>

instance sprod :: (flat, flat) flat
proof
  fix x y :: "'a \<otimes> 'b"
  assume "x \<sqsubseteq> y"
  then show "x = \<bottom> \<or> x = y"
    apply (induct x, simp)
    apply (induct y, simp)
    apply (simp add: spair_below_iff flat_below_iff)
    done
qed

end


theory v5_isar
  imports Main "../QML_S5"
begin

text \<open>
@{text "Compossibility\<^sub>5'"}: If a table @{term x} is originally made from matter @{term y} and it
is possible for a table to be the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z} according to plan @{term p}
while no table is made from matter that only partially overlaps @{term z}, then it is also possible
for table @{term x} to be originally made from matter @{term y} and in addition some table or other
@{term x'} to be the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z} according to plan
@{term p} while no table is made from matter that only partially overlaps @{term z}.

@{text "Origin Uniqueness\<^sub>5'"}: It is impossible that a single table @{term x} is originally made from
matter @{term y} and in addition is originally made from matter @{term z}.

@{text "Sufficiency\<^sub>5'"}: If it is possible that a table @{term x'} is the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p} while no table is made from matter that only partially overlaps @{term z},
then necessarily any table that is the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p} while no table is made from matter that only partially overlaps @{term z}
is the very table @{term x'} and no other.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>5'"}: If a given table is originally made from certain matter, then it is necessary
that the given table is not (the @{text "n\<^sup>t\<^sup>h"} table for any @{term n}) originally made from any non-overlapping
matter @{term z} according to any plan while no table is made from matter that only partially overlaps @{term z}.
\<close>

consts kTable :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu> \<Rightarrow> nat \<Rightarrow> \<sigma>" ("N")

(* (N x y p k) \<equiv> x is the kth table made from y according to p *)
lemma
assumes compossibilty5: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))))))\<rfloor>"
assumes sufficiency5: "\<lfloor>(\<^bold>\<forall>y. \<^bold>\<forall>x. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L y) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L y) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x)))\<rfloor>"
assumes origin_uniqueness5: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))\<rfloor>"
shows origin_essentialism5: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k'))))))\<rfloor>"

proof (rule allI)
  fix w
  show  "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
  proof (rule allI)
    fix x
    show  "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
    proof (rule allI)
      fix y
      show  "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
      proof (rule allI)
        fix z
        show  "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
        proof (rule allI)
          fix p
          show  "(\<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
          proof (rule allI)
            fix k
            show  "(\<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
            proof  (rule impI)
              assume antecedent: "(\<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k))) w"
              show "(\<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
              proof  (rule notI)
                assume n_consequent:"((\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
                from antecedent obtain w where w: "(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) w" by (rule exE)
                then have table_x_from_y: "(N x y p k) w" by (rule conjE)
                have non_overlapping: "(\<^bold>\<not>(y \<^bold>=\<^sup>L z)) w" using antecedent by auto

                from n_consequent have "((\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w" by simp
                then obtain v where v: "(((\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) v" by (rule exE)
                then have "(((\<^bold>\<forall>k'. N x z p k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) v" by (rule allE)
                then have "((( N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))))) v" by (rule allE)
                then have possibility: "((\<^bold>\<diamond>(N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))))) w" by (rule exI)

                then have compossibilty5_ante: "((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) w"
                  using table_x_from_y and non_overlapping and possibility by auto

                from compossibilty5 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w"..
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w" by (rule allE)
                then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w" by (rule allE)
                then have "(((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w" by (rule allE)
                then have "(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w"
                  using compossibilty5_ante by (rule mp)
                then obtain u where u: "(((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) u" by (rule exE)
                then have "(((\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) u" by (rule conjE)
                then obtain x' where x':  "(((N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) u" by (rule exE)
                then have sufficiency5_cons_ante: "(N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) u" by simp
                moreover from u have "(N x y p k) u" by auto

                from sufficiency5 have "(\<^bold>\<forall>y. \<^bold>\<forall>x. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L y) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L y) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) w"..
                then have "(\<^bold>\<forall>x. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) w" by (rule allE)
                then have "(\<^bold>\<diamond>(N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) w" by (rule allE)
                then have "(\<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) u"
                  using possibility by (rule mp)
                then have "((\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) u" by (rule allE)
                then have "(((N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m \<^bold>=\<^sup>L z) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) u" by (rule allE)
                then have identity: "(x' \<^bold>=\<^sup>L x) u" using sufficiency5_cons_ante by (rule mp)

                from sufficiency5_cons_ante have "(N x' z p k) u" by (rule conjE)
                then have "(N x z p k) u" using identity by auto
                then have conj_existence: "(N x y p k u \<and> N x z p k u)" using `N x y p k u` by auto
                then have impossible_arg: "(N x y p k u) \<and> (N x z p k u) \<and> \<not>((y \<^bold>=\<^sup>L z) u)"
                  using non_overlapping by auto

                from origin_uniqueness5 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w"..
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by (rule allE)
                then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by (rule allE)
                then have "(\<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by (rule allE)
                then have "(\<^bold>\<box>(\<^bold>\<not>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) w" by simp
                then have "((\<^bold>\<not>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
                then show False using impossible_arg by (rule notE)
              qed
            qed
          qed
        qed
      qed
    qed
  qed
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)
theory Plus2_Prefix
imports
  "../Prefix_Refinement"
begin

section \<open>The plus2 example.\<close>

text \<open>
This example presents an application of prefix refinement
to solve the plus2 verification problem.

The function below can be proven to do two increments per
instance when grouped in parallel. But RG-reasoning doesn't
work well for this proof, since the state change (+1) performed
by the counterparts must be allowed by the rely, which must be
transitively closed, allowing any number of (+1) operations,
which is far too general.

We address the issue with a ghost variable which records the number
of increments by each thread. We use prefix refinement to relate the
program with ghost variable to the initial program.
\<close>

definition
  "plus2 \<equiv> do env_steps; modify ((+) (1 :: nat));
    interference; modify ((+) 1); interference od"

section \<open>The ghost-extended program.\<close>

record
  plus2_xstate =
    mainv :: nat
    threadv :: "nat \<Rightarrow> nat"

definition
  point_update :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b))"
where
  "point_update x fup f = f (x := fup (f x))"

definition
  "plus2_x tid \<equiv> do env_steps;
    modify (mainv_update ((+) 1) o threadv_update (point_update tid ((+) 1)));
    interference;
    modify (mainv_update ((+) 1) o threadv_update (point_update tid ((+) 1)));
    interference
  od"

section \<open>Verifying the extended @{term plus2}.\<close>
text \<open>The RG-reasoning needed to verify the @{term plus2_x} program.\<close>
definition
  "plus2_inv tids s = (mainv s = sum (threadv s) tids)"

definition
  "plus2_rel tids fix_tids s0 s
    = ((plus2_inv tids s0 \<longrightarrow> plus2_inv tids s) \<and> (\<forall>tid \<in> fix_tids. threadv s tid = threadv s0 tid))"

lemma plus2_rel_trans[simp]:
  "rtranclp (plus2_rel tids ftids) = plus2_rel tids ftids"
  apply (rule rtranclp_id2)
   apply (simp add: plus2_rel_def)
  apply (clarsimp simp: plus2_rel_def)
  done

lemma plus2_inv_Suc[simp]:
  "tid \<in> tids \<Longrightarrow> finite tids
    \<Longrightarrow> plus2_inv tids (mainv_update Suc (threadv_update (point_update tid Suc) s))
        = plus2_inv tids s"
  apply (simp add: plus2_inv_def point_update_def)
  apply (simp add: sum.If_cases[where h=f and g=f and P="(=) tid" and A="tids" for f x, simplified])
  done

theorem plus2_x_property:
  "\<lbrace>\<lambda>s0 s. plus2_inv tids s \<and> threadv s tid = 0 \<and> s = s0 \<and> tid \<in> tids \<and> finite tids\<rbrace>,\<lbrace>plus2_rel tids {tid}\<rbrace>
    plus2_x tid \<lbrace>plus2_rel tids (- {tid})\<rbrace>,\<lbrace>\<lambda>_ _ s. plus2_inv tids s \<and> threadv s tid = 2\<rbrace>"
  apply (simp add: plus2_x_def)
  apply (rule validI_weaken_pre)
   apply wp
  apply clarsimp
  apply (clarsimp simp: plus2_rel_def point_update_def)
  done

corollary plus2_x_parallel:
  "\<lbrace>\<lambda>s0 s. mainv s = 0 \<and> (\<forall>tid \<in> {1, 2}. threadv s tid = 0) \<and> s = s0\<rbrace>,\<lbrace>\<lambda>a b. a = b\<rbrace>
    parallel (plus2_x 1) (plus2_x 2) \<lbrace>\<lambda>s0 s. True\<rbrace>,\<lbrace>\<lambda>_ s0 s. mainv s = 4\<rbrace>"
  apply (rule validI_weaken_pre)
   apply (rule validI_strengthen_post)
    apply ((rule rg_validI plus2_x_property[where tids="{1, 2}"])+; simp add: plus2_rel_def le_fun_def)
   apply (clarsimp simp: plus2_inv_def bipred_conj_def)
  apply (clarsimp simp add: bipred_conj_def plus2_inv_def)
  done

section \<open>Mapping across prefix refinement.\<close>
text \<open>Proving prefix refinement of @{term plus2} and @{term plus2_x} and
deriving the final result.\<close>

lemma env_stable:
  "env_stable AR R (\<lambda>s t. t = mainv s) (\<lambda>s t. t = mainv s) \<top>"
  apply (simp add: env_stable_def rely_stable_def env_rely_stable_iosr_def)
  apply (simp add: plus2_xstate.splits)
  done

abbreviation(input)
  "p_refn rvr P Q AR R \<equiv> prefix_refinement (\<lambda>s t. t = mainv s) (\<lambda>s t. t = mainv s)
    (\<lambda>s t. t = mainv s) rvr P Q AR R"

theorem pfx_refn_plus2_x:
  "p_refn (\<top>\<top>) (=) (\<top>\<top>) AR R (plus2_x tid) plus2"
  apply (simp add: plus2_x_def plus2_def)
  apply (rule prefix_refinement_weaken_pre)
    apply (rule pfx_refn_bind prefix_refinement_interference
         prefix_refinement_env_steps allI
         pfx_refn_modifyT env_stable
       | simp
       | wp)+
  done

lemma par_tr_fin_plus2_x:
  "par_tr_fin_principle (plus2_x tid)"
  by (simp add: plus2_x_def par_tr_fin_interference par_tr_fin_bind)

lemma prefix_closed_plus2:
  "prefix_closed plus2"
  apply (simp add: plus2_def)
  apply (rule validI_prefix_closed_T, rule validI_weaken_pre, wp)
  apply simp
  done

theorem plus2_parallel:
  "\<lbrace>\<lambda>s0 s. s = 0 \<and> s = s0\<rbrace>,\<lbrace>\<lambda>a b. a = b\<rbrace>
    parallel plus2 plus2 \<lbrace>\<lambda>s0 s. True\<rbrace>,\<lbrace>\<lambda>_ s0 s. s = 4\<rbrace>"
  apply (rule_tac sr="\<lambda>s t. t = mainv s" in prefix_refinement_validI)
  apply (rule prefix_refinement_parallel_triv;
      ((rule par_tr_fin_plus2_x prefix_closed_plus2)?))
       apply (rule pfx_refn_plus2_x[where tid=1])
      apply (rule pfx_refn_plus2_x[where tid=2])
     apply clarsimp
     apply (rule validI_strengthen_post)
      apply (rule plus2_x_parallel[simplified])
     apply clarsimp
    apply (clarsimp simp: plus2_xstate.splits)
    apply (strengthen exI[where x="f(1 := x, 2 := y)" for f x y])
    apply simp
   apply clarsimp
  apply (intro parallel_prefix_closed prefix_closed_plus2)
  done

section \<open>Generalising\<close>
text \<open>Just for fun, generalise to arbitrarily many
copies of the @{term plus2} program.\<close>

lemma plus2_x_n_parallel_induct:
  "n > 0 \<Longrightarrow> n \<le> N \<Longrightarrow>
  \<lbrace>\<lambda>s0 s. plus2_inv {..< N} s \<and> (\<forall>i < N. threadv s i = 0) \<and> s = s0\<rbrace>,\<lbrace>plus2_rel {..< N} {..< n}\<rbrace>
    fold parallel (map plus2_x [1 ..< n]) (plus2_x 0) \<lbrace>plus2_rel {..< N} ( - {..< n})\<rbrace>,\<lbrace>\<lambda>_ _ s.
        plus2_inv {..< N} s \<and> (\<forall>i < n. threadv s i = 2)\<rbrace>"
  apply (induct n)
   apply simp
  apply (case_tac n)
   apply (simp only: lessThan_Suc)
   apply simp
   apply (rule validI_weaken_pre, rule plus2_x_property)
   apply clarsimp
  apply (clarsimp split del: if_split)
  apply (rule validI_weaken_pre, rule validI_strengthen_post,
    rule rg_validI, rule plus2_x_property[where tids="{..< N}"],
    assumption, (clarsimp simp: plus2_rel_def)+)
   apply (auto dest: less_Suc_eq[THEN iffD1])[1]
  apply (clarsimp simp: bipred_conj_def)
  done

theorem plus2_x_n_parallel:
  "n > 0 \<Longrightarrow>
  \<lbrace>\<lambda>s0 s. mainv s = 0 \<and> (\<forall>i < n. threadv s i = 0) \<and> s = s0\<rbrace>,\<lbrace>plus2_rel {..< n} {..< n}\<rbrace>
    fold parallel (map plus2_x [1 ..< n]) (plus2_x 0) \<lbrace>\<lambda>s0 s. True\<rbrace>,\<lbrace>\<lambda>_ _ s. mainv s = (n * 2)\<rbrace>"
  apply (rule validI_weaken_pre, rule validI_strengthen_post,
      rule validI_strengthen_guar, erule plus2_x_n_parallel_induct)
     apply simp
    apply simp
   apply (clarsimp simp: plus2_inv_def)
  apply (clarsimp simp: plus2_inv_def)
  done

lemma par_tr_fin_principle_parallel:
  "par_tr_fin_principle f \<Longrightarrow> par_tr_fin_principle g
    \<Longrightarrow> par_tr_fin_principle (parallel f g)"
  apply (subst par_tr_fin_principle_def, clarsimp simp: parallel_def3)
  apply (drule(1) par_tr_fin_principleD)+
  apply (clarsimp simp: neq_Nil_conv)
  done

lemma fold_parallel_par_tr_fin_principle[where xs="rev xs" for xs, simplified]:
  "\<forall>x \<in> insert x (set xs). par_tr_fin_principle x
    \<Longrightarrow> par_tr_fin_principle (fold parallel (rev xs) x)"
  by (induct xs, simp_all add: par_tr_fin_principle_parallel)

lemma fold_parallel_prefix_closed[where xs="rev xs" for xs, simplified]:
  "\<forall>x \<in> insert x (set xs). prefix_closed x
    \<Longrightarrow> prefix_closed (fold parallel (rev xs) x)"
  by (induct xs, simp_all add: parallel_prefix_closed)

lemma bipred_disj_top_eq:
  "(Rel Or (\<lambda>_ _. True)) = (\<lambda>_ _. True)"
  "((\<lambda>_ _. True) Or Rel) = (\<lambda>_ _. True)"
  by (auto simp add: bipred_disj_def)

lemma fold_parallel_pfx_refn_induct:
  "list_all2 (prefix_refinement sr sr sr (\<lambda>_ _. True) P Q (\<top>\<top>) (\<top>\<top>)) xs ys
    \<Longrightarrow> prefix_refinement sr sr sr (\<lambda>_ _. True) P Q (\<top>\<top>) (\<top>\<top>) x y
    \<Longrightarrow> \<forall>x \<in> set (x # xs). par_tr_fin_principle x
    \<Longrightarrow> \<forall>y \<in> set (y # ys). prefix_closed y
    \<Longrightarrow> prefix_refinement sr sr sr (\<lambda>_ _. True) P Q (\<top>\<top>) (\<top>\<top>)
        (fold parallel (rev xs) x) (fold parallel (rev ys) y)"
  apply (induct rule: list_all2_induct; simp)
  apply (rule prefix_refinement_parallel_triv[simplified bipred_disj_top_eq]; simp?)
   apply (clarsimp simp: fold_parallel_par_tr_fin_principle
                         fold_parallel_prefix_closed)+
  done

lemmas fold_parallel_pfx_refn
    = fold_parallel_pfx_refn_induct[where xs="rev xs" and ys="rev ys" for xs ys, simplified]

theorem plus2_n_parallel:
  "n > 0
    \<Longrightarrow> \<lbrace>\<lambda>s0 s. s = 0 \<and> s = s0\<rbrace>,\<lbrace>\<lambda>a b. a = b\<rbrace>
        fold parallel (replicate (n - 1) plus2) plus2 \<lbrace>\<lambda>s0 s. True\<rbrace>,\<lbrace>\<lambda>_ s0 s. s = n * 2\<rbrace>"
  apply (rule_tac sr="\<lambda>s t. t = mainv s" in prefix_refinement_validI)
      apply (rule prefix_refinement_weaken_rely,
      rule_tac xs="map plus2_x [1 ..< n]" in fold_parallel_pfx_refn)
           apply (clarsimp simp: list_all2_conv_all_nth)
           apply (rule pfx_refn_plus2_x)
          apply (rule pfx_refn_plus2_x[where tid=0])
         apply (simp add: par_tr_fin_plus2_x)
        apply (simp add: prefix_closed_plus2)
       apply (simp add: le_fun_def)
      apply (simp add: le_fun_def)
     apply simp
     apply (rule validI_strengthen_post, rule plus2_x_n_parallel[simplified], simp)
     apply clarsimp
    apply (clarsimp simp: plus2_xstate.splits exI[where x="\<lambda>_. 0"])
   apply clarsimp
   apply (rule exI, strengthen refl)
   apply (clarsimp simp: plus2_rel_def plus2_inv_def)
  apply (rule fold_parallel_prefix_closed)
  apply (simp add: prefix_closed_plus2)
  done

end