text_raw \<open>\subsection[Sub-Structures]{Sub-Structures\isalabel{sec:sub-structures}}\<close>

theory SubStructures
  imports ParticularStructureMorphisms
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  A particular structure \<open>\<Gamma>\<^sub>1\<close> is considered a sub-structure of another
  particular structure \<open>\<Gamma>\<^sub>2\<close> by means of a morphism \<open>\<phi>\<close> if and only if
  the later is an injective morphism between the first and the second:
\<close>
abbreviation sub_structure_by ::
  \<open>('i\<^sub>1,'q) particular_struct \<Rightarrow> ('i\<^sub>1 \<Rightarrow> 'i\<^sub>2) \<Rightarrow> ('i\<^sub>2,'q) particular_struct \<Rightarrow> bool\<close>
  (\<open>_ \<lless>\<^bsub>_\<^esub> _\<close> [74,1,74] 75) where
  \<open>\<Gamma>\<^sub>1 \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>2 \<equiv> particular_struct_injection \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<phi>\<close>

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Every particular structure is a sub-structure of itself, through the identity morphism:
\<close>
lemma sub_structure_by_refl:
  assumes \<open>particular_struct \<Gamma>\<close>
  shows \<open>\<Gamma> \<lless>\<^bsub>id\<^esub> \<Gamma>\<close>
proof -
  interpret particular_struct \<Gamma> using assms .
  show ?thesis
    by (metis \<Gamma>_simps particular_struct_eqI particular_struct_bijection_1_def
          ufo_particular_theory.MorphImg_of_id
          ufo_particular_theory.id_is_isomorphism ufo_particular_theory_axioms)
qed

text \<^marker>\<open>tag bodyonly\<close> \<open>
  The sub-structure relation is transitive, through the composition of
  morphisms:
\<close>
lemma sub_structure_by_trans:
  assumes \<open>\<Gamma>\<^sub>1 \<lless>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>2\<close> \<open>\<Gamma>\<^sub>2 \<lless>\<^bsub>\<phi>\<^sub>2\<^esub> \<Gamma>\<^sub>3\<close>
  shows \<open>\<Gamma>\<^sub>1 \<lless>\<^bsub>\<phi>\<^sub>2 \<circ> \<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>3\<close>
  by (intro particular_struct_injection_comp[OF assms])

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Two particular structures are considered isomorphic by means of a morphism \<open>\<phi>\<close>
  just in case \<open>\<phi>\<close> is an bijective morphism:
\<close>

abbreviation isomorphic_by ::
  \<open>('i\<^sub>1,'q) particular_struct \<Rightarrow> ('i\<^sub>1 \<Rightarrow> 'i\<^sub>2) \<Rightarrow> ('i\<^sub>2,'q) particular_struct \<Rightarrow> bool\<close>
  (\<open>_ \<sim>\<^bsub>_\<^esub> _\<close> [74,1,74] 75) where
  \<open>\<Gamma>\<^sub>1 \<sim>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>2 \<equiv> particular_struct_bijection \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<phi>\<close>

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Given particular structures \<open>\<Gamma>\<^sub>1\<close> and \<open>\<Gamma>\<^sub>2\<close>, if \<open>\<Gamma>\<^sub>1\<close> is isomorphic to
  \<open>\<Gamma>\<^sub>2\<close> through a morphism \<open>\<phi>\<close>, then \<open>\<Gamma>\<^sub>1\<close> is a sub-structure of \<open>\<Gamma>\<^sub>2\<close>
  though \<open>\<phi>\<close>:
\<close>

lemma  isomorphic_by_imp_sub_structure[dest]:
  assumes \<open>\<Gamma>\<^sub>1 \<sim>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>2\<close>
  shows \<open>\<Gamma>\<^sub>1 \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>2\<close>
  using assms
  by (simp add: particular_struct_bijection.axioms(1))

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Every particular structure is isomorphic to itself through the
  identity morphism:
\<close>

lemma isomorphic_by_refl:
  assumes \<open>particular_struct \<Gamma>\<close>
  shows \<open>\<Gamma> \<sim>\<^bsub>id\<^esub> \<Gamma>\<close>
proof -
  interpret particular_struct \<Gamma> using assms.
  show ?thesis
    by (metis \<Gamma>_simps id_is_a_permutation
          particular_struct_eqI particular_struct_permutation.axioms(2))
qed

text \<^marker>\<open>tag bodyonly\<close> \<open>
  If \<open>\<Gamma>\<^sub>1\<close> is isomorphic to \<open>\<Gamma>\<^sub>2\<close> through a morphism \<open>\<phi>\<close>, then
  \<open>\<Gamma>\<^sub>2\<close> is isomorphic to \<open>\<Gamma>\<^sub>1\<close> through the inverse of \<open>\<phi>\<close>:
\<close>
lemma isomorphic_by_sym[intro!]:
  assumes \<open>\<Gamma>\<^sub>1 \<sim>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>2\<close>
  shows \<open>\<Gamma>\<^sub>2 \<sim>\<^bsub>particular_struct_morphism_sig.inv_morph \<Gamma>\<^sub>1 \<phi>\<^esub> \<Gamma>\<^sub>1\<close>
  using particular_struct_bijection.inv_is_bijective_morphism assms by metis

text \<^marker>\<open>tag bodyonly\<close> \<open>
  ``Being isomorphic to'' is a transitive relation:
\<close>

lemma isomorphic_by_trans[trans]:
  assumes \<open>\<Gamma>\<^sub>1 \<sim>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>2\<close> \<open>\<Gamma>\<^sub>2 \<sim>\<^bsub>\<phi>\<^sub>2\<^esub> \<Gamma>\<^sub>3\<close>
  shows \<open>\<Gamma>\<^sub>1 \<sim>\<^bsub>\<phi>\<^sub>2 \<circ> \<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>3\<close>
  using assms particular_struct_bijection_comp by blast

