theory Instantiation
  imports Individuals Universals ClosedPermutations
begin

record ('i,'u) instantiation_structure =
  indiv_structure :: "'i individual_structure" ("\<I>\<S>\<index>")
  univ_structure :: "'u universal_structure" ("\<U>\<S>\<index>")
  moment_miof :: "'i \<Rightarrow> 'u \<Rightarrow> bool" (infix "\<Colon>\<^sub>m\<^sub>\<diamondop>\<index>" 75)

abbreviation is_worlds ("\<W>\<^sub>*\<index>") where "\<W>\<^sub>* \<equiv> \<W>\<^bsub>\<I>\<S>\<^esub>" for S (structure)
abbreviation is_individuals ("\<I>\<^sub>*\<index>") where "\<I>\<^sub>* \<equiv> \<I>\<^bsub>\<I>\<S>\<^esub>" for S (structure)
abbreviation is_substantials ("\<S>\<^sub>*\<index>") where "\<S>\<^sub>* \<equiv> \<S>\<^bsub>\<I>\<S>\<^esub>" for S (structure)
abbreviation is_moments ("\<M>\<^sub>*\<index>") where "\<M>\<^sub>* \<equiv> \<M>\<^bsub>\<I>\<S>\<^esub>" for S (structure)
abbreviation is_inheres_in (infix "\<triangleleft>\<^sub>*\<index>" 75) where "(\<triangleleft>\<^sub>*) \<equiv> inheres_in \<I>\<S>" for S (structure)
abbreviation is_similar_to (infix "\<simeq>\<^sub>*\<index>" 75) where "(\<simeq>\<^sub>*) \<equiv> exactly_similar_to \<I>\<S>" for S (structure)
abbreviation is_refers_to (infix "\<hookrightarrow>\<^sub>*\<index>" 75) where "(\<hookrightarrow>\<^sub>*) \<equiv> refers_to \<I>\<S>" for S (structure)
abbreviation is_bearer ("\<beta>\<^sub>*\<index>") where "(\<beta>\<^sub>*) \<equiv> bearer \<I>\<S>" for S (structure)
abbreviation is_ed ("ed\<^sub>*\<index>") where "(ed\<^sub>*) \<equiv> existentially_dependent \<I>\<S>" for S (structure)
abbreviation is_universals ("\<U>\<^sub>*\<index>") where "\<U>\<^sub>* \<equiv> \<U>\<^bsub>\<U>\<S>\<^esub>" for S (structure)
abbreviation is_substantial_universals ("\<U>\<^sub>s\<^sub>*\<index>") where "\<U>\<^sub>s\<^sub>* \<equiv> \<U>\<^sub>s\<^bsub>\<U>\<S>\<^esub>" for S (structure)
abbreviation is_moment_universals ("\<U>\<^sub>m\<^sub>*\<index>") where "\<U>\<^sub>m\<^sub>* \<equiv> \<U>\<^sub>m\<^bsub>\<U>\<S>\<^esub>" for S (structure)
abbreviation is_char_by ("char'_by\<^sub>*\<index>") where "char_by\<^sub>* \<equiv> characterized_by \<U>\<S>" for S (structure)
abbreviation is_char_set ("char'_set\<^sub>*\<index>") where "char_set\<^sub>* \<equiv> characterizing_set \<U>\<S>" for S (structure)
abbreviation is_m_subsumes (infix "\<preceq>\<^sub>m\<^sub>*\<index>" 75) where "(\<preceq>\<^sub>m\<^sub>*) \<equiv> moment_subsumption \<U>\<S>" for S (structure)
abbreviation is_s_subsumes (infix "\<preceq>\<^sub>s\<^sub>*\<index>" 75) where "(\<preceq>\<^sub>s\<^sub>*) \<equiv> substantial_subsumption \<U>\<S>" for S (structure)
abbreviation is_subsumes (infix "\<preceq>\<^sub>*\<index>" 75) where "(\<preceq>\<^sub>*) \<equiv> subsumption \<U>\<S>" for S (structure)
abbreviation is_top_subst_univ ("\<top>\<^sub>s\<^sub>*\<index>") where "\<top>\<^sub>s\<^sub>* \<equiv> top_subst_univ \<U>\<S>" for S (structure)

abbreviation moment_iof :: "('i,'u) instantiation_structure \<Rightarrow> 'i \<Rightarrow> 'i set \<Rightarrow> 'u \<Rightarrow> bool" ("_ \<Colon>\<^sub>m\<index>\<^bsub>_\<^esub> _" [76,1,76] 75) where
  "m \<Colon>\<^sub>m\<^bsub>w\<^esub> u \<equiv> w \<in> \<W>\<^sub>* \<and> m \<in> w \<and> m \<Colon>\<^sub>m\<^sub>\<diamondop> u"
  for IS (structure)

definition substantial_iof :: "('i,'u) instantiation_structure \<Rightarrow> 'i \<Rightarrow> 'i set \<Rightarrow> 'u \<Rightarrow> bool" ("_ \<Colon>\<^sub>s\<index>\<^bsub>_\<^esub> _" [76,1,76] 75) where
  "x \<Colon>\<^sub>s\<^bsub>w\<^esub> U \<equiv> x \<in> \<S>\<^sub>* \<and> U \<in> \<U>\<^sub>s\<^sub>* \<and> w \<in> \<W>\<^sub>* \<and> x \<in> w \<and>
      (\<forall>u \<in> char_set\<^sub>* U. \<exists>m. m \<triangleleft>\<^sub>* x \<and> m \<Colon>\<^sub>m\<^bsub>w\<^esub> u)"
  for IS (structure)

lemma substantial_iof_I:
  fixes IS (structure)
  assumes "x \<in> \<S>\<^sub>*" "U \<in> \<U>\<^sub>s\<^sub>*" "w \<in> \<W>\<^sub>*" "x \<in> w"
      "\<And>u. u \<in> char_set\<^sub>* U \<Longrightarrow> \<exists>m. m \<triangleleft>\<^sub>* x \<and> m \<Colon>\<^sub>m\<^bsub>w\<^esub> u"
    shows "x \<Colon>\<^sub>s\<^bsub>w\<^esub> U"
  using assms by  (auto simp: substantial_iof_def)

lemma substantial_iof_E[elim!]:
  fixes IS (structure)
  assumes "x \<Colon>\<^sub>s\<^bsub>w\<^esub> U"
  obtains "x \<in> \<S>\<^sub>*" "U \<in> \<U>\<^sub>s\<^sub>*" "w \<in> \<W>\<^sub>*" "x \<in> w"
      "\<And>u. u \<in> char_set\<^sub>* U \<Longrightarrow> \<exists>m. m \<triangleleft>\<^sub>* x \<and> m \<Colon>\<^sub>m\<^bsub>w\<^esub> u"
  using assms by  (auto simp: substantial_iof_def)

definition iof :: "('i,'u) instantiation_structure \<Rightarrow> 'i \<Rightarrow> 'i set \<Rightarrow> 'u \<Rightarrow> bool" ("_ \<Colon>\<index>\<^bsub>_\<^esub> _" [76,1,76] 75) where
  "x \<Colon>\<^bsub>w\<^esub> U \<equiv> x \<Colon>\<^sub>s\<^bsub>w\<^esub> U \<or> x \<Colon>\<^sub>m\<^bsub>w\<^esub> U"
  for IS (structure)

lemma iof_S_I: "x \<Colon>\<^sub>s\<^bsub>w\<^esub> U \<Longrightarrow> x \<Colon>\<^bsub>w\<^esub> U"
  for IS (structure)
  by (auto simp: iof_def)

lemma iof_M_I: "x \<Colon>\<^sub>m\<^bsub>w\<^esub> U \<Longrightarrow> x \<Colon>\<^bsub>w\<^esub> U"
  for IS (structure)
  by (auto simp: iof_def)

lemma iof_I[intro!]: "x \<Colon>\<^sub>m\<^bsub>w\<^esub> U \<or> x \<Colon>\<^sub>s\<^bsub>w\<^esub> U \<Longrightarrow> x \<Colon>\<^bsub>w\<^esub> U"
  for IS (structure)
  by (auto simp: iof_def)

lemma iof_E[elim!,cases pred]:
  fixes IS (structure)
  assumes "x \<Colon>\<^bsub>w\<^esub> U"
  obtains (moment_iof) "x \<Colon>\<^sub>m\<^bsub>w\<^esub> U" |
          (subst_iof) "x \<Colon>\<^sub>s\<^bsub>w\<^esub> U"
  using assms
  by (simp only: iof_def ; metis)

definition miof :: "('i,'u) instantiation_structure \<Rightarrow> 'i \<Rightarrow> 'u \<Rightarrow> bool" (infix "\<Colon>\<^sub>\<diamondop>\<index>" 75) where
  "x \<Colon>\<^sub>\<diamondop> u \<equiv> \<exists>w \<in> worlds \<I>\<S>. x \<Colon>\<^bsub>w\<^esub> u"
  for IS (structure)

(* UNUSED lemma instantiation_structure_eqI:
  fixes A B :: "('i,'u) instantiation_structure"
  assumes "\<I>\<S>\<^bsub>A\<^esub> = \<I>\<S>\<^bsub>B\<^esub>" "\<U>\<S>\<^bsub>A\<^esub> = \<U>\<S>\<^bsub>B\<^esub>" "moment_miof A = moment_miof B"
  shows "A = B"
  using assms by (cases A ; cases B  ; simp) *)

locale instantiation_structure_defs =
  fixes IS :: "('i,'u) instantiation_structure" (structure)
begin

definition rigid where
  "rigid U \<equiv> U \<in> \<U>\<^sub>* \<and> (\<forall>x w\<^sub>1. \<forall>w\<^sub>2 \<in> \<W>\<^sub>*. x \<Colon>\<^bsub>w\<^sub>1\<^esub> U \<and> x \<in> w\<^sub>2 \<longrightarrow> x \<Colon>\<^bsub>w\<^sub>2\<^esub> U)"

definition non_rigid where
  "non_rigid U \<equiv> U \<in> \<U>\<^sub>* \<and> (\<exists>x w\<^sub>1. \<exists>w\<^sub>2 \<in> \<W>\<^sub>*. x \<Colon>\<^bsub>w\<^sub>1\<^esub> U \<and> x \<in> w\<^sub>2 \<and> \<not> x \<Colon>\<^bsub>w\<^sub>2\<^esub> U)"

abbreviation rigid_universals ("\<U>\<^sup>R") where
  "\<U>\<^sup>R \<equiv> { U . rigid U }"

abbreviation non_rigid_universals ("\<U>\<^sup>N") where
  "\<U>\<^sup>N \<equiv> { U . non_rigid U }"

definition equi_instances_S (infix "\<sim>\<^sub>s" 75) where
  "x \<sim>\<^sub>s y \<equiv> x \<in> \<S>\<^sub>* \<and> y \<in> \<S>\<^sub>* \<and> (\<forall>U w. x \<Colon>\<^sub>s\<^bsub>w\<^esub> U \<longleftrightarrow> y \<Colon>\<^sub>s\<^bsub>w\<^esub> U)"

definition equi_instances_M (infix "\<sim>\<^sub>m" 75) where
  "x \<sim>\<^sub>m y \<equiv> x \<in> \<M>\<^sub>* \<and> y \<in> \<M>\<^sub>* \<and> (\<forall>u. x \<Colon>\<^sub>m\<^sub>\<diamondop> u \<longleftrightarrow> y \<Colon>\<^sub>m\<^sub>\<diamondop> u) \<and> \<beta>\<^sub>* x \<sim>\<^sub>s \<beta>\<^sub>* y"

definition equi_instances (infix "\<sim>" 75) where
  "x \<sim> y \<equiv> x \<sim>\<^sub>s y \<or> x \<sim>\<^sub>m y"

abbreviation "EquiPerms \<equiv> individual_structure_defs.ClosedPerms \<I>\<S> (\<sim>)"

end

locale instantiation_structure =
  instantiation_structure_defs "IS" +
  individual_structure "\<I>\<S>" +
  universal_structure "\<U>\<S>"
  for IS :: "('i,'u) instantiation_structure" (structure) +
  assumes
    moment_miof_scope: "x \<Colon>\<^sub>m\<^sub>\<diamondop> u \<Longrightarrow> x \<in> \<M>\<^sub>* \<and> u \<in> \<U>\<^sub>m\<^sub>*" and
(*    iof_scope: "x \<Colon>\<^bsub>w\<^esub> u \<Longrightarrow> w \<in> \<W> \<and> x \<in> w \<and> u \<in> \<U>" and*)
    moment_miof_agrees_with_subsumes: "\<lbrakk> U\<^sub>1 \<in> \<U>\<^sub>m\<^sub>* ; U\<^sub>2 \<in> \<U>\<^sub>m\<^sub>* \<rbrakk> \<Longrightarrow> U\<^sub>1 \<preceq>\<^sub>m\<^sub>* U\<^sub>2 \<longleftrightarrow> (\<forall>x. x \<Colon>\<^sub>m\<^sub>\<diamondop> U\<^sub>1 \<longrightarrow> x \<Colon>\<^sub>m\<^sub>\<diamondop> U\<^sub>2)" and
(*     iof_agrees_with_subsumes: "U\<^sub>1 \<preceq> U\<^sub>2 \<longleftrightarrow> U\<^sub>1 \<in> \<U> \<and> (\<forall>x w. x \<Colon>\<^bsub>w\<^esub> U\<^sub>1 \<longrightarrow> x \<Colon>\<^bsub>w\<^esub> U\<^sub>2)" and *)
    at_least_one_instance: "U \<in> \<U>\<^sub>* \<Longrightarrow> \<exists>x w. x \<Colon>\<^bsub>w\<^esub> U" and
    every_individual_is_iof: "\<lbrakk> w \<in> \<W>\<^sub>* ; x \<in> w \<rbrakk> \<Longrightarrow> \<exists>U. x \<Colon>\<^bsub>w\<^esub> U" and
    iof_agree_with_characterization:
      "\<lbrakk> char_by\<^sub>* U u ; x \<Colon>\<^sub>s\<^bsub>w\<^esub> U \<rbrakk> \<Longrightarrow> \<exists>y. y \<triangleleft>\<^sub>* x \<and> y \<Colon>\<^sub>m\<^bsub>w\<^esub> u" and
    moment_iof_agrees_with_similarity_1: "\<lbrakk> m\<^sub>1 \<simeq>\<^sub>* m\<^sub>2 ; m\<^sub>1 \<Colon>\<^sub>m\<^sub>\<diamondop> U \<rbrakk> \<Longrightarrow> m\<^sub>2 \<Colon>\<^sub>m\<^sub>\<diamondop> U" and
    moment_univ_extensionality: "\<lbrakk> U\<^sub>1 \<in> \<U>\<^sub>m\<^sub>* ; U\<^sub>2 \<in> \<U>\<^sub>m\<^sub>* ; \<forall>x. x \<Colon>\<^sub>m\<^sub>\<diamondop> U\<^sub>1 \<longleftrightarrow> x \<Colon>\<^sub>m\<^sub>\<diamondop> U\<^sub>2 \<rbrakk> \<Longrightarrow> U\<^sub>1 = U\<^sub>2" and
    no_orphan_moments: "\<lbrakk> m \<triangleleft>\<^sub>* x ; w \<in> \<W>\<^sub>* ; m \<in> w \<rbrakk> \<Longrightarrow> \<exists>U u. m \<Colon>\<^sub>\<diamondop> u \<and> x \<Colon>\<^sub>s\<^bsub>w\<^esub> U \<and> char_by\<^sub>* U u"

