section \<open> Derivatives: extra laws and tactics \<close>

theory Derivative_extra
  imports
  "HOL-Analysis.Analysis"
  "HOL-Eisbach.Eisbach"
  "HOL-Decision_Procs.Approximation"
begin

subsection \<open> Properties of filters \<close>

lemma filtermap_within_range_minus: "filtermap (\<lambda> x. x - n::real) (at y within {x..<y}) = (at (y - n) within ({x-n..<y-n}))"
  by (simp add: filter_eq_iff eventually_filtermap eventually_at_filter filtermap_nhds_shift[symmetric])

lemma filtermap_within_range_plus: "filtermap (\<lambda> x. x + n::real) (at y within {x..<y}) = (at (y + n) within ({x+n..<y+n}))"
  using filtermap_within_range_minus[of "-n"] by simp

lemma filter_upto_contract:
  "\<lbrakk> (x::real) \<le> y; y < z \<rbrakk> \<Longrightarrow> (at z within {x..<z}) = (at z within {y..<z})"
  by (rule at_within_nhd[of _ "{y<..<z+1}"], auto)

subsection \<open> Topological Spaces \<close>

instantiation unit :: t2_space
begin
  definition open_unit :: "unit set \<Rightarrow> bool" where "open_unit = (\<lambda> _. True)"
  instance by (intro_classes, simp_all add: open_unit_def)
end

subsection \<open> Extra derivative rules \<close>

lemma has_vector_derivative_Pair [derivative_intros]:
  "\<lbrakk> (f has_vector_derivative f') (at x within s); (g has_vector_derivative g') (at x within s) \<rbrakk> \<Longrightarrow>
      ((\<lambda> x. (f x, g x)) has_vector_derivative (f', g')) (at x within s)"
  by (auto intro: has_derivative_Pair simp add: has_vector_derivative_def)

lemma has_vector_derivative_power[simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> 'a :: real_normed_field"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. f x^n) has_vector_derivative (of_nat n * f' * f x^(n - 1))) (at x within s)"
  using assms
  apply (simp add: has_vector_derivative_def)
  apply (subst has_derivative_eq_rhs)
  apply (rule has_derivative_power)
  apply (auto)
done

lemma has_vector_derivative_divide[simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> 'a :: real_normed_div_algebra"
  assumes f: "(f has_vector_derivative f') (at x within s)"
      and g: "(g has_vector_derivative g') (at x within s)"
  assumes x: "g x \<noteq> 0"
  shows "((\<lambda>x. f x / g x) has_vector_derivative
                (- f x * (inverse (g x) * g' * inverse (g x)) + f' / g x)) (at x within s)"
  using assms
  apply (simp add: has_vector_derivative_def)
  apply (subst has_derivative_eq_rhs)
  apply (rule has_derivative_divide)
  apply (auto simp add: divide_inverse real_vector.scale_right_diff_distrib)
done

lemma Pair_has_vector_derivative:
  assumes "(f has_vector_derivative f') (at x within s)"
    "(g has_vector_derivative g') (at x within s)"
  shows "((\<lambda>x. (f x, g x)) has_vector_derivative (f', g')) (at x within s)"
  using assms
  by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros)

lemma has_vector_derivative_fst:
  assumes "((\<lambda>x. (f x, g x)) has_vector_derivative (f', g')) (at x within s)"
  shows "(f has_vector_derivative f') (at x within s)"
  using assms
  by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros dest: has_derivative_fst)

lemma has_vector_derivative_fst' [derivative_intros]:
  assumes "(f has_vector_derivative (f', g')) (at x within s)"
  shows "(fst \<circ> f has_vector_derivative f') (at x within s)"
proof -
  have "(\<lambda> x. (fst (f x), snd (f x))) = f"
    by (simp)
  with assms have "((\<lambda> x. (fst (f x), snd (f x))) has_vector_derivative (f', g')) (at x within s)"
    by (simp)
  thus ?thesis
    by (drule_tac has_vector_derivative_fst, simp add: comp_def)
qed

lemma has_vector_derivative_snd:
  assumes "((\<lambda>x. (f x, g x)) has_vector_derivative (f', g')) (at x within s)"
  shows "(g has_vector_derivative g') (at x within s)"
  using assms
  by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros dest: has_derivative_snd)

lemma has_vector_derivative_snd'' [derivative_intros]:
  assumes "(f has_vector_derivative (f', g')) (at x within s)"
  shows "(snd \<circ> f has_vector_derivative g') (at x within s)"
proof -
  have "(\<lambda> x. (fst (f x), snd (f x))) = f"
    by (simp)
  with assms have "((\<lambda> x. (fst (f x), snd (f x))) has_vector_derivative (f', g')) (at x within s)"
    by (simp)
  thus ?thesis
    by (drule_tac has_vector_derivative_snd, simp add: comp_def)
qed

lemma Pair_has_vector_derivative_iff:
  "((\<lambda>x. (f x, g x)) has_vector_derivative (f', g')) (at x within s) \<longleftrightarrow>
   (f has_vector_derivative f') (at x within s) \<and> (g has_vector_derivative g') (at x within s)"
  using Pair_has_vector_derivative has_vector_derivative_fst has_vector_derivative_snd by blast

text \<open> The next four rules allow us to prove derivatives when the function is equivalent to
  another a function when approach from the left or right. \<close>