lemma \<^marker>\<open>tag (proof) aponly\<close> isomorphic_by_sub_structure_transf[simp]:
  assumes \<open>\<Gamma>\<^sub>1 \<sim>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>2\<close>
  shows \<open>\<Gamma> \<lless>\<^bsub>\<phi> \<circ> \<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>2 \<and> \<phi>\<^sub>1 ` particulars \<Gamma> \<subseteq> particulars \<Gamma>\<^sub>1 \<longleftrightarrow> \<Gamma> \<lless>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>1\<close>
proof -
  interpret I1: particular_struct_bijection \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<phi> using assms .
  interpret I2: particular_struct_bijection_1 \<Gamma>\<^sub>1 \<phi>
    using assms particular_struct_bijection_iff_particular_struct_bijection_1
    by blast
  have A[simp]: \<open>\<Gamma>\<^sub>2 = MorphImg \<phi> \<Gamma>\<^sub>1\<close>
    by (simp add: I1.tgt_is_morph_img)

  show ?thesis
  proof (cases \<open>particular_struct \<Gamma> \<and> inj_on \<phi>\<^sub>1 (particulars \<Gamma>) \<and> \<Gamma> \<lless>\<^bsub>\<phi> \<circ> \<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>2
                  \<and> \<phi>\<^sub>1 ` particulars \<Gamma> \<subseteq> particulars \<Gamma>\<^sub>1\<close>
          ; (elim conjE)?)
    case False
    note AA = this
    then consider (C1) \<open>\<not> particular_struct \<Gamma>\<close> |
                  (C2) \<open>\<not> inj_on \<phi>\<^sub>1 (particulars \<Gamma>)\<close> |
                  (C3) \<open>\<not> \<Gamma> \<lless>\<^bsub>\<phi> \<circ> \<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>2\<close> |
                  (C4) \<open>\<Gamma> \<lless>\<^bsub>\<phi> \<circ> \<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>2\<close> \<open>\<not> \<phi>\<^sub>1 ` particulars \<Gamma> \<subseteq> particulars \<Gamma>\<^sub>1\<close>
      by metis
    then show ?thesis
    proof cases
      case C1
      then show ?thesis
      by (simp only: particular_struct_injection_def
            particular_struct_morphism_def
            pre_particular_struct_morphism_def ; simp)
    next
      case C2
      then have B: \<open>\<not> inj_on (\<phi> \<circ> \<phi>\<^sub>1) (particulars \<Gamma>)\<close>
        using inj_on_imageI2 by blast
      show ?thesis
        by (simp only: particular_struct_injection_def
                particular_struct_injection_axioms_def C2 B ; simp)
    next
      case C3
      then have B: \<open>\<not> \<Gamma> \<lless>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>1\<close>
        using I1.particular_struct_injection_axioms
            particular_struct_injection_comp by metis
      show ?thesis
        by (intro iffI conjI ; (elim conjE)? ; (simp only: C3 B)?)
    next
      case C4
      then  interpret phi_phi1: particular_struct_injection \<Gamma> \<Gamma>\<^sub>2 \<open>\<phi> \<circ> \<phi>\<^sub>1\<close> by simp
      have B: \<open>(\<exists>x. x \<in> phi_phi1.src.endurants \<and> \<phi>\<^sub>1 x \<notin> I1.src.endurants)\<close>
        using C4 by blast
      show ?thesis
        by (simp add: C4 particular_struct_injection_def
              particular_struct_morphism_def
              pre_particular_struct_morphism_def
              pre_particular_struct_morphism_axioms_def
              B)
    qed
  next
    assume assms1: \<open>particular_struct \<Gamma>\<close>
        \<open>inj_on \<phi>\<^sub>1 (particulars \<Gamma>)\<close> \<open>\<Gamma> \<lless>\<^bsub>\<phi> \<circ> \<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>2\<close>
        \<open>\<phi>\<^sub>1 ` particulars \<Gamma> \<subseteq> particulars \<Gamma>\<^sub>1\<close>
    interpret gamma: particular_struct \<Gamma> using assms1(1) .
    interpret phi_phi1: particular_struct_injection \<Gamma> \<Gamma>\<^sub>2 \<open>\<phi> \<circ> \<phi>\<^sub>1\<close>
      using assms1(3) .

    have phi1_img[intro!]: \<open>\<phi>\<^sub>1 x \<in>  particulars \<Gamma>\<^sub>1 \<close> if \<open>x \<in> particulars \<Gamma>\<close> for x
        using assms1(4) that  by blast

    have B[simp]: \<open>\<phi> (\<phi>\<^sub>1 x) = \<phi> (\<phi>\<^sub>1 y) \<longleftrightarrow> x = y\<close> if \<open>x \<in> phi_phi1.src.\<P>\<close> \<open>y \<in> phi_phi1.src.\<P>\<close> for x y
      using phi_phi1.morph_is_injective[THEN inj_onD,OF _ that,simplified] by metis
    have C[simp]: \<open>\<phi>\<^sub>1 x = \<phi>\<^sub>1 y \<longleftrightarrow> x = y\<close> if \<open>x \<in> phi_phi1.src.\<P>\<close> \<open>y \<in> phi_phi1.src.\<P>\<close> for x y
      using assms1(2)[THEN inj_onD,OF _ that,simplified] by metis
    have D[simp]: \<open>\<phi> x = \<phi> y \<longleftrightarrow> x = y\<close> if \<open>x \<in> \<phi>\<^sub>1 ` phi_phi1.src.\<P>\<close> \<open>y \<in> \<phi>\<^sub>1 ` phi_phi1.src.\<P>\<close> for x y
      using that apply (elim imageE ; hypsubst_thin)
      by simp
    note simps = B C D
    have E: \<open>\<phi>\<^sub>1 x = I2.inv_morph ((\<phi> \<circ> \<phi>\<^sub>1) x)\<close> if \<open>x \<in> phi_phi1.src.\<P>\<close> for x
      using that assms assms1 by auto

    { fix x y z q
      note phi_phi1.morph_reflects_inherence[of x y]
           phi_phi1.morph_does_not_add_bearers[of x z]
           phi_phi1.morph_reflects_towardness[of x y]
           phi_phi1.morph_does_not_add_towards[of x z]
           phi_phi1.morph_reflects_quale_assoc[of x q] }
    note R1 = this
    { fix x y z q
      note I1.morph_reflects_inherence[of \<open>\<phi>\<^sub>1 x\<close> \<open>\<phi>\<^sub>1 y\<close>]
           I1.morph_does_not_add_bearers[of \<open>\<phi>\<^sub>1 x\<close> z]
           I1.morph_reflects_towardness[of \<open>\<phi>\<^sub>1 x\<close> \<open>\<phi>\<^sub>1 y\<close>]
           I1.morph_does_not_add_towards[of \<open>\<phi>\<^sub>1 x\<close> z]
           I1.morph_reflects_quale_assoc[of \<open>\<phi>\<^sub>1 x\<close> q] }
    note R2 = this

    interpret phi1: pre_particular_struct_morphism \<Gamma> \<Gamma>\<^sub>1 \<phi>\<^sub>1
      apply (unfold_locales ; simp? ; (simp only: E)?)
      subgoal G1  using phi_phi1.quality_space_subset by auto
      subgoal G2  using assms1 by (simp ; blast)
      subgoal G3 for x y
        using phi_phi1.morph_preserves_particulars phi_phi1.morph_reflects_inherence by auto
      subgoal G4 for x z
        by (metis (no_types, lifting) E G2 I1.inv_morph_morph I1.morph_reflects_inherence I1.src.endurantI2 I1.src.moment_non_migration phi_phi1.morph_does_not_add_bearers phi_phi1.morph_preserves_particulars)
      subgoal G5 for x y
        using phi_phi1.morph_preserves_particulars phi_phi1.morph_reflects_towardness by auto
      subgoal G6 for x y
        by (metis E G2 I1.inv_morph_morph I1.morph_reflects_towardness
              I1.src.towardness_scopeE I2.morph_is_injective
              phi_phi1.morph_does_not_add_towards
              phi_phi1.morph_preserves_particulars inj_onD)
      subgoal for x q
        using G2 by auto
      done

    have phi1_w_c: \<open>phi1.world_corresp w w\<^sub>2 \<longleftrightarrow> phi_phi1.world_corresp w (\<phi> ` w\<^sub>2) \<and> w\<^sub>2 \<in> I1.src.\<W>\<close> for w w\<^sub>2
      apply (simp add: particular_struct_morphism_sig.world_corresp_def
          ; intro iffI conjI impI ballI ; (elim imageE conjE disjE exE)? ; simp?)
      subgoal G1 by blast
      subgoal G2 for x y by (metis I2.morph_is_injective inj_onD phi1.tgt.\<P>_I phi1_img)
      using I2.src_world_corresp_image by blast

    have R4: \<open>phi1.inv_morph ` (w\<^sub>1 \<inter> \<phi>\<^sub>1 ` phi_phi1.src.\<P>) \<in> phi_phi1.src.\<W>\<close>
      if as: \<open>w\<^sub>1 \<in> phi1.tgt.\<W>\<close> for w\<^sub>1
    proof -
      obtain w\<^sub>2 where AA: \<open>I1.world_corresp w\<^sub>1 w\<^sub>2\<close>
        using as I1.morph_worlds_correspond_src_tgt by metis
      obtain BB: \<open>w\<^sub>2 \<in> I1.tgt.\<W>\<close>
                 \<open>\<And>x. x \<in> phi1.tgt.\<P> \<Longrightarrow> x \<in> w\<^sub>1 \<longleftrightarrow> \<phi> x \<in> w\<^sub>2\<close>
        using I1.world_corresp_E AA by metis
      obtain w\<^sub>3 where CC: \<open>phi_phi1.world_corresp w\<^sub>3 w\<^sub>2\<close>
        using BB phi_phi1.morph_worlds_correspond_tgt_src by metis
      obtain DD: \<open>w\<^sub>3 \<in> phi_phi1.src.\<W>\<close>
          \<open>\<And>x. x \<in> phi_phi1.src.\<P> \<Longrightarrow> x \<in> w\<^sub>3 \<longleftrightarrow>\<phi> (\<phi>\<^sub>1 x) \<in> w\<^sub>2\<close>
        using phi_phi1.world_corresp_E[OF CC] comp_apply by metis
      { fix x
        assume \<open>x \<in> w\<^sub>3\<close>
        then have EE: \<open>x \<in> phi_phi1.src.\<P>\<close> using DD(1) by blast
        then have FF: \<open>\<phi> (\<phi>\<^sub>1 x) \<in> w\<^sub>2 \<longleftrightarrow> x \<in> w\<^sub>3\<close> using DD(2) by simp
        have \<open>\<phi>\<^sub>1 x \<in> phi1.tgt.\<P>\<close> using EE by blast
        then have \<open>\<phi>\<^sub>1 x \<in> w\<^sub>1 \<longleftrightarrow> x \<in> w\<^sub>3\<close> using BB(2) FF by metis }
      note simp1[simp] = this

      { fix x
        assume EE: \<open>x \<in> phi_phi1.src.\<P>\<close>
        then have FF: \<open>\<phi> (\<phi>\<^sub>1 x) \<in> w\<^sub>2 \<longleftrightarrow> x \<in> w\<^sub>3\<close> using DD(2) by simp
        have \<open>\<phi>\<^sub>1 x \<in> phi1.tgt.\<P>\<close> using EE by blast
        then have \<open>\<phi>\<^sub>1 x \<in> w\<^sub>1 \<longleftrightarrow> x \<in> w\<^sub>3\<close> using BB(2) FF by metis }
      note simp2[simp] = this

      have GG: \<open>\<phi>\<^sub>1 ` w\<^sub>3 = w\<^sub>1 \<inter> \<phi>\<^sub>1 ` phi_phi1.src.\<P>\<close>
        apply (auto  ; (intro imageI)? ; simp?)
        using DD(1) by blast
      have HH: \<open>phi1.inv_morph (\<phi>\<^sub>1 x) = x\<close> if \<open>x \<in> phi_phi1.src.\<P>\<close> for x
        by (simp add: assms1(2) phi1.inv_morph_def that)
      have II: \<open>phi1.inv_morph ` \<phi>\<^sub>1 ` w\<^sub>3 = w\<^sub>3\<close>
        supply T = subsetD[OF phi_phi1.src.worlds_are_made_of_particulars,OF DD(1)]
        using T by (auto simp: image_iff HH)
      show ?thesis
        by (simp add: GG[symmetric] II DD(1))
    qed

    have ex_ex_1: \<open>(\<exists>y\<^sub>1\<in>w\<^sub>s. phi1.src_inheres_in y\<^sub>1 x \<and> \<phi> y = (\<phi> \<circ> \<phi>\<^sub>1) y\<^sub>1)
        \<longleftrightarrow>
          (\<exists>y\<^sub>1\<in>w\<^sub>s. phi1.src_inheres_in y\<^sub>1 x \<and> y = \<phi>\<^sub>1 y\<^sub>1)\<close>
      if \<open>y \<in> w\<^sub>t\<close> \<open>w\<^sub>t \<in> phi1.tgt.\<W>\<close> for y w\<^sub>t w\<^sub>s x
    proof -
      have AA[intro!,simp]: \<open>y \<in> phi1.tgt.\<P>\<close> using that by blast

      show ?thesis
        apply (intro iffI ; elim bexE conjE)
        subgoal for y\<^sub>1
          apply (intro bexI[of _ y\<^sub>1] conjI)
          subgoal using that AA by simp
          subgoal using that AA
            apply simp
            by (meson AA I2.morph_is_injective inj_onD phi1_img phi_phi1.src.inherence_scope)
          subgoal using that AA by simp
          done
        subgoal for y\<^sub>1
          by (intro bexI[of _ y\<^sub>1] conjI ; simp add: that)
        done
    qed

    interpret phi1: particular_struct_morphism \<Gamma> \<Gamma>\<^sub>1 \<phi>\<^sub>1
      apply (unfold_locales ; simp only: phi1_w_c simp_thms)
      subgoal G1 premises P for w\<^sub>1
        using phi_phi1.morph_worlds_correspond_src_tgt[OF P]
        apply (elim exE)
        subgoal premises Q for w\<^sub>2
          apply (rule phi_phi1.world_corresp_E[OF Q])
          subgoal premises T
            apply (intro exI[of _ \<open>I1.inv_morph ` w\<^sub>2\<close>] conjI)
            subgoal using Q T(2) by simp
            using T(2) by (simp add: I1.world_preserve_inv_img1)
          done
        done
      subgoal G2 premises P for w\<^sub>1
        apply (intro exI[of _ \<open>phi1.inv_morph ` (w\<^sub>1 \<inter> \<phi>\<^sub>1 ` phi_phi1.src.\<P>)\<close>] conjI)
        apply (intro phi1_w_c[THEN iffD1,THEN conjunct1]
                phi1.world_corresp_I P iffI ; simp)
        using P apply auto
        subgoal G2_1 using R4 by blast
        subgoal G2_2 by (simp add: assms1(2) phi1.inv_morph_def)
        by (metis IntI assms1(2) image_iff inv_into_f_f phi1.inv_morph_def)
      done

    interpret phi1: particular_struct_injection \<Gamma> \<Gamma>\<^sub>1 \<phi>\<^sub>1
      using assms1(2) by unfold_locales

    show ?thesis
      apply (intro conjI iffI ; (elim conjE)?)
      subgoal using phi1.particular_struct_injection_axioms by blast
      subgoal using phi_phi1.particular_struct_injection_axioms by blast
      by blast
  qed
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> finite_card_sub_structure_by_lteq:
  fixes \<Gamma>\<^sub>1 :: \<open>('p\<^sub>1,'q) particular_struct\<close> and
        \<Gamma>\<^sub>2 :: \<open>('p\<^sub>2,'q) particular_struct\<close>
  assumes \<open>finite (particulars \<Gamma>\<^sub>2)\<close> \<open>\<Gamma>\<^sub>1 \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>2\<close>
  shows \<open>card (particulars \<Gamma>\<^sub>1) \<le> card (particulars \<Gamma>\<^sub>2)\<close>
