section\<open>Multigraphs with Partially Ordered Weights\<close>

(*<*)
theory Graph
  imports "HOL-Library.Sublist" Antichain
begin
(*>*)

abbreviation (input) FROM where
  "FROM \<equiv> \<lambda>(s, l, t). s"

abbreviation (input) LBL where
  "LBL \<equiv> \<lambda>(s, l, t). l"

abbreviation (input) TO where
  "TO \<equiv> \<lambda>(s, l, t). t"

notation subseq (infix "\<preceq>" 50)

locale graph =
  fixes weights :: "'vtx :: finite \<Rightarrow> 'vtx \<Rightarrow> 'lbl :: {order, monoid_add} antichain"
  assumes zero_le[simp]: "0 \<le> (s::'lbl)"
    and plus_mono: "(s1::'lbl) \<le> s2 \<Longrightarrow> s3 \<le> s4 \<Longrightarrow> s1 + s3 \<le> s2 + s4"
    and summary_self: "weights loc loc = {}\<^sub>A"
begin

lemma le_plus: "(s::'lbl) \<le> s + s'" "(s'::'lbl) \<le> s + s'"
  by (intro plus_mono[of s s 0 s', simplified] plus_mono[of 0 s s' s', simplified])+

subsection\<open>Paths\<close>

inductive path :: "'vtx \<Rightarrow> 'vtx \<Rightarrow> ('vtx \<times> 'lbl \<times> 'vtx) list \<Rightarrow> bool" where
  path0: "l1 = l2 \<Longrightarrow> path l1 l2 []"
| path: "path l1 l2 xs \<Longrightarrow> lbl \<in>\<^sub>A weights l2 l3 \<Longrightarrow> path l1 l3 (xs @ [(l2, lbl, l3)])"

inductive_cases path0E: "path l1 l2 []"
inductive_cases path_AppendE: "path l1 l3 (xs @ [(l2,s,l2')])"

lemma path_trans: "path l1 l2 xs \<Longrightarrow> path l2 l3 ys \<Longrightarrow> path l1 l3 (xs @ ys)"
  by (rotate_tac, induct l2 l3 ys rule: path.induct)
    (auto intro: path.path simp flip: append_assoc)

lemma path_take_from: "path l1 l2 xs \<Longrightarrow> m < length xs \<Longrightarrow> FROM (xs ! m) = l2' \<Longrightarrow> path l1 l2' (take m xs)"
proof (induct l1 l2 xs rule: path.induct)
  case (path l1 l2 xs lbl l3)
  then show ?case
    apply (unfold take_append)
    apply simp
    apply (cases "l2=l2'")
     apply (metis linorder_not_less nth_append take_all)
    apply (metis case_prod_conv less_Suc_eq nth_append nth_append_length)
    done
qed simp

lemma path_take_to: "path l1 l2 xs \<Longrightarrow> m < length xs \<Longrightarrow> TO (xs ! m) = l2' \<Longrightarrow> path l1 l2' (take (m+1) xs)"
proof (induct l1 l2 xs rule: path.induct)
  case (path l1 l2 xs lbl l3)
  then show ?case
    apply (cases "m < length xs")
     apply (simp add: nth_append)
    apply clarsimp
    apply (metis case_prod_conv less_antisym nth_append_length path.path)
    done
qed simp

lemma path_determines_loc: "path l1 l2 xs \<Longrightarrow> path l1 l3 xs \<Longrightarrow> l2 = l3"
  by (induct l1 l2 xs rule: path.induct) (auto elim: path.cases)

lemma path_first_loc: "path loc loc' xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> FROM (xs ! 0) = loc"
proof (induct rule: path.induct)
  case (path l1 l2 xs lbl l3)
  then show ?case
    by (auto elim: path0E simp: nth_append)
qed simp

lemma path_to_eq_from: "path loc1 loc2 xs \<Longrightarrow> i + 1 < length xs \<Longrightarrow> FROM (xs ! (i+1)) = TO (xs ! i)"
proof (induct rule: path.induct)
  case (path l1 l2 xs lbl l3)
  then show ?case
    apply (cases "i + 1 < length xs")
     apply (simp add: nth_append)
    apply (simp add: nth_append)
    apply (metis add.commute drop_eq_Nil hd_drop_conv_nth id_take_nth_drop linorder_not_less path_determines_loc path_take_to plus_1_eq_Suc take_hd_drop)
    done
qed simp

lemma path_singleton[intro, simp]: "s \<in>\<^sub>A weights l1 l2 \<Longrightarrow> path l1 l2 [(l1,s,l2)]"
  by (subst path.simps) (auto simp: path.intros)

lemma path_appendE: "path l1 l3 (xs @ ys) \<Longrightarrow> \<exists>l2. path l2 l3 ys \<and> path l1 l2 xs"
proof (induct l1 l3 "xs@ys" arbitrary: xs ys rule: path.induct)
  case (path0 l1 l2)
  then show ?case by (auto intro: path.intros)
next
  case (path l1 l2 xs lbl l3 xs' ys')
  from path(1,3-) show ?case
    apply -
    apply (subst (asm) append_eq_append_conv2[of xs "[(l2,lbl,l3)]" xs' ys'])
    apply (elim exE conjE disjE)
    subgoal for us
      using path(2)[of xs' us]
      by (auto intro: path.intros)
    subgoal for us
      by (cases "us=[]") (auto intro: path.intros simp: Cons_eq_append_conv)
    done
qed

lemma path_replace_prefix:
  "path l1 l3 (xs @ zs) \<Longrightarrow> path l1 l2 ys \<Longrightarrow> path l1 l2 xs \<Longrightarrow> path l1 l3 (ys @ zs)"
  by (drule path_appendE) (auto elim!: path_trans dest: path_determines_loc)

lemma drop_subseq: "n \<le> length xs \<Longrightarrow> drop n xs \<preceq> xs"
  by (auto simp: suffix_def intro!: exI[of _ "take n xs"])

lemma take_subseq[simp, intro]: "take n xs \<preceq> xs"
  by (induct xs) auto

lemma map_take_subseq[simp, intro]: "map f (take n xs) \<preceq> map f xs"
  by (rule subseq_map, induct xs) auto

lemma path_distinct:
  "path l1 l2 xs \<Longrightarrow> \<exists>xs'. distinct xs' \<and> path l1 l2 xs' \<and> map LBL xs' \<preceq> map LBL xs"
proof (induct rule: path.induct)
  case (path0 l1 l2)
  then show ?case
    by (intro exI[of _ "[]"]) (auto intro: path.intros)
next
  case (path l1 l2 xs lbl l3)
  then obtain xs' where ih: "path l1 l2 xs'" "distinct xs'" "map LBL xs' \<preceq> map LBL xs"
    by blast
  then show ?case
  proof (cases "(l2, lbl, l3) \<in> set xs'")
    case True
    then obtain m where m: "m < length xs'" "xs' ! m = (l2, lbl, l3)"
      unfolding in_set_conv_nth by blast
    from m ih have "path l1 l2 (take m xs')"
      by (auto intro: path_take_from)
    with m ih path show ?thesis
      apply (intro exI[of _ "take m xs' @ [(l2, lbl, l3)]"])
      apply (rule conjI)
       apply (metis distinct_take take_Suc_conv_app_nth)
      apply (rule conjI)
       apply (rule path.intros)
        apply simp
       apply simp
      apply simp
      apply (metis ih(3) subseq_order.trans take_map take_subseq)
      done
  next
    case False
    with ih path(3) show ?thesis
      by (auto intro!: exI[of _ "xs' @ [(l2, lbl, l3)]"] intro: path.intros)
  qed
qed

lemma path_edge: "(l1', lbl, l2') \<in> set xs \<Longrightarrow> path l1 l2 xs \<Longrightarrow> lbl \<in>\<^sub>A weights l1' l2'"
  by (rotate_tac, induct rule: path.induct) auto

subsection\<open>Path Weights\<close>

abbreviation sum_weights :: "'lbl list \<Rightarrow> 'lbl" where
  "sum_weights xs \<equiv> foldr (+) xs 0"
abbreviation "sum_path_weights xs \<equiv> sum_weights (map LBL xs)"

definition "path_weightp l1 l2 s \<equiv> (\<exists>xs. path l1 l2 xs \<and> s = sum_path_weights xs)"

lemma sum_not_less_zero[simp, dest]: "(s::'lbl) < 0 \<Longrightarrow> False"
  by (simp add: less_le_not_le)

lemma sum_le_zero[simp]: "(s::'lbl) \<le> 0 \<longleftrightarrow> s = 0"
  by (simp add: eq_iff)

lemma sum_le_zeroD[dest]: "(x::'lbl) \<le> 0 \<Longrightarrow> x = 0"
  by simp

lemma foldr_plus_mono: "(n::'lbl) \<le> m \<Longrightarrow> foldr (+) xs n \<le> foldr (+) xs m"
  by (induct xs) (auto simp: plus_mono)

lemma sum_weights_append:
  "sum_weights (ys @ xs) = sum_weights ys + sum_weights xs"
  by (induct ys) (auto simp: add.assoc)

lemma sum_summary_prepend_le: "sum_path_weights ys \<le> sum_path_weights xs \<Longrightarrow> sum_path_weights (zs @ ys) \<le> sum_path_weights (zs @ xs)"
  by (induct zs arbitrary: xs ys) (auto intro: plus_mono)

lemma sum_summary_append_le: "sum_path_weights ys \<le> sum_path_weights xs \<Longrightarrow> sum_path_weights (ys @ zs) \<le> sum_path_weights (xs @ zs)"
proof (induct zs arbitrary: xs ys)
  case (Cons a zs)
  then show ?case
    by (metis plus_mono map_append order_refl sum_weights_append)
qed simp

lemma foldr_plus_zero_le: "foldr (+) xs (0::'lbl) \<le> foldr (+) xs a"
  by (induct xs) (simp_all add: plus_mono)

lemma subseq_sum_weights_le:
  assumes "xs \<preceq> ys"
  shows "sum_weights xs \<le> sum_weights ys"
  using assms
proof (induct rule: list_emb.induct)
  case (list_emb_Nil ys)
  then show ?case by auto
next
  case (list_emb_Cons xs ys y)
  then show ?case by (auto elim!: order_trans simp: le_plus)
next
  case (list_emb_Cons2 x y xs ys)
  then show ?case by (auto elim!: order_trans simp: plus_mono)
qed

lemma subseq_sum_path_weights_le:
  "map LBL xs \<preceq> map LBL ys \<Longrightarrow> sum_path_weights xs \<le> sum_path_weights ys"
  by (rule subseq_sum_weights_le)

lemma sum_path_weights_take_le[simp, intro]: "sum_path_weights (take i xs) \<le> sum_path_weights xs"
  by (auto intro!: subseq_sum_path_weights_le)

lemma sum_weights_append_singleton:
  "sum_weights (xs @ [x]) = sum_weights xs + x"
  by (induct xs) (simp_all add: add.assoc)

lemma sum_path_weights_append_singleton:
  "sum_path_weights (xs @ [(l,x,l')]) = sum_path_weights xs + x"
  by (induct xs) (simp_all add: add.assoc)

lemma path_weightp_ex_path:
  "path_weightp l1 l2 s \<Longrightarrow> \<exists>xs.
  (let s' = sum_path_weights xs in s' \<le> s \<and> path_weightp l1 l2 s' \<and> distinct xs \<and>
  (\<forall>(l1,s,l2) \<in> set xs. s \<in>\<^sub>A weights l1 l2))"
  unfolding path_weightp_def
  apply (erule exE conjE)+
  apply (drule path_distinct)
  apply (erule exE conjE)+
  subgoal for xs xs'
    apply (rule exI[of _ xs'])
    apply (auto simp: Let_def dest!: path_edge intro: subseq_sum_path_weights_le)
    done
  done

lemma finite_set_summaries:
  "finite ((\<lambda>((l1,l2),s). (l1,s,l2)) ` (Sigma UNIV (\<lambda>(l1,l2). set_antichain (weights l1 l2))))"
  by force

lemma finite_summaries: "finite {xs. distinct xs \<and> (\<forall>(l1, s, l2) \<in> set xs. s \<in>\<^sub>A weights l1 l2)}"
  apply (rule finite_subset[OF _ finite_distinct_bounded[of "((\<lambda>((l1,l2),s). (l1,s,l2)) ` (Sigma UNIV (\<lambda>(l1,l2). set_antichain (weights l1 l2))))"]])
   apply (force simp: finite_set_summaries)+
  done

lemma finite_minimal_antichain_path_weightp:
  "finite (minimal_antichain {x. path_weightp l1 l2 x})"
  apply (rule finite_surj[OF finite_summaries, where f = sum_path_weights])
  apply (clarsimp simp: minimal_antichain_def image_iff dest!: path_weightp_ex_path)
  apply (fastforce simp: Let_def)
  done

(* antichain of summaries along cycles-less paths (cycle-less = no edge repeated) *)
lift_definition path_weight :: "'vtx \<Rightarrow> 'vtx \<Rightarrow> 'lbl antichain"
  is "\<lambda>l1 l2. minimal_antichain {x. path_weightp l1 l2 x}"
  using finite_minimal_antichain_path_weightp
  by auto

definition "reachable l1 l2 \<equiv> path_weight l1 l2 \<noteq> {}\<^sub>A"

lemma in_path_weight: "s \<in>\<^sub>A path_weight loc1 loc2 \<longleftrightarrow> s \<in> minimal_antichain {s. path_weightp loc1 loc2 s}"
  by transfer simp

lemma path_weight_refl[simp]: "0 \<in>\<^sub>A path_weight loc loc"
proof -
  have *: "path loc loc []"
    by (simp add: path0)
  then have "0 = sum_path_weights []" by auto
  with * have "path_weightp loc loc 0"
    using path_weightp_def by blast
  then show ?thesis
    by (auto simp: in_path_weight in_minimal_antichain)
qed

lemma zero_in_minimal_antichain[simp]: "(0::'lbl) \<in> S \<Longrightarrow> 0 \<in> minimal_antichain S"
  by (auto simp: in_minimal_antichain intro: sum_not_less_zero)

definition "path_weightp_distinct l1 l2 s \<equiv> (\<exists>xs. distinct xs \<and> path l1 l2 xs \<and> s = sum_path_weights xs)"

lemma minimal_antichain_path_weightp_distinct:
  "minimal_antichain {xs. path_weightp l1 l2 xs} = minimal_antichain {xs. path_weightp_distinct l1 l2 xs}"
  unfolding path_weightp_def path_weightp_distinct_def minimal_antichain_def
  apply safe
     apply clarsimp
     apply (metis path_distinct order.strict_iff_order subseq_sum_path_weights_le)
    apply (blast+) [2]
  apply clarsimp
  apply (metis (no_types, lifting) le_less_trans path_distinct subseq_sum_weights_le)
  done

lemma finite_path_weightp_distinct[simp, intro]: "finite {xs. path_weightp_distinct l1 l2 xs}"
  unfolding path_weightp_distinct_def
  apply (rule finite_subset[where B = "sum_path_weights ` {xs. distinct xs \<and> path l1 l2 xs}"])
   apply clarsimp
  apply (rule finite_imageI)
  apply (rule finite_subset[OF _ finite_summaries])
  apply (clarsimp simp: path_edge)
  done

lemma path_weightp_distinct_nonempty:
  "{xs. path_weightp l1 l2 xs} \<noteq> {} \<longleftrightarrow> {xs. path_weightp_distinct l1 l2 xs} \<noteq> {}"
  by (auto dest: path_distinct simp: path_weightp_def path_weightp_distinct_def)

lemma path_weightp_distinct_member:
  "s \<in> {s. path_weightp l1 l2 s} \<Longrightarrow> \<exists>u. u \<in> {s. path_weightp_distinct l1 l2 s} \<and> u \<le> s"
  apply (clarsimp simp: path_weightp_def path_weightp_distinct_def)
  apply (drule path_distinct)
  apply (auto dest: subseq_sum_path_weights_le)
  done

lemma minimal_antichain_path_weightp_member:
  "s \<in> {xs. path_weightp l1 l2 xs} \<Longrightarrow> \<exists>u. u \<in> minimal_antichain {xs. path_weightp l1 l2 xs} \<and> u \<le> s"
proof -
  assume "s \<in> {xs. path_weightp l1 l2 xs}"
  then obtain u where u: "u \<in> {s. path_weightp_distinct l1 l2 s} \<and> u \<le> s"
    using path_weightp_distinct_member by blast
  have finite: "finite {xs. path_weightp_distinct l1 l2 xs}" ..
  from u finite obtain v where "v \<in> minimal_antichain {xs. path_weightp_distinct l1 l2 xs} \<and> v \<le> u"
    by atomize_elim (auto intro: minimal_antichain_member)
  with u show ?thesis
    by (auto simp: minimal_antichain_path_weightp_distinct)
qed

lemma path_path_weight: "path l1 l2 xs \<Longrightarrow> \<exists>s. s \<in>\<^sub>A path_weight l1 l2 \<and> s \<le> sum_path_weights xs"
proof -
  assume "path l1 l2 xs"
  then have "sum_path_weights xs \<in> {x. path_weightp l1 l2 x}"
    by (auto simp: path_weightp_def)
  then obtain u where "u \<in> minimal_antichain {x. path_weightp l1 l2 x} \<and> u \<le> sum_path_weights xs"
    apply atomize_elim
    apply (drule minimal_antichain_path_weightp_member)
    apply auto
    done
  then show ?thesis
    by transfer auto
qed

lemma path_weight_conv_path:
  "s \<in>\<^sub>A path_weight l1 l2 \<Longrightarrow> \<exists>xs. path l1 l2 xs \<and> s = sum_path_weights xs \<and> (\<forall>ys. path l1 l2 ys \<longrightarrow> \<not> sum_path_weights ys < sum_path_weights xs)"
  by transfer (auto simp: in_minimal_antichain path_weightp_def)

abbreviation "optimal_path loc1 loc2 xs \<equiv> path loc1 loc2 xs \<and>
   (\<forall>ys. path loc1 loc2 ys \<longrightarrow> \<not> sum_path_weights ys < sum_path_weights xs)"

lemma path_weight_path: "s \<in>\<^sub>A path_weight loc1 loc2 \<Longrightarrow>
  (\<And>xs. optimal_path loc1 loc2 xs \<Longrightarrow> distinct xs \<Longrightarrow> sum_path_weights xs = s \<Longrightarrow> P) \<Longrightarrow> P"
  apply atomize_elim
  apply transfer
  apply (clarsimp simp: in_minimal_antichain path_weightp_def)
  apply (drule path_distinct)
  apply (erule exE)
  subgoal for loc1 loc2 xs xs'
    apply (rule exI[of _ xs'])
    apply safe
    using order.strict_iff_order subseq_sum_path_weights_le apply metis
    using less_le subseq_sum_path_weights_le apply fastforce
    done
  done

lemma path_weight_elem_trans:
  "s \<in>\<^sub>A path_weight l1 l2 \<Longrightarrow> s' \<in>\<^sub>A path_weight l2 l3 \<Longrightarrow> \<exists>u. u \<in>\<^sub>A path_weight l1 l3 \<and> u \<le> s + s'"
proof -
  assume ps1: "s  \<in>\<^sub>A path_weight l1 l2"
  assume ps2: "s' \<in>\<^sub>A path_weight l2 l3"
  from ps1 obtain xs where path1: "path l1 l2 xs" "s = sum_path_weights xs"
    by (auto intro: path_weight_path)
  from ps2 obtain ys where path2: "path l2 l3 ys" "s' = sum_path_weights ys"
    by (auto intro: path_weight_path)
  from path1(1) path2(1) have "path l1 l3 (xs @ ys)"
    by (rule path_trans)
  with path1(2) path2(2) have "s + s' \<in> {s. path_weightp l1 l3 s}"
    by (auto simp: path_weightp_def sum_weights_append[symmetric])
  then show "\<exists>u. u \<in>\<^sub>A path_weight l1 l3 \<and> u \<le> s + s'"
    by transfer (simp add: minimal_antichain_path_weightp_member)
qed

end

(*<*)
end
(*>*)


(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

section \<open>Representing Intensional Logic\<close>

theory Intensional
imports Main
begin

text\<open>
  In higher-order logic, every proof rule has a corresponding tautology, i.e.
  the \emph{deduction theorem} holds. Isabelle/HOL implements this since object-level
  implication ($\longrightarrow$) and meta-level entailment ($\Longrightarrow$)
  commute, viz. the proof rule \<open>impI:\<close> @{thm impI}.
  However, the deduction theorem does not hold for
  most modal and temporal logics \cite[page 95]{Lamport02}\cite{Merz98}.
  For example $A \vdash \Box A$ holds, meaning that if $A$ holds in any world, then
  it always holds. However, $\vdash A \longrightarrow \Box A$, stating that
  $A$ always holds if it initially holds, is not valid.

  Merz  \cite{Merz98} overcame this problem by creating an
  @{term Intensional} logic. It exploits Isabelle's
  axiomatic type class feature  \cite{Wenzel00b} by creating a type
  class @{term world}, which provides Skolem constants to associate formulas
  with the world they hold in. The class is trivial, not requiring any axioms.
\<close>

class world
text \<open>
  @{term world} is a type class of possible worlds. It is a subclass
  of all HOL types @{term type}. No axioms are provided, since its only
  purpose is to avoid silly use of the @{term Intensional} syntax.
\<close>

subsection\<open>Abstract Syntax and Definitions\<close>

type_synonym ('w,'a) expr = "'w \<Rightarrow> 'a"
type_synonym  'w form = "('w, bool) expr"

text \<open>The intention is that @{typ 'a} will be used for unlifted
types (class @{term type}), while @{typ 'w} is lifted (class @{term world}).
\<close>

definition Valid :: "('w::world) form \<Rightarrow> bool"
  where "Valid A \<equiv> \<forall>w. A w"

definition const :: "'a \<Rightarrow> ('w::world, 'a) expr"
  where unl_con: "const c w \<equiv> c"

definition lift :: "['a \<Rightarrow> 'b, ('w::world, 'a) expr] \<Rightarrow> ('w,'b) expr"
  where unl_lift: "lift f x w \<equiv> f (x w)"

definition lift2 :: "['a \<Rightarrow> 'b \<Rightarrow> 'c, ('w::world,'a) expr, ('w,'b) expr] \<Rightarrow> ('w,'c) expr"
  where unl_lift2: "lift2 f x y w \<equiv> f (x w) (y w)"

definition lift3 :: "['a \<Rightarrow> 'b => 'c \<Rightarrow> 'd, ('w::world,'a) expr, ('w,'b) expr, ('w,'c) expr] \<Rightarrow> ('w,'d) expr"
  where unl_lift3: "lift3 f x y z w \<equiv> f (x w) (y w) (z w)"

definition lift4 :: "['a \<Rightarrow> 'b => 'c \<Rightarrow> 'd \<Rightarrow> 'e, ('w::world,'a) expr, ('w,'b) expr, ('w,'c) expr,('w,'d) expr] \<Rightarrow> ('w,'e) expr"
  where unl_lift4: "lift4 f x y z zz w \<equiv> f (x w) (y w) (z w) (zz w)"

text \<open>
  @{term "Valid F"} asserts that the lifted formula @{term F} holds everywhere.
  @{term const} allows lifting of a constant, while @{term lift} through
  @{term lift4} allow functions with arity 1--4 to be lifted. (Note that there
  is no way to define a generic lifting operator for functions of arbitrary arity.)
\<close>

definition RAll :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"  (binder "Rall " 10)
  where unl_Rall: "(Rall x. A x) w \<equiv> \<forall>x. A x w"

definition REx :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"  (binder "Rex " 10)
  where unl_Rex: "(Rex x. A x) w \<equiv> \<exists>x. A x w"

definition REx1 :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"  (binder "Rex! " 10)
  where unl_Rex1: "(Rex! x. A x) w \<equiv> \<exists>!x. A x w"

text \<open>
  @{term RAll}, @{term REx} and @{term REx1} introduces ``rigid'' quantification
  over values (of non-world types) within ``intensional'' formulas. @{term RAll}
  is universal quantification, @{term REx} is existential quantifcation.
  @{term REx1} requires unique existence.
\<close>

text \<open>
  We declare the ``unlifting rules'' as rewrite rules that will be applied
  automatically.
\<close>

lemmas intensional_rews[simp] =
  unl_con unl_lift unl_lift2 unl_lift3 unl_lift4
  unl_Rall unl_Rex unl_Rex1

subsection\<open>Concrete Syntax\<close>

nonterminal
  lift and liftargs

text\<open>
  The non-terminal @{term lift} represents lifted expressions. The idea is to use
  Isabelle's macro mechanism to convert between the concrete and abstract syntax.
\<close>

syntax
  ""            :: "id \<Rightarrow> lift"                          ("_")
  ""            :: "longid \<Rightarrow> lift"                      ("_")
  ""            :: "var \<Rightarrow> lift"                         ("_")
  "_applC"      :: "[lift, cargs] \<Rightarrow> lift"               ("(1_/ _)" [1000, 1000] 999)
  ""            :: "lift \<Rightarrow> lift"                        ("'(_')")
  "_lambda"     :: "[idts, 'a] \<Rightarrow> lift"                  ("(3%_./ _)" [0, 3] 3)
  "_constrain"  :: "[lift, type] \<Rightarrow> lift"                ("(_::_)" [4, 0] 3)
  ""            :: "lift \<Rightarrow> liftargs"                    ("_")
  "_liftargs"   :: "[lift, liftargs] \<Rightarrow> liftargs"        ("_,/ _")
  "_Valid"      :: "lift \<Rightarrow> bool"                        ("(\<turnstile> _)" 5)
  "_holdsAt"    :: "['a, lift] \<Rightarrow> bool"                  ("(_ \<Turnstile> _)" [100,10] 10)

  (* Syntax for lifted expressions outside the scope of \<turnstile> or \<Turnstile>.*)
  "LIFT"        :: "lift \<Rightarrow> 'a"                          ("LIFT _")

  (* generic syntax for lifted constants and functions *)
  "_const"      :: "'a \<Rightarrow> lift"                          ("(#_)" [1000] 999)
  "_lift"       :: "['a, lift] \<Rightarrow> lift"                  ("(_<_>)" [1000] 999)
  "_lift2"      :: "['a, lift, lift] \<Rightarrow> lift"            ("(_<_,/ _>)" [1000] 999)
  "_lift3"      :: "['a, lift, lift, lift] \<Rightarrow> lift"      ("(_<_,/ _,/ _>)" [1000] 999)
  "_lift4"      :: "['a, lift, lift, lift,lift] \<Rightarrow> lift"      ("(_<_,/ _,/ _,/ _>)" [1000] 999)

  (* concrete syntax for common infix functions: reuse same symbol *)
  "_liftEqu"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ =/ _)" [50,51] 50)
  "_liftNeq"    :: "[lift, lift] \<Rightarrow> lift"                (infixl "\<noteq>" 50)
  "_liftNot"    :: "lift \<Rightarrow> lift"                        ("\<not> _" [90] 90)
  "_liftAnd"    :: "[lift, lift] \<Rightarrow> lift"                (infixr "\<and>" 35)
  "_liftOr"     :: "[lift, lift] \<Rightarrow> lift"                (infixr "\<or>" 30)
  "_liftImp"    :: "[lift, lift] \<Rightarrow> lift"                (infixr "\<longrightarrow>" 25)
  "_liftIf"     :: "[lift, lift, lift] \<Rightarrow> lift"          ("(if (_)/ then (_)/ else (_))" 10)
  "_liftPlus"   :: "[lift, lift] \<Rightarrow> lift"                ("(_ +/ _)" [66,65] 65)
  "_liftMinus"  :: "[lift, lift] \<Rightarrow> lift"                ("(_ -/ _)" [66,65] 65)
  "_liftTimes"  :: "[lift, lift] \<Rightarrow> lift"                ("(_ */ _)" [71,70] 70)
  "_liftDiv"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ div _)" [71,70] 70)
  "_liftMod"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ mod _)" [71,70] 70)
  "_liftLess"   :: "[lift, lift] \<Rightarrow> lift"                ("(_/ < _)"  [50, 51] 50)
  "_liftLeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<le> _)" [50, 51] 50)
  "_liftMem"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<in> _)" [50, 51] 50)
  "_liftNotMem" :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<notin> _)" [50, 51] 50)
  "_liftFinset" :: "liftargs => lift"                    ("{(_)}")
  (** TODO: syntax for lifted collection / comprehension **)
  "_liftPair"   :: "[lift,liftargs] \<Rightarrow> lift"                   ("(1'(_,/ _'))")
  (* infix syntax for list operations *)
  "_liftCons" :: "[lift, lift] \<Rightarrow> lift"                  ("(_ #/ _)" [65,66] 65)
  "_liftApp"  :: "[lift, lift] \<Rightarrow> lift"                  ("(_ @/ _)" [65,66] 65)
  "_liftList" :: "liftargs \<Rightarrow> lift"                      ("[(_)]")

  (* Rigid quantification (syntax level) *)
  "_ARAll"  :: "[idts, lift] \<Rightarrow> lift"                    ("(3! _./ _)" [0, 10] 10)
  "_AREx"   :: "[idts, lift] \<Rightarrow> lift"                    ("(3? _./ _)" [0, 10] 10)
  "_AREx1"  :: "[idts, lift] \<Rightarrow> lift"                    ("(3?! _./ _)" [0, 10] 10)
  "_RAll"       :: "[idts, lift] \<Rightarrow> lift"                ("(3\<forall>_./ _)" [0, 10] 10)
  "_REx"        :: "[idts, lift] \<Rightarrow> lift"                ("(3\<exists>_./ _)" [0, 10] 10)
  "_REx1"       :: "[idts, lift] \<Rightarrow> lift"                ("(3\<exists>!_./ _)" [0, 10] 10)

translations
  "_const"        \<rightleftharpoons>  "CONST const"

translations
  "_lift"         \<rightleftharpoons> "CONST lift"
  "_lift2"        \<rightleftharpoons> "CONST lift2"
  "_lift3"        \<rightleftharpoons> "CONST lift3"
  "_lift4"        \<rightleftharpoons> "CONST lift4"
  "_Valid"        \<rightleftharpoons> "CONST Valid"

translations
  "_RAll x A"     \<rightleftharpoons> "Rall x. A"
  "_REx x A"      \<rightleftharpoons> "Rex x. A"
  "_REx1 x A"     \<rightleftharpoons> "Rex! x. A"

translations
  "_ARAll"        \<rightharpoonup>  "_RAll"
  "_AREx"         \<rightharpoonup> "_REx"
  "_AREx1"        \<rightharpoonup> "_REx1"

  "w \<Turnstile> A"        \<rightharpoonup> "A w"
  "LIFT A"        \<rightharpoonup> "A::_\<Rightarrow>_"

translations
  "_liftEqu"      \<rightleftharpoons> "_lift2 (=)"
  "_liftNeq u v"  \<rightleftharpoons> "_liftNot (_liftEqu u v)"
  "_liftNot"      \<rightleftharpoons> "_lift (CONST Not)"
  "_liftAnd"      \<rightleftharpoons> "_lift2 (&)"
  "_liftOr"       \<rightleftharpoons> "_lift2 ((|) )"
  "_liftImp"      \<rightleftharpoons> "_lift2 (-->)"
  "_liftIf"       \<rightleftharpoons> "_lift3 (CONST If)"
  "_liftPlus"     \<rightleftharpoons> "_lift2 (+)"
  "_liftMinus"    \<rightleftharpoons> "_lift2 (-)"
  "_liftTimes"    \<rightleftharpoons> "_lift2 (*)"
  "_liftDiv"      \<rightleftharpoons> "_lift2 (div)"
 "_liftMod"      \<rightleftharpoons> "_lift2 (mod)"
  "_liftLess"     \<rightleftharpoons> "_lift2 (<)"
  "_liftLeq"      \<rightleftharpoons> "_lift2 (<=)"
  "_liftMem"      \<rightleftharpoons> "_lift2 (:)"
  "_liftNotMem x xs"             \<rightleftharpoons> "_liftNot (_liftMem x xs)"

translations
  "_liftFinset (_liftargs x xs)" \<rightleftharpoons> "_lift2 (CONST insert) x (_liftFinset xs)"
  "_liftFinset x"                \<rightleftharpoons> "_lift2 (CONST insert) x (_const (CONST Set.empty))"
  "_liftPair x (_liftargs y z)"  \<rightleftharpoons> "_liftPair x (_liftPair y z)"
  "_liftPair"                    \<rightleftharpoons> "_lift2 (CONST Pair)"
  "_liftCons"                    \<rightleftharpoons> "_lift2 (CONST Cons)"
  "_liftApp"                     \<rightleftharpoons> "_lift2 (@)"
  "_liftList (_liftargs x xs)"   \<rightleftharpoons> "_liftCons x (_liftList xs)"
  "_liftList x"                  \<rightleftharpoons> "_liftCons x (_const [])"

  "w \<Turnstile> \<not> A" \<leftharpoondown> "_liftNot A w"
  "w \<Turnstile> A \<and> B" \<leftharpoondown> "_liftAnd A B w"
  "w \<Turnstile> A \<or> B" \<leftharpoondown> "_liftOr A B w"
  "w \<Turnstile> A \<longrightarrow> B" \<leftharpoondown> "_liftImp A B w"
  "w \<Turnstile> u = v" \<leftharpoondown> "_liftEqu u v w"
  "w \<Turnstile> \<forall>x. A" \<leftharpoondown> "_RAll x A w"
  "w \<Turnstile> \<exists>x. A" \<leftharpoondown> "_REx x A w"
  "w \<Turnstile> \<exists>!x. A" \<leftharpoondown> "_REx1 x A w"

syntax (ASCII)
  "_Valid"      :: "lift \<Rightarrow> bool"                        ("(|- _)" 5)
  "_holdsAt"    :: "['a, lift] \<Rightarrow> bool"                  ("(_ |= _)" [100,10] 10)
  "_liftNeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ ~=/ _)" [50,51] 50)
  "_liftNot"    :: "lift \<Rightarrow> lift"                        ("(~ _)" [90] 90)
  "_liftAnd"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ &/ _)" [36,35] 35)
  "_liftOr"     :: "[lift, lift] \<Rightarrow> lift"                ("(_ |/ _)" [31,30] 30)
  "_liftImp"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ -->/ _)" [26,25] 25)
  "_liftLeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ <= _)" [50, 51] 50)
  "_liftMem"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ : _)" [50, 51] 50)
  "_liftNotMem" :: "[lift, lift] \<Rightarrow> lift"                ("(_/ ~: _)" [50, 51] 50)
  "_RAll" :: "[idts, lift] \<Rightarrow> lift"                      ("(3ALL _./ _)" [0, 10] 10)
  "_REx"  :: "[idts, lift] \<Rightarrow> lift"                      ("(3EX _./ _)" [0, 10] 10)
  "_REx1" :: "[idts, lift] \<Rightarrow> lift"                      ("(3EX! _./ _)" [0, 10] 10)

