subsubsection \<open>State d equation\<close>

theory State_d_Equation imports State_0_Equation

begin

context rm_eq_fixes
begin

  text \<open>Equation 4.25\<close>
  definition state_d :: "bool" where
    "state_d \<equiv> \<forall>d>0. d\<le>m \<longrightarrow> s d = b*\<Sum>S+ p d s + b*\<Sum>S- p d (\<lambda>k. s k && z (modifies (p!k)))
                                                 + b*\<Sum>S0 p d (\<lambda>k. s k && (e - z (modifies (p!k))))"

  text \<open>Combining the two\<close>
  definition state_relations_from_recursion :: "bool" where
    "state_relations_from_recursion \<equiv> state_0 \<and> state_d"

end

context register_machine
begin

lemma state_d_dioph:
  fixes b e :: polynomial
  fixes z s :: "polynomial list"
  assumes "length z = n" "length s = Suc m"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.state_d p (ll!0!0) (ll!0!1)
                                                  (nth (ll!1)) (nth (ll!2)))
                      [[b, e], z, s]"
  shows "is_dioph_rel DR"
proof -

  define d_domain where "d_domain \<equiv> [1..<Suc m]"

  define number_of_ex_vars where "number_of_ex_vars = 2 * m"

  have "length d_domain = m"
    unfolding d_domain_def by auto

  define b' e' z' s' where pushed_def: "b' = push_param b number_of_ex_vars"
                                       "e' = push_param e number_of_ex_vars"
                                       "z' = map (\<lambda>x. push_param x number_of_ex_vars) z"
                                       "s' = map (\<lambda>x. push_param x number_of_ex_vars) s"

  note e'_def = \<open>e' = push_param e number_of_ex_vars\<close>

  define z0 z1 where z_def: "z0 \<equiv> map (\<lambda>i. z' ! modifies (p!i)) [0..<Suc m]"
                            "z1 \<equiv> map (\<lambda>i. e' [-] z' ! modifies (p!i)) [0..<Suc m]"

  define sum_ssub_nzero_param_of_state where
    "sum_ssub_nzero_param_of_state \<equiv> (\<lambda>d. Param (d - Suc 0))"
  write sum_ssub_nzero_param_of_state ("\<Sum>S-'_Param _")

  define sum_ssub_zero_param_of_state where
    "sum_ssub_zero_param_of_state \<equiv> (\<lambda>d. Param (m + d - Suc 0))"
  write sum_ssub_zero_param_of_state ("\<Sum>S0'_Param _")

  define param_is_sum_ssub_nzero_term where
    "param_is_sum_ssub_nzero_term \<equiv> (\<lambda>d::nat. [(\<Sum>S-_Param d) = \<Sum>S- d (s' && z0)])"

  define param_is_sum_ssub_zero_term where
    "param_is_sum_ssub_zero_term \<equiv> (\<lambda>d. [(\<Sum>S0_Param d) = \<Sum>S0 d (s' && z1)])"

  define params_are_sum_terms where
    "params_are_sum_terms \<equiv> [\<forall> in d_domain] (\<lambda>d. param_is_sum_ssub_nzero_term d
                                             [\<and>] param_is_sum_ssub_zero_term d)"

  define step_relation where
    "step_relation \<equiv> (\<lambda>d. (s'!d) [=] b' [*] ([\<Sum>S+] p d (nth s'))
                                    [+] b' [*] (\<Sum>S-_Param d)
                                    [+] b' [*] (\<Sum>S0_Param d))"

  define DS where "DS \<equiv> [\<exists>number_of_ex_vars] (([\<forall> in d_domain] (\<lambda>d. step_relation d))
                                               [\<and>] params_are_sum_terms)"

  have "length p > 0"
    using p_nonempty by auto
  hence "m \<ge> 0"
    unfolding m_def by auto
  have "length s' = Suc m" and "length z0 = Suc m" and "length z1 = Suc m"
    unfolding pushed_def z_def using \<open>length s = Suc m\<close> m_def \<open>length p > 0\<close> by auto

  have "eval DS a = eval DR a" for a
  proof -

    have b'_unfold: "peval b' (push_list a ks) = peval b a"
      if "length ks = number_of_ex_vars" for ks
      unfolding pushed_def using push_push_simp \<open>length d_domain = m\<close> by (metis that)

    have h0: "k < m \<Longrightarrow> d_domain ! k < Suc m" for k
      unfolding d_domain_def apply simp
      using One_nat_def Suc_pred \<open>0 < length p\<close>  add.commute
                    assms(3) d_domain_def less_diff_conv m_def nth_upt upt_Suc_append
      by (smt \<open>length d_domain = m\<close> less_nat_zero_code list.size(3) upt_Suc)

    have s'_unfold: "peval (s' ! (d_domain ! k)) (push_list a ks)
                   = peval (s ! (d_domain ! k)) a"
      if "length ks = number_of_ex_vars" and "k < m" for k ks
    proof -
      from \<open>k < m\<close> have "d_domain ! k < length s" unfolding \<open>length s = Suc m\<close>
        using h0 by blast

      have suc_k: "([Suc 0..<Suc m]) ! k = Suc k"
        by (metis Suc_leI Suc_pred add_less_cancel_left diff_Suc_1 le_add_diff_inverse nth_upt
            zero_less_Suc \<open>k < m\<close>)

      have "peval (map (\<lambda>x. push_param x number_of_ex_vars) s ! (d_domain ! k)) (push_list a ks)
            = list_eval s a (d_domain ! k)"
        using push_push_map_i[of "ks" "number_of_ex_vars" "d_domain!k" s a]
        using \<open>length ks = number_of_ex_vars\<close> \<open>k < m\<close> h0 \<open>length s = Suc m\<close> by auto
      also have "... = peval (s ! (d_domain ! k)) a"
        unfolding list_eval_def
        using nth_map [of "d_domain ! k" s "(\<lambda>x. peval x a)"] \<open>d_domain ! k < length s\<close>
        unfolding d_domain_def using \<open>m \<ge> 0\<close> \<open>k < m\<close> suc_k by auto

      finally show ?thesis unfolding pushed_def by auto
    qed

    have sum_sadd_unfold: "(\<Sum>S+ p (d_domain ! k) (\<lambda>x. peval (s' ! x) (push_list a ks)))
                         = (\<Sum>S+ p (d_domain ! k) ((!) (map (\<lambda>P. peval P a) s)))"
      if "length ks = number_of_ex_vars" for k ks
      apply (rule sum_sadd_cong, auto) unfolding pushed_def
      using push_push_map_i[of ks number_of_ex_vars _ s a] \<open>length ks = number_of_ex_vars\<close>
      unfolding list_eval_def by (simp add: \<open>length s = Suc m\<close> m_def)

    have s: "peval (s' ! ka) (push_list a ks) = map (\<lambda>P. peval P a) s ! ka"
      if "ka < Suc m" and "length ks = number_of_ex_vars" for ka ks
        unfolding pushed_def
        using push_push_map_i[of ks number_of_ex_vars ka s a] \<open>length ks = number_of_ex_vars\<close>
        using list_eval_def \<open>length s = Suc m\<close> \<open>ka < Suc m\<close> by auto

    have modifies_valid: "modifies (p ! ka) < length z" if "ka < Suc m" for ka
      using modifies_yields_valid_register that unfolding \<open>length z = n\<close> m_def
      using p_nonempty by auto

    have sum_ssub_nzero_unfold:
      "(\<Sum>S- p (d_domain ! k) (\<lambda>k. peval (s' ! k) (push_list a ks)
                              && peval (z0 ! k) (push_list a ks)))
     = (\<Sum>S- p (d_domain ! k) (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                              && map (\<lambda>P. peval P a) z ! modifies (p ! k)))"
      if "length ks = number_of_ex_vars" for k ks
    proof-
      have z0: "peval (z0 ! ka) (push_list a ks) = map (\<lambda>P. peval P a) z ! modifies (p ! ka)"
        if "ka < Suc m" for ka
        unfolding z_def pushed_def
        using push_push_map_i[of ks number_of_ex_vars "modifies (p!ka)" z a]
              \<open>length ks = number_of_ex_vars\<close> unfolding list_eval_def
        using \<open>length z0 = Suc m\<close> \<open>ka < Suc m\<close> modifies_valid \<open>0 < length p\<close> m_def map_nth by force

      show ?thesis apply (rule sum_ssub_nzero_cong) using s z0 le_imp_less_Suc m_def that
        by presburger
    qed

    have sum_ssub_zero_unfold:
      "(\<Sum>S0 p (d_domain ! k) (\<lambda>k. peval (s' ! k) (push_list a ks)
                                && peval (z1 ! k) (push_list a ks)))
     = (\<Sum>S0 p (d_domain ! k) (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                && peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! k)))"
      if "length ks = number_of_ex_vars" and "k < Suc m" for k ks
    proof-

      have map:
        "map (\<lambda>i. e' [-] (z' ! (modifies (p ! i)))) [0..<Suc m] ! ka
         = e' [-] (z' ! modifies (p ! ka))" if "ka < Suc m" for ka
        using nth_map[of ka "[0..<Suc m]" "\<lambda>i. e' [-] z' ! modifies (p ! i)"] \<open>ka < Suc m\<close>
        by (smt (z3) One_nat_def Suc_pred \<open>0 < length p\<close> \<open>m \<ge> 0\<close> le_trans length_map m_def map_nth
            nth_map upt_Suc_append zero_le_one)

      have "peval (e' [-] (z' ! modifies (p ! ka))) (push_list a ks)
              = peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! ka)"
        if "ka < Suc m" for ka
        unfolding z_def pushed_def apply (simp add: defs)
        using push_push_simp \<open>length ks = number_of_ex_vars\<close> apply auto
        using push_push_map_i[of ks number_of_ex_vars "modifies (p!ka)" z a]
              \<open>length ks = number_of_ex_vars\<close> modifies_valid \<open>ka < Suc m\<close>
        unfolding list_eval_def using \<open>length z0 = Suc m\<close> \<open>0 < length p\<close> m_def map_nth by auto

      hence z1: "peval (z1 ! ka) (push_list a ks)
           = peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! ka)" if "ka < Suc m" for ka
        unfolding z_def using map that by auto

      show ?thesis apply (rule sum_ssub_zero_cong) using s z1 le_imp_less_Suc m_def that
        by presburger

    qed

    define sum_ssub_nzero_map where
      "sum_ssub_nzero_map \<equiv> \<lambda>j. \<Sum>S- p j (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                                       && map (\<lambda>P. peval P a) z ! modifies (p ! k))"
    define sum_ssub_zero_map where
      "sum_ssub_zero_map \<equiv> \<lambda>j. \<Sum>S0 p j (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                               && peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! k)) "

    define ks_ex where
      "ks_ex \<equiv> map sum_ssub_nzero_map d_domain @ map sum_ssub_zero_map d_domain"

    have "length ks_ex = number_of_ex_vars"
      unfolding ks_ex_def number_of_ex_vars_def using \<open>length d_domain = m\<close> by auto

    have ks_ex1:
      "peval (\<Sum>S-_Param (d_domain ! k)) (push_list a ks_ex)
       = \<Sum>S- p (d_domain ! k) (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                 && map (\<lambda>P. peval P a) z ! modifies (p ! k))"
      if "k < m" for k
    proof -
      have domain_at_k_bound:
        "d_domain ! k - Suc 0 < length ks_ex" using that \<open>length ks_ex = number_of_ex_vars\<close>
        unfolding number_of_ex_vars_def using h0 by fastforce

      have "peval (\<Sum>S-_Param (d_domain ! k)) (push_list a ks_ex) = ks_ex ! k"
        unfolding push_list_def sum_ssub_nzero_param_of_state_def using that domain_at_k_bound
        apply auto
        using One_nat_def Suc_mono d_domain_def diff_Suc_1 nth_upt plus_1_eq_Suc by presburger

      also have "... = \<Sum>S- p (d_domain ! k) (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                 && map (\<lambda>P. peval P a) z ! modifies (p ! k))"
        unfolding ks_ex_def
        unfolding nth_append[of "map sum_ssub_nzero_map d_domain" "map sum_ssub_zero_map d_domain" k]
        using \<open>length d_domain = m\<close> that unfolding sum_ssub_nzero_map_def by auto
      finally show ?thesis by auto
    qed

    have ks_ex2:
      "peval (\<Sum>S0_Param (d_domain ! k)) (push_list a ks_ex)
          = \<Sum>S0 p (d_domain ! k) (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                       && peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! k))"
      if "k < m" for k
    proof -
      have domain_at_k_bound:
        "m + d_domain ! k - Suc 0 < length ks_ex" using that \<open>length ks_ex = number_of_ex_vars\<close>
        unfolding number_of_ex_vars_def using h0 by fastforce

      have "d_domain ! k \<ge> 1"
        unfolding d_domain_def \<open>k < m\<close>
        using m_def p_nonempty that by auto

      hence index_calculation: "(m + d_domain ! k - Suc 0) = k + m"
        unfolding d_domain_def
        by (metis (no_types, lifting) Nat.add_diff_assoc One_nat_def Suc_pred add.commute
            less_diff_conv m_def nth_upt ordered_cancel_comm_monoid_diff_class.le_imp_diff_is_add
            p_nonempty that)

      have "peval (\<Sum>S0_Param (d_domain ! k)) (push_list a ks_ex) = ks_ex ! (k + m)"
        unfolding push_list_def sum_ssub_zero_param_of_state_def using that domain_at_k_bound
        by (auto simp: index_calculation)

      also have "... = \<Sum>S0 p (d_domain ! k) (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                       && peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! k))"
        unfolding ks_ex_def
        unfolding nth_append[of "map sum_ssub_nzero_map d_domain" "map sum_ssub_zero_map d_domain"]
        using \<open>length d_domain = m\<close> that unfolding sum_ssub_zero_map_def by auto
      finally show ?thesis by auto
    qed

    have all_quantifier_switch: "(\<forall>k<length d_domain. Property (d_domain ! k))
                               = (\<forall>d>0. d \<le> m \<longrightarrow> Property d)" for Property
    proof (rule)
      assume asm: "\<forall>k<length d_domain. Property (d_domain ! k)"
      show "\<forall>d>0. d \<le> m \<longrightarrow> Property d"
      proof (auto)
        fix d
        assume "d > 0" "d \<le> m"
        hence "d - Suc 0 < length d_domain"
          by (metis Suc_le_eq Suc_pred \<open>length d_domain = m\<close>)
        hence "Property (d_domain ! (d - Suc 0))"
          using asm by auto
        thus "Property d"
          unfolding d_domain_def
          by (metis One_nat_def Suc_diff_1 \<open>0 < d\<close> \<open>d \<le> m\<close> le_imp_less_Suc nth_upt plus_1_eq_Suc)
      qed
    next
      assume asm: "\<forall>d>0. d \<le> m \<longrightarrow> Property d"
      show "\<forall>k<length d_domain. Property (d_domain ! k)"
      proof (auto)
        fix k
        assume "k < length d_domain"
        hence "d_domain ! k > 0"
          unfolding d_domain_def
          by (smt (z3) One_nat_def Suc_leI Suc_pred \<open>0 < length p\<close> \<open>length d_domain = m\<close>
              add_less_cancel_left d_domain_def diff_is_0_eq' gr_zeroI le_add_diff_inverse
              less_nat_zero_code less_numeral_extra(1) m_def nth_upt)
        moreover have "d_domain ! k \<le> m"
          unfolding d_domain_def using \<open>k < length d_domain\<close> unfolding \<open>length d_domain = m\<close>
          using d_domain_def h0 less_Suc_eq_le by auto
        ultimately show "Property (d_domain ! k)"
          using asm by auto
      qed
    qed

    have "peval (s!d) a = map (\<lambda>P. peval P a) s ! d" if "d > 0" and "d \<le> m" for d
      using nth_map[of d s "\<lambda>P. peval P a"] that \<open>length s = Suc m\<close> by simp

    (* Start chain of equivalences *)
    have "eval DS a = (\<exists>ks. number_of_ex_vars = length ks
          \<and> (\<forall>k<length d_domain. eval (step_relation (d_domain ! k)) (push_list a ks))
          \<and> eval params_are_sum_terms (push_list a ks))"
      unfolding DS_def by (simp add: defs)

    also have "... = (\<exists>ks. number_of_ex_vars = length ks \<and>
         (\<forall>k<m.
             peval (s ! (d_domain ! k)) a =
             peval b a * peval ([\<Sum>S+] p (d_domain ! k) ((!) s')) (push_list a ks) +
             peval b a * peval (\<Sum>S-_Param (d_domain ! k)) (push_list a ks) +
             peval b a * peval (\<Sum>S0_Param (d_domain ! k)) (push_list a ks)) \<and>
         eval params_are_sum_terms (push_list a ks))"
      unfolding step_relation_def \<open>length d_domain = m\<close>
      using b'_unfold s'_unfold by (auto simp: defs)

    also have "... = (\<exists>ks. number_of_ex_vars = length ks \<and>
         (\<forall>k<m.
             peval (s ! (d_domain ! k)) a =
             peval b a * (\<Sum>S+ p (d_domain ! k) (\<lambda>x. peval (s' ! x) (push_list a ks))) +
             peval b a * (peval (\<Sum>S-_Param (d_domain ! k)) (push_list a ks)) +
             peval b a * (peval (\<Sum>S0_Param (d_domain ! k)) (push_list a ks)))
       \<and> (\<forall>k<m.
             peval (\<Sum>S-_Param (d_domain ! k)) (push_list a ks)
                 = \<Sum>S- p (d_domain ! k) (\<lambda>k. peval (s' ! k) (push_list a ks)
                                           && peval (z0 ! k) (push_list a ks))
          \<and> peval (\<Sum>S0_Param (d_domain ! k)) (push_list a ks)
                 = \<Sum>S0 p (d_domain ! k) (\<lambda>k. peval (s' ! k) (push_list a ks)
                                           && peval (z1 ! k) (push_list a ks))))"
      unfolding params_are_sum_terms_def param_is_sum_ssub_nzero_term_def
        param_is_sum_ssub_zero_term_def apply (simp add: defs)
      using sum_rsub_nzero_of_bit_and_eval[of s' z0] sum_rsub_zero_of_bit_and_eval[of s' z1]
            \<open>length p > 0\<close> \<open>length s' = Suc m\<close> \<open>length z0 = Suc m\<close> \<open>length z1 = Suc m\<close>
      unfolding \<open>length d_domain = m\<close> by (simp add: defs)

    also have "... = (\<exists>ks. number_of_ex_vars = length ks \<and>
         (\<forall>k<m.
             peval (s ! (d_domain ! k)) a =
             peval b a * (\<Sum>S+ p (d_domain ! k) ((!) (map (\<lambda>P. peval P a) s)) )
           + peval b a * (\<Sum>S- p (d_domain ! k) (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                  && map (\<lambda>P. peval P a) z ! modifies (p ! k)))
           + peval b a * (\<Sum>S0 p (d_domain ! k) (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                  && peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! k))))
       \<and> (\<forall>k<m.
             peval (\<Sum>S-_Param (d_domain ! k)) (push_list a ks)
                 = \<Sum>S- p (d_domain ! k) (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                  && map (\<lambda>P. peval P a) z ! modifies (p ! k))
           \<and> peval (\<Sum>S0_Param (d_domain ! k)) (push_list a ks)
                 = \<Sum>S0 p (d_domain ! k) (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                  && peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! k))))"
      using sum_sadd_unfold sum_ssub_nzero_unfold sum_ssub_zero_unfold by auto

    also have "... = (\<forall>k<m.
             peval (s ! (d_domain ! k)) a =
             peval b a * (\<Sum>S+ p (d_domain ! k) ((!) (map (\<lambda>P. peval P a) s)) )
           + peval b a * (\<Sum>S- p (d_domain ! k)
                                (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                  && map (\<lambda>P. peval P a) z ! modifies (p ! k)))
           + peval b a * (\<Sum>S0 p (d_domain ! k)
                                (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                  && peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! k))))"
      apply auto
      apply (rule exI[of _ ks_ex])
      using \<open>length ks_ex = number_of_ex_vars\<close> ks_ex1 ks_ex2 by auto

    also have "... = (\<forall>d>0. d \<le> m \<longrightarrow>
           peval (s ! d) a
         = peval b a * \<Sum>S+ p d ((!) (map (\<lambda>P. peval P a) s))
         + peval b a * \<Sum>S- p d (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                     && map (\<lambda>P. peval P a) z ! modifies (p ! k))
         + peval b a * \<Sum>S0 p d (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                     && peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! k)) )"
      using all_quantifier_switch[of "\<lambda>d. peval (s ! d) a =
           peval b a * \<Sum>S+ p d ((!) (map (\<lambda>P. peval P a) s))  +
           peval b a * \<Sum>S- p d (\<lambda>k. map (\<lambda>P. peval P a) s ! k
           && map (\<lambda>P. peval P a) z ! modifies (p ! k))  +
           peval b a * \<Sum>S0 p d (\<lambda>k. map (\<lambda>P. peval P a) s ! k
           && peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! k))"]
      unfolding \<open>length d_domain = m\<close> by auto

    finally show ?thesis
      unfolding DR_def
      using local.register_machine_axioms rm_eq_fixes_def[of p n] rm_eq_fixes.state_d_def[of p n]
      apply (simp add: defs)
      using nth_map[of _ s "\<lambda>P. peval P a"] \<open>length s = Suc m\<close>
      by auto
  qed

  moreover have "is_dioph_rel DS"
  proof -
    have "is_dioph_rel (param_is_sum_ssub_nzero_term d [\<and>] param_is_sum_ssub_zero_term d)" for d
      unfolding param_is_sum_ssub_nzero_term_def param_is_sum_ssub_zero_term_def
      by (auto simp: dioph)
    hence 1: "list_all (is_dioph_rel \<circ> (\<lambda>d. param_is_sum_ssub_nzero_term d
                                     [\<and>] param_is_sum_ssub_zero_term d)) d_domain"
      by (simp add: list.inducts)

    have "is_dioph_rel (step_relation d)" for d
      unfolding step_relation_def by (auto simp: dioph)
    hence 2: "list_all (is_dioph_rel \<circ> step_relation) d_domain"
      by (simp add: list.inducts)

    show ?thesis
    unfolding DS_def params_are_sum_terms_def by (auto simp: dioph 1 2)
  qed

  ultimately show ?thesis using is_dioph_rel_def by auto
