theory Policy_Iteration_Fin
  imports
    Policy_Iteration
    MDP_fin
    Blinfun_To_Matrix
begin

context MDP_nat_disc begin

lemma finite_D\<^sub>D[simp]: "finite D\<^sub>D"
proof -
  let ?set = "{d. \<forall>x :: nat. (x \<in> {0..<states} \<longrightarrow> d x \<in> (\<Union>s\<in>{0..<states}. A s)) \<and> (x \<notin> {0..<states} \<longrightarrow> d x = 0)}"
  have "finite (\<Union>s<states. A s)"
    using A_fin by auto
  hence "finite ?set"
    by (intro finite_set_of_finite_funs) auto
  moreover have "D\<^sub>D \<subseteq> ?set"
    unfolding is_dec_det_def
    using A_outside
    by (auto simp: not_less)
  ultimately show ?thesis
    using finite_subset
    by auto
qed

lemma finite_rel: "finite {(u, v). is_dec_det u \<and> is_dec_det v \<and> \<nu>\<^sub>b (mk_stationary_det u) > \<nu>\<^sub>b (mk_stationary_det v)}"
proof-
  have aux: "finite {(u, v). is_dec_det u \<and> is_dec_det v}"
    by auto
  show ?thesis
    by (auto intro: finite_subset[OF _ aux])
qed

lemma eval_eq_imp_policy_eq:
  assumes "policy_eval d = policy_eval (policy_step d)" "is_dec_det d"
  shows "d = policy_step d"
proof -
  have "policy_eval d s = policy_eval (policy_step d) s" for s
    using assms
    by auto
  have "policy_eval d = L (mk_dec_det d) (policy_eval (policy_step d))"
    unfolding policy_eval_def
    using L_\<nu>_fix
    by (auto simp: assms(1)[symmetric, unfolded policy_eval_def])
  hence "policy_eval d = \<L>\<^sub>b (policy_eval d)"
    by (metis L_\<nu>_fix policy_eval_def assms eval_policy_step_L)
  hence "L (mk_dec_det d) (policy_eval d) s = \<L>\<^sub>b (policy_eval d) s" for s
    using \<open>policy_eval d = L (mk_dec_det d) (policy_eval (policy_step d))\<close> assms(1) by auto
  hence "is_arg_max (\<lambda>a. L\<^sub>a a (\<nu>\<^sub>b (mk_stationary (mk_dec_det d))) s) (\<lambda>a. a \<in> A s) (d s)" for s
    unfolding L_eq_L\<^sub>a_det
    unfolding policy_eval_def \<L>\<^sub>b.rep_eq \<L>_eq_SUP_det SUP_step_det_eq
    using assms(2) is_dec_det_def L\<^sub>a_le
    by (auto simp del: \<nu>\<^sub>b.rep_eq simp: \<nu>\<^sub>b.rep_eq[symmetric]
        intro!: SUP_is_arg_max boundedI[of _ "r\<^sub>M + l * norm _"] bounded_imp_bdd_above)
  thus ?thesis
    unfolding policy_eval_def policy_step_def policy_improvement_def
    by auto
qed

termination policy_iteration
proof (relation "{(u, v). u \<in> D\<^sub>D \<and> v \<in> D\<^sub>D \<and> \<nu>\<^sub>b (mk_stationary_det u) > \<nu>\<^sub>b (mk_stationary_det v)}")
  show "wf {(u, v). u \<in> D\<^sub>D \<and> v \<in> D\<^sub>D \<and> \<nu>\<^sub>b (mk_stationary_det v) < \<nu>\<^sub>b (mk_stationary_det u)}"
    using finite_rel
    by (auto intro!: finite_acyclic_wf acyclicI_order)
next
  fix d x
  assume h: "x = policy_step d" "\<not> (d = x \<or> \<not> is_dec_det d)"
  have "is_dec_det d \<Longrightarrow> \<nu>\<^sub>b (mk_stationary_det d) \<le> \<nu>\<^sub>b (mk_stationary_det (policy_step d))"
    using policy_eval_mon
    by (simp add: policy_eval_def)
  hence "is_dec_det d \<Longrightarrow> d \<noteq> policy_step d \<Longrightarrow>
    \<nu>\<^sub>b (mk_stationary_det d) < \<nu>\<^sub>b (mk_stationary_det (policy_step d))"
    using eval_eq_imp_policy_eq policy_eval_def
    by (force intro!: order.not_eq_order_implies_strict)
  thus "(x, d) \<in> {(u, v). u \<in> D\<^sub>D \<and> v \<in> D\<^sub>D \<and> \<nu>\<^sub>b (mk_stationary_det v) < \<nu>\<^sub>b (mk_stationary_det u)}"
    using is_dec_det_pi policy_step_def h
    by auto
qed

lemma is_dec_det_pi': "d \<in> D\<^sub>D \<Longrightarrow> is_dec_det (policy_iteration d)"
  using is_dec_det_pi
  by (induction d rule: policy_iteration.induct) (auto simp: Let_def policy_step_def)