begin

lemma moment_iof_agrees_with_similarity:
  assumes "m\<^sub>1 \<simeq>\<^sub>* m\<^sub>2" "m\<^sub>1 \<Colon>\<^sub>m\<^bsub>w\<^sub>1\<^esub> U" "w\<^sub>2 \<in> \<W>\<^sub>*" "m\<^sub>2 \<in> w\<^sub>2"
  shows "m\<^sub>2 \<Colon>\<^sub>m\<^bsub>w\<^sub>2\<^esub> U"
  using moment_iof_agrees_with_similarity_1[OF assms(1),of U] assms
    by simp

lemma moment_iof_scope: "x \<Colon>\<^sub>m\<^bsub>w\<^esub> u \<Longrightarrow> w \<in> \<W>\<^sub>* \<and> x \<in> w \<and> x \<in> \<M>\<^sub>* \<and> u \<in> \<U>\<^sub>m\<^sub>*"
  using moment_miof_scope
  by blast

lemma moment_iof_agrees_with_subsumes: "\<lbrakk> U\<^sub>1 \<in> \<U>\<^sub>m\<^sub>* ; U\<^sub>2 \<in> \<U>\<^sub>m\<^sub>* \<rbrakk> \<Longrightarrow> U\<^sub>1 \<preceq>\<^sub>m\<^sub>* U\<^sub>2 \<longleftrightarrow> (\<forall>x w. x \<Colon>\<^sub>m\<^bsub>w\<^esub> U\<^sub>1 \<longrightarrow> x \<Colon>\<^sub>m\<^bsub>w\<^esub> U\<^sub>2)"
  using moment_miof_agrees_with_subsumes
  by (meson every_individual_exists_somewhere inheres_in_scope moment_miof_scope momentsE)

lemma iof_scope:
  assumes "x \<Colon>\<^bsub>w\<^esub> u"
  shows "w \<in> \<W>\<^sub>* \<and> x \<in> w \<and> u \<in> \<U>\<^sub>*"
  using assms apply (cases rule: iof_E)
  subgoal using moment_iof_scope universal_I by metis
  using substantial_iof_E universal_I by force

lemma iof_scope_D:
  assumes "x \<Colon>\<^bsub>w\<^esub> u"
  shows "x \<in> \<I>\<^sub>*" "w \<in> \<W>\<^sub>*" "x \<in> w" "u \<in> \<U>\<^sub>*"
  using iof_scope[OF assms] worlds_are_made_of_individuals[of w] by blast+

lemma iof_scope_E[cases pred]:
  assumes "x \<Colon>\<^bsub>w\<^esub> u"
  obtains (subst) "w \<in> \<W>\<^sub>*" "x \<in> w" "x \<in> \<S>\<^sub>*" "u \<in> \<U>\<^sub>s\<^sub>*"  |
          (moment) "w \<in> \<W>\<^sub>*" "x \<in> w" "x \<in> \<M>\<^sub>*" "u \<in> \<U>\<^sub>m\<^sub>*"
proof -
  obtain A: "w \<in> \<W>\<^sub>*" "x \<in> w" "u \<in> \<U>\<^sub>*" using assms iof_scope by auto
  then have B:"x \<in> \<I>\<^sub>*" using worlds_are_made_of_individuals by blast
  have C1: False if "u \<in> \<U>\<^sub>m\<^sub>*" "u \<in> \<U>\<^sub>s\<^sub>*" using that A(3) universal_exhaust by blast
  have C2: False if "x \<in> \<S>\<^sub>*" "x \<in> \<M>\<^sub>*" using that B individuals_cases by blast
  have D1: "x \<in> \<M>\<^sub>* \<and> x \<notin> \<S>\<^sub>* \<and> u \<in> \<U>\<^sub>m\<^sub>* \<and> u \<notin> \<U>\<^sub>s\<^sub>*" if as: "x \<Colon>\<^sub>m\<^bsub>w\<^esub> u"
    using moment_iof_scope[OF as]
    apply (clarsimp)
    apply (intro conjI notI)
    subgoal by (frule C2 ; simp)
    by (frule C1 ; simp)

  have D2: "x \<notin> \<M>\<^sub>* \<and> x \<in> \<S>\<^sub>* \<and> u \<notin> \<U>\<^sub>m\<^sub>* \<and> u \<in> \<U>\<^sub>s\<^sub>*" if as: "x \<Colon>\<^sub>s\<^bsub>w\<^esub> u"
    using as apply (simp add: substantial_iof_def[of IS x w u] ;
                    elim conjE ; intro conjI notI)
    using C1 C2 by metis+

  obtain E: "x \<in> \<S>\<^sub>*" "u \<in> \<U>\<^sub>s\<^sub>*" if "x \<Colon>\<^sub>s\<^bsub>w\<^esub> u" using substantial_iof_def by metis
  note F = that[OF A(1,2)]
  show ?thesis
    apply (rule iof_E[OF assms])
    subgoal by (frule D1 ; simp add: F(2))
    by (frule D2 ; simp add: F(1))
qed

(* UNUSED lemma iof_moment_rigid:
  assumes "m \<in> \<M>\<^sub>*" "m \<Colon>\<^bsub>w\<^esub> U" "w' \<in> \<W>\<^sub>*" "m \<in> w'"
  shows "m \<Colon>\<^bsub>w'\<^esub> U"
  using assms
  by (meson exactly_similar_refl individual_structure.individuals_cases individual_structure.inheres_in_scope individual_structure_axioms iof_def moment_iof_agrees_with_similarity momentsE substantial_iof_E) *)

lemma char_by_E2:
  assumes "char_by\<^sub>* U\<^sub>1 U\<^sub>2"
  obtains "U\<^sub>1 \<in> \<U>\<^sub>s\<^sub>*" "U\<^sub>2 \<in> \<U>\<^sub>m\<^sub>*" "\<And>x w. x \<Colon>\<^bsub>w\<^esub> U\<^sub>1 \<Longrightarrow> \<exists>m. m \<Colon>\<^bsub>w\<^esub> U\<^sub>2 \<and> m \<triangleleft>\<^sub>* x"
proof -
  obtain A: "U\<^sub>1 \<in> \<U>\<^sub>s\<^sub>*" "\<And>x w. x \<Colon>\<^bsub>w\<^esub> U\<^sub>1 \<Longrightarrow> \<exists>m. m \<Colon>\<^bsub>w\<^esub> U\<^sub>2 \<and> m \<triangleleft>\<^sub>* x"
    using assms
    by (meson char_set_I characterized_by_scope instantiation_structure.moment_iof_scope instantiation_structure_axioms iof_def no_moment_univ_is_characterized substantial_iof_E)
  obtain x w where B: "x \<Colon>\<^bsub>w\<^esub> U\<^sub>1"
    using A(1) at_least_one_instance universal_I
    by presburger
  then obtain C: "x \<in> \<I>\<^sub>*" "w \<in> \<W>\<^sub>*" "x \<in> w"
    using iof_scope A(1) using A(2) inheres_in_scope
    by meson
  obtain m where D: "m \<Colon>\<^bsub>w\<^esub> U\<^sub>2" "m \<triangleleft>\<^sub>* x" using A(2) B by meson
  then have "m \<in> \<M>\<^sub>*" using momentsI by simp
  then have E: "U\<^sub>2 \<in> \<U>\<^sub>m\<^sub>*"
    using substantials_moments_disj momentsE inheres_in_scope
          D(1) iof_scope local.subsumes_refl local.subsumes_scope
    by (meson assms characterized_by_scope_E)
  show ?thesis using that A E by blast
qed

lemma miof_I[intro]:
  assumes "x \<Colon>\<^bsub>w\<^esub> u"
  shows "x \<Colon>\<^sub>\<diamondop> u"
  using assms apply (simp add: miof_def ; intro bexI[of _ w] ; simp?)
  using iof_scope by simp

lemma miof_E[elim]:
  assumes "x \<Colon>\<^sub>\<diamondop> u"
  obtains w where "x \<Colon>\<^bsub>w\<^esub> u"
  using assms by (simp add: miof_def ; meson)

lemma char_by_scope:
  assumes "char_by\<^sub>* U U'"
  shows "U \<in> \<U>\<^sub>s\<^sub>*" "U' \<in> \<U>\<^sub>m\<^sub>*"
  using assms char_by_E2 by metis+

lemma  iof_S_U_simp: "x \<Colon>\<^bsub>w\<^esub> u \<Longrightarrow> x \<in> \<S>\<^sub>* \<longleftrightarrow> u \<in> \<U>\<^sub>s\<^sub>*"
  using iof_scope_E substantials_moments_disj
  by (metis individual_structure.individuals_cases individual_structure_axioms instantiation_structure.iof_scope instantiation_structure_axioms substantialsE universal_exhaust)

lemma  iof_M_U_simp: "x \<Colon>\<^bsub>w\<^esub> u \<Longrightarrow> x \<in> \<M>\<^sub>* \<longleftrightarrow> u \<in> \<U>\<^sub>m\<^sub>*"
  using iof_scope_E substantials_moments_disj
  by (metis individual_structure.individuals_cases individual_structure_axioms instantiation_structure.iof_scope instantiation_structure_axioms substantialsE universal_exhaust)

lemma  iof_S_simp: "x \<in> \<S>\<^sub>* \<or> u \<in> \<U>\<^sub>s\<^sub>* \<Longrightarrow> x \<Colon>\<^bsub>w\<^esub> u \<longleftrightarrow> x \<Colon>\<^sub>s\<^bsub>w\<^esub> u"
  by (meson individuals_cases instantiation_structure.moment_iof_scope instantiation_structure_axioms iof_E iof_S_I iof_S_U_simp substantialsE)

lemma  iof_M_simp: "x \<in> \<M>\<^sub>* \<or> u \<in> \<U>\<^sub>m\<^sub>* \<Longrightarrow> x \<Colon>\<^bsub>w\<^esub> u \<longleftrightarrow> x \<Colon>\<^sub>m\<^bsub>w\<^esub> u"
  by (meson individuals_cases iof_E iof_M_I iof_M_U_simp substantial_iof_E substantialsE)

(* UNUSED lemma rigid_moment_universals: "u \<in> \<U>\<^sub>m\<^sub>* \<Longrightarrow> rigid u"
  apply (clarsimp simp: rigid_def ; intro conjI allI ballI impI ; (elim conjE)?)
  subgoal G1 using universal_I by simp
  subgoal G2 for x w\<^sub>1 w\<^sub>2
    apply (intro moment_iof_agrees_with_similarity[of x x w\<^sub>1 u w\<^sub>2, THEN iof_I[OF disjI1]] exactly_similar_refl[of x]
          ; simp?)
    subgoal by (simp add: iof_M_U_simp)
    by (simp add: iof_M_simp)
  done *)

lemma subtantial_iof_agrees_with_subsumes:
  assumes "x \<Colon>\<^sub>s\<^bsub>w\<^esub> U" "U \<preceq>\<^sub>s\<^sub>* U'"
  shows "x \<Colon>\<^sub>s\<^bsub>w\<^esub> U'"
proof -
  obtain A[simp,intro!]: "x \<in> \<S>\<^sub>*" "U \<in> \<U>\<^sub>s\<^sub>*" "w \<in> \<W>\<^sub>*" "x \<in> w"
    and B: "\<And>u. u \<in> characterizing_set \<U>\<S> U \<Longrightarrow> \<exists>m. m \<triangleleft>\<^sub>* x \<and> m \<Colon>\<^sub>m\<^bsub>w\<^esub> u"
    using substantial_iof_E[OF assms(1)] by metis
  then have B1: "\<And>u. char_by\<^sub>* U u \<Longrightarrow> \<exists>m. m \<triangleleft>\<^sub>* x \<and> m \<Colon>\<^sub>m\<^bsub>w\<^esub> u"
    using characterizing_set_def by simp
  obtain C[simp,intro!]: "U' \<in> \<U>\<^sub>s\<^sub>*" and D: "\<And>u.  char_by\<^sub>* U' u \<Longrightarrow> \<exists>u'. char_by\<^sub>* U u' \<and> u' \<preceq>\<^sub>m\<^sub>* u"
    using substantial_subsumption_E[OF assms(2)] by metis
  show ?thesis
    apply (intro substantial_iof_I A C)
    subgoal premises P for U
      apply (rule exE[OF P[THEN char_set_D, THEN D]] ; elim conjE ; intro B1)
      using characterization_respects_subsumption by blast
    done
qed

lemma iof_agrees_with_subsumes:
  assumes "x \<Colon>\<^bsub>w\<^esub> U" "U \<preceq>\<^sub>* U'"
  shows "x \<Colon>\<^bsub>w\<^esub> U'"