qed

lemma state_relations_from_recursion_dioph:
  fixes b e :: polynomial
  fixes z s :: "polynomial list"
  assumes "length z = n" "length s = Suc m"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.state_relations_from_recursion p (ll!0!0) (ll!0!1)
                                                                        (nth (ll!1)) (nth (ll!2)))
                      [[b, e], z, s]"
  shows "is_dioph_rel DR"
proof -

  define DS where "DS \<equiv> (LARY (\<lambda>ll. rm_eq_fixes.state_0 p (ll!0!0) (ll!0!1)
                            (nth (ll!1)) (nth (ll!2))) [[b, e], z, s])
                     [\<and>](LARY (\<lambda>ll. rm_eq_fixes.state_d p (ll!0!0) (ll!0!1) (nth (ll!1))
                            (nth (ll!2))) [[b, e], z, s])"

  have "eval DS a = eval DR a" for a
    unfolding DS_def DR_def
    using local.register_machine_axioms rm_eq_fixes_def
          rm_eq_fixes.state_relations_from_recursion_def
    using assms by (simp add: defs)

  moreover have "is_dioph_rel DS"
    unfolding DS_def apply (rule and_dioph) using assms state_0_dioph state_d_dioph by blast+

  ultimately show ?thesis using is_dioph_rel_def by auto