lemma pi_pi[simp]: "d \<in> D\<^sub>D \<Longrightarrow> policy_step (policy_iteration d) = policy_iteration d"
  using is_dec_det_pi
  by (induction d rule: policy_iteration.induct) (auto simp: policy_step_def Let_def)

lemma policy_iteration_correct:
  "d \<in> D\<^sub>D \<Longrightarrow> \<nu>\<^sub>b (mk_stationary_det (policy_iteration d)) = \<nu>\<^sub>b_opt"
  by (induction d rule: policy_iteration.induct)
    (fastforce intro!: policy_step_eq_imp_opt is_dec_det_pi' simp del: policy_iteration.simps)

lemma \<nu>\<^sub>b_zero_notin:  "s \<ge> states \<Longrightarrow> \<nu>\<^sub>b p s = 0"
  using  \<nu>_zero_notin unfolding \<nu>\<^sub>b.rep_eq by auto

lemma r_dec\<^sub>b_zero_notin:  "s \<ge> states \<Longrightarrow> r_dec\<^sub>b d s = 0"
  using reward_zero_outside
  by auto

lemma \<nu>\<^sub>b_eq_inv: "\<nu>\<^sub>b (mk_stationary d) = inv\<^sub>L (id_blinfun - l *\<^sub>R \<P>\<^sub>1 d) (r_dec\<^sub>b d)"
  using \<nu>_stationary_inv.

lemma \<nu>\<^sub>b_eq_bfun_if: "\<nu>\<^sub>b (mk_stationary d) = bfun_if (\<lambda>i. i < states) (\<nu>\<^sub>b (mk_stationary d)) 0"
  using \<nu>\<^sub>b_zero_notin by (auto simp: bfun_if.rep_eq)

lemma \<nu>\<^sub>b_vec_aux: "((1\<^sub>m states) - l \<cdot>\<^sub>m (blinfun_to_mat states states (\<P>\<^sub>1 d))) *\<^sub>v bfun_to_vec states (\<nu>\<^sub>b (mk_stationary d)) = bfun_to_vec states (r_dec\<^sub>b d)"
proof -
  let ?to_mat = "blinfun_to_mat states states"
  let ?to_vec = "bfun_to_vec states"

  have "((1\<^sub>m states) - l \<cdot>\<^sub>m (?to_mat (\<P>\<^sub>1 d))) *\<^sub>v ?to_vec (\<nu>\<^sub>b (mk_stationary d)) =
      ((1\<^sub>m states) - ?to_mat (l *\<^sub>R (\<P>\<^sub>1 d))) *\<^sub>v ?to_vec (\<nu>\<^sub>b (mk_stationary d))"
    using blinfun_to_mat_scale by fastforce
  also have "\<dots> = (?to_mat id_blinfun - ?to_mat (l *\<^sub>R (\<P>\<^sub>1 d))) *\<^sub>v ?to_vec (\<nu>\<^sub>b (mk_stationary d))"
    using blinfun_to_mat_id by presburger
  also have "\<dots> = ?to_mat (id_blinfun - l *\<^sub>R \<P>\<^sub>1 d) *\<^sub>v ?to_vec (\<nu>\<^sub>b (mk_stationary d))"
    using blinfun_to_mat_sub by presburger
  also have "\<dots> = ?to_vec ((id_blinfun - l *\<^sub>R \<P>\<^sub>1 d) ((\<nu>\<^sub>b (mk_stationary d))))"
    unfolding blinfun_to_mat_mult using \<nu>\<^sub>b_eq_bfun_if by auto
  also have "\<dots> = ?to_vec (r_dec\<^sub>b d)"
    by (metis L_\<nu>_fix_iff L_def blinfun.diff_left blinfun.scaleR_left diff_eq_eq id_blinfun.rep_eq)
  finally show ?thesis.
qed

lemma summable_geom_\<P>\<^sub>1: "summable (\<lambda>k. ((l *\<^sub>R \<P>\<^sub>1 d)^^k))"
  using summable_inv_Q norm_\<P>\<^sub>1
  by (metis add_diff_cancel_left' diff_add_cancel norm_\<P>\<^sub>1_l_less)

lemma summable_geom_\<P>\<^sub>1': "summable (\<lambda>k. ((l *\<^sub>R \<P>\<^sub>1 d)^^k) v)" for v
  using  summable_geom_\<P>\<^sub>1 tendsto_blinfun_apply
  unfolding summable_def sums_def
  by (fastforce simp: blinfun.sum_left)

lemma summable_geom_\<P>\<^sub>1'': "summable (\<lambda>k. ((l *\<^sub>R \<P>\<^sub>1 d)^^k) v s)" for v s
  using summable_geom_\<P>\<^sub>1' bfun_tendsto_apply_bfun
    unfolding summable_def sums_def
    by (fastforce simp: sum_apply_bfun)

lemma K_closed': "s<states \<Longrightarrow> j \<in> set_pmf (K (s, a)) \<Longrightarrow> j < states"
  by (meson K_closed atLeastLessThan_iff basic_trans_rules(31))

lemma \<P>\<^sub>1_indep:
  assumes "(\<And>i. i < states \<Longrightarrow> apply_bfun v i = apply_bfun v' i)" "j < states"
  shows "(l *\<^sub>R \<P>\<^sub>1 d) v j = (l *\<^sub>R \<P>\<^sub>1 d) v' j"
  using assms K_closed'[OF assms(2)]
  by (auto simp: blinfun.scaleR_left \<P>\<^sub>1.rep_eq K_st_def intro!: integral_cong_AE AE_pmfI)

lemma inv\<^sub>L_indep:
  assumes "\<And>i. i < states \<Longrightarrow> apply_bfun v i = apply_bfun v' i" "j < states"
  shows "((inv\<^sub>L (id_blinfun - l *\<^sub>R \<P>\<^sub>1 d)) v) j = ((inv\<^sub>L (id_blinfun - l *\<^sub>R \<P>\<^sub>1 d)) v') j"
proof -
  have "((l *\<^sub>R \<P>\<^sub>1 d) ^^ n) v j = ((l *\<^sub>R \<P>\<^sub>1 d) ^^ n) v' j" for n
    using assms \<P>\<^sub>1_indep by (induction n arbitrary: j v v') fastforce+
  thus ?thesis
    using summable_geom_\<P>\<^sub>1 summable_geom_\<P>\<^sub>1'
    by (auto simp: inv\<^sub>L_inf_sum blinfun_apply_suminf[symmetric] suminf_apply_bfun)
qed

lemma vec_\<nu>\<^sub>b: "bfun_to_vec states (\<nu>\<^sub>b (mk_stationary d)) =
    inverse_mat ((1\<^sub>m states) - l \<cdot>\<^sub>m (blinfun_to_mat states states (\<P>\<^sub>1 d))) *\<^sub>v (bfun_to_vec states (r_dec\<^sub>b d))"
proof -
  have "bfun_to_vec states (\<nu>\<^sub>b (mk_stationary d)) = bfun_to_vec states (inv\<^sub>L (id_blinfun - l *\<^sub>R \<P>\<^sub>1 d) (r_dec\<^sub>b d))"
    using \<nu>\<^sub>b_eq_inv by force
  also have "\<dots> = bfun_to_vec states (inv\<^sub>L (id_blinfun - l *\<^sub>R \<P>\<^sub>1 d) (bfun_if (\<lambda>i. i < states) (r_dec\<^sub>b d) 0))"
    using r_dec\<^sub>b_zero_notin
    by (subst bfun_if_eq) auto
  also have "\<dots> = blinfun_to_mat states states (inv\<^sub>L (id_blinfun - l *\<^sub>R \<P>\<^sub>1 d)) *\<^sub>v (bfun_to_vec states (r_dec\<^sub>b d))"
    using blinfun_to_mat_mult..
  also have "\<dots> = inverse_mat (blinfun_to_mat states states (id_blinfun - l *\<^sub>R \<P>\<^sub>1 d)) *\<^sub>v (bfun_to_vec states (r_dec\<^sub>b d))"
       using inv\<^sub>L_indep \<P>\<^sub>1_indep
       by (fastforce simp add: inverse_blinfun_to_mat  invertible\<^sub>L_inf_sum blinfun.diff_left)+
  finally show ?thesis
    using blinfun_to_mat_id blinfun_to_mat_scale blinfun_to_mat_sub by presburger
qed

lemma invertible_\<nu>\<^sub>b_mat: "invertible_mat ((1\<^sub>m states) - l \<cdot>\<^sub>m (blinfun_to_mat states states (\<P>\<^sub>1 d)))"
proof -
  have "invertible_mat (blinfun_to_mat states states ((id_blinfun - l *\<^sub>R \<P>\<^sub>1 d)))"
    using \<P>\<^sub>1_indep inv\<^sub>L_indep
    by (fastforce simp: invertible\<^sub>L_inf_sum blinfun.diff_left intro!: inverse_blinfun_to_mat(2))+
  thus ?thesis
    by (auto simp: blinfun_to_mat_id blinfun_to_mat_sub blinfun_to_mat_scale)
qed

lemma mat_cong:
  assumes "(\<And>i j. i < n \<Longrightarrow> j < m \<Longrightarrow> f i j = g i j)"
  shows "Matrix.mat n m (\<lambda>(i, j). f i j) = Matrix.mat n m (\<lambda>(i,j). g i j)"
  using assms by auto

lemma \<P>\<^sub>1_mat: "(Matrix.mat states states (\<lambda>(s, s'). pmf (K (s, d s)) s')) = blinfun_to_mat states states (\<P>\<^sub>1 (mk_dec_det d))"
proof -
  have "pmf (K (s, d s)) s' = measure_pmf.expectation (K (s, d s)) (\<lambda>k. if s' = k then 1 else 0)"
      if "s < states" "s' < states" for s s'
    by (auto simp: integral_measure_pmf_real[of "{s'}"] split: if_splits)
  thus ?thesis
    by (auto simp: blinfun_to_mat_def \<P>\<^sub>1.rep_eq K_st_def mk_dec_det_def bind_return_pmf)
qed

lemma vec_\<nu>\<^sub>b': "bfun_to_vec states (\<nu>\<^sub>b (mk_stationary_det d)) =
  inverse_mat ((1\<^sub>m states) - l \<cdot>\<^sub>m (Matrix.mat states states (\<lambda>(s, s'). pmf (K (s, d s)) s'))) *\<^sub>v
  (vec states (\<lambda>i. r (i, d i)))"
  unfolding vec_\<nu>\<^sub>b using \<P>\<^sub>1_mat by (auto simp: bfun_to_vec_def)

lemma vec_\<nu>\<^sub>b'':
  assumes "s < states"
  shows "(\<nu>\<^sub>b (mk_stationary_det d)) s =
  (inverse_mat ((1\<^sub>m states) - l \<cdot>\<^sub>m (Matrix.mat states states (\<lambda>(s, s'). pmf (K (s, d s)) s'))) *\<^sub>v
  (vec states (\<lambda>i. r (i, d i)))) $ s"
  using vec_\<nu>\<^sub>b' assms unfolding bfun_to_vec_def by (metis index_vec)

lemma invertible_\<nu>\<^sub>b_mat':
  "invertible_mat (1\<^sub>m states - l \<cdot>\<^sub>m Matrix.mat states states (\<lambda>(s, y). pmf (K (s, d s)) y))"
  using invertible_\<nu>\<^sub>b_mat \<P>\<^sub>1_mat by presburger

lemma dim_vec_\<nu>\<^sub>b: "dim_vec (inverse_mat ((1\<^sub>m states) -
  l \<cdot>\<^sub>m (Matrix.mat states states (\<lambda>(s, s'). pmf (K (s, d s)) s'))) *\<^sub>v
  (vec states (\<lambda>i. r (i, d i)))) = states"
  by (simp add: inverse_mat_dims(2) invertible_\<nu>\<^sub>b_mat')

end
end


(* Author: Andreas Lochbihler, ETH Zurich
   Author: Florian Haftmann, TU Muenchen
*)

section \<open>An abstract type for multivariate polynomials\<close>

theory MPoly_Type
imports "HOL-Library.Poly_Mapping"
begin

subsection \<open>Abstract type definition\<close>

typedef (overloaded) 'a mpoly =
  "UNIV :: ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) set"
  morphisms mapping_of MPoly
 ..

setup_lifting type_definition_mpoly

(* these theorems are automatically generated by setup_lifting... *)
thm mapping_of_inverse   thm MPoly_inverse
thm mapping_of_inject    thm MPoly_inject
thm mapping_of_induct    thm MPoly_induct
thm mapping_of_cases     thm MPoly_cases

subsection \<open>Additive structure\<close>

instantiation mpoly :: (zero) zero
begin

lift_definition zero_mpoly :: "'a mpoly"
  is "0 :: (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a" .

instance ..

end

instantiation mpoly :: (monoid_add) monoid_add
begin

lift_definition plus_mpoly :: "'a mpoly \<Rightarrow> 'a mpoly \<Rightarrow> 'a mpoly"
  is "Groups.plus :: ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> _" .

instance
  by intro_classes (transfer, simp add: fun_eq_iff add.assoc)+

end

instance mpoly :: (comm_monoid_add) comm_monoid_add
  by intro_classes (transfer, simp add: fun_eq_iff ac_simps)+

instantiation mpoly :: (cancel_comm_monoid_add) cancel_comm_monoid_add
begin

lift_definition minus_mpoly :: "'a mpoly \<Rightarrow> 'a mpoly \<Rightarrow> 'a mpoly"
  is "Groups.minus :: ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> _" .

instance
  by intro_classes (transfer, simp add: fun_eq_iff diff_diff_add)+

end

instantiation mpoly :: (ab_group_add) ab_group_add
begin

lift_definition uminus_mpoly :: "'a mpoly \<Rightarrow> 'a mpoly"
  is "Groups.uminus :: ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> _" .

instance
  by intro_classes (transfer, simp add: fun_eq_iff add_uminus_conv_diff)+

end

subsection \<open>Multiplication by a coefficient\<close>
(* ?do we need inc_power on abstract polynomials? *)

lift_definition smult :: "'a::{times,zero} \<Rightarrow> 'a mpoly \<Rightarrow> 'a mpoly"
  is "\<lambda>a. Poly_Mapping.map (Groups.times a) :: ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> _" .

(* left lemmas in subsection \<open>Pseudo-division of polynomials\<close>,
   because I couldn't disentangle them and the notion of monomials. *)

subsection \<open>Multiplicative structure\<close>

instantiation mpoly :: (zero_neq_one) zero_neq_one
begin

lift_definition one_mpoly :: "'a mpoly"
  is "1 :: ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a)" .

instance
  by intro_classes (transfer, simp)

end

instantiation mpoly :: (semiring_0) semiring_0
begin

lift_definition times_mpoly :: "'a mpoly \<Rightarrow> 'a mpoly \<Rightarrow> 'a mpoly"
  is "Groups.times :: ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> _" .

instance
  by intro_classes (transfer, simp add: algebra_simps)+

end

instance mpoly :: (comm_semiring_0) comm_semiring_0
  by intro_classes (transfer, simp add: algebra_simps)+

instance mpoly :: (semiring_0_cancel) semiring_0_cancel
  ..

instance mpoly :: (comm_semiring_0_cancel) comm_semiring_0_cancel
  ..

instance mpoly :: (semiring_1) semiring_1
  by intro_classes (transfer, simp)+

instance mpoly :: (comm_semiring_1) comm_semiring_1
  by intro_classes (transfer, simp)+

instance mpoly :: (semiring_1_cancel) semiring_1_cancel
  ..

(*instance mpoly :: (comm_semiring_1_cancel) comm_semiring_1_cancel
  .. FIXME unclear whether this holds *)

instance mpoly :: (ring) ring
  ..

instance mpoly :: (comm_ring) comm_ring
  ..

instance mpoly :: (ring_1) ring_1
  ..

instance mpoly :: (comm_ring_1) comm_ring_1
  ..

subsection \<open>Monomials\<close>

text \<open>
  Terminology is not unique here, so we use the notions as follows:
  A "monomial" and a "coefficient" together give a "term".
  These notions are significant in connection with "leading",
  "leading term", "leading coefficient" and "leading monomial",
  which all rely on a monomial order.
\<close>

lift_definition monom :: "(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a::zero \<Rightarrow> 'a mpoly"
  is "Poly_Mapping.single :: (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> _" .

lemma mapping_of_monom [simp]:
  "mapping_of (monom m a) = Poly_Mapping.single m a"
  by(fact monom.rep_eq)

lemma monom_zero [simp]:
  "monom 0 0 = 0"
  by transfer simp

lemma monom_one [simp]:
  "monom 0 1 = 1"
  by transfer simp

lemma monom_add:
  "monom m (a + b) = monom m a + monom m b"
  by transfer (simp add: single_add)

lemma monom_uminus:
  "monom m (- a) = - monom m a"
  by transfer (simp add: single_uminus)

lemma monom_diff:
  "monom m (a - b) = monom m a - monom m b"
  by transfer (simp add: single_diff)

lemma monom_numeral [simp]:
  "monom 0 (numeral n) = numeral n"
  by (induct n) (simp_all only: numeral.simps numeral_add monom_zero monom_one monom_add)

lemma monom_of_nat [simp]:
  "monom 0 (of_nat n) = of_nat n"
  by (induct n) (simp_all add: monom_add)

lemma of_nat_monom:
  "of_nat = monom 0 \<circ> of_nat"
  by (simp add: fun_eq_iff)

lemma inj_monom [iff]:
  "inj (monom m)"
proof (rule injI, transfer)
  fix a b :: 'a and m :: "nat \<Rightarrow>\<^sub>0 nat"
  assume "Poly_Mapping.single m a = Poly_Mapping.single m b"
  with injD [of "Poly_Mapping.single m" a b]
  show "a = b" by simp
qed

lemma mult_monom: "monom x a * monom y b = monom (x + y) (a * b)"
  by transfer' (simp add: Poly_Mapping.mult_single)

instance mpoly :: (semiring_char_0) semiring_char_0
  by intro_classes (auto simp add: of_nat_monom inj_of_nat intro: inj_compose)

instance mpoly :: (ring_char_0) ring_char_0
  ..

lemma monom_of_int [simp]:
  "monom 0 (of_int k) = of_int k"
  apply (cases k)
  apply simp_all
  unfolding monom_diff monom_uminus
  apply simp
  done

subsection \<open>Constants and Indeterminates\<close>

text \<open>Embedding of indeterminates and constants in type-class polynomials,
  can be used as constructors.\<close>

definition Var\<^sub>0 :: "'a \<Rightarrow> ('a \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::{one,zero}" where
  "Var\<^sub>0 n \<equiv> Poly_Mapping.single (Poly_Mapping.single n 1) 1"
definition Const\<^sub>0 :: "'b \<Rightarrow> ('a \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::zero" where "Const\<^sub>0 c \<equiv> Poly_Mapping.single 0 c"

lemma Const\<^sub>0_one: "Const\<^sub>0 1 = 1"
  by (simp add: Const\<^sub>0_def)

lemma Const\<^sub>0_numeral: "Const\<^sub>0 (numeral x) = numeral x"
  by (auto intro!: poly_mapping_eqI simp: Const\<^sub>0_def lookup_numeral)

lemma Const\<^sub>0_minus: "Const\<^sub>0 (- x) = - Const\<^sub>0 x"
  by (simp add: Const\<^sub>0_def single_uminus)

lemma Const\<^sub>0_zero: "Const\<^sub>0 0 = 0"
  by (auto intro!: poly_mapping_eqI simp: Const\<^sub>0_def)

lemma Var\<^sub>0_power: "Var\<^sub>0 v ^ n = Poly_Mapping.single (Poly_Mapping.single v n) 1"
  by (induction n) (auto simp: Var\<^sub>0_def mult_single single_add[symmetric])

lift_definition Var::"nat \<Rightarrow> 'b::{one,zero} mpoly" is Var\<^sub>0 .
lift_definition Const::"'b::zero \<Rightarrow> 'b mpoly" is Const\<^sub>0 .

subsection \<open>Integral domains\<close>

instance mpoly :: (ring_no_zero_divisors) ring_no_zero_divisors
  by intro_classes (transfer, simp)

instance mpoly :: (ring_1_no_zero_divisors) ring_1_no_zero_divisors
  ..

instance mpoly :: (idom) idom
  ..

subsection \<open>Monom coefficient lookup\<close>

definition coeff :: "'a::zero mpoly \<Rightarrow> (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a"
where
  "coeff p = Poly_Mapping.lookup (mapping_of p)"

subsection \<open>Insertion morphism\<close>

definition insertion_fun_natural :: "(nat \<Rightarrow> 'a) \<Rightarrow> ((nat \<Rightarrow> nat) \<Rightarrow> 'a) \<Rightarrow> 'a::comm_semiring_1"
where
  "insertion_fun_natural f p = (\<Sum>m. p m * (\<Prod>v. f v ^ m v))"

definition insertion_fun :: "(nat \<Rightarrow> 'a) \<Rightarrow> ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a) \<Rightarrow> 'a::comm_semiring_1"
where
  "insertion_fun f p = (\<Sum>m. p m * (\<Prod>v. f v ^ Poly_Mapping.lookup m v))"

text \<open>N.b. have been unable to relate this to @{const insertion_fun_natural} using lifting!\<close>

lift_definition insertion_aux :: "(nat \<Rightarrow> 'a) \<Rightarrow> ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> 'a::comm_semiring_1"
  is "insertion_fun" .

lift_definition insertion :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a mpoly \<Rightarrow> 'a::comm_semiring_1"
  is "insertion_aux" .

lemma aux:
  "Poly_Mapping.lookup f = (\<lambda>_. 0) \<longleftrightarrow> f = 0"
  apply transfer apply simp done

lemma insertion_trivial [simp]:
  "insertion (\<lambda>_. 0) p = coeff p 0"
proof -
  { fix f :: "(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a"
    have "insertion_aux (\<lambda>_. 0) f = Poly_Mapping.lookup f 0"
      apply (simp add: insertion_aux_def insertion_fun_def power_Sum_any [symmetric])
      apply (simp add: zero_power_eq mult_when aux)
      done
  }
  then show ?thesis by (simp add: coeff_def insertion_def)
qed

lemma insertion_zero [simp]:
  "insertion f 0 = 0"
  by transfer (simp add: insertion_aux_def insertion_fun_def)

lemma insertion_fun_add:
  fixes f p q
  shows "insertion_fun f (Poly_Mapping.lookup (p + q)) =
    insertion_fun f (Poly_Mapping.lookup p) +
      insertion_fun f (Poly_Mapping.lookup q)"
  unfolding insertion_fun_def
  apply (subst Sum_any.distrib [symmetric])
  apply (simp_all add: plus_poly_mapping.rep_eq algebra_simps)
  apply (rule finite_mult_not_eq_zero_rightI)
  apply simp
  apply (rule finite_mult_not_eq_zero_rightI)
  apply simp
  done

lemma insertion_add:
  "insertion f (p + q) = insertion f p + insertion f q"
  by transfer (simp add: insertion_aux_def insertion_fun_add)

lemma insertion_one [simp]:
  "insertion f 1 = 1"
  by transfer (simp add: insertion_aux_def insertion_fun_def one_poly_mapping.rep_eq when_mult)

lemma insertion_fun_mult:
  fixes f p q
  shows "insertion_fun f (Poly_Mapping.lookup (p * q)) =
    insertion_fun f (Poly_Mapping.lookup p) *
      insertion_fun f (Poly_Mapping.lookup q)"
proof -
  { fix m :: "nat \<Rightarrow>\<^sub>0 nat"
    have "finite {v. Poly_Mapping.lookup m v \<noteq> 0}"
      by simp
    then have "finite {v. f v ^ Poly_Mapping.lookup m v \<noteq> 1}"
      by (rule rev_finite_subset) (auto intro: ccontr)
  }
  moreover define g where "g m = (\<Prod>v. f v ^ Poly_Mapping.lookup m v)" for m
  ultimately have *: "\<And>a b. g (a + b) = g a * g b"
    by (simp add: plus_poly_mapping.rep_eq power_add Prod_any.distrib)
  have bij: "bij (\<lambda>(l, n, m). (m, l, n))"
    by (auto intro!: bijI injI simp add: image_def)
  let ?P = "{l. Poly_Mapping.lookup p l \<noteq> 0}"
  let ?Q = "{n. Poly_Mapping.lookup q n \<noteq> 0}"
  let ?PQ = "{l + n | l n. l \<in> Poly_Mapping.keys p \<and> n \<in> Poly_Mapping.keys q}"
  have "finite {l + n | l n. Poly_Mapping.lookup p l \<noteq> 0 \<and> Poly_Mapping.lookup q n \<noteq> 0}"
    by (rule finite_not_eq_zero_sumI) simp_all
  then have fin_PQ: "finite ?PQ"
    by (simp add: in_keys_iff)
  have "(\<Sum>m. Poly_Mapping.lookup (p * q) m * g m) =
    (\<Sum>m. (\<Sum>l. Poly_Mapping.lookup p l * (\<Sum>n. Poly_Mapping.lookup q n when m = l + n)) * g m)"
    by (simp add: times_poly_mapping.rep_eq prod_fun_def)
  also have "\<dots> = (\<Sum>m. (\<Sum>l. (\<Sum>n. g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)))"
    apply (subst Sum_any_left_distrib)
    apply (auto intro: finite_mult_not_eq_zero_rightI)
    apply (subst Sum_any_right_distrib)
    apply (auto intro: finite_mult_not_eq_zero_rightI)
    apply (subst Sum_any_left_distrib)
    apply (auto intro: finite_mult_not_eq_zero_leftI)
    apply (simp add: ac_simps mult_when)
    done
  also have "\<dots> = (\<Sum>m. (\<Sum>(l, n). g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n))"
    apply (subst (2) Sum_any.cartesian_product [of "?P \<times> ?Q"])
    apply (auto dest!: mult_not_zero)
    done
  also have "\<dots> = (\<Sum>(m, l, n). g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)"
    apply (subst Sum_any.cartesian_product [of "?PQ \<times> (?P \<times> ?Q)"])
      apply (auto dest!: mult_not_zero simp add: fin_PQ)
    apply (auto simp: in_keys_iff)
    done
  also have "\<dots> = (\<Sum>(l, n, m). g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)"
    using bij by (rule Sum_any.reindex_cong [of "\<lambda>(l, n, m). (m, l, n)"]) (simp add: fun_eq_iff)
  also have "\<dots> = (\<Sum>(l, n). \<Sum>m. g m * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n) when m = l + n)"
    apply (subst Sum_any.cartesian_product2 [of "(?P \<times> ?Q) \<times> ?PQ"])
    apply (auto dest!: mult_not_zero simp add: fin_PQ )
    apply (auto simp: in_keys_iff)
    done
  also have "\<dots> = (\<Sum>(l, n). (g l * g n) * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n))"
    by (simp add: *)
  also have "\<dots> = (\<Sum>l. \<Sum>n. (g l * g n) * (Poly_Mapping.lookup p l * Poly_Mapping.lookup q n))"
    apply (subst Sum_any.cartesian_product [of "?P \<times> ?Q"])
    apply (auto dest!: mult_not_zero)
    done
  also have "\<dots> = (\<Sum>l. \<Sum>n. (Poly_Mapping.lookup p l * g l) * (Poly_Mapping.lookup q n * g n))"
    by (simp add: ac_simps)
  also have "\<dots> =
    (\<Sum>m. Poly_Mapping.lookup p m * g m) *
    (\<Sum>m. Poly_Mapping.lookup q m * g m)"
    by (rule Sum_any_product [symmetric]) (auto intro: finite_mult_not_eq_zero_rightI)
  finally show ?thesis by (simp add: insertion_fun_def g_def)
qed

lemma insertion_mult:
  "insertion f (p * q) = insertion f p * insertion f q"
  by transfer (simp add: insertion_aux_def insertion_fun_mult)

subsection \<open>Degree\<close>

lift_definition degree :: "'a::zero mpoly \<Rightarrow> nat \<Rightarrow> nat"
is "\<lambda>p v. Max (insert 0 ((\<lambda>m. Poly_Mapping.lookup m v) ` Poly_Mapping.keys p))" .

lift_definition total_degree :: "'a::zero mpoly \<Rightarrow> nat"
is "\<lambda>p. Max (insert 0 ((\<lambda>m. sum (Poly_Mapping.lookup m) (Poly_Mapping.keys m)) ` Poly_Mapping.keys p))" .

lemma degree_zero [simp]:
  "degree 0 v = 0"
  by transfer simp

lemma total_degree_zero [simp]:
  "total_degree 0 = 0"
  by transfer simp
(*
value [code] "total_degree (0 :: int mpoly)" (***)
*)

lemma degree_one [simp]:
  "degree 1 v = 0"
  by transfer simp

lemma total_degree_one [simp]:
  "total_degree 1 = 0"
  by transfer simp

subsection \<open>Pseudo-division of polynomials\<close>

lemma smult_conv_mult: "smult s p = monom 0 s * p"
by transfer (simp add: mult_map_scale_conv_mult)

lemma smult_monom [simp]:
  fixes c :: "_ :: mult_zero"
  shows "smult c (monom x c') = monom x (c * c')"
by transfer simp

lemma smult_0 [simp]:
  fixes p :: "_ :: mult_zero mpoly"
  shows "smult 0 p = 0"
by transfer(simp add: map_eq_zero_iff)

lemma mult_smult_left: "smult s p * q = smult s (p * q)"
by(simp add: smult_conv_mult mult.assoc)

lift_definition sdiv :: "'a::euclidean_ring \<Rightarrow> 'a mpoly \<Rightarrow> 'a mpoly"
  is "\<lambda>a. Poly_Mapping.map (\<lambda>b. b div a) :: ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> _"
.
text \<open>
  \qt{Polynomial division} is only possible on univariate polynomials \<open>K[x]\<close>
  over a field \<open>K\<close>, all other kinds of polynomials only allow pseudo-division
  [1]p.40/41":

  \<open>\<forall>x y :: 'a mpoly. y \<noteq> 0 \<Rightarrow> \<exists>a q r. smult a x = q * y + r\<close>

  The introduction of pseudo-division below generalises @{file \<open>~~/src/HOL/Computational_Algebra/Polynomial.thy\<close>}.
  [1] Winkler, Polynomial Algorithms, 1996.
  The generalisation raises issues addressed by Wenda Li and commented below.
  Florian replied to the issues conjecturing, that the abstract mpoly needs not
  be aware of the issues, in case these are only concerned with executability.
\<close>

definition pseudo_divmod_rel
  :: "'a::euclidean_ring => 'a mpoly => 'a mpoly => 'a mpoly => 'a mpoly => bool"
where
  "pseudo_divmod_rel a x y q r \<longleftrightarrow>
    smult a x = q * y + r \<and> (if y = 0 then q = 0 else r = 0 \<or> degree r < degree y)"
(* the notion of degree resigns a main variable in multivariate polynomials;
   also, there are infinitely many tuples (a,q,r) such that a x = q y + r *)

definition pdiv :: "'a::euclidean_ring mpoly \<Rightarrow> 'a mpoly \<Rightarrow> ('a \<times> 'a mpoly)" (infixl "pdiv" 70)
where
  "x pdiv y = (THE (a, q). \<exists>r. pseudo_divmod_rel a x y q r)"

definition pmod :: "'a::euclidean_ring mpoly \<Rightarrow> 'a mpoly \<Rightarrow> 'a mpoly" (infixl "pmod" 70)
where
  "x pmod y = (THE r. \<exists>a q. pseudo_divmod_rel a x y q r)"

definition pdivmod :: "'a::euclidean_ring mpoly \<Rightarrow> 'a mpoly \<Rightarrow> ('a \<times> 'a mpoly) \<times> 'a mpoly"
where
  "pdivmod p q = (p pdiv q, p pmod q)"

(* "_code" seems inappropriate, since "THE" in definitions pdiv and pmod is not unique,
   see comment to definition pseudo_divmod_rel; so this cannot be executable ... *)
lemma pdiv_code:
  "p pdiv q = fst (pdivmod p q)"
  by (simp add: pdivmod_def)

lemma pmod_code:
  "p pmod q = snd (pdivmod p q)"
  by (simp add: pdivmod_def)

(*TODO ERROR: Ambiguous input produces n parse trees ???...*)
definition div :: "'a::{euclidean_ring,field} mpoly \<Rightarrow> 'a mpoly \<Rightarrow> 'a mpoly" (infixl "div" 70)
where
  "x div y = (THE q'. \<exists>a q r. (pseudo_divmod_rel a x y q r) \<and> (q' = smult (inverse a) q))"

definition mod :: "'a::{euclidean_ring,field} mpoly \<Rightarrow> 'a mpoly \<Rightarrow> 'a mpoly" (infixl "mod" 70)
where
  "x mod y = (THE r'. \<exists>a q r. (pseudo_divmod_rel a x y q r) \<and> (r' = smult (inverse a) r))"

definition divmod :: "'a::{euclidean_ring,field} mpoly \<Rightarrow> 'a mpoly \<Rightarrow> 'a mpoly \<times> 'a mpoly"
where
  "divmod p q = (p div q, p mod q)"

lemma div_poly_code:
  "p div q = fst (divmod p q)"
  by (simp add: divmod_def)

lemma mod_poly_code:
  "p mod q = snd (divmod p q)"
  by (simp add: divmod_def)

subsection \<open>Primitive poly, etc\<close>

lift_definition coeffs :: "'a :: zero mpoly \<Rightarrow> 'a set"
is "Poly_Mapping.range :: ((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> _" .

lemma finite_coeffs [simp]: "finite (coeffs p)"
by transfer simp

text \<open>[1]p.82
  A "primitive'" polynomial has coefficients with GCD equal to 1.
  A polynomial is factored into "content" and "primitive part"
  for many different purposes.\<close>

definition primitive :: "'a::{euclidean_ring,semiring_Gcd} mpoly \<Rightarrow> bool"
where
  "primitive p \<longleftrightarrow> Gcd (coeffs p) = 1"

definition content_primitive :: "'a::{euclidean_ring,GCD.Gcd} mpoly \<Rightarrow> 'a \<times> 'a mpoly"
where
  "content_primitive p = (
    let d = Gcd (coeffs p)
    in (d, sdiv d p))"

value "let p = M [1,2,3] (4::int) + M [2,0,4] 6 + M [2,0,5] 8
  in content_primitive p"

end