(*  Author:  LCP, ported from HOL Light
*)

section\<open>Euclidean space and n-spheres, as subtopologies of n-dimensional space\<close>

theory Abstract_Euclidean_Space
imports Homotopy Locally
begin

subsection \<open>Euclidean spaces as abstract topologies\<close>

definition Euclidean_space :: "nat \<Rightarrow> (nat \<Rightarrow> real) topology"
  where "Euclidean_space n \<equiv> subtopology (powertop_real UNIV) {x. \<forall>i\<ge>n. x i = 0}"

lemma topspace_Euclidean_space:
   "topspace(Euclidean_space n) = {x. \<forall>i\<ge>n. x i = 0}"
  by (simp add: Euclidean_space_def)

lemma nonempty_Euclidean_space: "topspace(Euclidean_space n) \<noteq> {}"
  by (force simp: topspace_Euclidean_space)

lemma subset_Euclidean_space [simp]:
   "topspace(Euclidean_space m) \<subseteq> topspace(Euclidean_space n) \<longleftrightarrow> m \<le> n"
  apply (simp add: topspace_Euclidean_space subset_iff, safe)
   apply (drule_tac x="(\<lambda>i. if i < m then 1 else 0)" in spec)
   apply auto
  using not_less by fastforce

lemma topspace_Euclidean_space_alt:
  "topspace(Euclidean_space n) = (\<Inter>i \<in> {n..}. {x. x \<in> topspace(powertop_real UNIV) \<and> x i \<in> {0}})"
  by (auto simp: topspace_Euclidean_space)

lemma closedin_Euclidean_space:
  "closedin (powertop_real UNIV) (topspace(Euclidean_space n))"
proof -
  have "closedin (powertop_real UNIV) {x. x i = 0}" if "n \<le> i" for i
  proof -
    have "closedin (powertop_real UNIV) {x \<in> topspace (powertop_real UNIV). x i \<in> {0}}"
    proof (rule closedin_continuous_map_preimage)
      show "continuous_map (powertop_real UNIV) euclideanreal (\<lambda>x. x i)"
        by (metis UNIV_I continuous_map_product_coordinates)
      show "closedin euclideanreal {0}"
        by simp
    qed
    then show ?thesis
      by auto
  qed
  then show ?thesis
    unfolding topspace_Euclidean_space_alt
    by force
qed

lemma closedin_Euclidean_imp_closed: "closedin (Euclidean_space m) S \<Longrightarrow> closed S"
  by (metis Euclidean_space_def closed_closedin closedin_Euclidean_space closedin_closed_subtopology euclidean_product_topology topspace_Euclidean_space)

lemma closedin_Euclidean_space_iff:
  "closedin (Euclidean_space m) S \<longleftrightarrow> closed S \<and> S \<subseteq> topspace (Euclidean_space m)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  show "?lhs \<Longrightarrow> ?rhs"
    using closedin_closed_subtopology topspace_Euclidean_space
    by (fastforce simp: topspace_Euclidean_space_alt closedin_Euclidean_imp_closed)
  show "?rhs \<Longrightarrow> ?lhs"
  apply (simp add: closedin_subtopology Euclidean_space_def)
    by (metis (no_types) closed_closedin euclidean_product_topology inf.orderE)
qed

lemma continuous_map_componentwise_Euclidean_space:
  "continuous_map X (Euclidean_space n) (\<lambda>x i. if i < n then f x i else 0) \<longleftrightarrow>
   (\<forall>i < n. continuous_map X euclideanreal (\<lambda>x. f x i))"
proof -
  have *: "continuous_map X euclideanreal (\<lambda>x. if k < n then f x k else 0)"
    if "\<And>i. i<n \<Longrightarrow> continuous_map X euclideanreal (\<lambda>x. f x i)" for k
    by (intro continuous_intros that)
  show ?thesis
    unfolding Euclidean_space_def continuous_map_in_subtopology
    by (fastforce simp: continuous_map_componentwise_UNIV * elim: continuous_map_eq)
qed

lemma continuous_map_Euclidean_space_add [continuous_intros]:
   "\<lbrakk>continuous_map X (Euclidean_space n) f; continuous_map X (Euclidean_space n) g\<rbrakk>
    \<Longrightarrow> continuous_map X (Euclidean_space n) (\<lambda>x i. f x i + g x i)"
  unfolding Euclidean_space_def continuous_map_in_subtopology
  by (fastforce simp add: continuous_map_componentwise_UNIV continuous_map_add)

lemma continuous_map_Euclidean_space_diff [continuous_intros]:
   "\<lbrakk>continuous_map X (Euclidean_space n) f; continuous_map X (Euclidean_space n) g\<rbrakk>
    \<Longrightarrow> continuous_map X (Euclidean_space n) (\<lambda>x i. f x i - g x i)"
  unfolding Euclidean_space_def continuous_map_in_subtopology
  by (fastforce simp add: continuous_map_componentwise_UNIV continuous_map_diff)

lemma continuous_map_Euclidean_space_iff:
  "continuous_map (Euclidean_space m) euclidean g
   = continuous_on (topspace (Euclidean_space m)) g"
proof
  assume "continuous_map (Euclidean_space m) euclidean g"
  then have "continuous_map (top_of_set {f. \<forall>n\<ge>m. f n = 0}) euclidean g"
    by (simp add: Euclidean_space_def euclidean_product_topology)
  then show "continuous_on (topspace (Euclidean_space m)) g"
    by (metis continuous_map_subtopology_eu subtopology_topspace topspace_Euclidean_space)
next
  assume "continuous_on (topspace (Euclidean_space m)) g"
  then have "continuous_map (top_of_set {f. \<forall>n\<ge>m. f n = 0}) euclidean g"
    by (metis (lifting) continuous_map_into_fulltopology continuous_map_subtopology_eu order_refl topspace_Euclidean_space)
  then show "continuous_map (Euclidean_space m) euclidean g"
    by (simp add: Euclidean_space_def euclidean_product_topology)
qed

lemma cm_Euclidean_space_iff_continuous_on:
  "continuous_map (subtopology (Euclidean_space m) S) (Euclidean_space n) f
   \<longleftrightarrow> continuous_on (topspace (subtopology (Euclidean_space m) S)) f \<and>
       f ` (topspace (subtopology (Euclidean_space m) S)) \<subseteq> topspace (Euclidean_space n)"
  (is "?P \<longleftrightarrow> ?Q \<and> ?R")
proof -
  have ?Q if ?P
  proof -
    have "\<And>n. Euclidean_space n = top_of_set {f. \<forall>m\<ge>n. f m = 0}"
      by (simp add: Euclidean_space_def euclidean_product_topology)
    with that show ?thesis
      by (simp add: subtopology_subtopology)
  qed
  moreover
  have ?R if ?P
    using that by (simp add: image_subset_iff continuous_map_def)
  moreover
  have ?P if ?Q ?R
  proof -
    have "continuous_map (top_of_set (topspace (subtopology (subtopology (powertop_real UNIV) {f. \<forall>n\<ge>m. f n = 0}) S))) (top_of_set (topspace (subtopology (powertop_real UNIV) {f. \<forall>na\<ge>n. f na = 0}))) f"
      using Euclidean_space_def that by auto
    then show ?thesis
      by (simp add: Euclidean_space_def euclidean_product_topology subtopology_subtopology)
  qed
  ultimately show ?thesis
    by auto
qed

lemma homeomorphic_Euclidean_space_product_topology:
  "Euclidean_space n homeomorphic_space product_topology (\<lambda>i. euclideanreal) {..<n}"
proof -
  have cm: "continuous_map (product_topology (\<lambda>i. euclideanreal) {..<n})
          euclideanreal (\<lambda>x. if k < n then x k else 0)" for k
    by (auto intro: continuous_map_if continuous_map_product_projection)
  show ?thesis
    unfolding homeomorphic_space_def homeomorphic_maps_def
    apply (rule_tac x="\<lambda>f. restrict f {..<n}" in exI)
    apply (rule_tac x="\<lambda>f i. if i < n then f i else 0" in exI)
    apply (simp add: Euclidean_space_def continuous_map_in_subtopology)
    apply (intro conjI continuous_map_from_subtopology)
       apply (force simp: continuous_map_componentwise cm intro: continuous_map_product_projection)+
    done
qed

lemma contractible_Euclidean_space [simp]: "contractible_space (Euclidean_space n)"
  using homeomorphic_Euclidean_space_product_topology contractible_space_euclideanreal
    contractible_space_product_topology homeomorphic_space_contractibility by blast

lemma path_connected_Euclidean_space: "path_connected_space (Euclidean_space n)"
  by (simp add: contractible_imp_path_connected_space)

lemma connected_Euclidean_space: "connected_space (Euclidean_space n)"
  by (simp add: contractible_imp_connected_space)

lemma locally_path_connected_Euclidean_space:
   "locally_path_connected_space (Euclidean_space n)"
  apply (simp add: homeomorphic_locally_path_connected_space [OF homeomorphic_Euclidean_space_product_topology [of n]]
                   locally_path_connected_space_product_topology)
  using locally_path_connected_space_euclideanreal by auto

lemma compact_Euclidean_space:
   "compact_space (Euclidean_space n) \<longleftrightarrow> n = 0"
  by (auto simp: homeomorphic_compact_space [OF homeomorphic_Euclidean_space_product_topology] compact_space_product_topology)

subsection\<open>n-dimensional spheres\<close>

definition nsphere where
 "nsphere n \<equiv> subtopology (Euclidean_space (Suc n)) { x. (\<Sum>i\<le>n. x i ^ 2) = 1 }"

lemma nsphere:
   "nsphere n = subtopology (powertop_real UNIV)
                            {x. (\<Sum>i\<le>n. x i ^ 2) = 1 \<and> (\<forall>i>n. x i = 0)}"
  by (simp add: nsphere_def Euclidean_space_def subtopology_subtopology Suc_le_eq Collect_conj_eq Int_commute)

lemma continuous_map_nsphere_projection: "continuous_map (nsphere n) euclideanreal (\<lambda>x. x k)"
  unfolding nsphere
  by (blast intro: continuous_map_from_subtopology [OF continuous_map_product_projection])

lemma in_topspace_nsphere: "(\<lambda>n. if n = 0 then 1 else 0) \<in> topspace (nsphere n)"
  by (simp add: nsphere_def topspace_Euclidean_space power2_eq_square if_distrib [where f = "\<lambda>x. x * _"] cong: if_cong)

lemma nonempty_nsphere [simp]: "~ (topspace(nsphere n) = {})"
  using in_topspace_nsphere by auto

lemma subtopology_nsphere_equator:
  "subtopology (nsphere (Suc n)) {x. x(Suc n) = 0} = nsphere n"
proof -
  have "({x. (\<Sum>i\<le>n. (x i)\<^sup>2) + (x (Suc n))\<^sup>2 = 1 \<and> (\<forall>i>Suc n. x i = 0)} \<inter> {x. x (Suc n) = 0})
      = {x. (\<Sum>i\<le>n. (x i)\<^sup>2) = 1 \<and> (\<forall>i>n. x i = (0::real))}"
    using Suc_lessI [of n] by (fastforce simp: set_eq_iff)
  then show ?thesis
    by (simp add: nsphere subtopology_subtopology)
qed

lemma topspace_nsphere_minus1:
  assumes x: "x \<in> topspace (nsphere n)" and "x n = 0"
  shows "x \<in> topspace (nsphere (n - Suc 0))"
proof (cases "n = 0")
  case True
  then show ?thesis
    using x by auto
next
  case False
  have subt_eq: "nsphere (n - Suc 0) = subtopology (nsphere n) {x. x n = 0}"
    by (metis False Suc_pred le_zero_eq not_le subtopology_nsphere_equator)
  with x show ?thesis
    by (simp add: assms)
qed

lemma continuous_map_nsphere_reflection:
  "continuous_map (nsphere n) (nsphere n) (\<lambda>x i. if i = k then -x i else x i)"
proof -
  have cm: "continuous_map (powertop_real UNIV) euclideanreal (\<lambda>x. if j = k then - x j else x j)" for j
  proof (cases "j=k")
    case True
    then show ?thesis
      by simp (metis UNIV_I continuous_map_product_projection)
  next
    case False
    then show ?thesis
      by (auto intro: continuous_map_product_projection)
  qed
  have eq: "(if i = k then x k * x k else x i * x i) = x i * x i" for i and x :: "nat \<Rightarrow> real"
    by simp
  show ?thesis
    apply (simp add: nsphere continuous_map_in_subtopology continuous_map_componentwise_UNIV
                     continuous_map_from_subtopology cm)
    apply (intro conjI allI impI continuous_intros continuous_map_from_subtopology continuous_map_product_projection)
      apply (auto simp: power2_eq_square if_distrib [where f = "\<lambda>x. x * _"] eq cong: if_cong)
    done
qed

proposition contractible_space_upper_hemisphere:
  assumes "k \<le> n"
  shows "contractible_space(subtopology (nsphere n) {x. x k \<ge> 0})"
proof -
  define p:: "nat \<Rightarrow> real" where "p \<equiv> \<lambda>i. if i = k then 1 else 0"
  have "p \<in> topspace(nsphere n)"
    using assms
    by (simp add: nsphere p_def power2_eq_square if_distrib [where f = "\<lambda>x. x * _"] cong: if_cong)
  let ?g = "\<lambda>x i. x i / sqrt(\<Sum>j\<le>n. x j ^ 2)"
  let ?h = "\<lambda>(t,q) i. (1 - t) * q i + t * p i"
  let ?Y = "subtopology (Euclidean_space (Suc n)) {x. 0 \<le> x k \<and> (\<exists>i\<le>n. x i \<noteq> 0)}"
  have "continuous_map (prod_topology (top_of_set {0..1}) (subtopology (nsphere n) {x. 0 \<le> x k}))
                       (subtopology (nsphere n) {x. 0 \<le> x k}) (?g \<circ> ?h)"
  proof (rule continuous_map_compose)
    have *: "\<lbrakk>0 \<le> b k; (\<Sum>i\<le>n. (b i)\<^sup>2) = 1; \<forall>i>n. b i = 0; 0 \<le> a; a \<le> 1\<rbrakk>
           \<Longrightarrow> \<exists>i. (i = k \<longrightarrow> (1 - a) * b k + a \<noteq> 0) \<and>
                   (i \<noteq> k \<longrightarrow> i \<le> n \<and> a \<noteq> 1 \<and> b i \<noteq> 0)" for a::real and b
      apply (cases "a \<noteq> 1 \<and> b k = 0"; simp)
       apply (metis (no_types, lifting) atMost_iff sum.neutral zero_power2)
      by (metis add.commute add_le_same_cancel2 diff_ge_0_iff_ge diff_zero less_eq_real_def mult_eq_0_iff mult_nonneg_nonneg not_le numeral_One zero_neq_numeral)
    show "continuous_map (prod_topology (top_of_set {0..1}) (subtopology (nsphere n) {x. 0 \<le> x k})) ?Y ?h"
      using assms
      apply (auto simp: * nsphere continuous_map_componentwise_UNIV
               prod_topology_subtopology subtopology_subtopology case_prod_unfold
               continuous_map_in_subtopology Euclidean_space_def p_def if_distrib [where f = "\<lambda>x. _ * x"] cong: if_cong)
      apply (intro continuous_map_prod_snd continuous_intros continuous_map_from_subtopology)
        apply auto
      done
  next
    have 1: "\<And>x i. \<lbrakk> i \<le> n; x i \<noteq> 0\<rbrakk> \<Longrightarrow> (\<Sum>i\<le>n. (x i / sqrt (\<Sum>j\<le>n. (x j)\<^sup>2))\<^sup>2) = 1"
      by (force simp: sum_nonneg sum_nonneg_eq_0_iff field_split_simps simp flip: sum_divide_distrib)
    have cm: "continuous_map ?Y (nsphere n) (\<lambda>x i. x i / sqrt (\<Sum>j\<le>n. (x j)\<^sup>2))"
      unfolding Euclidean_space_def nsphere subtopology_subtopology continuous_map_in_subtopology
    proof (intro continuous_intros conjI)
      show "continuous_map
               (subtopology (powertop_real UNIV) ({x. \<forall>i\<ge>Suc n. x i = 0} \<inter> {x. 0 \<le> x k \<and> (\<exists>i\<le>n. x i \<noteq> 0)}))
               (powertop_real UNIV) (\<lambda>x i. x i / sqrt (\<Sum>j\<le>n. (x j)\<^sup>2))"
        unfolding continuous_map_componentwise
        by (intro continuous_intros conjI ballI) (auto simp: sum_nonneg_eq_0_iff)
    qed (auto simp: 1)
    show "continuous_map ?Y (subtopology (nsphere n) {x. 0 \<le> x k}) (\<lambda>x i. x i / sqrt (\<Sum>j\<le>n. (x j)\<^sup>2))"
      by (force simp: cm sum_nonneg continuous_map_in_subtopology if_distrib [where f = "\<lambda>x. _ * x"] cong: if_cong)
  qed
  moreover have "(?g \<circ> ?h) (0, x) = x"
    if "x \<in> topspace (subtopology (nsphere n) {x. 0 \<le> x k})" for x
    using that
    by (simp add: assms nsphere)
  moreover
  have "(?g \<circ> ?h) (1, x) = p"
    if "x \<in> topspace (subtopology (nsphere n) {x. 0 \<le> x k})" for x
    by (force simp: assms p_def power2_eq_square if_distrib [where f = "\<lambda>x. x * _"] cong: if_cong)
  ultimately
  show ?thesis
    apply (simp add: contractible_space_def homotopic_with)
    apply (rule_tac x=p in exI)
    apply (rule_tac x="?g \<circ> ?h" in exI, force)
    done
qed

corollary contractible_space_lower_hemisphere:
  assumes "k \<le> n"
  shows "contractible_space(subtopology (nsphere n) {x. x k \<le> 0})"
proof -
  have "contractible_space (subtopology (nsphere n) {x. 0 \<le> x k}) = ?thesis"
  proof (rule homeomorphic_space_contractibility)
    show "subtopology (nsphere n) {x. 0 \<le> x k} homeomorphic_space subtopology (nsphere n) {x. x k \<le> 0}"
      unfolding homeomorphic_space_def homeomorphic_maps_def
      apply (rule_tac x="\<lambda>x i. if i = k then -(x i) else x i" in exI)+
      apply (auto simp: continuous_map_in_subtopology continuous_map_from_subtopology
                  continuous_map_nsphere_reflection)
      done
  qed
  then show ?thesis
    using contractible_space_upper_hemisphere [OF assms] by metis
qed

proposition nullhomotopic_nonsurjective_sphere_map:
  assumes f: "continuous_map (nsphere p) (nsphere p) f"
    and fim: "f ` (topspace(nsphere p)) \<noteq> topspace(nsphere p)"
  obtains a where "homotopic_with (\<lambda>x. True) (nsphere p) (nsphere p) f (\<lambda>x. a)"