proof -
  interpret phi: particular_struct_injection \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<phi> \<open>TYPE('p\<^sub>1)\<close> \<open>TYPE('p\<^sub>2)\<close> \<open>TYPE('q)\<close>
    using assms by simp
  have A: \<open>finite (particulars \<Gamma>\<^sub>1)\<close>
    using finite_image_iff[OF phi.morph_is_injective,THEN iffD1,
          OF finite_subset,of \<open>particulars \<Gamma>\<^sub>2\<close>] assms(1) by blast
  show ?thesis
    using A assms(1) phi.morph_is_injective
    by (metis card_image card_mono phi.morph_image_def phi.morph_scope)
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> finite_card_substruct_lt:
  fixes \<Gamma>\<^sub>1 :: \<open>('p\<^sub>1,'q) particular_struct\<close> and
        \<Gamma>\<^sub>2 :: \<open>('p\<^sub>2,'q) particular_struct\<close>
  assumes \<open>finite (particulars \<Gamma>\<^sub>2)\<close> \<open>\<Gamma>\<^sub>1 \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>2\<close> \<open>\<forall>\<phi>. \<not> \<Gamma>\<^sub>2 \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>1\<close>
  shows \<open>card (particulars \<Gamma>\<^sub>1) < card (particulars \<Gamma>\<^sub>2)\<close>
proof -
  interpret phi: particular_struct_injection \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<phi> \<open>TYPE('p\<^sub>1)\<close> \<open>TYPE('p\<^sub>2)\<close> \<open>TYPE('q)\<close>
    using assms by simp
  have A: \<open>finite (particulars \<Gamma>\<^sub>1)\<close>
    using finite_image_iff[OF phi.morph_is_injective,THEN iffD1,
          OF finite_subset,of \<open>particulars \<Gamma>\<^sub>2\<close>] assms(1) by blast
  have B: \<open>card (particulars \<Gamma>\<^sub>1) \<le> card (particulars \<Gamma>\<^sub>2)\<close>
    using A assms(1) phi.morph_is_injective
    by (metis card_image card_mono phi.morph_image_def phi.morph_scope)

  have C: \<open>card (particulars \<Gamma>\<^sub>1) \<noteq> card (particulars \<Gamma>\<^sub>2)\<close>
  proof
    assume AA: \<open>card (particulars \<Gamma>\<^sub>1) = card (particulars \<Gamma>\<^sub>2)\<close>
    then have \<open>bij_betw \<phi> (particulars \<Gamma>\<^sub>1) (particulars \<Gamma>\<^sub>2)\<close>
      using assms(1) A phi.morph_is_injective
      by (metis B card_image card_seteq phi.morph_bij_on_img phi.morph_image_def phi.morph_scope)
    then interpret phi: particular_struct_bijection \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<phi> \<open>TYPE('p\<^sub>1)\<close> \<open>TYPE('p\<^sub>2)\<close> \<open>TYPE('q)\<close>
      apply unfold_locales
      by (simp add: bij_betw_def)
    interpret phi_inv:  particular_struct_bijection \<Gamma>\<^sub>2 \<Gamma>\<^sub>1 \<open>phi.inv_morph\<close> \<open>TYPE('p\<^sub>2)\<close> \<open>TYPE('p\<^sub>1)\<close> \<open>TYPE('q)\<close>
      by simp
    show False using assms
      phi_inv.particular_struct_injection_axioms by simp
  qed
  then show ?thesis using B by auto
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> finite_card_sub_structure_by_finite:
  fixes \<Gamma>\<^sub>1 :: \<open>('p\<^sub>1,'q) particular_struct\<close> and
        \<Gamma>\<^sub>2 :: \<open>('p\<^sub>2,'q) particular_struct\<close>
  assumes \<open>finite (particulars \<Gamma>\<^sub>2)\<close> \<open>\<Gamma>\<^sub>1 \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>2\<close>
  shows \<open>finite (particulars \<Gamma>\<^sub>1)\<close>
proof -
  interpret phi: particular_struct_injection \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<phi> using assms by simp
  show ?thesis
    using assms phi.morph_is_injective
          finite_image_iff finite_subset phi.morph_scope
    by fastforce
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> isomorphic_by_sub_structure_transf_inv:
  assumes \<open>\<Gamma>\<^sub>1 \<sim>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>2\<close>
  shows \<open>\<Gamma> \<lless>\<^bsub>invMorph \<Gamma>\<^sub>1 \<phi> \<circ> \<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>1 \<and> \<phi>\<^sub>1 ` particulars \<Gamma> \<subseteq> particulars \<Gamma>\<^sub>2 \<longleftrightarrow>
         \<Gamma> \<lless>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>2\<close>
  using isomorphic_by_sub_structure_transf[OF isomorphic_by_sym] assms by metis

lemma \<^marker>\<open>tag (proof) aponly\<close> sub_structure_by_finite_weak_antisym[intro]:
  fixes \<Gamma>\<^sub>1 :: \<open>('p\<^sub>1,'q) particular_struct\<close> and
        \<Gamma>\<^sub>2 :: \<open>('p\<^sub>2,'q) particular_struct\<close>
  assumes \<open>\<Gamma>\<^sub>1 \<lless>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>2\<close> \<open>\<Gamma>\<^sub>2 \<lless>\<^bsub>\<phi>\<^sub>2\<^esub> \<Gamma>\<^sub>1\<close> \<open>finite (particulars \<Gamma>\<^sub>1)\<close>
  shows \<open>\<Gamma>\<^sub>1 \<sim>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>2\<close>
proof -
  interpret phi1: particular_struct_injection \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<phi>\<^sub>1 using assms(1) .
  interpret phi2: particular_struct_injection \<Gamma>\<^sub>2 \<Gamma>\<^sub>1 \<phi>\<^sub>2 using assms(2) .
  have A: \<open>inj_on (\<phi>\<^sub>2 \<circ> \<phi>\<^sub>1) phi1.src.\<P>\<close>
    using comp_inj_on phi1.morph_is_injective phi2.morph_is_injective
      phi1.morph_scope
    by (metis phi1.morph_image_def subset_inj_on)
  then have A1: \<open>inj_on \<phi>\<^sub>1 phi1.src.\<P>\<close> by blast
  have A2: \<open>inj_on \<phi>\<^sub>2 (\<phi>\<^sub>1 ` phi1.src.\<P>)\<close>
    using A A1 inj_on_imageI by blast
  have B: \<open>f ` A = B\<close> if
      \<open>inj_on f A\<close> \<open>finite A\<close> \<open>f ` A \<subseteq> B\<close>
      \<open>inj_on g B\<close>  \<open>g ` B \<subseteq> A\<close>
    for A :: \<open>'p\<^sub>1 set\<close> and B :: \<open>'p\<^sub>2 set\<close> and f g
    using that
    by (metis card_bij_eq card_image card_subset_eq inj_on_finite)
  have bij: \<open>bij_betw \<phi>\<^sub>1 phi1.src.\<P> phi1.tgt.\<P>\<close>
    apply (simp add: bij_betw_def)
    apply (intro B[of _ _ _ \<phi>\<^sub>2] ; simp?)
    using assms(3) by blast+
  then show ?thesis
    apply (unfold_locales)
    by (simp add: bij_betw_def)
qed

end


theory Punc_Proofs
  imports Punc_Specification "General_Proofs"
begin

lemma nonempty_msg_space[simp]: "msg_space () \<noteq> {}"
  using msg_space_element by blast

lemma weight_uniform_msg_space[simp]: "weight (uniform (msg_space ())) = 1"
  by simp

lemma aux1: "x\<in>supp (uniform (msg_space ())) \<Longrightarrow> x \<in> msg_space0 ()"
  using msg_space nonempty_msg_space by auto

lemma aux2[simp]: "force_into (msg_space0 ()) puncture = puncture"
  using force_into_good puncture by fastforce

lemma aux3[simp]: "force_into (msg_space0 ()) (force_into (msg_space0 ()) m0star2) = force_into (msg_space0 ()) m0star2"
  apply (rule force_into_good)
  apply (rule force_into_bad)
  using msg_space nonempty_msg_space by auto

lemma aux4[simp]: "force_into (msg_space0 ()) (force_into (msg_space ()) m0star2) = force_into (msg_space ()) m0star2"
proof -
  have "force_into (msg_space ()) m0star2 \<in> msg_space ()"
    using nonempty_msg_space by (simp add: force_into_bad)
  then have "force_into (msg_space ()) m0star2 \<in> msg_space0 ()"
    using msg_space by auto
  then show ?thesis
    by (rule force_into_good)
qed

lemma supp_params0[simp]: "supp params0 = {()}"
  unfolding params0_def by auto

lemma supp_params[simp]: "supp params = {()}"
  unfolding params_def by simp

lemma [simp]: "keygen () \<noteq> 0"
  unfolding keygen_def using weight_keygen0 by fastforce

end


header{*Theory of Agents and Messages for Security Protocols against the General Attacker*}

theory MessageGA imports Main begin

(*Needed occasionally with spy_analz_tac, e.g. in analz_insert_Key_newK*)
lemma [simp] : "A \<union> (B \<union> A) = B \<union> A"
by blast

type_synonym
  key = nat

consts
  all_symmetric :: bool        --{*true if all keys are symmetric*}
  invKey        :: "key=>key"  --{*inverse of a symmetric key*}

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric --> invKey = id"
    by (rule exI [of _ id], auto)

text{*The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa*}

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"

datatype  --{*We only allow for any number of friendly agents*}
  agent = Friend nat

datatype
     msg = Agent  agent     --{*Agent names*}
         | Number nat       --{*Ordinary integers, timestamps, ...*}
         | Nonce  nat       --{*Unguessable nonces*}
         | Key    key       --{*Crypto keys*}
         | Hash   msg       --{*Hashing*}
         | MPair  msg msg   --{*Compound messages*}
         | Crypt  key msg   --{*Encryption, public- or shared-key*}

text{*Concrete syntax: messages appear as {|A,B,NA|}, etc...*}
syntax
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2{|_,/ _|})")

syntax (xsymbols)
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2\<lbrace>_,/ _\<rbrace>)")

translations
  "{|x, y, z|}"   == "{|x, {|y, z|}|}"
  "{|x, y|}"      == "CONST MPair x y"

definition HPair :: "[msg,msg] => msg" ("(4Hash[_] /_)" [0, 1000]) where
    --{*Message Y paired with a MAC computed with the help of X*}
    "Hash[X] Y == {| Hash{|X,Y|}, Y|}"

definition keysFor :: "msg set => key set" where
    --{*Keys useful to decrypt elements of a message set*}
  "keysFor H == invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsection{*Inductive definition of all parts of a message*}

inductive_set
  parts :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro]:               "X \<in> H ==> X \<in> parts H"
  | Fst:         "{|X,Y|}   \<in> parts H ==> X \<in> parts H"
  | Snd:         "{|X,Y|}   \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

text{*Monotonicity*}
lemma parts_mono: "G \<subseteq> H ==> parts(G) \<subseteq> parts(H)"
apply auto
apply (erule parts.induct)
apply (blast dest: parts.Fst parts.Snd parts.Body)+
done

text{*Equations hold because constructors are injective.*}
lemma Friend_image_eq [simp]: "(Friend x \<in> Friend`A) = (x:A)"
by auto

lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
by auto

lemma Nonce_Key_image_eq [simp]: "(Nonce x \<notin> Key`A)"
by auto

subsection{*Inverse of keys *}

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K=K')"
by (metis invKey)

subsection{*keysFor operator*}

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

text{*Monotonicity*}
lemma keysFor_mono: "G \<subseteq> H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert {|X,Y|} H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection{*Inductive relation "parts"*}

lemma MPair_parts:
     "[| {|X,Y|} \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!]  parts.Body [dest!]
text{*NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  @{text MPair_parts} is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.*}

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct, blast+)
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

text{*WARNING: loops if H = {Y}, therefore must not be repeated!*}
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
by (erule parts.induct, fast+)

subsubsection{*Unions *}

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
by (metis insert_is_Un parts_Un)

text{*TWO inserts to avoid looping.  This rewrite is better than nothing.
  Not suitable for Addsimps: its behaviour can be strange.*}
lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
by (metis Un_commute Un_empty_right Un_insert_right insert_is_Un parts_Un)

lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)

lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_UN [simp]: "parts(\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts(H x))"
by (intro equalityI parts_UN_subset1 parts_UN_subset2)

text{*Added to simplify arguments to parts, analz and synth.
  NOTE: the UN versions are no longer used!*}

text{*This allows @{text blast} to simplify occurrences of
  @{term "parts(G\<union>H)"} in the assumption.*}
lemmas in_parts_UnE = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]
declare in_parts_UnE [elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection{*Idempotence and transitivity *}

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_subset_iff [simp]: "(parts G \<subseteq> parts H) = (G \<subseteq> parts H)"
by (metis parts_idem parts_increasing parts_mono subset_trans)

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (drule parts_mono, blast)

text{*Cut*}
lemma parts_cut:
     "[| Y\<in> parts (insert X G);  X\<in> parts H |] ==> Y\<in> parts (G \<union> H)"
by (blast intro: parts_trans)

lemma parts_cut_eq [simp]: "X\<in> parts H ==> parts (insert X H) = parts H"
by (force dest!: parts_cut intro: parts_insertI)

subsubsection{*Rewrite rules for pulling out atomic messages *}

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Number [simp]:
     "parts (insert (Number N) H) = insert (Number N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Hash [simp]:
     "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) = insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Body)
done

lemma parts_insert_MPair [simp]:
     "parts (insert {|X,Y|} H) =
          insert {|X,Y|} (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
apply auto
apply (erule parts.induct, auto)
done

text{*In any message, there is an upper bound N on its greatest nonce.*}
lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n --> Nonce n \<notin> parts {msg}"
apply (induct msg)
apply (simp_all (no_asm_simp) add: exI parts_insert2)
txt{*Nonce case*}
apply (metis Suc_n_not_le_n)
txt{*MPair case: metis works out the necessary sum itself!*}
apply (metis le_trans nat_le_linear)
done

subsection{*Inductive relation "analz"*}

text{*Inductive definition of "analz" -- what can be broken down from a set of
    messages, including keys.  A form of downward closure.  Pairs can
    be taken apart; messages decrypted with known keys.  *}

inductive_set
  analz :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] :    "X \<in> H ==> X \<in> analz H"
  | Fst:     "{|X,Y|} \<in> analz H ==> X \<in> analz H"
  | Snd:     "{|X,Y|} \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "[|Crypt K X \<in> analz H; Key(invKey K): analz H|] ==> X \<in> analz H"

text{*Monotonicity; Lemma 1 of Lowe's paper*}
lemma analz_mono: "G\<subseteq>H ==> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd)
done

text{*Making it safe speeds up proofs*}
lemma MPair_analz [elim!]:
     "[| {|X,Y|} \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
by (metis analz_increasing analz_subset_parts equalityI parts_mono parts_subset_iff)

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection{*General equational properties *}

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

text{*Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other*}
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection{*Rewrite rules for pulling out atomic messages *}

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Number [simp]:
     "analz (insert (Number N) H) = insert (Number N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Hash [simp]:
     "analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

text{*Can only pull out Keys if they are not needed to decrypt the rest*}
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert {|X,Y|} H) =
          insert {|X,Y|} (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

text{*Can pull out enCrypted message if the Key is not known*}
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)

done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

text{*Case analysis: either the message is secure, or it is not! Effective,
but can cause subgoals to blow up! Use with @{text "split_if"}; apparently
@{text "split_tac"} does not cope with patterns such as @{term"analz (insert
(Crypt K X) H)"} *}
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

text{*This rule supposes "for the sake of argument" that we have the key.*}
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

subsubsection{*Idempotence and transitivity *}

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_subset_iff [simp]: "(analz G \<subseteq> analz H) = (G \<subseteq> analz H)"
by (metis analz_idem analz_increasing analz_mono subset_trans)

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

text{*Cut; Lemma 2 of Lowe*}
lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (erule analz_trans, blast)

(*Cut can be proved easily by induction on
   "Y: analz (insert X H) ==> X: analz H --> Y: analz H"
*)

text{*This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated. *}
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI)

text{*A congruence rule for "analz" *}

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H' |]
      ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
apply simp
apply (iprover intro: conjI subset_trans analz_mono Un_upper1 Un_upper2)
done

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H' |]
      ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

text{*If there are no pairs or encryptions then analz does nothing*}
lemma analz_trivial:
     "[| \<forall>X Y. {|X,Y|} \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

text{*These two are obsolete but cost little to prove...*}
lemma analz_UN_analz_lemma:
     "X\<in> analz (\<Union>i\<in>A. analz (H i)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
done

lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])