qed

end

end


theory Chapter12_1_Language
imports DeBruijnEnvironment
begin

datatype type =
  Nat
| Arrow type type
| Unit
| Prod type type
| Void
| Sum type type

datatype patn =
  WildPat
| VarPat
| TrivPat
| PairPat patn patn
| InLPat patn
| InRPat patn

datatype expr =
  Var var
| Zero
| Suc expr
| Rec expr expr expr
| Lam type expr
| Appl expr expr
| Triv
| Pair expr expr
| ProjL expr
| ProjR expr
| Abort type expr
| Case expr expr expr
| InL type type expr
| InR type type expr
| Match expr "rule list"
and rule =
  Rule patn expr

fun pat_var_count :: "patn => nat"
where "pat_var_count WildPat = 0"
    | "pat_var_count VarPat = 1"
    | "pat_var_count TrivPat = 0"
    | "pat_var_count (PairPat p1 p2) = pat_var_count p1 + pat_var_count p2"
    | "pat_var_count (InLPat p) = pat_var_count p"
    | "pat_var_count (InRPat p) = pat_var_count p"

primrec insert :: "var => expr => expr"
    and insert_rules :: "var => rule list => rule list"
    and insert_rule :: "var => rule => rule"
where "insert n (Var v) = Var (incr n v)"
    | "insert n Zero = Zero"
    | "insert n (Suc e) = Suc (insert n e)"
    | "insert n (Rec et e0 es) = Rec (insert n et) (insert n e0) (insert (next (next n)) es)"
    | "insert n (Lam t e) = Lam t (insert (next n) e)"
    | "insert n (Appl e1 e2) = Appl (insert n e1) (insert n e2)"
    | "insert n Triv = Triv"
    | "insert n (Pair e1 e2) = Pair (insert n e1) (insert n e2)"
    | "insert n (ProjL e) = ProjL (insert n e)"
    | "insert n (ProjR e) = ProjR (insert n e)"
    | "insert n (Abort t e) = Abort t (insert n e)"
    | "insert n (Case et el er) = Case (insert n et) (insert (next n) el) (insert (next n) er)"
    | "insert n (InL t1 t2 e) = InL t1 t2 (insert n e)"
    | "insert n (InR t1 t2 e) = InR t1 t2 (insert n e)"
    | "insert n (Match e rs) = Match (insert n e) (insert_rules n rs)"
    | "insert_rules n [] = []"
    | "insert_rules n (r # rs) = insert_rule n r # insert_rules n rs"
    | "insert_rule n (Rule p e) = Rule p (insert (next_by (pat_var_count p) n) e)"

primrec mult_insert :: "nat => expr => expr"
where "mult_insert 0 e = e"
    | "mult_insert (Nat.Suc n) e = insert first (mult_insert n e)"

primrec subst :: "expr => var => expr => expr"
    and subst_rules :: "expr => var => rule list => rule list"
    and subst_rule :: "expr => var => rule => rule"