subsection \<open>Lemmas and Tactics\<close>

lemma intD[dest]: "\<turnstile> A \<Longrightarrow> w \<Turnstile> A"
proof -
  assume a:"\<turnstile> A"
  from a have "\<forall>w. w \<Turnstile> A" by (auto simp add: Valid_def)
  thus ?thesis ..
qed

lemma intI [intro!]: assumes P1:"(\<And> w. w \<Turnstile> A)" shows "\<turnstile> A"
  using assms by (auto simp: Valid_def)

text\<open>
  Basic unlifting introduces a parameter @{term w} and applies basic rewrites, e.g
  @{term "\<turnstile> F = G"} becomes @{term "F w = G w"} and @{term "\<turnstile> F \<longrightarrow> G"} becomes
  @{term "F w \<longrightarrow> G w"}.
\<close>

method_setup int_unlift = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD'
    (resolve_tac ctxt @{thms intI} THEN' rewrite_goal_tac ctxt @{thms intensional_rews}))
\<close> "method to unlift and followed by intensional rewrites"

lemma inteq_reflection: assumes P1: "\<turnstile> x=y" shows  "(x \<equiv> y)"
proof -
  from P1 have P2: "\<forall>w. x w = y w" by (unfold Valid_def unl_lift2)
  hence P3:"x=y" by blast
  thus "x \<equiv> y" by (rule "eq_reflection")
qed

lemma int_simps:
  "\<turnstile> (x=x) = #True"
  "\<turnstile> (\<not> #True) = #False"
  "\<turnstile> (\<not> #False) = #True"
  "\<turnstile> (\<not>\<not> P) = P"
  "\<turnstile> ((\<not> P) = P) = #False"
  "\<turnstile> (P = (\<not>P)) = #False"
  "\<turnstile> (P \<noteq> Q) = (P = (\<not> Q))"
  "\<turnstile> (#True=P) = P"
  "\<turnstile> (P=#True) = P"
  "\<turnstile> (#True \<longrightarrow> P) = P"
  "\<turnstile> (#False \<longrightarrow> P) = #True"
  "\<turnstile> (P \<longrightarrow> #True) = #True"
  "\<turnstile> (P \<longrightarrow> P) = #True"
  "\<turnstile> (P \<longrightarrow> #False) = (\<not>P)"
  "\<turnstile> (P \<longrightarrow> ~P) = (\<not>P)"
  "\<turnstile> (P \<and> #True) = P"
  "\<turnstile> (#True \<and> P) = P"
  "\<turnstile> (P \<and> #False) = #False"
  "\<turnstile> (#False \<and> P) = #False"
  "\<turnstile> (P \<and> P) = P"
  "\<turnstile> (P \<and> ~P) = #False"
  "\<turnstile> (\<not>P \<and> P) = #False"
  "\<turnstile> (P \<or> #True) = #True"
  "\<turnstile> (#True \<or> P) = #True"
  "\<turnstile> (P \<or> #False) = P"
  "\<turnstile> (#False \<or> P) = P"
  "\<turnstile> (P \<or> P) = P"
  "\<turnstile> (P \<or> \<not>P) = #True"
  "\<turnstile> (\<not>P \<or> P) = #True"
  "\<turnstile> (\<forall> x. P) = P"
  "\<turnstile> (\<exists> x. P) = P"
  by auto

lemmas intensional_simps[simp] = int_simps[THEN inteq_reflection]

method_setup int_rewrite = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (rewrite_goal_tac ctxt @{thms intensional_simps}))
\<close> "rewrite method at intensional level"