subsection{*Inductive relation "synth"*}

text{*Inductive definition of "synth" -- what can be built up from a set of
    messages.  A form of upward closure.  Pairs can be built, messages
    encrypted with known keys.  Agent names are public domain.
    Numbers can be guessed, but Nonces cannot be.  *}

inductive_set
  synth :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | Number [intro]:   "Number n  \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H ==> Hash X \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> {|X,Y|} \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

text{*Monotonicity*}
lemma synth_mono: "G\<subseteq>H ==> synth(G) \<subseteq> synth(H)"
  by (auto, erule synth.induct, auto)

text{*NO @{text Agent_synth}, as any Agent name can be synthesized.
  The same holds for @{term Number}*}

inductive_simps synth_simps [iff]:
 "Nonce n \<in> synth H"
 "Key K \<in> synth H"
 "Hash X \<in> synth H"
 "{|X,Y|} \<in> synth H"
 "Crypt K X \<in> synth H"

lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection{*Unions *}

text{*Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.*}
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])

subsubsection{*Idempotence and transitivity *}

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, auto)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_subset_iff [simp]: "(synth G \<subseteq> synth H) = (G \<subseteq> synth H)"
by (metis subset_trans synth_idem synth_increasing synth_mono)

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

text{*Cut; Lemma 2 of Lowe*}
lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (erule synth_trans, blast)

lemma Agent_synth [simp]: "Agent A \<in> synth H"
by blast

lemma Number_synth [simp]: "Number n \<in> synth H"
by blast