proof -
  obtain a where a: "a \<in> topspace(nsphere p)" "a \<notin> f ` (topspace(nsphere p))"
    using fim continuous_map_image_subset_topspace f by blast
  then have a1: "(\<Sum>i\<le>p. (a i)\<^sup>2) = 1" and a0: "\<And>i. i > p \<Longrightarrow> a i = 0"
    by (simp_all add: nsphere)
  have f1: "(\<Sum>j\<le>p. (f x j)\<^sup>2) = 1" if "x \<in> topspace (nsphere p)" for x
  proof -
    have "f x \<in> topspace (nsphere p)"
      using continuous_map_image_subset_topspace f that by blast
    then show ?thesis
      by (simp add: nsphere)
  qed
  show thesis
  proof
    let ?g = "\<lambda>x i. x i / sqrt(\<Sum>j\<le>p. x j ^ 2)"
    let ?h = "\<lambda>(t,x) i. (1 - t) * f x i - t * a i"
    let ?Y = "subtopology (Euclidean_space(Suc p)) (- {\<lambda>i. 0})"
    let ?T01 = "top_of_set {0..1::real}"
    have 1: "continuous_map (prod_topology ?T01 (nsphere p)) (nsphere p) (?g \<circ> ?h)"
    proof (rule continuous_map_compose)
      have "continuous_map (prod_topology ?T01 (nsphere p)) euclideanreal ((\<lambda>x. f x k) \<circ> snd)" for k
        unfolding nsphere
        apply (simp add: continuous_map_of_snd)
        apply (rule continuous_map_compose [of _ "nsphere p" f, unfolded o_def])
        using f apply (simp add: nsphere)
        by (simp add: continuous_map_nsphere_projection)
      then have "continuous_map (prod_topology ?T01 (nsphere p)) euclideanreal (\<lambda>r. ?h r k)"
        for k
        unfolding case_prod_unfold o_def
        by (intro continuous_map_into_fulltopology [OF continuous_map_fst] continuous_intros) auto
      moreover have "?h ` ({0..1} \<times> topspace (nsphere p)) \<subseteq> {x. \<forall>i\<ge>Suc p. x i = 0}"
        using continuous_map_image_subset_topspace [OF f]
        by (auto simp: nsphere image_subset_iff a0)
      moreover have "(\<lambda>i. 0) \<notin> ?h ` ({0..1} \<times> topspace (nsphere p))"
      proof clarify
        fix t b
        assume eq: "(\<lambda>i. 0) = (\<lambda>i. (1 - t) * f b i - t * a i)" and "t \<in> {0..1}" and b: "b \<in> topspace (nsphere p)"
        have "(1 - t)\<^sup>2 = (\<Sum>i\<le>p. ((1 - t) * f b i)^2)"
          using f1 [OF b] by (simp add: power_mult_distrib flip: sum_distrib_left)
        also have "\<dots> = (\<Sum>i\<le>p. (t * a i)^2)"
          using eq by (simp add: fun_eq_iff)
        also have "\<dots> = t\<^sup>2"
          using a1 by (simp add: power_mult_distrib flip: sum_distrib_left)
        finally have "1 - t = t"
          by (simp add: power2_eq_iff)
        then have *: "t = 1/2"
          by simp
        have fba: "f b \<noteq> a"
          using a(2) b by blast
        then show False
          using eq unfolding * by (simp add: fun_eq_iff)
      qed
      ultimately show "continuous_map (prod_topology ?T01 (nsphere p)) ?Y ?h"
        by (simp add: Euclidean_space_def continuous_map_in_subtopology continuous_map_componentwise_UNIV)
    next
      have *: "\<lbrakk>\<forall>i\<ge>Suc p. x i = 0; x \<noteq> (\<lambda>i. 0)\<rbrakk> \<Longrightarrow> (\<Sum>j\<le>p. (x j)\<^sup>2) \<noteq> 0" for x :: "nat \<Rightarrow> real"
        by (force simp: fun_eq_iff not_less_eq_eq sum_nonneg_eq_0_iff)
      show "continuous_map ?Y (nsphere p) ?g"
        apply (simp add: Euclidean_space_def continuous_map_in_subtopology continuous_map_componentwise_UNIV
                         nsphere continuous_map_componentwise subtopology_subtopology)
        apply (intro conjI allI continuous_intros continuous_map_from_subtopology [OF continuous_map_product_projection])
            apply (simp_all add: *)
         apply (force simp: sum_nonneg fun_eq_iff not_less_eq_eq sum_nonneg_eq_0_iff power_divide simp flip: sum_divide_distrib)
        done
    qed
    have 2: "(?g \<circ> ?h) (0, x) = f x" if "x \<in> topspace (nsphere p)" for x
      using that f1 by simp
    have 3: "(?g \<circ> ?h) (1, x) = (\<lambda>i. - a i)" for x
      using a by (force simp: field_split_simps nsphere)
    then show "homotopic_with (\<lambda>x. True) (nsphere p) (nsphere p) f (\<lambda>x. (\<lambda>i. - a i))"
      by (force simp: homotopic_with intro: 1 2 3)
  qed
qed

lemma Hausdorff_Euclidean_space:
   "Hausdorff_space (Euclidean_space n)"
  unfolding Euclidean_space_def
  by (rule Hausdorff_space_subtopology) (metis Hausdorff_space_euclidean Hausdorff_space_product_topology)

end


(* Author: Tobias Nipkow *)

section \<open>Function \textit{lookup} for Tree2\<close>

theory Lookup2
imports
  Tree2
  Cmp
  Map_Specs
begin

fun lookup :: "(('a::linorder * 'b) * 'c) tree \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup Leaf x = None" |
"lookup (Node l ((a,b), _) r) x =
  (case cmp x a of LT \<Rightarrow> lookup l x | GT \<Rightarrow> lookup r x | EQ \<Rightarrow> Some b)"

lemma lookup_map_of:
  "sorted1(inorder t) \<Longrightarrow> lookup t x = map_of (inorder t) x"