lemma Not_Rall: "\<turnstile> (\<not>(\<forall> x. F x)) = (\<exists> x. \<not>F x)"
  by auto

lemma Not_Rex: "\<turnstile> (\<not>(\<exists> x. F x)) = (\<forall> x. \<not>F x)"
  by auto

lemma TrueW [simp]: "\<turnstile> #True"
  by auto

lemma int_eq: "\<turnstile> X = Y \<Longrightarrow> X = Y"
  by (auto simp: inteq_reflection)

lemma int_iffI:
  assumes "\<turnstile> F \<longrightarrow> G" and "\<turnstile> G \<longrightarrow> F"
  shows "\<turnstile> F = G"
  using assms by force

lemma int_iffD1: assumes h: "\<turnstile> F = G" shows "\<turnstile> F \<longrightarrow> G"
  using h by auto

lemma int_iffD2: assumes h: "\<turnstile> F = G" shows "\<turnstile> G \<longrightarrow> F"
  using h by auto

lemma lift_imp_trans:
  assumes "\<turnstile> A \<longrightarrow> B" and "\<turnstile> B \<longrightarrow> C"
  shows "\<turnstile> A \<longrightarrow> C"
  using assms by force

lemma lift_imp_neg: assumes "\<turnstile> A \<longrightarrow> B" shows "\<turnstile> \<not>B \<longrightarrow> \<not>A"
  using assms by auto