lemma Nonce_synth_eq [simp]: "(Nonce N \<in> synth H) = (Nonce N \<in> H)"
by blast

lemma Crypt_synth_eq [simp]:
     "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection{*Combinations of parts, analz and synth *}

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD]
                    parts.Fst parts.Snd parts.Body)+
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
prefer 5 apply (blast intro: analz_mono [THEN [2] rev_subsetD])
apply (blast intro: analz.Fst analz.Snd analz.Decrypt)+
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
by (metis Un_empty_right analz_synth_Un)

subsubsection{*For reasoning about the Fake rule in traces *}

lemma parts_insert_subset_Un: "X\<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (metis UnCI Un_upper2 insert_subset parts_Un parts_mono)

text{*More specifically for Fake. See also @{text Fake_parts_sing} below *}
lemma Fake_parts_insert:
     "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
by (metis Un_commute analz_increasing insert_subset parts_analz parts_mono
          parts_synth synth_mono synth_subset_iff)

lemma Fake_parts_insert_in_Un:
     "[|Z \<in> parts (insert X H);  X: synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (metis Fake_parts_insert set_mp)

text{*@{term H} is sometimes @{term"Key ` KK \<union> spies evs"}, so can't put
  @{term "G=H"}.*}
lemma Fake_analz_insert:
     "X\<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H)", force)