proof -
  consider (c1) "x \<Colon>\<^sub>s\<^bsub>w\<^esub> U" "U \<preceq>\<^sub>s\<^sub>* U'" | (c2) "x \<Colon>\<^sub>m\<^bsub>w\<^esub> U" "U \<preceq>\<^sub>m\<^sub>* U'"
    using assms(1,2)
    by (meson iof_M_simp iof_S_simp moment_subsumes_scope substantial_subsumption_scope(1) subsumesE)
  then show ?thesis
    apply cases
    subgoal G1 using subtantial_iof_agrees_with_subsumes  iof_S_I by metis
    subgoal G2 premises P
      using moment_iof_agrees_with_subsumes[of U U',THEN iffD1,rule_format,of w x,OF _  _ P(2,1)]
                    iof_M_I[of w IS x U'] moment_iof_scope[of w x U'] moment_iof_scope[OF  P(1)]
                    P(2) moment_subsumes_scope
      by blast
    done
qed

lemma miof_agrees_with_subsumes:
  assumes "x \<Colon>\<^sub>\<diamondop> U" "U \<preceq>\<^sub>* U'"
  shows "x \<Colon>\<^sub>\<diamondop> U'"
  using assms miof_def iof_agrees_with_subsumes by metis

lemma  not_subst_miof_ex:
  assumes "s\<^sub>y \<in> \<S>\<^sub>*" "U \<in> \<U>\<^sub>s\<^sub>*" "\<not> s\<^sub>y \<Colon>\<^sub>\<diamondop> U" "w \<in> \<W>\<^sub>*" "s\<^sub>y \<in> w"
  shows "\<exists>u. char_by\<^sub>* U u \<and> (\<forall>m. m \<triangleleft>\<^sub>* s\<^sub>y \<and> m \<in> w \<longrightarrow> \<not> m \<Colon>\<^sub>m\<^sub>\<diamondop> u)"
proof (rule ccontr ; simp only: not_ex de_Morgan_conj not_all not_imp not_not)
  assume as: "\<forall>u. \<not> char_by\<^sub>* U u \<or> (\<exists>m. (m \<triangleleft>\<^sub>* s\<^sub>y \<and> m \<in> w) \<and> m \<Colon>\<^sub>m\<^sub>\<diamondop> u)"
  then have A: "char_by\<^sub>* U u \<Longrightarrow> \<exists>m. m \<triangleleft>\<^sub>* s\<^sub>y \<and> m \<Colon>\<^sub>m\<^bsub>w\<^esub> u" for u
    by (simp add: assms)
  then obtain \<sigma> where B: "\<sigma> u \<triangleleft>\<^sub>* s\<^sub>y" "\<sigma> u \<in> w" "\<sigma> u \<Colon>\<^sub>m\<^sub>\<diamondop> u" if "char_by\<^sub>* U u" for u
    using that by moura
  have "s\<^sub>y \<Colon>\<^sub>s\<^bsub>w\<^esub> U"
    apply (intro substantial_iof_I assms)
    apply (elim char_set_E)
    using A by simp
  then have "s\<^sub>y \<Colon>\<^sub>\<diamondop> U" by (meson iof_S_I miof_I)
  then show False using assms by simp
qed

(* UNUSED lemma  not_subst_miof_E:
  assumes "s\<^sub>y \<in> \<S>\<^sub>*" "U \<in> \<U>\<^sub>s\<^sub>*" "\<not> s\<^sub>y \<Colon>\<^sub>\<diamondop> U" "w \<in> \<W>\<^sub>*" "s\<^sub>y \<in> w"
  obtains u where "char_by\<^sub>* U u" "\<And>m. \<lbrakk> m \<triangleleft>\<^sub>* s\<^sub>y ; m \<in> w \<rbrakk> \<Longrightarrow> \<not> m \<Colon>\<^sub>m\<^sub>\<diamondop> u"
  using not_subst_miof_ex[OF assms] by metis *)

lemma equi_instances_S_I[intro!]:
  assumes "x \<in> \<S>\<^sub>*" "y \<in> \<S>\<^sub>*" "\<And>U w. x \<Colon>\<^sub>s\<^bsub>w\<^esub> U \<longleftrightarrow> y \<Colon>\<^sub>s\<^bsub>w\<^esub> U"
  shows "x \<sim>\<^sub>s y"
  using assms by (auto simp: equi_instances_S_def)

lemma equi_instances_S_E[elim!]:
  assumes "x \<sim>\<^sub>s y"
  obtains "x \<in> \<S>\<^sub>*" "y \<in> \<S>\<^sub>*" "\<And>U w. x \<Colon>\<^sub>s\<^bsub>w\<^esub> U \<longleftrightarrow> y \<Colon>\<^sub>s\<^bsub>w\<^esub> U"
  using assms by (auto simp: equi_instances_S_def)

lemma equi_instances_S[simp]:
  "x \<sim>\<^sub>s y \<longleftrightarrow> x \<in> \<S>\<^sub>* \<and> y \<in> \<S>\<^sub>* \<and> (\<forall>U w. x \<Colon>\<^sub>s\<^bsub>w\<^esub> U \<longleftrightarrow> y \<Colon>\<^sub>s\<^bsub>w\<^esub> U)"
  by (auto simp: equi_instances_S_def)

lemma equi_instances_S_refl: "x \<in> \<S>\<^sub>* \<Longrightarrow> x \<sim>\<^sub>s x" by blast
lemma equi_instances_S_sym[sym]: "x \<sim>\<^sub>s y \<Longrightarrow> y \<sim>\<^sub>s x " by auto
lemma equi_instances_S_trans: "\<lbrakk> x \<sim>\<^sub>s y ; y \<sim>\<^sub>s z \<rbrakk> \<Longrightarrow> x \<sim>\<^sub>s z " by auto

lemmas equi_instances_S_eq_rel_props = equi_instances_S_refl equi_instances_S_sym equi_instances_S_trans

lemma equi_instances_M_I[intro!]:
  assumes "x \<in> \<M>\<^sub>*" "y \<in> \<M>\<^sub>*" "\<And>u. x \<Colon>\<^sub>m\<^sub>\<diamondop> u \<longleftrightarrow> y \<Colon>\<^sub>m\<^sub>\<diamondop> u" "\<beta>\<^sub>* x \<sim>\<^sub>s \<beta>\<^sub>* y"
  shows "x \<sim>\<^sub>m y"
  using assms by (auto simp: equi_instances_M_def)

lemma equi_instances_M_E[elim!]:
  assumes "x \<sim>\<^sub>m y"
  obtains "x \<in> \<M>\<^sub>*" "y \<in> \<M>\<^sub>*" "\<And>u. x \<Colon>\<^sub>m\<^sub>\<diamondop> u \<longleftrightarrow> y \<Colon>\<^sub>m\<^sub>\<diamondop> u" "\<beta>\<^sub>* x \<sim>\<^sub>s \<beta>\<^sub>* y"
  using assms by (auto simp: equi_instances_M_def)

lemma equi_instances_M[simp]:
  "x \<sim>\<^sub>m y \<longleftrightarrow> x \<in> \<M>\<^sub>* \<and> y \<in> \<M>\<^sub>* \<and> (\<forall>u. x \<Colon>\<^sub>m\<^sub>\<diamondop> u \<longleftrightarrow> y \<Colon>\<^sub>m\<^sub>\<diamondop> u) \<and> \<beta>\<^sub>* x \<sim>\<^sub>s \<beta>\<^sub>* y"
  by (simp only: equi_instances_M_def)

lemma equi_instances_M_refl: "x \<in> \<M>\<^sub>* \<Longrightarrow> x \<sim>\<^sub>m x"
  using inheres_in_scope by blast

lemma equi_instances_M_sym[sym]: "x \<sim>\<^sub>m y \<Longrightarrow> y \<sim>\<^sub>m x " by auto
lemma equi_instances_M_trans: "\<lbrakk> x \<sim>\<^sub>m y ; y \<sim>\<^sub>m z \<rbrakk> \<Longrightarrow> x \<sim>\<^sub>m z " by auto

lemmas equi_instances_M_eq_rel_props = equi_instances_M_refl equi_instances_M_sym equi_instances_M_trans

lemma equi_instances_I[intro!]:
  "x \<sim>\<^sub>s y \<or> x \<sim>\<^sub>m y \<Longrightarrow> x \<sim> y"
  by (auto simp: equi_instances_def)

(* UNUSED lemma equi_instances_cases[cases pred]:
  assumes "x \<sim> y"
  obtains (moments) "x \<sim>\<^sub>m y" | (substantials) "x \<sim>\<^sub>s y"
  using assms by (simp only: equi_instances_def ; metis) *)

lemma equi_instances_iff:
  "x \<sim> y \<longleftrightarrow> x \<in> \<S>\<^sub>* \<and> y \<in> \<S>\<^sub>* \<and> x \<sim>\<^sub>s y \<or>
             x \<in> \<M>\<^sub>* \<and> y \<in> \<M>\<^sub>* \<and> x \<sim>\<^sub>m y"
   by (simp only: equi_instances_def equi_instances_M_def equi_instances_S_def
      simp_thms ; intro iffI conjI impI allI ; (elim conjE disjE)? ; simp? ; blast)

lemma equi_instances_simps:
   "x \<in> \<S>\<^sub>* \<Longrightarrow> x \<sim> y \<longleftrightarrow> x \<in> \<S>\<^sub>* \<and> y \<in> \<S>\<^sub>* \<and> x \<sim>\<^sub>s y"
   "x \<in> \<S>\<^sub>* \<Longrightarrow> y \<sim> x \<longleftrightarrow> x \<in> \<S>\<^sub>* \<and> y \<in> \<S>\<^sub>* \<and> y \<sim>\<^sub>s x"
   "x \<in> \<M>\<^sub>* \<Longrightarrow> x \<sim> y \<longleftrightarrow> x \<in> \<M>\<^sub>* \<and> y \<in> \<M>\<^sub>* \<and> x \<sim>\<^sub>m y"
   "x \<in> \<M>\<^sub>* \<Longrightarrow> y \<sim> x \<longleftrightarrow> x \<in> \<M>\<^sub>* \<and> y \<in> \<M>\<^sub>* \<and> y \<sim>\<^sub>m x"
   by (simp only: equi_instances_def equi_instances_M_def equi_instances_S_def
      simp_thms ; intro iffI conjI impI allI ; (elim conjE disjE)? ; simp? ; blast)+

declare equi_instances_def[simp]

lemma equi_instance_equiv_rel_P[simp,intro!]: "closure_rel_P (\<sim>) \<I>\<^sub>*"
  apply (unfold_locales)
  subgoal using equi_instances_M_eq_rel_props equi_instances_S_eq_rel_props equi_instances_iff
    substantials_moments_disj by meson
  subgoal using equi_instances_M_eq_rel_props equi_instances_S_eq_rel_props equi_instances_iff
    substantials_moments_disj by (smt equi_instances_simps(3))
  subgoal using equi_instances_M_eq_rel_props equi_instances_S_eq_rel_props equi_instances_iff
    substantials_moments_disj by blast
  subgoal using equi_instances_M_eq_rel_props equi_instances_S_eq_rel_props equi_instances_iff
    substantials_moments_disj
    by (meson moments_are_individuals substantialsE)
  done

lemma id_on_equi_iof_perms[intro!,simp]: "id \<in> EquiPerms"
  using ClosedPerms_iff equi_instances_def id_on_perm
  using equi_instances_M_refl individuals_moments_substantials by auto

(* UNUSED lemma equi_iof_perms_ne[intro!,simp]: "EquiPerms \<noteq> {}" using id_on_equi_iof_perms by blast *)

end

end


(*  Title:      JinjaThreads/BV/JVM_SemiType.thy
    Author:     Gerwin Klein, Andreas Lochbihler

    Based on the theory Jinja/BV/JVM_SemiType
*)

header {*
  \chapter{Bytecode verifier}
  \isaheader{The JVM Type System as Semilattice}
*}

theory JVM_SemiType
imports
  "../Common/SemiType"
begin

type_synonym ty\<^sub>l = "ty err list"
type_synonym ty\<^sub>s = "ty list"
type_synonym ty\<^sub>i = "ty\<^sub>s \<times> ty\<^sub>l"
type_synonym ty\<^sub>i' = "ty\<^sub>i option"
type_synonym ty\<^sub>m = "ty\<^sub>i' list"
type_synonym ty\<^sub>P = "mname \<Rightarrow> cname \<Rightarrow> ty\<^sub>m"

definition stk_esl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty\<^sub>s esl"
where
  "stk_esl P mxs \<equiv> upto_esl mxs (SemiType.esl P)"

definition loc_sl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty\<^sub>l sl"
where
  "loc_sl P mxl \<equiv> Listn.sl mxl (Err.sl (SemiType.esl P))"

definition sl :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err sl"
where
  "sl P mxs mxl \<equiv>
  Err.sl(Opt.esl(Product.esl (stk_esl P mxs) (Err.esl(loc_sl P mxl))))"

definition "states" :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err set"
where
  "states P mxs mxl \<equiv> fst(sl P mxs mxl)"

definition le :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err ord"
where
  "le P mxs mxl \<equiv> fst(snd(sl P mxs mxl))"

definition sup :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err binop"
where
  "sup P mxs mxl \<equiv> snd(snd(sl P mxs mxl))"

definition sup_ty_opt :: "['c prog,ty err,ty err] \<Rightarrow> bool"
                 ("_ |- _ <=T _" [71,71,71] 70)
where
  "sup_ty_opt P \<equiv> Err.le (widen P)"

definition sup_state :: "['c prog,ty\<^sub>i,ty\<^sub>i] \<Rightarrow> bool"
                 ("_ |- _ <=i _"  [71,71,71] 70)
where
  "sup_state P \<equiv> Product.le (Listn.le (widen P)) (Listn.le (sup_ty_opt P))"

definition sup_state_opt :: "['c prog,ty\<^sub>i',ty\<^sub>i'] \<Rightarrow> bool"
                 ("_ |- _ <=' _"  [71,71,71] 70)
where
  "sup_state_opt P \<equiv> Opt.le (sup_state P)"

abbreviation sup_loc :: "['c prog,ty\<^sub>l,ty\<^sub>l] \<Rightarrow> bool" ("_ |- _ [<=T] _"  [71,71,71] 70)
where "P |- LT [<=T] LT' \<equiv> list_all2 (sup_ty_opt P) LT LT'"

notation (xsymbols)
  sup_ty_opt ("_ \<turnstile> _ \<le>\<^sub>\<top> _" [71,71,71] 70) and
  sup_state ("_ \<turnstile> _ \<le>\<^sub>i _" [71,71,71] 70) and
  sup_state_opt ("_ \<turnstile> _ \<le>' _" [71,71,71] 70) and
  sup_loc ("_ \<turnstile> _ [\<le>\<^sub>\<top>] _"  [71,71,71] 70)

section "Unfolding"

lemma JVM_states_unfold:
  "states P mxs mxl \<equiv> err(opt((Union {list n (types P) |n. n <= mxs}) <*>
                                 list mxl (err(types P))))"
  apply (unfold states_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  apply simp
  done

lemma JVM_le_unfold:
 "le P m n \<equiv>
  Err.le(Opt.le(Product.le(Listn.le(widen P))(Listn.le(Err.le(widen P)))))"
  apply (unfold le_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  apply simp
  done

lemma sl_def2:
  "JVM_SemiType.sl P mxs mxl \<equiv>
  (states P mxs mxl, JVM_SemiType.le P mxs mxl, JVM_SemiType.sup P mxs mxl)"
 by (unfold JVM_SemiType.sup_def states_def JVM_SemiType.le_def) simp

lemma JVM_le_conv:
  "le P m n (OK t1) (OK t2) = P \<turnstile> t1 \<le>' t2"
 by (simp add: JVM_le_unfold Err.le_def lesub_def sup_state_opt_def
                sup_state_def sup_ty_opt_def)

lemma JVM_le_Err_conv:
  "le P m n = Err.le (sup_state_opt P)"
 by (unfold sup_state_opt_def sup_state_def
             sup_ty_opt_def JVM_le_unfold) simp

lemma err_le_unfold [iff]:
  "Err.le r (OK a) (OK b) = r a b"
 by (simp add: Err.le_def lesub_def)

section {* Semilattice *}

lemma order_sup_state_opt [intro, simp]:
  "wf_prog wf_mb P \<Longrightarrow> order (sup_state_opt P)"
 by (unfold sup_state_opt_def sup_state_def sup_ty_opt_def) blast

lemma semilat_JVM [intro?]:
  "wf_prog wf_mb P \<Longrightarrow> semilat (JVM_SemiType.sl P mxs mxl)"
  apply (unfold JVM_SemiType.sl_def stk_esl_def loc_sl_def)
  apply (blast intro: err_semilat_Product_esl err_semilat_upto_esl
                      Listn_sl err_semilat_JType_esl)
  done

lemma acc_JVM [intro]:
  "wf_prog wf_mb P \<Longrightarrow> acc (JVM_SemiType.states P mxs mxl) (JVM_SemiType.le P mxs mxl)"
by(unfold JVM_le_unfold JVM_states_unfold) blast

section {* Widening with @{text "\<top>"} *}

lemma widen_refl[iff]: "widen P t t"  by (simp add: fun_of_def)

lemma sup_ty_opt_refl [iff]: "P \<turnstile> T \<le>\<^sub>\<top> T"
  apply (unfold sup_ty_opt_def)
  apply (fold lesub_def)
  apply (rule le_err_refl)
  apply (simp add: lesub_def)
  done

lemma Err_any_conv [iff]: "P \<turnstile> Err \<le>\<^sub>\<top> T = (T = Err)"
 by (unfold sup_ty_opt_def) (rule Err_le_conv [simplified lesub_def])

lemma any_Err [iff]: "P \<turnstile> T \<le>\<^sub>\<top> Err"
 by (unfold sup_ty_opt_def) (rule le_Err [simplified lesub_def])

lemma OK_OK_conv [iff]:
  "P \<turnstile> OK T \<le>\<^sub>\<top> OK T' = P \<turnstile> T \<le> T'"
 by (simp add: sup_ty_opt_def fun_of_def)

lemma any_OK_conv [iff]:
  "P \<turnstile> X \<le>\<^sub>\<top> OK T' = (\<exists>T. X = OK T \<and> P \<turnstile> T \<le> T')"
  apply (unfold sup_ty_opt_def)
  apply (rule le_OK_conv [simplified lesub_def])
  done

lemma OK_any_conv:
 "P \<turnstile> OK T \<le>\<^sub>\<top> X = (X = Err \<or> (\<exists>T'. X = OK T' \<and> P \<turnstile> T \<le> T'))"
  apply (unfold sup_ty_opt_def)
  apply (rule OK_le_conv [simplified lesub_def])
  done

lemma sup_ty_opt_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>\<^sub>\<top> b; P \<turnstile> b \<le>\<^sub>\<top> c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>\<^sub>\<top> c"
 by (auto intro: widen_trans
           simp add: sup_ty_opt_def Err.le_def lesub_def fun_of_def
           split: err.splits)

section "Stack and Registers"

lemma stk_convert:
  "P \<turnstile> ST [\<le>] ST' = Listn.le (widen P) ST ST'"
 by (simp add: Listn.le_def lesub_def)

lemma sup_loc_refl [iff]: "P \<turnstile> LT [\<le>\<^sub>\<top>] LT"
 by (rule list_all2_refl) simp

lemmas sup_loc_Cons1 [iff] = list_all2_Cons1 [of "sup_ty_opt P"] for P

lemma sup_loc_def:
  "P \<turnstile> LT [\<le>\<^sub>\<top>] LT' \<equiv> Listn.le (sup_ty_opt P) LT LT'"
 by (simp add: Listn.le_def lesub_def)

lemma sup_loc_widens_conv [iff]:
  "P \<turnstile> map OK Ts [\<le>\<^sub>\<top>] map OK Ts' = P \<turnstile> Ts [\<le>] Ts'"
  by (simp add: list_all2_map1 list_all2_map2)

lemma sup_loc_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a [\<le>\<^sub>\<top>] b; P \<turnstile> b [\<le>\<^sub>\<top>] c\<rbrakk> \<Longrightarrow> P \<turnstile> a [\<le>\<^sub>\<top>] c"
 by (rule list_all2_trans, rule sup_ty_opt_trans)

section "State Type"

lemma sup_state_conv [iff]:
  "P \<turnstile> (ST,LT) \<le>\<^sub>i (ST',LT') = (P \<turnstile> ST [\<le>] ST' \<and> P \<turnstile> LT [\<le>\<^sub>\<top>] LT')"
 by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_def)

lemma sup_state_conv2:
  "P \<turnstile> s1 \<le>\<^sub>i s2 = (P \<turnstile> fst s1 [\<le>] fst s2 \<and> P \<turnstile> snd s1 [\<le>\<^sub>\<top>] snd s2)"
 by (cases s1, cases s2) simp

lemma sup_state_refl [iff]: "P \<turnstile> s \<le>\<^sub>i s"
by (auto simp add: sup_state_conv2 intro: list_all2_refl)

lemma sup_state_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>\<^sub>i b; P \<turnstile> b \<le>\<^sub>i c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>\<^sub>i c"
 by (auto intro: sup_loc_trans widens_trans simp add: sup_state_conv2)

lemma sup_state_opt_None_any [iff]:
  "P \<turnstile> None \<le>' s"
 by (simp add: sup_state_opt_def Opt.le_def)

lemma sup_state_opt_any_None [iff]:
  "P \<turnstile> s \<le>' None = (s = None)"
 by (simp add: sup_state_opt_def Opt.le_def)

lemma sup_state_opt_Some_Some [iff]:
  "P \<turnstile> Some a \<le>' Some b = P \<turnstile> a \<le>\<^sub>i b"
 by (simp add: sup_state_opt_def Opt.le_def lesub_def)

lemma sup_state_opt_any_Some:
  "P \<turnstile> (Some s) \<le>' X = (\<exists>s'. X = Some s' \<and> P \<turnstile> s \<le>\<^sub>i s')"
 by (simp add: sup_state_opt_def Opt.le_def lesub_def)

lemma sup_state_opt_refl [iff]: "P \<turnstile> s \<le>' s"
 by (simp add: sup_state_opt_def Opt.le_def lesub_def)

lemma sup_state_opt_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>' b; P \<turnstile> b \<le>' c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>' c"
  apply (unfold sup_state_opt_def Opt.le_def lesub_def)
  apply (simp del: split_paired_All)
  apply (rule sup_state_trans, assumption+)
  done

end


(*
 * Copyright 2018, Data61, CSIRO
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

theory More_Numeral_Type
  imports "Word_Lib.WordSetup"
begin

(* This theory provides additional setup for numeral types, which should probably go into
   Numeral_Type in the distribution at some point. *)

text \<open>
  The function package uses @{const size} for guessing termination measures.
  Using @{const size} also provides a convenient cast to natural numbers.
\<close>

instantiation num1 :: size
begin
  definition size_num1 where [simp, code]: "size (n::num1) = 0"
  instance ..
end

instantiation bit0 and bit1 :: (finite) size
begin
  definition size_bit0 where [code]: "size n = nat (Rep_bit0 n)"
  definition size_bit1 where [code]: "size n = nat (Rep_bit1 n)"
  instance ..
end

(* As in the parent theory Numeral_Type, we first prove everything abstractly to avoid duplication,
   and then instantiate bit0 and bit1. *)
locale mod_size_order = mod_ring n Rep Abs
  for n :: int
  and Rep :: "'a::{comm_ring_1,size,linorder} \<Rightarrow> int"
  and Abs :: "int \<Rightarrow> 'a::{comm_ring_1,size,linorder}" +
  assumes size_def: "size x = nat (Rep x)"
  assumes less_def: "(a < b) = (Rep a < Rep b)"
  assumes less_eq_def: "(a \<le> b) = (Rep a \<le> Rep b)"
begin

text \<open>
  Automatic simplification of concrete @{term "(<)"} and @{term "(<=)"} goals on numeral types.
\<close>
lemmas order_numeral[simp] =
  less_def[of "numeral a" "numeral b" for a b]
  less_eq_def[of "numeral a" "numeral b" for a b]
  less_def[of "0" "numeral b" for b]
  less_def[of "1" "numeral b" for b]
  less_eq_def[of "0" "numeral b" for b]
  less_eq_def[of "1" "numeral b" for b]
  less_def[of "numeral a" "0" for a]
  less_def[of "numeral a" "1" for a]
  less_eq_def[of "numeral a" "0" for a]
  less_eq_def[of "numeral a" "1" for a]

text \<open> Simplifying size numerals. \<close>
lemmas [simp] = Rep_numeral
lemmas size_numerals[simp] = size_def[of "numeral m" for m]

text \<open> Simplifying representatives of 0 and 1 \<close>
lemmas [simp] = Rep_0 Rep_1

lemmas definitions = definitions less_def less_eq_def size_def

lemmas Rep = type_definition.Rep[OF type]
lemmas Abs_cases = type_definition.Abs_cases[OF type]

lemma of_nat_size[simp]:
  "of_nat (size x) = (x::'a)"
  by (cases x rule: Abs_cases) (clarsimp simp: Abs_inverse of_int_eq size_def)

lemma size_of_nat[simp]:
  "size (of_nat x :: 'a) = x mod n"
  by (simp add: Rep_Abs_mod of_nat_eq size0 size_def)

lemma zero_less_eq[simp]:
  "0 \<le> (x :: 'a)"
  using Rep by (simp add: less_eq_def)

lemma zero_less_one[simp,intro!]:
  "0 < (1::'a)"
  by (simp add: less_def)

lemma zero_least[simp,intro]:
  "(x::'a) < y \<Longrightarrow> 0 < y"
  by (simp add: le_less_trans)

lemma not_less_zero_bit0[simp]:
  "\<not> (x::'a) < 0"
  by (simp add: not_less)

lemmas not_less_zeroE[elim!] = notE[OF not_less_zero]

lemma one_leq[simp]:
  "(1 \<le> x) = (0 < (x::'a))"
  using less_def less_eq_def by auto

lemma less_eq_0[simp]:
  "(x \<le> 0) = (x = (0::'a))"
  by (simp add: antisym)

lemma size_less[simp]:
  "(size (x::'a) < size y) = (x < y)"
  by (cases x rule: Abs_cases, cases y rule: Abs_cases) (auto simp: Abs_inverse definitions)

lemma size_inj[simp]:
  "(size (x::'a) = size y) = (x = y)"
  by (metis of_nat_size)

lemma size_less_eq[simp]:
  "(size (x::'a) \<le> size y) = (x \<le> y)"
  by (auto simp: le_eq_less_or_eq)

lemma size_0[simp]:
  "size (0::'a) = 0"
  by (simp add: size_def)

lemma size_1[simp]:
  "size (1::'a) = 1"
  by (simp add: size_def)

lemma size_eq_0[simp]:
  "(size x = 0) = ((x::'a) = 0)"
  using size_inj by fastforce

lemma minus_less:
  "\<lbrakk> y \<le> x; 0 < y \<rbrakk> \<Longrightarrow> x - y < (x::'a)"
  unfolding definitions
  by (cases x rule: Abs_cases, cases y rule: Abs_cases) (simp add: Abs_inverse)

lemma pred[simp,intro!]:
  "0 < (x::'a) \<Longrightarrow> x - 1 < x"
  by (auto intro!: minus_less)

lemma minus1_leq:
  "\<lbrakk> x - 1 \<le> y; y < x \<rbrakk> \<Longrightarrow> (y::'a) = x-1"
  by (smt Rep_1 Rep_Abs_mod Rep_less_n less_def diff_def int_mod_ge le_neq_trans)

lemma max_bound_leq[simp,intro!]:
  "(x::'a) \<le> -1"
  by (smt Rep_1 Rep_Abs_mod Rep_less_n less_eq_def int_mod_ge' minus_def)

lemma leq_minus1_less:
  "0 < y \<Longrightarrow> (x \<le> y - 1) = (x < (y::'a))"
  by (metis le_less less_trans minus1_leq not_less pred)

lemma max_bound_neq_conv[simp]:
  "(x \<noteq> -1) = ((x::'a) < -1)"
  using le_neq_trans by auto

lemma max_bound_leq_conv[simp]:
  "(- 1 \<le> (x::'a)) = (x = - 1)"
  by (simp add: eq_iff)

lemma max_bound_not_less[simp]:
  "\<not> -1 < (x::'a)"
  using minus1_leq by fastforce

lemma minus_1_eq:
  "(-1::'a) = of_nat (nat n - 1)"
  unfolding definitions using Rep_Abs_1 of_nat_eq size1 by auto

lemma n_not_less_Rep[simp]:
  "\<not> n < Rep x"
  using Rep[of x] by (simp add: not_less)

lemma size_plus:
  "(x::'a) < x + y \<Longrightarrow> size (x + y) = size x + size y"
  unfolding definitions Rep_Abs_mod
  using Rep size0
  by (simp flip: nat_add_distrib add: eq_nat_nat_iff pos_mod_sign mod_add_if_z split: if_split_asm)

lemma Suc_size[simp]:
  "(x::'a) < x + 1 \<Longrightarrow> size (x + 1) = Suc (size x)"
  by (simp add: size_plus)

lemma no_overflow_eq_max_bound:
  "((x::'a) < x + 1) = (x < -1)"
  unfolding definitions
  by (smt Rep_Abs_mod Rep_Abs_1 Rep_less_n int_mod_ge int_mod_ge' size0)

lemma plus_one_leq:
  "x < y \<Longrightarrow> x + 1 \<le> (y::'a)"
  by (metis add_diff_cancel_right' leq_minus1_less not_le zero_least)

lemma less_uminus:
  "\<lbrakk> - x < y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> - y < (x::'a)"
  unfolding definitions
  by (smt Rep_inverse Rep_mod Rep_Abs_mod size0 zmod_zminus1_eq_if)

lemma of_nat_cases[case_names of_nat]:
  "(\<And>m. \<lbrakk> (x::'a) = of_nat m; m < nat n \<rbrakk> \<Longrightarrow> P) \<Longrightarrow> P"
  by (metis mod_type.Rep_less_n mod_type_axioms nat_mono_iff of_nat_size size0 size_def)

lemma minus_induct[case_names 0 minus]:
  assumes "P (0::'a)"
  assumes suc: "\<And>x. \<lbrakk> P (x - 1); 0 < x \<rbrakk> \<Longrightarrow> P x"
  shows "P x"
proof (cases x rule: of_nat_cases)
  case (of_nat m)
  have "P (of_nat m)"
  proof (induct m)
    case 0
    then show ?case using `P 0` by simp
  next
    case (Suc m)
    show ?case
    proof (cases "1 + of_nat m = (0::'a)")
      case True
      then show ?thesis using `P 0` by simp
    next
      case False
      with Suc suc show ?thesis by (metis add_diff_cancel_left' less_eq_0 not_less of_nat_Suc)
    qed
  qed
  with of_nat show ?thesis by simp
qed

lemma plus_induct[case_names 0 plus]:
  assumes "P (0::'a)"
  assumes suc: "\<And>x. \<lbrakk> P x; x < x + 1 \<rbrakk> \<Longrightarrow> P (x + 1)"
  shows "P x"
proof (cases x rule: of_nat_cases)
  case (of_nat m)
  have "P (of_nat m)"
  proof (induct m)
    case 0
    then show ?case using `P 0` by simp
  next
    case (Suc m)
    with `P 0` suc show ?case by (metis diff_add_cancel minus_induct pred)
  qed
  with of_nat show ?thesis by simp
qed

lemma from_top_induct[case_names top step]:
  assumes top: "\<And>x. y \<le> x \<Longrightarrow> P (x::'a)"
  assumes step: "\<And>x. \<lbrakk>P x; 0 < x; x \<le> y\<rbrakk> \<Longrightarrow> P (x - 1)"
  shows "P x"
proof -
  obtain z where x: "x = y - z"
    by (metis diff_eq_diff_eq diff_right_commute)
  moreover
  have "P (y - z)"
  proof (induct z rule: plus_induct)
    case 0
    then show ?case by (simp add: top)
  next
    case (plus x)
    then have [simp]: "y - (x + 1) = (y - x) - 1" by simp
    show ?case
    proof (cases "x < y")
      case True
      with plus show ?thesis
       by simp (metis diff_add_cancel eq_iff_diff_eq_0 le_neq_trans step plus_one_leq not_le
                      top zero_less_eq)
    next
      case False
      with plus show ?thesis
       by (smt top Rep_Abs_mod Rep_le_n less_def less_eq_def diff_def int_mod_ge' size0)
    qed
  qed
  ultimately show ?thesis by simp
qed

lemma tranclp_greater: "(>)\<^sup>+\<^sup>+ = ((>) :: 'a \<Rightarrow> 'a \<Rightarrow> bool)"
  by(auto simp add: fun_eq_iff intro: less_trans elim: tranclp.induct)

lemma card_n:
  "CARD('a) = nat n"
  using type by (simp add: type_definition.card)

lemma finite_UNIV[intro!,simp]:
  "finite (UNIV::'a set)"
  by (rule card_ge_0_finite) (simp add: card_n size0)

lemma finite_greater[simp]:
  "finite {(x, y). y < (x::'a)}"
  by (rule finite_subset[of _ "UNIV \<times> UNIV"], simp)
     (rule finite_cartesian_product; rule finite_UNIV)

lemma wf_greater[intro!,simp]:
  "wf {(x,y). x > (y::'a)}"
  by (auto simp: trancl_def tranclp_greater intro!: finite_acyclic_wf acyclicI)

(* less_induct already instantiated in class well_order *)
lemma greater_induct[case_names greater]:
  "(\<And>x. (\<And>z. x < z \<Longrightarrow> P z) \<Longrightarrow> P x) \<Longrightarrow> P (x::'a)"
  by (rule wf_induct_rule, rule wf_greater) fastforce

lemma from_top_full_induct[case_names top step]:
  assumes top: "\<And>x. y \<le> x \<Longrightarrow> P (x::'a)"
  assumes step: "\<And>x. \<lbrakk>\<forall>z > x. P z; x < y\<rbrakk> \<Longrightarrow> P x"
  shows "P x"
proof (induct x rule: greater_induct)
  case (greater x)
  show ?case
  proof (cases "x < y")
    case True
    then show ?thesis by (blast intro: step greater)
  next
    case False
    then show ?thesis by (auto simp: not_less intro: top)
  qed
qed

interpretation greater_wellorder: wellorder "(\<ge>) :: 'a \<Rightarrow> 'a \<Rightarrow> bool" "(>) :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
  by unfold_locales (auto intro: greater_induct)

lemma greater_least_fold[simp]: "greater_wellorder.Least = Greatest"
  by (auto simp: greater_wellorder.Least_def Greatest_def)

lemmas GreatestI = greater_wellorder.LeastI[simplified greater_least_fold]
lemmas Greatest_le = greater_wellorder.Least_le[simplified greater_least_fold]
lemmas exists_greatest_iff = greater_wellorder.exists_least_iff
lemmas GreatestI2_wellorder = greater_wellorder.LeastI2_wellorder[simplified greater_least_fold]

lemma neq_0_conv:
  "((x::'a) \<noteq> 0) = (0 < x)"
  by (meson neqE not_less_zero_bit0)

lemma minus_leq_less: "\<lbrakk> (x::'a) \<le> y; 0 < z; z \<le> x \<rbrakk> \<Longrightarrow> x - z < y"
  by (metis le_less less_trans minus_less)

lemma minus_one_leq_less: "\<lbrakk> (x::'a) \<le> y; 0 < x \<rbrakk> \<Longrightarrow> x - 1 < y"
  using pred by fastforce

end

interpretation bit0:
  mod_size_order "int CARD('a::finite bit0)"
                 "Rep_bit0 :: 'a::finite bit0 \<Rightarrow> int"
                 "Abs_bit0 :: int \<Rightarrow> 'a::finite bit0"
  by unfold_locales (auto simp: size_bit0_def less_bit0_def less_eq_bit0_def)

interpretation bit1:
  mod_size_order "int CARD('a::finite bit1)"
                 "Rep_bit1 :: 'a::finite bit1 \<Rightarrow> int"
                 "Abs_bit1 :: int \<Rightarrow> 'a::finite bit1"
  by unfold_locales (auto simp: size_bit1_def less_bit1_def less_eq_bit1_def)

declare bit0.minus_induct[induct type]
declare bit1.minus_induct[induct type]

section \<open>Further enumeration instances.\<close>

instantiation bit0 and bit1 :: (finite) enumeration_both
begin

definition enum_alt_bit0 where "enum_alt \<equiv> alt_from_ord (enum :: 'a :: finite bit0 list)"
definition enum_alt_bit1  where "enum_alt \<equiv> alt_from_ord (enum :: 'a :: finite bit1 list)"

instance by intro_classes (auto simp: enum_alt_bit0_def enum_alt_bit1_def)

end

subsection \<open>Relating @{const enum} and @{const size}\<close>

lemma fromEnum_size_bit0[simp]:
  "fromEnum (x::'a::finite bit0) = size x"
proof -
  have "enum ! the_index enum x = x" by (auto intro: nth_the_index)
  moreover
  have "the_index enum x < length (enum::'a bit0 list)" by (auto intro: the_index_bounded)
  moreover
  { fix y
    assume "Abs_bit0' (int y) = x"
    moreover
    assume "y < 2 * CARD('a)"
    ultimately
    have "y = nat (Rep_bit0 x)"
      by (smt Abs_bit0'_code card_bit0 mod_pos_pos_trivial nat_int of_nat_less_0_iff
              zless_nat_eq_int_zless)
  }
  ultimately
  show ?thesis by (simp  add: fromEnum_def enum_bit0_def size_bit0_def)
qed

lemma fromEnum_size_bitq[simp]:
  "fromEnum (x::'a::finite bit1) = size x"
proof -
  have "enum ! the_index enum x = x" by (auto intro: nth_the_index)
  moreover
  have "the_index enum x < length (enum::'a bit1 list)" by (auto intro: the_index_bounded)
  moreover
  { fix y
    assume "Abs_bit1' (int y) = x"
    moreover
    assume "y < Suc (2 * CARD('a))"
    ultimately
    have "y = nat (Rep_bit1 x)"
      by (smt Abs_bit1'_code card_bit1 mod_pos_pos_trivial nat_int of_nat_less_0_iff
              zless_nat_eq_int_zless)
  }
  ultimately
  show ?thesis by (simp add: fromEnum_def enum_bit1_def size_bit1_def del: upt_Suc)
qed

lemma minBound_size_bit0[simp]:
  "(minBound::'a::finite bit0) = 0"
  by (simp add: minBound_def hd_map enum_bit0_def Abs_bit0'_def zero_bit0_def)

lemma minBound_size_bit1[simp]:
  "(minBound::'a::finite bit1) = 0"
  by (simp add: minBound_def hd_map enum_bit1_def Abs_bit1'_def zero_bit1_def)

lemma maxBound_size_bit0:
  "(maxBound::'a::finite bit0) = of_nat (2 * CARD('a) - 1)"
  by (simp add: maxBound_def enum_bit0_def last_map Abs_bit0'_def bit0.of_nat_eq)

lemma maxBound_size_bit1:
  "(maxBound::'a::finite bit1) = of_nat (2 * CARD('a))"
  by (simp add: maxBound_def enum_bit1_def last_map Abs_bit1'_def bit1.of_nat_eq)

lemma maxBound_minus_one_bit0:
  "maxBound = (-1 ::'a::finite bit0)"
  by (simp add: bit0.definitions bit0.of_nat_eq bit0.Rep_Abs_1 maxBound_size_bit0)

lemma maxBound_minus_one_bit1:
  "maxBound = (-1 ::'a::finite bit1)"
  by (simp add: bit1.definitions bit1.of_nat_eq bit1.Rep_Abs_1 zmod_minus1 maxBound_size_bit1)

lemmas maxBound_size_bit = maxBound_size_bit0 maxBound_size_bit1
lemmas maxBound_minus_one_bit[simp] = maxBound_minus_one_bit1 maxBound_minus_one_bit0

end


theory Force imports Main begin
  (*Use Divides rather than Main to experiment with the first proof.
    Otherwise, it is done by the nat_divide_cancel_factor simprocs.*)

declare div_mult_self_is_m [simp del]

lemma div_mult_self_is_m:
      "0<n \<Longrightarrow> (m*n) div n = (m::nat)"
apply (insert mod_div_equality [of "m*n" n])
apply simp
done

lemma "(\<forall>x. P x) \<and> (\<exists>x. Q x) \<longrightarrow> (\<forall>x. P x \<and> Q x)"
apply clarify
oops

text {*
proof\ {\isacharparenleft}prove{\isacharparenright}{\isacharcolon}\ step\ {\isadigit{1}}\isanewline
\isanewline
goal\ {\isacharparenleft}lemma{\isacharparenright}{\isacharcolon}\isanewline
{\isacharparenleft}{\isasymforall}x{\isachardot}\ P\ x{\isacharparenright}\ {\isasymand}\ {\isacharparenleft}{\isasymexists}x{\isachardot}\ Q\ x{\isacharparenright}\ {\isasymlongrightarrow}\ {\isacharparenleft}{\isasymforall}x{\isachardot}\ P\ x\ {\isasymand}\ Q\ x{\isacharparenright}\isanewline
\ {\isadigit{1}}{\isachardot}\ {\isasymAnd}x\ xa{\isachardot}\ {\isasymlbrakk}{\isasymforall}x{\isachardot}\ P\ x{\isacharsemicolon}\ Q\ xa{\isasymrbrakk}\ {\isasymLongrightarrow}\ P\ x\ {\isasymand}\ Q\ x
*}

text {*
couldn't find a good example of clarsimp

@{thm[display]"someI"}
\rulename{someI}
*}

lemma "\<lbrakk>Q a; P a\<rbrakk> \<Longrightarrow> P (SOME x. P x \<and> Q x) \<and> Q (SOME x. P x \<and> Q x)"
apply (rule someI)
oops

lemma "\<lbrakk>Q a; P a\<rbrakk> \<Longrightarrow> P (SOME x. P x \<and> Q x) \<and> Q (SOME x. P x \<and> Q x)"
apply (fast intro!: someI)
done

text{*
proof\ {\isacharparenleft}prove{\isacharparenright}{\isacharcolon}\ step\ \isadigit{1}\isanewline
\isanewline
goal\ {\isacharparenleft}lemma{\isacharparenright}{\isacharcolon}\isanewline
{\isasymlbrakk}Q\ a{\isacharsemicolon}\ P\ a{\isasymrbrakk}\ {\isasymLongrightarrow}\ P\ {\isacharparenleft}SOME\ x{\isachardot}\ P\ x\ {\isasymand}\ Q\ x{\isacharparenright}\ {\isasymand}\ Q\ {\isacharparenleft}SOME\ x{\isachardot}\ P\ x\ {\isasymand}\ Q\ x{\isacharparenright}\isanewline
\ \isadigit{1}{\isachardot}\ {\isasymlbrakk}Q\ a{\isacharsemicolon}\ P\ a{\isasymrbrakk}\ {\isasymLongrightarrow}\ P\ {\isacharquery}x\ {\isasymand}\ Q\ {\isacharquery}x
*}

end


section \<open>WebAssembly Base Definitions\<close>

theory Wasm_Base_Defs imports Wasm_Ast Wasm_Type_Abs begin

instantiation i32 :: wasm_int begin instance .. end
instantiation i64 :: wasm_int begin instance .. end
instantiation f32 :: wasm_float begin instance .. end
instantiation f64 :: wasm_float begin instance .. end

consts
  (* inter-type conversions *)
  (* float to i32 *)
  ui32_trunc_f32 :: "f32 \<Rightarrow> i32 option"
  si32_trunc_f32 :: "f32 \<Rightarrow> i32 option"
  ui32_trunc_f64 :: "f64 \<Rightarrow> i32 option"
  si32_trunc_f64 :: "f64 \<Rightarrow> i32 option"
  (* float to i64 *)
  ui64_trunc_f32 :: "f32 \<Rightarrow> i64 option"
  si64_trunc_f32 :: "f32 \<Rightarrow> i64 option"
  ui64_trunc_f64 :: "f64 \<Rightarrow> i64 option"
  si64_trunc_f64 :: "f64 \<Rightarrow> i64 option"
  (* int to f32 *)
  f32_convert_ui32 :: "i32 \<Rightarrow> f32"
  f32_convert_si32 :: "i32 \<Rightarrow> f32"
  f32_convert_ui64 :: "i64 \<Rightarrow> f32"
  f32_convert_si64 :: "i64 \<Rightarrow> f32"
  (* int to f64 *)
  f64_convert_ui32 :: "i32 \<Rightarrow> f64"
  f64_convert_si32 :: "i32 \<Rightarrow> f64"
  f64_convert_ui64 :: "i64 \<Rightarrow> f64"
  f64_convert_si64 :: "i64 \<Rightarrow> f64"
  (* intra-{int/float} conversions *)
  wasm_wrap :: "i64 \<Rightarrow> i32"
  wasm_extend_u :: "i32 \<Rightarrow> i64"
  wasm_extend_s :: "i32 \<Rightarrow> i64"
  wasm_demote :: "f64 \<Rightarrow> f32"
  wasm_promote :: "f32 \<Rightarrow> f64"
  (* boolean encoding *)
  serialise_i32 :: "i32 \<Rightarrow> bytes"
  serialise_i64 :: "i64 \<Rightarrow> bytes"
  serialise_f32 :: "f32 \<Rightarrow> bytes"
  serialise_f64 :: "f64 \<Rightarrow> bytes"
  wasm_bool :: "bool \<Rightarrow> i32"
  int32_minus_one :: i32

  (* memory *)
definition mem_size :: "mem \<Rightarrow> nat" where
  "mem_size m = length (Rep_mem m)"

definition mem_grow :: "mem \<Rightarrow> nat \<Rightarrow> mem" where
  "mem_grow m n = mem_append m (bytes_replicate (n * 64000) 0)"

definition load :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> nat \<Rightarrow> bytes option" where
  "load m n off l = (if (mem_size m \<ge> (n+off+l))
                       then Some (read_bytes m (n+off) l)
                       else None)"

definition sign_extend :: "sx \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> bytes" where
  "sign_extend sx l bytes = (let msb = msb (msbyte bytes) in
                          let byte = (case sx of U \<Rightarrow> 0 | S \<Rightarrow> if msb then -1 else 0) in
                          bytes_takefill byte l bytes)"

definition load_packed :: "sx \<Rightarrow> mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bytes option" where
  "load_packed sx m n off lp l = map_option (sign_extend sx l) (load m n off lp)"

definition store :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> bytes \<Rightarrow> nat \<Rightarrow> mem option" where
  "store m n off bs l = (if (mem_size m \<ge> (n+off+l))
                          then Some (write_bytes m (n+off) (bytes_takefill 0 l bs))
                          else None)"

definition store_packed :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> bytes \<Rightarrow> nat \<Rightarrow> mem option" where
  "store_packed = store"

consts
  wasm_deserialise :: "bytes \<Rightarrow> t \<Rightarrow> v"
  (* host *)
  host_apply :: "s \<Rightarrow> tf \<Rightarrow> host \<Rightarrow> v list \<Rightarrow> host_state \<Rightarrow> (s \<times> v list) option"

definition typeof :: " v \<Rightarrow> t" where
  "typeof v = (case v of
                 ConstInt32 _ \<Rightarrow> T_i32
               | ConstInt64 _ \<Rightarrow> T_i64
               | ConstFloat32 _ \<Rightarrow> T_f32
               | ConstFloat64 _ \<Rightarrow> T_f64)"

definition option_projl :: "('a \<times> 'b) option \<Rightarrow> 'a option" where
  "option_projl x = map_option fst x"

definition option_projr :: "('a \<times> 'b) option \<Rightarrow> 'b option" where
  "option_projr x = map_option snd x"

definition t_length :: "t \<Rightarrow> nat" where
 "t_length t = (case t of
                  T_i32 \<Rightarrow> 4
                | T_i64 \<Rightarrow> 8
                | T_f32 \<Rightarrow> 4
                | T_f64 \<Rightarrow> 8)"

definition tp_length :: "tp \<Rightarrow> nat" where
 "tp_length tp = (case tp of
                 Tp_i8 \<Rightarrow> 1
               | Tp_i16 \<Rightarrow> 2
               | Tp_i32 \<Rightarrow> 4)"

definition is_int_t :: "t \<Rightarrow> bool" where
 "is_int_t t = (case t of
                  T_i32 \<Rightarrow> True
                | T_i64 \<Rightarrow> True
                | T_f32 \<Rightarrow> False
                | T_f64 \<Rightarrow> False)"

definition is_float_t :: "t \<Rightarrow> bool" where
 "is_float_t t = (case t of
                    T_i32 \<Rightarrow> False
                  | T_i64 \<Rightarrow> False
                  | T_f32 \<Rightarrow> True
                  | T_f64 \<Rightarrow> True)"

definition is_mut :: "tg \<Rightarrow> bool" where
  "is_mut tg = (tg_mut tg = T_mut)"

definition app_unop_i :: "unop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int" where
  "app_unop_i iop c =
     (case iop of
     Ctz \<Rightarrow> int_ctz c
   | Clz \<Rightarrow> int_clz c
   | Popcnt \<Rightarrow> int_popcnt c)"

definition app_unop_f :: "unop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float" where
  "app_unop_f fop c =
                 (case fop of
                    Neg \<Rightarrow> float_neg c
                  | Abs \<Rightarrow> float_abs c
                  | Ceil \<Rightarrow> float_ceil c
                  | Floor \<Rightarrow> float_floor c
                  | Trunc \<Rightarrow> float_trunc c
                  | Nearest \<Rightarrow> float_nearest c
                  | Sqrt \<Rightarrow> float_sqrt c)"

definition app_binop_i :: "binop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int \<Rightarrow> ('i::wasm_int) option" where
  "app_binop_i iop c1 c2 = (case iop of
                              Add \<Rightarrow> Some (int_add c1 c2)
                            | Sub \<Rightarrow> Some (int_sub c1 c2)
                            | Mul \<Rightarrow> Some (int_mul c1 c2)
                            | Div U \<Rightarrow> int_div_u c1 c2
                            | Div S \<Rightarrow> int_div_s c1 c2
                            | Rem U \<Rightarrow> int_rem_u c1 c2
                            | Rem S \<Rightarrow> int_rem_s c1 c2
                            | And \<Rightarrow> Some (int_and c1 c2)
                            | Or \<Rightarrow> Some (int_or c1 c2)
                            | Xor \<Rightarrow> Some (int_xor c1 c2)
                            | Shl \<Rightarrow> Some (int_shl c1 c2)
                            | Shr U \<Rightarrow> Some (int_shr_u c1 c2)
                            | Shr S \<Rightarrow> Some (int_shr_s c1 c2)
                            | Rotl \<Rightarrow> Some (int_rotl c1 c2)
                            | Rotr \<Rightarrow> Some (int_rotr c1 c2))"

definition app_binop_f :: "binop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float \<Rightarrow> ('f::wasm_float) option" where
  "app_binop_f fop c1 c2 = (case fop of
                              Addf \<Rightarrow> Some (float_add c1 c2)
                            | Subf \<Rightarrow> Some (float_sub c1 c2)
                            | Mulf \<Rightarrow> Some (float_mul c1 c2)
                            | Divf \<Rightarrow> Some (float_div c1 c2)
                            | Min \<Rightarrow> Some (float_min c1 c2)
                            | Max \<Rightarrow> Some (float_max c1 c2)
                            | Copysign \<Rightarrow> Some (float_copysign c1 c2))"

definition app_testop_i :: "testop \<Rightarrow> 'i::wasm_int \<Rightarrow> bool" where
  "app_testop_i testop c = (case testop of Eqz \<Rightarrow> int_eqz c)"

definition app_relop_i :: "relop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int \<Rightarrow> bool" where
  "app_relop_i rop c1 c2 = (case rop of
                              Eq \<Rightarrow> int_eq c1 c2
                            | Ne \<Rightarrow> int_ne c1 c2
                            | Lt U \<Rightarrow> int_lt_u c1 c2
                            | Lt S \<Rightarrow> int_lt_s c1 c2
                            | Gt U \<Rightarrow> int_gt_u c1 c2
                            | Gt S \<Rightarrow> int_gt_s c1 c2
                            | Le U \<Rightarrow> int_le_u c1 c2
                            | Le S \<Rightarrow> int_le_s c1 c2
                            | Ge U \<Rightarrow> int_ge_u c1 c2
                            | Ge S \<Rightarrow> int_ge_s c1 c2)"