lemma lift_and_com:  "\<turnstile> (A \<and> B) = (B \<and> A)"
  by auto

end


(* Author: Alexander Maletzky *)

section \<open>Sample Computations of Gr\"obner Bases via Macaulay Matrices\<close>

theory Groebner_Macaulay_Examples
  imports
    Groebner_Macaulay
    Dube_Bound
    Groebner_Bases.Benchmarks
    Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
    Groebner_Bases.Code_Target_Rat
begin

subsection \<open>Combining @{theory Groebner_Macaulay.Groebner_Macaulay} and
  @{theory Groebner_Macaulay.Dube_Bound}\<close>

context extended_ord_pm_powerprod
begin

theorem thm_2_3_6_Dube:
  assumes "finite X" and "set fs \<subseteq> P[X]"
  shows "punit.is_Groebner_basis (set (punit.Macaulay_list
                                        (deg_shifts X (Dube (Suc (card X)) (maxdeg (set fs))) fs)))"
  using assms Dube_is_GB_cofactor_bound by (rule thm_2_3_6) (simp_all add: assms)

theorem thm_2_3_7_Dube:
  assumes "finite X" and "set fs \<subseteq> P[X]"
  shows "1 \<in> ideal (set fs) \<longleftrightarrow>
          1 \<in> set (punit.Macaulay_list (deg_shifts X (Dube (Suc (card X)) (maxdeg (set fs))) fs))"
  using assms Dube_is_GB_cofactor_bound by (rule thm_2_3_7) (simp_all add: assms)