apply (blast intro: analz_mono [THEN [2] rev_subsetD] analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
done

lemma analz_conj_parts [simp]:
     "(X \<in> analz H & X \<in> parts H) = (X \<in> analz H)"
by (blast intro: analz_subset_parts [THEN subsetD])

lemma analz_disj_parts [simp]:
     "(X \<in> analz H | X \<in> parts H) = (X \<in> parts H)"
by (blast intro: analz_subset_parts [THEN subsetD])

text{*Without this equation, other rules for synth and analz would yield
  redundant cases*}
lemma MPair_synth_analz [iff]:
     "({|X,Y|} \<in> synth (analz H)) =
      (X \<in> synth (analz H) & Y \<in> synth (analz H))"
by blast

lemma Crypt_synth_analz:
     "[| Key K \<in> analz H;  Key (invKey K) \<in> analz H |]
       ==> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast

lemma Hash_synth_analz [simp]:
     "X \<notin> synth (analz H)
      ==> (Hash{|X,Y|} \<in> synth (analz H)) = (Hash{|X,Y|} \<in> analz H)"
by blast

subsection{*HPair: a combination of Hash and MPair*}

subsubsection{*Freeness *}

lemma Agent_neq_HPair: "Agent A ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Nonce_neq_HPair: "Nonce N ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Number_neq_HPair: "Number N ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Key_neq_HPair: "Key K ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Hash_neq_HPair: "Hash Z ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Crypt_neq_HPair: "Crypt K X' ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemmas HPair_neqs = Agent_neq_HPair Nonce_neq_HPair Number_neq_HPair
                    Key_neq_HPair Hash_neq_HPair Crypt_neq_HPair

declare HPair_neqs [iff]
declare HPair_neqs [symmetric, iff]

lemma HPair_eq [iff]: "(Hash[X'] Y' = Hash[X] Y) = (X' = X & Y'=Y)"
by (simp add: HPair_def)

lemma MPair_eq_HPair [iff]:
     "({|X',Y'|} = Hash[X] Y) = (X' = Hash{|X,Y|} & Y'=Y)"
by (simp add: HPair_def)

lemma HPair_eq_MPair [iff]:
     "(Hash[X] Y = {|X',Y'|}) = (X' = Hash{|X,Y|} & Y'=Y)"
by (auto simp add: HPair_def)

subsubsection{*Specialized laws, proved in terms of those for Hash and MPair *}

lemma keysFor_insert_HPair [simp]: "keysFor (insert (Hash[X] Y) H) = keysFor H"
by (simp add: HPair_def)

lemma parts_insert_HPair [simp]:
    "parts (insert (Hash[X] Y) H) =
     insert (Hash[X] Y) (insert (Hash{|X,Y|}) (parts (insert Y H)))"
by (simp add: HPair_def)

lemma analz_insert_HPair [simp]:
    "analz (insert (Hash[X] Y) H) =
     insert (Hash[X] Y) (insert (Hash{|X,Y|}) (analz (insert Y H)))"
by (simp add: HPair_def)

lemma HPair_synth_analz [simp]:
     "X \<notin> synth (analz H)
    ==> (Hash[X] Y \<in> synth (analz H)) =
        (Hash {|X, Y|} \<in> analz H & Y \<in> synth (analz H))"
by (auto simp add: HPair_def)

text{*We do NOT want Crypt... messages broken up in protocols!!*}
declare parts.Body [rule del]

text{*Rewrites to push in Key and Crypt messages, so that other messages can
    be pulled out using the @{text analz_insert} rules*}

lemmas pushKeys =
  insert_commute [of "Key K" "Agent C"]
  insert_commute [of "Key K" "Nonce N"]
  insert_commute [of "Key K" "Number N"]
  insert_commute [of "Key K" "Hash X"]
  insert_commute [of "Key K" "MPair X Y"]
  insert_commute [of "Key K" "Crypt X K'"]
  for K C N X Y K'

lemmas pushCrypts =
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Nonce N"]
  insert_commute [of "Crypt X K" "Number N"]
  insert_commute [of "Crypt X K" "Hash X'"]
  insert_commute [of "Crypt X K" "MPair X' Y"]
  for X K C N X' Y

text{*Cannot be added with @{text "[simp]"} -- messages should not always be
  re-ordered. *}
lemmas pushes = pushKeys pushCrypts

subsection{*The set of key-free messages*}

(*Note that even the encryption of a key-free message remains key-free.
  This concept is valuable because of the theorem analz_keyfree_into_Un, proved below. *)

inductive_set
  keyfree :: "msg set"
  where
    Agent:  "Agent A \<in> keyfree"
  | Number: "Number N \<in> keyfree"
  | Nonce:  "Nonce N \<in> keyfree"
  | Hash:   "Hash X \<in> keyfree"
  | MPair:  "[|X \<in> keyfree;  Y \<in> keyfree|] ==> {|X,Y|} \<in> keyfree"
  | Crypt:  "[|X \<in> keyfree|] ==> Crypt K X \<in> keyfree"

declare keyfree.intros [intro]

inductive_cases keyfree_KeyE: "Key K \<in> keyfree"
inductive_cases keyfree_MPairE: "{|X,Y|} \<in> keyfree"
inductive_cases keyfree_CryptE: "Crypt K X \<in> keyfree"

lemma parts_keyfree: "parts (keyfree) \<subseteq> keyfree"
  by (clarify, erule parts.induct, auto elim!: keyfree_KeyE keyfree_MPairE keyfree_CryptE)

(*The key-free part of a set of messages can be removed from the scope of the analz operator.*)
lemma analz_keyfree_into_Un: "\<lbrakk>X \<in> analz (G \<union> H); G \<subseteq> keyfree\<rbrakk> \<Longrightarrow> X \<in> parts G \<union> analz H"
apply (erule analz.induct, auto)
apply (blast dest:parts.Body)
apply (blast dest: parts.Body)
apply (metis Un_absorb2 keyfree_KeyE parts_Un parts_keyfree UnI2)
done

subsection{*Tactics useful for many protocol proofs*}
ML
{*
(*Analysis of Fake cases.  Also works for messages that forward unknown parts,
  but this application is no longer necessary if analz_insert_eq is used.
  DEPENDS UPON "X" REFERRING TO THE FRADULENT MESSAGE *)

fun impOfSubs th = th RSN (2, @{thm rev_subsetD})

(*Apply rules to break down assumptions of the form
  Y \<in> parts(insert X H)  and  Y \<in> analz(insert X H)
*)
val Fake_insert_tac =
    dresolve_tac [impOfSubs @{thm Fake_analz_insert},
                  impOfSubs @{thm Fake_parts_insert}] THEN'
    eresolve_tac [asm_rl, @{thm synth.Inj}];

fun Fake_insert_simp_tac ss i =
  REPEAT (Fake_insert_tac i) THEN asm_full_simp_tac ss i;

fun atomic_spy_analz_tac ctxt =
  SELECT_GOAL
   (Fake_insert_simp_tac ctxt 1 THEN
    IF_UNSOLVED
      (Blast.depth_tac
        (ctxt addIs [@{thm analz_insertI}, impOfSubs @{thm analz_subset_parts}]) 4 1));

fun spy_analz_tac ctxt i =
  DETERM
   (SELECT_GOAL
     (EVERY
      [  (*push in occurrences of X...*)
       (REPEAT o CHANGED)
           (res_inst_tac ctxt [(("x", 1), "X")] (insert_commute RS ssubst) 1),
       (*...allowing further simplifications*)
       simp_tac ctxt 1,
       REPEAT (FIRSTGOAL (resolve_tac [allI,impI,notI,conjI,iffI])),
       DEPTH_SOLVE (atomic_spy_analz_tac ctxt 1)]) i);
*}

text{*By default only @{text o_apply} is built-in.  But in the presence of
eta-expansion this means that some terms displayed as @{term "f o g"} will be
rewritten, and others will not!*}
declare o_def [simp]

lemma Crypt_notin_image_Key [simp]: "Crypt K X \<notin> Key ` A"
by auto

lemma Hash_notin_image_Key [simp] :"Hash X \<notin> Key ` A"
by auto

lemma synth_analz_mono: "G\<subseteq>H ==> synth (analz(G)) \<subseteq> synth (analz(H))"
by (iprover intro: synth_mono analz_mono)

lemma Fake_analz_eq [simp]:
     "X \<in> synth(analz H) ==> synth (analz (insert X H)) = synth (analz H)"
by (metis Fake_analz_insert Un_absorb Un_absorb1 Un_commute
          subset_insertI synth_analz_mono synth_increasing synth_subset_iff)

text{*Two generalizations of @{text analz_insert_eq}*}
lemma gen_analz_insert_eq [rule_format]:
     "X \<in> analz H ==> ALL G. H \<subseteq> G --> analz (insert X G) = analz G"
by (blast intro: analz_cut analz_insertI analz_mono [THEN [2] rev_subsetD])

lemma synth_analz_insert_eq [rule_format]:
     "X \<in> synth (analz H)
      ==> ALL G. H \<subseteq> G --> (Key K \<in> analz (insert X G)) = (Key K \<in> analz G)"
apply (erule synth.induct)
apply (simp_all add: gen_analz_insert_eq subset_trans [OF _ subset_insertI])
done

lemma Fake_parts_sing:
     "X \<in> synth (analz H) ==> parts{X} \<subseteq> synth (analz H) \<union> parts H"
by (metis Fake_parts_insert empty_subsetI insert_mono parts_mono subset_trans)

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

method_setup spy_analz = {*
    Scan.succeed (SIMPLE_METHOD' o spy_analz_tac) *}
    "for proving the Fake case when analz is involved"

method_setup atomic_spy_analz = {*
    Scan.succeed (SIMPLE_METHOD' o atomic_spy_analz_tac) *}
    "for debugging spy_analz"

method_setup Fake_insert_simp = {*
    Scan.succeed (SIMPLE_METHOD' o Fake_insert_simp_tac) *}
    "for debugging spy_analz"

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_nat_boring_gt_asymmetric
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun lt :: "Nat => Nat => bool" where
"lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S n) (S z) = lt n z"

fun gt :: "Nat => Nat => bool" where
"gt x y = lt y x"

theorem property0 :
  "((gt x y) ==> (~ (gt y x)))"
  oops

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory MuddyChildren
imports ClockView SPRViewDet
begin
(*>*)

subsection\<open>The Muddy Children\<close>

text\<open>

\label{sec:kbps-theory-mc}

Our first example of a multi-agent broadcast scenario is the classic
muddy children puzzle, one of a class of such puzzles that exemplify
non-obvious reasoning about mutual states of knowledge. It goes as
follows \citep[\S1.1, Example~7.2.5]{FHMV:1995}:
\begin{quotation}

  $N$ children are playing together, $k$ of whom get mud on their
  foreheads. Each can see the mud on the others' foreheads but not
  their own.

  A parental figure appears and says ``At least one of you has mud on your
  forehead.'', expressing something already known to each of them if $k >
  1$.

  The parental figure then asks ``Does any of you know whether you have mud
  on your own forehead?'' over and over.

  Assuming the children are perceptive, intelligent, truthful and they
  answer simultaneously, what will happen?
\end{quotation}
This puzzle relies essentially on \emph{synchronous public broadcasts}
making particular facts \emph{common knowledge}, and that agents are
capable of the requisite logical inference.

As the mother has complete knowledge of the situation, we integrate
her behaviour into the environment. Each agent $\mbox{child}_i$
reasons with the following KBP:
\begin{center}
  \begin{tabular}{lll}
    $\mathbf{do}$\\
     & $\gcalt\ \hat{\mathbf{K}}_{\mbox{child}_i} \mbox{muddy}_i$ & $\<open>\<rightarrow>\<close>$ Say ``I know if my forehead is muddy''\\
     & $\gcalt\ \<open>\<not>\<close>\hat{\mathbf{K}}_{\mbox{child}_i} \mbox{muddy}_i$ & $\<open>\<rightarrow>\<close>$ Say nothing\\
    $\mathbf{od}$\\
  \end{tabular}
\end{center}
where $\hat{\mathbf{K}}_a \<open>\<phi>\<close>$ abbreviates $\mathbf{K}_a
\<open>\<phi>\<close>\ \<open>\<or>\<close>\ \mathbf{K}_a \<open>\<not>\<phi>\<close>$.

As this protocol is deterministic, we use the SPR algorithm of
\S\ref{sec:kbps-theory-spr-deterministic-protocols}.

\begin{wrapfigure}{r}{0.5\textwidth}
  \vspace{-20pt}
  \includegraphics[width=0.48\textwidth]{MC}
  \vspace{-10pt}
  \caption{The protocol of $\mbox{child}_0$.}
  \label{fig:mc}
\end{wrapfigure}

The model records a child's initial observation of the mother's
pronouncement and the muddiness of the other children in her initial
private state, and these states are not changed by @{term
"envTrans"}. The recurring common observation is all of the children's
public responses to the mother's questions. Being able to distinguish
these observations is crucial to making this a broadcast scenario.

Running the algorithm for three children and minimising using
Hopcroft's algorithm yields the automaton in Figure~\ref{fig:mc} for
$\mbox{child}_0$. The initial transitions are labelled with the
initial observation, i.e., the cleanliness ``C'' or muddiness ``M'' of
the other two children. The dashed initial transition covers the case
where everyone is clean; in the others the mother has announced that
someone is dirty. Later transitions simply record the actions
performed by each of the agents, where ``K'' is the first action in
the above KBP, and ``N'' the second. Double-circled states are those
in which $\mbox{child}_0$ knows whether she is muddy, and
single-circled where she does not.

In essence the child counts the number of muddy foreheads she sees and
waits that many rounds before announcing that she knows.

Note that a solution to this puzzle is beyond the reach of the clock
semantics as it requires (in general) remembering the sequence of
previous broadcasts of length proportional to the number of
children. We discuss this further in \S\ref{sec:kbps-muddychildren}.

\<close>
(*<*)

datatype Agent = Child0 | Child1 | Child2
datatype Proposition = Dirty Agent

datatype ChildAct = SayIKnow | SayNothing

lemma Agent_univ: "(UNIV :: Agent set) = {Child0, Child1, Child2}"
  unfolding UNIV_def
  apply auto
  apply (case_tac x)
  apply auto
  done

instance Agent :: finite
  apply intro_classes
  apply (auto iff: Agent_univ)
  done

instantiation Agent :: linorder
begin

fun
  less_Agent
where
  "less_Agent Child0 Child0 = False"
| "less_Agent Child0 _      = True"
| "less_Agent Child1 Child2 = True"
| "less_Agent Child1 _      = False"
| "less_Agent Child2 _      = False"

definition
  less_eq_Agent :: "Agent \<Rightarrow> Agent \<Rightarrow> bool"
where
  "less_eq_Agent x y \<equiv> x = y \<or> x < y"

instance
  apply intro_classes
  unfolding less_eq_Agent_def
  apply (case_tac x, case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac x, case_tac y, case_tac z, simp_all)
  apply (case_tac x, case_tac z, simp_all)
  apply (case_tac x, case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac x, case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac y, simp_all)
  done
end

instantiation Agent :: enum
begin

definition
  "enum_class.enum = [Child0, Child1, Child2]"

definition
  "enum_class.enum_all P = (P Child0 \<and> P Child1 \<and> P Child2)"

definition
  "enum_class.enum_ex P = (P Child0 \<or> P Child1 \<or> P Child2)"

instance
  apply standard
  unfolding enum_Agent_def enum_all_Agent_def enum_ex_Agent_def
  by auto (case_tac x, auto)+

end

lemma Act_univ: "(UNIV :: ChildAct set) = {SayIKnow, SayNothing}"
  unfolding UNIV_def
  apply auto
  apply (case_tac x)
  apply auto
  done

instance ChildAct :: finite
  by standard (auto iff: Act_univ)

instantiation ChildAct :: enum
begin

definition
  "enum_class.enum = [SayIKnow, SayNothing]"

definition
  "enum_class.enum_all P = (P SayIKnow \<and> P SayNothing)"

definition
  "enum_class.enum_ex P = (P SayIKnow \<or> P SayNothing)"

instance
  apply standard
  unfolding enum_ChildAct_def enum_all_ChildAct_def enum_ex_ChildAct_def
  by auto (case_tac x, auto)+

end

instantiation ChildAct :: linorder
begin

fun
  less_ChildAct
where
  "less_ChildAct SayIKnow SayNothing = True"
| "less_ChildAct _ _ = False"

definition
  less_eq_ChildAct :: "ChildAct \<Rightarrow> ChildAct \<Rightarrow> bool"
where
  "less_eq_ChildAct x y \<equiv> x = y \<or> x < y"

instance
  apply intro_classes
  unfolding less_eq_ChildAct_def
  apply (case_tac x, case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac x, case_tac y, simp_all)
  apply (case_tac y, simp_all)
  done
end

type_synonym EnvAct = "unit"
type_synonym EnvState = "(bool \<times> bool \<times> bool) \<times> (ChildAct \<times> ChildAct \<times> ChildAct)"
type_synonym AgentState = "bool \<times> bool \<times> bool"
type_synonym GlobalState = "(Agent, EnvState, AgentState) BEState"

definition "agents \<equiv> fromList [Child0, Child1, Child2]"

fun
  aChildIsDirty :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"
where
  "aChildIsDirty False False False = False"
| "aChildIsDirty _ _ _ = True"

definition
  initPS :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> (Agent \<times> (bool \<times> bool \<times> bool)) odlist"
where
  "initPS c0 c1 c2 \<equiv>
     let acid = aChildIsDirty c0 c1 c2
      in fromList [ (Child0, (acid, c1, c2)), (Child1, (acid, c0, c2)), (Child2, (acid, c0, c1))]"

definition
  envInit :: "GlobalState list"
where
  "envInit \<equiv>
    let bu = [False, True]
     in [ \<lparr> es = ((c0, c1, c2), (SayNothing, SayNothing, SayNothing)), ps = initPS c0 c1 c2 \<rparr> .
             c0 \<leftarrow> bu, c1 \<leftarrow> bu, c2 \<leftarrow> bu ]"

(* The environment is passive, but it still needs to do something in
   each round for the system as a whole to evolve. *)

definition
  envAction :: "GlobalState \<Rightarrow> EnvAct list"
where
  "envAction \<equiv> \<lambda>_. [()]"

(* Transitions involve broadcasting the children's private actions,
leaving their private states unchanged. *)

definition
  envTransES :: "EnvAct \<Rightarrow> (Agent \<Rightarrow> ChildAct) \<Rightarrow> EnvState \<Rightarrow> EnvState"
where
  "envTransES \<equiv> \<lambda>eAct aAct s. (fst s, aAct Child0, aAct Child1, aAct Child2)"

definition
  envTrans :: "EnvAct \<Rightarrow> (Agent \<Rightarrow> ChildAct) \<Rightarrow> GlobalState \<Rightarrow> GlobalState"
where
  "envTrans eact aact s \<equiv> s \<lparr> es := envTransES eact aact (es s) \<rparr>"

(* Common observation: the actions of the agents. *)

definition "envObsC \<equiv> snd"

definition
  envVal :: "GlobalState \<Rightarrow> Proposition \<Rightarrow> bool"
where
  "envVal \<equiv> \<lambda>s p.
     case p of Dirty a \<Rightarrow>
       (case es s of ((c0, c1, c2), _) \<Rightarrow>
         (case a of
            Child0 \<Rightarrow> c0
          | Child1 \<Rightarrow> c1
          | Child2 \<Rightarrow> c2))"

(* FIXME This is a bit grot, this definition is already made for us in the locale. *)

definition "envObs \<equiv> \<lambda>a s. (envObsC (es s), ODList.lookup (ps s) a)"

(* The KBP. Clearly subjective and deterministic. *)

abbreviation
  "Kor \<phi> \<psi> \<equiv> Knot (Kand (Knot \<phi>) (Knot \<psi>))"

definition
  jkbp :: "Agent \<Rightarrow> (Agent, Proposition, ChildAct) KBP"
where
  "jkbp a = [ \<lparr> guard = Kor (\<^bold>K\<^sub>a (Kprop (Dirty a)))
                            (\<^bold>K\<^sub>a (Knot (Kprop (Dirty a)))), action = SayIKnow \<rparr>,
              \<lparr> guard = Kand (Knot (\<^bold>K\<^sub>a (Kprop (Dirty a))))
                             (Knot (\<^bold>K\<^sub>a (Knot (Kprop (Dirty a))))), action = SayNothing \<rparr> ]"

subsubsection\<open>Locale instantiations\<close>

interpretation MC: Environment jkbp envInit envAction envTrans envVal envObs
  apply unfold_locales
  apply (auto simp: jkbp_def)
  done

subsubsection\<open>The Clock view implementation\<close>

interpretation MC_Clock:
  FiniteLinorderEnvironment jkbp envInit envAction envTrans envVal envObs agents
  apply unfold_locales
  apply (simp add: Agent_univ agents_def)
  done

definition
  mc_ClockDFS
where
  "mc_ClockDFS \<equiv> ClockAutoDFS agents jkbp envInit envAction envTrans envVal envObs"

definition
  mc_ClockAlg
where
  "mc_ClockAlg \<equiv> mkClockAuto agents jkbp envInit envAction envTrans envVal envObs"

lemma (in FiniteLinorderEnvironment)
  "MC.Clock.implements mc_ClockAlg"
  unfolding mc_ClockAlg_def by (rule MC_Clock.mkClockAuto_implements)

subsubsection\<open>The SPR view implementation\<close>

interpretation MC_SPR:
  FiniteDetBroadcastEnvironment jkbp envInit envAction envTrans envVal envObs agents envObsC
  apply unfold_locales
  prefer 3
  apply (fold envObs_def envAction_def envTrans_def)
  apply clarify
  apply (erule MC.SPR.jkbpDetI)
   apply (simp add: jkbp_def)
   apply (auto simp: jkbp_def)[1]

  unfolding envAction_def envTrans_def envObs_def agents_def
  apply (simp_all add: Agent_univ jkbp_def)

  done

definition
  mc_SPRDFS
where
  "mc_SPRDFS \<equiv> SPRDetAutoDFS agents jkbp envInit envAction envTrans envVal envObsC envObs"

definition
  mc_SPRAlg
where
  "mc_SPRAlg \<equiv> mkSPRDetAuto agents jkbp envInit envAction envTrans envVal envObsC envObs"

lemma (in FiniteDetBroadcastEnvironment)
  "MC.SPR.implements mc_SPRAlg"
  unfolding mc_SPRAlg_def by (rule MC_SPR.mkSPRDetAuto_implements)

end
(*>*)