definition app_relop_f :: "relop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float \<Rightarrow> bool" where
  "app_relop_f rop c1 c2 = (case rop of
                              Eqf \<Rightarrow> float_eq c1 c2
                            | Nef \<Rightarrow> float_ne c1 c2
                            | Ltf \<Rightarrow> float_lt c1 c2
                            | Gtf \<Rightarrow> float_gt c1 c2
                            | Lef \<Rightarrow> float_le c1 c2
                            | Gef \<Rightarrow> float_ge c1 c2)"

definition types_agree :: "t \<Rightarrow> v \<Rightarrow> bool" where
  "types_agree t v = (typeof v = t)"

definition cl_type :: "cl \<Rightarrow> tf" where
  "cl_type cl = (case cl of Func_native _ tf _ _ \<Rightarrow> tf | Func_host tf _ \<Rightarrow> tf)"

definition rglob_is_mut :: "global \<Rightarrow> bool" where
  "rglob_is_mut g = (g_mut g = T_mut)"

definition stypes :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tf" where
  "stypes s i j = ((types ((inst s)!i))!j)"

definition sfunc_ind :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "sfunc_ind s i j = ((inst.funcs ((inst s)!i))!j)"

definition sfunc :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> cl" where
  "sfunc s i j = (funcs s)!(sfunc_ind s i j)"