theorem thm_2_3_6_indets_Dube:
  fixes fs
  defines "X \<equiv> \<Union>(indets ` set fs)"
  shows "punit.is_Groebner_basis (set (punit.Macaulay_list
                                        (deg_shifts X (Dube (Suc (card X)) (maxdeg (set fs))) fs)))"
  unfolding X_def using Dube_is_GB_cofactor_bound_indets by (rule thm_2_3_6_indets) (fact finite_set)

theorem thm_2_3_7_indets_Dube:
  fixes fs
  defines "X \<equiv> \<Union>(indets ` set fs)"
  shows "1 \<in> ideal (set fs) \<longleftrightarrow>
          1 \<in> set (punit.Macaulay_list (deg_shifts X (Dube (Suc (card X)) (maxdeg (set fs))) fs))"
  unfolding X_def using Dube_is_GB_cofactor_bound_indets by (rule thm_2_3_7_indets) (fact finite_set)

end (* extended_ord_pm_powerprod *)

subsection \<open>Preparations\<close>

(* This is exactly the same as in "Groebner_Bases.F4_Examples". Pull out into common ancestor? *)

primrec remdups_wrt_rev :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'a list" where
  "remdups_wrt_rev f [] vs = []" |
  "remdups_wrt_rev f (x # xs) vs =
    (let fx = f x in if List.member vs fx then remdups_wrt_rev f xs vs else x # (remdups_wrt_rev f xs (fx # vs)))"

lemma remdups_wrt_rev_notin: "v \<in> set vs \<Longrightarrow> v \<notin> f ` set (remdups_wrt_rev f xs vs)"
proof (induct xs arbitrary: vs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  from Cons(2) have 1: "v \<notin> f ` set (remdups_wrt_rev f xs vs)" by (rule Cons(1))
  from Cons(2) have "v \<in> set (f x # vs)" by simp
  hence 2: "v \<notin> f ` set (remdups_wrt_rev f xs (f x # vs))" by (rule Cons(1))
  from Cons(2) show ?case by (auto simp: Let_def 1 2 List.member_def)
qed

lemma distinct_remdups_wrt_rev: "distinct (map f (remdups_wrt_rev f xs vs))"
proof (induct xs arbitrary: vs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  show ?case by (simp add: Let_def Cons(1) remdups_wrt_rev_notin)
qed

lemma map_of_remdups_wrt_rev':
  "map_of (remdups_wrt_rev fst xs vs) k = map_of (filter (\<lambda>x. fst x \<notin> set vs) xs) k"
proof (induct xs arbitrary: vs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  show ?case
  proof (simp add: Let_def List.member_def Cons, intro impI)
    assume "k \<noteq> fst x"
    have "map_of (filter (\<lambda>y. fst y \<noteq> fst x \<and> fst y \<notin> set vs) xs) =
          map_of (filter (\<lambda>y. fst y \<noteq> fst x) (filter (\<lambda>y. fst y \<notin> set vs) xs))"
      by (simp only: filter_filter conj_commute)
    also have "... = map_of (filter (\<lambda>y. fst y \<notin> set vs) xs) |` {y. y \<noteq> fst x}" by (rule map_of_filter)
    finally show "map_of (filter (\<lambda>y. fst y \<noteq> fst x \<and> fst y \<notin> set vs) xs) k =
                  map_of (filter (\<lambda>y. fst y \<notin> set vs) xs) k"
      by (simp add: restrict_map_def \<open>k \<noteq> fst x\<close>)
  qed
qed

corollary map_of_remdups_wrt_rev: "map_of (remdups_wrt_rev fst xs []) = map_of xs"
  by (rule ext, simp add: map_of_remdups_wrt_rev')

lemma (in term_powerprod) compute_list_to_poly [code]:
  "list_to_poly ts cs = distr\<^sub>0 DRLEX (remdups_wrt_rev fst (zip ts cs) [])"
  by (rule poly_mapping_eqI,
      simp add: lookup_list_to_poly list_to_fun_def distr\<^sub>0_def oalist_of_list_ntm_def
        oa_ntm.lookup_oalist_of_list distinct_remdups_wrt_rev lookup_dflt_def map_of_remdups_wrt_rev)

lemma (in ordered_term) compute_Macaulay_list [code]:
  "Macaulay_list ps =
     (let ts = Keys_to_list ps in
      filter (\<lambda>p. p \<noteq> 0) (mat_to_polys ts (row_echelon (polys_to_mat ts ps)))
     )"
  by (simp add: Macaulay_list_def Macaulay_mat_def Let_def)

declare conversep_iff [code]

derive (eq) ceq poly_mapping
derive (no) ccompare poly_mapping
derive (dlist) set_impl poly_mapping
derive (no) cenum poly_mapping

derive (eq) ceq rat
derive (no) ccompare rat
derive (dlist) set_impl rat
derive (no) cenum rat

subsubsection \<open>Connection between @{typ "('x \<Rightarrow>\<^sub>0 'a) \<Rightarrow>\<^sub>0 'b"} and @{typ "('x, 'a) pp \<Rightarrow>\<^sub>0 'b"}\<close>

(* Move into "Polynomials.PP_Type"? *)

definition keys_pp_to_list :: "('x::linorder, 'a::zero) pp \<Rightarrow> 'x list"
  where "keys_pp_to_list t = sorted_list_of_set (keys_pp t)"

lemma inj_PP: "inj PP"
  by (simp add: PP_inject inj_def)

lemma inj_mapping_of: "inj mapping_of"
  by (simp add: mapping_of_inject inj_def)

lemma mapping_of_comp_PP [simp]:
  "mapping_of \<circ> PP = (\<lambda>x. x)"
  "PP \<circ> mapping_of = (\<lambda>x. x)"
  by (simp_all add: comp_def PP_inverse mapping_of_inverse)

lemma map_key_PP_mapping_of [simp]: "Poly_Mapping.map_key PP (Poly_Mapping.map_key mapping_of p) = p"
  by (simp add: map_key_compose[OF inj_PP inj_mapping_of] comp_def PP_inverse map_key_id)

lemma map_key_mapping_of_PP [simp]: "Poly_Mapping.map_key mapping_of (Poly_Mapping.map_key PP p) = p"
  by (simp add: map_key_compose[OF inj_mapping_of inj_PP] comp_def mapping_of_inverse map_key_id)

lemmas map_key_PP_plus = map_key_plus[OF inj_PP]
lemmas map_key_PP_zero [simp] = map_key_zero[OF inj_PP]

lemma lookup_map_key_PP: "lookup (Poly_Mapping.map_key PP p) t = lookup p (PP t)"
  by (simp add: map_key.rep_eq inj_PP)

lemma keys_map_key_PP: "keys (Poly_Mapping.map_key PP p) = mapping_of ` keys p"
  by (simp add: keys_map_key inj_PP)
     (smt Collect_cong PP_inverse UNIV_I image_def pp.mapping_of_inverse vimage_def)

lemma map_key_PP_zero_iff [iff]: "Poly_Mapping.map_key PP p = 0 \<longleftrightarrow> p = 0"
  by (metis map_key_PP_zero map_key_mapping_of_PP)

lemma map_key_PP_uminus [simp]: "Poly_Mapping.map_key PP (- p) = - Poly_Mapping.map_key PP p"
  by (rule poly_mapping_eqI) (simp add: lookup_map_key_PP)

lemma map_key_PP_minus:
  "Poly_Mapping.map_key PP (p - q) = Poly_Mapping.map_key PP p - Poly_Mapping.map_key PP q"
  by (rule poly_mapping_eqI) (simp add: lookup_map_key_PP lookup_minus)

lemma map_key_PP_monomial [simp]: "Poly_Mapping.map_key PP (monomial c t) = monomial c (mapping_of t)"
proof -
  have "Poly_Mapping.map_key PP (monomial c t) = Poly_Mapping.map_key PP (monomial c (PP (mapping_of t)))"
    by (simp only: mapping_of_inverse)
  also from inj_PP have "\<dots> = monomial c (mapping_of t)" by (fact map_key_single)
  finally show ?thesis .
qed

lemma map_key_PP_one [simp]: "Poly_Mapping.map_key PP 1 = 1"
  by (simp add: zero_pp.rep_eq flip: single_one)

lemma map_key_PP_monom_mult_punit:
  "Poly_Mapping.map_key PP (monom_mult_punit c t p) =
    monom_mult_punit c (mapping_of t) (Poly_Mapping.map_key PP p)"
  by (rule poly_mapping_eqI)
     (simp add: punit.lookup_monom_mult monom_mult_punit_def adds_pp_iff PP_inverse lookup_map_key_PP
          mapping_of_inverse flip: minus_pp.abs_eq)

lemma map_key_PP_times:
  "Poly_Mapping.map_key PP (p * q) =
    Poly_Mapping.map_key PP p * Poly_Mapping.map_key PP (q::(_, _::add_linorder) pp \<Rightarrow>\<^sub>0 _)"
  by (induct p rule: poly_mapping_plus_induct)
     (simp_all add: distrib_right map_key_PP_plus times_monomial_left map_key_PP_monom_mult_punit
        flip: monom_mult_punit_def)

lemma map_key_PP_sum: "Poly_Mapping.map_key PP (sum f A) = (\<Sum>a\<in>A. Poly_Mapping.map_key PP (f a))"
  by (induct A rule: infinite_finite_induct) (simp_all add: map_key_PP_plus)

lemma map_key_PP_ideal:
  "Poly_Mapping.map_key PP ` ideal F = ideal (Poly_Mapping.map_key PP ` (F::((_, _::add_linorder) pp \<Rightarrow>\<^sub>0 _) set))"
proof -
  from map_key_PP_mapping_of have "surj (Poly_Mapping.map_key PP)" by (rule surjI)
  with map_key_PP_plus map_key_PP_times show ?thesis by (rule image_ideal_eq_surj)
qed

subsubsection \<open>Locale \<open>pp_powerprod\<close>\<close>

text \<open>We have to introduce a new locale analogous to @{locale pm_powerprod}, but this time for
  power-products represented by @{type pp} rather than @{type poly_mapping}. This apparently leads
  to some (more-or-less) duplicate definitions and lemmas, but seems to be the only feasible way to
  get both
  \<^item> the convenient representation by @{type poly_mapping} for theory development, and
  \<^item> the executable representation by @{type pp} for code generation.\<close>

locale pp_powerprod =
  ordered_powerprod ord ord_strict
  for ord::"('x::{countable,linorder}, nat) pp \<Rightarrow> ('x, nat) pp \<Rightarrow> bool"
  and ord_strict
begin

sublocale gd_powerprod ..

sublocale pp_pm: extended_ord_pm_powerprod "\<lambda>s t. ord (PP s) (PP t)" "\<lambda>s t. ord_strict (PP s) (PP t)"
  by standard (auto simp: zero_min plus_monotone simp flip: zero_pp_def plus_pp.abs_eq PP_inject)

definition poly_deg_pp :: "(('x, nat) pp \<Rightarrow>\<^sub>0 'a::zero) \<Rightarrow> nat"
  where "poly_deg_pp p = (if p = 0 then 0 else max_list (map deg_pp (punit.keys_to_list p)))"

primrec deg_le_sect_pp_aux :: "'x list \<Rightarrow> nat \<Rightarrow> ('x, nat) pp \<Rightarrow>\<^sub>0 nat" where
  "deg_le_sect_pp_aux xs 0 = 1" |
  "deg_le_sect_pp_aux xs (Suc n) =
    (let p = deg_le_sect_pp_aux xs n in p + foldr (\<lambda>x. (+) (monom_mult_punit 1 (single_pp x 1) p)) xs 0)"

definition deg_le_sect_pp  :: "'x list \<Rightarrow> nat \<Rightarrow> ('x, nat) pp list"
  where "deg_le_sect_pp xs d = punit.keys_to_list (deg_le_sect_pp_aux xs d)"

definition deg_shifts_pp :: "'x list \<Rightarrow> nat \<Rightarrow>
                                (('x, nat) pp \<Rightarrow>\<^sub>0 'b) list \<Rightarrow> (('x, nat) pp \<Rightarrow>\<^sub>0 'b::semiring_1) list"
  where "deg_shifts_pp xs d fs = concat (map (\<lambda>f. (map (\<lambda>t. monom_mult_punit 1 t f)
                                          (deg_le_sect_pp xs (d - poly_deg_pp f)))) fs)"

definition indets_pp :: "(('x, nat) pp \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 'x list"
  where "indets_pp p = remdups (concat (map keys_pp_to_list (punit.keys_to_list p)))"

definition Indets_pp :: "(('x, nat) pp \<Rightarrow>\<^sub>0 'b::zero) list \<Rightarrow> 'x list"
  where "Indets_pp ps = remdups (concat (map indets_pp ps))"

lemma map_PP_insort:
  "map PP (pp_pm.ordered_powerprod_lin.insort x xs) = ordered_powerprod_lin.insort (PP x) (map PP xs)"
  by (induct xs) simp_all

lemma map_PP_sorted_list_of_set:
  "map PP (pp_pm.ordered_powerprod_lin.sorted_list_of_set T) =
    ordered_powerprod_lin.sorted_list_of_set (PP ` T)"
proof (induct T rule: infinite_finite_induct)
  case (infinite T)
  moreover from inj_PP subset_UNIV have "inj_on PP T" by (rule inj_on_subset)
  ultimately show ?case by (simp add: inj_PP finite_image_iff)
next
  case empty
  show ?case by simp
next
  case (insert t T)
  moreover from insert(2) have "PP t \<notin> PP ` T" by (simp add: PP_inject image_iff)
  ultimately show ?case by (simp add: map_PP_insort)
qed

lemma map_PP_pps_to_list: "map PP (pp_pm.punit.pps_to_list T) = punit.pps_to_list (PP ` T)"
  by (simp add: pp_pm.punit.pps_to_list_def punit.pps_to_list_def map_PP_sorted_list_of_set flip: rev_map)

lemma map_mapping_of_pps_to_list:
  "map mapping_of (punit.pps_to_list T) = pp_pm.punit.pps_to_list (mapping_of ` T)"
proof -
  have "map mapping_of (punit.pps_to_list T) = map mapping_of (punit.pps_to_list (PP ` mapping_of ` T))"
    by (simp add: image_comp)
  also have "\<dots> = map mapping_of (map PP (pp_pm.punit.pps_to_list (mapping_of ` T)))"
    by (simp only: map_PP_pps_to_list)
  also have "\<dots> = pp_pm.punit.pps_to_list (mapping_of ` T)" by simp
  finally show ?thesis .
qed

lemma keys_to_list_map_key_PP:
  "pp_pm.punit.keys_to_list (Poly_Mapping.map_key PP p) = map mapping_of (punit.keys_to_list p)"
  by (simp add: pp_pm.punit.keys_to_list_def punit.keys_to_list_def keys_map_key_PP map_mapping_of_pps_to_list)

lemma Keys_to_list_map_key_PP:
  "pp_pm.punit.Keys_to_list (map (Poly_Mapping.map_key PP) fs) = map mapping_of (punit.Keys_to_list fs)"
  by (simp add: punit.Keys_to_list_eq_pps_to_list pp_pm.punit.Keys_to_list_eq_pps_to_list
          map_mapping_of_pps_to_list Keys_def image_UN keys_map_key_PP)

lemma poly_deg_map_key_PP: "poly_deg (Poly_Mapping.map_key PP p) = poly_deg_pp p"
proof -
  {
    assume "p \<noteq> 0"
    hence "map deg_pp (punit.keys_to_list p) \<noteq> []"
      by (simp add: punit.keys_to_list_def punit.pps_to_list_def)
    hence "Max (deg_pp ` keys p) = max_list (map deg_pp (punit.keys_to_list p))"
      by (simp add: max_list_Max punit.set_keys_to_list)
  }
  thus ?thesis
    by (simp add: poly_deg_def poly_deg_pp_def keys_map_key_PP image_image flip: deg_pp.rep_eq)
qed

lemma deg_le_sect_pp_aux_1:
  assumes "t \<in> keys (deg_le_sect_pp_aux xs n)"
  shows "deg_pp t \<le> n" and "keys_pp t \<subseteq> set xs"
proof -
  from assms have "deg_pp t \<le> n \<and> keys_pp t \<subseteq> set xs"
  proof (induct n arbitrary: t)
    case 0
    thus ?case by (simp_all add: keys_pp.rep_eq zero_pp.rep_eq)
  next
    case (Suc n)
    define X where "X = set xs"
    define q where "q = deg_le_sect_pp_aux xs n"
    have 1: "s \<in> keys q \<Longrightarrow> deg_pp s \<le> n \<and> keys_pp s \<subseteq> X" for s unfolding q_def X_def by (fact Suc.hyps)
    note Suc.prems
    also have "keys (deg_le_sect_pp_aux xs (Suc n)) \<subseteq> keys q \<union>
                    keys (foldr (\<lambda>x. (+) (monom_mult_punit 1 (single_pp x 1) q)) xs 0)"
      (is "_ \<subseteq> _ \<union> keys (foldr ?r xs 0)") by (simp add: Let_def Poly_Mapping.keys_add flip: q_def)
    finally show ?case
    proof
      assume "t \<in> keys q"
      hence "deg_pp t \<le> n \<and> keys_pp t \<subseteq> set xs" unfolding q_def by (rule Suc.hyps)
      thus ?thesis by simp
    next
      assume "t \<in> keys (foldr ?r xs 0)"
      moreover have "set xs \<subseteq> X" by (simp add: X_def)
      ultimately have "deg_pp t \<le> Suc n \<and> keys_pp t \<subseteq> X"
      proof (induct xs arbitrary: t)
        case Nil
        thus ?case by simp
      next
        case (Cons x xs)
        from Cons.prems(2) have "x \<in> X" and "set xs \<subseteq> X" by simp_all
        note Cons.prems(1)
        also have "keys (foldr ?r (x # xs) 0) \<subseteq> keys (?r x 0) \<union> keys (foldr ?r xs 0)"
          by (simp add: Poly_Mapping.keys_add)
        finally show ?case
        proof
          assume "t \<in> keys (?r x 0)"
          also have "\<dots> = (+) (single_pp x 1) ` keys q"
            by (simp add: monom_mult_punit_def punit.keys_monom_mult)
          finally obtain s where "s \<in> keys q" and t: "t = single_pp x 1 + s" ..
          from this(1) have "deg_pp s \<le> n \<and> keys_pp s \<subseteq> X" by (rule 1)
          with \<open>x \<in> X\<close> show ?thesis
            by (simp add: t deg_pp_plus deg_pp_single keys_pp.rep_eq plus_pp.rep_eq
                keys_plus_ninv_comm_monoid_add single_pp.rep_eq)
        next
          assume "t \<in> keys (foldr ?r xs 0)"
          thus "deg_pp t \<le> Suc n \<and> keys_pp t \<subseteq> X" using \<open>set xs \<subseteq> X\<close> by (rule Cons.hyps)
        qed
      qed
      thus ?thesis by (simp only: X_def)
    qed
  qed
  thus "deg_pp t \<le> n" and "keys_pp t \<subseteq> set xs" by simp_all
qed

lemma deg_le_sect_pp_aux_2:
  assumes "deg_pp t \<le> n" and "keys_pp t \<subseteq> set xs"
  shows "t \<in> keys (deg_le_sect_pp_aux xs n)"
  using assms
proof (induct n arbitrary: t)
  case 0
  thus ?case by simp
next
  case (Suc n)
  have foldr: "foldr (\<lambda>x. (+) (f x)) ys 0 + y = foldr (\<lambda>x. (+) (f x)) ys y"
    for f ys and y::"'z::monoid_add" by (induct ys) (simp_all add: ac_simps)
  define q where "q = deg_le_sect_pp_aux xs n"
  from Suc.prems(1) have "deg_pp t \<le> n \<or> deg_pp t = Suc n" by auto
  thus ?case
  proof
    assume "deg_pp t \<le> n"
    hence "t \<in> keys q" unfolding q_def using Suc.prems(2) by (rule Suc.hyps)
    hence "0 < lookup q t" by (simp add: in_keys_iff)
    also have "\<dots> \<le> lookup (deg_le_sect_pp_aux xs (Suc n)) t"
      by (simp add: Let_def lookup_add flip: q_def)
    finally show ?thesis by (simp add: in_keys_iff)
  next
    assume eq: "deg_pp t = Suc n"
    hence "keys_pp t \<noteq> {}" by (auto simp: keys_pp.rep_eq deg_pp.rep_eq)
    then obtain x where "x \<in> keys_pp t" by blast
    with Suc.prems(2) have "x \<in> set xs" ..
    then obtain xs1 xs2 where xs: "xs = xs1 @ x # xs2" by (meson split_list)
    define s where "s = t - single_pp x 1"
    from \<open>x \<in> keys_pp t\<close> have "single_pp x 1 adds t"
      by (simp add: adds_pp_iff single_pp.rep_eq keys_pp.rep_eq adds_poly_mapping le_fun_def
          lookup_single when_def in_keys_iff)
    hence "s + single_pp x 1 = (t + single_pp x 1) - single_pp x 1"
      unfolding s_def by (rule minus_plus)
    hence t: "t = single_pp x 1 + s" by (simp add: add.commute)
    with eq have "deg_pp s \<le> n" by (simp add: deg_pp_plus deg_pp_single)
    moreover have "keys_pp s \<subseteq> set xs"
    proof (rule subset_trans)
      from Suc.prems(2) \<open>x \<in> set xs\<close> show "keys_pp t \<union> keys_pp (single_pp x (Suc 0)) \<subseteq> set xs"
        by (simp add: keys_pp.rep_eq single_pp.rep_eq)
    qed (simp add: s_def keys_pp.rep_eq minus_pp.rep_eq keys_diff)
    ultimately have "s \<in> keys q" unfolding q_def by (rule Suc.hyps)
    hence "t \<in> keys (monom_mult_punit 1 (single_pp x 1) q)"
      by (simp add: monom_mult_punit_def punit.keys_monom_mult t)
    hence "0 < lookup (monom_mult_punit 1 (single_pp x 1) q) t" by (simp add: in_keys_iff)
    also have "\<dots> \<le> lookup (q + (foldr (\<lambda>x. (+) (monom_mult_punit 1 (single_pp x 1) q)) xs1 0 +
                      (monom_mult_punit 1 (single_pp x 1) q +
                        foldr (\<lambda>x. (+) (monom_mult_punit 1 (single_pp x 1) q)) xs2 0))) t"
      by (simp add: lookup_add)
    also have "\<dots> = lookup (deg_le_sect_pp_aux xs (Suc n)) t"
      by (simp add: Let_def foldr flip: q_def, simp add: xs)
    finally show ?thesis by (simp add: in_keys_iff)
  qed
qed

lemma keys_deg_le_sect_pp_aux:
  "keys (deg_le_sect_pp_aux xs n) = {t. deg_pp t \<le> n \<and> keys_pp t \<subseteq> set xs}"
  by (auto dest: deg_le_sect_pp_aux_1 deg_le_sect_pp_aux_2)

lemma deg_le_sect_deg_le_sect_pp:
  "map PP (pp_pm.punit.pps_to_list (deg_le_sect (set xs) d)) = deg_le_sect_pp xs d"
proof -
  have "PP ` {t. deg_pm t \<le> d \<and> keys t \<subseteq> set xs} = PP ` {t. deg_pp (PP t) \<le> d \<and> keys_pp (PP t) \<subseteq> set xs}"
    by (simp only: keys_pp.abs_eq deg_pp.abs_eq)
  also have "\<dots> = {t. deg_pp t \<le> d \<and> keys_pp t \<subseteq> set xs}"
  proof (intro subset_antisym subsetI)
    fix t
    assume "t \<in> {t. deg_pp t \<le> d \<and> keys_pp t \<subseteq> set xs}"
    moreover have "t = PP (mapping_of t)" by (simp only: mapping_of_inverse)
    ultimately show "t \<in> PP ` {t. deg_pp (PP t) \<le> d \<and> keys_pp (PP t) \<subseteq> set xs}" by auto
  qed auto
  finally show ?thesis
    by (simp add: deg_le_sect_pp_def punit.keys_to_list_def keys_deg_le_sect_pp_aux deg_le_sect_alt
      PPs_def conj_commute map_PP_pps_to_list flip: Collect_conj_eq)
qed

lemma deg_shifts_deg_shifts_pp:
  "pp_pm.deg_shifts (set xs) d (map (Poly_Mapping.map_key PP) fs) =
        map (Poly_Mapping.map_key PP) (deg_shifts_pp xs d fs)"
  by (simp add: pp_pm.deg_shifts_def deg_shifts_pp_def map_concat comp_def poly_deg_map_key_PP
         map_key_PP_monom_mult_punit PP_inverse flip: deg_le_sect_deg_le_sect_pp monom_mult_punit_def)

lemma ideal_deg_shifts_pp: "ideal (set (deg_shifts_pp xs d fs)) = ideal (set fs)"
proof -
  have "ideal (set (deg_shifts_pp xs d fs)) =
        Poly_Mapping.map_key mapping_of ` Poly_Mapping.map_key PP ` ideal (set (deg_shifts_pp xs d fs))"
    by (simp add: image_comp)
  also have "\<dots> = Poly_Mapping.map_key mapping_of ` ideal
                    (set (map (Poly_Mapping.map_key PP) (deg_shifts_pp xs d fs)))"
    by (simp add: map_key_PP_ideal)
  also have "\<dots> = Poly_Mapping.map_key mapping_of ` ideal (Poly_Mapping.map_key PP ` set fs)"
    by (simp flip: deg_shifts_deg_shifts_pp)
  also have "\<dots> = Poly_Mapping.map_key mapping_of ` Poly_Mapping.map_key PP ` ideal (set fs)"
    by (simp only: map_key_PP_ideal)
  also have "\<dots> = ideal (set fs)" by (simp add: image_comp)
  finally show ?thesis .
qed

lemma set_indets_pp: "set (indets_pp p) = indets (Poly_Mapping.map_key PP p)"
  by (simp add: indets_pp_def indets_def keys_pp_to_list_def keys_pp.rep_eq punit.set_keys_to_list
        keys_map_key_PP)

lemma poly_to_row_map_key_PP:
  "poly_to_row (map pp.mapping_of xs) (Poly_Mapping.map_key PP p) = poly_to_row xs p"
  by (simp add: poly_to_row_def comp_def lookup_map_key_PP mapping_of_inverse)

lemma Macaulay_mat_map_key_PP:
  "pp_pm.punit.Macaulay_mat (map (Poly_Mapping.map_key PP) fs) = punit.Macaulay_mat fs"
  by (simp add: punit.Macaulay_mat_def pp_pm.punit.Macaulay_mat_def Keys_to_list_map_key_PP
          polys_to_mat_def comp_def poly_to_row_map_key_PP)

lemma row_to_poly_mapping_of:
  assumes "distinct ts" and "dim_vec r = length ts"
  shows "row_to_poly (map pp.mapping_of ts) r = Poly_Mapping.map_key PP (row_to_poly ts r)"
proof (rule poly_mapping_eqI, simp only: lookup_map_key_PP)
  fix t
  let ?ts = "map mapping_of ts"
  from inj_mapping_of subset_UNIV have "inj_on mapping_of (set ts)" by (rule inj_on_subset)
  with assms(1) have 1: "distinct ?ts" by (simp add: distinct_map)
  from assms(2) have 2: "dim_vec r = length ?ts" by simp
  show "lookup (row_to_poly ?ts r) t = lookup (row_to_poly ts r) (PP t)"
  proof (cases "t \<in> set ?ts")
    case True
    then obtain i where i1: "i < length ?ts" and t1: "t = ?ts ! i" by (metis in_set_conv_nth)
    hence i2: "i < length ts" and t2: "PP t = ts ! i" by (simp_all add: mapping_of_inverse)
    have "lookup (row_to_poly ?ts r) t = r $ i"
      unfolding t1 using 1 2 i1 by (rule punit.lookup_row_to_poly)
    moreover have "lookup (row_to_poly ts r) (PP t) = r $ i"
      unfolding t2 using assms i2 by (rule punit.lookup_row_to_poly)
    ultimately show ?thesis by simp
  next
    case False
    have "PP t \<notin> set ts"
    proof
      assume "PP t \<in> set ts"
      hence "mapping_of (PP t) \<in> mapping_of ` set ts" by (rule imageI)
      with False show False by (simp add: PP_inverse)
    qed
    with punit.keys_row_to_poly have "lookup (row_to_poly ts r) (PP t) = 0"
      by (metis in_keys_iff in_mono)
    moreover from False punit.keys_row_to_poly have "lookup (row_to_poly ?ts r) t = 0"
      by (metis in_keys_iff in_mono)
    ultimately show ?thesis by simp
  qed
qed

lemma mat_to_polys_mapping_of:
  assumes "distinct ts" and "dim_col m = length ts"
  shows "mat_to_polys (map pp.mapping_of ts) m = map (Poly_Mapping.map_key PP) (mat_to_polys ts m)"
proof -
  {
    fix r
    assume "r \<in> set (rows m)"
    then obtain i where "r = row m i" by (auto simp: rows_def)
    hence "dim_vec r = length ts" by (simp add: assms(2))
    with assms(1) have "row_to_poly (map pp.mapping_of ts) r = Poly_Mapping.map_key PP (row_to_poly ts r)"
      by (rule row_to_poly_mapping_of)
  }
  thus ?thesis using assms by (simp add: mat_to_polys_def)
qed

lemma map_key_PP_Macaulay_list:
  "map (Poly_Mapping.map_key PP) (punit.Macaulay_list fs) =
      pp_pm.punit.Macaulay_list (map (Poly_Mapping.map_key PP) fs)"
  by (simp add: punit.Macaulay_list_def pp_pm.punit.Macaulay_list_def Macaulay_mat_map_key_PP
          Keys_to_list_map_key_PP mat_to_polys_mapping_of filter_map comp_def
          punit.distinct_Keys_to_list punit.length_Keys_to_list)

lemma lpp_map_key_PP: "pp_pm.lpp (Poly_Mapping.map_key PP p) = mapping_of (lpp p)"
proof (cases "p = 0")
  case True
  thus ?thesis by (simp add: zero_pp.rep_eq)
next
  case False
  show ?thesis
  proof (rule pp_pm.punit.lt_eqI_keys)
    show "pp.mapping_of (lpp p) \<in> keys (Poly_Mapping.map_key PP p)" unfolding keys_map_key_PP
      by (intro imageI punit.lt_in_keys False)
  next
    fix s
    assume "s \<in> keys (Poly_Mapping.map_key PP p)"
    then obtain t where "t \<in> keys p" and s: "s = mapping_of t" unfolding keys_map_key_PP ..
    thus "ord (PP s) (PP (pp.mapping_of (lpp p)))" by (simp add: mapping_of_inverse punit.lt_max_keys)
  qed
qed

lemma is_GB_map_key_PP:
  "finite G \<Longrightarrow> pp_pm.punit.is_Groebner_basis (Poly_Mapping.map_key PP ` G) \<longleftrightarrow> punit.is_Groebner_basis G"
  by (simp add: punit.GB_alt_3_finite pp_pm.punit.GB_alt_3_finite lpp_map_key_PP adds_pp_iff
        flip: map_key_PP_ideal)

lemma thm_2_3_6_pp:
  assumes "pp_pm.is_GB_cofactor_bound (Poly_Mapping.map_key PP ` set fs) b"
  shows "punit.is_Groebner_basis (set (punit.Macaulay_list (deg_shifts_pp (Indets_pp fs) b fs)))"
proof -
  let ?fs = "map (Poly_Mapping.map_key PP) fs"
  from assms have "pp_pm.is_GB_cofactor_bound (set ?fs) b" by simp
  hence "pp_pm.punit.is_Groebner_basis
                (set (pp_pm.punit.Macaulay_list (pp_pm.deg_shifts (\<Union> (indets ` set ?fs)) b ?fs)))"
    by (rule pp_pm.thm_2_3_6_indets)
  also have "(\<Union> (indets ` set ?fs)) = set (Indets_pp fs)" by (simp add: Indets_pp_def set_indets_pp)
  finally show ?thesis
    by (simp add: deg_shifts_deg_shifts_pp map_key_PP_Macaulay_list flip: set_map is_GB_map_key_PP)
qed

lemma Dube_is_GB_cofactor_bound_pp:
  "pp_pm.is_GB_cofactor_bound (Poly_Mapping.map_key PP ` set fs)
            (Dube (Suc (length (Indets_pp fs))) (max_list (map poly_deg_pp fs)))"
proof (cases "fs = []")
  case True
  show ?thesis by (rule pp_pm.is_GB_cofactor_boundI_subset_zero) (simp add: True)
next
  case False
  let ?F = "Poly_Mapping.map_key PP ` set fs"
  have "pp_pm.is_GB_cofactor_bound ?F (Dube (Suc (card (\<Union> (indets ` ?F)))) (maxdeg ?F))"
    by (intro pp_pm.Dube_is_GB_cofactor_bound_indets finite_imageI finite_set)
  moreover have "card (\<Union> (indets ` ?F)) = length (Indets_pp fs)"
    by (simp add: Indets_pp_def length_remdups_card_conv set_indets_pp)
  moreover from False have "maxdeg ?F = max_list (map poly_deg_pp fs)"
    by (simp add: max_list_Max maxdeg_def image_image poly_deg_map_key_PP)
  ultimately show ?thesis by simp
qed

definition GB_Macaulay_Dube :: "(('x, nat) pp \<Rightarrow>\<^sub>0 'a) list \<Rightarrow> (('x, nat) pp \<Rightarrow>\<^sub>0 'a::field) list"
  where "GB_Macaulay_Dube fs = punit.Macaulay_list (deg_shifts_pp (Indets_pp fs)
                            (Dube (Suc (length (Indets_pp fs))) (max_list (map poly_deg_pp fs))) fs)"

lemma GB_Macaulay_Dube_is_GB: "punit.is_Groebner_basis (set (GB_Macaulay_Dube fs))"
  unfolding GB_Macaulay_Dube_def using Dube_is_GB_cofactor_bound_pp by (rule thm_2_3_6_pp)

lemma ideal_GB_Macaulay_Dube: "ideal (set (GB_Macaulay_Dube fs)) = ideal (set fs)"
  by (simp add: GB_Macaulay_Dube_def punit.pmdl_Macaulay_list[simplified] ideal_deg_shifts_pp)

end

global_interpretation punit': pp_powerprod "ord_pp_punit cmp_term" "ord_pp_strict_punit cmp_term"
  rewrites "punit.adds_term = (adds)"
  and "punit.pp_of_term = (\<lambda>x. x)"
  and "punit.component_of_term = (\<lambda>_. ())"
  and "punit.monom_mult = monom_mult_punit"
  and "punit.mult_scalar = mult_scalar_punit"
  and "punit'.punit.min_term = min_term_punit"
  and "punit'.punit.lt = lt_punit cmp_term"
  and "punit'.punit.lc = lc_punit cmp_term"
  and "punit'.punit.tail = tail_punit cmp_term"
  and "punit'.punit.ord_p = ord_p_punit cmp_term"
  and "punit'.punit.keys_to_list = keys_to_list_punit cmp_term"
  for cmp_term :: "('a::nat, nat) pp nat_term_order"

  defines max_punit = punit'.ordered_powerprod_lin.max
  and max_list_punit = punit'.ordered_powerprod_lin.max_list
  and Keys_to_list_punit = punit'.punit.Keys_to_list
  and Macaulay_mat_punit = punit'.punit.Macaulay_mat
  and Macaulay_list_punit = punit'.punit.Macaulay_list
  and poly_deg_pp_punit = punit'.poly_deg_pp
  and deg_le_sect_pp_aux_punit = punit'.deg_le_sect_pp_aux
  and deg_le_sect_pp_punit = punit'.deg_le_sect_pp
  and deg_shifts_pp_punit = punit'.deg_shifts_pp
  and indets_pp_punit = punit'.indets_pp
  and Indets_pp_punit = punit'.Indets_pp
  and GB_Macaulay_Dube_punit = punit'.GB_Macaulay_Dube

  (* Only needed for auto-reduction: *)
  and find_adds_punit = punit'.punit.find_adds
  and trd_aux_punit = punit'.punit.trd_aux
  and trd_punit = punit'.punit.trd
  and comp_min_basis_punit = punit'.punit.comp_min_basis
  and comp_red_basis_aux_punit = punit'.punit.comp_red_basis_aux
  and comp_red_basis_punit = punit'.punit.comp_red_basis
  subgoal unfolding punit0.ord_pp_def punit0.ord_pp_strict_def ..
  subgoal by (fact punit_adds_term)
  subgoal by (simp add: id_def)
  subgoal by (fact punit_component_of_term)
  subgoal by (simp only: monom_mult_punit_def)
  subgoal by (simp only: mult_scalar_punit_def)
  subgoal using min_term_punit_def by fastforce
  subgoal by (simp only: lt_punit_def ord_pp_punit_alt)
  subgoal by (simp only: lc_punit_def ord_pp_punit_alt)
  subgoal by (simp only: tail_punit_def ord_pp_punit_alt)
  subgoal by (simp only: ord_p_punit_def ord_pp_strict_punit_alt)
  subgoal by (simp only: keys_to_list_punit_def ord_pp_punit_alt)
  done

subsection \<open>Computations\<close>

experiment begin interpretation trivariate\<^sub>0_rat .

lemma
  "comp_red_basis_punit DRLEX (GB_Macaulay_Dube_punit DRLEX [X * Y\<^sup>2 + 3 * X\<^sup>2 * Y, Y ^ 3 - X ^ 3]) =
    [X ^ 5, X ^ 3 * Y - C\<^sub>0 (1 / 9) * X ^ 4, Y ^ 3 - X ^ 3, X * Y\<^sup>2 + 3 * X\<^sup>2 * Y]"
  by eval

end

end (* theory *)