by(induction t rule: tree2_induct) (auto simp: map_of_simps split: option.split)

end


(*  Title:      HOL/Map.thy
    Author:     Tobias Nipkow, based on a theory by David von Oheimb
    Copyright   1997-2003 TU Muenchen

The datatype of "maps"; strongly resembles maps in VDM.
*)

section \<open>Maps\<close>

theory Map
imports List
begin

type_synonym ('a, 'b) "map" = "'a \<Rightarrow> 'b option" (infixr "\<rightharpoonup>" 0)

abbreviation
  empty :: "'a \<rightharpoonup> 'b" where
  "empty \<equiv> \<lambda>x. None"

definition
  map_comp :: "('b \<rightharpoonup> 'c) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'c)"  (infixl "\<circ>\<^sub>m" 55) where
  "f \<circ>\<^sub>m g = (\<lambda>k. case g k of None \<Rightarrow> None | Some v \<Rightarrow> f v)"

definition
  map_add :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)"  (infixl "++" 100) where
  "m1 ++ m2 = (\<lambda>x. case m2 x of None \<Rightarrow> m1 x | Some y \<Rightarrow> Some y)"

definition
  restrict_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a set \<Rightarrow> ('a \<rightharpoonup> 'b)"  (infixl "|`"  110) where
  "m|`A = (\<lambda>x. if x \<in> A then m x else None)"

notation (latex output)
  restrict_map  ("_\<restriction>\<^bsub>_\<^esub>" [111,110] 110)

definition
  dom :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a set" where
  "dom m = {a. m a \<noteq> None}"

definition
  ran :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set" where
  "ran m = {b. \<exists>a. m a = Some b}"

definition
  map_le :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool"  (infix "\<subseteq>\<^sub>m" 50) where
  "(m\<^sub>1 \<subseteq>\<^sub>m m\<^sub>2) \<longleftrightarrow> (\<forall>a \<in> dom m\<^sub>1. m\<^sub>1 a = m\<^sub>2 a)"

nonterminal maplets and maplet

syntax
  "_maplet"  :: "['a, 'a] \<Rightarrow> maplet"             ("_ /\<mapsto>/ _")
  "_maplets" :: "['a, 'a] \<Rightarrow> maplet"             ("_ /[\<mapsto>]/ _")
  ""         :: "maplet \<Rightarrow> maplets"             ("_")
  "_Maplets" :: "[maplet, maplets] \<Rightarrow> maplets" ("_,/ _")
  "_MapUpd"  :: "['a \<rightharpoonup> 'b, maplets] \<Rightarrow> 'a \<rightharpoonup> 'b" ("_/'(_')" [900, 0] 900)
  "_Map"     :: "maplets \<Rightarrow> 'a \<rightharpoonup> 'b"            ("(1[_])")

syntax (ASCII)
  "_maplet"  :: "['a, 'a] \<Rightarrow> maplet"             ("_ /|->/ _")
  "_maplets" :: "['a, 'a] \<Rightarrow> maplet"             ("_ /[|->]/ _")

translations
  "_MapUpd m (_Maplets xy ms)"  \<rightleftharpoons> "_MapUpd (_MapUpd m xy) ms"
  "_MapUpd m (_maplet  x y)"    \<rightleftharpoons> "m(x := CONST Some y)"
  "_Map ms"                     \<rightleftharpoons> "_MapUpd (CONST empty) ms"
  "_Map (_Maplets ms1 ms2)"     \<leftharpoondown> "_MapUpd (_Map ms1) ms2"
  "_Maplets ms1 (_Maplets ms2 ms3)" \<leftharpoondown> "_Maplets (_Maplets ms1 ms2) ms3"

primrec map_of :: "('a \<times> 'b) list \<Rightarrow> 'a \<rightharpoonup> 'b"
where
  "map_of [] = empty"
| "map_of (p # ps) = (map_of ps)(fst p \<mapsto> snd p)"

definition map_upds :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'a \<rightharpoonup> 'b"
  where "map_upds m xs ys = m ++ map_of (rev (zip xs ys))"
translations
  "_MapUpd m (_maplets x y)" \<rightleftharpoons> "CONST map_upds m x y"

lemma map_of_Cons_code [code]:
  "map_of [] k = None"
  "map_of ((l, v) # ps) k = (if l = k then Some v else map_of ps k)"
  by simp_all

subsection \<open>@{term [source] empty}\<close>

lemma empty_upd_none [simp]: "empty(x := None) = empty"
  by (rule ext) simp

subsection \<open>@{term [source] map_upd}\<close>

lemma map_upd_triv: "t k = Some x \<Longrightarrow> t(k\<mapsto>x) = t"
  by (rule ext) simp

lemma map_upd_nonempty [simp]: "t(k\<mapsto>x) \<noteq> empty"
proof
  assume "t(k \<mapsto> x) = empty"
  then have "(t(k \<mapsto> x)) k = None" by simp
  then show False by simp
qed

lemma map_upd_eqD1:
  assumes "m(a\<mapsto>x) = n(a\<mapsto>y)"
  shows "x = y"
proof -
  from assms have "(m(a\<mapsto>x)) a = (n(a\<mapsto>y)) a" by simp
  then show ?thesis by simp
qed

lemma map_upd_Some_unfold:
  "((m(a\<mapsto>b)) x = Some y) = (x = a \<and> b = y \<or> x \<noteq> a \<and> m x = Some y)"
by auto

lemma image_map_upd [simp]: "x \<notin> A \<Longrightarrow> m(x \<mapsto> y) ` A = m ` A"
by auto

lemma finite_range_updI: "finite (range f) \<Longrightarrow> finite (range (f(a\<mapsto>b)))"
unfolding image_def
apply (simp (no_asm_use) add:full_SetCompr_eq)
apply (rule finite_subset)
 prefer 2 apply assumption
apply (auto)
done

subsection \<open>@{term [source] map_of}\<close>

lemma map_of_eq_None_iff:
  "(map_of xys x = None) = (x \<notin> fst ` (set xys))"
by (induct xys) simp_all

lemma map_of_eq_Some_iff [simp]:
  "distinct(map fst xys) \<Longrightarrow> (map_of xys x = Some y) = ((x,y) \<in> set xys)"
apply (induct xys)
 apply simp
apply (auto simp: map_of_eq_None_iff [symmetric])
done

lemma Some_eq_map_of_iff [simp]:
  "distinct(map fst xys) \<Longrightarrow> (Some y = map_of xys x) = ((x,y) \<in> set xys)"
by (auto simp del: map_of_eq_Some_iff simp: map_of_eq_Some_iff [symmetric])

lemma map_of_is_SomeI [simp]: "\<lbrakk> distinct(map fst xys); (x,y) \<in> set xys \<rbrakk>
    \<Longrightarrow> map_of xys x = Some y"
apply (induct xys)
 apply simp
apply force
done

lemma map_of_zip_is_None [simp]:
  "length xs = length ys \<Longrightarrow> (map_of (zip xs ys) x = None) = (x \<notin> set xs)"
by (induct rule: list_induct2) simp_all

lemma map_of_zip_is_Some:
  assumes "length xs = length ys"
  shows "x \<in> set xs \<longleftrightarrow> (\<exists>y. map_of (zip xs ys) x = Some y)"
using assms by (induct rule: list_induct2) simp_all

lemma map_of_zip_upd:
  fixes x :: 'a and xs :: "'a list" and ys zs :: "'b list"
  assumes "length ys = length xs"
    and "length zs = length xs"
    and "x \<notin> set xs"
    and "map_of (zip xs ys)(x \<mapsto> y) = map_of (zip xs zs)(x \<mapsto> z)"
  shows "map_of (zip xs ys) = map_of (zip xs zs)"