definition sglob_ind :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "sglob_ind s i j = ((inst.globs ((inst s)!i))!j)"

definition sglob :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> global" where
  "sglob s i j = (globs s)!(sglob_ind s i j)"

definition sglob_val :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> v" where
  "sglob_val s i j = g_val (sglob s i j)"

definition smem_ind :: "s \<Rightarrow> nat \<Rightarrow> nat option" where
  "smem_ind s i = (inst.mem ((inst s)!i))"

definition stab_s :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> cl option" where
  "stab_s s i j = (let stabinst = ((tab s)!i) in  (if (length (stabinst) > j) then (stabinst!j) else None))"

definition stab :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> cl option" where
  "stab s i j = (case (inst.tab ((inst s)!i)) of Some k => stab_s s k j | None => None)"

definition supdate_glob_s :: "s \<Rightarrow> nat \<Rightarrow> v \<Rightarrow> s" where
  "supdate_glob_s s k v = s\<lparr>globs := (globs s)[k:=((globs s)!k)\<lparr>g_val := v\<rparr>]\<rparr>"

definition supdate_glob :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> v \<Rightarrow> s" where
  "supdate_glob s i j v = (let k = sglob_ind s i j in supdate_glob_s s k v)"

definition is_const :: "e \<Rightarrow> bool" where
  "is_const e = (case e of Basic (C _) \<Rightarrow> True | _ \<Rightarrow> False)"