where "subst e' n (Var v) = (if v = n then e' else Var (subr n v))"
    | "subst e' n Zero = Zero"
    | "subst e' n (Suc e) = Suc (subst e' n e)"
    | "subst e' n (Rec et e0 es) =
                      Rec (subst e' n et)
                          (subst e' n e0)
                          (subst (insert first (insert first e')) (next (next n)) es)"
    | "subst e' n (Lam t e) = Lam t (subst (insert first e') (next n) e)"
    | "subst e' n (Appl e1 e2) = Appl (subst e' n e1) (subst e' n e2)"
    | "subst e' n Triv = Triv"
    | "subst e' n (Pair e1 e2) = Pair (subst e' n e1) (subst e' n e2)"
    | "subst e' n (ProjL e) = ProjL (subst e' n e)"
    | "subst e' n (ProjR e) = ProjR (subst e' n e)"
    | "subst e' n (Abort t e) = Abort t (subst e' n e)"
    | "subst e' n (Case et el er) =
                      Case (subst e' n et)
                           (subst (insert first e') (next n) el)
                           (subst (insert first e') (next n) er)"
    | "subst e' n (InL t1 t2 e) = InL t1 t2 (subst e' n e)"
    | "subst e' n (InR t1 t2 e) = InR t1 t2 (subst e' n e)"
    | "subst e' n (Match e rs) = Match (subst e' n e) (subst_rules e' n rs)"
    | "subst_rules e' n [] = []"
    | "subst_rules e' n (r # rs) = subst_rule e' n r # subst_rules e' n rs"
    | "subst_rule e' n (Rule p e) = Rule p (subst (mult_insert (pat_var_count p) e')
                                                  (next_by (pat_var_count p) n) e)"

lemma [simp]: "mult_insert m (insert n e) = insert (next_by m n) (mult_insert m e)"
by (induction m arbitrary: n e, simp_all)

end


(*  Title:      HOL/Algebra/Zassenhaus.thy
    Author:     Martin Baillon
*)

section \<open>The Zassenhaus Lemma\<close>

theory Zassenhaus
  imports Coset Group_Action
begin

text \<open>Proves the second isomorphism theorem and the Zassenhaus lemma.\<close>

subsection \<open>Lemmas about normalizer\<close>

lemma (in group) subgroup_in_normalizer:
  assumes "subgroup H G"
  shows "normal H (G\<lparr>carrier:= (normalizer G H)\<rparr>)"
proof(intro group.normal_invI)
  show "Group.group (G\<lparr>carrier := normalizer G H\<rparr>)"
    by (simp add: assms group.normalizer_imp_subgroup is_group subgroup_imp_group subgroup.subset)
  have K:"H \<subseteq> (normalizer G H)" unfolding normalizer_def
  proof
    fix x assume xH: "x \<in> H"
    from xH have xG : "x \<in> carrier G" using subgroup.subset assms by auto
    have "x <# H = H"
      by (metis \<open>x \<in> H\<close> assms group.lcos_mult_one is_group
         l_repr_independence one_closed subgroup.subset)
    moreover have "H #> inv x = H"
      by (simp add: xH assms is_group subgroup.rcos_const subgroup.m_inv_closed)
    ultimately have "x <# H #> (inv x) = H" by simp
    thus " x \<in> stabilizer G (\<lambda>g. \<lambda>H\<in>{H. H \<subseteq> carrier G}. g <# H #> inv g) H"
      using assms xG subgroup.subset unfolding stabilizer_def by auto
  qed
  thus "subgroup H (G\<lparr>carrier:= (normalizer G H)\<rparr>)"
    using subgroup_incl normalizer_imp_subgroup assms by (simp add: subgroup.subset)
  show  " \<And>x h. x \<in> carrier (G\<lparr>carrier := normalizer G H\<rparr>) \<Longrightarrow> h \<in> H \<Longrightarrow>
             x \<otimes>\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> h
               \<otimes>\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> inv\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> x \<in> H"
    proof-
    fix x h assume xnorm : "x \<in> carrier (G\<lparr>carrier := normalizer G H\<rparr>)" and hH : "h \<in> H"
    have xnormalizer:"x \<in> normalizer G H" using xnorm by simp
    moreover have hnormalizer:"h \<in> normalizer G H" using hH K by auto
    ultimately have "x \<otimes>\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> h = x \<otimes> h" by simp
    moreover have " inv\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> x =  inv x"
      using xnormalizer
      by (simp add: assms normalizer_imp_subgroup subgroup.subset m_inv_consistent)
    ultimately  have xhxegal: "x \<otimes>\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> h
                \<otimes>\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> inv\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> x
                  = x \<otimes>h \<otimes> inv x"
      using  hnormalizer by simp
    have  "x \<otimes>h \<otimes> inv x \<in> (x <# H #> inv x)"
      unfolding l_coset_def r_coset_def using hH  by auto
    moreover have "x <# H #> inv x = H"
      using xnormalizer assms subgroup.subset[OF assms]
      unfolding normalizer_def stabilizer_def by auto
    ultimately have "x \<otimes>h \<otimes> inv x \<in> H" by simp
    thus  " x \<otimes>\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> h
               \<otimes>\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> inv\<^bsub>G\<lparr>carrier := normalizer G H\<rparr>\<^esub> x \<in> H"
      using xhxegal hH xnorm by simp
  qed
qed

lemma (in group) normal_imp_subgroup_normalizer:
  assumes "subgroup H G"
    and "N \<lhd> (G\<lparr>carrier := H\<rparr>)"
  shows "subgroup H (G\<lparr>carrier := normalizer G N\<rparr>)"
proof-
  have N_carrierG : "N \<subseteq> carrier(G)"
    using assms normal_imp_subgroup subgroup.subset
    using incl_subgroup by blast
  {have "H \<subseteq> normalizer G N" unfolding normalizer_def stabilizer_def
    proof
      fix x assume xH : "x \<in> H"
      hence xcarrierG : "x \<in> carrier(G)" using assms subgroup.subset  by auto
      have "   N #> x = x <# N" using assms xH
        unfolding r_coset_def l_coset_def normal_def normal_axioms_def subgroup_imp_group by auto
      hence "x <# N #> inv x =(N #> x) #> inv x"
        by simp
      also have "... = N #> \<one>"
        using  assms r_inv xcarrierG coset_mult_assoc[OF N_carrierG] by simp
      finally have "x <# N #> inv x = N" by (simp add: N_carrierG)
      thus "x \<in> {g \<in> carrier G. (\<lambda>H\<in>{H. H \<subseteq> carrier G}. g <# H #> inv g) N = N}"
        using xcarrierG by (simp add : N_carrierG)
    qed}
  thus "subgroup H (G\<lparr>carrier := normalizer G N\<rparr>)"
    using subgroup_incl[OF assms(1) normalizer_imp_subgroup]
      assms normal_imp_subgroup subgroup.subset
    by (metis  group.incl_subgroup is_group)
qed

subsection \<open>Second Isomorphism Theorem\<close>

lemma (in group) mult_norm_subgroup:
  assumes "normal N G"
    and "subgroup H G"
  shows "subgroup (N<#>H) G" unfolding subgroup_def
proof-
  have  A :"N <#> H \<subseteq> carrier G"
    using assms  setmult_subset_G by (simp add: normal_imp_subgroup subgroup.subset)

  have B :"\<And> x y. \<lbrakk>x \<in> (N <#> H); y \<in> (N <#> H)\<rbrakk> \<Longrightarrow> (x \<otimes> y) \<in> (N<#>H)"
  proof-
    fix x y assume B1a: "x \<in> (N <#> H)"  and B1b: "y \<in> (N <#> H)"
    obtain n1 h1 where B2:"n1 \<in> N \<and> h1 \<in> H \<and> n1\<otimes>h1 = x"
      using set_mult_def B1a by (metis (no_types, lifting) UN_E singletonD)
    obtain n2 h2 where B3:"n2 \<in> N \<and> h2 \<in> H \<and> n2\<otimes>h2 = y"
      using set_mult_def B1b by (metis (no_types, lifting) UN_E singletonD)
    have "N #> h1 = h1 <# N"
      using normalI B2 assms normal.coset_eq subgroup.subset by blast
    hence "h1\<otimes>n2 \<in> N #> h1"
      using B2 B3 assms l_coset_def by fastforce
    from this obtain y2 where y2_def:"y2 \<in> N" and y2_prop:"y2\<otimes>h1 = h1\<otimes>n2"
      using singletonD by (metis (no_types, lifting) UN_E r_coset_def)
    have "\<And>a. a \<in> N \<Longrightarrow> a \<in> carrier G"  "\<And>a. a \<in> H \<Longrightarrow> a \<in> carrier G"
      by (meson assms normal_def subgroup.mem_carrier)+
    then have "x\<otimes>y =  n1 \<otimes> y2 \<otimes> h1 \<otimes> h2" using y2_def B2 B3
      by (metis (no_types) B2 B3 \<open>\<And>a. a \<in> N \<Longrightarrow> a \<in> carrier G\<close> m_assoc m_closed y2_def y2_prop)
    moreover have B4 :"n1 \<otimes> y2 \<in>N"
      using B2 y2_def assms normal_imp_subgroup by (metis subgroup_def)
    moreover have "h1 \<otimes> h2 \<in>H" using B2 B3 assms by (simp add: subgroup.m_closed)
    hence "(n1 \<otimes> y2) \<otimes> (h1 \<otimes> h2) \<in>(N<#>H) "
      using B4  unfolding set_mult_def by auto
    hence "n1 \<otimes> y2 \<otimes> h1 \<otimes> h2 \<in>(N<#>H)"
      using m_assoc B2 B3 assms  normal_imp_subgroup by (metis B4 subgroup.mem_carrier)
    ultimately show  "x \<otimes> y \<in> N <#> H" by auto
  qed
  have C :"\<And> x. x\<in>(N<#>H)  \<Longrightarrow> (inv x)\<in>(N<#>H)"

  proof-
    fix x assume C1 : "x \<in> (N<#>H)"
    obtain n h where C2:"n \<in> N \<and> h \<in> H \<and> n\<otimes>h = x"
      using set_mult_def C1 by (metis (no_types, lifting) UN_E singletonD)
    have C3 :"inv(n\<otimes>h) = inv(h)\<otimes>inv(n)"
      by (meson C2  assms inv_mult_group normal_imp_subgroup subgroup.mem_carrier)
    hence "... \<otimes>h \<in> N"
      using assms C2
      by (meson normal.inv_op_closed1 normal_def subgroup.m_inv_closed subgroup.mem_carrier)
    hence  C4:"(inv h \<otimes> inv n \<otimes> h) \<otimes> inv h \<in> (N<#>H)"
      using   C2 assms subgroup.m_inv_closed[of H G h] unfolding set_mult_def by auto
    have "inv h \<otimes> inv n \<otimes> h \<otimes> inv h = inv h \<otimes> inv n"
      using  subgroup.subset[OF assms(2)]
      by (metis A C1 C2 C3 inv_closed inv_solve_right m_closed subsetCE)
    thus "inv(x)\<in>N<#>H" using C4 C2 C3 by simp
  qed

  have D : "\<one> \<in> N <#> H"
  proof-
    have D1 : "\<one> \<in> N"
      using assms by (simp add: normal_def subgroup.one_closed)
     have D2 :"\<one> \<in> H"
      using assms by (simp add: subgroup.one_closed)
    thus "\<one> \<in> (N <#> H)"
      using set_mult_def D1 assms by fastforce
  qed
  thus "(N <#> H \<subseteq> carrier G \<and> (\<forall>x y. x \<in> N <#> H \<longrightarrow> y \<in> N <#> H \<longrightarrow> x \<otimes> y \<in> N <#> H)) \<and>
    \<one> \<in> N <#> H \<and> (\<forall>x. x \<in> N <#> H \<longrightarrow> inv x \<in> N <#> H)" using A B C D assms by blast
qed

lemma (in group) mult_norm_sub_in_sub:
  assumes "normal N (G\<lparr>carrier:=K\<rparr>)"
  assumes "subgroup H (G\<lparr>carrier:=K\<rparr>)"
  assumes "subgroup K G"
  shows  "subgroup (N<#>H) (G\<lparr>carrier:=K\<rparr>)"
proof-
  have Hyp:"subgroup (N <#>\<^bsub>G\<lparr>carrier := K\<rparr>\<^esub> H) (G\<lparr>carrier := K\<rparr>)"
    using group.mult_norm_subgroup[where ?G = "G\<lparr>carrier := K\<rparr>"] assms subgroup_imp_group by auto
  have "H \<subseteq> carrier(G\<lparr>carrier := K\<rparr>)" using assms subgroup.subset by blast
  also have "... \<subseteq> K" by simp
  finally have Incl1:"H \<subseteq> K" by simp
  have "N \<subseteq> carrier(G\<lparr>carrier := K\<rparr>)" using assms normal_imp_subgroup subgroup.subset by blast
  also have "... \<subseteq> K" by simp
  finally have Incl2:"N \<subseteq> K" by simp
  have "(N <#>\<^bsub>G\<lparr>carrier := K\<rparr>\<^esub> H) = (N <#> H)"
    using set_mult_consistent by simp
  thus "subgroup (N<#>H) (G\<lparr>carrier:=K\<rparr>)" using Hyp by auto
qed

lemma (in group) subgroup_of_normal_set_mult:
  assumes "normal N G"
and "subgroup H G"
shows "subgroup H (G\<lparr>carrier := N <#> H\<rparr>)"
proof-
  have "\<one> \<in> N" using normal_imp_subgroup assms(1) subgroup_def by blast
  hence "\<one> <# H \<subseteq> N <#> H" unfolding set_mult_def l_coset_def by blast
  hence H_incl : "H \<subseteq> N <#> H"
    by (metis assms(2) lcos_mult_one subgroup_def)
  show "subgroup H (G\<lparr>carrier := N <#> H\<rparr>)"
  using subgroup_incl[OF assms(2) mult_norm_subgroup[OF assms(1) assms(2)] H_incl] .
qed

lemma (in group) normal_in_normal_set_mult:
  assumes "normal N G"
and "subgroup H G"
shows "normal N (G\<lparr>carrier := N <#> H\<rparr>)"
proof-
  have "\<one> \<in> H" using  assms(2) subgroup_def by blast
  hence "N #> \<one>  \<subseteq> N <#> H" unfolding set_mult_def r_coset_def by blast
  hence N_incl : "N \<subseteq> N <#> H"
    by (metis assms(1) normal_imp_subgroup coset_mult_one subgroup_def)
  thus "normal N (G\<lparr>carrier := N <#> H\<rparr>)"
    using normal_Int_subgroup[OF mult_norm_subgroup[OF assms] assms(1)]
    by (simp add : inf_absorb1)
qed

proposition (in group) weak_snd_iso_thme:
  assumes "subgroup  H G"
    and "N\<lhd>G"
  shows "(G\<lparr>carrier := N<#>H\<rparr> Mod N \<cong> G\<lparr>carrier:=H\<rparr> Mod (N\<inter>H))"
proof-
  define f where "f =  (#>) N"
  have GroupNH : "Group.group (G\<lparr>carrier := N<#>H\<rparr>)"
    using subgroup_imp_group assms mult_norm_subgroup by simp
  have  HcarrierNH :"H \<subseteq> carrier(G\<lparr>carrier := N<#>H\<rparr>)"
    using assms subgroup_of_normal_set_mult subgroup.subset by blast
  hence HNH :"H \<subseteq> N<#>H" by simp
  have op_hom : "f \<in> hom (G\<lparr>carrier := H\<rparr>) (G\<lparr>carrier := N <#> H\<rparr> Mod N)" unfolding hom_def
  proof
    have "\<And>x . x \<in> carrier (G\<lparr>carrier :=H\<rparr>) \<Longrightarrow>
       (#>\<^bsub>G\<lparr>carrier := N <#> H\<rparr>\<^esub>) N x \<in>  carrier (G\<lparr>carrier := N <#> H\<rparr> Mod N)"
    proof-
      fix x assume  "x \<in> carrier (G\<lparr>carrier :=H\<rparr>)"
      hence xH : "x \<in> H" by simp
      hence "(#>\<^bsub>G\<lparr>carrier := N <#> H\<rparr>\<^esub>) N x \<in> rcosets\<^bsub>G\<lparr>carrier := N <#> H\<rparr>\<^esub> N"
        using HcarrierNH RCOSETS_def[where ?G = "G\<lparr>carrier := N <#> H\<rparr>"] by blast
      thus "(#>\<^bsub>G\<lparr>carrier := N <#> H\<rparr>\<^esub>) N x \<in>  carrier (G\<lparr>carrier := N <#> H\<rparr> Mod N)"
        unfolding FactGroup_def by simp
    qed
    hence "(#>\<^bsub>G\<lparr>carrier := N <#> H\<rparr>\<^esub>) N \<in> carrier (G\<lparr>carrier :=H\<rparr>) \<rightarrow>
            carrier (G\<lparr>carrier := N <#> H\<rparr> Mod N)" by auto
    hence "f \<in> carrier (G\<lparr>carrier :=H\<rparr>) \<rightarrow> carrier (G\<lparr>carrier := N <#> H\<rparr> Mod N)"
      unfolding r_coset_def f_def  by simp
    moreover have "\<And>x y. x\<in>carrier (G\<lparr>carrier := H\<rparr>) \<Longrightarrow> y\<in>carrier (G\<lparr>carrier := H\<rparr>) \<Longrightarrow>
                  f (x \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> y) =  f(x) \<otimes>\<^bsub>G\<lparr>carrier := N <#> H\<rparr> Mod N\<^esub> f(y)"
    proof-
      fix x y assume "x\<in>carrier (G\<lparr>carrier := H\<rparr>)" "y\<in>carrier (G\<lparr>carrier := H\<rparr>)"
      hence xHyH :"x \<in> H" "y \<in> H" by auto
      have Nxeq :"N #>\<^bsub>G\<lparr>carrier := N<#>H\<rparr>\<^esub> x = N #>x" unfolding r_coset_def by simp
      have Nyeq :"N #>\<^bsub>G\<lparr>carrier := N<#>H\<rparr>\<^esub> y = N #>y" unfolding r_coset_def by simp

      have "x \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> y =x \<otimes>\<^bsub>G\<lparr>carrier := N<#>H\<rparr>\<^esub> y" by simp
      hence "N #>\<^bsub>G\<lparr>carrier := N<#>H\<rparr>\<^esub> x \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> y
             = N #>\<^bsub>G\<lparr>carrier := N<#>H\<rparr>\<^esub> x \<otimes>\<^bsub>G\<lparr>carrier := N<#>H\<rparr>\<^esub> y" by simp
      also have "... = (N #>\<^bsub>G\<lparr>carrier := N<#>H\<rparr>\<^esub> x) <#>\<^bsub>G\<lparr>carrier := N<#>H\<rparr>\<^esub>
                       (N #>\<^bsub>G\<lparr>carrier := N<#>H\<rparr>\<^esub> y)"
        using normal.rcos_sum[OF normal_in_normal_set_mult[OF assms(2) assms(1)], of x y]
             xHyH assms HcarrierNH by auto
      finally show "f (x \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> y) =  f(x) \<otimes>\<^bsub>G\<lparr>carrier := N <#> H\<rparr> Mod N\<^esub> f(y)"
        unfolding  FactGroup_def r_coset_def f_def  using Nxeq Nyeq  by auto
    qed
    hence "(\<forall>x\<in>carrier (G\<lparr>carrier := H\<rparr>). \<forall>y\<in>carrier (G\<lparr>carrier := H\<rparr>).
           f (x \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> y) =  f(x) \<otimes>\<^bsub>G\<lparr>carrier := N <#> H\<rparr> Mod N\<^esub> f(y))" by blast
    ultimately show  " f \<in> carrier (G\<lparr>carrier := H\<rparr>) \<rightarrow> carrier (G\<lparr>carrier := N <#> H\<rparr> Mod N) \<and>
    (\<forall>x\<in>carrier (G\<lparr>carrier := H\<rparr>). \<forall>y\<in>carrier (G\<lparr>carrier := H\<rparr>).
     f (x \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> y) =  f(x) \<otimes>\<^bsub>G\<lparr>carrier := N <#> H\<rparr> Mod N\<^esub> f(y))"
      by auto
  qed
  hence homomorphism : "group_hom (G\<lparr>carrier := H\<rparr>) (G\<lparr>carrier := N <#> H\<rparr> Mod N) f"
    unfolding group_hom_def group_hom_axioms_def using subgroup_imp_group[OF assms(1)]
             normal.factorgroup_is_group[OF normal_in_normal_set_mult[OF assms(2) assms(1)]] by auto
  moreover have im_f :  "(f  ` carrier(G\<lparr>carrier:=H\<rparr>)) = carrier(G\<lparr>carrier := N <#> H\<rparr> Mod N)"
  proof
    show  "f ` carrier (G\<lparr>carrier := H\<rparr>) \<subseteq> carrier (G\<lparr>carrier := N <#> H\<rparr> Mod N)"
      using op_hom unfolding hom_def using funcset_image by blast
  next
    show "carrier (G\<lparr>carrier := N <#> H\<rparr> Mod N) \<subseteq> f ` carrier (G\<lparr>carrier := H\<rparr>)"
    proof
      fix x assume p : " x \<in> carrier (G\<lparr>carrier := N <#> H\<rparr> Mod N)"
      hence "x \<in> \<Union>{y. \<exists>x\<in>carrier (G\<lparr>carrier := N <#> H\<rparr>). y = {N #>\<^bsub>G\<lparr>carrier := N <#> H\<rparr>\<^esub> x}}"
        unfolding FactGroup_def RCOSETS_def by auto
      hence hyp :"\<exists>y. \<exists>h\<in>carrier (G\<lparr>carrier := N <#> H\<rparr>). y = {N #>\<^bsub>G\<lparr>carrier := N <#> H\<rparr>\<^esub> h} \<and> x \<in> y"
        using Union_iff by blast
      from hyp obtain nh where nhNH:"nh \<in>carrier (G\<lparr>carrier := N <#> H\<rparr>)"
                          and "x \<in> {N #>\<^bsub>G\<lparr>carrier := N <#> H\<rparr>\<^esub> nh}"
        by blast
      hence K: "x = (#>\<^bsub>G\<lparr>carrier := N <#> H\<rparr>\<^esub>) N nh" by simp
      have "nh \<in> N <#> H" using nhNH by simp
      from this obtain n h where nN : "n \<in> N" and hH : " h \<in> H" and nhnh: "n \<otimes> h = nh"
        unfolding set_mult_def by blast
      have  "x = (#>\<^bsub>G\<lparr>carrier := N <#> H\<rparr>\<^esub>) N (n \<otimes> h)" using K nhnh by simp
      hence  "x = (#>) N (n \<otimes> h)" using K nhnh unfolding r_coset_def by auto
      also have "... = (N #> n) #>h"
        using coset_mult_assoc hH nN assms subgroup.subset normal_imp_subgroup
        by (metis subgroup.mem_carrier)
      finally have "x = (#>) N h"
        using coset_join2[of n N] nN assms by (simp add: normal_imp_subgroup subgroup.mem_carrier)
      thus "x \<in> f ` carrier (G\<lparr>carrier := H\<rparr>)" using hH unfolding f_def by simp
    qed
  qed
  moreover have ker_f :"kernel (G\<lparr>carrier := H\<rparr>) (G\<lparr>carrier := N<#>H\<rparr> Mod N) f  = N\<inter>H"
    unfolding kernel_def f_def
    proof-
      have "{x \<in> carrier (G\<lparr>carrier := H\<rparr>). N #> x = \<one>\<^bsub>G\<lparr>carrier := N <#> H\<rparr> Mod N\<^esub>} =
            {x \<in> carrier (G\<lparr>carrier := H\<rparr>). N #> x = N}" unfolding FactGroup_def by simp
      also have "... = {x \<in> carrier (G\<lparr>carrier := H\<rparr>). x \<in> N}"
        using coset_join1
        by (metis (no_types, lifting) assms group.subgroup_self incl_subgroup is_group
          normal_imp_subgroup subgroup.mem_carrier subgroup.rcos_const subgroup_imp_group)
      also have "... =N \<inter> (carrier(G\<lparr>carrier := H\<rparr>))" by auto
      finally show "{x \<in> carrier (G\<lparr>carrier := H\<rparr>). N#>x = \<one>\<^bsub>G\<lparr>carrier := N <#> H\<rparr> Mod N\<^esub>} = N \<inter> H"
        by simp
    qed
    ultimately have "(G\<lparr>carrier := H\<rparr> Mod N \<inter> H) \<cong> (G\<lparr>carrier := N <#> H\<rparr> Mod N)"
      using group_hom.FactGroup_iso[OF homomorphism im_f] by auto
    hence "G\<lparr>carrier := N <#> H\<rparr> Mod N \<cong> G\<lparr>carrier := H\<rparr> Mod N \<inter> H"
      by (simp add: group.iso_sym assms normal.factorgroup_is_group normal_Int_subgroup)
    thus "G\<lparr>carrier := N <#> H\<rparr> Mod N \<cong> G\<lparr>carrier := H\<rparr> Mod N \<inter> H" by auto
qed

theorem (in group) snd_iso_thme:
  assumes "subgroup H G"
    and "subgroup N G"
    and "subgroup H (G\<lparr>carrier:= (normalizer G N)\<rparr>)"
  shows "(G\<lparr>carrier:= N<#>H\<rparr> Mod N)  \<cong> (G\<lparr>carrier:= H\<rparr> Mod (H\<inter>N))"
proof-
  have "G\<lparr>carrier := normalizer G N, carrier := H\<rparr>
       = G\<lparr>carrier := H\<rparr>"  by simp
  hence "G\<lparr>carrier := normalizer G N, carrier := H\<rparr> Mod N \<inter> H =
         G\<lparr>carrier := H\<rparr> Mod N \<inter> H" by auto
  moreover have "G\<lparr>carrier := normalizer G N,
                    carrier := N <#>\<^bsub>G\<lparr>carrier := normalizer G N\<rparr>\<^esub> H\<rparr> =
                G\<lparr>carrier := N <#>\<^bsub>G\<lparr>carrier := normalizer G N\<rparr>\<^esub> H\<rparr>" by simp
  hence "G\<lparr>carrier := normalizer G N,
          carrier := N <#>\<^bsub>G\<lparr>carrier := normalizer G N\<rparr>\<^esub> H\<rparr> Mod N =
          G\<lparr>carrier := N <#>\<^bsub>G\<lparr>carrier := normalizer G N\<rparr>\<^esub> H\<rparr> Mod N" by auto
  hence "G\<lparr>carrier := normalizer G N,
          carrier := N <#>\<^bsub>G\<lparr>carrier := normalizer G N\<rparr>\<^esub> H\<rparr> Mod N  \<cong>
         G\<lparr>carrier := normalizer G N, carrier := H\<rparr> Mod N \<inter> H =
          (G\<lparr>carrier:= N<#>H\<rparr> Mod N)  \<cong>
         G\<lparr>carrier := normalizer G N, carrier := H\<rparr> Mod N \<inter> H"
    using subgroup.subset[OF assms(3)]
          subgroup.subset[OF normal_imp_subgroup[OF subgroup_in_normalizer[OF assms(2)]]]
    by simp
  ultimately have "G\<lparr>carrier := normalizer G N,
                    carrier := N <#>\<^bsub>G\<lparr>carrier := normalizer G N\<rparr>\<^esub> H\<rparr> Mod N  \<cong>
                  G\<lparr>carrier := normalizer G N, carrier := H\<rparr> Mod N \<inter> H =
                 (G\<lparr>carrier:= N<#>H\<rparr> Mod N)  \<cong>  G\<lparr>carrier := H\<rparr> Mod N \<inter> H" by auto
  moreover have "G\<lparr>carrier := normalizer G N,
                    carrier := N <#>\<^bsub>G\<lparr>carrier := normalizer G N\<rparr>\<^esub> H\<rparr> Mod N  \<cong>
                  G\<lparr>carrier := normalizer G N, carrier := H\<rparr> Mod N \<inter> H"
    using group.weak_snd_iso_thme[OF subgroup_imp_group[OF normalizer_imp_subgroup[OF
          subgroup.subset[OF assms(2)]]] assms(3) subgroup_in_normalizer[OF assms(2)]]
    by simp
  moreover have "H\<inter>N = N\<inter>H" using assms  by auto
  ultimately show "(G\<lparr>carrier:= N<#>H\<rparr> Mod N)  \<cong>  G\<lparr>carrier := H\<rparr> Mod H \<inter> N" by auto
qed

corollary (in group) snd_iso_thme_recip :
  assumes "subgroup H G"
    and "subgroup N G"
    and "subgroup H (G\<lparr>carrier:= (normalizer G N)\<rparr>)"
  shows "(G\<lparr>carrier:= H<#>N\<rparr> Mod N)  \<cong> (G\<lparr>carrier:= H\<rparr> Mod (H\<inter>N))"
  by (metis assms commut_normal_subgroup group.subgroup_in_normalizer is_group subgroup.subset
      normalizer_imp_subgroup snd_iso_thme)

subsection\<open>The Zassenhaus Lemma\<close>

lemma (in group) distinc:
  assumes "subgroup  H G"
    and "H1\<lhd>G\<lparr>carrier := H\<rparr>"
    and  "subgroup K G"
    and "K1\<lhd>G\<lparr>carrier:=K\<rparr>"
  shows "subgroup (H\<inter>K) (G\<lparr>carrier:=(normalizer G (H1<#>(H\<inter>K1))) \<rparr>)"
proof (intro subgroup_incl[OF subgroups_Inter_pair[OF assms(1) assms(3)]])
  show "subgroup (normalizer G (H1 <#> H \<inter> K1)) G"
    using normalizer_imp_subgroup assms normal_imp_subgroup subgroup.subset
    by (metis group.incl_subgroup is_group setmult_subset_G subgroups_Inter_pair)
next
  show "H \<inter> K \<subseteq> normalizer G (H1 <#> H \<inter> K1)" unfolding normalizer_def stabilizer_def
  proof
    fix x assume xHK : "x \<in> H \<inter> K"
    hence xG : "{x} \<subseteq> carrier G" "{inv x} \<subseteq> carrier G"
      using subgroup.subset assms inv_closed xHK by auto
    have allG : "H \<subseteq> carrier G" "K \<subseteq> carrier G" "H1 \<subseteq> carrier G"  "K1 \<subseteq> carrier G"
      using assms subgroup.subset normal_imp_subgroup incl_subgroup apply blast+ .
    have HK1: "H \<inter> K1 \<subseteq> carrier G"
      by (simp add: allG(1) le_infI1)
    have HK1_normal: "H\<inter>K1 \<lhd> (G\<lparr>carrier :=  H \<inter> K\<rparr>)" using normal_inter[OF assms(3)assms(1)assms(4)]
      by (simp add : inf_commute)
    have "H \<inter> K \<subseteq> normalizer G (H \<inter> K1)"
      using subgroup.subset[OF normal_imp_subgroup_normalizer[OF subgroups_Inter_pair[OF
            assms(1)assms(3)]HK1_normal]] by auto
    hence "x <# (H \<inter> K1) #> inv x = (H \<inter> K1)"
      using xHK subgroup.subset[OF subgroups_Inter_pair[OF assms(1) incl_subgroup[OF assms(3)
                                                            normal_imp_subgroup[OF assms(4)]]]]
      unfolding normalizer_def stabilizer_def by auto
    moreover have "H \<subseteq>  normalizer G H1"
      using subgroup.subset[OF normal_imp_subgroup_normalizer[OF assms(1)assms(2)]] by auto
    hence "x <# H1 #> inv x = H1"
      using xHK subgroup.subset[OF  incl_subgroup[OF assms(1) normal_imp_subgroup[OF assms(2)]]]
      unfolding normalizer_def stabilizer_def by auto
    ultimately have "H1 <#> H \<inter> K1 = (x <# H1 #> inv x) <#> (x <#  H \<inter> K1 #> inv x)" by auto
    also have "... = ({x} <#> H1) <#> {inv x} <#> ({x} <#>  H \<inter> K1 <#> {inv x})"
      by (simp add : r_coset_eq_set_mult l_coset_eq_set_mult)
    also have "... = ({x} <#> H1 <#> {inv x} <#> {x}) <#>  (H \<inter> K1 <#> {inv x})"
      using HK1 allG(3) set_mult_assoc setmult_subset_G xG(1) by auto
    also have "... = ({x} <#> H1 <#> {\<one>}) <#>  (H \<inter> K1 <#> {inv x})"
      using allG xG coset_mult_assoc by (simp add: r_coset_eq_set_mult setmult_subset_G)
    also have "... =({x} <#> H1) <#>  (H \<inter> K1 <#> {inv x})"
      using coset_mult_one r_coset_eq_set_mult[of G H1 \<one>] set_mult_assoc[OF xG(1) allG(3)] allG
      by auto
    also have "... = {x} <#> (H1 <#> H \<inter> K1) <#> {inv x}"
      using allG xG set_mult_assoc setmult_subset_G by (metis inf.coboundedI2)
    finally have "H1 <#> H \<inter> K1 = x <# (H1 <#> H \<inter> K1) #> inv x"
      using xG setmult_subset_G allG by (simp add: l_coset_eq_set_mult r_coset_eq_set_mult)
    thus "x \<in> {g \<in> carrier G. (\<lambda>H\<in>{H. H \<subseteq> carrier G}. g <# H #> inv g) (H1 <#> H \<inter> K1)
                                                                       = H1 <#> H \<inter> K1}"
      using xG allG setmult_subset_G[OF allG(3), where ?K = "H\<inter>K1"] xHK
      by auto
  qed
qed

lemma (in group) preliminary1:
  assumes "subgroup  H G"
    and "H1\<lhd>G\<lparr>carrier := H\<rparr>"
    and  "subgroup K G"
    and "K1\<lhd>G\<lparr>carrier:=K\<rparr>"
  shows " (H\<inter>K) \<inter> (H1<#>(H\<inter>K1)) = (H1\<inter>K)<#>(H\<inter>K1)"
proof
  have all_inclG : "H \<subseteq> carrier G" "H1 \<subseteq> carrier G" "K \<subseteq> carrier G" "K1 \<subseteq> carrier G"
    using assms subgroup.subset normal_imp_subgroup incl_subgroup apply blast+.
  show "H \<inter> K \<inter> (H1 <#> H \<inter> K1) \<subseteq> H1 \<inter> K <#> H \<inter> K1"
  proof
    fix x assume x_def : "x \<in> (H \<inter> K) \<inter> (H1 <#> (H \<inter> K1))"
    from x_def have x_incl : "x \<in> H" "x \<in> K" "x \<in> (H1 <#> (H \<inter> K1))" by auto
    then obtain h1 hk1 where h1hk1_def : "h1 \<in> H1" "hk1 \<in> H \<inter> K1" "h1 \<otimes> hk1 = x"
      using assms unfolding set_mult_def by blast
    hence "hk1 \<in> H \<inter> K" using subgroup.subset[OF normal_imp_subgroup[OF assms(4)]] by auto
    hence "inv hk1 \<in> H \<inter> K" using subgroup.m_inv_closed[OF subgroups_Inter_pair] assms by auto
    moreover have "h1 \<otimes> hk1 \<in> H \<inter> K" using x_incl h1hk1_def by auto
    ultimately have "h1 \<otimes> hk1 \<otimes> inv hk1 \<in> H \<inter> K"
      using subgroup.m_closed[OF subgroups_Inter_pair] assms by auto
    hence "h1 \<in> H \<inter> K" using  h1hk1_def assms subgroup.subset incl_subgroup normal_imp_subgroup
      by (metis Int_iff contra_subsetD inv_solve_right m_closed)
    hence "h1 \<in> H1 \<inter> H \<inter> K" using h1hk1_def by auto
    hence "h1 \<in> H1 \<inter> K" using subgroup.subset[OF normal_imp_subgroup[OF assms(2)]] by auto
    hence "h1 \<otimes> hk1 \<in> (H1\<inter>K)<#>(H\<inter>K1)"
      using h1hk1_def unfolding set_mult_def by auto
    thus " x \<in> (H1\<inter>K)<#>(H\<inter>K1)" using h1hk1_def x_def by auto
  qed
  show "H1 \<inter> K <#> H \<inter> K1 \<subseteq> H \<inter> K \<inter> (H1 <#> H \<inter> K1)"
  proof-
    have "H1 \<inter> K \<subseteq> H \<inter> K" using subgroup.subset[OF normal_imp_subgroup[OF assms(2)]] by auto
    moreover have "H \<inter> K1 \<subseteq> H \<inter> K"
      using subgroup.subset[OF normal_imp_subgroup[OF assms(4)]] by auto
    ultimately have "H1 \<inter> K <#> H \<inter> K1 \<subseteq> H \<inter> K" unfolding set_mult_def
      using subgroup.m_closed[OF subgroups_Inter_pair [OF assms(1)assms(3)]] by blast
    moreover have "H1 \<inter> K \<subseteq> H1" by auto
    hence "H1 \<inter> K <#> H \<inter> K1 \<subseteq> (H1 <#> H \<inter> K1)" unfolding set_mult_def by auto
    ultimately show "H1 \<inter> K <#> H \<inter> K1 \<subseteq> H \<inter> K \<inter> (H1 <#> H \<inter> K1)" by auto
  qed
qed

lemma (in group) preliminary2:
  assumes "subgroup  H G"
    and "H1\<lhd>G\<lparr>carrier := H\<rparr>"
    and  "subgroup K G"
    and "K1\<lhd>G\<lparr>carrier:=K\<rparr>"
  shows "(H1<#>(H\<inter>K1)) \<lhd> G\<lparr>carrier:=(H1<#>(H\<inter>K))\<rparr>"
proof-
  have all_inclG : "H \<subseteq> carrier G" "H1 \<subseteq> carrier G" "K \<subseteq> carrier G" "K1 \<subseteq> carrier G"
    using assms subgroup.subset normal_imp_subgroup incl_subgroup apply blast+.
  have subH1:"subgroup (H1 <#> H \<inter> K) (G\<lparr>carrier := H\<rparr>)"
    using mult_norm_sub_in_sub[OF assms(2)subgroup_incl[OF subgroups_Inter_pair[OF assms(1)assms(3)]
          assms(1)]] assms by auto
  have "Group.group (G\<lparr>carrier:=(H1<#>(H\<inter>K))\<rparr>)"
    using  subgroup_imp_group[OF incl_subgroup[OF assms(1) subH1]].
  moreover have subH2 : "subgroup (H1 <#> H \<inter> K1) (G\<lparr>carrier := H\<rparr>)"
    using mult_norm_sub_in_sub[OF assms(2) subgroup_incl[OF subgroups_Inter_pair[OF
           assms(1) incl_subgroup[OF assms(3)normal_imp_subgroup[OF assms(4)]]]]] assms by auto
  hence "(H\<inter>K1) \<subseteq> (H\<inter>K)"
    using assms subgroup.subset normal_imp_subgroup monoid.cases_scheme
    by (metis inf.mono  partial_object.simps(1) partial_object.update_convs(1) subset_refl)
  hence incl:"(H1<#>(H\<inter>K1)) \<subseteq> H1<#>(H\<inter>K)" using assms subgroup.subset normal_imp_subgroup
    unfolding set_mult_def by blast
  hence "subgroup (H1 <#> H \<inter> K1) (G\<lparr>carrier := (H1<#>(H\<inter>K))\<rparr>)"
    using assms subgroup_incl[OF incl_subgroup[OF assms(1)subH2]incl_subgroup[OF assms(1)
          subH1]] normal_imp_subgroup subgroup.subset unfolding set_mult_def by blast
  moreover have " (\<And> x. x\<in>carrier (G\<lparr>carrier := H1 <#> H \<inter> K\<rparr>) \<Longrightarrow>
        H1 <#> H\<inter>K1 #>\<^bsub>G\<lparr>carrier := H1 <#> H\<inter>K\<rparr>\<^esub> x = x <#\<^bsub>G\<lparr>carrier := H1 <#> H\<inter>K\<rparr>\<^esub> (H1 <#> H\<inter>K1))"
  proof-
    fix x assume  "x \<in>carrier (G\<lparr>carrier := H1 <#> H \<inter> K\<rparr>)"
    hence x_def : "x \<in> H1 <#> H \<inter> K" by simp
    from this obtain h1 hk where h1hk_def :"h1 \<in> H1" "hk \<in> H \<inter> K" "h1 \<otimes> hk = x"
      unfolding set_mult_def by blast
    have HK1: "H \<inter> K1 \<subseteq> carrier G"
      by (simp add: all_inclG(1) le_infI1)
    have xH : "x \<in> H" using subgroup.subset[OF subH1] using x_def by auto
    hence allG : "h1 \<in> carrier G" "hk \<in> carrier G" "x \<in> carrier G"
      using assms subgroup.subset h1hk_def normal_imp_subgroup incl_subgroup apply blast+.
    hence "x <#\<^bsub>G\<lparr>carrier := H1 <#> H\<inter>K\<rparr>\<^esub> (H1 <#> H\<inter>K1) =h1 \<otimes> hk <# (H1 <#> H\<inter>K1)"
      using subgroup.subset xH h1hk_def by (simp add: l_coset_def)
    also have "... = h1 <# (hk <# (H1 <#> H\<inter>K1))"
      using lcos_m_assoc[OF subgroup.subset[OF incl_subgroup[OF assms(1) subH1]]allG(1)allG(2)]
      by (metis allG(1) allG(2) assms(1) incl_subgroup lcos_m_assoc subH2 subgroup.subset)
    also have "... = h1 <# (hk <# H1 <#> H\<inter>K1)"
      using set_mult_assoc all_inclG allG by (simp add: l_coset_eq_set_mult inf.coboundedI1)
    also have "... = h1 <# (hk <# H1 #> \<one> <#> H\<inter>K1 #> \<one>)"
      using coset_mult_one allG all_inclG l_coset_subset_G
      by (simp add: inf.coboundedI2 setmult_subset_G)
    also have "... = h1 <# (hk <# H1 #> inv hk #> hk <#> H\<inter>K1 #> inv hk #> hk)"
      using all_inclG allG coset_mult_assoc l_coset_subset_G
      by (simp add: inf.coboundedI1 setmult_subset_G)
    finally have "x <#\<^bsub>G\<lparr>carrier := H1 <#> H \<inter> K\<rparr>\<^esub> (H1 <#> H \<inter> K1)
                  = h1 <# ((hk <# H1 #> inv hk) <#> (hk <# H\<inter>K1 #> inv hk) #> hk)"
      using rcos_assoc_lcos allG all_inclG HK1
      by (simp add: l_coset_subset_G r_coset_subset_G setmult_rcos_assoc)
    moreover have "H \<subseteq>  normalizer G H1"
      using assms h1hk_def subgroup.subset[OF normal_imp_subgroup_normalizer] by simp
    hence "\<And>g. g \<in> H \<Longrightarrow>  g \<in> {g \<in> carrier G. (\<lambda>H\<in>{H. H \<subseteq> carrier G}. g <# H #> inv g) H1 = H1}"
      using all_inclG assms unfolding normalizer_def stabilizer_def by auto
    hence "\<And>g. g \<in> H \<Longrightarrow>  g <# H1 #> inv g = H1" using all_inclG by simp
    hence "(hk <# H1 #> inv hk) = H1" using h1hk_def all_inclG by simp
    moreover have "H\<inter>K \<subseteq> normalizer G (H\<inter>K1)"
      using normal_inter[OF assms(3)assms(1)assms(4)] assms subgroups_Inter_pair
            subgroup.subset[OF normal_imp_subgroup_normalizer] by (simp add: inf_commute)
    hence "\<And>g. g\<in>H\<inter>K \<Longrightarrow> g\<in>{g\<in>carrier G. (\<lambda>H\<in>{H. H \<subseteq> carrier G}. g <# H #> inv g) (H\<inter>K1) = H\<inter>K1}"
      using all_inclG assms unfolding normalizer_def stabilizer_def by auto
    hence "\<And>g. g \<in> H\<inter>K \<Longrightarrow>  g <# (H\<inter>K1) #> inv g = H\<inter>K1"
      using subgroup.subset[OF subgroups_Inter_pair[OF assms(1) incl_subgroup[OF
            assms(3)normal_imp_subgroup[OF assms(4)]]]] by auto
    hence "(hk <# H\<inter>K1 #> inv hk) = H\<inter>K1" using h1hk_def by simp
    ultimately have "x <#\<^bsub>G\<lparr>carrier := H1 <#> H \<inter> K\<rparr>\<^esub> (H1 <#> H \<inter> K1) = h1 <#(H1 <#> (H \<inter> K1)#> hk)"
      by auto
    also have "... = h1 <# H1 <#> ((H \<inter> K1)#> hk)"
      using set_mult_assoc[where ?M = "{h1}" and ?H = "H1" and ?K = "(H \<inter> K1)#> hk"] allG all_inclG
      by (simp add: l_coset_eq_set_mult inf.coboundedI2 r_coset_subset_G setmult_rcos_assoc)
    also have "... = H1 <#> ((H \<inter> K1)#> hk)"
      using coset_join3 allG incl_subgroup[OF assms(1)normal_imp_subgroup[OF assms(2)]] h1hk_def
      by auto
    finally have eq1 : "x <#\<^bsub>G\<lparr>carrier := H1 <#> H \<inter> K\<rparr>\<^esub> (H1 <#> H \<inter> K1) = H1 <#> (H \<inter> K1) #> hk"
      by (simp add: allG(2) all_inclG inf.coboundedI2 setmult_rcos_assoc)
    have "H1 <#> H \<inter> K1 #>\<^bsub>G\<lparr>carrier := H1 <#> H \<inter> K\<rparr>\<^esub> x = H1 <#> H \<inter> K1 #> (h1 \<otimes> hk)"
      using subgroup.subset xH h1hk_def by (simp add: r_coset_def)
    also have "... = H1 <#> H \<inter> K1 #> h1 #> hk"
      using coset_mult_assoc by (simp add: allG all_inclG inf.coboundedI2 setmult_subset_G)
    also have"... =  H \<inter> K1 <#> H1 #> h1 #> hk"
      using commut_normal_subgroup[OF assms(1)assms(2)subgroup_incl[OF subgroups_Inter_pair[OF
           assms(1)incl_subgroup[OF assms(3)normal_imp_subgroup[OF assms(4)]]]assms(1)]] by simp
    also have "... = H \<inter> K1 <#> H1  #> hk"
      using coset_join2[OF allG(1)incl_subgroup[OF assms(1)normal_imp_subgroup]
            h1hk_def(1)] all_inclG allG assms by (metis inf.coboundedI2 setmult_rcos_assoc)
    finally  have "H1 <#> H \<inter> K1 #>\<^bsub>G\<lparr>carrier := H1 <#> H \<inter> K\<rparr>\<^esub> x =H1 <#> H \<inter> K1  #> hk"
      using commut_normal_subgroup[OF assms(1)assms(2)subgroup_incl[OF subgroups_Inter_pair[OF
           assms(1)incl_subgroup[OF assms(3)normal_imp_subgroup[OF assms(4)]]]assms(1)]] by simp
    thus " H1 <#> H \<inter> K1 #>\<^bsub>G\<lparr>carrier := H1 <#> H \<inter> K\<rparr>\<^esub> x =
             x <#\<^bsub>G\<lparr>carrier := H1 <#> H \<inter> K\<rparr>\<^esub> (H1 <#> H \<inter> K1)" using eq1 by simp
  qed
  ultimately show "H1 <#> H \<inter> K1 \<lhd> G\<lparr>carrier := H1 <#> H \<inter> K\<rparr>"
    unfolding normal_def normal_axioms_def by auto
qed

proposition (in group)  Zassenhaus_1:
  assumes "subgroup  H G"
    and "H1\<lhd>G\<lparr>carrier := H\<rparr>"
    and  "subgroup K G"
    and "K1\<lhd>G\<lparr>carrier:=K\<rparr>"
  shows "(G\<lparr>carrier:= H1 <#> (H\<inter>K)\<rparr> Mod (H1<#>H\<inter>K1)) \<cong> (G\<lparr>carrier:= (H\<inter>K)\<rparr> Mod  ((H1\<inter>K)<#>(H\<inter>K1)))"
proof-
  define N  and N1 where "N = (H\<inter>K)" and "N1 =H1<#>(H\<inter>K1)"
  have normal_N_N1 : "subgroup N (G\<lparr>carrier:=(normalizer G N1)\<rparr>)"
    by (simp add: N1_def N_def assms distinc normal_imp_subgroup)
  have Hp:"(G\<lparr>carrier:= N<#>N1\<rparr> Mod N1)  \<cong> (G\<lparr>carrier:= N\<rparr> Mod (N\<inter>N1))"
  by (metis N1_def N_def assms incl_subgroup inf_le1 mult_norm_sub_in_sub
        normal_N_N1 normal_imp_subgroup snd_iso_thme_recip subgroup_incl subgroups_Inter_pair)
  have H_simp: "N<#>N1 = H1<#> (H\<inter>K)"
  proof-
    have H1_incl_G : "H1 \<subseteq> carrier G"
      using assms normal_imp_subgroup incl_subgroup subgroup.subset by blast
    have K1_incl_G :"K1 \<subseteq> carrier G"
      using assms normal_imp_subgroup incl_subgroup subgroup.subset by blast
    have "N<#>N1=  (H\<inter>K)<#> (H1<#>(H\<inter>K1))" by (auto simp add: N_def N1_def)
    also have "... = ((H\<inter>K)<#>H1) <#>(H\<inter>K1)"
      using set_mult_assoc[where ?M = "H\<inter>K"] K1_incl_G H1_incl_G assms
      by (simp add: inf.coboundedI2 subgroup.subset)
    also have "... = (H1<#>(H\<inter>K))<#>(H\<inter>K1)"
      using commut_normal_subgroup assms subgroup_incl subgroups_Inter_pair by auto
    also have "... =  H1 <#> ((H\<inter>K)<#>(H\<inter>K1))"
      using set_mult_assoc K1_incl_G H1_incl_G assms
      by (simp add: inf.coboundedI2 subgroup.subset)
    also have " ((H\<inter>K)<#>(H\<inter>K1)) = (H\<inter>K)"
    proof (intro set_mult_subgroup_idem[where ?H = "H\<inter>K" and ?N="H\<inter>K1",
             OF subgroups_Inter_pair[OF assms(1) assms(3)]])
      show "subgroup (H \<inter> K1) (G\<lparr>carrier := H \<inter> K\<rparr>)"
        using subgroup_incl[where ?I = "H\<inter>K1" and ?J = "H\<inter>K",OF subgroups_Inter_pair[OF assms(1)
              incl_subgroup[OF assms(3) normal_imp_subgroup]] subgroups_Inter_pair] assms
              normal_imp_subgroup by (metis inf_commute normal_inter)
    qed
    hence " H1 <#> ((H\<inter>K)<#>(H\<inter>K1)) =  H1 <#> ((H\<inter>K))"
      by simp
    thus "N <#> N1 = H1 <#> H \<inter> K"
      by (simp add: calculation)
  qed

  have "N\<inter>N1 = (H1\<inter>K)<#>(H\<inter>K1)"
    using preliminary1 assms N_def N1_def by simp
  thus  "(G\<lparr>carrier:= H1 <#> (H\<inter>K)\<rparr> Mod N1)  \<cong> (G\<lparr>carrier:= N\<rparr> Mod  ((H1\<inter>K)<#>(H\<inter>K1)))"
    using H_simp Hp by auto
qed

theorem (in group) Zassenhaus:
  assumes "subgroup  H G"
    and "H1\<lhd>G\<lparr>carrier := H\<rparr>"
    and  "subgroup K G"
    and "K1\<lhd>G\<lparr>carrier:=K\<rparr>"
  shows "(G\<lparr>carrier:= H1 <#> (H\<inter>K)\<rparr> Mod (H1<#>(H\<inter>K1)))  \<cong>
         (G\<lparr>carrier:= K1 <#> (H\<inter>K)\<rparr> Mod (K1<#>(K\<inter>H1)))"
proof-
  define Gmod1 Gmod2 Gmod3 Gmod4
    where "Gmod1 = (G\<lparr>carrier:= H1 <#> (H\<inter>K)\<rparr> Mod (H1<#>(H\<inter>K1))) "
      and "Gmod2 = (G\<lparr>carrier:= K1 <#> (K\<inter>H)\<rparr> Mod (K1<#>(K\<inter>H1)))"
      and "Gmod3 = (G\<lparr>carrier:= (H\<inter>K)\<rparr> Mod  ((H1\<inter>K)<#>(H\<inter>K1)))"
      and "Gmod4 = (G\<lparr>carrier:= (K\<inter>H)\<rparr> Mod  ((K1\<inter>H)<#>(K\<inter>H1)))"
  have Hyp :  "Gmod1  \<cong> Gmod3" "Gmod2  \<cong>  Gmod4"
    using Zassenhaus_1 assms Gmod1_def Gmod2_def Gmod3_def Gmod4_def by auto
  have Hp : "Gmod3 = G\<lparr>carrier:= (K\<inter>H)\<rparr> Mod ((K\<inter>H1)<#>(K1\<inter>H))"
    by (simp add: Gmod3_def inf_commute)
  have "(K\<inter>H1)<#>(K1\<inter>H) = (K1\<inter>H)<#>(K\<inter>H1)"
  proof (intro commut_normal_subgroup[OF subgroups_Inter_pair[OF assms(1)assms(3)]])
    show "K1 \<inter> H \<lhd> G\<lparr>carrier := H \<inter> K\<rparr>"
      using normal_inter[OF assms(3)assms(1)assms(4)] by (simp add: inf_commute)
   next
    show "subgroup (K \<inter> H1) (G\<lparr>carrier := H \<inter> K\<rparr>)"
      using subgroup_incl by (simp add: assms inf_commute normal_imp_subgroup normal_inter)
  qed
  hence  "Gmod3  = Gmod4" using Hp Gmod4_def by simp
  hence "Gmod1 \<cong> Gmod2"
    by (metis assms group.iso_sym iso_trans Hyp normal.factorgroup_is_group Gmod2_def preliminary2)
  thus ?thesis using Gmod1_def Gmod2_def by (simp add: inf_commute)
qed

end


theory Exe2p3
  imports Main
begin

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count a [] = 0" |
"count a (b # t) = (if a = b then count a t + 1 else count a t)"

lemma count_le_length: "count x xs \<le> length xs"
  apply(induction xs)
   apply(auto)
  done

end