proof
  fix x' :: 'a
  show "map_of (zip xs ys) x' = map_of (zip xs zs) x'"
  proof (cases "x = x'")
    case True
    from assms True map_of_zip_is_None [of xs ys x']
      have "map_of (zip xs ys) x' = None" by simp
    moreover from assms True map_of_zip_is_None [of xs zs x']
      have "map_of (zip xs zs) x' = None" by simp
    ultimately show ?thesis by simp
  next
    case False from assms
      have "(map_of (zip xs ys)(x \<mapsto> y)) x' = (map_of (zip xs zs)(x \<mapsto> z)) x'" by auto
    with False show ?thesis by simp
  qed
qed

lemma map_of_zip_inject:
  assumes "length ys = length xs"
    and "length zs = length xs"
    and dist: "distinct xs"
    and map_of: "map_of (zip xs ys) = map_of (zip xs zs)"
  shows "ys = zs"
  using assms(1) assms(2)[symmetric]
  using dist map_of
proof (induct ys xs zs rule: list_induct3)
  case Nil show ?case by simp
next
  case (Cons y ys x xs z zs)
  from \<open>map_of (zip (x#xs) (y#ys)) = map_of (zip (x#xs) (z#zs))\<close>
    have map_of: "map_of (zip xs ys)(x \<mapsto> y) = map_of (zip xs zs)(x \<mapsto> z)" by simp
  from Cons have "length ys = length xs" and "length zs = length xs"
    and "x \<notin> set xs" by simp_all
  then have "map_of (zip xs ys) = map_of (zip xs zs)" using map_of by (rule map_of_zip_upd)
  with Cons.hyps \<open>distinct (x # xs)\<close> have "ys = zs" by simp
  moreover from map_of have "y = z" by (rule map_upd_eqD1)
  ultimately show ?case by simp
qed

lemma map_of_zip_map:
  "map_of (zip xs (map f xs)) = (\<lambda>x. if x \<in> set xs then Some (f x) else None)"
  by (induct xs) (simp_all add: fun_eq_iff)

lemma finite_range_map_of: "finite (range (map_of xys))"
apply (induct xys)
 apply (simp_all add: image_constant)
apply (rule finite_subset)
 prefer 2 apply assumption
apply auto
done

lemma map_of_SomeD: "map_of xs k = Some y \<Longrightarrow> (k, y) \<in> set xs"
  by (induct xs) (auto split: if_splits)

lemma map_of_mapk_SomeI:
  "inj f \<Longrightarrow> map_of t k = Some x \<Longrightarrow>
   map_of (map (case_prod (\<lambda>k. Pair (f k))) t) (f k) = Some x"
by (induct t) (auto simp: inj_eq)

lemma weak_map_of_SomeI: "(k, x) \<in> set l \<Longrightarrow> \<exists>x. map_of l k = Some x"
by (induct l) auto

lemma map_of_filter_in:
  "map_of xs k = Some z \<Longrightarrow> P k z \<Longrightarrow> map_of (filter (case_prod P) xs) k = Some z"
by (induct xs) auto

lemma map_of_map:
  "map_of (map (\<lambda>(k, v). (k, f v)) xs) = map_option f \<circ> map_of xs"
  by (induct xs) (auto simp: fun_eq_iff)

lemma dom_map_option:
  "dom (\<lambda>k. map_option (f k) (m k)) = dom m"
  by (simp add: dom_def)

lemma dom_map_option_comp [simp]:
  "dom (map_option g \<circ> m) = dom m"
  using dom_map_option [of "\<lambda>_. g" m] by (simp add: comp_def)

subsection \<open>@{const map_option} related\<close>

lemma map_option_o_empty [simp]: "map_option f o empty = empty"
by (rule ext) simp

lemma map_option_o_map_upd [simp]:
  "map_option f o m(a\<mapsto>b) = (map_option f o m)(a\<mapsto>f b)"
by (rule ext) simp

subsection \<open>@{term [source] map_comp} related\<close>

lemma map_comp_empty [simp]:
  "m \<circ>\<^sub>m empty = empty"
  "empty \<circ>\<^sub>m m = empty"
by (auto simp: map_comp_def split: option.splits)

lemma map_comp_simps [simp]:
  "m2 k = None \<Longrightarrow> (m1 \<circ>\<^sub>m m2) k = None"
  "m2 k = Some k' \<Longrightarrow> (m1 \<circ>\<^sub>m m2) k = m1 k'"
by (auto simp: map_comp_def)

lemma map_comp_Some_iff:
  "((m1 \<circ>\<^sub>m m2) k = Some v) = (\<exists>k'. m2 k = Some k' \<and> m1 k' = Some v)"
by (auto simp: map_comp_def split: option.splits)

lemma map_comp_None_iff:
  "((m1 \<circ>\<^sub>m m2) k = None) = (m2 k = None \<or> (\<exists>k'. m2 k = Some k' \<and> m1 k' = None)) "
by (auto simp: map_comp_def split: option.splits)

subsection \<open>\<open>++\<close>\<close>

lemma map_add_empty[simp]: "m ++ empty = m"
by(simp add: map_add_def)

lemma empty_map_add[simp]: "empty ++ m = m"
by (rule ext) (simp add: map_add_def split: option.split)

lemma map_add_assoc[simp]: "m1 ++ (m2 ++ m3) = (m1 ++ m2) ++ m3"
by (rule ext) (simp add: map_add_def split: option.split)

lemma map_add_Some_iff:
  "((m ++ n) k = Some x) = (n k = Some x | n k = None & m k = Some x)"
by (simp add: map_add_def split: option.split)

lemma map_add_SomeD [dest!]:
  "(m ++ n) k = Some x \<Longrightarrow> n k = Some x \<or> n k = None \<and> m k = Some x"
by (rule map_add_Some_iff [THEN iffD1])

lemma map_add_find_right [simp]: "n k = Some xx \<Longrightarrow> (m ++ n) k = Some xx"
by (subst map_add_Some_iff) fast

lemma map_add_None [iff]: "((m ++ n) k = None) = (n k = None & m k = None)"
by (simp add: map_add_def split: option.split)

lemma map_add_upd[simp]: "f ++ g(x\<mapsto>y) = (f ++ g)(x\<mapsto>y)"
by (rule ext) (simp add: map_add_def)

lemma map_add_upds[simp]: "m1 ++ (m2(xs[\<mapsto>]ys)) = (m1++m2)(xs[\<mapsto>]ys)"
by (simp add: map_upds_def)

lemma map_add_upd_left: "m\<notin>dom e2 \<Longrightarrow> e1(m \<mapsto> u1) ++ e2 = (e1 ++ e2)(m \<mapsto> u1)"
by (rule ext) (auto simp: map_add_def dom_def split: option.split)

lemma map_of_append[simp]: "map_of (xs @ ys) = map_of ys ++ map_of xs"
unfolding map_add_def
apply (induct xs)
 apply simp
apply (rule ext)
apply (simp split: option.split)
done

lemma finite_range_map_of_map_add:
  "finite (range f) \<Longrightarrow> finite (range (f ++ map_of l))"
apply (induct l)
 apply (auto simp del: fun_upd_apply)
apply (erule finite_range_updI)
done

lemma inj_on_map_add_dom [iff]:
  "inj_on (m ++ m') (dom m') = inj_on m' (dom m')"
by (fastforce simp: map_add_def dom_def inj_on_def split: option.splits)

lemma map_upds_fold_map_upd:
  "m(ks[\<mapsto>]vs) = foldl (\<lambda>m (k, v). m(k \<mapsto> v)) m (zip ks vs)"
unfolding map_upds_def proof (rule sym, rule zip_obtain_same_length)
  fix ks :: "'a list" and vs :: "'b list"
  assume "length ks = length vs"
  then show "foldl (\<lambda>m (k, v). m(k\<mapsto>v)) m (zip ks vs) = m ++ map_of (rev (zip ks vs))"
    by(induct arbitrary: m rule: list_induct2) simp_all
qed

lemma map_add_map_of_foldr:
  "m ++ map_of ps = foldr (\<lambda>(k, v) m. m(k \<mapsto> v)) ps m"
  by (induct ps) (auto simp: fun_eq_iff map_add_def)

subsection \<open>@{term [source] restrict_map}\<close>

lemma restrict_map_to_empty [simp]: "m|`{} = empty"
by (simp add: restrict_map_def)

lemma restrict_map_insert: "f |` (insert a A) = (f |` A)(a := f a)"
by (auto simp: restrict_map_def)

lemma restrict_map_empty [simp]: "empty|`D = empty"
by (simp add: restrict_map_def)

lemma restrict_in [simp]: "x \<in> A \<Longrightarrow> (m|`A) x = m x"
by (simp add: restrict_map_def)

lemma restrict_out [simp]: "x \<notin> A \<Longrightarrow> (m|`A) x = None"
by (simp add: restrict_map_def)

lemma ran_restrictD: "y \<in> ran (m|`A) \<Longrightarrow> \<exists>x\<in>A. m x = Some y"
by (auto simp: restrict_map_def ran_def split: if_split_asm)

lemma dom_restrict [simp]: "dom (m|`A) = dom m \<inter> A"
by (auto simp: restrict_map_def dom_def split: if_split_asm)

lemma restrict_upd_same [simp]: "m(x\<mapsto>y)|`(-{x}) = m|`(-{x})"
by (rule ext) (auto simp: restrict_map_def)

lemma restrict_restrict [simp]: "m|`A|`B = m|`(A\<inter>B)"
by (rule ext) (auto simp: restrict_map_def)

lemma restrict_fun_upd [simp]:
  "m(x := y)|`D = (if x \<in> D then (m|`(D-{x}))(x := y) else m|`D)"
by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_None_restrict [simp]:
  "(m|`D)(x := None) = (if x \<in> D then m|`(D - {x}) else m|`D)"
by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_restrict: "(m|`D)(x := y) = (m|`(D-{x}))(x := y)"
by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_restrict_conv [simp]:
  "x \<in> D \<Longrightarrow> (m|`D)(x := y) = (m|`(D-{x}))(x := y)"
by (simp add: restrict_map_def fun_eq_iff)

lemma map_of_map_restrict:
  "map_of (map (\<lambda>k. (k, f k)) ks) = (Some \<circ> f) |` set ks"
  by (induct ks) (simp_all add: fun_eq_iff restrict_map_insert)

lemma restrict_complement_singleton_eq:
  "f |` (- {x}) = f(x := None)"
  by (simp add: restrict_map_def fun_eq_iff)

subsection \<open>@{term [source] map_upds}\<close>

lemma map_upds_Nil1 [simp]: "m([] [\<mapsto>] bs) = m"
by (simp add: map_upds_def)

lemma map_upds_Nil2 [simp]: "m(as [\<mapsto>] []) = m"
by (simp add:map_upds_def)

lemma map_upds_Cons [simp]: "m(a#as [\<mapsto>] b#bs) = (m(a\<mapsto>b))(as[\<mapsto>]bs)"
by (simp add:map_upds_def)

lemma map_upds_append1 [simp]: "size xs < size ys \<Longrightarrow>
  m(xs@[x] [\<mapsto>] ys) = m(xs [\<mapsto>] ys)(x \<mapsto> ys!size xs)"
apply(induct xs arbitrary: ys m)
 apply (clarsimp simp add: neq_Nil_conv)
apply (case_tac ys)
 apply simp
apply simp
done

lemma map_upds_list_update2_drop [simp]:
  "size xs \<le> i \<Longrightarrow> m(xs[\<mapsto>]ys[i:=y]) = m(xs[\<mapsto>]ys)"
apply (induct xs arbitrary: m ys i)
 apply simp
apply (case_tac ys)
 apply simp
apply (simp split: nat.split)
done

lemma map_upd_upds_conv_if:
  "(f(x\<mapsto>y))(xs [\<mapsto>] ys) =
   (if x \<in> set(take (length ys) xs) then f(xs [\<mapsto>] ys)
                                    else (f(xs [\<mapsto>] ys))(x\<mapsto>y))"
apply (induct xs arbitrary: x y ys f)
 apply simp
apply (case_tac ys)
 apply (auto split: if_split simp: fun_upd_twist)
done

lemma map_upds_twist [simp]:
  "a \<notin> set as \<Longrightarrow> m(a\<mapsto>b)(as[\<mapsto>]bs) = m(as[\<mapsto>]bs)(a\<mapsto>b)"
using set_take_subset by (fastforce simp add: map_upd_upds_conv_if)

lemma map_upds_apply_nontin [simp]:
  "x \<notin> set xs \<Longrightarrow> (f(xs[\<mapsto>]ys)) x = f x"
apply (induct xs arbitrary: ys)
 apply simp
apply (case_tac ys)
 apply (auto simp: map_upd_upds_conv_if)
done

lemma fun_upds_append_drop [simp]:
  "size xs = size ys \<Longrightarrow> m(xs@zs[\<mapsto>]ys) = m(xs[\<mapsto>]ys)"
apply (induct xs arbitrary: m ys)
 apply simp
apply (case_tac ys)
 apply simp_all
done

lemma fun_upds_append2_drop [simp]:
  "size xs = size ys \<Longrightarrow> m(xs[\<mapsto>]ys@zs) = m(xs[\<mapsto>]ys)"
apply (induct xs arbitrary: m ys)
 apply simp
apply (case_tac ys)
 apply simp_all
done

lemma restrict_map_upds[simp]:
  "\<lbrakk> length xs = length ys; set xs \<subseteq> D \<rbrakk>
    \<Longrightarrow> m(xs [\<mapsto>] ys)|`D = (m|`(D - set xs))(xs [\<mapsto>] ys)"
apply (induct xs arbitrary: m ys)
 apply simp
apply (case_tac ys)
 apply simp
apply (simp add: Diff_insert [symmetric] insert_absorb)
apply (simp add: map_upd_upds_conv_if)
done

subsection \<open>@{term [source] dom}\<close>

lemma dom_eq_empty_conv [simp]: "dom f = {} \<longleftrightarrow> f = empty"
  by (auto simp: dom_def)

lemma domI: "m a = Some b \<Longrightarrow> a \<in> dom m"
  by (simp add: dom_def)
(* declare domI [intro]? *)

lemma domD: "a \<in> dom m \<Longrightarrow> \<exists>b. m a = Some b"
  by (cases "m a") (auto simp add: dom_def)

lemma domIff [iff, simp del]: "a \<in> dom m \<longleftrightarrow> m a \<noteq> None"
  by (simp add: dom_def)

lemma dom_empty [simp]: "dom empty = {}"
  by (simp add: dom_def)

lemma dom_fun_upd [simp]:
  "dom(f(x := y)) = (if y = None then dom f - {x} else insert x (dom f))"
  by (auto simp: dom_def)

lemma dom_if:
  "dom (\<lambda>x. if P x then f x else g x) = dom f \<inter> {x. P x} \<union> dom g \<inter> {x. \<not> P x}"
  by (auto split: if_splits)

lemma dom_map_of_conv_image_fst:
  "dom (map_of xys) = fst ` set xys"
  by (induct xys) (auto simp add: dom_if)

lemma dom_map_of_zip [simp]: "length xs = length ys \<Longrightarrow> dom (map_of (zip xs ys)) = set xs"
  by (induct rule: list_induct2) (auto simp: dom_if)

lemma finite_dom_map_of: "finite (dom (map_of l))"
  by (induct l) (auto simp: dom_def insert_Collect [symmetric])

lemma dom_map_upds [simp]:
  "dom(m(xs[\<mapsto>]ys)) = set(take (length ys) xs) \<union> dom m"
apply (induct xs arbitrary: m ys)
 apply simp
apply (case_tac ys)
 apply auto
done

lemma dom_map_add [simp]: "dom (m ++ n) = dom n \<union> dom m"
  by (auto simp: dom_def)

lemma dom_override_on [simp]:
  "dom (override_on f g A) =
    (dom f  - {a. a \<in> A - dom g}) \<union> {a. a \<in> A \<inter> dom g}"
  by (auto simp: dom_def override_on_def)

lemma map_add_dom_app_simps:
  "m \<in> dom l2 \<Longrightarrow> (l1 ++ l2) m = l2 m"
  "m \<notin> dom l1 \<Longrightarrow> (l1 ++ l2) m = l2 m"
  "m \<notin> dom l2 \<Longrightarrow> (l1 ++ l2) m = l1 m"
  by (auto simp add: map_add_def split: option.split_asm)

lemma dom_const [simp]:
  "dom (\<lambda>x. Some (f x)) = UNIV"
  by auto

(* Due to John Matthews - could be rephrased with dom *)
lemma finite_map_freshness:
  "finite (dom (f :: 'a \<rightharpoonup> 'b)) \<Longrightarrow> \<not> finite (UNIV :: 'a set) \<Longrightarrow>
   \<exists>x. f x = None"
  by (bestsimp dest: ex_new_if_finite)

lemma dom_minus:
  "f x = None \<Longrightarrow> dom f - insert x A = dom f - A"
  unfolding dom_def by simp

lemma insert_dom:
  "f x = Some y \<Longrightarrow> insert x (dom f) = dom f"
  unfolding dom_def by auto

lemma map_of_map_keys:
  "set xs = dom m \<Longrightarrow> map_of (map (\<lambda>k. (k, the (m k))) xs) = m"
  by (rule ext) (auto simp add: map_of_map_restrict restrict_map_def)

lemma map_of_eqI:
  assumes set_eq: "set (map fst xs) = set (map fst ys)"
  assumes map_eq: "\<forall>k\<in>set (map fst xs). map_of xs k = map_of ys k"
  shows "map_of xs = map_of ys"
proof (rule ext)
  fix k show "map_of xs k = map_of ys k"
  proof (cases "map_of xs k")
    case None
    then have "k \<notin> set (map fst xs)" by (simp add: map_of_eq_None_iff)
    with set_eq have "k \<notin> set (map fst ys)" by simp
    then have "map_of ys k = None" by (simp add: map_of_eq_None_iff)
    with None show ?thesis by simp
  next
    case (Some v)
    then have "k \<in> set (map fst xs)" by (auto simp add: dom_map_of_conv_image_fst [symmetric])
    with map_eq show ?thesis by auto
  qed
qed

lemma map_of_eq_dom:
  assumes "map_of xs = map_of ys"
  shows "fst ` set xs = fst ` set ys"
proof -
  from assms have "dom (map_of xs) = dom (map_of ys)" by simp
  then show ?thesis by (simp add: dom_map_of_conv_image_fst)
qed

lemma finite_set_of_finite_maps:
  assumes "finite A" "finite B"
  shows "finite {m. dom m = A \<and> ran m \<subseteq> B}" (is "finite ?S")
proof -
  let ?S' = "{m. \<forall>x. (x \<in> A \<longrightarrow> m x \<in> Some ` B) \<and> (x \<notin> A \<longrightarrow> m x = None)}"
  have "?S = ?S'"
  proof
    show "?S \<subseteq> ?S'" by (auto simp: dom_def ran_def image_def)
    show "?S' \<subseteq> ?S"
    proof
      fix m assume "m \<in> ?S'"
      hence 1: "dom m = A" by force
      hence 2: "ran m \<subseteq> B" using \<open>m \<in> ?S'\<close> by (auto simp: dom_def ran_def)
      from 1 2 show "m \<in> ?S" by blast
    qed
  qed
  with assms show ?thesis by(simp add: finite_set_of_finite_funs)
qed

subsection \<open>@{term [source] ran}\<close>

lemma ranI: "m a = Some b \<Longrightarrow> b \<in> ran m"
  by (auto simp: ran_def)
(* declare ranI [intro]? *)

lemma ran_empty [simp]: "ran empty = {}"
  by (auto simp: ran_def)

lemma ran_map_upd [simp]: "m a = None \<Longrightarrow> ran(m(a\<mapsto>b)) = insert b (ran m)"
  unfolding ran_def
apply auto
apply (subgoal_tac "aa \<noteq> a")
 apply auto
done

lemma ran_distinct:
  assumes dist: "distinct (map fst al)"
  shows "ran (map_of al) = snd ` set al"
  using assms
proof (induct al)
  case Nil
  then show ?case by simp
next
  case (Cons kv al)
  then have "ran (map_of al) = snd ` set al" by simp
  moreover from Cons.prems have "map_of al (fst kv) = None"
    by (simp add: map_of_eq_None_iff)
  ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
qed

lemma ran_map_option: "ran (\<lambda>x. map_option f (m x)) = f ` ran m"
  by (auto simp add: ran_def)

subsection \<open>\<open>map_le\<close>\<close>

lemma map_le_empty [simp]: "empty \<subseteq>\<^sub>m g"
  by (simp add: map_le_def)

lemma upd_None_map_le [simp]: "f(x := None) \<subseteq>\<^sub>m f"
  by (force simp add: map_le_def)

lemma map_le_upd[simp]: "f \<subseteq>\<^sub>m g ==> f(a := b) \<subseteq>\<^sub>m g(a := b)"
  by (fastforce simp add: map_le_def)

lemma map_le_imp_upd_le [simp]: "m1 \<subseteq>\<^sub>m m2 \<Longrightarrow> m1(x := None) \<subseteq>\<^sub>m m2(x \<mapsto> y)"
  by (force simp add: map_le_def)

lemma map_le_upds [simp]:
  "f \<subseteq>\<^sub>m g \<Longrightarrow> f(as [\<mapsto>] bs) \<subseteq>\<^sub>m g(as [\<mapsto>] bs)"
apply (induct as arbitrary: f g bs)
 apply simp
apply (case_tac bs)
 apply auto
done

lemma map_le_implies_dom_le: "(f \<subseteq>\<^sub>m g) \<Longrightarrow> (dom f \<subseteq> dom g)"
  by (fastforce simp add: map_le_def dom_def)

lemma map_le_refl [simp]: "f \<subseteq>\<^sub>m f"
  by (simp add: map_le_def)

lemma map_le_trans[trans]: "\<lbrakk> m1 \<subseteq>\<^sub>m m2; m2 \<subseteq>\<^sub>m m3\<rbrakk> \<Longrightarrow> m1 \<subseteq>\<^sub>m m3"
  by (auto simp add: map_le_def dom_def)

lemma map_le_antisym: "\<lbrakk> f \<subseteq>\<^sub>m g; g \<subseteq>\<^sub>m f \<rbrakk> \<Longrightarrow> f = g"
unfolding map_le_def
apply (rule ext)
apply (case_tac "x \<in> dom f", simp)
apply (case_tac "x \<in> dom g", simp, fastforce)
done

lemma map_le_map_add [simp]: "f \<subseteq>\<^sub>m g ++ f"
  by (fastforce simp: map_le_def)

lemma map_le_iff_map_add_commute: "f \<subseteq>\<^sub>m f ++ g \<longleftrightarrow> f ++ g = g ++ f"
  by (fastforce simp: map_add_def map_le_def fun_eq_iff split: option.splits)

lemma map_add_le_mapE: "f ++ g \<subseteq>\<^sub>m h \<Longrightarrow> g \<subseteq>\<^sub>m h"
  by (fastforce simp: map_le_def map_add_def dom_def)

lemma map_add_le_mapI: "\<lbrakk> f \<subseteq>\<^sub>m h; g \<subseteq>\<^sub>m h \<rbrakk> \<Longrightarrow> f ++ g \<subseteq>\<^sub>m h"
  by (auto simp: map_le_def map_add_def dom_def split: option.splits)

lemma map_add_subsumed1: "f \<subseteq>\<^sub>m g \<Longrightarrow> f++g = g"
by (simp add: map_add_le_mapI map_le_antisym)

lemma map_add_subsumed2: "f \<subseteq>\<^sub>m g \<Longrightarrow> g++f = g"
by (metis map_add_subsumed1 map_le_iff_map_add_commute)

lemma dom_eq_singleton_conv: "dom f = {x} \<longleftrightarrow> (\<exists>v. f = [x \<mapsto> v])"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs
  then show ?lhs by (auto split: if_split_asm)
next
  assume ?lhs
  then obtain v where v: "f x = Some v" by auto
  show ?rhs
  proof
    show "f = [x \<mapsto> v]"
    proof (rule map_le_antisym)
      show "[x \<mapsto> v] \<subseteq>\<^sub>m f"
        using v by (auto simp add: map_le_def)
      show "f \<subseteq>\<^sub>m [x \<mapsto> v]"
        using \<open>dom f = {x}\<close> \<open>f x = Some v\<close> by (auto simp add: map_le_def)
    qed
  qed
qed

subsection \<open>Various\<close>

lemma set_map_of_compr:
  assumes distinct: "distinct (map fst xs)"
  shows "set xs = {(k, v). map_of xs k = Some v}"
  using assms
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  obtain k v where "x = (k, v)" by (cases x) blast
  with Cons.prems have "k \<notin> dom (map_of xs)"
    by (simp add: dom_map_of_conv_image_fst)
  then have *: "insert (k, v) {(k, v). map_of xs k = Some v} =
    {(k', v'). (map_of xs(k \<mapsto> v)) k' = Some v'}"
    by (auto split: if_splits)
  from Cons have "set xs = {(k, v). map_of xs k = Some v}" by simp
  with * \<open>x = (k, v)\<close> show ?case by simp
qed

lemma map_of_inject_set:
  assumes distinct: "distinct (map fst xs)" "distinct (map fst ys)"
  shows "map_of xs = map_of ys \<longleftrightarrow> set xs = set ys" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  moreover from \<open>distinct (map fst xs)\<close> have "set xs = {(k, v). map_of xs k = Some v}"
    by (rule set_map_of_compr)
  moreover from \<open>distinct (map fst ys)\<close> have "set ys = {(k, v). map_of ys k = Some v}"
    by (rule set_map_of_compr)
  ultimately show ?rhs by simp
next
  assume ?rhs show ?lhs
  proof
    fix k
    show "map_of xs k = map_of ys k"
    proof (cases "map_of xs k")
      case None
      with \<open>?rhs\<close> have "map_of ys k = None"
        by (simp add: map_of_eq_None_iff)
      with None show ?thesis by simp
    next
      case (Some v)
      with distinct \<open>?rhs\<close> have "map_of ys k = Some v"
        by simp
      with Some show ?thesis by simp
    qed
  qed
qed

end


(*  Title:      HOL/Algebra/RingHom.thy
    Author:     Stephan Hohe, TU Muenchen
*)

theory RingHom
imports Ideal
begin

section \<open>Homomorphisms of Non-Commutative Rings\<close>

text \<open>Lifting existing lemmas in a \<open>ring_hom_ring\<close> locale\<close>
locale ring_hom_ring = R?: ring R + S?: ring S
    for R (structure) and S (structure) +
  fixes h
  assumes homh: "h \<in> ring_hom R S"
  notes hom_mult [simp] = ring_hom_mult [OF homh]
    and hom_one [simp] = ring_hom_one [OF homh]

sublocale ring_hom_cring \<subseteq> ring: ring_hom_ring
  by standard (rule homh)

sublocale ring_hom_ring \<subseteq> abelian_group?: abelian_group_hom R S
apply (rule abelian_group_homI)
  apply (rule R.is_abelian_group)
 apply (rule S.is_abelian_group)
apply (intro group_hom.intro group_hom_axioms.intro)
  apply (rule R.a_group)
 apply (rule S.a_group)
apply (insert homh, unfold hom_def ring_hom_def)
apply simp
done

lemma (in ring_hom_ring) is_ring_hom_ring:
  "ring_hom_ring R S h"
  by (rule ring_hom_ring_axioms)

lemma ring_hom_ringI:
  fixes R (structure) and S (structure)
  assumes "ring R" "ring S"
  assumes (* morphism: "h \<in> carrier R \<rightarrow> carrier S" *)
          hom_closed: "!!x. x \<in> carrier R ==> h x \<in> carrier S"
      and compatible_mult: "!!x y. [| x : carrier R; y : carrier R |] ==> h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
      and compatible_add: "!!x y. [| x : carrier R; y : carrier R |] ==> h (x \<oplus> y) = h x \<oplus>\<^bsub>S\<^esub> h y"
      and compatible_one: "h \<one> = \<one>\<^bsub>S\<^esub>"
  shows "ring_hom_ring R S h"
proof -
  interpret ring R by fact
  interpret ring S by fact
  show ?thesis apply unfold_locales
apply (unfold ring_hom_def, safe)
   apply (simp add: hom_closed Pi_def)
  apply (erule (1) compatible_mult)
 apply (erule (1) compatible_add)
apply (rule compatible_one)
done
qed

lemma ring_hom_ringI2:
  assumes "ring R" "ring S"
  assumes h: "h \<in> ring_hom R S"
  shows "ring_hom_ring R S h"
proof -
  interpret R: ring R by fact
  interpret S: ring S by fact
  show ?thesis apply (intro ring_hom_ring.intro ring_hom_ring_axioms.intro)
    apply (rule R.is_ring)
    apply (rule S.is_ring)
    apply (rule h)
    done
qed

lemma ring_hom_ringI3:
  fixes R (structure) and S (structure)
  assumes "abelian_group_hom R S h" "ring R" "ring S"
  assumes compatible_mult: "!!x y. [| x : carrier R; y : carrier R |] ==> h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
      and compatible_one: "h \<one> = \<one>\<^bsub>S\<^esub>"
  shows "ring_hom_ring R S h"
proof -
  interpret abelian_group_hom R S h by fact
  interpret R: ring R by fact
  interpret S: ring S by fact
  show ?thesis apply (intro ring_hom_ring.intro ring_hom_ring_axioms.intro, rule R.is_ring, rule S.is_ring)
    apply (insert group_hom.homh[OF a_group_hom])
    apply (unfold hom_def ring_hom_def, simp)
    apply safe
    apply (erule (1) compatible_mult)
    apply (rule compatible_one)
    done
qed

lemma ring_hom_cringI:
  assumes "ring_hom_ring R S h" "cring R" "cring S"
  shows "ring_hom_cring R S h"
proof -
  interpret ring_hom_ring R S h by fact
  interpret R: cring R by fact
  interpret S: cring S by fact
  show ?thesis by (intro ring_hom_cring.intro ring_hom_cring_axioms.intro)
    (rule R.is_cring, rule S.is_cring, rule homh)
qed

subsection \<open>The Kernel of a Ring Homomorphism\<close>

\<comment>"the kernel of a ring homomorphism is an ideal"
lemma (in ring_hom_ring) kernel_is_ideal:
  shows "ideal (a_kernel R S h) R"
apply (rule idealI)
   apply (rule R.is_ring)
  apply (rule additive_subgroup.a_subgroup[OF additive_subgroup_a_kernel])
 apply (unfold a_kernel_def', simp+)
done

text \<open>Elements of the kernel are mapped to zero\<close>
lemma (in abelian_group_hom) kernel_zero [simp]:
  "i \<in> a_kernel R S h \<Longrightarrow> h i = \<zero>\<^bsub>S\<^esub>"
by (simp add: a_kernel_defs)

subsection \<open>Cosets\<close>

text \<open>Cosets of the kernel correspond to the elements of the image of the homomorphism\<close>
lemma (in ring_hom_ring) rcos_imp_homeq:
  assumes acarr: "a \<in> carrier R"
      and xrcos: "x \<in> a_kernel R S h +> a"
  shows "h x = h a"
proof -
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  from xrcos
      have "\<exists>i \<in> a_kernel R S h. x = i \<oplus> a" by (simp add: a_r_coset_defs)
  from this obtain i
      where iker: "i \<in> a_kernel R S h"
        and x: "x = i \<oplus> a"
      by fast+
  note carr = acarr iker[THEN a_Hcarr]

  from x
      have "h x = h (i \<oplus> a)" by simp
  also from carr
      have "\<dots> = h i \<oplus>\<^bsub>S\<^esub> h a" by simp
  also from iker
      have "\<dots> = \<zero>\<^bsub>S\<^esub> \<oplus>\<^bsub>S\<^esub> h a" by simp
  also from carr
      have "\<dots> = h a" by simp
  finally
      show "h x = h a" .
qed

lemma (in ring_hom_ring) homeq_imp_rcos:
  assumes acarr: "a \<in> carrier R"
      and xcarr: "x \<in> carrier R"
      and hx: "h x = h a"
  shows "x \<in> a_kernel R S h +> a"
proof -
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  note carr = acarr xcarr
  note hcarr = acarr[THEN hom_closed] xcarr[THEN hom_closed]

  from hx and hcarr
      have a: "h x \<oplus>\<^bsub>S\<^esub> \<ominus>\<^bsub>S\<^esub>h a = \<zero>\<^bsub>S\<^esub>" by algebra
  from carr
      have "h x \<oplus>\<^bsub>S\<^esub> \<ominus>\<^bsub>S\<^esub>h a = h (x \<oplus> \<ominus>a)" by simp
  from a and this
      have b: "h (x \<oplus> \<ominus>a) = \<zero>\<^bsub>S\<^esub>" by simp

  from carr have "x \<oplus> \<ominus>a \<in> carrier R" by simp
  from this and b
      have "x \<oplus> \<ominus>a \<in> a_kernel R S h"
      unfolding a_kernel_def'
      by fast

  from this and carr
      show "x \<in> a_kernel R S h +> a" by (simp add: a_rcos_module_rev)
qed

corollary (in ring_hom_ring) rcos_eq_homeq:
  assumes acarr: "a \<in> carrier R"
  shows "(a_kernel R S h) +> a = {x \<in> carrier R. h x = h a}"
apply rule defer 1
apply clarsimp defer 1
proof
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  fix x
  assume xrcos: "x \<in> a_kernel R S h +> a"
  from acarr and this
      have xcarr: "x \<in> carrier R"
      by (rule a_elemrcos_carrier)

  from xrcos
      have "h x = h a" by (rule rcos_imp_homeq[OF acarr])
  from xcarr and this
      show "x \<in> {x \<in> carrier R. h x = h a}" by fast
next
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  fix x
  assume xcarr: "x \<in> carrier R"
     and hx: "h x = h a"
  from acarr xcarr hx
      show "x \<in> a_kernel R S h +> a" by (rule homeq_imp_rcos)
qed

end


theory ConcreteSemantics9_1_Ex3
  imports "~~/src/HOL/IMP/Star" Complex_Main
begin
section "A Typed Language"

theory Types imports Star Complex_Main begin

text \<open>We build on \<^theory>\<open>Complex_Main\<close> instead of \<^theory>\<open>Main\<close> to access
the real numbers.\<close>

subsection "Arithmetic Expressions"

datatype val = Iv int | Rv real

type_synonym vname = string
type_synonym state = "vname \<Rightarrow> val"

text_raw\<open>\snip{aexptDef}{0}{2}{%\<close>
datatype aexp =  Ic int | Rc real | V vname | Plus aexp aexp
text_raw\<open>}%endsnip\<close>

inductive taval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"taval (Ic i) s (Iv i)" |
"taval (Rc r) s (Rv r)" |
"taval (V x) s (s x)" |
"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2)
 \<Longrightarrow> taval (Plus a1 a2) s (Iv(i1+i2))" |
"taval a1 s (Rv r1) \<Longrightarrow> taval a2 s (Rv r2)
 \<Longrightarrow> taval (Plus a1 a2) s (Rv(r1+r2))"

inductive_cases [elim!]:
  "taval (Ic i) s v"  "taval (Rc i) s v"
  "taval (V x) s v"
  "taval (Plus a1 a2) s v"

subsection "Boolean Expressions"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

inductive tbval :: "bexp \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool" where
"tbval (Bc v) s v" |
"tbval b s bv \<Longrightarrow> tbval (Not b) s (\<not> bv)" |
"tbval b1 s bv1 \<Longrightarrow> tbval b2 s bv2 \<Longrightarrow> tbval (And b1 b2) s (bv1 & bv2)" |
"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2) \<Longrightarrow> tbval (Less a1 a2) s (i1 < i2)" |
"taval a1 s (Rv r1) \<Longrightarrow> taval a2 s (Rv r2) \<Longrightarrow> tbval (Less a1 a2) s (r1 < r2)"

subsection "Syntax of Commands"
(* a copy of Com.thy - keep in sync! *)

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;; _"  [60, 61] 60)
      | If     bexp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  bexp com         ("WHILE _ DO _"  [0, 61] 61)
      | Repeat  com bexp         ("(REPEAT _/ UNTIL _)"  [0, 61] 61)

subsection "Small-Step Semantics of Commands"

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "taval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |

IfTrue:  "tbval b s True \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "tbval b s False \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |
Repeat: "(REPEAT c UNTIL b, s) \<rightarrow> (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

subsection "The Type System"

datatype ty = Ity | Rty

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive atyping :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
where
Ic_ty: "\<Gamma> \<turnstile> Ic i : Ity" |
Rc_ty: "\<Gamma> \<turnstile> Rc r : Rty" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
Plus_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : \<tau>"

declare atyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> Ic i : \<tau>" "\<Gamma> \<turnstile> Rc r : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>"

text\<open>Warning: the ``:'' notation leads to syntactic ambiguities,
i.e. multiple parse trees, because ``:'' also stands for set membership.
In most situations Isabelle's type system will reject all but one parse tree,
but will still inform you of the potential ambiguity.\<close>

inductive btyping :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" (infix "\<turnstile>" 50)
where
B_ty: "\<Gamma> \<turnstile> Bc v" |
Not_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> Not b" |
And_ty: "\<Gamma> \<turnstile> b1 \<Longrightarrow> \<Gamma> \<turnstile> b2 \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2" |
Less_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2"

declare btyping.intros [intro!]
inductive_cases [elim!]: "\<Gamma> \<turnstile> Not b" "\<Gamma> \<turnstile> And b1 b2" "\<Gamma> \<turnstile> Less a1 a2"

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
If_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c" |
Repeat_typ: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> REPEAT c UNTIL b"

declare ctyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"
  "\<Gamma> \<turnstile> REPEAT c UNTIL b"

subsection "Well-typed Programs Do Not Get Stuck"

fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Rv r) = Rty"

lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
by (cases v) simp_all

lemma type_eq_Rty[simp]: "type v = Rty \<longleftrightarrow> (\<exists>r. v = Rv r)"
by (cases v) simp_all

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"

lemma apreservation:
  "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> taval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
apply(induction arbitrary: v rule: atyping.induct)
apply (fastforce simp: styping_def)+
done

lemma aprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. taval a s v"
proof(induction rule: atyping.induct)
  case (Plus_ty \<Gamma> a1 t a2)
  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2" by blast
  show ?case
  proof (cases v1)
    case Iv
    with Plus_ty v show ?thesis
      by(fastforce intro: taval.intros(4) dest!: apreservation)
  next
    case Rv
    with Plus_ty v show ?thesis
      by(fastforce intro: taval.intros(5) dest!: apreservation)
  qed
qed (auto intro: taval.intros)

lemma bprogress: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. tbval b s v"
proof(induction rule: btyping.induct)
  case (Less_ty \<Gamma> a1 t a2)
  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2"
    by (metis aprogress)
  show ?case
  proof (cases v1)
    case Iv
    with Less_ty v show ?thesis
      by (fastforce intro!: tbval.intros(4) dest!:apreservation)
  next
    case Rv
    with Less_ty v show ?thesis
      by (fastforce intro!: tbval.intros(5) dest!:apreservation)
  qed
qed (auto intro: tbval.intros)

theorem progress:
  "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
proof(induction rule: ctyping.induct)
  case Skip_ty thus ?case by simp
next
  case Assign_ty
  thus ?case by (metis Assign aprogress)
next
  case Seq_ty thus ?case by simp (metis Seq1 Seq2)
next
  case (If_ty \<Gamma> b c1 c2)
  then obtain bv where "tbval b s bv" by (metis bprogress)
  show ?case
  proof(cases bv)
    assume "bv"
    with \<open>tbval b s bv\<close> show ?case by simp (metis IfTrue)
  next
    assume "\<not>bv"
    with \<open>tbval b s bv\<close> show ?case by simp (metis IfFalse)
  qed
next
  case While_ty show ?case by (metis While)
next
  case (Repeat_typ \<Gamma> b c)
  then show ?case
    using Repeat by blast
qed

theorem styping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
proof(induction rule: small_step_induct)
  case Assign thus ?case
    by (auto simp: styping_def) (metis Assign(1,3) apreservation)
qed auto

theorem ctyping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
  by (induct rule: small_step_induct) (auto simp: ctyping.intros)

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

theorem type_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
apply(induction rule:star_induct)
apply (metis progress)
by (metis styping_preservation ctyping_preservation)
end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
(*TODO: Rename! *)
section \<open>Gauss Lemma\<close>

text \<open>We formalized Gauss Lemma, that the content of a product of two polynomials $p$ and $q$
  is the product of the contents of $p$ and $q$. As a corollary we provide an algorithm
  to convert a rational factor of an integer polynomial into an integer factor.

  In contrast to the theory on unique factorization domains -- where Gauss Lemma is also proven
   in a more generic setting --
  we are here in an executable setting and do not use the unspecified $some-gcd$ function.
  Moreover, there is a slight difference in the definition of content: in this theory it is only
  defined for integer-polynomials, whereas in the UFD theory, the content is defined for
  polynomials in the fraction field.\<close>

theory Gauss_Lemma
imports
  "HOL-Computational_Algebra.Primes"
  Polynomial_Interpolation.Ring_Hom_Poly
  Missing_Polynomial_Factorial
begin

lemma primitive_part_alt_def:
  "primitive_part p = sdiv_poly p (content p)"
  by (simp add: primitive_part_def sdiv_poly_def)

definition common_denom :: "rat list \<Rightarrow> int \<times> int list" where
  "common_denom xs \<equiv> let
     nds = map quotient_of xs;
     denom = list_lcm (map snd nds);
     ints = map (\<lambda> (n,d). n * denom div d) nds
   in (denom, ints)"

definition rat_to_int_poly :: "rat poly \<Rightarrow> int \<times> int poly" where
  "rat_to_int_poly p \<equiv> let
     ais = coeffs p;
     d = fst (common_denom ais)
   in (d, map_poly (\<lambda> x. case quotient_of x of (p,q) \<Rightarrow> p * d div q) p)"

definition rat_to_normalized_int_poly :: "rat poly \<Rightarrow> rat \<times> int poly" where
  "rat_to_normalized_int_poly p \<equiv> if p = 0 then (1,0) else case rat_to_int_poly p of (s,q)
    \<Rightarrow> (of_int (content q) / of_int s, primitive_part q)"

lemma rat_to_normalized_int_poly_code[code]:
  "rat_to_normalized_int_poly p = (if p = 0 then (1,0) else case rat_to_int_poly p of (s,q)
    \<Rightarrow> let c = content q in (of_int c / of_int s, sdiv_poly q c))"
    unfolding Let_def rat_to_normalized_int_poly_def primitive_part_alt_def ..

lemma common_denom: assumes cd: "common_denom xs = (dd,ys)"
  shows "xs = map (\<lambda> i. of_int i / of_int dd) ys" "dd > 0"
  "\<And>x. x \<in> set xs \<Longrightarrow> rat_of_int (case quotient_of x of (n, x) \<Rightarrow> n * dd div x) / rat_of_int dd = x"
proof -
  let ?nds = "map quotient_of xs"
  define nds where "nds = ?nds"
  let ?denom = "list_lcm (map snd nds)"
  let ?ints = "map (\<lambda> (n,d). n * dd div d) nds"
  from cd[unfolded common_denom_def Let_def]
  have dd: "dd = ?denom" and ys: "ys = ?ints" unfolding nds_def by auto
  show dd0: "dd > 0" unfolding dd
    by (intro list_lcm_pos(3), auto simp: nds_def quotient_of_nonzero)
  {
    fix x
    assume x: "x \<in> set xs"
    obtain p q where quot: "quotient_of x = (p,q)" by force
    from x have "(p,q) \<in> set nds" unfolding nds_def using quot by force
    hence "q \<in> set (map snd nds)" by force
    from list_lcm[OF this] have q: "q dvd dd" unfolding dd .
    show "rat_of_int (case quotient_of x of (n, x) \<Rightarrow> n * dd div x) / rat_of_int dd = x"
      unfolding quot split unfolding quotient_of_div[OF quot]
    proof -
      have f1: "q * (dd div q) = dd"
        using dvd_mult_div_cancel q by blast
      have "rat_of_int (dd div q) \<noteq> 0"
        using dd0 dvd_mult_div_cancel q by fastforce
      thus "rat_of_int (p * dd div q) / rat_of_int dd = rat_of_int p / rat_of_int q"
        using f1 by (metis (no_types) div_mult_swap mult_divide_mult_cancel_right of_int_mult q)
    qed
  } note main = this
  show "xs = map (\<lambda> i. of_int i / of_int dd) ys" unfolding ys map_map o_def nds_def
    by (rule sym, rule map_idI, rule main)
qed

lemma rat_to_int_poly: assumes "rat_to_int_poly p = (d,q)"
  shows "p = smult (inverse (of_int d)) (map_poly of_int q)" "d > 0"
proof -
  let ?f = "\<lambda> x. case quotient_of x of (pa, x) \<Rightarrow> pa * d div x"
  define f where "f = ?f"
  from assms[unfolded rat_to_int_poly_def Let_def]
    obtain xs where cd: "common_denom (coeffs p) = (d,xs)"
    and q: "q = map_poly f p" unfolding f_def by (cases "common_denom (coeffs p)", auto)
  from common_denom[OF cd] have d: "d > 0"  and
    id: "\<And> x. x \<in> set (coeffs p) \<Longrightarrow> rat_of_int (f x) / rat_of_int d = x"
    unfolding f_def by auto
  have f0: "f 0 = 0" unfolding f_def by auto
  have id: "rat_of_int (f (coeff p n)) / rat_of_int d = coeff p n" for n
    using id[of "coeff p n"] f0 range_coeff by (cases "coeff p n = 0", auto)
  show "d > 0" by fact
  show "p = smult (inverse (of_int d)) (map_poly of_int q)"
    unfolding q smult_as_map_poly using id f0
    by (intro poly_eqI, auto simp: field_simps coeff_map_poly)
qed

lemma content_ge_0_int: "content p \<ge> (0 :: int)"
  unfolding content_def
  by (cases "coeffs p", auto)

lemma abs_content_int[simp]: fixes p :: "int poly"
  shows "abs (content p) = content p" using content_ge_0_int[of p] by auto

lemma content_smult_int: fixes p :: "int poly"
  shows "content (smult a p) = abs a * content p" by simp

lemma normalize_non_0_smult: "\<exists> a. (a :: 'a :: semiring_gcd) \<noteq> 0 \<and> smult a (primitive_part p) = p"
  by (cases "p = 0", rule exI[of _ 1], simp, rule exI[of _ "content p"], auto)

lemma rat_to_normalized_int_poly: assumes "rat_to_normalized_int_poly p = (d,q)"
  shows "p = smult d (map_poly of_int q)" "d > 0" "p \<noteq> 0 \<Longrightarrow> content q = 1" "degree q = degree p"
proof -
  have "p = smult d (map_poly of_int q) \<and> d > 0 \<and> (p \<noteq> 0 \<longrightarrow> content q = 1)"
  proof (cases "p = 0")
    case True
    thus ?thesis using assms unfolding rat_to_normalized_int_poly_def
      by (auto simp: eval_poly_def)
  next
    case False
    hence p0: "p \<noteq> 0" by auto
    obtain s r where id: "rat_to_int_poly p = (s,r)" by force
    let ?cr = "rat_of_int (content r)"
    let ?s = "rat_of_int s"
    let ?q = "map_poly rat_of_int q"
    from rat_to_int_poly[OF id] have p: "p = smult (inverse ?s) (map_poly of_int r)"
    and s: "s > 0" by auto
    let ?q = "map_poly rat_of_int q"
    from p0 assms[unfolded rat_to_normalized_int_poly_def id split]
    have d: "d = ?cr / ?s" and q: "q = primitive_part r" by auto
    from content_times_primitive_part[of r, folded q] have qr: "smult (content r) q = r" .
    have "smult d ?q = smult (?cr / ?s) ?q"
      unfolding d by simp
    also have "?cr / ?s = ?cr * inverse ?s" by (rule divide_inverse)
    also have "\<dots> = inverse ?s * ?cr" by simp
    also have "smult (inverse ?s * ?cr) ?q = smult (inverse ?s) (smult ?cr ?q)" by simp
    also have "smult ?cr ?q = map_poly of_int (smult (content r) q)" by (simp add: hom_distribs)
    also have "\<dots> = map_poly of_int r" unfolding qr ..
    finally have pq: "p = smult d ?q" unfolding p by simp
    from p p0 have r0: "r \<noteq> 0" by auto
    from content_eq_zero_iff[of r] content_ge_0_int[of r] r0 have cr: "?cr > 0" by linarith
    with s have d0: "d > 0" unfolding d by auto
    from content_primitive_part[OF r0] have cq: "content q = 1" unfolding q .
    from pq d0 cq show ?thesis by auto
  qed
  thus p: "p = smult d (map_poly of_int q)" and d: "d > 0" and "p \<noteq> 0 \<Longrightarrow> content q = 1" by auto
  show "degree q = degree p" unfolding p smult_as_map_poly
    by (rule sym, subst map_poly_map_poly, force+, rule degree_map_poly, insert d, auto)
qed

lemma content_dvd_1:
  "content g = 1" if "content f = (1 :: 'a :: semiring_gcd)" "g dvd f"
proof -
  from \<open>g dvd f\<close> have "content g dvd content f"
    by (rule content_dvd_contentI)
  with \<open>content f = 1\<close> show ?thesis
    by simp
qed

lemma dvd_smult_int: fixes c :: int assumes c: "c \<noteq> 0"
  and dvd: "q dvd (smult c p)"
  shows "primitive_part q dvd p"
proof (cases "p = 0")
  case True thus ?thesis by auto
next
  case False note p0 = this
  let ?cp = "smult c p"
  from p0 c have cp0: "?cp \<noteq> 0" by auto
  from dvd obtain r where prod: "?cp = q * r" unfolding dvd_def by auto
  from prod cp0 have q0: "q \<noteq> 0" and r0: "r \<noteq> 0" by auto
  let ?c = "content :: int poly \<Rightarrow> int"
  let ?n = "primitive_part :: int poly \<Rightarrow> int poly"
  let ?pn = "\<lambda> p. smult (?c p) (?n p)"
  have cq: "(?c q = 0) = False" using content_eq_zero_iff q0 by auto
  from prod have id1: "?cp = ?pn q * ?pn r" unfolding content_times_primitive_part by simp
  from arg_cong[OF this, of content, unfolded content_smult_int content_mult
    content_primitive_part[OF r0] content_primitive_part[OF q0], symmetric]
    p0[folded content_eq_zero_iff] c
  have "abs c dvd ?c q * ?c r" unfolding dvd_def by auto
  hence "c dvd ?c q * ?c r" by auto
  then obtain d where id: "?c q * ?c r = c * d" unfolding dvd_def by auto
  have "?cp = ?pn q * ?pn r" by fact
  also have "\<dots> = smult (c * d) (?n q * ?n r)" unfolding id [symmetric]
    by (metis content_mult content_times_primitive_part primitive_part_mult)
  finally have id: "?cp = smult c (?n q * smult d (?n r))" by (simp add: mult.commute)
  interpret map_poly_inj_zero_hom "(*) c" using c by (unfold_locales, auto)
  have "p = ?n q * smult d (?n r)" using id[unfolded smult_as_map_poly[of c]] by auto
  thus dvd: "?n q dvd p" unfolding dvd_def by blast
qed

lemma irreducible\<^sub>d_primitive_part:
  fixes p :: "int poly" (* can be relaxed but primitive_part_mult has bad type constraint *)
  shows "irreducible\<^sub>d (primitive_part p) \<longleftrightarrow> irreducible\<^sub>d p" (is "?l \<longleftrightarrow> ?r")
proof (rule iffI, rule irreducible\<^sub>dI)
  assume l: ?l
  show "degree p > 0" using l by auto
  have dpp: "degree (primitive_part p) = degree p" by simp
  fix q r
  assume deg: "degree q < degree p" "degree r < degree p" and "p = q * r"
  then have pp: "primitive_part p = primitive_part q * primitive_part r" by (simp add: primitive_part_mult)
  have "\<not> irreducible\<^sub>d (primitive_part p)"
    apply (intro reducible\<^sub>dI, rule exI[of _ "primitive_part q"], rule exI[of _ "primitive_part r"], unfold dpp)
    using deg pp by auto
  with l show False by auto
next
  show "?r \<Longrightarrow> ?l" by (metis irreducible\<^sub>d_smultI normalize_non_0_smult)
qed

lemma irreducible\<^sub>d_smult_int:
  fixes c :: int assumes c: "c \<noteq> 0"
  shows "irreducible\<^sub>d (smult c p) = irreducible\<^sub>d p" (is "?l = ?r")
  using irreducible\<^sub>d_primitive_part[of "smult c p", unfolded primitive_part_smult] c
  apply (cases "c < 0", simp)
  apply (metis add.inverse_inverse add.inverse_neutral c irreducible\<^sub>d_smultI normalize_non_0_smult smult_1_left smult_minus_left)
  apply (simp add: irreducible\<^sub>d_primitive_part)
  done

lemma irreducible\<^sub>d_as_irreducible:
  fixes p :: "int poly"
  shows "irreducible\<^sub>d p \<longleftrightarrow> irreducible (primitive_part p)"
  using irreducible_primitive_connect[of "primitive_part p"]
  by (cases "p = 0", auto simp: irreducible\<^sub>d_primitive_part)

lemma rat_to_int_factor_content_1: fixes p :: "int poly"
  assumes cp: "content p = 1"
  and pgh: "map_poly rat_of_int p = g * h"
  and g: "rat_to_normalized_int_poly g = (r,rg)"
  and h: "rat_to_normalized_int_poly h = (s,sh)"
  and p: "p \<noteq> 0"
  shows "p = rg * sh"
proof -
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  from p have rp0: "?rp p \<noteq> 0" by simp
  with pgh have g0: "g \<noteq> 0" and h0: "h \<noteq> 0" by auto
  from rat_to_normalized_int_poly[OF g] g0
  have r: "r > 0" "r \<noteq> 0" and g: "g = smult r (?rp rg)" and crg: "content rg = 1" by auto
  from rat_to_normalized_int_poly[OF h] h0
  have s: "s > 0" "s \<noteq> 0" and h: "h = smult s (?rp sh)" and csh: "content sh = 1" by auto
  let ?irs = "inverse (r * s)"
  from r s have irs0: "?irs \<noteq> 0" by (auto simp: field_simps)
  have "?rp (rg * sh) = ?rp rg * ?rp sh" by (simp add: hom_distribs)
  also have "\<dots> = smult ?irs (?rp p)" unfolding pgh g h using r s
    by (simp add: field_simps)
  finally have id: "?rp (rg * sh) = smult ?irs (?rp p)" by auto
  have rsZ: "?irs \<in> \<int>"
  proof (rule ccontr)
    assume not: "\<not> ?irs \<in> \<int>"
    obtain n d where irs': "quotient_of ?irs = (n,d)" by force
    from quotient_of_denom_pos[OF irs'] have "d > 0" .
    from not quotient_of_div[OF irs'] have "d \<noteq> 1" "d \<noteq> 0" and irs: "?irs = ?r n / ?r d" by auto
    with irs0 have n0: "n \<noteq> 0" by auto
    from \<open>d > 0\<close> \<open>d \<noteq> 1\<close> have "d \<ge> 2" and "\<not> d dvd 1" by auto
    with content_iff[of d p, unfolded cp] obtain c where
      c: "c \<in> set (coeffs p)" and dc: "\<not> d dvd c"
      by auto
    from c range_coeff[of p] obtain i where "c = coeff p i" by auto
    from arg_cong[OF id, of "\<lambda> p. coeff p i",
      unfolded coeff_smult of_int_hom.coeff_map_poly_hom this[symmetric] irs]
    have "?r n / ?r d * ?r c \<in> \<int>" by (metis Ints_of_int)
    also have "?r n / ?r d * ?r c = ?r (n * c) / ?r d" by simp
    finally have inZ: "?r (n * c) / ?r d \<in> \<int>" .
    have cop: "coprime n d" by (rule quotient_of_coprime[OF irs'])
    (* now there comes tedious reasoning that `coprime n d` `\<not> d dvd c` ` nc / d \<in> \<int>` yields a
       contradiction *)
    define prod where "prod = ?r (n * c) / ?r d"
    obtain n' d' where quot: "quotient_of prod = (n',d')" by force
    have qr: "\<And> x. quotient_of (?r x) = (x, 1)"
      using Rat.of_int_def quotient_of_int by auto
    from quotient_of_denom_pos[OF quot] have "d' > 0" .
    with quotient_of_div[OF quot] inZ[folded prod_def] have "d' = 1"
      by (metis Ints_cases Rat.of_int_def old.prod.inject quot quotient_of_int)
    with quotient_of_div[OF quot] have "prod = ?r n'" by auto
    from arg_cong[OF this, of quotient_of, unfolded prod_def rat_divide_code qr Let_def split]
    have "Rat.normalize (n * c, d) = (n',1)" by simp
    from normalize_crossproduct[OF \<open>d \<noteq> 0\<close>, of 1 "n * c" n', unfolded this]
    have id: "n * c = n' * d" by auto
    from quotient_of_coprime[OF irs'] have "coprime n d" .
    with id have "d dvd c"
      by (metis coprime_commute coprime_dvd_mult_right_iff dvd_triv_right)
    with dc show False ..
  qed
  then obtain irs where irs: "?irs = ?r irs" unfolding Ints_def by blast
  from id[unfolded irs, folded hom_distribs, unfolded of_int_poly_hom.eq_iff]
  have p: "rg * sh = smult irs p" by auto
  have "content (rg * sh) = 1" unfolding content_mult crg csh by auto
  from this[unfolded p content_smult_int cp] have "abs irs = 1" by simp
  hence "abs ?irs = 1" using irs by auto
  with r s have "?irs = 1" by auto
  with irs have "irs = 1" by auto
  with p show p: "p = rg * sh" by auto
qed

lemma rat_to_int_factor_explicit: fixes p :: "int poly"
  assumes pgh: "map_poly rat_of_int p = g * h"
  and g: "rat_to_normalized_int_poly g = (r,rg)"
  shows "\<exists> r. p = rg * smult (content p) r"
proof -
  show ?thesis
  proof (cases "p = 0")
    case True
    show ?thesis unfolding True
      by (rule exI[of _ 0], auto simp: degree_monom_eq)
  next
    case False
    hence p: "p \<noteq> 0" by auto
    let ?r = "rat_of_int"
    let ?rp = "map_poly ?r"
    define q where "q = primitive_part p"
    from content_times_primitive_part[of p, folded q_def] content_eq_zero_iff[of p] p
      obtain a where a: "a \<noteq> 0" and pq: "p = smult a q" and acp: "content p = a" by metis
    from a pq p have ra: "?r a \<noteq> 0" and q0: "q \<noteq> 0" by auto
    from content_primitive_part[OF p, folded q_def] have cq: "content q = 1" by auto
    obtain s sh where h: "rat_to_normalized_int_poly (smult (inverse (?r a)) h) = (s,sh)" by force
    from arg_cong[OF pgh[unfolded pq], of "smult (inverse (?r a))"] ra
    have "?rp q = g * smult (inverse (?r a)) h" by (auto simp: hom_distribs)
    from rat_to_int_factor_content_1[OF cq this g h q0]
    have qrs: "q = rg * sh" .
    show ?thesis unfolding acp unfolding pq qrs
      by (rule exI[of _ sh], auto)
  qed
qed

lemma rat_to_int_factor: fixes p :: "int poly"
  assumes pgh: "map_poly rat_of_int p = g * h"
  shows "\<exists> g' h'. p = g' * h' \<and> degree g' = degree g \<and> degree h' = degree h"
proof(cases "p = 0")
  case True
  with pgh have "g = 0 \<or> h = 0" by auto
  then show ?thesis
    by (metis True degree_0 mult_hom.hom_zero mult_zero_left rat_to_normalized_int_poly(4) surj_pair)
next
  case False
  obtain r rg where ri: "rat_to_normalized_int_poly (smult (1 / of_int (content p)) g) = (r,rg)" by force
  obtain q qh where ri2: "rat_to_normalized_int_poly h = (q,qh)" by force
  show ?thesis
  proof (intro exI conjI)
    have "of_int_poly (primitive_part p) = smult (1 / of_int (content p)) (g * h)"
      apply (auto simp: primitive_part_def pgh[symmetric] smult_map_poly map_poly_map_poly o_def intro!: map_poly_cong)
      by (metis (no_types, lifting) content_dvd_coeffs div_by_0 dvd_mult_div_cancel floor_of_int nonzero_mult_div_cancel_left of_int_hom.hom_zero of_int_mult)
    also have "\<dots> = smult (1 / of_int (content p)) g * h" by simp
    finally have "of_int_poly (primitive_part p) = \<dots>".
    note main = rat_to_int_factor_content_1[OF _ this ri ri2, simplified, OF False]
    show "p = smult (content p) rg * qh" by (simp add: main[symmetric])
    from ri2 show "degree qh = degree h" by (fact rat_to_normalized_int_poly)
    from rat_to_normalized_int_poly(4)[OF ri] False
    show "degree (smult (content p) rg) = degree g" by auto
  qed
qed

lemma rat_to_int_factor_normalized_int_poly: fixes p :: "rat poly"
  assumes pgh: "p = g * h"
  and p: "rat_to_normalized_int_poly p = (i,ip)"
  shows "\<exists> g' h'. ip = g' * h' \<and> degree g' = degree g"
proof -
  from rat_to_normalized_int_poly[OF p]
  have p: "p = smult i (map_poly rat_of_int ip)" and i: "i \<noteq> 0" by auto
  from arg_cong[OF p, of "smult (inverse i)", unfolded pgh] i
  have "map_poly rat_of_int ip = g * smult (inverse i) h" by auto
  from rat_to_int_factor[OF this] show ?thesis by auto
qed

(* TODO: move *)
lemma irreducible_smult [simp]:
  fixes c :: "'a :: field"
  shows "irreducible (smult c p) \<longleftrightarrow> irreducible p \<and> c \<noteq> 0"
  using irreducible_mult_unit_left[of "[:c:]", simplified] by force

text \<open>A polynomial with integer coefficients is
   irreducible over the rationals, if it is irreducible over the integers.\<close>
theorem irreducible\<^sub>d_int_rat: fixes p :: "int poly"
  assumes p: "irreducible\<^sub>d p"
  shows "irreducible\<^sub>d (map_poly rat_of_int p)"
proof (rule irreducible\<^sub>dI)
  from irreducible\<^sub>dD[OF p]
  have p: "degree p \<noteq> 0" and irr: "\<And> q r. degree q < degree p \<Longrightarrow> degree r < degree p \<Longrightarrow> p \<noteq> q * r" by auto
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  from p show rp: "degree (?rp p) > 0" by auto
  from p have p0: "p \<noteq> 0" by auto
  fix g h :: "rat poly"
  assume deg: "degree g > 0" "degree g < degree (?rp p)" "degree h > 0" "degree h < degree (?rp p)" and pgh: "?rp p = g * h"
  from rat_to_int_factor[OF pgh] obtain g' h' where p: "p = g' * h'" and dg: "degree g' = degree g" "degree h' = degree h"
    by auto
  from irr[of g' h'] deg[unfolded dg]
  show False using degree_mult_eq[of g' h'] by (auto simp: p dg)
qed

corollary irreducible\<^sub>d_rat_to_normalized_int_poly:
  assumes rp: "rat_to_normalized_int_poly rp = (a, ip)"
  and ip: "irreducible\<^sub>d ip"
  shows "irreducible\<^sub>d rp"
proof -
  from rat_to_normalized_int_poly[OF rp]
  have rp: "rp = smult a (map_poly rat_of_int ip)" and a: "a \<noteq> 0" by auto
  with irreducible\<^sub>d_int_rat[OF ip] show ?thesis by auto
qed

lemma dvd_content_dvd: assumes dvd: "content f dvd content g" "primitive_part f dvd primitive_part g"
  shows "f dvd g"
proof -
  let ?cf = "content f" let ?nf = "primitive_part f"
  let ?cg = "content g" let ?ng = "primitive_part g"
  have "f dvd g = (smult ?cf ?nf dvd smult ?cg ?ng)"
    unfolding content_times_primitive_part by auto
  from dvd(1) obtain ch where cg: "?cg = ?cf * ch" unfolding dvd_def by auto
  from dvd(2) obtain nh where ng: "?ng = ?nf * nh" unfolding dvd_def by auto
  have "f dvd g = (smult ?cf ?nf dvd smult ?cg ?ng)"
    unfolding content_times_primitive_part[of f] content_times_primitive_part[of g] by auto
  also have "\<dots> = (smult ?cf ?nf dvd smult ?cf ?nf * smult ch nh)" unfolding cg ng
    by (metis mult.commute mult_smult_right smult_smult)
  also have "\<dots>" by (rule dvd_triv_left)
  finally show ?thesis .
qed

lemma sdiv_poly_smult: "c \<noteq> 0 \<Longrightarrow> sdiv_poly (smult c f) c = f"
  by (intro poly_eqI, unfold coeff_sdiv_poly coeff_smult, auto)

lemma primitive_part_smult_int: fixes f :: "int poly" shows
  "primitive_part (smult d f) = smult (sgn d) (primitive_part f)"
proof (cases "d = 0 \<or> f = 0")
  case False
  obtain cf where cf: "content f = cf" by auto
  with False have 0: "d \<noteq> 0" "f \<noteq> 0" "cf \<noteq> 0" by auto
  show ?thesis
  proof (rule poly_eqI, unfold primitive_part_alt_def coeff_sdiv_poly content_smult_int coeff_smult cf)
    fix n
    consider (pos) "d > 0" | (neg) "d < 0" using 0(1) by linarith
    thus "d * coeff f n div (\<bar>d\<bar> * cf) = sgn d * (coeff f n div cf)"
    proof cases
      case neg
      hence "?thesis = (d * coeff f n div - (d * cf) = - (coeff f n div cf))" by auto
      also have "d * coeff f n div - (d * cf) = - (d * coeff f n div (d * cf))"
        by (subst dvd_div_neg, insert 0(1), auto simp: cf[symmetric])
      also have "d * coeff f n div (d * cf) = coeff f n div cf" using 0(1) by auto
      finally show ?thesis by simp
    qed auto
  qed
qed auto

end