definition const_list :: "e list \<Rightarrow> bool" where
  "const_list xs = list_all is_const xs"

inductive store_extension :: "s \<Rightarrow> s \<Rightarrow> bool" where
"\<lbrakk>insts = insts'; fs = fs'; tclss = tclss'; list_all2 (\<lambda>bs bs'. mem_size bs \<le> mem_size bs') bss bss'; gs = gs'\<rbrakk> \<Longrightarrow>
  store_extension \<lparr>s.inst = insts, s.funcs = fs, s.tab = tclss, s.mem = bss, s.globs = gs\<rparr>
                    \<lparr>s.inst = insts', s.funcs = fs', s.tab = tclss', s.mem = bss', s.globs = gs'\<rparr>"

abbreviation to_e_list :: "b_e list \<Rightarrow> e list" ("$* _" 60) where
  "to_e_list b_es \<equiv> map Basic b_es"

abbreviation v_to_e_list :: "v list \<Rightarrow> e list" ("$$* _" 60) where
  "v_to_e_list ves \<equiv> map (\<lambda>v. $C v) ves"

  (* Lfilled depth thing-to-fill fill-with result *)
inductive Lfilled :: "nat \<Rightarrow> Lholed \<Rightarrow> e list \<Rightarrow> e list \<Rightarrow> bool" where
  (* "Lfill (LBase vs es') es = vs @ es @ es'" *)
  L0:"\<lbrakk>const_list vs; lholed = (LBase vs es')\<rbrakk> \<Longrightarrow> Lfilled 0 lholed es (vs @ es @ es')"
  (* "Lfill (LRec vs ts es' l es'') es = vs @ [Label ts es' (Lfill l es)] @ es''" *)
| LN:"\<lbrakk>const_list vs; lholed = (LRec vs n es' l es''); Lfilled k l es lfilledk\<rbrakk> \<Longrightarrow> Lfilled (k+1) lholed es (vs @ [Label n es' lfilledk] @ es'')"

  (* Lfilled depth thing-to-fill fill-with result *)
inductive Lfilled_exact :: "nat \<Rightarrow> Lholed \<Rightarrow> e list \<Rightarrow> e list \<Rightarrow> bool" where
  (* "Lfill (LBase vs es') es = vs @ es @ es'" *)
  L0:"\<lbrakk>lholed = (LBase [] [])\<rbrakk> \<Longrightarrow> Lfilled_exact 0 lholed es es"
  (* "Lfill (LRec vs ts es' l es'') es = vs @ [Label ts es' (Lfill l es)] @ es''" *)
| LN:"\<lbrakk>const_list vs; lholed = (LRec vs n es' l es''); Lfilled_exact k l es lfilledk\<rbrakk> \<Longrightarrow> Lfilled_exact (k+1) lholed es (vs @ [Label n es' lfilledk] @ es'')"

definition load_store_t_bounds :: "a \<Rightarrow> tp option \<Rightarrow> t \<Rightarrow> bool" where
  "load_store_t_bounds a tp t = (case tp of
                                   None \<Rightarrow> 2^a \<le> t_length t
                                 | Some tp \<Rightarrow> 2^a \<le> tp_length tp \<and> tp_length tp < t_length t \<and>  is_int_t t)"

definition cvt_i32 :: "sx option \<Rightarrow> v \<Rightarrow> i32 option" where
  "cvt_i32 sx v = (case v of
                   ConstInt32 c \<Rightarrow> None
                 | ConstInt64 c \<Rightarrow> Some (wasm_wrap c)
                 | ConstFloat32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui32_trunc_f32 c
                                      | Some S \<Rightarrow> si32_trunc_f32 c
                                      | None \<Rightarrow> None)
                 | ConstFloat64 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui32_trunc_f64 c
                                      | Some S \<Rightarrow> si32_trunc_f64 c
                                      | None \<Rightarrow> None))"

definition cvt_i64 :: "sx option \<Rightarrow> v \<Rightarrow> i64 option" where
  "cvt_i64 sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> Some (wasm_extend_u c)
                                      | Some S \<Rightarrow> Some (wasm_extend_s c)
                                      | None \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> None
                 | ConstFloat32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui64_trunc_f32 c
                                      | Some S \<Rightarrow> si64_trunc_f32 c
                                      | None \<Rightarrow> None)
                 | ConstFloat64 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui64_trunc_f64 c
                                      | Some S \<Rightarrow> si64_trunc_f64 c
                                      | None \<Rightarrow> None))"

definition cvt_f32 :: "sx option \<Rightarrow> v \<Rightarrow> f32 option" where
  "cvt_f32 sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f32_convert_ui32 c)
                                    | Some S \<Rightarrow> Some (f32_convert_si32 c)
                                    | _ \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f32_convert_ui64 c)
                                    | Some S \<Rightarrow> Some (f32_convert_si64 c)
                                    | _ \<Rightarrow> None)
                 | ConstFloat32 c \<Rightarrow> None
                 | ConstFloat64 c \<Rightarrow> Some (wasm_demote c))"

definition cvt_f64 :: "sx option \<Rightarrow> v \<Rightarrow> f64 option" where
  "cvt_f64 sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f64_convert_ui32 c)
                                    | Some S \<Rightarrow> Some (f64_convert_si32 c)
                                    | _ \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f64_convert_ui64 c)
                                    | Some S \<Rightarrow> Some (f64_convert_si64 c)
                                    | _ \<Rightarrow> None)
                 | ConstFloat32 c \<Rightarrow> Some (wasm_promote c)
                 | ConstFloat64 c \<Rightarrow> None)"

definition cvt :: "t \<Rightarrow> sx option \<Rightarrow> v \<Rightarrow> v option" where
  "cvt t sx v = (case t of
                 T_i32 \<Rightarrow> (case (cvt_i32 sx v) of Some c \<Rightarrow> Some (ConstInt32 c) | None \<Rightarrow> None)
               | T_i64 \<Rightarrow> (case (cvt_i64 sx v) of Some c \<Rightarrow> Some (ConstInt64 c) | None \<Rightarrow> None)
               | T_f32 \<Rightarrow> (case (cvt_f32 sx v) of Some c \<Rightarrow> Some (ConstFloat32 c) | None \<Rightarrow> None)
               | T_f64 \<Rightarrow> (case (cvt_f64 sx v) of Some c \<Rightarrow> Some (ConstFloat64 c) | None \<Rightarrow> None))"

definition bits :: "v \<Rightarrow> bytes" where
  "bits v = (case v of
               ConstInt32 c \<Rightarrow> (serialise_i32 c)
             | ConstInt64 c \<Rightarrow> (serialise_i64 c)
             | ConstFloat32 c \<Rightarrow> (serialise_f32 c)
             | ConstFloat64 c \<Rightarrow> (serialise_f64 c))"

definition bitzero :: "t \<Rightarrow> v" where
  "bitzero t = (case t of
                T_i32 \<Rightarrow> ConstInt32 0
              | T_i64 \<Rightarrow> ConstInt64 0
              | T_f32 \<Rightarrow> ConstFloat32 0
              | T_f64 \<Rightarrow> ConstFloat64 0)"