lemma has_derivative_left_point:
  fixes f g :: "real \<Rightarrow> real"
  assumes "(f has_derivative f') (at x within s)" "x \<in> s" "x < y" "\<forall>x'<y. f x' = g x'"
  shows "(g has_derivative f') (at x within s)"
  apply (rule has_derivative_transform_within[of f f' x s "y-x" g])
  apply (simp_all add: assms dist_real_def)
done

lemma has_derivative_right_point:
  fixes f g :: "real \<Rightarrow> real"
  assumes "(f has_derivative f') (at x within s)" "x \<in> s" "x > y" "\<forall>x'>y. f x' = g x'"
  shows "(g has_derivative f') (at x within s)"
  apply (rule has_derivative_transform_within[of f f' x s "x-y" g])
  apply (simp_all add: assms dist_real_def)
done

lemma has_vector_derivative_left_point:
  fixes f g :: "real \<Rightarrow> real"
  assumes "(f has_vector_derivative f') (at x within s)" "x \<in> s" "x < y" "\<forall>x'<y. f x' = g x'"
  shows "(g has_vector_derivative f') (at x within s)"
  using assms
  apply (simp add: has_vector_derivative_def)
  apply (rule_tac y="y" and f="f" in has_derivative_left_point)
  apply (auto simp add: assms)
done

lemma has_vector_derivative_right_point:
  fixes f g :: "real \<Rightarrow> real"
  assumes "(f has_vector_derivative f') (at x within s)" "x \<in> s" "x > y" "\<forall>x'>y. f x' = g x'"
  shows "(g has_vector_derivative f') (at x within s)"
  using assms
  apply (simp add: has_vector_derivative_def)
  apply (rule_tac y="y" and f="f" in has_derivative_right_point)
  apply (auto simp add: assms)
done

method prove_vec_deriv = (simp add: has_vector_derivative_def, subst has_derivative_eq_rhs, force intro: derivative_intros; auto simp add: field_simps)

lemma has_vector_derivative_sqrt[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  assumes "f x > 0"
  shows "((\<lambda>x. sqrt(f x)) has_vector_derivative (f' * 1/(2 * sqrt(f x)))) (at x within s)"
  using assms unfolding divide_inverse by prove_vec_deriv

lemma has_vector_derivative_sin[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. sin(f x)) has_vector_derivative (f' * cos(f x))) (at x within s)"
  using assms by prove_vec_deriv

lemma has_vector_derivative_cos[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. cos(f x)) has_vector_derivative (f' * - sin(f x))) (at x within s)"
  using assms by prove_vec_deriv

lemma has_vector_derivative_exp[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. exp(f x)) has_vector_derivative (f' * exp(f x))) (at x within s)"
  using assms by prove_vec_deriv

lemma has_vector_derivative_ln[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)" "0 < f x"
  shows "((\<lambda>x. ln(f x)) has_vector_derivative (f' * inverse(f x))) (at x within s)"
  using assms by prove_vec_deriv

lemma has_vector_derivative_powr[derivative_intros]:
  fixes f :: "real \<Rightarrow> real" and g :: "real \<Rightarrow> real"
  assumes
    "(g has_vector_derivative g') (at x within X)"
    "(f has_vector_derivative f') (at x within X)"
    "0 < g x" "x \<in> X"
  shows "((\<lambda>x. g x powr f x) has_vector_derivative (g x powr f x * (f' * ln (g x) + g' * f x / g x))) (at x within X)"
  using assms by prove_vec_deriv

lemma max_simps [simp]:
  "(y::real) < max x y \<longleftrightarrow> y < x"
  "x < max x y \<longleftrightarrow> x < y"
  "max x y = y \<longleftrightarrow> x \<le> y"
  by auto

lemma min_simps [simp]:
  "min (x::real) y < x \<longleftrightarrow> y < x"
  "min x y < y \<longleftrightarrow> x < y"
  by auto

subsection \<open> Thomas' extra rules: \<close>

lemma has_vector_derivative_sinh[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. sinh(f x)) has_vector_derivative (f' * cosh(f x))) (at x within s)"
  using assms by (simp add: sinh_def cosh_def, prove_vec_deriv)

lemma has_vector_derivative_cosh[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. cosh(f x)) has_vector_derivative (f' * sinh(f x))) (at x within s)"
  using assms by (simp add: sinh_def cosh_def, prove_vec_deriv)

lemma has_vector_derivative_tanh[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at (x::real) within s)"
  shows "((\<lambda>(x::real). tanh(f x)) has_vector_derivative (f' * (1 - (tanh (f x))^2))) (at (x::real) within s)"
  oops
thm has_field_derivative_tanh

lemma has_vector_derivative_arcsin[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  assumes "-1 < f x & f x < 1"
  shows "((\<lambda>x. arcsin(f x)) has_vector_derivative (f' * inverse (sqrt(1-(f x)^2)))) (at x within s)"
  using assms by prove_vec_deriv

lemma has_vector_derivative_arccos[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  assumes "-1 < f x & f x < 1"
  shows "((\<lambda>x. arccos(f x)) has_vector_derivative (f' * inverse (- sqrt(1-(f x)^2)))) (at x within s)"
  using assms by prove_vec_deriv

lemma has_vector_derivative_arctan[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. arctan(f x)) has_vector_derivative (f' * inverse (1 + (f x)^2))) (at x within s)"
  using assms by prove_vec_deriv

text \<open> These laws seem helpful for discharging real conjectures. \<close>

lemma real_sqrt_pow2_combine [simp]: "x > 0 \<Longrightarrow> sqrt x * (sqrt x * n) = x * n"
  by simp

declare power2_eq_square [field_simps]

subsection \<open> Calculating derivatives \<close>

text \<open> We set up some nice syntax for taking derivatives by calculation, and prove associated
  theorems based on the Multivariate Analysis package. \<close>

notation frechet_derivative ("\<partial>")
notation vector_derivative ("\<partial>\<^sub>v")

lemma vector_derivative_chain_frechet:
  fixes g :: "'a::ordered_euclidean_space \<Rightarrow> 'b::ordered_euclidean_space"
  assumes "f differentiable (at x)" "g differentiable (at (f x))"
  shows "\<partial>\<^sub>v (g \<circ> f) (at x) = \<partial> g (at (f x)) (\<partial>\<^sub>v f (at x))"
proof -
  have "(g has_derivative \<partial> g (at (f x))) (at (f x))"
    using assms(2) frechet_derivative_works by blast
  hence 1:"(g has_derivative \<partial> g (at (f x))) (at (f x) within range f)"
    by (simp add: has_derivative_at_withinI)
  from 1 assms show ?thesis
    by (auto intro: vector_derivative_chain_within simp add: at_eq_bot_iff)
qed

lemma frechet_derivative_const: "\<partial> (\<lambda> x. k) (at t) = (\<lambda> x. 0)"
  by (metis frechet_derivative_at has_derivative_const)

lemma frechet_derivative_plus:
  fixes f g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
  assumes "f differentiable (at t)" "g differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x + g x) (at t) = (\<lambda> x. \<partial> f (at t) x + \<partial> g (at t) x)"
proof -
  have "((\<lambda>x. f x + g x) has_derivative (\<lambda>x. \<partial> f (at t) x + \<partial> g (at t) x)) (at t)"
    using assms(1) assms(2) frechet_derivative_works has_derivative_add by blast
  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_uminus:
  assumes "f differentiable (at t)"
  shows "\<partial> (\<lambda> x. - f x) (at t) = (\<lambda>x. - \<partial> f (at t) x)"
proof -
  have "((\<lambda>x. - f x) has_derivative (\<lambda>x. - \<partial> f (at t) x)) (at t)"
    using assms frechet_derivative_works has_derivative_minus by blast
  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_minus:
  fixes f g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
  assumes "f differentiable (at t)" "g differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x - g x) (at t) = (\<lambda> x. \<partial> f (at t) x - \<partial> g (at t) x)"
proof -
  have "((\<lambda>x. f x - g x) has_derivative (\<lambda>x. \<partial> f (at t) x - \<partial> g (at t) x)) (at t)"
    using assms(1) assms(2) frechet_derivative_works has_derivative_diff by blast
  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_mult:
  fixes f g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_algebra"
  assumes "f differentiable (at t)" "g differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x * g x) (at t) =
         (\<lambda> x. f t * \<partial> g (at t) x + \<partial> f (at t) x * g t)"
proof -
  have "((\<lambda>x. f x * g x) has_derivative (\<lambda> x. f t * \<partial> g (at t) x + \<partial> f (at t) x * g t)) (at t)"
    using assms(1) assms(2) frechet_derivative_works has_derivative_mult by blast
  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_scaleR:
  fixes g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_algebra"
  assumes "f differentiable (at t)" "g differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x *\<^sub>R g x) (at t) =
         (\<lambda> x. f t *\<^sub>R \<partial> g (at t) x + \<partial> f (at t) x *\<^sub>R g t)"
proof -
  have "((\<lambda>x. f x *\<^sub>R g x) has_derivative (\<lambda> x. f t *\<^sub>R \<partial> g (at t) x + \<partial> f (at t) x *\<^sub>R g t)) (at t)"
  proof -
    have "(f has_derivative \<partial> f (at t)) (at t)"
      by (meson assms(1) frechet_derivative_works)
    then show ?thesis
      using assms(2) frechet_derivative_works has_derivative_scaleR by blast
  qed

  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_norm:
  fixes f :: "'a::{real_inner} \<Rightarrow> 'b::{real_inner}"
  assumes "f differentiable (at t)" "f t \<noteq> 0"
  shows "\<partial> (\<lambda> x. norm (f x)) (at t) = (\<lambda> x. \<partial> f (at t) x \<bullet> sgn (f t))"
proof -
  have "(norm \<circ> f has_derivative ((\<lambda> x. x \<bullet> sgn (f t)) \<circ> \<partial> f (at t))) (at t)"
    using assms(1) assms(2) diff_chain_at frechet_derivative_works has_derivative_norm by blast
  thus ?thesis
    by (metis assms differentiable_def frechet_derivative_at has_derivative_compose has_derivative_norm)
qed

lemma frechet_derivative_power:
  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_field"
  assumes "f differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x ^ n) (at t) = (\<lambda>y. of_nat n * \<partial> f (at t) y * f t ^ (n - 1))"
  using assms has_derivative_power[of f "\<partial> f (at t)" t UNIV n] frechet_derivative_at
  by (fastforce simp add: frechet_derivative_works)

lemma frechet_derivative_powr:
  fixes f :: "'a::{banach, real_normed_algebra_1} \<Rightarrow> real"
  assumes "f differentiable (at t)" "g differentiable (at t)" "0 < f t"
  shows "\<partial> (\<lambda> x. f x powr g x) (at t) = (\<lambda>h. f t powr g t * (\<partial> g (at t) h * ln (f t) + \<partial> f (at t) h * g t / f t))"
  using assms has_derivative_powr[of f "\<partial> f (at t)" t UNIV g "\<partial> g (at t)"] frechet_derivative_at
  by (fastforce simp add: frechet_derivative_works)

lemma frechet_derivative_ln:
  fixes f :: "'a::{banach, real_normed_algebra_1} \<Rightarrow> real"
  assumes "f differentiable (at t)" "0 < f t"
  shows "\<partial> (\<lambda> x. ln (f x)) (at t) = (\<lambda> x. \<partial> f (at t) x * inverse (f t))"
  by (metis assms(1) assms(2) frechet_derivative_at frechet_derivative_works has_derivative_ln)

lemma frechet_derivative_sin:
  fixes f :: "'a::{banach, real_normed_algebra_1} \<Rightarrow> real"
  assumes "f differentiable (at t)"
  shows "\<partial> (\<lambda> x. sin (f x)) (at t) = (\<lambda> x. \<partial> f (at t) x * cos (f t))"
  by (metis assms frechet_derivative_at frechet_derivative_works has_derivative_sin)

end


section\<open>Free Abelian Groups\<close>

theory Free_Abelian_Groups
  imports
    Product_Groups FiniteProduct "HOL-Cardinals.Cardinal_Arithmetic"
   "HOL-Library.Countable_Set" "HOL-Library.Poly_Mapping" "HOL-Library.Equipollence"

begin

(*Move? But where?*)
lemma eqpoll_Fpow:
  assumes "infinite A" shows "Fpow A \<approx> A"
  unfolding eqpoll_iff_card_of_ordIso
  by (metis assms card_of_Fpow_infinite)

lemma infinite_iff_card_of_countable: "\<lbrakk>countable B; infinite B\<rbrakk> \<Longrightarrow> infinite A \<longleftrightarrow> ( |B| \<le>o |A| )"
  unfolding infinite_iff_countable_subset card_of_ordLeq countable_def
  by (force intro: card_of_ordLeqI ordLeq_transitive)

lemma iso_imp_eqpoll_carrier: "G \<cong> H \<Longrightarrow> carrier G \<approx> carrier H"
  by (auto simp: is_iso_def iso_def eqpoll_def)

subsection\<open>Generalised finite product\<close>

definition
  gfinprod :: "[('b, 'm) monoid_scheme, 'a \<Rightarrow> 'b, 'a set] \<Rightarrow> 'b"
  where "gfinprod G f A =
   (if finite {x \<in> A. f x \<noteq> \<one>\<^bsub>G\<^esub>} then finprod G f {x \<in> A. f x \<noteq> \<one>\<^bsub>G\<^esub>} else \<one>\<^bsub>G\<^esub>)"

context comm_monoid begin

lemma gfinprod_closed [simp]:
  "f \<in> A \<rightarrow> carrier G \<Longrightarrow> gfinprod G f A \<in> carrier G"
  unfolding gfinprod_def
  by (auto simp: image_subset_iff_funcset intro: finprod_closed)

lemma gfinprod_cong:
  "\<lbrakk>A = B; f \<in> B \<rightarrow> carrier G;
    \<And>i. i \<in> B =simp=> f i = g i\<rbrakk> \<Longrightarrow> gfinprod G f A = gfinprod G g B"
  unfolding gfinprod_def
  by (auto simp: simp_implies_def cong: conj_cong intro: finprod_cong)

lemma gfinprod_eq_finprod [simp]: "\<lbrakk>finite A; f \<in> A \<rightarrow> carrier G\<rbrakk> \<Longrightarrow> gfinprod G f A = finprod G f A"
  by (auto simp: gfinprod_def intro: finprod_mono_neutral_cong_left)

lemma gfinprod_insert [simp]:
  assumes "finite {x \<in> A. f x \<noteq> \<one>\<^bsub>G\<^esub>}" "f \<in> A \<rightarrow> carrier G" "f i \<in> carrier G"
  shows "gfinprod G f (insert i A) = (if i \<in> A then gfinprod G f A else f i \<otimes> gfinprod G f A)"
proof -
  have f: "f \<in> {x \<in> A. f x \<noteq> \<one>} \<rightarrow> carrier G"
    using assms by (auto simp: image_subset_iff_funcset)
  have "{x. x = i \<and> f x \<noteq> \<one> \<or> x \<in> A \<and> f x \<noteq> \<one>} = (if f i = \<one> then {x \<in> A. f x \<noteq> \<one>} else insert i {x \<in> A. f x \<noteq> \<one>})"
    by auto
  then show ?thesis
    using assms
    unfolding gfinprod_def by (simp add: conj_disj_distribR insert_absorb f split: if_split_asm)
qed

lemma gfinprod_distrib:
  assumes fin: "finite {x \<in> A. f x \<noteq> \<one>\<^bsub>G\<^esub>}" "finite {x \<in> A. g x \<noteq> \<one>\<^bsub>G\<^esub>}"
     and "f \<in> A \<rightarrow> carrier G" "g \<in> A \<rightarrow> carrier G"
  shows "gfinprod G (\<lambda>i. f i \<otimes> g i) A = gfinprod G f A \<otimes> gfinprod G g A"
proof -
  have "finite {x \<in> A. f x \<otimes> g x \<noteq> \<one>}"
    by (auto intro: finite_subset [OF _ finite_UnI [OF fin]])
  then have "gfinprod G (\<lambda>i. f i \<otimes> g i) A = gfinprod G (\<lambda>i. f i \<otimes> g i) ({i \<in> A. f i \<noteq> \<one>\<^bsub>G\<^esub>} \<union> {i \<in> A. g i \<noteq> \<one>\<^bsub>G\<^esub>})"
    unfolding gfinprod_def
    using assms by (force intro: finprod_mono_neutral_cong)
  also have "\<dots> = gfinprod G f A \<otimes> gfinprod G g A"
  proof -
    have "finprod G f ({i \<in> A. f i \<noteq> \<one>\<^bsub>G\<^esub>} \<union> {i \<in> A. g i \<noteq> \<one>\<^bsub>G\<^esub>}) = gfinprod G f A"
      "finprod G g ({i \<in> A. f i \<noteq> \<one>\<^bsub>G\<^esub>} \<union> {i \<in> A. g i \<noteq> \<one>\<^bsub>G\<^esub>}) = gfinprod G g A"
      using assms by (auto simp: gfinprod_def intro: finprod_mono_neutral_cong_right)
    moreover have "(\<lambda>i. f i \<otimes> g i) \<in> {i \<in> A. f i \<noteq> \<one>} \<union> {i \<in> A. g i \<noteq> \<one>} \<rightarrow> carrier G"
      using assms by (force simp: image_subset_iff_funcset)
    ultimately show ?thesis
      using assms
      apply simp
      apply (subst finprod_multf, auto)
      done
  qed
  finally show ?thesis .
qed

lemma gfinprod_mono_neutral_cong_left:
  assumes "A \<subseteq> B"
    and 1: "\<And>i. i \<in> B - A \<Longrightarrow> h i = \<one>"
    and gh: "\<And>x. x \<in> A \<Longrightarrow> g x = h x"
    and h: "h \<in> B \<rightarrow> carrier G"
  shows "gfinprod G g A = gfinprod G h B"
proof (cases "finite {x \<in> B. h x \<noteq> \<one>}")
  case True
  then have "finite {x \<in> A. h x \<noteq> \<one>}"
    apply (rule rev_finite_subset)
    using \<open>A \<subseteq> B\<close> by auto
  with True assms show ?thesis
    apply (simp add: gfinprod_def cong: conj_cong)
    apply (auto intro!: finprod_mono_neutral_cong_left)
    done
next
  case False
  have "{x \<in> B. h x \<noteq> \<one>} \<subseteq> {x \<in> A. h x \<noteq> \<one>}"
    using 1 by auto
  with False have "infinite {x \<in> A. h x \<noteq> \<one>}"
    using infinite_super by blast
  with False assms show ?thesis
    by (simp add: gfinprod_def cong: conj_cong)
qed

lemma gfinprod_mono_neutral_cong_right:
  assumes "A \<subseteq> B" "\<And>i. i \<in> B - A \<Longrightarrow> g i = \<one>" "\<And>x. x \<in> A \<Longrightarrow> g x = h x" "g \<in> B \<rightarrow> carrier G"
  shows "gfinprod G g B = gfinprod G h A"
  using assms  by (auto intro!: gfinprod_mono_neutral_cong_left [symmetric])

lemma gfinprod_mono_neutral_cong:
  assumes [simp]: "finite B" "finite A"
    and *: "\<And>i. i \<in> B - A \<Longrightarrow> h i = \<one>" "\<And>i. i \<in> A - B \<Longrightarrow> g i = \<one>"
    and gh: "\<And>x. x \<in> A \<inter> B \<Longrightarrow> g x = h x"
    and g: "g \<in> A \<rightarrow> carrier G"
    and h: "h \<in> B \<rightarrow> carrier G"
 shows "gfinprod G g A = gfinprod G h B"
proof-
  have "gfinprod G g A = gfinprod G g (A \<inter> B)"
    by (rule gfinprod_mono_neutral_cong_right) (use assms in auto)
  also have "\<dots> = gfinprod G h (A \<inter> B)"
    by (rule gfinprod_cong) (use assms in auto)
  also have "\<dots> = gfinprod G h B"
    by (rule gfinprod_mono_neutral_cong_left) (use assms in auto)
  finally show ?thesis .
qed

end

lemma (in comm_group) hom_group_sum:
  assumes hom: "\<And>i. i \<in> I \<Longrightarrow> f i \<in> hom (A i) G" and grp: "\<And>i. i \<in> I \<Longrightarrow> group (A i)"
  shows "(\<lambda>x. gfinprod G (\<lambda>i. (f i) (x i)) I) \<in> hom (sum_group I A) G"
  unfolding hom_def
proof (intro CollectI conjI ballI)
  show "(\<lambda>x. gfinprod G (\<lambda>i. f i (x i)) I) \<in> carrier (sum_group I A) \<rightarrow> carrier G"
    using assms
    by (force simp: hom_def carrier_sum_group intro: gfinprod_closed simp flip: image_subset_iff_funcset)
next
  fix x y
  assume x: "x \<in> carrier (sum_group I A)" and y: "y \<in> carrier (sum_group I A)"
  then have finx: "finite {i \<in> I. x i \<noteq> \<one>\<^bsub>A i\<^esub>}" and finy: "finite {i \<in> I. y i \<noteq> \<one>\<^bsub>A i\<^esub>}"
    using assms by (auto simp: carrier_sum_group)
  have finfx: "finite {i \<in> I. f i (x i) \<noteq> \<one>}"
    using assms by (auto simp: is_group hom_one [OF hom] intro: finite_subset [OF _ finx])
  have finfy: "finite {i \<in> I. f i (y i) \<noteq> \<one>}"
    using assms by (auto simp: is_group hom_one [OF hom] intro: finite_subset [OF _ finy])
  have carr: "f i (x i) \<in> carrier G"  "f i (y i) \<in> carrier G" if "i \<in> I" for i
    using hom_carrier [OF hom] that x y assms
    by (fastforce simp add: carrier_sum_group)+
  have lam: "(\<lambda>i. f i ( x i \<otimes>\<^bsub>A i\<^esub> y i)) \<in> I \<rightarrow> carrier G"
    using x y assms by (auto simp: hom_def carrier_sum_group PiE_def Pi_def)
  have lam': "(\<lambda>i. f i (if i \<in> I then x i \<otimes>\<^bsub>A i\<^esub> y i else undefined)) \<in> I \<rightarrow> carrier G"
    by (simp add: lam Pi_cong)
  with lam x y assms
  show "gfinprod G (\<lambda>i. f i ((x \<otimes>\<^bsub>sum_group I A\<^esub> y) i)) I
      = gfinprod G (\<lambda>i. f i (x i)) I \<otimes> gfinprod G (\<lambda>i. f i (y i)) I"
    by (simp add: carrier_sum_group PiE_def Pi_def hom_mult [OF hom]
                  gfinprod_distrib finfx finfy carr cong: gfinprod_cong)
qed

subsection\<open>Free Abelian groups on a set, using the "frag" type constructor.          \<close>

definition free_Abelian_group :: "'a set \<Rightarrow> ('a \<Rightarrow>\<^sub>0 int) monoid"
  where "free_Abelian_group S = \<lparr>carrier = {c. Poly_Mapping.keys c \<subseteq> S}, monoid.mult = (+), one  = 0\<rparr>"

lemma group_free_Abelian_group [simp]: "group (free_Abelian_group S)"
proof -
  have "\<And>x. Poly_Mapping.keys x \<subseteq> S \<Longrightarrow> x \<in> Units (free_Abelian_group S)"
    unfolding free_Abelian_group_def Units_def
    by clarsimp (metis eq_neg_iff_add_eq_0 neg_eq_iff_add_eq_0 keys_minus)
  then show ?thesis
    unfolding free_Abelian_group_def
    by unfold_locales (auto simp: dest: subsetD [OF keys_add])
qed

lemma carrier_free_Abelian_group_iff [simp]:
  shows "x \<in> carrier (free_Abelian_group S) \<longleftrightarrow> Poly_Mapping.keys x \<subseteq> S"
  by (auto simp: free_Abelian_group_def)

lemma one_free_Abelian_group [simp]: "\<one>\<^bsub>free_Abelian_group S\<^esub> = 0"
  by (auto simp: free_Abelian_group_def)

lemma mult_free_Abelian_group [simp]: "x \<otimes>\<^bsub>free_Abelian_group S\<^esub> y = x + y"
  by (auto simp: free_Abelian_group_def)

lemma inv_free_Abelian_group [simp]: "Poly_Mapping.keys x \<subseteq> S \<Longrightarrow> inv\<^bsub>free_Abelian_group S\<^esub> x = -x"
  by (rule group.inv_equality [OF group_free_Abelian_group]) auto

lemma abelian_free_Abelian_group: "comm_group(free_Abelian_group S)"
  apply (rule group.group_comm_groupI [OF group_free_Abelian_group])
  by (simp add: free_Abelian_group_def)

lemma pow_free_Abelian_group [simp]:
  fixes n::nat
  shows "Group.pow (free_Abelian_group S) x n = frag_cmul (int n) x"
  by (induction n) (auto simp: nat_pow_def free_Abelian_group_def frag_cmul_distrib)

lemma int_pow_free_Abelian_group [simp]:
  fixes n::int
  assumes "Poly_Mapping.keys x \<subseteq> S"
  shows "Group.pow (free_Abelian_group S) x n = frag_cmul n x"
proof (induction n)
  case (nonneg n)
  then show ?case
    by (simp add: int_pow_int)
next
  case (neg n)
  have "x [^]\<^bsub>free_Abelian_group S\<^esub> - int (Suc n)
     = inv\<^bsub>free_Abelian_group S\<^esub> (x [^]\<^bsub>free_Abelian_group S\<^esub> int (Suc n))"
    by (rule group.int_pow_neg [OF group_free_Abelian_group]) (use assms in \<open>simp add: free_Abelian_group_def\<close>)
  also have "\<dots> = frag_cmul (- int (Suc n)) x"
    by (metis assms inv_free_Abelian_group pow_free_Abelian_group int_pow_int minus_frag_cmul
              order_trans keys_cmul)
  finally show ?case .
qed

lemma frag_of_in_free_Abelian_group [simp]:
   "frag_of x \<in> carrier(free_Abelian_group S) \<longleftrightarrow> x \<in> S"
  by simp

lemma free_Abelian_group_induct:
  assumes major: "Poly_Mapping.keys x \<subseteq> S"
      and minor: "P(0)"
           "\<And>x y. \<lbrakk>Poly_Mapping.keys x \<subseteq> S; Poly_Mapping.keys y \<subseteq> S; P x; P y\<rbrakk> \<Longrightarrow> P(x-y)"
           "\<And>a. a \<in> S \<Longrightarrow> P(frag_of a)"
         shows "P x"
proof -
  have "Poly_Mapping.keys x \<subseteq> S \<and> P x"
    using major
  proof (induction x rule: frag_induction)
    case (diff a b)
    then show ?case
      by (meson Un_least minor(2) order.trans keys_diff)
  qed (auto intro: minor)
  then show ?thesis ..
qed

lemma sum_closed_free_Abelian_group:
    "(\<And>i. i \<in> I \<Longrightarrow> x i \<in> carrier (free_Abelian_group S)) \<Longrightarrow> sum x I \<in> carrier (free_Abelian_group S)"
  apply (induction I rule: infinite_finite_induct, auto)
  by (metis (no_types, opaque_lifting) UnE subsetCE keys_add)

lemma (in comm_group) free_Abelian_group_universal:
  fixes f :: "'c \<Rightarrow> 'a"
  assumes "f ` S \<subseteq> carrier G"
  obtains h where "h \<in> hom (free_Abelian_group S) G" "\<And>x. x \<in> S \<Longrightarrow> h(frag_of x) = f x"
proof
  have fin: "Poly_Mapping.keys u \<subseteq> S \<Longrightarrow> finite {x \<in> S. f x [^] poly_mapping.lookup u x \<noteq> \<one>}" for u :: "'c \<Rightarrow>\<^sub>0 int"
    apply (rule finite_subset [OF _ finite_keys [of u]])
    unfolding keys.rep_eq by force
  define h :: "('c \<Rightarrow>\<^sub>0 int) \<Rightarrow> 'a"
    where "h \<equiv> \<lambda>x. gfinprod G (\<lambda>a. f a [^] poly_mapping.lookup x a) S"
  show "h \<in> hom (free_Abelian_group S) G"
  proof (rule homI)
    fix x y
    assume xy: "x \<in> carrier (free_Abelian_group S)" "y \<in> carrier (free_Abelian_group S)"
    then show "h (x \<otimes>\<^bsub>free_Abelian_group S\<^esub> y) = h x \<otimes> h y"
      using assms unfolding h_def free_Abelian_group_def
      by (simp add: fin gfinprod_distrib image_subset_iff Poly_Mapping.lookup_add int_pow_mult cong: gfinprod_cong)
  qed (use assms in \<open>force simp: free_Abelian_group_def h_def intro: gfinprod_closed\<close>)
  show "h(frag_of x) = f x" if "x \<in> S" for x
  proof -
    have fin: "(\<lambda>a. f x [^] (1::int)) \<in> {x} \<rightarrow> carrier G" "f x [^] (1::int) \<in> carrier G"
      using assms that by force+
    show ?thesis
      by (cases " f x [^] (1::int) = \<one>") (use assms that in \<open>auto simp: h_def gfinprod_def finprod_singleton\<close>)
  qed
qed

lemma eqpoll_free_Abelian_group_infinite:
  assumes "infinite A" shows "carrier(free_Abelian_group A) \<approx> A"
proof (rule lepoll_antisym)
  have "carrier (free_Abelian_group A) \<lesssim> {f::'a\<Rightarrow>int. f ` A \<subseteq> UNIV \<and> {x. f x \<noteq> 0} \<subseteq> A \<and> finite {x. f x \<noteq> 0}}"
    unfolding lepoll_def
    by (rule_tac x="Poly_Mapping.lookup" in exI) (auto simp: poly_mapping_eqI lookup_not_eq_zero_eq_in_keys inj_onI)
  also have "\<dots> \<lesssim> Fpow (A \<times> (UNIV::int set))"
    by (rule lepoll_restricted_funspace)
  also have "\<dots> \<approx> A \<times> (UNIV::int set)"
  proof (rule eqpoll_Fpow)
    show "infinite (A \<times> (UNIV::int set))"
      using assms finite_cartesian_productD1 by fastforce
  qed
  also have "\<dots> \<approx> A"
    unfolding eqpoll_iff_card_of_ordIso
  proof -
    have "|A \<times> (UNIV::int set)| <=o |A|"
      by (simp add: assms card_of_Times_ordLeq_infinite flip: infinite_iff_card_of_countable)
    moreover have "|A| \<le>o |A \<times> (UNIV::int set)|"
      by simp
    ultimately have "|A| *c |(UNIV::int set)| =o |A|"
      by (simp add: cprod_def ordIso_iff_ordLeq)
    then show "|A \<times> (UNIV::int set)| =o |A|"
      by (metis Times_cprod ordIso_transitive)
  qed
  finally show "carrier (free_Abelian_group A) \<lesssim> A" .
  have "inj_on frag_of A"
    by (simp add: frag_of_eq inj_on_def)
  moreover have "frag_of ` A \<subseteq> carrier (free_Abelian_group A)"
    by (simp add: image_subsetI)
  ultimately show "A \<lesssim> carrier (free_Abelian_group A)"
    by (force simp: lepoll_def)
qed

proposition (in comm_group) eqpoll_homomorphisms_from_free_Abelian_group:
   "{f. f \<in> extensional (carrier(free_Abelian_group S)) \<and> f \<in> hom (free_Abelian_group S) G}
    \<approx> (S \<rightarrow>\<^sub>E carrier G)"  (is "?lhs \<approx> ?rhs")
  unfolding eqpoll_def bij_betw_def
proof (intro exI conjI)
  let ?f = "\<lambda>f. restrict (f \<circ> frag_of) S"
  show "inj_on ?f ?lhs"
  proof (clarsimp simp: inj_on_def)
    fix g h
    assume
      g: "g \<in> extensional (carrier (free_Abelian_group S))" "g \<in> hom (free_Abelian_group S) G"
      and h: "h \<in> extensional (carrier (free_Abelian_group S))" "h \<in> hom (free_Abelian_group S) G"
      and eq: "restrict (g \<circ> frag_of) S = restrict (h \<circ> frag_of) S"
    have 0: "0 \<in> carrier (free_Abelian_group S)"
      by simp
    interpret hom_g: group_hom "free_Abelian_group S" G g
      using g by (auto simp: group_hom_def group_hom_axioms_def is_group)
    interpret hom_h: group_hom "free_Abelian_group S" G h
      using h by (auto simp: group_hom_def group_hom_axioms_def is_group)
    have "Poly_Mapping.keys c \<subseteq> S \<Longrightarrow> Poly_Mapping.keys c \<subseteq> S \<and> g c = h c" for c
    proof (induction c rule: frag_induction)
      case zero
      show ?case
        using hom_g.hom_one hom_h.hom_one by auto
    next
      case (one x)
      then show ?case
        using eq by (simp add: fun_eq_iff) (metis comp_def)
    next
      case (diff a b)
      then show ?case
        using hom_g.hom_mult hom_h.hom_mult hom_g.hom_inv hom_h.hom_inv
        apply (auto simp: dest: subsetD [OF keys_diff])
        by (metis keys_minus uminus_add_conv_diff)
    qed
    then show "g = h"
      by (meson g h carrier_free_Abelian_group_iff extensionalityI)
  qed
  have "f \<in> (\<lambda>f. restrict (f \<circ> frag_of) S) `
            {f \<in> extensional (carrier (free_Abelian_group S)). f \<in> hom (free_Abelian_group S) G}"
    if f: "f \<in> S \<rightarrow>\<^sub>E carrier G"
    for f :: "'c \<Rightarrow> 'a"
  proof -
    obtain h where h: "h \<in> hom (free_Abelian_group S) G" "\<And>x. x \<in> S \<Longrightarrow> h(frag_of x) = f x"
    proof (rule free_Abelian_group_universal)
      show "f ` S \<subseteq> carrier G"
        using f by blast
    qed auto
    let ?h = "restrict h (carrier (free_Abelian_group S))"
    show ?thesis
    proof
      show "f = restrict (?h \<circ> frag_of) S"
        using f by (force simp: h)
      show "?h \<in> {f \<in> extensional (carrier (free_Abelian_group S)). f \<in> hom (free_Abelian_group S) G}"
        using h by (auto simp: hom_def dest!: subsetD [OF keys_add])
    qed
  qed
  then show "?f ` ?lhs = S \<rightarrow>\<^sub>E carrier G"
    by (auto simp: hom_def Ball_def Pi_def)
qed

lemma hom_frag_minus:
  assumes "h \<in> hom (free_Abelian_group S) (free_Abelian_group T)" "Poly_Mapping.keys a \<subseteq> S"
  shows "h (-a) = - (h a)"
proof -
  have "Poly_Mapping.keys (h a) \<subseteq> T"
    by (meson assms carrier_free_Abelian_group_iff hom_in_carrier)
  then show ?thesis
    by (metis (no_types) assms carrier_free_Abelian_group_iff group_free_Abelian_group group_hom.hom_inv group_hom_axioms_def group_hom_def inv_free_Abelian_group)
qed

lemma hom_frag_add:
  assumes "h \<in> hom (free_Abelian_group S) (free_Abelian_group T)" "Poly_Mapping.keys a \<subseteq> S" "Poly_Mapping.keys b \<subseteq> S"
  shows "h (a+b) = h a + h b"
proof -
  have "Poly_Mapping.keys (h a) \<subseteq> T"
    by (meson assms carrier_free_Abelian_group_iff hom_in_carrier)
  moreover
  have "Poly_Mapping.keys (h b) \<subseteq> T"
    by (meson assms carrier_free_Abelian_group_iff hom_in_carrier)
  ultimately show ?thesis
    using assms hom_mult by fastforce
qed

lemma hom_frag_diff:
  assumes "h \<in> hom (free_Abelian_group S) (free_Abelian_group T)" "Poly_Mapping.keys a \<subseteq> S" "Poly_Mapping.keys b \<subseteq> S"
  shows "h (a-b) = h a - h b"
  by (metis (no_types, lifting) assms diff_conv_add_uminus hom_frag_add hom_frag_minus keys_minus)

proposition isomorphic_free_Abelian_groups:
   "free_Abelian_group S \<cong> free_Abelian_group T \<longleftrightarrow> S \<approx> T"  (is "(?FS \<cong> ?FT) = ?rhs")
proof
  interpret S: group "?FS"
    by simp
  interpret T: group "?FT"
    by simp
  interpret G2: comm_group "integer_mod_group 2"
    by (rule abelian_integer_mod_group)
  let ?Two = "{0..<2::int}"
  have [simp]: "\<not> ?Two \<subseteq> {a}" for a
    by (simp add: subset_iff) presburger
  assume L: "?FS \<cong> ?FT"
  let ?HS = "{h \<in> extensional (carrier ?FS). h \<in> hom ?FS (integer_mod_group 2)}"
  let ?HT = "{h \<in> extensional (carrier ?FT). h \<in> hom ?FT (integer_mod_group 2)}"
  have "S \<rightarrow>\<^sub>E ?Two \<approx> ?HS"
    apply (rule eqpoll_sym)
    using G2.eqpoll_homomorphisms_from_free_Abelian_group by (simp add: carrier_integer_mod_group)
  also have "\<dots> \<approx> ?HT"
  proof -
    obtain f g where "group_isomorphisms ?FS ?FT f g"
      using L S.iso_iff_group_isomorphisms by (force simp: is_iso_def)
    then have f: "f \<in> hom ?FS ?FT"
      and g: "g \<in> hom ?FT ?FS"
      and gf: "\<forall>x \<in> carrier ?FS. g(f x) = x"
      and fg: "\<forall>y \<in> carrier ?FT. f(g y) = y"
      by (auto simp: group_isomorphisms_def)
    let ?f = "\<lambda>h. restrict (h \<circ> g) (carrier ?FT)"
    let ?g = "\<lambda>h. restrict (h \<circ> f) (carrier ?FS)"
    show ?thesis
    proof (rule lepoll_antisym)
      show "?HS \<lesssim> ?HT"
        unfolding lepoll_def
      proof (intro exI conjI)
        show "inj_on ?f ?HS"
          apply (rule inj_on_inverseI [where g = ?g])
          using hom_in_carrier [OF f]
          by (auto simp: gf fun_eq_iff carrier_integer_mod_group Ball_def Pi_def extensional_def)
        show "?f ` ?HS \<subseteq> ?HT"
        proof clarsimp
          fix h
          assume h: "h \<in> hom ?FS (integer_mod_group 2)"
          have "h \<circ> g \<in> hom ?FT (integer_mod_group 2)"
            by (rule hom_compose [OF g h])
          moreover have "restrict (h \<circ> g) (carrier ?FT) x = (h \<circ> g) x" if "x \<in> carrier ?FT" for x
            using g that by (simp add: hom_def)
          ultimately show "restrict (h \<circ> g) (carrier ?FT) \<in> hom ?FT (integer_mod_group 2)"
            using T.hom_restrict by fastforce
        qed
      qed
    next
      show "?HT \<lesssim> ?HS"
        unfolding lepoll_def
      proof (intro exI conjI)
        show "inj_on ?g ?HT"
          apply (rule inj_on_inverseI [where g = ?f])
          using hom_in_carrier [OF g]
          by (auto simp: fg fun_eq_iff carrier_integer_mod_group Ball_def Pi_def extensional_def)
        show "?g ` ?HT \<subseteq> ?HS"
        proof clarsimp
          fix k
          assume k: "k \<in> hom ?FT (integer_mod_group 2)"
          have "k \<circ> f \<in> hom ?FS (integer_mod_group 2)"
            by (rule hom_compose [OF f k])
          moreover have "restrict (k \<circ> f) (carrier ?FS) x = (k \<circ> f) x" if "x \<in> carrier ?FS" for x
            using f that by (simp add: hom_def)
          ultimately show "restrict (k \<circ> f) (carrier ?FS) \<in> hom ?FS (integer_mod_group 2)"
            using S.hom_restrict by fastforce
        qed
      qed
    qed
  qed
  also have "\<dots> \<approx> T \<rightarrow>\<^sub>E ?Two"
    using G2.eqpoll_homomorphisms_from_free_Abelian_group by (simp add: carrier_integer_mod_group)
  finally have *: "S \<rightarrow>\<^sub>E ?Two \<approx> T \<rightarrow>\<^sub>E ?Two" .
  then have "finite (S \<rightarrow>\<^sub>E ?Two) \<longleftrightarrow> finite (T \<rightarrow>\<^sub>E ?Two)"
    by (rule eqpoll_finite_iff)
  then have "finite S \<longleftrightarrow> finite T"
    by (auto simp: finite_funcset_iff)
  then consider "finite S" "finite T" | "~ finite S" "~ finite T"
    by blast
  then show ?rhs
  proof cases
    case 1
    with * have "2 ^ card S = (2::nat) ^ card T"
      by (simp add: card_PiE finite_PiE eqpoll_iff_card)
    then have "card S = card T"
      by auto
    then show ?thesis
      using eqpoll_iff_card 1 by blast
  next
    case 2
    have "carrier (free_Abelian_group S) \<approx> carrier (free_Abelian_group T)"
      using L by (simp add: iso_imp_eqpoll_carrier)
    then show ?thesis
      using 2 eqpoll_free_Abelian_group_infinite eqpoll_sym eqpoll_trans by metis
  qed
next
  assume ?rhs
  then obtain f g where f: "\<And>x. x \<in> S \<Longrightarrow> f x \<in> T \<and> g(f x) = x"
                    and g: "\<And>y. y \<in> T \<Longrightarrow> g y \<in> S \<and> f(g y) = y"
    using eqpoll_iff_bijections by metis
  interpret S: comm_group "?FS"
    by (simp add: abelian_free_Abelian_group)
  interpret T: comm_group "?FT"
    by (simp add: abelian_free_Abelian_group)
  have "(frag_of \<circ> f) ` S \<subseteq> carrier (free_Abelian_group T)"
    using f by auto
  then obtain h where h: "h \<in> hom (free_Abelian_group S) (free_Abelian_group T)"
    and h_frag: "\<And>x. x \<in> S \<Longrightarrow> h (frag_of x) = (frag_of \<circ> f) x"
    using T.free_Abelian_group_universal [of "frag_of \<circ> f" S] by blast
  interpret hhom: group_hom "free_Abelian_group S" "free_Abelian_group T" h
    by (simp add: h group_hom_axioms_def group_hom_def)
  have "(frag_of \<circ> g) ` T \<subseteq> carrier (free_Abelian_group S)"
    using g by auto
  then obtain k where k: "k \<in> hom (free_Abelian_group T) (free_Abelian_group S)"
    and k_frag: "\<And>x. x \<in> T \<Longrightarrow> k (frag_of x) = (frag_of \<circ> g) x"
    using S.free_Abelian_group_universal [of "frag_of \<circ> g" T] by blast
  interpret khom: group_hom "free_Abelian_group T" "free_Abelian_group S" k
    by (simp add: k group_hom_axioms_def group_hom_def)
  have kh: "Poly_Mapping.keys x \<subseteq> S \<Longrightarrow> Poly_Mapping.keys x \<subseteq> S \<and> k (h x) = x" for x
  proof (induction rule: frag_induction)
    case zero
    then show ?case
      apply auto
      by (metis group_free_Abelian_group h hom_one k one_free_Abelian_group)
  next
    case (one x)
    then show ?case
      by (auto simp: h_frag k_frag f)
  next
    case (diff a b)
    with keys_diff have "Poly_Mapping.keys (a - b) \<subseteq> S"
      by (metis Un_least order_trans)
    with diff hhom.hom_closed show ?case
      by (simp add: hom_frag_diff [OF h] hom_frag_diff [OF k])
  qed
  have hk: "Poly_Mapping.keys y \<subseteq> T \<Longrightarrow> Poly_Mapping.keys y \<subseteq> T \<and> h (k y) = y" for y
  proof (induction rule: frag_induction)
    case zero
    then show ?case
      apply auto
      by (metis group_free_Abelian_group h hom_one k one_free_Abelian_group)
  next
    case (one y)
    then show ?case
      by (auto simp: h_frag k_frag g)
  next
    case (diff a b)
    with keys_diff have "Poly_Mapping.keys (a - b) \<subseteq> T"
      by (metis Un_least order_trans)
    with diff khom.hom_closed show ?case
      by (simp add: hom_frag_diff [OF h] hom_frag_diff [OF k])
  qed
  have "h \<in> iso ?FS ?FT"
    unfolding iso_def bij_betw_iff_bijections mem_Collect_eq
  proof (intro conjI exI ballI h)
    fix x
    assume x: "x \<in> carrier (free_Abelian_group S)"
    show "h x \<in> carrier (free_Abelian_group T)"
      by (meson x h hom_in_carrier)
    show "k (h x) = x"
      using x by (simp add: kh)
  next
    fix y
    assume y: "y \<in> carrier (free_Abelian_group T)"
    show "k y \<in> carrier (free_Abelian_group S)"
      by (meson y k hom_in_carrier)
    show "h (k y) = y"
      using y by (simp add: hk)
  qed
  then show "?FS \<cong> ?FT"
    by (auto simp: is_iso_def)
qed

lemma isomorphic_group_integer_free_Abelian_group_singleton:
  "integer_group \<cong> free_Abelian_group {x}"
proof -
  have "(\<lambda>n. frag_cmul n (frag_of x)) \<in> iso integer_group (free_Abelian_group {x})"
  proof (rule isoI [OF homI])
    show "bij_betw (\<lambda>n. frag_cmul n (frag_of x)) (carrier integer_group) (carrier (free_Abelian_group {x}))"
      apply (rule bij_betwI [where g = "\<lambda>y. Poly_Mapping.lookup y x"])
      by (auto simp: integer_group_def in_keys_iff intro!: poly_mapping_eqI)
  qed (auto simp: frag_cmul_distrib)
  then show ?thesis
    unfolding is_iso_def
    by blast
qed

lemma group_hom_free_Abelian_groups_id:
  "id \<in> hom (free_Abelian_group S) (free_Abelian_group T) \<longleftrightarrow> S \<subseteq> T"
proof -
  have "x \<in> T" if ST: "\<And>c:: 'a \<Rightarrow>\<^sub>0 int. Poly_Mapping.keys c \<subseteq> S \<longrightarrow> Poly_Mapping.keys c \<subseteq> T" and "x \<in> S" for x
    using ST [of "frag_of x"] \<open>x \<in> S\<close> by simp
  then show ?thesis
    by (auto simp: hom_def free_Abelian_group_def Pi_def)
qed

proposition iso_free_Abelian_group_sum:
  assumes "pairwise (\<lambda>i j. disjnt (S i) (S j)) I"
  shows "(\<lambda>f. sum' f I) \<in> iso (sum_group I (\<lambda>i. free_Abelian_group(S i))) (free_Abelian_group (\<Union>(S ` I)))"
    (is "?h \<in> iso ?G ?H")
proof (rule isoI)
  show hom: "?h \<in> hom ?G ?H"
  proof (rule homI)
    show "?h c \<in> carrier ?H" if "c \<in> carrier ?G" for c
      using that
      apply (simp add: sum.G_def carrier_sum_group)
      apply (rule order_trans [OF keys_sum])
      apply (auto simp: free_Abelian_group_def)
      done
    show "?h (x \<otimes>\<^bsub>?G\<^esub> y) = ?h x \<otimes>\<^bsub>?H\<^esub> ?h y"
      if "x \<in> carrier ?G" "y \<in> carrier ?G"  for x y
      using that by (simp add: sum.finite_Collect_op carrier_sum_group sum.distrib')
  qed
  interpret GH: group_hom "?G" "?H" "?h"
    using hom by (simp add: group_hom_def group_hom_axioms_def)
  show "bij_betw ?h (carrier ?G) (carrier ?H)"
    unfolding bij_betw_def
  proof (intro conjI subset_antisym)
    show "?h ` carrier ?G \<subseteq> carrier ?H"
      apply (clarsimp simp: sum.G_def carrier_sum_group simp del: carrier_free_Abelian_group_iff)
      by (force simp: PiE_def Pi_iff intro!: sum_closed_free_Abelian_group)
    have *: "poly_mapping.lookup (Abs_poly_mapping (\<lambda>j. if j \<in> S i then poly_mapping.lookup x j else 0)) k
           = (if k \<in> S i then poly_mapping.lookup x k else 0)" if "i \<in> I" for i k and x :: "'b \<Rightarrow>\<^sub>0 int"
      using that by (auto simp: conj_commute cong: conj_cong)
    have eq: "Abs_poly_mapping (\<lambda>j. if j \<in> S i then poly_mapping.lookup x j else 0) = 0
     \<longleftrightarrow> (\<forall>c \<in> S i. poly_mapping.lookup x c = 0)" if "i \<in> I" for i and x :: "'b \<Rightarrow>\<^sub>0 int"
      apply (auto simp: poly_mapping_eq_iff fun_eq_iff)
      apply (simp add: * Abs_poly_mapping_inverse conj_commute cong: conj_cong)
      apply (force dest!: spec split: if_split_asm)
      done
    have "x \<in> ?h ` {x \<in> \<Pi>\<^sub>E i\<in>I. {c. Poly_Mapping.keys c \<subseteq> S i}. finite {i \<in> I. x i \<noteq> 0}}"
      if x: "Poly_Mapping.keys x \<subseteq> \<Union> (S ` I)" for x :: "'b \<Rightarrow>\<^sub>0 int"
    proof -
      let ?f = "(\<lambda>i c. if c \<in> S i then Poly_Mapping.lookup x c else 0)"
      define J where "J \<equiv> {i \<in> I. \<exists>c\<in>S i. c \<in> Poly_Mapping.keys x}"
      have "J \<subseteq> (\<lambda>c. THE i. i \<in> I \<and> c \<in> S i) ` Poly_Mapping.keys x"
      proof (clarsimp simp: J_def)
        show "i \<in> (\<lambda>c. THE i. i \<in> I \<and> c \<in> S i) ` Poly_Mapping.keys x"
          if "i \<in> I" "c \<in> S i" "c \<in> Poly_Mapping.keys x" for i c
        proof
          show "i = (THE i. i \<in> I \<and> c \<in> S i)"
            using assms that by (auto simp: pairwise_def disjnt_def intro: the_equality [symmetric])
        qed (simp add: that)
      qed
      then have fin: "finite J"
        using finite_subset finite_keys by blast
      have [simp]: "Poly_Mapping.keys (Abs_poly_mapping (?f i)) = {k. ?f i k \<noteq> 0}" if "i \<in> I" for i
        by (simp add: eq_onp_def keys.abs_eq conj_commute cong: conj_cong)
      have [simp]: "Poly_Mapping.lookup (Abs_poly_mapping (?f i)) c = ?f i c" if "i \<in> I" for i c
        by (auto simp: Abs_poly_mapping_inverse conj_commute cong: conj_cong)
      show ?thesis
      proof
        have "poly_mapping.lookup x c = poly_mapping.lookup (?h (\<lambda>i\<in>I. Abs_poly_mapping (?f i))) c"
          for c
        proof (cases "c \<in> Poly_Mapping.keys x")
          case True
          then obtain i where "i \<in> I" "c \<in> S i" "?f i c \<noteq> 0"
            using x by (auto simp: in_keys_iff)
          then have 1: "poly_mapping.lookup (sum' (\<lambda>j. Abs_poly_mapping (?f j)) (I - {i})) c = 0"
            using assms
            apply (simp add: sum.G_def Poly_Mapping.lookup_sum pairwise_def disjnt_def)
            apply (force simp: eq split: if_split_asm intro!: comm_monoid_add_class.sum.neutral)
            done
          have 2: "poly_mapping.lookup x c = poly_mapping.lookup (Abs_poly_mapping (?f i)) c"
            by (auto simp: \<open>c \<in> S i\<close> Abs_poly_mapping_inverse conj_commute cong: conj_cong)
          have "finite {i \<in> I. Abs_poly_mapping (?f i) \<noteq> 0}"
            by (rule finite_subset [OF _ fin]) (use \<open>i \<in> I\<close> J_def eq in \<open>auto simp: in_keys_iff\<close>)
          with \<open>i \<in> I\<close> have "?h (\<lambda>j\<in>I. Abs_poly_mapping (?f j)) = Abs_poly_mapping (?f i) + sum' (\<lambda>j. Abs_poly_mapping (?f j)) (I - {i})"
            by (simp add: sum_diff1')
          then show ?thesis
            by (simp add: 1 2 Poly_Mapping.lookup_add)
        next
          case False
          then have "poly_mapping.lookup x c = 0"
            using keys.rep_eq by force
          then show ?thesis
            unfolding sum.G_def by (simp add: lookup_sum * comm_monoid_add_class.sum.neutral)
        qed
        then show "x = ?h (\<lambda>i\<in>I. Abs_poly_mapping (?f i))"
          by (rule poly_mapping_eqI)
        have "(\<lambda>i. Abs_poly_mapping (?f i)) \<in> (\<Pi> i\<in>I. {c. Poly_Mapping.keys c \<subseteq> S i})"
          by (auto simp: PiE_def Pi_def in_keys_iff)
        then show "(\<lambda>i\<in>I. Abs_poly_mapping (?f i))
                 \<in> {x \<in> \<Pi>\<^sub>E i\<in>I. {c. Poly_Mapping.keys c \<subseteq> S i}. finite {i \<in> I. x i \<noteq> 0}}"
          using fin unfolding J_def by (force simp add: eq in_keys_iff cong: conj_cong)
      qed
    qed
    then show "carrier ?H \<subseteq> ?h ` carrier ?G"
      by (simp add: carrier_sum_group) (auto simp: free_Abelian_group_def)
    show "inj_on ?h (carrier (sum_group I (\<lambda>i. free_Abelian_group (S i))))"
      unfolding GH.inj_on_one_iff
    proof clarify
      fix x
      assume "x \<in> carrier ?G" "?h x = \<one>\<^bsub>?H\<^esub>"
      then have eq0: "sum' x I = 0"
        and xs: "\<And>i. i \<in> I \<Longrightarrow> Poly_Mapping.keys (x i) \<subseteq> S i" and xext: "x \<in> extensional I"
        and fin: "finite {i \<in> I. x i \<noteq> 0}"
        by (simp_all add: carrier_sum_group PiE_def Pi_def)
      have "x i = 0" if "i \<in> I" for i
      proof -
        have "sum' x (insert i (I - {i})) = 0"
          using eq0 that by (simp add: insert_absorb)
        moreover have "Poly_Mapping.keys (sum' x (I - {i})) = {}"
        proof -
          have "x i = - sum' x (I - {i})"
            by (metis (mono_tags, lifting) diff_zero eq0 fin sum_diff1' minus_diff_eq that)
          then have "Poly_Mapping.keys (x i) = Poly_Mapping.keys (sum' x (I - {i}))"
            by simp
          then have "Poly_Mapping.keys (sum' x (I - {i})) \<subseteq> S i"
            using that xs by metis
          moreover
          have "Poly_Mapping.keys (sum' x (I - {i})) \<subseteq> (\<Union>j \<in> I - {i}. S j)"
          proof -
            have "Poly_Mapping.keys (sum' x (I - {i})) \<subseteq> (\<Union>i\<in>{j \<in> I. j \<noteq> i \<and> x j \<noteq> 0}. Poly_Mapping.keys (x i))"
              using keys_sum [of x "{j \<in> I. j \<noteq> i \<and> x j \<noteq> 0}"] by (simp add: sum.G_def)
            also have "\<dots> \<subseteq> \<Union> (S ` (I - {i}))"
              using xs by force
            finally show ?thesis .
          qed
          moreover have "A = {}" if "A \<subseteq> S i" "A \<subseteq> \<Union> (S ` (I - {i}))" for A
            using assms that \<open>i \<in> I\<close>
            by (force simp: pairwise_def disjnt_def image_def subset_iff)
          ultimately show ?thesis
            by metis
        qed
        then have [simp]: "sum' x (I - {i}) = 0"
          by (auto simp: sum.G_def)
        have "sum' x (insert i (I - {i})) = x i"
          by (subst sum.insert' [OF finite_subset [OF _ fin]]) auto
        ultimately show ?thesis
          by metis
      qed
      with xext [unfolded extensional_def]
      show "x = \<one>\<^bsub>sum_group I (\<lambda>i. free_Abelian_group (S i))\<^esub>"
        by (force simp: free_Abelian_group_def)
    qed
  qed
qed

lemma isomorphic_free_Abelian_group_Union:
  "pairwise disjnt I \<Longrightarrow> free_Abelian_group(\<Union> I) \<cong> sum_group I free_Abelian_group"
  using iso_free_Abelian_group_sum [of "\<lambda>X. X" I]
  by (metis SUP_identity_eq empty_iff group.iso_sym group_free_Abelian_group is_iso_def sum_group)

lemma isomorphic_sum_integer_group:
   "sum_group I (\<lambda>i. integer_group) \<cong> free_Abelian_group I"
proof -
  have "sum_group I (\<lambda>i. integer_group) \<cong> sum_group I (\<lambda>i. free_Abelian_group {i})"
    by (rule iso_sum_groupI) (auto simp: isomorphic_group_integer_free_Abelian_group_singleton)
  also have "\<dots> \<cong> free_Abelian_group I"
    using iso_free_Abelian_group_sum [of "\<lambda>x. {x}" I] by (auto simp: is_iso_def)
  finally show ?thesis .
qed

end


subsection \<open>Example: A Reference Monitor for a Simple Language\<close>

theory Simple_Lang
imports Main
begin

text \<open>In this example we will use the above theorem to prove the security of a very simplistic
programming language incorporating a reference monitor.\<close>

subsubsection \<open>Language\<close>

text \<open>As actions, we only consider assignments of the form @{text "n :=\<^bsub>d\<^esub> \<tau>"}, where @{text n}
is a variable name, @{text d} is a domain, and @{text \<tau>} is an expression. We only consider basic
expressions that are built using constants, variable references, subtraction, and addition:\<close>

datatype 'var expr =
  Var 'var
| Const integer
| Plus "('var expr)" "('var expr)"
| Minus "('var expr)" "('var expr)"

text \<open>For example, the term @{text "Minus (Plus (Var Y) (Var Z)) (Const 5)"} is a syntactic
representation of an expression which would more commonly be written as @{text "(Y + Z) - 5"}.

The state of the automaton is simply a mapping from variable names to integers.\<close>

type_synonym 'var state = "'var \<Rightarrow> integer"

text \<open>The function @{text \<E>} evaluates an expression in a given state.\<close>

fun \<E> :: "'var expr \<Rightarrow> 'var state \<Rightarrow> integer" where
  "\<E> (Var v) s = s v"
| "\<E> (Const c) s = c"
| "\<E> (Plus e1 e2) s = \<E> e1 s + \<E> e2 s"
| "\<E> (Minus e1 e2) s = \<E> e1 s - \<E> e2 s"

text \<open>The function @{text Vars} returns the set of variables appearing in an expression.\<close>

fun Vars :: "'var expr \<Rightarrow> 'var set" where
  "Vars (Var v) = {v}"
| "Vars (Const c) = {}"
| "Vars (Plus e1 e2) = Vars e1 \<union> Vars e2"
| "Vars (Minus e1 e2) = Vars e1 \<union> Vars e2"

text \<open>Actions are assignments of expressions to variables, annotated with a domain.\<close>

datatype ('var, 'dom) cmd =
  Assign 'var (dom: 'dom) "'var expr" ("_ :=\<^bsub>_\<^esub> _")

lemma "dom (v :=\<^bsub>d\<^esub> e) = d"
by auto

text \<open>The effect of an assignment @{text "v :=\<^bsub>d\<^esub> e"} in a state @{text s} is that the value of
@{text v} is updated to the evaluation of @{text "e"} in @{text s}.\<close>

fun execute :: "'var state \<Rightarrow> ('var, 'dom) cmd \<Rightarrow> 'var state" where
  "execute s (v :=\<^bsub>d\<^esub> e) = s(v := \<E> e s)"

text \<open>The following coincidence lemma will be useful: If two states coincide on the variables
appearing in an expression, then the result of evaluating the expression in both states is equal.\<close>

lemma coincidence:
  assumes "\<forall>v \<in> Vars e. s v = t v"
  shows "\<E> e s = \<E> e t"
using assms
by (induction e) auto

end


(* Author:     Andreas Lochbihler, ETH Zurich
   Author:     Joshua Schneider, ETH Zurich
*)

subsection \<open>Pointwise arithmetic on streams\<close>

theory Stream_Algebra
imports Applicative_Stream
begin

instantiation stream :: (zero) zero begin
definition [applicative_unfold]: "0 = sconst 0"
instance ..
end

instantiation stream :: (one) one begin
definition [applicative_unfold]: "1 = sconst 1"
instance ..
end

instantiation stream :: (plus) plus begin
context includes applicative_syntax begin
definition [applicative_unfold]: "x + y = pure (+) \<diamondop> x \<diamondop> (y :: 'a stream)"
end
instance ..
end

instantiation stream :: (minus) minus begin
context includes applicative_syntax begin
definition [applicative_unfold]: "x - y = pure (-) \<diamondop> x \<diamondop> (y :: 'a stream)"
end
instance ..
end

instantiation stream :: (uminus) uminus begin
context includes applicative_syntax begin
definition [applicative_unfold stream]: "uminus = ((\<diamondop>) (pure uminus) :: 'a stream \<Rightarrow> 'a stream)"
end
instance ..
end

instantiation stream :: (times) times begin
context includes applicative_syntax begin
definition [applicative_unfold]: "x * y = pure (*) \<diamondop> x \<diamondop> (y :: 'a stream)"
end
instance ..
end

instance stream :: (Rings.dvd) Rings.dvd ..

instantiation stream :: (modulo) modulo begin
context includes applicative_syntax begin
definition [applicative_unfold]: "x div y = pure (div) \<diamondop> x \<diamondop> (y :: 'a stream)"
definition [applicative_unfold]: "x mod y = pure (mod) \<diamondop> x \<diamondop> (y :: 'a stream)"
end
instance ..
end

instance stream :: (semigroup_add) semigroup_add
using add.assoc by intro_classes applicative_lifting

instance stream :: (ab_semigroup_add) ab_semigroup_add
using add.commute by intro_classes applicative_lifting

instance stream :: (semigroup_mult) semigroup_mult
using mult.assoc by intro_classes applicative_lifting

instance stream :: (ab_semigroup_mult) ab_semigroup_mult
using mult.commute by intro_classes applicative_lifting

instance stream :: (monoid_add) monoid_add
by intro_classes (applicative_lifting, simp)+

instance stream :: (comm_monoid_add) comm_monoid_add
by intro_classes (applicative_lifting, simp)

instance stream :: (comm_monoid_diff) comm_monoid_diff
by intro_classes (applicative_lifting, simp add: diff_diff_add)+

instance stream :: (monoid_mult) monoid_mult
by intro_classes (applicative_lifting, simp)+

instance stream :: (comm_monoid_mult) comm_monoid_mult
by intro_classes (applicative_lifting, simp)

(*
  Lifted properties which are more complex than plain equations are not handled by the
  applicative lifting tool.
*)

lemma plus_stream_shd: "shd (x + y) = shd x + shd y"
unfolding plus_stream_def by simp

lemma plus_stream_stl: "stl (x + y) = stl x + stl y"
unfolding plus_stream_def by simp

instance stream :: (cancel_semigroup_add) cancel_semigroup_add
proof
  fix a b c :: "'a stream"
  assume "a + b = a + c"
  thus "b = c" proof (coinduction arbitrary: a b c)
    case (Eq_stream a b c)
    hence "shd (a + b) = shd (a + c)" "stl (a + b) = stl (a + c)" by simp_all
    thus ?case by (auto simp add: plus_stream_shd plus_stream_stl)
  qed
next
  fix a b c :: "'a stream"
  assume "b + a = c + a"
  thus "b = c" proof (coinduction arbitrary: a b c)
    case (Eq_stream a b c)
    hence "shd (b + a) = shd (c + a)" "stl (b + a) = stl (c + a)" by simp_all
    thus ?case by (auto simp add: plus_stream_shd plus_stream_stl)
  qed
qed

instance stream :: (cancel_ab_semigroup_add) cancel_ab_semigroup_add
by intro_classes (applicative_lifting, simp add: diff_diff_eq)+

instance stream :: (cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance stream :: (group_add) group_add
by intro_classes (applicative_lifting, simp)+

instance stream :: (ab_group_add) ab_group_add
by intro_classes simp_all

instance stream :: (semiring) semiring
by intro_classes (applicative_lifting, simp add: ring_distribs)+

instance stream :: (mult_zero) mult_zero
by intro_classes (applicative_lifting, simp)+

instance stream :: (semiring_0) semiring_0 ..

instance stream :: (semiring_0_cancel) semiring_0_cancel ..

instance stream :: (comm_semiring) comm_semiring
by intro_classes(rule distrib_right)

instance stream :: (comm_semiring_0) comm_semiring_0 ..

instance stream :: (comm_semiring_0_cancel) comm_semiring_0_cancel ..

lemma pure_stream_inject [simp]: "sconst x = sconst y \<longleftrightarrow> x = y"
proof
  assume "sconst x = sconst y"
  hence "shd (sconst x) = shd (sconst y)" by simp
  thus "x = y" by simp
qed auto

instance stream :: (zero_neq_one) zero_neq_one
by intro_classes (applicative_unfold stream)

instance stream :: (semiring_1) semiring_1 ..

instance stream :: (comm_semiring_1) comm_semiring_1 ..

instance stream :: (semiring_1_cancel) semiring_1_cancel ..

instance stream :: (comm_semiring_1_cancel) comm_semiring_1_cancel
by(intro_classes; applicative_lifting, rule right_diff_distrib')

instance stream :: (ring) ring ..

instance stream :: (comm_ring) comm_ring ..

instance stream :: (ring_1) ring_1 ..

instance stream :: (comm_ring_1) comm_ring_1 ..

instance stream :: (numeral) numeral ..

instance stream :: (neg_numeral) neg_numeral ..

instance stream :: (semiring_numeral) semiring_numeral ..

lemma of_nat_stream [applicative_unfold]: "of_nat n = sconst (of_nat n)"
proof (induction n)
  case 0 show ?case by (simp add: zero_stream_def del: id_apply)
next
  case (Suc n)
  have "1 + pure (of_nat n) = pure (1 + of_nat n)" by applicative_nf rule
  with Suc.IH show ?case by (simp del: id_apply)
qed

instance stream :: (semiring_char_0) semiring_char_0
by intro_classes (simp add: inj_on_def of_nat_stream)

lemma pure_stream_numeral [applicative_unfold]: "numeral n = pure (numeral n)"
by(induction n)(simp_all only: numeral.simps one_stream_def plus_stream_def ap_stream_homo)

instance stream :: (ring_char_0) ring_char_0 ..

end


(*  Title:      HOL/HOLCF/FOCUS/Fstreams.thy
    Author:     Borislav Gajanovic

FOCUS flat streams (with lifted elements).

TODO: integrate this with Fstream.
*)

theory Fstreams
imports "~~/src/HOL/HOLCF/Library/Stream"
begin

default_sort type

type_synonym 'a fstream = "('a lift) stream"

definition
  fsingleton    :: "'a => 'a fstream"  ("<_>" [1000] 999) where
  fsingleton_def2: "fsingleton = (%a. Def a && UU)"

definition
  fsfilter      :: "'a set \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
  "fsfilter A = sfilter\<cdot>(flift2 (\<lambda>x. x\<in>A))"

definition
  fsmap         :: "('a => 'b) => 'a fstream -> 'b fstream" where
  "fsmap f = smap$(flift2 f)"

definition
  jth           :: "nat => 'a fstream => 'a" where
  "jth = (%n s. if enat n < #s then THE a. i_th n s = Def a else undefined)"

definition
  first         :: "'a fstream => 'a" where
  "first = (%s. jth 0 s)"

definition
  last          :: "'a fstream => 'a" where
  "last = (%s. case #s of enat n => (if n~=0 then jth (THE k. Suc k = n) s else undefined))"

abbreviation
  emptystream :: "'a fstream"  ("<>") where
  "<> == \<bottom>"

abbreviation
  fsfilter' :: "'a set \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"       ("(_'(C')_)" [64,63] 63) where
  "A(C)s == fsfilter A\<cdot>s"

notation (xsymbols)
  fsfilter'  ("(_\<copyright>_)" [64,63] 63)

lemma ft_fsingleton[simp]: "ft$(<a>) = Def a"
by (simp add: fsingleton_def2)

lemma slen_fsingleton[simp]: "#(<a>) = enat 1"
by (simp add: fsingleton_def2 enat_defs)

lemma slen_fstreams[simp]: "#(<a> ooo s) = eSuc (#s)"
by (simp add: fsingleton_def2)

lemma slen_fstreams2[simp]: "#(s ooo <a>) = eSuc (#s)"
apply (cases "#s")
apply (auto simp add: eSuc_enat)
apply (insert slen_sconc [of _ s "Suc 0" "<a>"], auto)
apply (simp add: sconc_def)
done

lemma j_th_0_fsingleton[simp]:"jth 0 (<a>) = a"
apply (simp add: fsingleton_def2 jth_def)
apply (simp add: i_th_def enat_0)
done

lemma jth_0[simp]: "jth 0 (<a> ooo s) = a"
apply (simp add: fsingleton_def2 jth_def)
apply (simp add: i_th_def enat_0)
done

lemma first_sconc[simp]: "first (<a> ooo s) = a"
by (simp add: first_def)

lemma first_fsingleton[simp]: "first (<a>) = a"
by (simp add: first_def)

lemma jth_n[simp]: "enat n = #s ==> jth n (s ooo <a>) = a"
apply (simp add: jth_def, auto)
apply (simp add: i_th_def rt_sconc1)
apply (simp add: enat_defs split: enat.splits)
done

lemma last_sconc[simp]: "enat n = #s ==> last (s ooo <a>) = a"
apply (simp add: last_def)
apply (simp add: enat_defs split:enat.splits)
apply (drule sym, auto)
done

lemma last_fsingleton[simp]: "last (<a>) = a"
by (simp add: last_def)

lemma first_UU[simp]: "first UU = undefined"
by (simp add: first_def jth_def)

lemma last_UU[simp]:"last UU = undefined"
by (simp add: last_def jth_def enat_defs)

lemma last_infinite[simp]:"#s = \<infinity> ==> last s = undefined"
by (simp add: last_def)

lemma jth_slen_lemma1:"n <= k & enat n = #s ==> jth k s = undefined"
by (simp add: jth_def enat_defs split:enat.splits, auto)

lemma jth_UU[simp]:"jth n UU = undefined"
by (simp add: jth_def)

lemma ext_last:"[|s ~= UU; enat (Suc n) = #s|] ==> (stream_take n$s) ooo <(last s)> = s"
apply (simp add: last_def)
apply (case_tac "#s", auto)
apply (simp add: fsingleton_def2)
apply (subgoal_tac "Def (jth n s) = i_th n s")
apply (auto simp add: i_th_last)
apply (drule slen_take_lemma1, auto)
apply (simp add: jth_def)
apply (case_tac "i_th n s = UU")
apply auto
apply (simp add: i_th_def)
apply (case_tac "i_rt n s = UU", auto)
apply (drule i_rt_slen [THEN iffD1])
apply (drule slen_take_eq_rev [rule_format, THEN iffD2],auto)
apply (drule not_Undef_is_Def [THEN iffD1], auto)
done

lemma fsingleton_lemma1[simp]: "(<a> = <b>) = (a=b)"
by (simp add: fsingleton_def2)

lemma fsingleton_lemma2[simp]: "<a> ~= <>"
by (simp add: fsingleton_def2)

lemma fsingleton_sconc:"<a> ooo s = Def a && s"
by (simp add: fsingleton_def2)

lemma fstreams_ind:
  "[| adm P; P <>; !!a s. P s ==> P (<a> ooo s) |] ==> P x"
apply (simp add: fsingleton_def2)
apply (rule stream.induct, auto)
apply (drule not_Undef_is_Def [THEN iffD1], auto)
done

lemma fstreams_ind2:
  "[| adm P; P <>; !!a. P (<a>); !!a b s. P s ==> P (<a> ooo <b> ooo s) |] ==> P x"
apply (simp add: fsingleton_def2)
apply (rule stream_ind2, auto)
apply (drule not_Undef_is_Def [THEN iffD1], auto)+
done

lemma fstreams_take_Suc[simp]: "stream_take (Suc n)$(<a> ooo s) = <a> ooo stream_take n$s"
by (simp add: fsingleton_def2)

lemma fstreams_not_empty[simp]: "<a> ooo s ~= <>"
by (simp add: fsingleton_def2)

lemma fstreams_not_empty2[simp]: "s ooo <a> ~= <>"
by (case_tac "s=UU", auto)

lemma fstreams_exhaust: "x = UU | (EX a s. x = <a> ooo s)"
apply (simp add: fsingleton_def2, auto)
apply (erule contrapos_pp, auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (drule not_Undef_is_Def [THEN iffD1], auto)
done

lemma fstreams_cases: "[| x = UU ==> P; !!a y. x = <a> ooo y ==> P |] ==> P"
by (insert fstreams_exhaust [of x], auto)

lemma fstreams_exhaust_eq: "(x ~= UU) = (? a y. x = <a> ooo y)"
apply (simp add: fsingleton_def2, auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (drule not_Undef_is_Def [THEN iffD1], auto)
done

lemma fstreams_inject: "(<a> ooo s = <b> ooo t) = (a=b & s=t)"
by (simp add: fsingleton_def2)

lemma fstreams_prefix: "<a> ooo s << t ==> EX tt. t = <a> ooo tt &  s << tt"
apply (simp add: fsingleton_def2)
apply (insert stream_prefix [of "Def a" s t], auto)
done

lemma fstreams_prefix': "x << <a> ooo z = (x = <> |  (EX y. x = <a> ooo y &  y << z))"
apply (auto, case_tac "x=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (simp add: fsingleton_def2, auto)
apply (drule ax_flat, simp)
apply (erule sconc_mono)
done

lemma ft_fstreams[simp]: "ft$(<a> ooo s) = Def a"
by (simp add: fsingleton_def2)

lemma rt_fstreams[simp]: "rt$(<a> ooo s) = s"
by (simp add: fsingleton_def2)

lemma ft_eq[simp]: "(ft$s = Def a) = (EX t. s = <a> ooo t)"
apply (cases s, auto)
apply (auto simp add: fsingleton_def2)
done

lemma surjective_fstreams: "(<d> ooo y = x) = (ft$x = Def d & rt$x = y)"
by auto

lemma fstreams_mono: "<a> ooo b << <a> ooo c ==> b << c"
by (simp add: fsingleton_def2)

lemma fsmap_UU[simp]: "fsmap f$UU = UU"
by (simp add: fsmap_def)

lemma fsmap_fsingleton_sconc: "fsmap f$(<x> ooo xs) = <(f x)> ooo (fsmap f$xs)"
by (simp add: fsmap_def fsingleton_def2 flift2_def)

lemma fsmap_fsingleton[simp]: "fsmap f$(<x>) = <(f x)>"
by (simp add: fsmap_def fsingleton_def2 flift2_def)

lemma fstreams_chain_lemma[rule_format]:
  "ALL s x y. stream_take n$(s::'a fstream) << x & x << y & y << s & x ~= y --> stream_take (Suc n)$s << y"
apply (induct_tac n, auto)
apply (case_tac "s=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (case_tac "y=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (simp add: flat_below_iff)
apply (case_tac "s=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (erule_tac x="ya" in allE)
apply (drule stream_prefix, auto)
apply (case_tac "y=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
apply auto
apply (simp add: flat_below_iff)
apply (erule_tac x="tt" in allE)
apply (erule_tac x="yb" in allE, auto)
apply (simp add: flat_below_iff)
apply (simp add: flat_below_iff)
done

lemma fstreams_lub_lemma1: "[| chain Y; (LUB i. Y i) = <a> ooo s |] ==> EX j t. Y j = <a> ooo t"
apply (subgoal_tac "(LUB i. Y i) ~= UU")
apply (frule lub_eq_bottom_iff, auto)
apply (drule_tac x="i" in is_ub_thelub, auto)
apply (drule fstreams_prefix' [THEN iffD1], auto)
done

lemma fstreams_lub1:
 "[| chain Y; (LUB i. Y i) = <a> ooo s |]
     ==> (EX j t. Y j = <a> ooo t) & (EX X. chain X & (ALL i. EX j. <a> ooo X i << Y j) & (LUB i. X i) = s)"
apply (auto simp add: fstreams_lub_lemma1)
apply (rule_tac x="%n. stream_take n$s" in exI, auto)
apply (induct_tac i, auto)
apply (drule fstreams_lub_lemma1, auto)
apply (rule_tac x="j" in exI, auto)
apply (case_tac "max_in_chain j Y")
apply (frule lub_finch1 [THEN lub_eqI], auto)
apply (rule_tac x="j" in exI)
apply (erule subst) back back
apply (simp add: below_prod_def sconc_mono)
apply (simp add: max_in_chain_def, auto)
apply (rule_tac x="ja" in exI)
apply (subgoal_tac "Y j << Y ja")
apply (drule fstreams_prefix, auto)+
apply (rule sconc_mono)
apply (rule fstreams_chain_lemma, auto)
apply (subgoal_tac "Y ja << (LUB i. (Y i))", clarsimp)
apply (drule fstreams_mono, simp)
apply (rule is_ub_thelub, simp)
apply (blast intro: chain_mono)
by (rule stream_reach2)

lemma lub_Pair_not_UU_lemma:
  "[| chain Y; (LUB i. Y i) = ((a::'a::flat), b); a ~= UU; b ~= UU |]
      ==> EX j c d. Y j = (c, d) & c ~= UU & d ~= UU"
apply (frule lub_prod, clarsimp)
apply (clarsimp simp add: lub_eq_bottom_iff [where Y="\<lambda>i. fst (Y i)"])
apply (case_tac "Y i", clarsimp)
apply (case_tac "max_in_chain i Y")
apply (drule maxinch_is_thelub, auto)
apply (rule_tac x="i" in exI, auto)
apply (simp add: max_in_chain_def, auto)
apply (subgoal_tac "Y i << Y j",auto)
apply (simp add: below_prod_def, clarsimp)
apply (drule ax_flat, auto)
apply (case_tac "snd (Y j) = UU",auto)
apply (case_tac "Y j", auto)
apply (rule_tac x="j" in exI)
apply (case_tac "Y j",auto)
apply (drule chain_mono, auto)
done

lemma fstreams_lub_lemma2:
  "[| chain Y; (LUB i. Y i) = (a, <m> ooo ms); (a::'a::flat) ~= UU |] ==> EX j t. Y j = (a, <m> ooo t)"
apply (frule lub_Pair_not_UU_lemma, auto)
apply (drule_tac x="j" in is_ub_thelub, auto)
apply (drule ax_flat, clarsimp)
apply (drule fstreams_prefix' [THEN iffD1], auto)
done

lemma fstreams_lub2:
  "[| chain Y; (LUB i. Y i) = (a, <m> ooo ms); (a::'a::flat) ~= UU |]
      ==> (EX j t. Y j = (a, <m> ooo t)) & (EX X. chain X & (ALL i. EX j. (a, <m> ooo X i) << Y j) & (LUB i. X i) = ms)"
apply (auto simp add: fstreams_lub_lemma2)
apply (rule_tac x="%n. stream_take n$ms" in exI, auto)
apply (induct_tac i, auto)
apply (drule fstreams_lub_lemma2, auto)
apply (rule_tac x="j" in exI, auto)
apply (case_tac "max_in_chain j Y")
apply (frule lub_finch1 [THEN lub_eqI], auto)
apply (rule_tac x="j" in exI)
apply (erule subst) back back
apply (simp add: sconc_mono)
apply (simp add: max_in_chain_def, auto)
apply (rule_tac x="ja" in exI)
apply (subgoal_tac "Y j << Y ja")
apply (simp add: below_prod_def, auto)
apply (drule below_trans)
apply (simp add: ax_flat, auto)
apply (drule fstreams_prefix, auto)+
apply (rule sconc_mono)
apply (subgoal_tac "tt ~= tta" "tta << ms")
apply (blast intro: fstreams_chain_lemma)
apply (frule lub_prod, auto)
apply (subgoal_tac "snd (Y ja) << (LUB i. snd (Y i))", clarsimp)
apply (drule fstreams_mono, simp)
apply (rule is_ub_thelub chainI)
apply (simp add: chain_def below_prod_def)
apply (subgoal_tac "fst (Y j) ~= fst (Y ja) | snd (Y j) ~= snd (Y ja)", simp)
apply (drule ax_flat, simp)+
apply (drule prod_eqI, auto)
apply (simp add: chain_mono)
apply (rule stream_reach2)
done

lemma cpo_cont_lemma:
  "[| monofun (f::'a::cpo => 'b::cpo); (!Y. chain Y --> f (lub(range Y)) << (LUB i. f (Y i))) |] ==> cont f"
apply (erule contI2)
apply simp
done

end


(*  Title:      HOL/Hoare/Separation.thy
    Author:     Tobias Nipkow
    Copyright   2003 TUM

A first attempt at a nice syntactic embedding of separation logic.
Already builds on the theory for list abstractions.

If we suppress the H parameter for "List", we have to hardwired this
into parser and pretty printer, which is not very modular.
Alternative: some syntax like <P> which stands for P H. No more
compact, but avoids the funny H.
*)

section \<open>Separation logic\<close>

theory Separation
  imports Hoare_Logic_Abort SepLogHeap
begin

text\<open>The semantic definition of a few connectives:\<close>

definition ortho :: "heap \<Rightarrow> heap \<Rightarrow> bool" (infix "\<bottom>" 55)
  where "h1 \<bottom> h2 \<longleftrightarrow> dom h1 \<inter> dom h2 = {}"

definition is_empty :: "heap \<Rightarrow> bool"
  where "is_empty h \<longleftrightarrow> h = Map.empty"

definition singl:: "heap \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "singl h x y \<longleftrightarrow> dom h = {x} & h x = Some y"

definition star:: "(heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool)"
  where "star P Q = (\<lambda>h. \<exists>h1 h2. h = h1++h2 \<and> h1 \<bottom> h2 \<and> P h1 \<and> Q h2)"

definition wand:: "(heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool)"
  where "wand P Q = (\<lambda>h. \<forall>h'. h' \<bottom> h \<and> P h' \<longrightarrow> Q(h++h'))"

text\<open>This is what assertions look like without any syntactic sugar:\<close>

lemma "VARS x y z w h
 {star (%h. singl h x y) (%h. singl h z w) h}
 SKIP
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

text\<open>Now we add nice input syntax.  To suppress the heap parameter
of the connectives, we assume it is always called H and add/remove it
upon parsing/printing. Thus every pointer program needs to have a
program variable H, and assertions should not contain any locally
bound Hs - otherwise they may bind the implicit H.\<close>

syntax
 "_emp" :: "bool" ("emp")
 "_singl" :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("[_ \<mapsto> _]")
 "_star" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "**" 60)
 "_wand" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "-*" 60)

(* FIXME does not handle "_idtdummy" *)
ML \<open>
\<comment> \<open>\<open>free_tr\<close> takes care of free vars in the scope of separation logic connectives:
    they are implicitly applied to the heap\<close>
fun free_tr(t as Free _) = t $ Syntax.free "H"
\<^cancel>\<open>| free_tr((list as Free("List",_))$ p $ ps) = list $ Syntax.free "H" $ p $ ps\<close>
  | free_tr t = t

fun emp_tr [] = Syntax.const \<^const_syntax>\<open>is_empty\<close> $ Syntax.free "H"
  | emp_tr ts = raise TERM ("emp_tr", ts);
fun singl_tr [p, q] = Syntax.const \<^const_syntax>\<open>singl\<close> $ Syntax.free "H" $ p $ q
  | singl_tr ts = raise TERM ("singl_tr", ts);
fun star_tr [P,Q] = Syntax.const \<^const_syntax>\<open>star\<close> $
      absfree ("H", dummyT) (free_tr P) $ absfree ("H", dummyT) (free_tr Q) $
      Syntax.free "H"
  | star_tr ts = raise TERM ("star_tr", ts);
fun wand_tr [P, Q] = Syntax.const \<^const_syntax>\<open>wand\<close> $
      absfree ("H", dummyT) P $ absfree ("H", dummyT) Q $ Syntax.free "H"
  | wand_tr ts = raise TERM ("wand_tr", ts);
\<close>

parse_translation \<open>
 [(\<^syntax_const>\<open>_emp\<close>, K emp_tr),
  (\<^syntax_const>\<open>_singl\<close>, K singl_tr),
  (\<^syntax_const>\<open>_star\<close>, K star_tr),
  (\<^syntax_const>\<open>_wand\<close>, K wand_tr)]
\<close>

text\<open>Now it looks much better:\<close>

lemma "VARS H x y z w
 {[x\<mapsto>y] ** [z\<mapsto>w]}
 SKIP
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

lemma "VARS H x y z w
 {emp ** emp}
 SKIP
 {emp}"
apply vcg
apply(auto simp:star_def ortho_def is_empty_def)
done

text\<open>But the output is still unreadable. Thus we also strip the heap
parameters upon output:\<close>

ML \<open>
local

fun strip (Abs(_,_,(t as Const("_free",_) $ Free _) $ Bound 0)) = t
  | strip (Abs(_,_,(t as Free _) $ Bound 0)) = t
\<^cancel>\<open>| strip (Abs(_,_,((list as Const("List",_))$ Bound 0 $ p $ ps))) = list$p$ps\<close>
  | strip (Abs(_,_,(t as Const("_var",_) $ Var _) $ Bound 0)) = t
  | strip (Abs(_,_,P)) = P
  | strip (Const(\<^const_syntax>\<open>is_empty\<close>,_)) = Syntax.const \<^syntax_const>\<open>_emp\<close>
  | strip t = t;

in

fun is_empty_tr' [_] = Syntax.const \<^syntax_const>\<open>_emp\<close>
fun singl_tr' [_,p,q] = Syntax.const \<^syntax_const>\<open>_singl\<close> $ p $ q
fun star_tr' [P,Q,_] = Syntax.const \<^syntax_const>\<open>_star\<close> $ strip P $ strip Q
fun wand_tr' [P,Q,_] = Syntax.const \<^syntax_const>\<open>_wand\<close> $ strip P $ strip Q

end
\<close>

print_translation \<open>
 [(\<^const_syntax>\<open>is_empty\<close>, K is_empty_tr'),
  (\<^const_syntax>\<open>singl\<close>, K singl_tr'),
  (\<^const_syntax>\<open>star\<close>, K star_tr'),
  (\<^const_syntax>\<open>wand\<close>, K wand_tr')]
\<close>

text\<open>Now the intermediate proof states are also readable:\<close>

lemma "VARS H x y z w
 {[x\<mapsto>y] ** [z\<mapsto>w]}
 y := w
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

lemma "VARS H x y z w
 {emp ** emp}
 SKIP
 {emp}"
apply vcg
apply(auto simp:star_def ortho_def is_empty_def)
done

text\<open>So far we have unfolded the separation logic connectives in
proofs. Here comes a simple example of a program proof that uses a law
of separation logic instead.\<close>

\<comment> \<open>a law of separation logic\<close>
lemma star_comm: "P ** Q = Q ** P"
  by(auto simp add:star_def ortho_def dest: map_add_comm)

lemma "VARS H x y z w
 {P ** Q}
 SKIP
 {Q ** P}"
apply vcg
apply(simp add: star_comm)
done

lemma "VARS H
 {p\<noteq>0 \<and> [p \<mapsto> x] ** List H q qs}
 H := H(p \<mapsto> q)
 {List H p (p#qs)}"
apply vcg
apply(simp add: star_def ortho_def singl_def)
apply clarify
apply(subgoal_tac "p \<notin> set qs")
 prefer 2
 apply(blast dest:list_in_heap)
apply simp
done

lemma "VARS H p q r
  {List H p Ps ** List H q Qs}
  WHILE p \<noteq> 0
  INV {\<exists>ps qs. (List H p ps ** List H q qs) \<and> rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := the(H p); H := H(r \<mapsto> q); q := r OD
  {List H q (rev Ps @ Qs)}"
apply vcg
apply(simp_all add: star_def ortho_def singl_def)

apply fastforce

apply (clarsimp simp add:List_non_null)
apply(rename_tac ps')
apply(rule_tac x = ps' in exI)
apply(rule_tac x = "p#qs" in exI)
apply simp
apply(rule_tac x = "h1(p:=None)" in exI)
apply(rule_tac x = "h2(p\<mapsto>q)" in exI)
apply simp
apply(rule conjI)
 apply(rule ext)
 apply(simp add:map_add_def split:option.split)
apply(rule conjI)
 apply blast
apply(simp add:map_add_def split:option.split)
apply(rule conjI)
apply(subgoal_tac "p \<notin> set qs")
 prefer 2
 apply(blast dest:list_in_heap)
apply(simp)
apply fast

apply(fastforce)
done

end