theory Pure_States
  imports Quantum_Extra2 "HOL-Eisbach.Eisbach"
begin

definition \<open>pure_state_target_vector F \<eta>\<^sub>F = (if ket default \<in> range (cblinfun_apply (F (butterfly \<eta>\<^sub>F \<eta>\<^sub>F)))
   then ket default
   else (SOME \<eta>'. norm \<eta>' = 1 \<and> \<eta>' \<in> range (cblinfun_apply (F (butterfly \<eta>\<^sub>F \<eta>\<^sub>F)))))\<close>

lemma pure_state_target_vector_eqI:
  assumes \<open>F (butterfly \<eta>\<^sub>F \<eta>\<^sub>F) = G (butterfly \<eta>\<^sub>G \<eta>\<^sub>G)\<close>
  shows \<open>pure_state_target_vector F \<eta>\<^sub>F = pure_state_target_vector G \<eta>\<^sub>G\<close>
  by (simp add: assms pure_state_target_vector_def)

lemma pure_state_target_vector_ket_default: \<open>pure_state_target_vector F \<eta>\<^sub>F = ket default\<close> if \<open>ket default \<in> range (cblinfun_apply (F (butterfly \<eta>\<^sub>F \<eta>\<^sub>F)))\<close>
  by (simp add: pure_state_target_vector_def that)

lemma
  assumes [simp]: \<open>\<eta>\<^sub>F \<noteq> 0\<close> \<open>register F\<close>
  shows pure_state_target_vector_in_range: \<open>pure_state_target_vector F \<eta>\<^sub>F \<in> range ((*\<^sub>V) (F (selfbutter \<eta>\<^sub>F)))\<close> (is ?range)
    and pure_state_target_vector_norm: \<open>norm (pure_state_target_vector F \<eta>\<^sub>F) = 1\<close> (is ?norm)
proof -
  from assms have \<open>selfbutter \<eta>\<^sub>F \<noteq> 0\<close>
    by (metis butterfly_0_right complex_vector.scale_zero_right inj_selfbutter_upto_phase)
  then have \<open>F (selfbutter \<eta>\<^sub>F) \<noteq> 0\<close>
    using register_inj[OF \<open>register F\<close>, THEN injD, where y=0]
    by (auto simp: complex_vector.linear_0)
  then obtain \<psi>' where \<psi>': \<open>F (selfbutter \<eta>\<^sub>F) *\<^sub>V \<psi>' \<noteq> 0\<close>
    by (meson cblinfun_eq_0_on_UNIV_span complex_vector.span_UNIV)
  have ex: \<open>\<exists>\<psi>. norm \<psi> = 1 \<and> \<psi> \<in> range ((*\<^sub>V) (F (selfbutter \<eta>\<^sub>F)))\<close>
    apply (rule exI[of _ \<open>(F (selfbutter \<eta>\<^sub>F) *\<^sub>V \<psi>') /\<^sub>C norm (F (selfbutter \<eta>\<^sub>F) *\<^sub>V \<psi>')\<close>])
    using \<psi>' apply (auto simp add: norm_inverse)
    by (metis cblinfun.scaleC_right rangeI)
  then show ?range
    by (metis (mono_tags, lifting) pure_state_target_vector_def verit_sko_ex')
  show ?norm
    apply (simp add: pure_state_target_vector_def)
    using ex by (metis (mono_tags, lifting) verit_sko_ex')
qed

lemma pure_state_target_vector_correct:
  assumes [simp]: \<open>\<eta> \<noteq> 0\<close> \<open>register F\<close>
  shows \<open>F (selfbutter \<eta>) *\<^sub>V pure_state_target_vector F \<eta> \<noteq> 0\<close>
proof -
  obtain \<psi> where \<psi>: \<open>F (selfbutter \<eta>) \<psi> = pure_state_target_vector F \<eta>\<close>
    apply atomize_elim
    using pure_state_target_vector_in_range[OF assms]
    by (smt (verit, best) image_iff top_ccsubspace.rep_eq top_set_def)

  define n where \<open>n = cinner \<eta> \<eta>\<close>
  then have \<open>n \<noteq> 0\<close>
    by auto

  have pure_state_target_vector_neq0: \<open>pure_state_target_vector F \<eta> \<noteq> 0\<close>
    using pure_state_target_vector_norm[OF assms]
    by auto

  have \<open>F (selfbutter \<eta>) *\<^sub>V pure_state_target_vector F \<eta> = F (selfbutter \<eta>) *\<^sub>V F (selfbutter \<eta>) *\<^sub>V \<psi>\<close>
    by (simp add: \<psi>)
  also have \<open>\<dots> = n *\<^sub>C F (selfbutter \<eta>) *\<^sub>V \<psi>\<close>
    by (simp flip: cblinfun_apply_cblinfun_compose add: register_mult register_scaleC n_def)
  also have \<open>\<dots> = n *\<^sub>C pure_state_target_vector F \<eta>\<close>
    by (simp add: \<psi>)
  also have \<open>\<dots> \<noteq> 0\<close>
    using pure_state_target_vector_neq0 \<open>n \<noteq> 0\<close>
    by auto
  finally show ?thesis
    by -
qed

definition \<open>pure_state' F \<psi> \<eta>\<^sub>F = F (butterfly \<psi> \<eta>\<^sub>F) *\<^sub>V pure_state_target_vector F \<eta>\<^sub>F\<close>

abbreviation \<open>pure_state F \<psi> \<equiv> pure_state' F \<psi> (ket default)\<close>

nonterminal pure_tensor
syntax "_pure_tensor" :: \<open>'a \<Rightarrow> 'b \<Rightarrow> pure_tensor \<Rightarrow> pure_tensor\<close> ("_ _ \<otimes>\<^sub>p _" [1000, 0, 0] 1000)
syntax "_pure_tensor2" :: \<open>'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> pure_tensor\<close> ("_ _ \<otimes>\<^sub>p _ _" [1000, 0, 1000, 0] 1000)
syntax "_pure_tensor1" :: \<open>'a \<Rightarrow> 'b \<Rightarrow> pure_tensor\<close>
syntax "_pure_tensor_start" :: \<open>pure_tensor \<Rightarrow> 'a\<close> ("'(_')")

translations
  "_pure_tensor2 F \<psi> G \<phi>" \<rightharpoonup> "CONST pure_state (F; G) (\<psi> \<otimes>\<^sub>s \<phi>)"
  "_pure_tensor F \<psi> (CONST pure_state G \<phi>)" \<rightharpoonup> "CONST pure_state (F; G) (\<psi> \<otimes>\<^sub>s \<phi>)"
  "_pure_tensor_start x" \<rightharpoonup> "x"

  "_pure_tensor_start (_pure_tensor2 F \<psi> G \<phi>)" \<leftharpoondown> "CONST pure_state (F; G) (\<psi> \<otimes>\<^sub>s \<phi>)"
  "_pure_tensor F \<psi> (_pure_tensor2 G \<phi> H \<eta>)" \<leftharpoondown> "_pure_tensor2 F \<psi> (G;H) (\<phi> \<otimes>\<^sub>s \<eta>)"

term \<open>(F \<psi> \<otimes>\<^sub>p G \<phi> \<otimes>\<^sub>p H z)\<close>
term \<open>pure_state (F; G) (a \<otimes>\<^sub>s b)\<close>

lemma register_pair_butterfly_tensor: \<open>(F; G) (butterfly (a \<otimes>\<^sub>s b) (c \<otimes>\<^sub>s d)) = F (butterfly a c) o\<^sub>C\<^sub>L G (butterfly b d)\<close>
  if [simp]: \<open>compatible F G\<close>
  by (auto simp: default_prod_def simp flip: tensor_ell2_ket tensor_butterfly register_pair_apply)

lemma pure_state_eqI:
  assumes \<open>F (selfbutter \<eta>\<^sub>F) = G (selfbutter \<eta>\<^sub>G)\<close>
  assumes \<open>F (butterfly \<psi> \<eta>\<^sub>F) = G (butterfly \<phi> \<eta>\<^sub>G)\<close>
  shows \<open>pure_state' F \<psi> \<eta>\<^sub>F = pure_state' G \<phi> \<eta>\<^sub>G\<close>
proof -
  from assms(1) have \<open>pure_state_target_vector F \<eta>\<^sub>F = pure_state_target_vector G \<eta>\<^sub>G\<close>
    by (rule pure_state_target_vector_eqI)
  with assms(2)
  show ?thesis
    unfolding pure_state'_def
    by simp
qed

definition \<open>regular_register F \<longleftrightarrow> register F \<and> (\<exists>a. (F; complement F) (selfbutterket default \<otimes>\<^sub>o a) = selfbutterket default)\<close>

lemma regular_registerI:
  assumes [simp]: \<open>register F\<close>
  assumes [simp]: \<open>complements F G\<close>
  assumes eq: \<open>(F; G) (selfbutterket default \<otimes>\<^sub>o a) = selfbutterket default\<close>
  shows \<open>regular_register F\<close>
proof -
  have [simp]: \<open>compatible F G\<close>
    using assms by (simp add: complements_def)
  from \<open>complements F G\<close>
  obtain I where cFI: \<open>complement F o I = G\<close> and \<open>iso_register I\<close>
    apply atomize_elim
    by (meson Laws_Complement_Quantum.complement_unique equivalent_registers_def equivalent_registers_sym)
  have \<open>(F; complement F) (selfbutterket default \<otimes>\<^sub>o I a) = (F; G) (selfbutterket default \<otimes>\<^sub>o a)\<close>
    using cFI by (auto simp: register_pair_apply)
  also have \<open>\<dots> = selfbutterket default\<close>
    by (rule eq)
  finally show ?thesis
    unfolding regular_register_def by auto
qed

lemma regular_register_pair:
  assumes [simp]: \<open>compatible F G\<close>
  assumes \<open>regular_register F\<close> and \<open>regular_register G\<close>
  shows \<open>regular_register (F;G)\<close>
proof -
  have [simp]: \<open>bij (F;complement F)\<close> \<open>bij (G;complement G)\<close>
    using assms(1) compatible_def complement_is_complement complements_def iso_register_bij by blast+
  have [simp]: \<open>bij ((F;G);complement (F;G))\<close>
    using assms(1) complement_is_complement complements_def iso_register_bij pair_is_register by blast
  have [simp]: \<open>register F\<close> \<open>register G\<close>
    using assms(1) unfolding compatible_def by auto

  obtain aF where [simp]: \<open>inv (F;complement F) (selfbutterket default) = selfbutterket default \<otimes>\<^sub>o aF\<close>
    by (metis assms(2) compatible_complement_right invI pair_is_register register_inj regular_register_def)
  obtain aG where [simp]: \<open>inv (G;complement G) (selfbutterket default) = selfbutterket default \<otimes>\<^sub>o aG\<close>
    by (metis assms(3) complement_is_complement complements_def inj_iff inv_f_f iso_register_inv_comp1 regular_register_def)
  define t1 where \<open>t1 = inv ((F;G); complement (F;G)) (selfbutterket default)\<close>
  define t2 where \<open>t2 = inv (F; (G; complement (F;G))) (selfbutterket default)\<close>
  define t3 where \<open>t3 = inv (G; (F; complement (F;G))) (selfbutterket default)\<close>

  have \<open>complements F (G; complement (F;G))\<close>
    apply (rule complements_complement_pair)
    by simp
  then have \<open>equivalent_registers (complement F) (G; complement (F;G))\<close>
    using Laws_Complement_Quantum.complement_unique equivalent_registers_sym by blast
  then obtain I where [simp]: \<open>iso_register I\<close> and I: \<open>(G; complement (F;G)) = complement F o I\<close>
    by (metis equivalent_registers_def)
  then have [simp]: \<open>register I\<close>
    by (meson iso_register_is_register)
  have [simp]: \<open>bij (id \<otimes>\<^sub>r I)\<close>
    by (rule iso_register_bij, simp)
  have [simp]: \<open>inv (id \<otimes>\<^sub>r I) = id \<otimes>\<^sub>r inv I\<close>
    by auto

  have \<open>t2 = (inv (id \<otimes>\<^sub>r I) o inv (F;complement F)) (selfbutterket default)\<close>
    unfolding t2_def I
    apply (subst o_inv_distrib[symmetric])
    by (auto simp: pair_o_tensor)
  also have \<open>\<dots> = (selfbutterket default \<otimes>\<^sub>o inv I aF)\<close>
    apply auto
    by (metis \<open>iso_register I\<close> id_def iso_register_def iso_register_inv register_id register_tensor_apply)
  finally have t2': \<open>t2 = selfbutterket default \<otimes>\<^sub>o inv I aF\<close>
    by simp

  have *: \<open>complements G (F; complement (F;G))\<close>
    apply (rule complements_complement_pair')
    by simp
  then have [simp]: \<open>compatible G (F; complement (F;G))\<close>
    using complements_def by blast
  from * have \<open>equivalent_registers (complement G) (F; complement (F;G))\<close>
    using complement_unique equivalent_registers_sym by blast
  then obtain J where [simp]: \<open>iso_register J\<close> and I: \<open>(F; complement (F;G)) = complement G o J\<close>
    by (metis equivalent_registers_def)
  then have [simp]: \<open>register J\<close>
    by (meson iso_register_is_register)
  have [simp]: \<open>bij (id \<otimes>\<^sub>r J)\<close>
    by (rule iso_register_bij, simp)
  have [simp]: \<open>inv (id \<otimes>\<^sub>r J) = id \<otimes>\<^sub>r inv J\<close>
    by auto

  have \<open>t3 = (inv (id \<otimes>\<^sub>r J) o inv (G;complement G)) (selfbutterket default)\<close>
    unfolding t3_def I
    apply (subst o_inv_distrib[symmetric])
    by (auto simp: pair_o_tensor)
  also have \<open>\<dots> = (selfbutterket default \<otimes>\<^sub>o inv J aG)\<close>
    apply auto
    by (metis \<open>iso_register J\<close> id_def iso_register_def iso_register_inv register_id register_tensor_apply)
  finally have t3': \<open>t3 = selfbutterket default \<otimes>\<^sub>o inv J aG\<close>
    by simp

  have *: \<open>((F;G); complement (F;G)) o assoc' = (F; (G; complement (F;G)))\<close>
    apply (rule tensor_extensionality3)
    by (auto simp: register_pair_apply  compatible_complement_pair1 compatible_complement_pair2)
  have t2_t1: \<open>t2 = assoc t1\<close>
    unfolding t1_def t2_def *[symmetric] apply (subst o_inv_distrib)
    by auto

  have *: \<open>((F;G); complement (F;G)) o (swap \<otimes>\<^sub>r id) o assoc' = (G; (F; complement (F;G)))\<close>
    apply (rule tensor_extensionality3)
      apply (auto intro!: register_comp register_tensor_is_register pair_is_register complements_complement_pair
        simp: register_pair_apply compatible_complement_pair1)
    by (metis assms(1) cblinfun_assoc_left(1) swap_registers_left)
  have t3_t1: \<open>t3 = assoc ((swap \<otimes>\<^sub>r id) t1)\<close>
    unfolding t1_def t3_def *[symmetric] apply (subst o_inv_distrib)
    by (auto intro!: bij_comp simp: iso_register_bij o_inv_distrib)

  from \<open>t2 = assoc t1\<close> \<open>t3 = assoc ((swap \<otimes>\<^sub>r id) t1)\<close>
  have *: \<open>selfbutterket default \<otimes>\<^sub>o inv J aG =  assoc ((swap \<otimes>\<^sub>r id) (assoc' (selfbutterket default \<otimes>\<^sub>o inv I aF)))\<close>
    by (simp add: t2' t3')

  have \<open>selfbutterket default \<otimes>\<^sub>o swap (inv J aG) = (id \<otimes>\<^sub>r swap) (selfbutterket default \<otimes>\<^sub>o inv J aG)\<close>
    by auto
  also have \<open>\<dots> = ((id \<otimes>\<^sub>r swap) o assoc o (swap \<otimes>\<^sub>r id) o assoc') (selfbutterket default \<otimes>\<^sub>o inv I aF)\<close>
    by (simp add: *)
  also have \<open>\<dots> = (assoc o swap) (selfbutterket default \<otimes>\<^sub>o inv I aF)\<close>
    apply (rule fun_cong[where g=\<open>assoc o swap\<close>])
    apply (intro tensor_extensionality3 register_comp register_tensor_is_register)
    by auto
  also have \<open>\<dots> = assoc (inv I aF \<otimes>\<^sub>o selfbutterket default)\<close>
    by auto
  finally have *: \<open>selfbutterket default \<otimes>\<^sub>o swap (inv J aG) = assoc (inv I aF \<otimes>\<^sub>o selfbutterket default)\<close>
    by -

  obtain c where *: \<open>selfbutterket (default::'c) \<otimes>\<^sub>o swap (inv J aG) = selfbutterket default \<otimes>\<^sub>o c \<otimes>\<^sub>o selfbutterket default\<close>
    apply atomize_elim
    apply (rule overlapping_tensor)
    using * unfolding assoc_ell2_sandwich sandwich_def
    by auto

  have \<open>t1 = ((swap \<otimes>\<^sub>r id) o assoc') t3\<close>
    by (simp add: t3_t1 register_tensor_distrib[unfolded o_def, THEN fun_cong] flip: id_def)
  also have \<open>\<dots> = ((swap \<otimes>\<^sub>r id) o assoc' o (id \<otimes>\<^sub>r swap)) (selfbutterket (default::'c) \<otimes>\<^sub>o swap (inv J aG))\<close>
    unfolding t3' by auto
  also have \<open>\<dots> = ((swap \<otimes>\<^sub>r id) o assoc' o (id \<otimes>\<^sub>r swap)) (selfbutterket default \<otimes>\<^sub>o c \<otimes>\<^sub>o selfbutterket default)\<close>
    unfolding * by simp
  also have \<open>\<dots> = selfbutterket default \<otimes>\<^sub>o c\<close>
    apply (simp del: tensor_butterfly)
    by (simp add: default_prod_def)
  finally have \<open>t1 = selfbutterket default \<otimes>\<^sub>o c\<close>
    by -

  then show ?thesis
    apply (auto intro!: exI[of _ c] simp: regular_register_def t1_def)
    by (metis \<open>bij ((F;G);complement (F;G))\<close> bij_inv_eq_iff)
qed

lemma regular_register_comp: \<open>regular_register (F o G)\<close> if \<open>regular_register F\<close> \<open>regular_register G\<close>
proof -
  have [simp]: \<open>register F\<close> \<open>register G\<close>
    using regular_register_def that by blast+
  from that obtain a where a: \<open>(F; complement F) (selfbutterket default \<otimes>\<^sub>o a) = selfbutterket default\<close>
    unfolding regular_register_def by metis
  from that obtain b where b: \<open>(G; complement G) (selfbutterket default \<otimes>\<^sub>o b) = selfbutterket default\<close>
    unfolding regular_register_def by metis
  have \<open>complements (F o G) (complement F; F o complement G)\<close>
    by (simp add: complements_chain)
  then have \<open>equivalent_registers (complement F; F o complement G) (complement (F o G))\<close>
    using complement_unique by blast
  then obtain J where [simp]: \<open>iso_register J\<close> and 1: \<open>(complement F; F o complement G) o J = (complement (F o G))\<close>
    using equivalent_registers_def by blast
  have [simp]: \<open>register J\<close>
    by (simp add: iso_register_is_register)

  define c where \<open>c = inv J (a \<otimes>\<^sub>o b)\<close>

  have \<open>((F o G); complement (F o G)) (selfbutterket default \<otimes>\<^sub>o c) = ((F o G); (complement F; F o complement G)) (selfbutterket default \<otimes>\<^sub>o J c)\<close>
    by (auto simp flip: 1 simp: register_pair_apply)
  also have \<open>\<dots> = ((F o (G; complement G); complement F) o assoc' o (id \<otimes>\<^sub>r swap)) (selfbutterket default \<otimes>\<^sub>o J c)\<close>
    apply (subst register_comp_pair[symmetric])
      apply auto[2]
    apply (subst pair_o_assoc')
       apply auto[3]
    apply (subst pair_o_tensor)
    by auto
  also have \<open>\<dots> = ((F o (G; complement G); complement F) o assoc') (selfbutterket default \<otimes>\<^sub>o swap (J c))\<close>
    by auto
  also have \<open>\<dots> = ((F o (G; complement G); complement F) o assoc') (selfbutterket default \<otimes>\<^sub>o (b \<otimes>\<^sub>o a))\<close>
    unfolding c_def apply (subst surj_f_inv_f[where f=J])
     apply (meson \<open>iso_register J\<close> bij_betw_inv_into_right iso_register_inv_comp1 iso_register_inv_comp2 iso_tuple_UNIV_I o_bij surj_iff_all)
    by auto
  also have \<open>\<dots> = (F \<circ> (G;complement G);complement F) ((selfbutterket default \<otimes>\<^sub>o b) \<otimes>\<^sub>o a)\<close>
    by (simp add: assoc'_apply)
  also have \<open>\<dots> = (F; complement F) ((G;complement G) (selfbutterket default \<otimes>\<^sub>o b) \<otimes>\<^sub>o a)\<close>
    by (simp add: register_pair_apply')
  also have \<open>\<dots> = selfbutterket default\<close>
    by (auto simp: a b)
  finally have \<open>(F \<circ> G;complement (F \<circ> G)) (selfbutterket default \<otimes>\<^sub>o c) = selfbutterket default\<close>
    by -
  then show ?thesis
    using \<open>register F\<close> \<open>register G\<close> register_comp regular_register_def by blast
qed

lemma regular_iso_register:
  assumes \<open>regular_register F\<close>
  assumes [register]: \<open>iso_register F\<close>
  shows \<open>F (selfbutterket default) = selfbutterket default\<close>
proof -
  from assms(1) obtain a where a: \<open>(F;complement F) (selfbutterket default \<otimes>\<^sub>o a) = selfbutterket default\<close>
    using regular_register_def by blast

  let ?u = \<open>empty_var :: (unit ell2 \<Rightarrow>\<^sub>C\<^sub>L unit ell2) \<Rightarrow> _\<close>
  have \<open>is_unit_register ?u\<close> and \<open>is_unit_register (complement F)\<close>
    by auto
  then have \<open>equivalent_registers (complement F) ?u\<close>
    using unit_register_unique by blast
  then obtain I where \<open>iso_register I\<close> and \<open>complement F = ?u o I\<close>
    by (metis \<open>is_unit_register (complement F)\<close> equivalent_registers_def is_unit_register_empty_var unit_register_unique)
  have \<open>selfbutterket default = (F; ?u o I) (selfbutterket default \<otimes>\<^sub>o a)\<close>
    using \<open>complement F = empty_var \<circ> I\<close> a by presburger
  also have \<open>\<dots> = (F; ?u) (selfbutterket default \<otimes>\<^sub>o I a)\<close>
    by (metis Laws_Quantum.register_pair_apply \<open>complement F = empty_var \<circ> I\<close> \<open>equivalent_registers (complement F) empty_var\<close> assms(2) comp_apply complement_is_complement complements_def equivalent_complements iso_register_is_register)
  also have \<open>\<dots> = (F; ?u) (selfbutterket default \<otimes>\<^sub>o (one_dim_iso (I a) *\<^sub>C id_cblinfun))\<close>
    by simp
  also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C (F; ?u) (selfbutterket default \<otimes>\<^sub>o id_cblinfun)\<close>
    by (simp add: Axioms_Quantum.register_pair_apply empty_var_def iso_register_is_register)
  also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C F (selfbutterket default)\<close>
    by (auto simp: register_pair_apply iso_register_is_register simp del: id_cblinfun_eq_1)
  finally have F: \<open>one_dim_iso (I a) *\<^sub>C F (selfbutterket default) = selfbutterket default\<close>
    by simp

  from F have \<open>one_dim_iso (I a) \<noteq> (0::complex)\<close>
    by (metis butterfly_apply butterfly_scaleC_left complex_vector.scale_eq_0_iff id_cblinfun_eq_1 id_cblinfun_not_0 cinner_ket_same ket_nonzero one_dim_iso_of_one one_dim_iso_of_zero')

  have \<open>selfbutterket default = one_dim_iso (I a) *\<^sub>C F (selfbutterket default)\<close>
    using F by simp
  also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C F (selfbutterket default o\<^sub>C\<^sub>L selfbutterket default)\<close>
    by auto
  also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C (F (selfbutterket default) o\<^sub>C\<^sub>L F (selfbutterket default))\<close>
    by (simp add: assms(2) iso_register_is_register register_mult)
  also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C ((selfbutterket default /\<^sub>C one_dim_iso (I a)) o\<^sub>C\<^sub>L (selfbutterket default /\<^sub>C one_dim_iso (I a)))\<close>
    by (metis (no_types, lifting) F \<open>one_dim_iso (I a) \<noteq> 0\<close> complex_vector.scale_left_imp_eq inverse_1 left_inverse scaleC_scaleC zero_neq_one)
  also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C selfbutterket default\<close>
    by (smt (verit, best) butterfly_comp_butterfly calculation cblinfun_compose_scaleC_left cblinfun_compose_scaleC_right complex_vector.scale_cancel_left cinner_ket_same left_inverse scaleC_one scaleC_scaleC)
  finally have \<open>one_dim_iso (I a) = (1::complex)\<close>
    by (metis butterfly_0_left butterfly_apply complex_vector.scale_cancel_right cinner_ket_same ket_nonzero scaleC_one)
  with F show \<open>F (selfbutterket default) = selfbutterket default\<close>
    by simp
qed

lemma pure_state_nested:
  assumes [simp]: \<open>compatible F G\<close>
  assumes \<open>regular_register H\<close>
  assumes \<open>iso_register H\<close>
  shows \<open>pure_state (F;G) (pure_state H h \<otimes>\<^sub>s g) = pure_state ((F o H);G) (h \<otimes>\<^sub>s g)\<close>
proof -
  note [[simproc del: Laws_Quantum.compatibility_warn]]
  have [simp]: \<open>register H\<close>
    by (meson assms(3) iso_register_is_register)
  have [simp]: \<open>H (selfbutterket default) = selfbutterket default\<close>
    apply (rule regular_iso_register)
    using assms by auto
  have 1: \<open>pure_state_target_vector H (ket default) = ket default\<close>
    apply (rule pure_state_target_vector_ket_default)
    apply auto
    by (metis (no_types, lifting) cinner_ket_same rangeI scaleC_one)

  have \<open>butterfly (pure_state H h) (ket default) = butterfly (H (butterfly h (ket default)) *\<^sub>V ket default) (ket default)\<close>
    by (simp add: pure_state'_def 1)
  also have \<open>\<dots> = H (butterfly h (ket default)) o\<^sub>C\<^sub>L selfbutterket default\<close>
    by (metis (no_types, opaque_lifting) adj_cblinfun_compose butterfly_adjoint butterfly_comp_cblinfun double_adj)
  also have \<open>\<dots> = H (butterfly h (ket default)) o\<^sub>C\<^sub>L H (selfbutterket default)\<close>
    by simp
  also have \<open>\<dots> = H (butterfly h (ket default) o\<^sub>C\<^sub>L selfbutterket default)\<close>
    by (meson \<open>register H\<close> register_mult)
  also have \<open>\<dots> = H (butterfly h (ket default))\<close>
    by auto
  finally have 2: \<open>butterfly (pure_state H h) (ket default) = H (butterfly h (ket default))\<close>
    by simp

  show ?thesis
    apply (rule pure_state_eqI)
    using 1 2
    by (auto simp: register_pair_butterfly_tensor compatible_ac_rules default_prod_def simp flip: tensor_ell2_ket)
qed

lemma state_apply1:
  assumes [register]: \<open>compatible F G\<close>
  shows \<open>F U *\<^sub>V (F \<psi> \<otimes>\<^sub>p G \<phi>) = (F (U \<psi>) \<otimes>\<^sub>p G \<phi>)\<close>
proof -
  have [register]: \<open>compatible F G\<close>
    using assms(1) complements_def by blast
  have \<open>F U *\<^sub>V (F \<psi> \<otimes>\<^sub>p G \<phi>) = (F;G) (U \<otimes>\<^sub>o id_cblinfun) *\<^sub>V (F \<psi> \<otimes>\<^sub>p G \<phi>)\<close>
    apply (subst register_pair_apply)
    by auto
  also have \<open>\<dots> = (F (U \<psi>) \<otimes>\<^sub>p G \<phi>)\<close>
    unfolding pure_state'_def
    by (auto simp: register_mult' cblinfun_comp_butterfly tensor_op_ell2)
  finally show ?thesis
    by -
qed

lemma Fst_regular[simp]: \<open>regular_register Fst\<close>
  apply (rule regular_registerI[where a=\<open>selfbutterket default\<close> and G=Snd])
  by (auto simp: pair_Fst_Snd default_prod_def)

lemma Snd_regular[simp]: \<open>regular_register Snd\<close>
  apply (rule regular_registerI[where a=\<open>selfbutterket default\<close> and G=Fst])
    apply auto[2]
  apply (auto simp only: default_prod_def swap_apply simp flip: swap_def)
  by auto

lemma id_regular[simp]: \<open>regular_register id\<close>
  apply (rule regular_registerI[where G=unit_register and a=id_cblinfun])
  by (auto simp: register_pair_apply)

lemma swap_regular[simp]: \<open>regular_register swap\<close>
  by (auto intro!: regular_register_pair simp: swap_def)

lemma assoc_regular[simp]: \<open>regular_register assoc\<close>
  by (auto intro!: regular_register_pair regular_register_comp simp: assoc_def)

lemma assoc'_regular[simp]: \<open>regular_register assoc'\<close>
  by (auto intro!: regular_register_pair regular_register_comp simp: assoc'_def)

lemma cspan_pure_state':
  assumes \<open>iso_register F\<close>
  assumes \<open>cspan (g ` X) = UNIV\<close>
  assumes \<eta>_cond: \<open>F (selfbutter \<eta>) *\<^sub>V pure_state_target_vector F \<eta> \<noteq> 0\<close>
  shows \<open>cspan ((\<lambda>z. pure_state' F (g z) \<eta>) ` X) = UNIV\<close>
proof -
  from iso_register_decomposition[of F]
  obtain U where [simp]: \<open>unitary U\<close> and F: \<open>F = sandwich U\<close>
    using assms(1) by blast

  define \<eta>' c where \<open>\<eta>' = pure_state_target_vector F \<eta>\<close> and \<open>c = cinner (U *\<^sub>V \<eta>) \<eta>'\<close>

  from \<eta>_cond
  have \<open>c \<noteq> 0\<close>
    by (simp add: \<eta>'_def F sandwich_def c_def cinner_adj_right)

  have \<open>cspan ((\<lambda>z. pure_state' F (g z) \<eta>) ` X) = cspan ((\<lambda>z. F (butterfly (g z) \<eta>) *\<^sub>V \<eta>') ` X)\<close>
    by (simp add: \<eta>'_def pure_state'_def)
  also have \<open>\<dots> = cspan ((\<lambda>z. (butterfly (U *\<^sub>V g z) (U *\<^sub>V \<eta>)) *\<^sub>V \<eta>') ` X)\<close>
    by (simp add: F sandwich_def cinner_adj_right)
  also have \<open>\<dots> = cspan ((\<lambda>z. c *\<^sub>C U *\<^sub>V g z) ` X)\<close>
    by (simp add: c_def)
  also have \<open>\<dots> = (\<lambda>z. c *\<^sub>C U *\<^sub>V z) ` cspan (g ` X)\<close>
    apply (subst complex_vector.linear_span_image[symmetric])
    by (auto simp: image_image)
  also have \<open>\<dots> = (\<lambda>z. c *\<^sub>C U *\<^sub>V z) ` UNIV\<close>
    using assms(2) by presburger
  also have \<open>\<dots> = UNIV\<close>
    apply (rule surjI[where f=\<open>\<lambda>z. (U* *\<^sub>V z) /\<^sub>C c\<close>])
    using \<open>c \<noteq> 0\<close> by (auto simp flip: cblinfun_apply_cblinfun_compose)
  finally show ?thesis
    by -
qed

lemma cspan_pure_state:
  assumes [simp]: \<open>iso_register F\<close>
  assumes \<open>cspan (g ` X) = UNIV\<close>
  shows \<open>cspan ((\<lambda>z. pure_state F (g z)) ` X) = UNIV\<close>
  apply (rule cspan_pure_state')
  using assms apply auto[2]
  apply (rule pure_state_target_vector_correct)
  by (auto simp: iso_register_is_register)

lemma pure_state_bounded_clinear:
  assumes [register]: \<open>compatible F G\<close>
  shows \<open>bounded_clinear (\<lambda>\<psi>. (F \<psi> \<otimes>\<^sub>p G \<phi>))\<close>
proof -
  have [bounded_clinear]: \<open>bounded_clinear (F;G)\<close>
    using assms pair_is_register register_bounded_clinear by blast
  show ?thesis
    unfolding pure_state'_def
    by (auto intro!: bounded_linear_intros)
qed

lemma pure_state_bounded_clinear_right:
  assumes [register]: \<open>compatible F G\<close>
  shows \<open>bounded_clinear (\<lambda>\<phi>. (F \<psi> \<otimes>\<^sub>p G \<phi>))\<close>
proof -
  have [bounded_clinear]: \<open>bounded_clinear (F;G)\<close>
    using assms pair_is_register register_bounded_clinear by blast
  show ?thesis
    unfolding pure_state'_def
    by (auto intro!: bounded_linear_intros)
qed

lemma pure_state_clinear:
  assumes [register]: \<open>compatible F G\<close>
  shows \<open>clinear (\<lambda>\<psi>. (F \<psi> \<otimes>\<^sub>p G \<phi>))\<close>
  using assms bounded_clinear.clinear pure_state_bounded_clinear by blast

method pure_state_flatten_nested =
  (subst pure_state_nested, (auto; fail)[3])+

text \<open>The following method \<open>pure_state_eq\<close> tries to solve a equality where both sides are of the form
  \<open>F\<^sub>1(\<psi>\<^sub>1) \<otimes>\<^sub>p F\<^sub>2(\<psi>\<^sub>2) \<otimes>\<^sub>p \<dots> \<otimes>\<^sub>p F\<^sub>n(\<psi>\<^sub>n)\<close> by reordering the registers and unfolding nested register pairs.
  (For the unfolding of nested pairs, it is necessary that the corresponding \<^term>\<open>compatible F G\<close> facts are provable by the simplifier.)

  If the some of the pure states \<^term>\<open>\<psi>\<^sub>i\<close> themselves are \<open>\<otimes>\<^sub>p\<close>-tensors, they will be flattened if possible.
  (If all necessary conditions can be proven, such as \<open>regular_register\<close> etc.)

  The method may either succeed, fail, or reduce the equality to a hopefully simpler one.\<close>

method pure_state_eq =
  (pure_state_flatten_nested?,
    rule pure_state_eqI;
    auto simp: register_pair_butterfly_tensor compatible_ac_rules default_prod_def
    simp flip: tensor_ell2_ket)

lemma example:
  fixes F :: \<open>bit update \<Rightarrow> 'c::{finite,default} update\<close>
    and G :: \<open>bit update \<Rightarrow> 'c update\<close>
  assumes [register]: \<open>compatible F G\<close>
  shows  \<open>(F;G) CNOT o\<^sub>C\<^sub>L (G;F) CNOT o\<^sub>C\<^sub>L (F;G) CNOT = (F;G) swap_ell2\<close>
proof -
  define Z where \<open>Z = complement (F;G)\<close>
  then have [register]: \<open>compatible Z F\<close> \<open>compatible Z G\<close>
    using assms compatible_complement_pair1 compatible_complement_pair2 compatible_sym by blast+

  have [simp]: \<open>iso_register (F;(G;Z))\<close>
    using Z_def assms complements_complement_pair complements_def by blast

  have eq1: \<open>((F;G) CNOT o\<^sub>C\<^sub>L (G;F) CNOT o\<^sub>C\<^sub>L (F;G) CNOT) *\<^sub>V (F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z))
           = (F;G) swap_ell2 *\<^sub>V (F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z))\<close> for f g z
  proof -
    have \<open>(F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z)) = ((F;G) (ket f \<otimes>\<^sub>s ket g) \<otimes>\<^sub>p Z(ket z))\<close>
      by pure_state_eq
    also have \<open>(F;G) CNOT *\<^sub>V \<dots> = ((F;G) (ket f \<otimes>\<^sub>s ket (g+f)) \<otimes>\<^sub>p Z(ket z))\<close>
      apply (subst state_apply1) by auto
    also have \<open>\<dots> = ((G;F) (ket (g+f) \<otimes>\<^sub>s ket f) \<otimes>\<^sub>p Z(ket z))\<close>
      by pure_state_eq
    also have \<open>(G;F) CNOT *\<^sub>V \<dots> = ((G;F) (ket (g+f) \<otimes>\<^sub>s ket g) \<otimes>\<^sub>p Z ket z)\<close>
      apply (subst state_apply1) by auto
    also have \<open>\<dots> = ((F;G) (ket g \<otimes>\<^sub>s ket (g+f)) \<otimes>\<^sub>p Z ket z)\<close>
      by pure_state_eq
    also have \<open>(F;G) CNOT *\<^sub>V \<dots> = ((F;G) ket g \<otimes>\<^sub>s ket f \<otimes>\<^sub>p Z ket z)\<close>
      apply (subst state_apply1)
      apply simp
      using add_right_imp_eq by fastforce
    also have \<open>\<dots> = (F(ket g) \<otimes>\<^sub>p G(ket f) \<otimes>\<^sub>p Z(ket z))\<close>
      by pure_state_eq
    finally have 1: \<open>((F;G) CNOT o\<^sub>C\<^sub>L (G;F) CNOT o\<^sub>C\<^sub>L (F;G) CNOT) *\<^sub>V (F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z)) = (F(ket g) \<otimes>\<^sub>p G(ket f) \<otimes>\<^sub>p Z(ket z))\<close>
      by auto

    have \<open>(F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z)) = ((F;G) (ket f \<otimes>\<^sub>s ket g) \<otimes>\<^sub>p Z(ket z))\<close>
      by pure_state_eq
    also have \<open>(F;G) swap_ell2 *\<^sub>V \<dots> = ((F;G) (ket g \<otimes>\<^sub>s ket f) \<otimes>\<^sub>p Z(ket z))\<close>
      by (auto simp: state_apply1 swap_ell2_tensor simp del: tensor_ell2_ket)
    also have \<open>\<dots> = (F(ket g) \<otimes>\<^sub>p G(ket f) \<otimes>\<^sub>p Z(ket z))\<close>
      by pure_state_eq
    finally have 2: \<open>(F;G) swap_ell2 *\<^sub>V (F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z)) = (F(ket g) \<otimes>\<^sub>p G(ket f) \<otimes>\<^sub>p Z(ket z))\<close>
      by -

    from 1 2 show ?thesis
      by simp
  qed

  then have eq1: \<open>((F;G) CNOT o\<^sub>C\<^sub>L (G;F) CNOT o\<^sub>C\<^sub>L (F;G) CNOT) *\<^sub>V \<psi>
           = (F;G) swap_ell2 *\<^sub>V \<psi>\<close> if \<open>\<psi> \<in> {(F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z))| f g z. True}\<close> for \<psi>
    using that by auto

  moreover have \<open>cspan {(F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z))| f g z. True} = UNIV\<close>
    apply (simp only: double_exists setcompr_eq_image full_SetCompr_eq)
    apply simp
    apply (rule cspan_pure_state)
    by auto

  ultimately show ?thesis
    using cblinfun_eq_on_UNIV_span by blast
qed

end


theory Submission
  imports Defs
begin

fun erase :: "level \<Rightarrow> com \<Rightarrow> com"  where
  "erase l SKIP = SKIP" |
  "erase l (x ::= a) = (if sec (V x) \<ge> l then SKIP else (x ::= a))" |
  "erase l (c\<^sub>1;;c\<^sub>2) = (erase l c\<^sub>1) ;; (erase l c\<^sub>2)" |
  "erase l (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (if sec b \<ge> l then SKIP else (IF b THEN (erase l c\<^sub>1) ELSE (erase l c\<^sub>2)))" |
  "erase l (WHILE b DO c) = (if sec b \<ge> l then SKIP else (WHILE b DO erase l c))"

lemma aval_eq: "\<lbrakk> s = t (< l); sec a < l \<rbrakk> \<Longrightarrow> aval a s = aval a t"
  by(induction rule: aexp.induct, auto)

lemma bval_eq: "\<lbrakk> s = t (< l); sec b < l \<rbrakk> \<Longrightarrow> bval b s = bval b t"
  by(induction rule: bexp.induct, auto simp: aval_eq)

theorem erase_correct:
  "\<lbrakk> (c,s) \<Rightarrow> s'; (erase l c,t) \<Rightarrow> t';  0 \<turnstile> c;  s = t (< l) \<rbrakk>
   \<Longrightarrow> s' = t' (< l)"
proof(induction arbitrary: t t' rule: big_step_induct)
  case (Assign x a s)
  then have "sec x \<ge> sec a" using \<open>0 \<turnstile> x ::= a\<close> by auto
  then show ?case
    proof(cases "sec (V x) \<ge> l")
      case True
      then show ?thesis using Assign by fastforce
    next
      case False
      then have "erase l (x ::= a) = (x ::= a)" by simp
      moreover have "t' = t(x := aval a t)" using False Assign by auto
      moreover have "aval a s = aval a t" using Assign aval_eq False by auto
      ultimately show ?thesis
        by (simp add: Assign.prems(3))
    qed
  next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  have "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" using \<open>0 \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2\<close> by auto
  then show ?case
  proof(cases "sec b \<ge> l")
    case True
    then show ?thesis
      using IfTrue \<open>sec b \<turnstile> c\<^sub>1\<close> anti_mono confinement erase.simps(4) sec_type.Skip
      by fastforce
  next
    case False
    then have
      "erase l (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =  IF b THEN (erase l c\<^sub>1) ELSE (erase l c\<^sub>2)"
      by simp
    then have "(erase l c\<^sub>1, t) \<Rightarrow> t'"
      using IfTrue bval_eq False by auto
    then show ?thesis
      using IfTrue.IH IfTrue.prems(3) \<open>sec b \<turnstile> c\<^sub>1\<close> anti_mono by blast
  qed
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  have "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" using \<open>0 \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2\<close> by auto
  then show ?case
  proof(cases "sec b \<ge> l")
    case True
    then show ?thesis
      using IfFalse \<open>sec b \<turnstile> c\<^sub>2\<close> anti_mono confinement erase.simps(4) sec_type.Skip
      by fastforce
  next
    case False
    then have
      "erase l (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =  IF b THEN (erase l c\<^sub>1) ELSE (erase l c\<^sub>2)"
      by simp
    then have "(erase l c\<^sub>2, t) \<Rightarrow> t'"
      using IfFalse bval_eq False by auto
    then show ?thesis
      using IfFalse.IH IfFalse.prems(3) \<open>sec b \<turnstile> c\<^sub>2\<close> anti_mono by blast
  qed
next
  case (WhileFalse b s c)
  have "sec b \<turnstile> c" using WhileFalse.prems(2) by auto
  with WhileFalse show ?case
  proof cases
    assume "sec b \<ge> l"
    then show ?thesis
      using WhileFalse.prems(1) WhileFalse.prems(3) by auto
  next
    assume "\<not> sec b \<ge> l"
    then show ?thesis
      using WhileFalse.hyps WhileFalse.prems(1) WhileFalse.prems(3) \<open>\<not> l \<le> sec b\<close> bval_eq by auto
  qed
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3 t\<^sub>1 t\<^sub>3)
   have "sec b \<turnstile> c" using WhileTrue.prems(2) by auto
  with WhileTrue show ?case
  proof cases
    assume "sec b \<ge> l"
    then show ?thesis
      using \<open>sec b \<turnstile> c\<close> WhileTrue anti_mono confinement by metis
  next
    assume "\<not> sec b \<ge> l"
    hence "s\<^sub>1 = t\<^sub>1 (\<le> sec b)" using \<open>s\<^sub>1 = t\<^sub>1 (< l)\<close> by auto
    hence "bval b t\<^sub>1"
      using WhileTrue.hyps(1) bval_eq_if_eq_le by blast
    then obtain t\<^sub>2 where "(erase l c,t\<^sub>1) \<Rightarrow> t\<^sub>2" "(erase l (WHILE b DO c),t\<^sub>2) \<Rightarrow> t\<^sub>3"
      using \<open>(erase l (WHILE b DO c),t\<^sub>1) \<Rightarrow> t\<^sub>3\<close> \<open>\<not> l \<le> sec b\<close> by auto
    from WhileTrue.IH(2)[OF \<open>(erase l (WHILE b DO c),t\<^sub>2) \<Rightarrow> t\<^sub>3\<close> \<open>0 \<turnstile> WHILE b DO c\<close>
      WhileTrue.IH(1)[OF \<open>(erase l c,t\<^sub>1) \<Rightarrow> t\<^sub>2\<close> anti_mono[OF \<open>sec b \<turnstile> c\<close>]
        \<open>s\<^sub>1 = t\<^sub>1 (< l)\<close>]]
    show ?thesis by simp
  qed
qed auto

prop "\<lbrakk> (c,s) \<Rightarrow> s';  0 \<turnstile> c;  s = t (< l) \<rbrakk>
  \<Longrightarrow> \<exists>t'. (erase l c,t) \<Rightarrow> t' \<and> s' = t' (< l)"
text \<open>
From (c,s) \<Rightarrow> s' we know (c, s) terminates. With s = t (< l) also (erase l c,t) must terminate
(erase replaces coms either by the same com or SKIP). Hence, \<exists>t'. (erase l c,t) \<Rightarrow> t'.
From big_step_determ we know big_step is deterministic. Hence we don't only know about the
existance of t' but even the exact outcome of (erase l c,t) \<Rightarrow> t'. Thus all the requirements
to apply erase_correct are given. Hence, also s' = t' (< l) must hold.
Therefore, this proposition holds.
\<close>

prop "\<lbrakk> (erase l c,s) \<Rightarrow> s';  0 \<turnstile> c;  s = t (< l) \<rbrakk> \<Longrightarrow> \<exists>t'. (c,t) \<Rightarrow> t'"
text \<open>
Counter example: An infinite loop that is erased by `erase l c`

l = 0; c = WHILE (Bc True) DO SKIP; s = 0; t = 0

Then:
erase l c s = SKIP
and
(erase l c,s) \<Rightarrow> s = s'
0 \<turnstile> c
and
s = t (< l)

but no terminal state (c,t) \<Rightarrow> t' exists since c is an infinite loop.
\<close>

theorem well_initialized_commands:
  assumes "D A c B"
      and "s = s' on A"
      and "(c,s) \<Rightarrow> t"
      and "(c,s') \<Rightarrow> t'"
    shows "t=t' on B"
using assms proof(induction arbitrary: s s' t t' rule: D.induct)
  case (Assign a A x)
  then have "vars a \<subseteq> A"
    by simp
  moreover have "D A (x ::= a) (insert x A)"
    by (simp add: D.Assign calculation)
  moreover have "aval a s = aval a s'"
    using aval_eq_if_eq_on_vars \<open>s = s' on A\<close> Assign.hyps by blast
  ultimately have "t = t' on (insert x A)" using Assign
    by auto
  then show ?case .
next
  case (If b A c\<^sub>1 A\<^sub>1 c\<^sub>2 A\<^sub>2)
  then have "vars b \<subseteq> A" "D A c\<^sub>1 A\<^sub>1" "D A c\<^sub>2 A\<^sub>2"
    by blast+
  moreover have "D A (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (A\<^sub>1 Int A\<^sub>2)"
    by (simp add: D.If calculation)
  moreover have "bval b s = bval b s'"
    using bval_eq_if_eq_on_vars \<open>s = s' on A\<close> If.hyps by blast
  ultimately have "t = t' on (A\<^sub>1 Int A\<^sub>2)"
    using Assign If.IH(1) If.IH(2) If.prems(1) If.prems(2) If.prems(3) IfE by blast
  then show ?case .
next
  case (While b A c A')
  from While(5) show ?case using While
  proof(induction "WHILE b DO c" s t arbitrary: s' t' rule: big_step_induct)
    case (WhileFalse s)
    have "bval b s = bval b s'"
      using bval_eq_if_eq_on_vars \<open>s = s' on A\<close> While.hyps by blast
    then show ?case
      using WhileFalse.hyps WhileFalse.prems(4) WhileFalse.prems(6) by auto
  next
    case (WhileTrue s\<^sub>1 s\<^sub>2 s\<^sub>3)
    have "bval b s\<^sub>1 = bval b s'"
      using bval_eq_if_eq_on_vars \<open>s\<^sub>1 = s' on A\<close> While.hyps by blast
    then obtain s'\<^sub>2 where "(c,s') \<Rightarrow> s'\<^sub>2" "(WHILE b DO c, s'\<^sub>2) \<Rightarrow> t'"
      using WhileTrue.hyps(1) WhileTrue.prems(6) by auto
    then have "s\<^sub>2 = s'\<^sub>2 on A"
      using D_incr WhileTrue by blast
    then show ?case
      using WhileTrue \<open>(WHILE b DO c, s'\<^sub>2) \<Rightarrow> t'\<close> by blast
  qed
qed (blast)+

end


theory Projection
  imports Instantiation IndividualSubStructure IndividualMorphisms
begin

context instantiation_structure_defs
begin

definition excluded_moments where
  "excluded_moments U \<equiv> { m . m \<in> \<M>\<^sub>* \<and> \<beta>\<^sub>* m \<Colon>\<^sub>\<diamondop> U \<and> (\<forall>u'. char_by\<^sub>* U u' \<longrightarrow> \<not> m \<Colon>\<^sub>m\<^sub>\<diamondop> u')}"

lemma excluded_moments_I[intro]:
  assumes "m \<in> \<M>\<^sub>*" "\<beta>\<^sub>* m \<Colon>\<^sub>\<diamondop> U"  "\<And>u'. char_by\<^sub>* U u' \<Longrightarrow> \<not> m \<Colon>\<^sub>m\<^sub>\<diamondop> u'"
  shows "m \<in> excluded_moments U"
  using assms by (auto simp: excluded_moments_def)

lemma excluded_moments_E[elim]:
  assumes "m \<in> excluded_moments U"
  obtains x where "m \<in> \<M>\<^sub>*" "\<beta>\<^sub>* m \<Colon>\<^sub>\<diamondop> U"  "\<And>u'. char_by\<^sub>* U u' \<Longrightarrow> \<not> m \<Colon>\<^sub>m\<^sub>\<diamondop> u'"
  using assms by (auto simp: excluded_moments_def)

lemma excluded_moments_iff:
  "m \<in> excluded_moments U \<longleftrightarrow> m \<in> \<M>\<^sub>* \<and> \<beta>\<^sub>* m \<Colon>\<^sub>\<diamondop> U \<and> (\<forall>u'. char_by\<^sub>* U u' \<longrightarrow> \<not> m \<Colon>\<^sub>m\<^sub>\<diamondop> u')"
  by blast

definition project  where
  "project U \<equiv>  \<lparr>
             individuals = \<I>\<^sub>* - (excluded_moments U),
             inheres_in = (\<lambda>x y. x \<triangleleft>\<^sub>* y \<and> x \<notin> excluded_moments U),
             exactly_similar_to = (\<lambda>x y. x \<simeq>\<^sub>* y \<and> x \<notin> excluded_moments U \<and> y \<notin> excluded_moments U),
             worlds = { w - excluded_moments U | w . w \<in> \<W>\<^sub>* },
             refers_to = (\<lambda>x y. x \<hookrightarrow>\<^sub>* y \<and> x \<notin> excluded_moments U)
          \<rparr>"

lemma project_simps:
  "individuals (project U) = \<I>\<^sub>* - (excluded_moments U)"
  "inheres_in (project U) =  (\<lambda>x y. x \<triangleleft>\<^sub>* y \<and> x \<notin> excluded_moments U)"
  "exactly_similar_to (project U) = (\<lambda>x y. x \<simeq>\<^sub>* y \<and> x \<notin> excluded_moments U \<and> y \<notin> excluded_moments U)"
  "worlds (project U)  = { w - excluded_moments U | w . w \<in> \<W>\<^sub>* }"
  "refers_to (project U) = (\<lambda>x y. x \<hookrightarrow>\<^sub>* y \<and> x \<notin> excluded_moments U)"
  "moments (project U) = \<M>\<^sub>* - excluded_moments U"
  "substantials (project U) = \<S>\<^sub>*"
  by (auto simp add: project_def excluded_moments_def moments_def)

declare project_simps(2,3,4,5,6,7)[simp]

abbreviation "ProjEquiPerms U \<equiv>
  individual_structure_defs.ClosedPerms (project U) (\<sim>)"

end

context instantiation_structure
begin

context
  fixes U
  assumes U_subst_univ[simp,intro!]:"U \<in> \<U>\<^sub>s\<^sub>*"
begin

abbreviation projected_structure :: "'i individual_structure" ("IS\<^sup>\<down>")  where
  "IS\<^sup>\<down> \<equiv>  project U"

abbreviation projected_out_moments :: "'i set" ("\<Delta>")  where
  "\<Delta> \<equiv> excluded_moments U"

private abbreviation projected_moments ("\<M>\<^sup>\<down>")
  where "\<M>\<^sup>\<down> \<equiv> moments IS\<^sup>\<down>"

private abbreviation projected_individuals ("\<I>\<^sup>\<down>")
  where "\<I>\<^sup>\<down> \<equiv> individuals IS\<^sup>\<down>"

private abbreviation projected_worlds ("\<W>\<^sup>\<down>")
  where "\<W>\<^sup>\<down> \<equiv> worlds IS\<^sup>\<down>"

abbreviation projected_inheres_in (infix "\<triangleleft>\<^sup>\<down>" 75)
  where "(\<triangleleft>\<^sup>\<down>) \<equiv> inheres_in IS\<^sup>\<down>"

abbreviation projected_similar_to (infix "\<simeq>\<^sup>\<down>" 75) where
  "(\<simeq>\<^sup>\<down>) \<equiv> exactly_similar_to IS\<^sup>\<down>"

abbreviation projected_refers_to (infix "\<hookrightarrow>\<^sup>\<down>" 75) where
  "(\<hookrightarrow>\<^sup>\<down>) \<equiv> refers_to IS\<^sup>\<down>"

abbreviation projected_bearer ("\<beta>\<^sup>\<down>") where
  "\<beta>\<^sup>\<down> \<equiv> bearer IS\<^sup>\<down>"

abbreviation projected_ed ("ed\<^sup>\<down>") where
  "ed\<^sup>\<down> \<equiv> existentially_dependent IS\<^sup>\<down>"

lemma delta_closed_on_sim[simp,intro!]: "closure_rel_P (\<sim>) \<Delta>"
proof -
  interpret P: closure_rel_P "(\<sim>)" "\<I>\<^sub>*" by simp
  have A: "\<forall>x. x \<in> \<Delta> \<longrightarrow> x \<sim> x" using P.refl inheres_in_scope by auto
  have B: "\<forall>x y. x \<sim> y \<longrightarrow> y \<sim> x" by auto
  have C: "\<forall>x y z. x \<sim> y \<longrightarrow> y \<sim> z \<longrightarrow> x \<sim> z" by (meson P.trans)
  show ?thesis
  proof (unfold_locales ; (atomize (full))? ; (intro A B C)? ; safe)
    fix x y
    assume as: "x \<sim> y" "x \<in> \<Delta>"
    obtain D: "x \<in> \<M>\<^sub>*" "\<beta>\<^sub>* x \<Colon>\<^sub>\<diamondop> U" "\<And>u'. char_by\<^sub>* U u' \<Longrightarrow> \<not> x \<Colon>\<^sub>m\<^sub>\<diamondop> u'"
      using as(2) by blast
    obtain E: "y \<in> \<M>\<^sub>*" "x \<sim>\<^sub>m y" using equi_instances_simps(3)[OF D(1),of y] as(1) by metis
    obtain F[simp]: "\<And>u. x \<Colon>\<^sub>m\<^sub>\<diamondop> u = y \<Colon>\<^sub>m\<^sub>\<diamondop> u" and G: "\<beta>\<^sub>* x \<sim>\<^sub>s \<beta>\<^sub>* y"
      using equi_instances_M_E[OF E(2)] by metis
    obtain H: "\<beta>\<^sub>* x \<in> \<S>\<^sub>*" "\<beta>\<^sub>* y \<in> \<S>\<^sub>*" and I[simp]: "\<And>U w. \<beta>\<^sub>* x \<Colon>\<^sub>s\<^bsub>w\<^esub> U = \<beta>\<^sub>* y \<Colon>\<^sub>s\<^bsub>w\<^esub> U"
      using equi_instances_S_E[OF G] by metis
    obtain w\<^sub>x where J: "\<beta>\<^sub>* x \<Colon>\<^sub>s\<^bsub>w\<^sub>x\<^esub> U" using D(2) H(1) by (meson iof_S_simp miof_E)
    obtain K: "w\<^sub>x \<in> \<W>\<^sub>*" "\<beta>\<^sub>* x \<in> w\<^sub>x" "\<And>u. u \<in> char_set\<^sub>* U \<Longrightarrow> \<exists>m. m \<triangleleft>\<^sub>* \<beta>\<^sub>* x \<and> m \<Colon>\<^sub>m\<^bsub>w\<^sub>x\<^esub> u"
      using substantial_iof_E[OF J] by metis
    obtain L: "\<beta>\<^sub>* y \<Colon>\<^sub>s\<^bsub>w\<^sub>x\<^esub> U" using I[THEN iffD1,OF J(1)] by metis
    then have L1: "\<beta>\<^sub>* y \<in> w\<^sub>x" by blast
    obtain M: "\<beta>\<^sub>* y \<Colon>\<^sub>\<diamondop> U" using L miof_I iof_S_I by metis
    have N: " \<forall>u'. char_by\<^sub>* U u' \<longrightarrow> \<not> y \<Colon>\<^sub>m\<^sub>\<diamondop> u'"
    proof (intro allI impI notI)
      fix u'
      assume AA: "char_by\<^sub>* U u'" and BB: "y \<Colon>\<^sub>m\<^sub>\<diamondop> u'"
      then have "x \<Colon>\<^sub>m\<^sub>\<diamondop> u'" by simp
      then show False using D(3)[OF AA] by simp
    qed
    show "y \<in> \<Delta>"
      by (intro excluded_moments_I E(1) M ; atomize (full) ; intro N)
  qed
qed

interpretation delta_closure: closure_rel_P "(\<sim>)" \<Delta> by simp

lemma proj_indiv_closed_on_sim[simp,intro!]: "closure_rel_P (\<sim>) (\<I>\<^sup>\<down>)"
  by (simp only: project_simps(1) ; intro closure_rel_combs(3) ; simp)

lemma substantials_closed_on_sim[simp,intro!]: "closure_rel_P (\<sim>) \<S>\<^sub>*"
  apply (unfold_locales)
  subgoal G1 by blast
  apply (simp only: equi_instances_iff ; elim disjE conjE ; simp)
  using substantials_moments_disj_2 by metis

lemma moments_closed_on_sim[simp,intro!]: "closure_rel_P (\<sim>) \<M>\<^sub>*"
  apply (subgoal_tac "\<M>\<^sub>* = \<I>\<^sub>* - \<S>\<^sub>*")
  subgoal using closure_rel_combs(3)[of "(\<sim>)" "\<I>\<^sub>*" "\<S>\<^sub>*"] by auto
  apply (simp only: individuals_moments_substantials)
  using substantials_moments_disj by blast

lemma projected_out_moments_are_moments:  "\<Delta> \<subseteq> \<M>\<^sub>*"
  by (meson momentsI excluded_moments_iff subsetI)

lemma project_individuals_eq: "\<I>\<^sup>\<down> = \<S>\<^sub>* \<union> \<M>\<^sub>* - \<Delta>"
  by (simp add: project_simps(1) individuals_moments_substantials)

lemma project_individuals_cases:
  assumes "x \<in> \<I>\<^sup>\<down>"
  obtains (c1) "x \<in> \<S>\<^sub>*" | (c2) "x \<in> \<M>\<^sub>*" "x \<notin> \<Delta>"
  using assms by (simp add: project_individuals_eq ; blast)

lemma project_ed_simp[simp]:
  "ed\<^sup>\<down> x y \<longleftrightarrow> ed\<^sub>* x y \<and> x \<notin> \<Delta> \<and> y \<notin> \<Delta>" (is "?A \<longleftrightarrow> ?B")
proof -
  have C: "\<lbrakk> w \<in> \<W>\<^sup>\<down> ; x \<in> w \<rbrakk> \<Longrightarrow> x \<in> \<I>\<^sub>*" for x w
    apply (simp add: project_individuals_eq ; elim exE conjE ; hypsubst ; elim DiffE)
    using worlds_are_made_of_individuals by blast
  show ?thesis
  proof (*   *)
    assume as: "?A"
    then obtain A: "x \<in> \<I>\<^sup>\<down>" "y \<in> \<I>\<^sup>\<down>"
          "\<And>w. \<lbrakk> w \<in> \<W>\<^sup>\<down> ; x \<in> w \<rbrakk> \<Longrightarrow> y \<in> w"
      using ed_E[OF as]  by (simp ; metis)
    note B = A(1,2)[THEN project_individuals_cases]
    obtain D[simp,intro!]: "x \<in> \<I>\<^sub>*" "y \<in> \<I>\<^sub>*" using B individuals_moments_substantials Un_iff by metis
    obtain E[simp,intro!]: "x \<notin> \<Delta>" "y \<notin> \<Delta>"
      using A(1,2)
      by (simp add: project_individuals_eq)
    show "?B"
      apply (intro iffI ed_I allI conjI impI; (elim ed_E conjE)? ; simp?)
      subgoal for w
        using A(3)[simplified, OF exI[of _ w], of "w - \<Delta>",simplified]
        by metis
      done
  next
    assume as: "?B"
    then obtain "ed\<^sub>* x y" and A[simp,intro!]: "x \<notin> \<Delta>" "y \<notin> \<Delta>" by metis
    then obtain B: "x \<in> \<I>\<^sub>*" "y \<in> \<I>\<^sub>*" "\<And>w. \<lbrakk> w \<in> \<W>\<^sub>* ; x \<in> w \<rbrakk> \<Longrightarrow> y \<in> w" using ed_E by metis
    obtain D[simp,intro!]: "x \<in> \<I>\<^sup>\<down>" "y \<in> \<I>\<^sup>\<down>"
      using A B(1,2) that by (simp add: project_simps(1))
    show ?A
      by (intro ed_I ; simp add: B project_simps(1) ; clarify
            ; simp add: B(3))
  qed
qed

lemma project_individual_structure[intro!,simp]: "individual_structure IS\<^sup>\<down>"
  supply project_simps(1)[simp]
  apply (unfold_locales ; (simp add: excluded_moments_iff)?
      ; (elim conjE exE)? ; (intro impI allI)?)
  subgoal G1 using inheres_in_scope by blast
  subgoal G2 by blast
  subgoal G3 using inheres_in_sep by blast
  subgoal G4 using exactly_similar_scope by presburger
  subgoal G6 by (simp add: exactly_similar_refl)
  subgoal G7 by blast
  subgoal G8 by (simp add: Diff_mono worlds_are_made_of_individuals)
  subgoal G9 by (metis Diff_iff excluded_moments_E individuals_iff)
  subgoal G10 using inherence_imp_ed by auto
  subgoal G11 by (simp add: refers_to_scope)
  subgoal G12 by (simp add: refers_to_diff_bearer)
  subgoal G13 by (meson refers_to_imp_ed refers_to_scope substantials_moments_disj_2)
  done

interpretation IS': individual_structure "IS\<^sup>\<down>" using U_subst_univ by simp

lemma project_substructure: "individual_substructure IS\<^sup>\<down> \<I>\<S>"
proof -
  interpret P: individual_structure "IS\<^sup>\<down>" by simp
  show ?thesis
    apply (intro_locales ; unfold_locales ; clarsimp simp: excluded_moments_iff existentially_dependent_def project_simps(1))
    subgoal G1 by (metis Diff_iff excluded_moments_iff )
    subgoal G2 for w
      apply (rule ccontr ; simp)
      subgoal premises P
        apply (rule notE[OF P(2)[rule_format,of w,simplified] P(1)])
        using projected_out_moments_are_moments P(1)
              worlds_are_made_of_individuals individuals_moments_substantials
        by blast
      done
    subgoal G3 premises P for w
      using G2[OF P(1)] apply (elim exE conjE)
      subgoal for w'
        apply (intro exI[of _ w] conjI ; (simp add: P(1))?)
        subgoal premises Q
          apply (simp only: Q(1)[symmetric])
          using projected_out_moments_are_moments P(1)
              worlds_are_made_of_individuals individuals_moments_substantials
          by blast
        done
      done
    done
qed

lemma project_out_moments_mono[intro!]:
  assumes "U \<preceq>\<^sub>s\<^sub>* U'"
  shows "\<Delta> \<subseteq> excluded_moments U'"
  apply (intro subsetI)
  subgoal for x
    apply (intro excluded_moments_I)
    subgoal G1 using assms bearer_eq miof_agrees_with_subsumes subsumesI_S by auto
    subgoal G2 using bearer_eq by (meson assms excluded_moments_iff miof_agrees_with_subsumes subsumesI_S)
    using assms char_by_scope(1) subst_subsumes_by_char_set by auto
  done

lemma individuals_exhaust_2:
  obtains "y \<in> \<I>\<^sub>*" "y \<in> \<S>\<^sub>*" "y \<notin> \<M>\<^sub>*" "y \<notin> \<Delta>" "y \<noteq> undefined"  |
          "y \<in> \<I>\<^sub>*" "y \<notin> \<S>\<^sub>*" "y \<in> \<M>\<^sub>*" "y \<notin> \<Delta>" "y \<noteq> undefined" |
          "y \<in> \<I>\<^sub>*" "y \<notin> \<S>\<^sub>*" "y \<in> \<M>\<^sub>*" "y \<in> \<Delta>" "y \<noteq> undefined" |
          "y \<notin> \<I>\<^sub>*" "y \<notin> \<M>\<^sub>*" "y \<notin> \<S>\<^sub>*" "y \<notin> \<Delta>" "y = undefined" |
          "y \<notin> \<I>\<^sub>*" "y \<notin> \<M>\<^sub>*" "y \<notin> \<S>\<^sub>*" "y \<notin> \<Delta>" "y \<noteq> undefined"
proof -
  have B: "y \<in> \<Delta> \<Longrightarrow> y \<in> \<M>\<^sub>*" using projected_out_moments_are_moments by blast
  have C: "y \<in> \<S>\<^sub>* \<Longrightarrow> y \<in> \<I>\<^sub>*" by blast
  have D: "y \<in> \<M>\<^sub>* \<Longrightarrow> y \<in> \<I>\<^sub>*" by blast
  have E: "y = undefined \<Longrightarrow> y \<notin> \<I>\<^sub>*" by simp
  have G: "\<lbrakk> y \<notin> \<S>\<^sub>* ; y \<notin> \<M>\<^sub>* \<rbrakk> \<Longrightarrow> y \<notin> \<I>\<^sub>*" by blast
  have I: "y \<in> \<M>\<^sub>* \<Longrightarrow> y \<notin> \<S>\<^sub>*"  by blast
  note simps = B C D E G I
  show ?thesis
    by (cases "y \<in> \<I>\<^sub>*" ; cases "y \<in> \<S>\<^sub>*" ; cases "y \<in> \<M>\<^sub>*" ; cases "y \<in> \<Delta>" ; cases "y = undefined"
        ; insert simps that ; metis)
qed

context
  fixes \<Omega>
  assumes \<Omega>_EquiPerm[iff]: "\<Omega> \<in> EquiPerms"
begin

lemma \<Omega>_Perm[iff]: "\<Omega> \<in> Perms" and
      \<Omega>_closed_I[simp]: "\<And>x. x \<in> \<I>\<^sub>* \<Longrightarrow> x \<sim> (\<Omega> x)"
  using ClosedPermsE[OF \<Omega>_EquiPerm] by metis+

interpretation  individual_structure_permutation_morphism \<I>\<S> \<Omega>
  using Perms_def by blast

interpretation m_inv: individual_structure_permutation_morphism \<I>\<S> \<Theta>
  using m_inv_individual_structure_permutation_morphism by simp

interpretation IS'_IS: individual_substructure  "IS\<^sup>\<down>" \<I>\<S>
  using project_substructure by simp

declare IS'_IS.preserve_inherence[simp del]
    IS'_IS.preserve_exact_similarity[simp del]
    IS'_IS.m_preserve_ext_dep[simp del]

lemmas fliped_IS'_IS_simps[simp] = IS'_IS.preserve_inherence[symmetric]
    IS'_IS.preserve_exact_similarity[symmetric]
    IS'_IS.m_preserve_ext_dep[symmetric]

definition proj_morph ("\<Omega>\<^sup>\<down>") where "\<Omega>\<^sup>\<down> y \<equiv> if y \<in> \<I>\<^sup>\<down> then \<Omega> y else undefined"

private lemma worlds1: "{w \<inter> \<Omega> ` \<I>\<^sub>* |w. w \<in> \<W>\<^sub>*} = \<W>\<^sub>*" for w
  apply (simp ; intro set_eqI ; simp ; intro iffI ; (elim exE)? ; simp?)
  subgoal for w\<^sub>1
    by (intro exI[of _ w\<^sub>1] ; simp)
  done

lemma m_preserve_m_iof[simp]:
  fixes y u
  shows "\<Omega> y \<Colon>\<^sub>m\<^sub>\<diamondop> u \<longleftrightarrow> y \<Colon>\<^sub>m\<^sub>\<diamondop> u"
proof (intro iffI)
  show "\<Omega> y \<Colon>\<^sub>m\<^sub>\<diamondop> u"  if as:  "y \<Colon>\<^sub>m\<^sub>\<diamondop> u"
  proof -
    obtain A: "y \<in> \<M>\<^sub>*" "\<Omega> y \<in> \<M>\<^sub>*" using as
      by (simp add: moment_miof_scope)
    have B: "y \<simeq>\<^sub>* \<Omega> y" using m_strong_preserve_similarity[OF A(1)] by simp
    have C: "\<Omega> y \<Colon>\<^sub>m\<^bsub>w\<^sub>2\<^esub> u" if "y \<Colon>\<^sub>m\<^bsub>w\<^sub>1\<^esub> u" "w\<^sub>2 \<in> \<W>\<^sub>*" "\<Omega> y \<in> w\<^sub>2" for w\<^sub>1 w\<^sub>2 u
      using moment_iof_agrees_with_similarity[OF B,of w\<^sub>1 u w\<^sub>2] that by blast
    obtain w\<^sub>1 where AA: "y \<Colon>\<^sub>m\<^bsub>w\<^sub>1\<^esub> u" using as that(1) A(1) \<open>y \<Colon>\<^sub>m\<^sub>\<diamondop> u\<close> every_individual_exists_somewhere by blast
    obtain w\<^sub>2 where BB: "w\<^sub>2 \<in> \<W>\<^sub>*" "\<Omega> y \<in> w\<^sub>2"  using A(2) every_individual_exists_somewhere moments_are_individuals by blast
    show ?thesis using BB(1) C[OF AA BB] by simp
  qed
  show "y \<Colon>\<^sub>m\<^sub>\<diamondop> u"  if as:  "\<Omega> y \<Colon>\<^sub>m\<^sub>\<diamondop> u"
  proof -
    obtain A: "y \<in> \<M>\<^sub>*" "\<Omega> y \<in> \<M>\<^sub>*" using as
      using moment_miof_scope by blast
    have B: "\<Omega> y \<simeq>\<^sub>* y" using m_strong_preserve_similarity[OF A(1)] by simp
    have C: "y \<Colon>\<^sub>m\<^bsub>w\<^sub>2\<^esub> u" if "\<Omega> y \<Colon>\<^sub>m\<^bsub>w\<^sub>1\<^esub> u" "w\<^sub>2 \<in> \<W>\<^sub>*" "y \<in> w\<^sub>2" for w\<^sub>1 w\<^sub>2 u
      using moment_iof_agrees_with_similarity[OF B,of w\<^sub>1 u w\<^sub>2] that by blast
    obtain w\<^sub>1 where AA: "\<Omega> y \<Colon>\<^sub>m\<^bsub>w\<^sub>1\<^esub> u" using as that(1) A(1) \<open>\<Omega> y \<Colon>\<^sub>m\<^sub>\<diamondop> u\<close> every_individual_exists_somewhere
      by (meson A(2) moments_are_individuals)
    obtain w\<^sub>2 where BB: "w\<^sub>2 \<in> \<W>\<^sub>*" "y \<in> w\<^sub>2"  using A(2) every_individual_exists_somewhere moments_are_individuals by blast
    show ?thesis using BB(1) C[OF AA BB] by simp
  qed
qed

lemma m_preserve_s_iof:
  fixes x\<^sub>s U\<^sub>s
  shows "\<Omega> x\<^sub>s \<Colon>\<^sub>s\<^bsub>\<Omega> ` w\<^esub> U\<^sub>s \<longleftrightarrow> x\<^sub>s \<Colon>\<^sub>s\<^bsub>w\<^esub> U\<^sub>s" (is "?Q \<longleftrightarrow> ?P")
proof -
  { assume A: "x\<^sub>s \<in> \<S>\<^sub>*" "w \<in> \<W>\<^sub>*" "U\<^sub>s \<in> \<U>\<^sub>s\<^sub>*"
    have "?P \<longleftrightarrow> ?Q"
    proof
      assume as: "?P"
      then obtain AA: "x\<^sub>s \<in> \<S>\<^sub>*" "U\<^sub>s \<in> \<U>\<^sub>s\<^sub>*" "w \<in> \<W>\<^sub>*" "x\<^sub>s \<in> w" "\<And>u. u \<in> char_set\<^sub>* U\<^sub>s \<Longrightarrow> \<exists>x.  x \<triangleleft>\<^sub>* x\<^sub>s \<and> x \<Colon>\<^sub>m\<^bsub>w\<^esub> u"
        using substantial_iof_E[OF as] by blast
      then have BB: "\<And>u. char_by\<^sub>*  U\<^sub>s u \<Longrightarrow> \<exists>x. x \<triangleleft>\<^sub>* x\<^sub>s \<and> x \<Colon>\<^sub>m\<^bsub>w\<^esub> u" using AA(5) by blast
      have CC: "char_by\<^sub>* U\<^sub>s u \<Longrightarrow> (\<And>x. \<lbrakk> x \<triangleleft>\<^sub>* x\<^sub>s ; x \<Colon>\<^sub>m\<^bsub>w\<^esub> u \<rbrakk> \<Longrightarrow> Q) \<Longrightarrow> Q" for u Q
        using BB by blast
      obtain DD: "\<Omega> x\<^sub>s \<in> \<S>\<^sub>*" "\<Omega> ` w \<in> \<W>\<^sub>*" "\<Omega> x\<^sub>s \<in> \<Omega> ` w"
        using AA(1,3,4) by simp
      show "?Q"
      proof (intro substantial_iof_I AA(2) DD ; elim char_set_E)
        fix u
        assume as1: "char_by\<^sub>* U\<^sub>s u"
        obtain n where AAA: "n \<triangleleft>\<^sub>* x\<^sub>s" "n \<Colon>\<^sub>m\<^bsub>w\<^esub> u" using CC[OF as1] by blast
        then obtain "\<Omega> n \<triangleleft>\<^sub>* \<Omega> x\<^sub>s" "\<Omega> n \<Colon>\<^sub>m\<^bsub>\<Omega> ` w\<^esub> u" by simp
        then show "\<exists>ma. ma \<triangleleft>\<^sub>* \<Omega> x\<^sub>s \<and> ma \<Colon>\<^sub>m\<^bsub>\<Omega> ` w\<^esub> u" by blast
      qed
    next
      assume as: "?Q"
      obtain AA: "\<Omega> x\<^sub>s \<in> \<S>\<^sub>*" "U\<^sub>s \<in> \<U>\<^sub>s\<^sub>*" "\<Omega> ` w \<in> \<W>\<^sub>*" "\<Omega> x\<^sub>s \<in> \<Omega> ` w" "\<And>u. u \<in> char_set\<^sub>* U\<^sub>s \<Longrightarrow> \<exists>z. z \<triangleleft>\<^sub>* \<Omega> x\<^sub>s \<and> z \<Colon>\<^sub>m\<^bsub>\<Omega> ` w\<^esub> u"
        using substantial_iof_E[OF as] by metis
      then have BB: "\<And>u. char_by\<^sub>*  U\<^sub>s u \<Longrightarrow> \<exists>z. z \<triangleleft>\<^sub>* \<Omega> x\<^sub>s \<and> z \<Colon>\<^sub>m\<^bsub>\<Omega> ` w\<^esub> u" using AA(5) by blast
      have CC: "char_by\<^sub>* U\<^sub>s u \<Longrightarrow> (\<And>x. \<lbrakk> x \<triangleleft>\<^sub>* \<Omega> x\<^sub>s ; x \<Colon>\<^sub>m\<^bsub>\<Omega> ` w\<^esub> u \<rbrakk> \<Longrightarrow> Q) \<Longrightarrow> Q" for u Q
        using BB by blast
      obtain DD: "x\<^sub>s \<in> \<S>\<^sub>*" "w \<in> \<W>\<^sub>*" "x\<^sub>s \<in> w"
        using AA(1,3,4) by (metis A(1) A(2) image_eqI m_inv_substantials src_world_inv_m)
      show "?P"
      proof (intro substantial_iof_I AA(2) DD ; elim char_set_E)
        fix u
        assume as1: "char_by\<^sub>* U\<^sub>s u"
        obtain n where AAA: "n \<triangleleft>\<^sub>* \<Omega> x\<^sub>s" "n \<Colon>\<^sub>m\<^bsub>\<Omega> ` w\<^esub> u" using CC[OF as1] by blast
        have BBB: "n = \<Omega> (\<Theta> n)"  using AAA(1) inheres_in_scope by simp
        obtain CCC: "\<Omega> (\<Theta> n) \<triangleleft>\<^sub>* \<Omega> x\<^sub>s" "\<Omega> (\<Theta> n) \<Colon>\<^sub>m\<^bsub>\<Omega> ` w\<^esub> u"
          using that BBB AAA by metis
        then obtain DDD: "\<Theta> n \<triangleleft>\<^sub>* x\<^sub>s" "\<Theta> n \<Colon>\<^sub>m\<^bsub>w\<^esub> u"
          by (metis BBB DD(2) image_eqI m_preserve_inherence src_world_inv_m m_preserve_m_iof)
        then show "\<exists>ma. ma \<triangleleft>\<^sub>* x\<^sub>s \<and> ma \<Colon>\<^sub>m\<^bsub>w\<^esub> u" by blast
      qed
    qed }
  note R1 = this
  obtain R2: "x\<^sub>s \<in> \<S>\<^sub>*" "w \<in> \<W>\<^sub>*" "U\<^sub>s \<in> \<U>\<^sub>s\<^sub>*" if "?P \<or> ?Q"
    using m_w_W by blast
  show ?thesis using R1 R2 by metis
qed

lemma m_preserve_inv_s_iof[simp]:
  fixes x\<^sub>s U\<^sub>s
  shows "x\<^sub>s \<Colon>\<^sub>s\<^bsub>\<Omega> ` w\<^esub> U\<^sub>s \<longleftrightarrow> \<Theta> x\<^sub>s \<Colon>\<^sub>s\<^bsub>w\<^esub> U\<^sub>s" (is "?P \<longleftrightarrow> ?Q")
proof -
  have R1: ?thesis if as: "x\<^sub>s \<in> \<S>\<^sub>*" "w \<in> \<W>\<^sub>*" "U\<^sub>s \<in> \<U>\<^sub>s\<^sub>*"
  proof -
    have A[simp]: "\<Omega> (\<Theta> x\<^sub>s) = x\<^sub>s" using as
      by (simp add: substantials_are_individuals)
    have B[simp]: "\<Omega> ` \<Theta> ` w = w" using as
      using tgt_world_m_inv by blast
    show ?thesis using m_preserve_s_iof[of "\<Theta> x\<^sub>s" "w" U\<^sub>s,simplified A,symmetric] by simp
  qed
  obtain R2: "x\<^sub>s \<in> \<S>\<^sub>*" "w \<in> \<W>\<^sub>*" "U\<^sub>s \<in> \<U>\<^sub>s\<^sub>*" if "?Q \<or> ?P"
    using m_w_W by blast
  show ?thesis using R1 R2 by metis
qed

lemma miof_moments_iff: "u \<in> \<U>\<^sub>m\<^sub>* \<or> y \<in> \<M>\<^sub>* \<Longrightarrow> y \<Colon>\<^sub>\<diamondop> u \<longleftrightarrow> y \<Colon>\<^sub>m\<^sub>\<diamondop> u" for u y
  using miof_I miof_E iof_I
  by (metis every_individual_exists_somewhere iof_M_simp moment_miof_scope moments_are_individuals)

lemma miof_substantials_iff: "u \<in> \<U>\<^sub>s\<^sub>* \<or> y \<in> \<S>\<^sub>* \<Longrightarrow> y \<Colon>\<^sub>\<diamondop> u \<longleftrightarrow> (\<exists>w. y \<Colon>\<^sub>s\<^bsub>w\<^esub> u)" for u y
  using miof_I miof_E iof_I
  by (metis iof_S_simp)

lemma miof_out_scope: "\<lbrakk> u \<notin> \<U>\<^sub>* \<or> y \<notin> \<I>\<^sub>* \<rbrakk> \<Longrightarrow> \<not> y \<Colon>\<^sub>\<diamondop> u" for u y
  by (meson iof_scope iof_scope_E miof_E moments_are_individuals substantials_are_individuals)

lemmas miof_sep_simps = miof_moments_iff miof_substantials_iff miof_out_scope

lemma m_preserve_miof[simp]:
  fixes y u
  shows "\<Omega> y \<Colon>\<^sub>\<diamondop> u \<longleftrightarrow> y \<Colon>\<^sub>\<diamondop> u" (is "?P \<longleftrightarrow> ?Q")
  apply (cases "y \<in> \<I>\<^sub>*")
  subgoal inI
    apply (cases y rule: individuals_cases ; simp add: miof_sep_simps)
    apply (intro ex_iff_exI[where ?f="(`) \<Theta>" and ?g="(`) \<Omega>"] ; simp?)
    subgoal for w
      apply (simp only: m_preserve_s_iof[of y "\<Theta> ` w" u,symmetric])
      apply (cases "w \<in> \<W>\<^sub>*" ; simp)
      subgoal premises P
        using P(4,5) substantial_iof_E by metis
      done
    done
  subgoal notInI by (simp add: miof_out_scope)
  done

lemma m_projected_out_moments[simp]: "\<And>x. \<Omega> x \<in> \<Delta> \<longleftrightarrow> x \<in> \<Delta>"
  by (smt \<Omega>_closed_I delta_closure.closed_iff individuals_exhaust_2 m_undefined_1(2))

lemma m_inv_projected_out_moments[simp]: "\<And>x. \<Theta> x \<in> \<Delta> \<longleftrightarrow> x \<in> \<Delta>"
proof -
  fix x
  show "?thesis x"
  proof -
    have "x \<in> \<M>\<^sub>* \<or> (\<Theta> x \<in> \<Delta>) = (x \<in> \<Delta>)"
      by blast
    then show ?thesis
      by (metis (full_types) m_projected_out_moments[symmetric,of "\<Theta> x"] m_inv_inv_moments_iff m_surjective_on_moments)
  qed
qed

lemma m'_image1: "X \<subseteq> \<I>\<^sup>\<down> \<Longrightarrow> \<Omega>\<^sup>\<down> ` X = \<Omega> ` X"
  by (simp add: subset_iff ; intro set_eqI ; simp add: image_iff Bex_def
        ; intro ex_iff_exI[where ?f=id and ?g=id] ; simp
        ; elim conjE ; hypsubst_thin?
        ; simp add: proj_morph_def)

private lemma not_image_E:
  assumes "f y \<notin> f ` Y"
  obtains "y \<notin> Y" using assms imageI by metis

private lemma image_Diff_subset: "\<lbrakk> Y \<subseteq> X ; f ` X \<inter> f ` Y = {} \<rbrakk> \<Longrightarrow> f ` (X - Y) = f ` X - f ` Y"
  by blast

lemma m'_inj_on[intro!,simp]: "inj_on \<Omega>\<^sup>\<down> (\<I>\<^sup>\<down>)"
  apply (intro inj_onI ; simp only: proj_morph_def if_True)
  apply (rule m_injective[THEN inj_onD])
  using individuals_moments_substantials IS'_IS.individuals_subset by blast+

private lemma m'_image3: "\<Omega>\<^sup>\<down> ` (\<S>\<^sub>* \<union> (\<M>\<^sub>* - \<Delta>)) = (\<S>\<^sub>* \<union> (\<M>\<^sub>* - \<Delta>))"
  apply (simp only: project_simps(1)[of U,symmetric] set_eq_iff image_iff Bex_def)
  apply (intro allI iffI ; (elim exE conjE ; hypsubst_thin)?)
  subgoal by (metis Diff_iff IS'.individuals_moments_substantials IS'_IS.same_substantials m_inv_individuals m_inv_scope_individuals m_projected_out_moments m_surjective' proj_morph_def project_simps(1) project_simps(6))
  subgoal for a apply (intro exI[of _ "\<Theta> a"] ; simp)
    using proj_morph_def project_individuals_eq by auto
  done

definition world_lift :: "'i set \<Rightarrow> 'i set" ("_\<up>" [1000] 999)
  where "w\<up> \<equiv> SOME w'. w' \<in> \<W>\<^sub>* \<and> w = w' \<inter> - \<Delta>"

definition world_project :: "'i set \<Rightarrow> 'i set" ("_\<down>" [1000] 999)
  where "w\<down> \<equiv> w - \<Delta>"

lemma world_project_I[intro!]: "w \<in> \<W>\<^sub>* \<Longrightarrow> w\<down> \<in> \<W>\<^sup>\<down>"
  by (simp add: world_project_def ; blast)

lemma world_project_subset_2[intro!]: "w \<in> \<W>\<^sub>* \<Longrightarrow> w\<down> \<subseteq> \<I>\<^sub>*"
  apply (simp add: world_project_def)
  by (meson Diff_subset dual_order.trans worlds_are_made_of_individuals)

lemma world_project_eq_int:
  assumes "w \<in> \<W>\<^sub>*"
  shows "w\<down> = w \<inter> \<I>\<^sup>\<down>"
proof -
  have A: "A = B \<inter> C" if "A = B - D" "C \<inter> D = {}" "B \<subseteq> C \<union> D" for A B C D :: "'z set"
    using that by blast
  show ?thesis
    apply (intro A[of _ _ \<Delta>])
    subgoal using world_project_def by simp
    subgoal by (simp only: project_simps(1) ; blast)
    subgoal  using worlds_are_made_of_individuals[OF assms]
      apply (simp only: project_simps(1)) by blast
    done
qed

lemma exist_lift[intro!,simp]:
  assumes "w \<in> \<W>\<^sup>\<down>"
  shows "\<exists>w'. w' \<in> \<W>\<^sub>* \<and> w = w' \<inter> - \<Delta>"
proof -
  have "\<exists>I. w = I - \<Delta> \<and> I \<in> \<W>\<^sub>*"
    using assms by force
  then show ?thesis
    by blast
qed

lemma world_lift_E[elim!]:
  assumes "w \<in> \<W>\<^sup>\<down>"
  obtains "w\<up> \<in> \<W>\<^sub>*" "w = w\<up> \<inter> \<I>\<^sup>\<down>" "w = w\<up> - \<Delta>"
  using someI_ex[OF exist_lift[OF assms]] world_lift_def
  by (metis Diff_eq world_project_def world_project_eq_int)

lemma world_lift_D:
  assumes "w \<in> \<W>\<^sup>\<down>"
  shows "w\<up> \<in> \<W>\<^sub>*" "w = w\<up> \<inter> - \<Delta>"
  using world_lift_E[OF assms] by blast+

lemma world_lift_project[simp]:
  assumes "w \<in> \<W>\<^sup>\<down>"
  shows "(w\<up>)\<down> = w"
  using assms
  by (metis world_lift_E world_project_def)

lemma delta_morph[simp]: "\<Omega> ` \<Delta> = \<Delta>"
proof -
  note m_projected_out_moments
  note delta_closure.closed delta_closure.closed[OF delta_closure.sym]
  show ?thesis
    apply (intro equalityI subsetI ; (elim imageE)? ; hypsubst_thin?)
    subgoal using m_projected_out_moments by simp
    subgoal for x
      apply (intro rev_image_eqI[of "\<Theta> x"])
      subgoal using m_inv_projected_out_moments by simp
      subgoal
        apply (subgoal_tac "x \<in> \<I>\<^sub>*" ; simp?)
        by blast
      done
    done
qed

lemma delta_inv_morph[simp]: "\<Theta> ` \<Delta> = \<Delta>"
proof -
  show ?thesis when A: "\<Omega> ` \<Delta> = \<Omega> ` (\<Theta> ` \<Delta>)" (is "?Q")
    apply (rule m_image_injective_on_subsets_of_I[THEN inj_onD])
    subgoal using A by simp
    subgoal
    proof -
      have "\<And>i. i \<notin> \<Delta> \<or> \<Theta> i \<in> \<I>\<^sub>*"
        using individuals_exhaust_2 by auto
      then show ?thesis
        by blast
    qed
    using projected_out_moments_are_moments by auto
  have "\<Omega> ` \<Theta> ` \<Delta> = \<Delta>"
    by (meson m_comp_m_inv_I_image' moments_subset_individuals projected_out_moments_are_moments subset_trans)
  then show ?Q
    using delta_morph by simp
qed

lemma proj_morph_world_proj:
  assumes "w \<in> \<W>\<^sub>*"
  shows "\<Omega>\<^sup>\<down> ` w\<down> = (\<Omega> ` w) \<inter> \<I>\<^sup>\<down>"
proof -

  have "\<Omega>\<^sup>\<down> ` w\<down> = \<Omega>\<^sup>\<down> ` (w \<inter> \<I>\<^sup>\<down>)" using assms world_project_eq_int by simp
  also have "... = \<Omega> ` (w \<inter> \<I>\<^sup>\<down>)" by (simp add: m'_image1)
  oops

lemma delta_in_individuals[intro!,simp]: "\<Delta> \<subseteq> \<I>\<^sub>*"
    using projected_out_moments_are_moments by auto

lemma m_inv_image_subset_I_down: "X \<subseteq> \<I>\<^sup>\<down> \<Longrightarrow> \<Theta> ` X \<subseteq> \<I>\<^sup>\<down>"
  by (smt IS'.individuals_moments_substantials IS'_IS.moments_subset IS'_IS.same_substantials delta_inv_morph
      image_Un image_mono inj_on_image_set_diff project_simps(6) instantiation_structure_axioms
      m_inv.m_injective_on_moments m_inv.m_surjective_on_moments m_inv.m_surjective_on_substantials
      projected_out_moments_are_moments)

lemma down_image_of_I_eq_I[simp]: "\<Omega>\<^sup>\<down> ` \<I>\<^sup>\<down> = \<I>\<^sup>\<down>"
  using IS'.individuals_moments_substantials IS'_IS.same_substantials m'_image3 project_simps(6) by presburger

lemma up_image_down_eq_down_image:
  assumes "w \<in> \<W>\<^sup>\<down>"
  shows "(\<Omega> ` w\<up>)\<down> = \<Omega>\<^sup>\<down> ` w"
proof -
  obtain A: "w\<up> \<in> \<W>\<^sub>*" "w = w\<up> - \<Delta>" "w = w\<up> \<inter> \<I>\<^sup>\<down>"
    using world_lift_E assms by metis
  have A1: "w \<subseteq> \<I>\<^sup>\<down>" using assms by blast
  have B: "\<Omega> ` w\<up> \<in> \<W>\<^sub>*" using A(1) m_w_W by blast
  have B1:"\<Omega> ` w\<up> - \<Omega> ` \<Delta> \<subseteq> \<I>\<^sub>*" using B world_project_def world_project_subset_2 by auto
  have B2: "\<Omega> ` \<Delta> \<subseteq> \<I>\<^sub>*" by (simp)
  note B3 = inj_on_image_set_diff[
      OF m_inv_injective, of "\<Omega> ` w\<up>" "\<Omega> ` \<Delta>",
      OF B1 B2]
  have C: "(\<Omega> ` w\<up>)\<down> = (\<Omega> ` w\<up>) - \<Delta>"
    using world_project_def by simp
  then have "\<Theta> ` (\<Omega> ` w\<up>)\<down> = \<Theta> ` (\<Omega> ` w\<up> - \<Delta>)"
    by simp
  then have "\<Theta> ` (\<Omega> ` w\<up>)\<down> = \<Theta> ` (\<Omega> ` w\<up> - \<Omega> ` \<Delta>)"
    by simp
  then have "\<Theta> ` (\<Omega> ` w\<up>)\<down> = \<Theta> ` \<Omega> ` w\<up> - \<Theta> ` \<Omega> ` \<Delta>"
    using B3 by simp
  then have "\<Theta> ` (\<Omega> ` w\<up>)\<down> = w\<up> - \<Delta>" by (simp add: A(1))
  then have D: "\<Theta> ` (\<Omega> ` w\<up>)\<down> = w"  using A(2) by auto
  have E: "\<Theta> ` (\<Omega> ` w\<up>)\<down> \<subseteq> \<I>\<^sup>\<down>"
    using m_inv_image_subset_I_down[of w] assms D IS'.worlds_are_made_of_individuals by presburger
  then have "\<Omega> ` \<Theta> ` (\<Omega> ` w\<up>)\<down> = (\<Omega> ` w\<up>)\<down>"  using B1 C by auto
  then have F: "(\<Omega> ` w\<up>)\<down> = \<Omega> ` w" using D by simp
  have G: "\<Omega> ` w = \<Omega>\<^sup>\<down> ` w"
    using A1 by (simp add: m'_image1)
  then show ?thesis
    using F by simp
qed

lemma up_inv_image_down_eq_down_inv_image:
  assumes "w \<in> \<W>\<^sup>\<down>"
  shows "(\<Theta> ` w\<up>)\<down> = \<Theta> ` w"
  using assms
proof -
  assume "w \<in> \<W>\<^sup>\<down>"
  then have "(w\<up>)\<down> = w"
    by (metis world_lift_project)
  then show ?thesis
    using inj_on_image_set_diff world_project_def by auto
qed

lemma m'_morphism[intro!,simp]: "individual_structure_morphism IS\<^sup>\<down> IS\<^sup>\<down> \<Omega>\<^sup>\<down>"
proof -
  show ?thesis
    apply (unfold_locales)
    subgoal G1
      apply (simp add: project_simps(1))
      using proj_morph_def project_individuals_eq by auto
    subgoal G2
      apply (auto simp: proj_morph_def)
      subgoal using inheres_in_scope_2 by (metis IS'_IS.same_substantials substantialsE)
      using inheres_in_scope_2 project_individuals_eq by auto
    subgoal G3  by (metis (no_types, lifting) G1 IS'.exactly_similar_scope IS'.moments_are_individuals IS'.substantials_moments_disj_2 IS'_IS.preserve_exact_similarity m_preserve_exact_similarity proj_morph_def)
    subgoal G4 for x y
      apply (intro iffI ; (elim exE conjE ; hypsubst_thin)? ; (intro exI[of _ "\<Theta> y"])? ; simp
          ; (elim conjE)? ; (intro conjI notI)? )
      subgoal G4_1
      proof -
        assume a1: "\<Omega>\<^sup>\<down> x \<hookrightarrow>\<^sub>* y"
        assume "\<Omega>\<^sup>\<down> x \<notin> \<Delta>"
        then have "x \<in> \<I>\<^sup>\<down>"
          using a1 proj_morph_def by auto
        then show ?thesis
          using a1 by (metis (no_types) m_inv.m_substantials m_inv_inv_substantials_iff m_inv_scope_substantials m_preserce_refers_to_1 proj_morph_def refers_to_scope)
      qed
      subgoal G4_2 by (metis  m_projected_out_moments proj_morph_def undefined_simps(5))
      subgoal G4_3 using IS'.substantials_are_individuals proj_morph_def refers_to_scope by force
      subgoal G4_4 by (metis DiffI IS'.substantials_are_individuals IS'_IS.same_substantials individuals_moments_substantials m_preserce_refers_to_1 moments_are_individuals proj_morph_def project_individuals_eq refers_to_scope)
      subgoal G4_5 by (metis G4_4  m_projected_out_moments proj_morph_def undefined_simps(5))
      done
    subgoal G5 by (metis (no_types, hide_lams) IS'.undefined_simps(7) IS'.undefined_simps(8) IS'_IS.m_preserve_ed ed_E m_preserve_ed proj_morph_def)
    subgoal G6
    proof (intro morphism_worlds_axiom_iff[THEN iffD2] conjI ballI)
      fix w
      assume A: "w \<in> \<W>\<^sup>\<down>"
      define w' where "w' \<equiv> (\<Omega> ` (w\<up>)) \<down>"
      have B: "\<Omega>\<^sup>\<down> ` w \<inter> \<I>\<^sup>\<down> = \<Omega>\<^sup>\<down> ` w" using A
        by (metis IS'.worlds_are_made_of_individuals down_image_of_I_eq_I image_mono inf.absorb1)
      have R1: "w' \<in> \<W>\<^sup>\<down>"
        by (simp only: w'_def ; intro world_project_I
           ; simp only: m_w_W ; intro world_lift_D(1) A)
      have R2: "\<Omega>\<^sup>\<down> ` w = w' \<inter> \<Omega>\<^sup>\<down> ` \<I>\<^sup>\<down>"
        by (simp add: w'_def
                up_image_down_eq_down_image[OF A] B)
      show "\<exists>w'\<in>\<W>\<^sup>\<down>. \<Omega>\<^sup>\<down> ` w = w' \<inter> \<Omega>\<^sup>\<down> ` \<I>\<^sup>\<down>"
        by (intro bexI[of _ w'] R1 R2)
    next
      fix w
      assume A: "w \<in> \<W>\<^sup>\<down>"
      have A1: "w \<subseteq> \<I>\<^sup>\<down>" using A  by blast
      then obtain B: "\<Omega>\<^sup>\<down> ` \<Theta> ` w = w"
          "w \<inter> \<I>\<^sup>\<down> = w"
        using IS'_IS.individuals_subset m'_image1 m_inv_image_subset_I_down by auto
      define w' where "w' \<equiv> (\<Theta> ` (w\<up>)) \<down>"
      have R1: "w' \<in> \<W>\<^sup>\<down>"
        apply (simp only: w'_def ; intro world_project_I ; simp add: image_iff)
        using A by blast
      have R2: "\<Omega>\<^sup>\<down> ` w' = w \<inter> \<Omega>\<^sup>\<down> ` \<I>\<^sup>\<down>"
        apply (simp add: w'_def)
        apply (simp add:  up_inv_image_down_eq_down_inv_image[OF A])
        by (simp add: B)
      show "\<exists>w'\<in>\<W>\<^sup>\<down>. \<Omega>\<^sup>\<down> ` w' = w \<inter> \<Omega>\<^sup>\<down> ` \<I>\<^sup>\<down>"
        by (intro bexI[of _ w'] R1 R2)
    qed
    done
qed

interpretation m': individual_structure_morphism "IS\<^sup>\<down>" "IS\<^sup>\<down>" "\<Omega>\<^sup>\<down>"
  by simp

lemma m'_permutation[intro!,simp]: "individual_structure_permutation_morphism IS\<^sup>\<down> \<Omega>\<^sup>\<down>"
  apply (unfold_locales)
  subgoal by blast
  subgoal using down_image_of_I_eq_I by blast
  using proj_morph_def
  by (simp add: IS'.moments_are_individuals m_strong_preserve_similarity)

interpretation m': individual_structure_permutation_morphism "IS\<^sup>\<down>" "\<Omega>\<^sup>\<down>"
  by simp

end (* "U \<in> \<U>\<^sub>s\<^sub>*" "\<Omega> \<in> EquiPerms"  *)

lemma "EquiPerms \<subseteq> ProjEquiPerms U"
  apply (rule subsetI)
  apply (intro IS'.substructure_closed_perms[of _ "(\<sim>)"] ; simp?)
  using project_substructure by simp

end (* "U \<in> \<U>\<^sub>s\<^sub>*" *)

context
  fixes U U'
  assumes U_U': "U \<preceq>\<^sub>s\<^sub>* U'"
begin

lemma U_U'_Univs[simp,intro!]: "U \<in> \<U>\<^sub>s\<^sub>*" "U' \<in> \<U>\<^sub>s\<^sub>*" using U_U' by blast+

interpretation U: individual_structure "projected_structure U"
   by simp

interpretation U': individual_structure "projected_structure U'"
   by simp

lemma proj_out_U_subs_U': "projected_out_moments U \<subseteq> projected_out_moments U'"
  using U_U'
  by (simp add: project_out_moments_mono)

lemma subsumption_imp_proj_substructure:
  "individual_substructure (projected_structure U') (projected_structure U)"
proof -
  note A = proj_out_U_subs_U'[THEN subsetD]
  show ?thesis
   apply (unfold_locales ; simp? ; (intro subsetI DiffI ; (elim DiffE)? ; simp?)?)
    subgoal G1 using A by blast
    subgoal G2 using A by blast
    subgoal G3 using A by meson
    subgoal G4 using A by blast
    subgoal G5 using A using project_simps(1) by auto
    subgoal G6 using A by blast
    subgoal G7 for w
      apply (elim exE conjE ; hypsubst_thin)
      subgoal for w
        apply (intro exI[of _ w] equalityI conjI ; simp?
              ; (intro conjI)? )
        subgoal G7_1 using project_simps(1) by auto
        subgoal G7_2 by (simp add: Diff_mono proj_out_U_subs_U')
        using project_simps(1) worlds_are_made_of_individuals by fastforce
      done
    subgoal G8
      apply (elim exE conjE ; hypsubst_thin)
      subgoal for w
        apply (rule exI[of _ "w - projected_out_moments U"] ; intro conjI
              ;(intro exI[of _ w])? ; (intro conjI)? ; simp?)
        apply (intro equalityI Int_subset_iff[THEN iffD2] conjI)
        subgoal G8_1 using proj_out_U_subs_U' by (simp add: Diff_mono)
        subgoal G8_2 using proj_out_U_subs_U' by (simp add: Diff_mono project_simps(1) worlds_are_made_of_individuals)
        using project_simps(1) by auto
      done
    done
qed

lemma proj_equi_perms_mono: "ProjEquiPerms U \<subseteq> ProjEquiPerms U'"
proof -

  have A: "individual_structure (projected_structure U')"
     by simp
  have B: " individual_substructure (projected_structure U') (projected_structure U)"
    using subsumption_imp_proj_substructure by simp
  have C: "closure_rel_P (\<sim>) \<S>\<^sub>*" by blast
  show ?thesis
    apply (rule subsetI)
    by (rule
        individual_structure.substructure_closed_perms[of _ "projected_structure U" "(\<sim>)"] ;
        (simp add: A B C)?)
qed

end (*  "U \<preceq>\<^sub>s\<^sub>* U'"   *)

end (* instantiation_structure *)

end (* theory *)


theory StackTypecheck
imports Stack "../01Expression/Typecheck"
begin

inductive typecheck_value :: "kind list \<Rightarrow> type list \<Rightarrow> val \<Rightarrow> type \<Rightarrow> bool" (infix ",_ \<turnstile>\<^sub>v _ :" 60) where
  tc_vabs [simp]: "\<Delta>,insert_at 0 t\<^sub>1 \<Gamma> \<turnstile> e : t\<^sub>2 \<Longrightarrow> \<Delta> \<turnstile>\<^sub>k t\<^sub>1 : Star \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile>\<^sub>v VAbs t\<^sub>1 e : Arrow t\<^sub>1 t\<^sub>2"
| tc_vrec [simp]: "\<Delta>,\<Gamma> \<turnstile>\<^sub>x\<^sub>s fs : ts \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile>\<^sub>v VRec fs : Record ts"
| tc_vinj [simp]: "lookup \<Gamma> x = Some t \<Longrightarrow> lookup ts l = Some t \<Longrightarrow> \<forall>tt \<in> set ts. \<Delta> \<turnstile>\<^sub>k tt : Star \<Longrightarrow>
    \<Delta>,\<Gamma> \<turnstile>\<^sub>v VInj l ts x : Variant ts"
| tc_vfold [simp]: "lookup \<Gamma> x = Some (subst\<^sub>t\<^sub>t 0 (Inductive k t) t) \<Longrightarrow>
    insert_at 0 k \<Delta> \<turnstile>\<^sub>k t : Star \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile>\<^sub>v VFold t x : Inductive k t"
| tc_vtyabs [simp]: "insert_at 0 k \<Delta>,map (incr\<^sub>t\<^sub>t 0) \<Gamma> \<turnstile> e : t \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile>\<^sub>v VTyAbs k e : Forall k t"

inductive_cases [elim]: "\<Delta>,\<Gamma> \<turnstile>\<^sub>v VAbs t\<^sub>1 e : t"
inductive_cases [elim]: "\<Delta>,\<Gamma> \<turnstile>\<^sub>v VRec fs : t"
inductive_cases [elim]: "\<Delta>,\<Gamma> \<turnstile>\<^sub>v VInj e ts l : t"
inductive_cases [elim]: "\<Delta>,\<Gamma> \<turnstile>\<^sub>v VFold t' e : t"
inductive_cases [elim]: "\<Delta>,\<Gamma> \<turnstile>\<^sub>v VTyAbs k e : t"

inductive typecheck_frame :: "type list \<Rightarrow> frame \<Rightarrow> type \<Rightarrow> type \<Rightarrow> bool" (infix "\<turnstile>\<^sub>s _ : _ \<rightarrow>" 60) where
  tc_sref [simp]: "lookup \<Gamma> x = Some t \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>s SRef x : t \<rightarrow> t"
| tc_sapp [simp]: "[],\<Gamma> \<turnstile> e : t' \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>s SApp e : Arrow t' t \<rightarrow> t"
| tc_sproj [simp]: "lookup ts l = Some t \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>s SProj l : Record ts \<rightarrow> t"
| tc_scase [simp]: "[],\<Gamma> \<turnstile>\<^sub>c cs : ts \<rightarrow> t \<Longrightarrow> [] \<turnstile>\<^sub>k t : Star \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>s SCase t cs : Variant ts \<rightarrow> t"
| tc_sunfold [simp]: "[k] \<turnstile>\<^sub>k t : Star \<Longrightarrow>
    \<Gamma> \<turnstile>\<^sub>s SUnfold t : Inductive k t \<rightarrow> subst\<^sub>t\<^sub>t 0 (Inductive k t) t"
| tc_styapp [simp]: "[] \<turnstile>\<^sub>k t' : k \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>s STyApp t' : Forall k t \<rightarrow> subst\<^sub>t\<^sub>t 0 t' t"

inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>s SRef x : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>s SApp e : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>s SProj l : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>s SCase tt cs : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>s SUnfold tt : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>s STyApp tt : t \<rightarrow> t'"

inductive typecheck_stack :: "type list \<Rightarrow> frame list \<Rightarrow> type \<Rightarrow> type \<Rightarrow> bool"
    (infix "\<turnstile>\<^sub>s\<^sub>s _ : _ \<rightarrow>" 60) where
  tcs_nil [simp]: "\<Gamma> \<turnstile>\<^sub>s\<^sub>s [] : t \<rightarrow> t"
| tcs_cons [simp]: "\<Gamma> \<turnstile>\<^sub>s f : t \<rightarrow> t' \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>s\<^sub>s s : t' \<rightarrow> t'' \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>s\<^sub>s f # s : t \<rightarrow> t''"

inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>s\<^sub>s [] : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>s\<^sub>s f # s : t \<rightarrow> t'"

definition typecheck_heap :: "expr heap \<Rightarrow> type list \<Rightarrow> bool" (infix "\<turnstile>\<^sub>h" 60) where
  "h \<turnstile>\<^sub>h \<Gamma> = (length\<^sub>h h = length \<Gamma> \<and> (\<forall>i t. lookup \<Gamma> i = Some t \<longrightarrow> [],\<Gamma> \<turnstile> lookup\<^sub>h h i : t))"

inductive typecheck_stack_state :: "stack_state \<Rightarrow> type \<Rightarrow> bool" (infix "hastype" 60) where
  tc_eval_state [simp]: "\<Gamma> \<turnstile>\<^sub>s\<^sub>s s : t \<rightarrow> t' \<Longrightarrow> [],\<Gamma> \<turnstile> e : t \<Longrightarrow> h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow>
    StackState (Eval e) s h hastype t'"
| tc_return_state [simp]: "\<Gamma> \<turnstile>\<^sub>s\<^sub>s s : t \<rightarrow> t' \<Longrightarrow> [],\<Gamma> \<turnstile>\<^sub>v v : t \<Longrightarrow> h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow>
    StackState (Return v) s h hastype t'"

inductive_cases [elim]: "StackState (Eval e) s h hastype t"
inductive_cases [elim]: "StackState (Return v) s h hastype t"

lemma tc_devalue [simp]: "\<Delta>,\<Gamma> \<turnstile>\<^sub>v v : t \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile> devalue v : t"
  proof (induction \<Delta> \<Gamma> v t rule: typecheck_value.inducts)
  case (tc_vinj \<Gamma> x t ts l \<Delta>)
    hence "lookup \<Gamma> x = Some t" by simp
    moreover from tc_vinj have "lookup ts l = Some t" by simp
    moreover from tc_vinj have "\<forall>tt \<in> set ts. \<Delta> \<turnstile>\<^sub>k tt : Star" by simp
    ultimately show ?case by simp
  qed simp_all

lemma [simp]: "h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow> [],\<Gamma> \<turnstile> e : t \<Longrightarrow> extend\<^sub>h h e \<turnstile>\<^sub>h insert_at (length\<^sub>h h) t \<Gamma>"
  using lookup_less_than by (unfold typecheck_heap_def) fastforce

lemma [elim]: "h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow> length\<^sub>h h = length \<Gamma>"
  by (simp add: typecheck_heap_def)

lemma [simp]: "empty\<^sub>h \<turnstile>\<^sub>h []"
  by (simp add: typecheck_heap_def)

lemma [elim]: "empty\<^sub>h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow> \<Gamma> = []"
  by (simp add: typecheck_heap_def)

lemma tc_frame_weaken [simp]: "\<Gamma> \<turnstile>\<^sub>s f : t \<rightarrow> t' \<Longrightarrow> insert_at (length \<Gamma>) tt \<Gamma> \<turnstile>\<^sub>s f : t \<rightarrow> t'"
  by (induction \<Gamma> f t t' rule: typecheck_frame.induct) simp_all

lemma tc_stack_weaken [simp]: "\<Gamma> \<turnstile>\<^sub>s\<^sub>s s : t \<rightarrow> t' \<Longrightarrow> insert_at (length \<Gamma>) tt \<Gamma> \<turnstile>\<^sub>s\<^sub>s s : t \<rightarrow> t'"
  proof (induction \<Gamma> s t t' rule: typecheck_stack.induct)
  case (tcs_cons \<Gamma> f t t' s t'')
    hence "insert_at (length \<Gamma>) tt \<Gamma> \<turnstile>\<^sub>s\<^sub>s s : t' \<rightarrow> t''" by simp
    moreover from tcs_cons have "insert_at (length \<Gamma>) tt \<Gamma> \<turnstile>\<^sub>s f : t \<rightarrow> t'" by simp
    ultimately show ?case by simp
  qed simp_all

lemma [simp]: "h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow> lookup \<Gamma> x = Some t \<Longrightarrow> [],\<Gamma> \<turnstile> lookup\<^sub>h h x : t"
  by (simp add: typecheck_heap_def)

end


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

locale Type_System =
  SSP? : Strongly_Secure_Programs "E" "BMap" "DA"
  for E :: "('exp, 'id, 'val) Evalfunction"
  and BMap :: "'val \<Rightarrow> bool"
  and DA :: "('id, 'd::order) DomainAssignment"
+
fixes
AssignSideCondition :: "'id \<Rightarrow> 'exp \<Rightarrow> bool"
and WhileSideCondition :: "'exp \<Rightarrow> bool"
and IfSideCondition ::
  "'exp \<Rightarrow> ('exp,'id) MWLfCom \<Rightarrow> ('exp,'id) MWLfCom \<Rightarrow> bool"
assumes semAssignSC: "AssignSideCondition x e \<Longrightarrow> e \<equiv>\<^bsub>DA x\<^esub> e"
and semWhileSC: "WhileSideCondition e \<Longrightarrow> \<forall>d. e \<equiv>\<^bsub>d\<^esub> e"
and semIfSC: "IfSideCondition e c1 c2 \<Longrightarrow> \<forall>d. e \<equiv>\<^bsub>d\<^esub> e \<or> [c1] \<approx>\<^bsub>d\<^esub> [c2]"
begin

\<comment> \<open>Security typing rules for the language commands\<close>
inductive
ComSecTyping :: "('exp, 'id) MWLfCom \<Rightarrow> bool"
  ("\<turnstile>\<^bsub>\<C>\<^esub> _")
and ComSecTypingL :: "('exp,'id) MWLfCom list \<Rightarrow> bool"
   ("\<turnstile>\<^bsub>\<V>\<^esub> _")
where
skip: "\<turnstile>\<^bsub>\<C>\<^esub> skip" |
Assign: "\<lbrakk> AssignSideCondition x e \<rbrakk> \<Longrightarrow> \<turnstile>\<^bsub>\<C>\<^esub> x := e" |
Fork: "\<lbrakk> \<turnstile>\<^bsub>\<C>\<^esub> c; \<turnstile>\<^bsub>\<V>\<^esub> V \<rbrakk> \<Longrightarrow> \<turnstile>\<^bsub>\<C>\<^esub> fork c V" |
Seq: "\<lbrakk> \<turnstile>\<^bsub>\<C>\<^esub> c1; \<turnstile>\<^bsub>\<C>\<^esub> c2 \<rbrakk> \<Longrightarrow> \<turnstile>\<^bsub>\<C>\<^esub> c1;c2" |
While: "\<lbrakk> \<turnstile>\<^bsub>\<C>\<^esub> c; WhileSideCondition b \<rbrakk>
     \<Longrightarrow> \<turnstile>\<^bsub>\<C>\<^esub> while b do c od" |
If: "\<lbrakk> \<turnstile>\<^bsub>\<C>\<^esub> c1; \<turnstile>\<^bsub>\<C>\<^esub> c2; IfSideCondition b c1 c2 \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^bsub>\<C>\<^esub> if b then c1 else c2 fi" |
Parallel: "\<lbrakk> \<forall>i < length V. \<turnstile>\<^bsub>\<C>\<^esub> V!i \<rbrakk> \<Longrightarrow> \<turnstile>\<^bsub>\<V>\<^esub> V"

inductive_cases parallel_cases:
"\<turnstile>\<^bsub>\<V>\<^esub> V"

\<comment> \<open>soundness proof of abstract type system\<close>
theorem ComSecTyping_single_is_sound:
"\<turnstile>\<^bsub>\<C>\<^esub> c \<Longrightarrow> Strongly_Secure [c]"
by (induct rule: ComSecTyping_ComSecTypingL.inducts(1)
    [of _ _ "Strongly_Secure"],
  auto simp add: Strongly_Secure_def,
  metis Strongly_Secure_Skip,
  metis Strongly_Secure_Assign semAssignSC,
  metis Compositionality_Fork,
  metis Compositionality_Seq,
  metis Compositionality_While semWhileSC,
  metis Compositionality_If semIfSC,
  metis parallel_composition)

theorem ComSecTyping_list_is_sound:
"\<turnstile>\<^bsub>\<V>\<^esub> V \<Longrightarrow> Strongly_Secure V"
by (metis ComSecTyping_single_is_sound Strongly_Secure_def
  parallel_composition parallel_cases)

end

end


(*  Title:      Containers/Card_Datatype_Ex.thy
    Author:     Andreas Lochbihler, ETH Zurich *)

theory Card_Datatype_Ex imports
  "../Card_Datatype"
begin

subsection \<open>Examples\<close>

subsubsection \<open>Finite types\<close>

datatype ('a, 'b) foo = Foo 'a | Bar 'a 'b | FooBar 'a 'b "'a + 'b" | Stop

lemma inj_foo [simp]:
  "inj Foo"
  "inj Bar" "inj (Bar x)"
  "inj FooBar" "inj (FooBar x)" "inj (FooBar x y)"
by(simp_all add: inj_on_def fun_eq_iff)

context includes card_datatype begin

lemma UNIV_foo:
  "(UNIV :: ('a, 'b) foo set) =
  rangeC {Foo} \<union>
  rangeC (rangeC {Bar}) \<union>
  rangeC (rangeC (rangeC {FooBar})) \<union>
  rangeC {\<lambda>_::unit. Stop}"
apply(rule UNIV_eq_I)
apply(case_tac x)
apply(simp_all)
done

lemma finite_UNIV_foo:
  "finite (UNIV :: ('a, 'b) foo set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
by(simp add: UNIV_foo)

definition card_foo :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where "card_foo a b = (if a = 0 \<or> b = 0 then 0 else a + a * b + a * b * card_sum a b + 1)"

lemma CARD_foo [card_simps]:
  "CARD(('a, 'b) foo) = card_foo CARD('a) CARD('b)"
by(simp add: card_foo_def UNIV_foo Let_def card_simps)

end

datatype ('a, 'b) bar
  = Bar1
  | Bar2 "'a \<Rightarrow> 'b"
  | Bar3 "('a, 'b) foo" "'a \<Rightarrow> char \<Rightarrow> 'b \<Rightarrow> 'a" "('a \<times> 'b) option"
  | Bar4 char 'a bool

lemma inj_bar [simp]:
  "inj Bar2"
  "inj Bar3"
  "inj (Bar3 x)"
  "inj (Bar3 x y)"
  "inj Bar4"
  "inj (Bar4 z)"
  "inj (Bar4 z u)"
by(simp_all add: inj_on_def fun_eq_iff)

context includes card_datatype begin

lemma UNIV_bar:
  "(UNIV :: ('a, 'b) bar set) =
  rangeC {\<lambda>_::unit. Bar1} \<union>
  rangeC {Bar2} \<union>
  rangeC (rangeC (rangeC {Bar3})) \<union>
  rangeC (rangeC (rangeC {Bar4}))"
apply(rule UNIV_eq_I)
apply(case_tac x)
apply(simp_all)
done

lemma finite_UNIV_bar:
  "finite (UNIV :: ('a, 'b) bar set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
by(auto simp add: UNIV_bar finite_UNIV_fun finite_prod finite_UNIV_foo)

definition card_bar :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "card_bar a b =
  (if a = 0 \<or> b = 0 then 0
   else 1 + card_fun a b + card_foo a b * card_fun a (card_fun CARD(char) (card_fun b a)) * card_option (card_prod a b) + CARD(char) * a * CARD(bool))"

lemma CARD_bar [card_simps]:
  "CARD(('a, 'b) bar) = card_bar CARD('a) CARD('b)"
by(simp add: UNIV_bar card_bar_def finite_UNIV_bar finite_UNIV_foo finite_prod finite_UNIV_fun card_simps del: card_prod)

end

subsection \<open>Infinite types\<close>

datatype 'a tree = Leaf | Node 'a "'a tree" "'a tree"

lemma inj_expr [simp]:
  "inj Node"
  "inj (Node a)"
  "inj (Node a l)"
by(simp_all add: inj_on_def fun_eq_iff)

context includes card_datatype begin

lemma finite_UNIV_tree: "finite (UNIV :: 'a tree set) \<longleftrightarrow> False"
proof -
  have "rangeIt Leaf (Node (undefined :: 'a) Leaf) \<subseteq> UNIV" by simp
  from finite_subset[OF this] show ?thesis by auto
qed

definition card_tree :: "nat \<Rightarrow> nat"
where "card_tree _ = 0"

lemma CARD_tree [card_simps]:
  "CARD('a tree) = card_tree CARD('a)"
by(simp add: card_tree_def finite_UNIV_tree)

end

end