definition n_zeros :: "t list \<Rightarrow> v list" where
  "n_zeros ts = (map (\<lambda>t. bitzero t) ts)"

lemma is_int_t_exists:
  assumes "is_int_t t"
  shows "t = T_i32 \<or> t = T_i64"
  using assms
  by (cases t) (auto simp add: is_int_t_def)

lemma is_float_t_exists:
  assumes "is_float_t t"
  shows "t = T_f32 \<or> t = T_f64"
  using assms
  by (cases t) (auto simp add: is_float_t_def)

lemma int_float_disjoint: "is_int_t t = -(is_float_t t)"
  by simp (metis is_float_t_def is_int_t_def t.exhaust t.simps(13-16))

lemma stab_unfold:
  assumes "stab s i j = Some cl"
  shows "\<exists>k. inst.tab ((inst s)!i) = Some k \<and> length ((tab s)!k) > j \<and>((tab s)!k)!j = Some cl"
proof -
  obtain k where have_k:"(inst.tab ((inst s)!i)) = Some k"
    using assms
    unfolding stab_def
    by fastforce
  hence s_o:"stab s i j = stab_s s k j"
    using assms
    unfolding stab_def
    by simp
  then obtain stabinst where stabinst_def:"stabinst = ((tab s)!k)"
    by blast
  hence "stab_s s k j = (stabinst!j) \<and> (length stabinst > j)"
    using assms s_o
    unfolding stab_s_def
    by (cases "(length stabinst > j)", auto)
  thus ?thesis
    using have_k stabinst_def assms s_o
    by auto
qed

lemma inj_basic: "inj Basic"
  by (meson e.inject(1) injI)

lemma inj_basic_econst: "inj (\<lambda>v. $C v)"
  by (meson b_e.inject(16) e.inject(1) injI)

lemma to_e_list_1:"[$ a] = $* [a]"
  by simp

lemma to_e_list_2:"[$ a, $ b] = $* [a, b]"
  by simp

lemma to_e_list_3:"[$ a, $ b, $ c] = $* [a, b, c]"
  by simp

lemma v_exists_b_e:"\<exists>ves. ($$*vs) = ($*ves)"
proof (induction vs)
  case (Cons a vs)
  thus ?case
  by (metis list.simps(9))
qed auto

lemma Lfilled_exact_imp_Lfilled:
  assumes "Lfilled_exact n lholed es LI"
  shows "Lfilled n lholed es LI"
  using assms
proof (induction rule: Lfilled_exact.induct)
  case (L0 lholed es)
  thus ?case
    using const_list_def Lfilled.intros(1)
    by fastforce
next
  case (LN vs lholed n es' l es'' k es lfilledk)
  thus ?case
    using Lfilled.intros(2)
    by fastforce
qed

lemma Lfilled_exact_app_imp_exists_Lfilled:
  assumes "const_list ves"
          "Lfilled_exact n lholed (ves@es) LI"
  shows "\<exists>lholed'. Lfilled n lholed' es LI"
  using assms(2,1)
proof (induction "(ves@es)" LI rule: Lfilled_exact.induct)
  case (L0 lholed)
  show ?case
    using Lfilled.intros(1)[OF L0(2), of _ "[]"]
    by fastforce
next
  case (LN vs lholed n es' l es'' k lfilledk)
  thus ?case
    using Lfilled.intros(2)
    by fastforce
qed

lemma Lfilled_imp_exists_Lfilled_exact:
  assumes "Lfilled n lholed es LI"
  shows "\<exists>lholed' ves es_c. const_list ves \<and> Lfilled_exact n lholed' (ves@es@es_c) LI"
  using assms Lfilled_exact.intros
  by (induction rule: Lfilled.induct) fastforce+

lemma n_zeros_typeof:
  "n_zeros ts = vs \<Longrightarrow> (ts = map typeof vs)"
proof (induction ts arbitrary: vs)
  case Nil
  thus ?case
    unfolding n_zeros_def
    by simp
next
  case (Cons t ts)
  obtain vs' where "n_zeros ts = vs'"
    using n_zeros_def
    by blast
  moreover
  have "typeof (bitzero t) = t"
    unfolding typeof_def bitzero_def
    by (cases t, simp_all)
  ultimately
  show ?case
    using Cons
    unfolding n_zeros_def
    by auto
qed

end


(*  Title:      HOL/Auth/NS_Public_Bad.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Inductive relation "ns_public" for the Needham-Schroeder Public-Key protocol.
Flawed version, vulnerable to Lowe's attack.

From page 260 of
  Burrows, Abadi and Needham.  A Logic of Authentication.
  Proc. Royal Soc. 426 (1989)
*)

section{*Verifying the Needham-Schroeder Public-Key Protocol*}

theory NS_Public_Bad imports Public begin

inductive_set ns_public :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> ns_public"

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "\<lbrakk>evsf \<in> ns_public;  X \<in> synth (analz (spies evsf))\<rbrakk>
          \<Longrightarrow> Says Spy B X  # evsf \<in> ns_public"

         (*Alice initiates a protocol run, sending a nonce to Bob*)
 | NS1:  "\<lbrakk>evs1 \<in> ns_public;  Nonce NA \<notin> used evs1\<rbrakk>
          \<Longrightarrow> Says A B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>)
                # evs1  \<in>  ns_public"

         (*Bob responds to Alice's message with a further nonce*)
 | NS2:  "\<lbrakk>evs2 \<in> ns_public;  Nonce NB \<notin> used evs2;
           Says A' B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs2\<rbrakk>
          \<Longrightarrow> Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>)
                # evs2  \<in>  ns_public"

         (*Alice proves her existence by sending NB back to Bob.*)
 | NS3:  "\<lbrakk>evs3 \<in> ns_public;
           Says A  B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs3;
           Says B' A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs3\<rbrakk>
          \<Longrightarrow> Says A B (Crypt (pubEK B) (Nonce NB)) # evs3 \<in> ns_public"

declare knows_Spy_partsEs [elim]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un [dest]

(*A "possibility property": there are traces that reach the end*)
lemma "\<exists>NB. \<exists>evs \<in> ns_public. Says A B (Crypt (pubEK B) (Nonce NB)) \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] ns_public.Nil [THEN ns_public.NS1, THEN ns_public.NS2,
                                   THEN ns_public.NS3])
by possibility

(**** Inductive proofs about ns_public ****)

(** Theorems of the form X \<notin> parts (spies evs) imply that NOBODY
    sends messages containing X! **)

(*Spy never sees another agent's private key! (unless it's bad at start)*)
lemma Spy_see_priEK [simp]:
      "evs \<in> ns_public \<Longrightarrow> (Key (priEK A) \<in> parts (spies evs)) = (A \<in> bad)"
by (erule ns_public.induct, auto)

lemma Spy_analz_priEK [simp]:
      "evs \<in> ns_public \<Longrightarrow> (Key (priEK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

(*** Authenticity properties obtained from NS2 ***)

(*It is impossible to re-use a nonce in both NS1 and NS2, provided the nonce
  is secret.  (Honest users generate fresh nonces.)*)

