Theory Polynomials.PP_Type
theory PP_Type
imports Power_Products
begin
text ‹For code generation, we must introduce a copy of type @{typ "'a ⇒⇩0 'b"} for power-products.›
typedef (overloaded) ('a, 'b) pp = "UNIV::('a ⇒⇩0 'b) set"
morphisms mapping_of PP ..
setup_lifting type_definition_pp
lift_definition pp_of_fun :: "('a ⇒ 'b) ⇒ ('a, 'b::zero) pp"
is Abs_poly_mapping .
subsection ‹‹lookup_pp›, ‹keys_pp› and ‹single_pp››
lift_definition lookup_pp :: "('a, 'b::zero) pp ⇒ 'a ⇒ 'b" is lookup .
lift_definition keys_pp :: "('a, 'b::zero) pp ⇒ 'a set" is keys .
lift_definition single_pp :: "'a ⇒ 'b ⇒ ('a, 'b::zero) pp" is Poly_Mapping.single .
lemma lookup_pp_of_fun: "finite {x. f x ≠ 0} ⟹ lookup_pp (pp_of_fun f) = f"
by (transfer, rule Abs_poly_mapping_inverse, simp)
lemma pp_of_lookup: "pp_of_fun (lookup_pp t) = t"
by (transfer, fact lookup_inverse)
lemma pp_eqI: "(⋀u. lookup_pp s u = lookup_pp t u) ⟹ s = t"
by (transfer, rule poly_mapping_eqI)
lemma pp_eq_iff: "(s = t) ⟷ (lookup_pp s = lookup_pp t)"
by (auto intro: pp_eqI)
lemma keys_pp_iff: "x ∈ keys_pp t ⟷ (lookup_pp t x ≠ 0)"
by (simp add: in_keys_iff keys_pp.rep_eq lookup_pp.rep_eq)
lemma pp_eqI':
assumes "⋀u. u ∈ keys_pp s ∪ keys_pp t ⟹ lookup_pp s u = lookup_pp t u"
shows "s = t"
proof (rule pp_eqI)
fix u
show "lookup_pp s u = lookup_pp t u"
proof (cases "u ∈ keys_pp s ∪ keys_pp t")
case True
thus ?thesis by (rule assms)
next
case False
thus ?thesis by (simp add: keys_pp_iff)
qed
qed
lemma lookup_single_pp: "lookup_pp (single_pp x e) y = (e when x = y)"
by (transfer, simp only: lookup_single)
subsection ‹Additive Structure›
instantiation pp :: (type, zero) zero
begin
lift_definition zero_pp :: "('a, 'b) pp" is "0::'a ⇒⇩0 'b" .
lemma lookup_zero_pp [simp]: "lookup_pp 0 = 0"
by (transfer, simp add: lookup_zero_fun)
instance ..
end
lemma single_pp_zero [simp]: "single_pp x 0 = 0"
by (rule pp_eqI, simp add: lookup_single_pp)
instantiation pp :: (type, monoid_add) monoid_add
begin
lift_definition plus_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ ('a, 'b) pp" is "(+)::('a ⇒⇩0 'b) ⇒ _" .
lemma lookup_plus_pp: "lookup_pp (s + t) = lookup_pp s + lookup_pp t"
by (transfer, simp add: lookup_plus_fun)
instance by intro_classes (transfer, simp add: fun_eq_iff add.assoc)+
end
lemma single_pp_plus: "single_pp x a + single_pp x b = single_pp x (a + b)"
by (rule pp_eqI, simp add: lookup_single_pp lookup_plus_pp when_def)
instance pp :: (type, comm_monoid_add) comm_monoid_add
by intro_classes (transfer, simp add: fun_eq_iff ac_simps)+
instantiation pp :: (type, cancel_comm_monoid_add) cancel_comm_monoid_add
begin
lift_definition minus_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ ('a, 'b) pp" is "(-)::('a ⇒⇩0 'b) ⇒ _" .
lemma lookup_minus_pp: "lookup_pp (s - t) = lookup_pp s - lookup_pp t"
by (transfer, simp only: lookup_minus_fun)
instance by intro_classes (transfer, simp add: fun_eq_iff diff_diff_add)+
end
subsection ‹@{typ "('a, 'b) poly_mapping"} belongs to class @{class comm_powerprod}›
instance poly_mapping :: (type, cancel_comm_monoid_add) comm_powerprod
by standard
subsection ‹@{typ "('a, 'b) poly_mapping"} belongs to class @{class ninv_comm_monoid_add}›
instance poly_mapping :: (type, ninv_comm_monoid_add) ninv_comm_monoid_add
proof (standard, transfer)
fix s t::"'a ⇒ 'b"
assume "(λk. s k + t k) = (λ_. 0)"
hence "s + t = 0" by (simp only: plus_fun_def zero_fun_def)
hence "s = 0" by (rule plus_eq_zero)
thus "s = (λ_. 0)" by (simp only: zero_fun_def)
qed
subsection ‹@{typ "('a, 'b) pp"} belongs to class @{class lcs_powerprod}›
lemma adds_pp_iff: "(s adds t) ⟷ (mapping_of s adds mapping_of t)"
unfolding adds_def by (transfer, fact refl)
instantiation pp :: (type, add_linorder) lcs_powerprod
begin
lift_definition lcs_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ ('a, 'b) pp" is "lcs_powerprod_class.lcs" .
lemma lookup_lcs_pp: "lookup_pp (lcs s t) x = max (lookup_pp s x) (lookup_pp t x)"
by (transfer, simp add: lookup_lcs_fun lcs_fun_def)
instance
apply (intro_classes, simp_all only: adds_pp_iff)
subgoal by (transfer, rule adds_lcs)
subgoal by (transfer, elim lcs_adds)
subgoal by (transfer, rule lcs_comm)
done
end
subsection ‹@{typ "('a, 'b) pp"} belongs to class @{class ulcs_powerprod}›
instance pp :: (type, add_linorder_min) ulcs_powerprod by intro_classes (transfer, elim plus_eq_zero)
subsection ‹Dickson's lemma for power-products in finitely many indeterminates›
lemma almost_full_on_pp_iff:
"almost_full_on (adds) A ⟷ almost_full_on (adds) (mapping_of ` A)" (is "?l ⟷ ?r")
proof
assume ?l
with _ show ?r
proof (rule almost_full_on_hom)
fix x y :: "('a, 'b) pp"
assume "x adds y"
thus "mapping_of x adds mapping_of y" by (simp only: adds_pp_iff)
qed
next
assume ?r
hence "almost_full_on (λx y. mapping_of x adds mapping_of y) A"
using subset_refl by (rule almost_full_on_map)
thus ?l by (simp only: adds_pp_iff[symmetric])
qed
lift_definition varnum_pp :: "('a::countable, 'b::zero) pp ⇒ nat" is "varnum {}" .
lemma dickson_grading_varnum_pp:
"dickson_grading (varnum_pp::('a::countable, 'b::add_wellorder) pp ⇒ nat)"
proof (rule dickson_gradingI)
fix s t :: "('a, 'b) pp"
show "varnum_pp (s + t) = max (varnum_pp s) (varnum_pp t)" by (transfer, rule varnum_plus)
next
fix m::nat
show "almost_full_on (adds) {x::('a, 'b) pp. varnum_pp x ≤ m}" unfolding almost_full_on_pp_iff
proof (transfer, simp)
fix m::nat
from dickson_grading_varnum_empty show "almost_full_on (adds) {x::'a ⇒⇩0 'b. varnum {} x ≤ m}"
by (rule dickson_gradingD2)
qed
qed
instance pp :: (countable, add_wellorder) graded_dickson_powerprod
by (standard, rule, fact dickson_grading_varnum_pp)
instance pp :: (finite, add_wellorder) dickson_powerprod
proof
have eq: "range mapping_of = UNIV" by (rule surjI, rule PP_inverse, rule UNIV_I)
show "almost_full_on (adds) (UNIV::('a, 'b) pp set)" by (simp add: almost_full_on_pp_iff eq dickson)
qed
subsection ‹Lexicographic Term Order›
lift_definition lex_pp :: "('a, 'b) pp ⇒ ('a::linorder, 'b::{zero,linorder}) pp ⇒ bool" is lex_pm .
lift_definition lex_pp_strict :: "('a, 'b) pp ⇒ ('a::linorder, 'b::{zero,linorder}) pp ⇒ bool" is lex_pm_strict .
lemma lex_pp_alt: "lex_pp s t = (s = t ∨ (∃x. lookup_pp s x < lookup_pp t x ∧ (∀y<x. lookup_pp s y = lookup_pp t y)))"
by (transfer, fact lex_pm_alt)
lemma lex_pp_refl: "lex_pp s s"
by (transfer, fact lex_pm_refl)
lemma lex_pp_antisym: "lex_pp s t ⟹ lex_pp t s ⟹ s = t"
by (transfer, intro lex_pm_antisym)
lemma lex_pp_trans: "lex_pp s t ⟹ lex_pp t u ⟹ lex_pp s u"
by (transfer, rule lex_pm_trans)
lemma lex_pp_lin: "lex_pp s t ∨ lex_pp t s"
by (transfer, fact lex_pm_lin)
lemma lex_pp_lin': "¬ lex_pp t s ⟹ lex_pp s t"
using lex_pp_lin by blast
corollary lex_pp_strict_alt [code]:
"lex_pp_strict s t = (¬ lex_pp t s)" for s t::"(_, _::ordered_comm_monoid_add) pp"
by (transfer, fact lex_pm_strict_alt)
lemma lex_pp_zero_min: "lex_pp 0 s" for s::"(_, _::add_linorder_min) pp"
by (transfer, fact lex_pm_zero_min)
lemma lex_pp_plus_monotone: "lex_pp s t ⟹ lex_pp (s + u) (t + u)"
for s t::"(_, _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) pp"
by (transfer, intro lex_pm_plus_monotone)
lemma lex_pp_plus_monotone': "lex_pp s t ⟹ lex_pp (u + s) (u + t)"
for s t::"(_, _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) pp"
unfolding add.commute[of u] by (rule lex_pp_plus_monotone)
instantiation pp :: (linorder, "{ordered_comm_monoid_add, linorder}") linorder
begin
definition less_eq_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ bool"
where "less_eq_pp = lex_pp"
definition less_pp :: "('a, 'b) pp ⇒ ('a, 'b) pp ⇒ bool"
where "less_pp = lex_pp_strict"
instance by intro_classes (auto simp: less_eq_pp_def less_pp_def lex_pp_refl lex_pp_strict_alt intro: lex_pp_antisym lex_pp_lin' elim: lex_pp_trans)
end
subsection ‹Degree›
lift_definition deg_pp :: "('a, 'b::comm_monoid_add) pp ⇒ 'b" is deg_pm .
lemma deg_pp_alt: "deg_pp s = sum (lookup_pp s) (keys_pp s)"
by (transfer, transfer, simp add: deg_fun_def supp_fun_def)
lemma deg_pp_zero [simp]: "deg_pp 0 = 0"
by (transfer, fact deg_pm_zero)
lemma deg_pp_eq_0_iff [simp]: "deg_pp s = 0 ⟷ s = 0" for s::"('a, 'b::add_linorder_min) pp"
by (transfer, fact deg_pm_eq_0_iff)
lemma deg_pp_plus: "deg_pp (s + t) = deg_pp s + deg_pp (t::('a, 'b::comm_monoid_add) pp)"
by (transfer, fact deg_pm_plus)
lemma deg_pp_single: "deg_pp (single_pp x k) = k"
by (transfer, fact deg_pm_single)
subsection ‹Degree-Lexicographic Term Order›
lift_definition dlex_pp :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp ⇒ ('a, 'b) pp ⇒ bool"
is dlex_pm .
lift_definition dlex_pp_strict :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp ⇒ ('a, 'b) pp ⇒ bool"
is dlex_pm_strict .
lemma dlex_pp_alt: "dlex_pp s t ⟷ (deg_pp s < deg_pp t ∨ (deg_pp s = deg_pp t ∧ lex_pp s t))"
by transfer (simp only: dlex_pm_def dord_pm_alt)
lemma dlex_pp_refl: "dlex_pp s s"
by (transfer) (fact dlex_pm_refl)
lemma dlex_pp_antisym: "dlex_pp s t ⟹ dlex_pp t s ⟹ s = t"
by (transfer, elim dlex_pm_antisym)
lemma dlex_pp_trans: "dlex_pp s t ⟹ dlex_pp t u ⟹ dlex_pp s u"
by (transfer, rule dlex_pm_trans)
lemma dlex_pp_lin: "dlex_pp s t ∨ dlex_pp t s"
by (transfer, fact dlex_pm_lin)
corollary dlex_pp_strict_alt [code]: "dlex_pp_strict s t = (¬ dlex_pp t s)"
by (transfer, fact dlex_pm_strict_alt)
lemma dlex_pp_zero_min: "dlex_pp 0 s"
for s t::"(_, _::add_linorder_min) pp"
by (transfer, fact dlex_pm_zero_min)
lemma dlex_pp_plus_monotone: "dlex_pp s t ⟹ dlex_pp (s + u) (t + u)"
for s t::"(_, _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}) pp"
by (transfer, rule dlex_pm_plus_monotone)
subsection ‹Degree-Reverse-Lexicographic Term Order›
lift_definition drlex_pp :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp ⇒ ('a, 'b) pp ⇒ bool"
is drlex_pm .
lift_definition drlex_pp_strict :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp ⇒ ('a, 'b) pp ⇒ bool"
is drlex_pm_strict .
lemma drlex_pp_alt: "drlex_pp s t ⟷ (deg_pp s < deg_pp t ∨ (deg_pp s = deg_pp t ∧ lex_pp t s))"
by transfer (simp only: drlex_pm_def dord_pm_alt)
lemma drlex_pp_refl: "drlex_pp s s"
by (transfer, fact drlex_pm_refl)
lemma drlex_pp_antisym: "drlex_pp s t ⟹ drlex_pp t s ⟹ s = t"
by (transfer, rule drlex_pm_antisym)
lemma drlex_pp_trans: "drlex_pp s t ⟹ drlex_pp t u ⟹ drlex_pp s u"
by (transfer, rule drlex_pm_trans)
lemma drlex_pp_lin: "drlex_pp s t ∨ drlex_pp t s"
by (transfer, fact drlex_pm_lin)
corollary drlex_pp_strict_alt [code]: "drlex_pp_strict s t = (¬ drlex_pp t s)"
by (transfer, fact drlex_pm_strict_alt)
lemma drlex_pp_zero_min: "drlex_pp 0 s"
for s t::"(_, _::add_linorder_min) pp"
by (transfer, fact drlex_pm_zero_min)
lemma drlex_pp_plus_monotone: "drlex_pp s t ⟹ drlex_pp (s + u) (t + u)"
for s t::"(_, _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}) pp"
by (transfer, rule drlex_pm_plus_monotone)
end