(*Unicity for NS1: nonce NA identifies agents A and B*)
lemma unique_NA:
     "\<lbrakk>Crypt(pubEK B)  \<lbrace>Nonce NA, Agent A \<rbrace> \<in> parts(spies evs);
       Crypt(pubEK B') \<lbrace>Nonce NA, Agent A'\<rbrace> \<in> parts(spies evs);
       Nonce NA \<notin> analz (spies evs); evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> A=A' \<and> B=B'"
apply (erule rev_mp, erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all)
(*Fake, NS1*)
apply (blast intro!: analz_insertI)+
done

(*Secrecy: Spy does not see the nonce sent in msg NS1 if A and B are secure
  The major premise "Says A B ..." makes it a dest-rule, so we use
  (erule rev_mp) rather than rule_format. *)
theorem Spy_not_see_NA:
      "\<lbrakk>Says A B (Crypt(pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
       \<Longrightarrow> Nonce NA \<notin> analz (spies evs)"
apply (erule rev_mp)
apply (erule ns_public.induct, simp_all, spy_analz)
apply (blast dest: unique_NA intro: no_nonce_NS1_NS2)+
done

(*Authentication for A: if she receives message 2 and has used NA
  to start a run, then B has sent message 2.*)
lemma A_trusts_NS2_lemma [rule_format]:
   "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
    \<Longrightarrow> Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts (spies evs) \<longrightarrow>
        Says A B (Crypt(pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs \<longrightarrow>
        Says B A (Crypt(pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs"
apply (erule ns_public.induct)
apply (auto dest: Spy_not_see_NA unique_NA)
done

theorem A_trusts_NS2:
     "\<lbrakk>Says A  B (Crypt(pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs;
       Says B' A (Crypt(pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> Says B A (Crypt(pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs"
by (blast intro: A_trusts_NS2_lemma)

(*If the encrypted message appears then it originated with Alice in NS1*)
lemma B_trusts_NS1 [rule_format]:
     "evs \<in> ns_public
      \<Longrightarrow> Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts (spies evs) \<longrightarrow>
          Nonce NA \<notin> analz (spies evs) \<longrightarrow>
          Says A B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs"
apply (erule ns_public.induct, simp_all)
(*Fake*)
apply (blast intro!: analz_insertI)
done

(*** Authenticity properties obtained from NS2 ***)

(*Unicity for NS2: nonce NB identifies nonce NA and agent A
  [proof closely follows that for unique_NA] *)
lemma unique_NB [dest]:
     "\<lbrakk>Crypt(pubEK A)  \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts(spies evs);
       Crypt(pubEK A') \<lbrace>Nonce NA', Nonce NB\<rbrace> \<in> parts(spies evs);
       Nonce NB \<notin> analz (spies evs); evs \<in> ns_public\<rbrakk>
     \<Longrightarrow> A=A' \<and> NA=NA'"
apply (erule rev_mp, erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all)
(*Fake, NS2*)
apply (blast intro!: analz_insertI)+
done

(*NB remains secret PROVIDED Alice never responds with round 3*)
theorem Spy_not_see_NB [dest]:
     "\<lbrakk>Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs;
       \<forall>C. Says A C (Crypt (pubEK C) (Nonce NB)) \<notin> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
     \<Longrightarrow> Nonce NB \<notin> analz (spies evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all, spy_analz)
apply (simp_all add: all_conj_distrib) (*speeds up the next step*)
apply (blast intro: no_nonce_NS1_NS2)+
done

(*Authentication for B: if he receives message 3 and has used NB
  in message 2, then A has sent message 3--to somebody....*)

lemma B_trusts_NS3_lemma [rule_format]:
     "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> Crypt (pubEK B) (Nonce NB) \<in> parts (spies evs) \<longrightarrow>
          Says B A  (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs \<longrightarrow>
          (\<exists>C. Says A C (Crypt (pubEK C) (Nonce NB)) \<in> set evs)"
apply (erule ns_public.induct, auto)
by (blast intro: no_nonce_NS1_NS2)+

theorem B_trusts_NS3:
     "\<lbrakk>Says B A  (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs;
       Says A' B (Crypt (pubEK B) (Nonce NB)) \<in> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> \<exists>C. Says A C (Crypt (pubEK C) (Nonce NB)) \<in> set evs"
by (blast intro: B_trusts_NS3_lemma)

(*Can we strengthen the secrecy theorem Spy_not_see_NB?  NO*)
lemma "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
       \<Longrightarrow> Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs
           \<longrightarrow> Nonce NB \<notin> analz (spies evs)"
apply (erule ns_public.induct, simp_all, spy_analz)
(*NS1: by freshness*)
apply blast
(*NS2: by freshness and unicity of NB*)
apply (blast intro: no_nonce_NS1_NS2)
(*NS3: unicity of NB identifies A and NA, but not B*)
apply clarify
apply (frule_tac A' = A in
       Says_imp_knows_Spy [THEN parts.Inj, THEN unique_NB], auto)
apply (rename_tac evs3 B' C)
txt{*This is the attack!
@{subgoals[display,indent=0,margin=65]}
*}
oops

(*
THIS IS THE ATTACK!
Level 8
!!evs. \<lbrakk>A \<notin> bad; B \<notin> bad; evs \<in> ns_public\<rbrakk>
       \<Longrightarrow> Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs \<longrightarrow>
           Nonce NB \<notin> analz (spies evs)
 1. !!C B' evs3.
       \<lbrakk>A \<notin> bad; B \<notin> bad; evs3 \<in> ns_public
        Says A C (Crypt (pubEK C) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs3;
        Says B' A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs3;
        C \<in> bad;
        Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs3;
        Nonce NB \<notin> analz (spies evs3)\<rbrakk>
       \<Longrightarrow> False
*)

end


section \<open>Infinitely Transitive Closure\<close>

theory Inf
  imports Well_founded
begin

coinductive inf :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" for r where
  inf_step: "r x y \<Longrightarrow> inf r y \<Longrightarrow> inf r x"

coinductive inf_wf :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool" for r order where
  inf_wf: "order n m \<Longrightarrow> inf_wf r order n x \<Longrightarrow> inf_wf r order m x" |
  inf_wf_step: "r\<^sup>+\<^sup>+ x y \<Longrightarrow> inf_wf r order n y \<Longrightarrow> inf_wf r order m x"

lemma inf_wf_to_step_inf_wf:
  assumes "well_founded order"
  shows "inf_wf r order n x \<Longrightarrow> \<exists>y m. r x y \<and> inf_wf r order m y"
proof (induction n arbitrary: x rule: well_founded.induct[OF assms(1)])
  case (1 n)
  from "1.prems"(1) show ?case
  proof (induction rule: inf_wf.cases)
    case (inf_wf m n' x')
    then show ?case using "1.IH" by simp
  next
    case (inf_wf_step x' y m n')
    then show ?case
      by (metis converse_tranclpE inf_wf.inf_wf_step)
  qed
qed

lemma inf_wf_to_inf:
  assumes "well_founded order"
  shows "inf_wf r order n x \<Longrightarrow> inf r x"
proof (coinduction arbitrary: x n rule: inf.coinduct)
  case (inf x n)
  then obtain y m where "r x y" and "inf_wf r order m y"
    using inf_wf_to_step_inf_wf[OF assms(1) inf(1)] by metis
  thus ?case by auto
qed

lemma step_inf:
  assumes
    deterministic: "\<And>x y z. r x y \<Longrightarrow> r x z \<Longrightarrow> y = z"
  shows "r x y \<Longrightarrow> inf r x \<Longrightarrow> inf r y"
  by (metis deterministic inf.cases)

lemma star_inf:
  assumes
    deterministic: "\<And>x y z. r x y \<Longrightarrow> r x z \<Longrightarrow> y = z"
  shows "r\<^sup>*\<^sup>* x y \<Longrightarrow> inf r x \<Longrightarrow> inf r y"
proof (induction y rule: rtranclp_induct)
  case base
  then show ?case .
next
  case (step y z)
  then show ?case
    using step_inf deterministic by metis
qed

end


(*  Title:      HOL/Algebra/Congruence.thy
    Author:     Clemens Ballarin, started 3 January 2008
    Copyright:  Clemens Ballarin
*)

theory Congruence
imports Main
begin

section \<open>Objects\<close>

subsection \<open>Structure with Carrier Set.\<close>

record 'a partial_object =
  carrier :: "'a set"

subsection \<open>Structure with Carrier and Equivalence Relation \<open>eq\<close>\<close>

record 'a eq_object = "'a partial_object" +
  eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl ".=\<index>" 50)

definition
  elem :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> bool" (infixl ".\<in>\<index>" 50)
  where "x .\<in>\<^bsub>S\<^esub> A \<longleftrightarrow> (\<exists>y \<in> A. x .=\<^bsub>S\<^esub> y)"

definition
  set_eq :: "_ \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "{.=}\<index>" 50)
  where "A {.=}\<^bsub>S\<^esub> B \<longleftrightarrow> ((\<forall>x \<in> A. x .\<in>\<^bsub>S\<^esub> B) \<and> (\<forall>x \<in> B. x .\<in>\<^bsub>S\<^esub> A))"

definition
  eq_class_of :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set" ("class'_of\<index>")
  where "class_of\<^bsub>S\<^esub> x = {y \<in> carrier S. x .=\<^bsub>S\<^esub> y}"

definition
  eq_closure_of :: "_ \<Rightarrow> 'a set \<Rightarrow> 'a set" ("closure'_of\<index>")
  where "closure_of\<^bsub>S\<^esub> A = {y \<in> carrier S. y .\<in>\<^bsub>S\<^esub> A}"

definition
  eq_is_closed :: "_ \<Rightarrow> 'a set \<Rightarrow> bool" ("is'_closed\<index>")
  where "is_closed\<^bsub>S\<^esub> A \<longleftrightarrow> A \<subseteq> carrier S \<and> closure_of\<^bsub>S\<^esub> A = A"

abbreviation
  not_eq :: "_ \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl ".\<noteq>\<index>" 50)
  where "x .\<noteq>\<^bsub>S\<^esub> y == ~(x .=\<^bsub>S\<^esub> y)"

abbreviation
  not_elem :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> bool" (infixl ".\<notin>\<index>" 50)
  where "x .\<notin>\<^bsub>S\<^esub> A == ~(x .\<in>\<^bsub>S\<^esub> A)"

abbreviation
  set_not_eq :: "_ \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "{.\<noteq>}\<index>" 50)
  where "A {.\<noteq>}\<^bsub>S\<^esub> B == ~(A {.=}\<^bsub>S\<^esub> B)"

locale equivalence =
  fixes S (structure)
  assumes refl [simp, intro]: "x \<in> carrier S \<Longrightarrow> x .= x"
    and sym [sym]: "\<lbrakk> x .= y; x \<in> carrier S; y \<in> carrier S \<rbrakk> \<Longrightarrow> y .= x"
    and trans [trans]:
      "\<lbrakk> x .= y; y .= z; x \<in> carrier S; y \<in> carrier S; z \<in> carrier S \<rbrakk> \<Longrightarrow> x .= z"

(* Lemmas by Stephan Hohe *)

lemma elemI:
  fixes R (structure)
  assumes "a' \<in> A" and "a .= a'"
  shows "a .\<in> A"
unfolding elem_def
using assms
by fast

lemma (in equivalence) elem_exact:
  assumes "a \<in> carrier S" and "a \<in> A"
  shows "a .\<in> A"
using assms
by (fast intro: elemI)

lemma elemE:
  fixes S (structure)
  assumes "a .\<in> A"
    and "\<And>a'. \<lbrakk>a' \<in> A; a .= a'\<rbrakk> \<Longrightarrow> P"
  shows "P"
using assms
unfolding elem_def
by fast

lemma (in equivalence) elem_cong_l [trans]:
  assumes cong: "a' .= a"
    and a: "a .\<in> A"
    and carr: "a \<in> carrier S"  "a' \<in> carrier S"
    and Acarr: "A \<subseteq> carrier S"
  shows "a' .\<in> A"
using a
apply (elim elemE, intro elemI)
proof assumption
  fix b
  assume bA: "b \<in> A"
  note [simp] = carr bA[THEN subsetD[OF Acarr]]
  note cong
  also assume "a .= b"
  finally show "a' .= b" by simp
qed

lemma (in equivalence) elem_subsetD:
  assumes "A \<subseteq> B"
    and aA: "a .\<in> A"
  shows "a .\<in> B"
using assms
by (fast intro: elemI elim: elemE dest: subsetD)

lemma (in equivalence) mem_imp_elem [simp, intro]:
  "[| x \<in> A; x \<in> carrier S |] ==> x .\<in> A"
  unfolding elem_def by blast

lemma set_eqI:
  fixes R (structure)
  assumes ltr: "\<And>a. a \<in> A \<Longrightarrow> a .\<in> B"
    and rtl: "\<And>b. b \<in> B \<Longrightarrow> b .\<in> A"
  shows "A {.=} B"
unfolding set_eq_def
by (fast intro: ltr rtl)

lemma set_eqI2:
  fixes R (structure)
  assumes ltr: "\<And>a b. a \<in> A \<Longrightarrow> \<exists>b\<in>B. a .= b"
    and rtl: "\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. b .= a"
  shows "A {.=} B"
  by (intro set_eqI, unfold elem_def) (fast intro: ltr rtl)+

lemma set_eqD1:
  fixes R (structure)
  assumes AA': "A {.=} A'"
    and "a \<in> A"
  shows "\<exists>a'\<in>A'. a .= a'"
using assms
unfolding set_eq_def elem_def
by fast

lemma set_eqD2:
  fixes R (structure)
  assumes AA': "A {.=} A'"
    and "a' \<in> A'"
  shows "\<exists>a\<in>A. a' .= a"
using assms
unfolding set_eq_def elem_def
by fast

lemma set_eqE:
  fixes R (structure)
  assumes AB: "A {.=} B"
    and r: "\<lbrakk>\<forall>a\<in>A. a .\<in> B; \<forall>b\<in>B. b .\<in> A\<rbrakk> \<Longrightarrow> P"
  shows "P"
using AB
unfolding set_eq_def
by (blast dest: r)

lemma set_eqE2:
  fixes R (structure)
  assumes AB: "A {.=} B"
    and r: "\<lbrakk>\<forall>a\<in>A. (\<exists>b\<in>B. a .= b); \<forall>b\<in>B. (\<exists>a\<in>A. b .= a)\<rbrakk> \<Longrightarrow> P"
  shows "P"
using AB
unfolding set_eq_def elem_def
by (blast dest: r)

lemma set_eqE':
  fixes R (structure)
  assumes AB: "A {.=} B"
    and aA: "a \<in> A" and bB: "b \<in> B"
    and r: "\<And>a' b'. \<lbrakk>a' \<in> A; b .= a'; b' \<in> B; a .= b'\<rbrakk> \<Longrightarrow> P"
  shows "P"
proof -
  from AB aA
      have "\<exists>b'\<in>B. a .= b'" by (rule set_eqD1)
  from this obtain b'
      where b': "b' \<in> B" "a .= b'" by auto

  from AB bB
      have "\<exists>a'\<in>A. b .= a'" by (rule set_eqD2)
  from this obtain a'
      where a': "a' \<in> A" "b .= a'" by auto

  from a' b'
      show "P" by (rule r)
qed

lemma (in equivalence) eq_elem_cong_r [trans]:
  assumes a: "a .\<in> A"
    and cong: "A {.=} A'"
    and carr: "a \<in> carrier S"
    and Carr: "A \<subseteq> carrier S" "A' \<subseteq> carrier S"
  shows "a .\<in> A'"
using a cong
proof (elim elemE set_eqE)
  fix b
  assume bA: "b \<in> A"
     and inA': "\<forall>b\<in>A. b .\<in> A'"
  note [simp] = carr Carr Carr[THEN subsetD] bA
  assume "a .= b"
  also from bA inA'
       have "b .\<in> A'" by fast
  finally
       show "a .\<in> A'" by simp
qed

lemma (in equivalence) set_eq_sym [sym]:
  assumes "A {.=} B"
    and "A \<subseteq> carrier S" "B \<subseteq> carrier S"
  shows "B {.=} A"
using assms
unfolding set_eq_def elem_def
by fast

(* FIXME: the following two required in Isabelle 2008, not Isabelle 2007 *)
(* alternatively, could declare lemmas [trans] = ssubst [where 'a = "'a set"] *)

lemma (in equivalence) equal_set_eq_trans [trans]:
  assumes AB: "A = B" and BC: "B {.=} C"
  shows "A {.=} C"
  using AB BC by simp

lemma (in equivalence) set_eq_equal_trans [trans]:
  assumes AB: "A {.=} B" and BC: "B = C"
  shows "A {.=} C"
  using AB BC by simp

lemma (in equivalence) set_eq_trans [trans]:
  assumes AB: "A {.=} B" and BC: "B {.=} C"
    and carr: "A \<subseteq> carrier S"  "B \<subseteq> carrier S"  "C \<subseteq> carrier S"
  shows "A {.=} C"
proof (intro set_eqI)
  fix a
  assume aA: "a \<in> A"
  with carr have "a \<in> carrier S" by fast
  note [simp] = carr this

  from aA
       have "a .\<in> A" by (simp add: elem_exact)
  also note AB
  also note BC
  finally
       show "a .\<in> C" by simp
next
  fix c
  assume cC: "c \<in> C"
  with carr have "c \<in> carrier S" by fast
  note [simp] = carr this

  from cC
       have "c .\<in> C" by (simp add: elem_exact)
  also note BC[symmetric]
  also note AB[symmetric]
  finally
       show "c .\<in> A" by simp
qed

(* FIXME: generalise for insert *)

(*
lemma (in equivalence) set_eq_insert:
  assumes x: "x .= x'"
    and carr: "x \<in> carrier S" "x' \<in> carrier S" "A \<subseteq> carrier S"
  shows "insert x A {.=} insert x' A"
  unfolding set_eq_def elem_def
apply rule
apply rule
apply (case_tac "xa = x")
using x apply fast
apply (subgoal_tac "xa \<in> A") prefer 2 apply fast
apply (rule_tac x=xa in bexI)
using carr apply (rule_tac refl) apply auto [1]
apply safe
*)

lemma (in equivalence) set_eq_pairI:
  assumes xx': "x .= x'"
    and carr: "x \<in> carrier S" "x' \<in> carrier S" "y \<in> carrier S"
  shows "{x, y} {.=} {x', y}"
unfolding set_eq_def elem_def
proof safe
  have "x' \<in> {x', y}" by fast
  with xx' show "\<exists>b\<in>{x', y}. x .= b" by fast
next
  have "y \<in> {x', y}" by fast
  with carr show "\<exists>b\<in>{x', y}. y .= b" by fast
next
  have "x \<in> {x, y}" by fast
  with xx'[symmetric] carr
  show "\<exists>a\<in>{x, y}. x' .= a" by fast
next
  have "y \<in> {x, y}" by fast
  with carr show "\<exists>a\<in>{x, y}. y .= a" by fast
qed

lemma (in equivalence) is_closedI:
  assumes closed: "!!x y. [| x .= y; x \<in> A; y \<in> carrier S |] ==> y \<in> A"
    and S: "A \<subseteq> carrier S"
  shows "is_closed A"
  unfolding eq_is_closed_def eq_closure_of_def elem_def
  using S
  by (blast dest: closed sym)

lemma (in equivalence) closure_of_eq:
  "[| x .= x'; A \<subseteq> carrier S; x \<in> closure_of A; x \<in> carrier S; x' \<in> carrier S |] ==> x' \<in> closure_of A"
  unfolding eq_closure_of_def elem_def
  by (blast intro: trans sym)

lemma (in equivalence) is_closed_eq [dest]:
  "[| x .= x'; x \<in> A; is_closed A; x \<in> carrier S; x' \<in> carrier S |] ==> x' \<in> A"
  unfolding eq_is_closed_def
  using closure_of_eq [where A = A]
  by simp

lemma (in equivalence) is_closed_eq_rev [dest]:
  "[| x .= x'; x' \<in> A; is_closed A; x \<in> carrier S; x' \<in> carrier S |] ==> x \<in> A"
  by (drule sym) (simp_all add: is_closed_eq)

lemma closure_of_closed [simp, intro]:
  fixes S (structure)
  shows "closure_of A \<subseteq> carrier S"
unfolding eq_closure_of_def
by fast

lemma closure_of_memI:
  fixes S (structure)
  assumes "a .\<in> A"
    and "a \<in> carrier S"
  shows "a \<in> closure_of A"
unfolding eq_closure_of_def
using assms
by fast

lemma closure_ofI2:
  fixes S (structure)
  assumes "a .= a'"
    and "a' \<in> A"
    and "a \<in> carrier S"
  shows "a \<in> closure_of A"
unfolding eq_closure_of_def elem_def
using assms
by fast

lemma closure_of_memE:
  fixes S (structure)
  assumes p: "a \<in> closure_of A"
    and r: "\<lbrakk>a \<in> carrier S; a .\<in> A\<rbrakk> \<Longrightarrow> P"
  shows "P"
proof -
  from p
      have acarr: "a \<in> carrier S"
      and "a .\<in> A"
      by (simp add: eq_closure_of_def)+
  thus "P" by (rule r)
qed

lemma closure_ofE2:
  fixes S (structure)
  assumes p: "a \<in> closure_of A"
    and r: "\<And>a'. \<lbrakk>a \<in> carrier S; a' \<in> A; a .= a'\<rbrakk> \<Longrightarrow> P"
  shows "P"
proof -
  from p have acarr: "a \<in> carrier S" by (simp add: eq_closure_of_def)

  from p have "\<exists>a'\<in>A. a .= a'" by (simp add: eq_closure_of_def elem_def)
  from this obtain a'
      where "a' \<in> A" and "a .= a'" by auto

  from acarr and this
      show "P" by (rule r)
qed

(*
lemma (in equivalence) classes_consistent:
  assumes Acarr: "A \<subseteq> carrier S"
  shows "is_closed (closure_of A)"
apply (blast intro: elemI elim elemE)
using assms
apply (intro is_closedI closure_of_memI, simp)
 apply (elim elemE closure_of_memE)
proof -
  fix x a' a''
  assume carr: "x \<in> carrier S" "a' \<in> carrier S"
  assume a''A: "a'' \<in> A"
  with Acarr have "a'' \<in> carrier S" by fast
  note [simp] = carr this Acarr

  assume "x .= a'"
  also assume "a' .= a''"
  also from a''A
       have "a'' .\<in> A" by (simp add: elem_exact)
  finally show "x .\<in> A" by simp
qed
*)
(*
lemma (in equivalence) classes_small:
  assumes "is_closed B"
    and "A \<subseteq> B"
  shows "closure_of A \<subseteq> B"
using assms
by (blast dest: is_closedD2 elem_subsetD elim: closure_of_memE)

lemma (in equivalence) classes_eq:
  assumes "A \<subseteq> carrier S"
  shows "A {.=} closure_of A"
using assms
by (blast intro: set_eqI elem_exact closure_of_memI elim: closure_of_memE)

lemma (in equivalence) complete_classes:
  assumes c: "is_closed A"
  shows "A = closure_of A"
using assms
by (blast intro: closure_of_memI elem_exact dest: is_closedD1 is_closedD2 closure_of_memE)
*)

end