(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
subsection \<open>Abstract Unification\<close>

text \<open>We formalize an inference system for unification.\<close>

theory Abstract_Unification
  imports
    Unifiers
    Term_Pair_Multiset
    "Abstract-Rewriting.Abstract_Rewriting"
begin

(*TODO: move*)
lemma foldr_assoc:
  assumes "\<And>f g h. b (b f g) h = b f (b g h)"
  shows "foldr b xs (b y z) = b (foldr b xs y) z"
  using assms by (induct xs) simp_all

(*TODO: move*)
lemma union_commutes:
  "M + {#x#} + N = M + N + {#x#}"
  "M + mset xs + N = M + N + mset xs"
  by (auto simp: ac_simps)

subsubsection \<open>Inference Rules\<close>

text \<open>Inference rules with explicit substitutions.\<close>
inductive
  UNIF1 :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equation multiset \<Rightarrow> ('f, 'v) equation multiset \<Rightarrow> bool"
where
  trivial [simp]: "UNIF1 Var (add_mset (t, t) E) E" |
  decomp: "\<lbrakk>length ss = length ts\<rbrakk> \<Longrightarrow>
    UNIF1 Var (add_mset (Fun f ss, Fun f ts) E) (E + mset (zip ss ts))" |
  Var_left: "\<lbrakk>x \<notin> vars_term t\<rbrakk> \<Longrightarrow>
    UNIF1 (subst x t) (add_mset (Var x, t) E) (subst_mset (subst x t) E)" |
  Var_right: "\<lbrakk>x \<notin> vars_term t\<rbrakk> \<Longrightarrow>
    UNIF1 (subst x t) (add_mset (t, Var x) E) (subst_mset (subst x t) E)"

text \<open>Relation version of @{const UNIF1} with implicit substitutions.\<close>
definition "unif = {(x, y). \<exists>\<sigma>. UNIF1 \<sigma> x y}"

lemma unif_UNIF1_conv:
  "(E, E') \<in> unif \<longleftrightarrow> (\<exists>\<sigma>. UNIF1 \<sigma> E E')"
  by (auto simp: unif_def)

lemma UNIF1_unifD:
  "UNIF1 \<sigma> E E' \<Longrightarrow> (E, E') \<in> unif"
  by (auto simp: unif_def)

text \<open>A termination order for @{const UNIF1}.\<close>
definition unifless :: "(('f, 'v) equation multiset \<times> ('f, 'v) equation multiset) set" where
  "unifless = inv_image (finite_psubset <*lex*> measure size_mset) (\<lambda>x. (vars_mset x, x))"

lemma wf_unifless:
  "wf unifless"
  by (auto simp: unifless_def)

lemma UNIF1_vars_mset_leq:
  assumes "UNIF1 \<sigma> E E'"
  shows "vars_mset E' \<subseteq> vars_mset E"
  using assms by (cases) (auto dest: mem_vars_mset_subst_mset)

lemma vars_mset_subset_size_mset_uniflessI [intro]:
  "vars_mset M \<subseteq> vars_mset N \<Longrightarrow> size_mset M < size_mset N \<Longrightarrow> (M, N) \<in> unifless"
  by (auto simp: unifless_def finite_vars_mset)

lemma vars_mset_psubset_uniflessI [intro]:
  "vars_mset M \<subset> vars_mset N \<Longrightarrow> (M, N) \<in> unifless"
  by (auto simp: unifless_def finite_vars_mset)

lemma UNIF1_unifless:
  assumes "UNIF1 \<sigma> E E'"
  shows "(E', E) \<in> unifless"
proof -
  have "vars_mset E' \<subseteq> vars_mset E"
    using UNIF1_vars_mset_leq [OF assms] .
  with assms
  show ?thesis
    apply cases
       apply (auto simp: pair_size_def intro!: Var_left_vars_mset_less Var_right_vars_mset_less)
    apply (rule vars_mset_subset_size_mset_uniflessI)
     apply auto
    using size_mset_Fun_less by fastforce
qed

lemma converse_unif_subset_unifless:
  "unif\<inverse> \<subseteq> unifless"
  using UNIF1_unifless by (auto simp: unif_def)

subsubsection \<open>Termination of the Inference Rules\<close>

lemma wf_converse_unif:
  "wf (unif\<inverse>)"
  by (rule wf_subset [OF wf_unifless converse_unif_subset_unifless])

text \<open>Reflexive and transitive closure of @{const UNIF1} collecting substitutions
produced by single steps.\<close>
inductive
  UNIF :: "('f, 'v) subst list \<Rightarrow> ('f, 'v) equation multiset \<Rightarrow> ('f, 'v) equation multiset \<Rightarrow> bool"
where
  empty [simp, intro!]: "UNIF [] E E" |
  step [intro]: "UNIF1 \<sigma> E E' \<Longrightarrow> UNIF ss E' E'' \<Longrightarrow> UNIF (\<sigma> # ss) E E''"

lemma unif_rtrancl_UNIF_conv:
  "(E, E') \<in> unif\<^sup>* \<longleftrightarrow> (\<exists>ss. UNIF ss E E')"
proof
  assume "(E, E') \<in> unif\<^sup>*"
  then show "\<exists>ss. UNIF ss E E'"
    by (induct rule: converse_rtrancl_induct) (auto simp: unif_UNIF1_conv)
next
  assume "\<exists>ss. UNIF ss E E'"
  then obtain ss where "UNIF ss E E'" ..
  then show "(E, E') \<in> unif\<^sup>*" by (induct) (auto dest: UNIF1_unifD)
qed

text \<open>Compose a list of substitutions.\<close>
definition compose :: "('f, 'v) subst list \<Rightarrow> ('f, 'v) subst"
  where
    "compose ss = List.foldr (\<circ>\<^sub>s) ss Var"

lemma compose_simps [simp]:
  "compose [] = Var"
  "compose (Var # ss) = compose ss"
  "compose (\<sigma> # ss) = \<sigma> \<circ>\<^sub>s compose ss"
  by (simp_all add: compose_def)

lemma compose_append [simp]:
  "compose (ss @ ts) = compose ss \<circ>\<^sub>s compose ts"
    using foldr_assoc [of "(\<circ>\<^sub>s)" ss Var "foldr (\<circ>\<^sub>s) ts Var"]
    by (simp add: compose_def ac_simps)

lemma set_mset_subst_mset [simp]:
  "set_mset (subst_mset \<sigma> E) = subst_set \<sigma> (set_mset E)"
  by (auto simp: subst_set_def subst_mset_def)

lemma UNIF1_subst_domain_Int:
  assumes "UNIF1 \<sigma> E E'"
  shows "subst_domain \<sigma> \<inter> vars_mset E' = {}"
  using assms by (cases) simp+

lemma UNIF1_subst_domain_subset:
  assumes "UNIF1 \<sigma> E E'"
  shows "subst_domain \<sigma> \<subseteq> vars_mset E"
  using assms by (cases) simp+

lemma UNIF_subst_domain_subset:
  assumes "UNIF ss E E'"
  shows "subst_domain (compose ss) \<subseteq> vars_mset E"
  using assms
  by (induct)
     (auto dest: UNIF1_subst_domain_subset UNIF1_vars_mset_leq simp: subst_domain_subst_compose)

lemma UNIF1_range_vars_subset:
  assumes "UNIF1 \<sigma> E E'"
  shows "range_vars \<sigma> \<subseteq> vars_mset E"
  using assms by (cases) (auto simp: range_vars_def)

lemma UNIF1_subst_domain_range_vars_Int:
  assumes "UNIF1 \<sigma> E E'"
  shows "subst_domain \<sigma> \<inter> range_vars \<sigma> = {}"
  using assms by (cases) auto

lemma UNIF_range_vars_subset:
  assumes "UNIF ss E E'"
  shows "range_vars (compose ss) \<subseteq> vars_mset E"
  using assms
  by (induct)
     (auto dest: UNIF1_range_vars_subset UNIF1_vars_mset_leq
           dest!: range_vars_subst_compose_subset [THEN subsetD])

lemma UNIF_subst_domain_range_vars_Int:
  assumes "UNIF ss E E'"
  shows "subst_domain (compose ss) \<inter> range_vars (compose ss) = {}"
using assms
proof (induct)
  case (step \<sigma> E E' ss E'')
  from UNIF1_subst_domain_Int [OF step(1)]
    and UNIF_subst_domain_subset [OF step(2)]
    and UNIF1_subst_domain_range_vars_Int [OF step(1)]
    and UNIF_range_vars_subset [OF step(2)]
    have "subst_domain \<sigma> \<inter> range_vars \<sigma> = {}"
      and "subst_domain (compose ss) \<inter> subst_domain \<sigma> = {}"
      and "subst_domain \<sigma> \<inter> range_vars (compose ss) = {}" by blast+
  then have "(subst_domain \<sigma> \<union> subst_domain (compose ss)) \<inter>
    ((range_vars \<sigma> - subst_domain (compose ss)) \<union> range_vars (compose ss)) = {}"
    using step(3) by auto
  then show ?case
    using subst_domain_subst_compose [of \<sigma> "compose ss"]
    and range_vars_subst_compose_subset [of \<sigma> "compose ss"]
    by (auto)
qed simp

text \<open>The inference rules generate idempotent substitutions.\<close>
lemma UNIF_idemp:
  assumes "UNIF ss E E'"
  shows "compose ss \<circ>\<^sub>s compose ss = compose ss"
  using UNIF_subst_domain_range_vars_Int [OF assms]
    by (simp only: subst_idemp_iff)

lemma UNIF1_mono:
  assumes "UNIF1 \<sigma> E E'"
  shows "UNIF1 \<sigma> (E + M) (E' + subst_mset \<sigma> M)"
  using assms
  by (cases) (auto intro: UNIF1.intros simp: union_commutes subst_mset_union [symmetric])

lemma unif_mono:
  assumes "(E, E') \<in> unif"
  shows "\<exists>\<sigma>. (E + M, E' + subst_mset \<sigma> M) \<in> unif"
  using assms by (auto simp: unif_UNIF1_conv intro: UNIF1_mono)

lemma unif_rtrancl_mono:
  assumes "(E, E') \<in> unif\<^sup>*"
  shows "\<exists>\<sigma>. (E + M, E' + subst_mset \<sigma> M) \<in> unif\<^sup>*"
using assms
proof (induction arbitrary: M rule: converse_rtrancl_induct)
  case base
  have "(E' + M, E' + subst_mset Var M) \<in> unif\<^sup>*" by auto
  then show ?case by blast
next
  case (step E F)
  obtain \<sigma> where "(E + M, F + subst_mset \<sigma> M) \<in> unif"
    using unif_mono [OF \<open>(E, F) \<in> unif\<close>] ..
  moreover obtain \<tau>
    where "(F + subst_mset \<sigma> M, E' + subst_mset \<tau> (subst_mset \<sigma> M)) \<in> unif\<^sup>*"
    using step.IH by blast
  ultimately have "(E + M, E' + subst_mset (\<sigma> \<circ>\<^sub>s \<tau>) M) \<in> unif\<^sup>*" by simp
  then show ?case by blast
qed

subsubsection \<open>Soundness of the Inference Rules\<close>

text \<open>The inference rules of unification are sound in the sense that
  when the empty set of equations is reached, a most general unifier
  is obtained.\<close>
lemma UNIF_empty_imp_is_mgu_compose:
  fixes E :: "('f, 'v) equation multiset"
  assumes "UNIF ss E {#}"
  shows "is_mgu (compose ss) (set_mset E)"
using assms
proof (induct ss E "{#}::('f, 'v) equation multiset")
  case (step \<sigma> E E' ss)
  then show ?case
    by (cases) (auto simp: is_mgu_subst_set_subst)
qed simp

subsubsection \<open>Completeness of the Inference Rules\<close>

lemma UNIF1_singleton_decomp [intro]:
  assumes "length ss = length ts"
  shows "UNIF1 Var {#(Fun f ss, Fun f ts)#} (mset (zip ss ts))"
  using UNIF1.decomp [OF assms, of f "{#}"] by simp

lemma UNIF1_singleton_Var_left [intro]:
  "x \<notin> vars_term t \<Longrightarrow> UNIF1 (subst x t) {#(Var x, t)#} {#}"
  using UNIF1.Var_left [of x t "{#}"] by simp

lemma UNIF1_singleton_Var_right [intro]:
  "x \<notin> vars_term t \<Longrightarrow> UNIF1 (subst x t) {#(t, Var x)#} {#}"
  using UNIF1.Var_right [of x t "{#}"] by simp

lemma not_UNIF1_singleton_Var_right [dest]:
  "\<not> UNIF1 Var {#(Var x, Var y)#} {#} \<Longrightarrow> x \<noteq> y"
  "\<not> UNIF1 (subst x (Var y)) {#(Var x, Var y)#} {#} \<Longrightarrow> x = y"
  by auto

lemma not_unifD:
  assumes "\<not> (\<exists>E'. ({#e#}, E') \<in> unif)"
  shows "(\<exists>x t. (e = (Var x, t) \<or> e = (t, Var x)) \<and> x \<in> vars_term t \<and> is_Fun t) \<or>
    (\<exists>f g ss ts. e = (Fun f ss, Fun g ts) \<and> (f \<noteq> g \<or> length ss \<noteq> length ts))"
proof (rule ccontr)
  assume *: "\<not> ?thesis"
  show False
  proof (cases e)
    case (Pair s t)
    with assms and * show ?thesis
      by (cases s) (cases t, auto simp: unif_def simp del: term.simps, (blast | succeed))+
  qed
qed

lemma unifiable_imp_unif:
  assumes "unifiable {e}"
  shows "\<exists>E'. ({#e#}, E') \<in> unif"
proof (rule ccontr)
  assume "\<not> ?thesis"
  from not_unifD [OF this] and assms
  show False by (auto simp: unifiable_def)
qed

lemma unifiable_imp_empty_or_unif:
  assumes "unifiable (set_mset E)"
  shows "E = {#} \<or> (\<exists>E'. (E, E') \<in> unif)"
proof (cases E)
  case [simp]: (add e E')
  from assms have "unifiable {e}" by (auto simp: unifiable_def unifiers_insert)
  from unifiable_imp_unif [OF this]
    obtain E'' where "({#e#}, E'') \<in> unif" ..
  then obtain \<sigma> where "UNIF1 \<sigma> {#e#} E''" by (auto simp: unif_UNIF1_conv)
  from UNIF1_mono [OF this] have "UNIF1 \<sigma> E (E'' + subst_mset \<sigma> E')" by (auto simp: ac_simps)
  then show ?thesis by (auto simp: unif_UNIF1_conv)
qed simp

lemma UNIF1_preserves_unifiers:
  assumes "UNIF1 \<sigma> E E'" and "\<tau> \<in> unifiers (set_mset E)"
  shows "(\<sigma> \<circ>\<^sub>s \<tau>) \<in> unifiers (set_mset E')"
  using assms by (cases) (auto simp: unifiers_def subst_mset_def)

lemma unif_preserves_unifiable:
  assumes "(E, E') \<in> unif" and "unifiable (set_mset E)"
  shows "unifiable (set_mset E')"
  using UNIF1_preserves_unifiers [of _ E E'] and assms
  by (auto simp: unif_UNIF1_conv unifiable_def)

lemma unif_imp_converse_unifless [dest]:
  "(x, y) \<in> unif \<Longrightarrow> (y, x) \<in> unifless"
  by (metis UNIF1_unifless unif_UNIF1_conv)

text \<open>Every unifiable set of equations can be reduced to the empty
  set by applying the inference rules of unification.\<close>

lemma unifiable_imp_empty:
  assumes "unifiable (set_mset E)"
  shows "(E, {#}) \<in> unif\<^sup>*"
  using assms
proof (induct E rule: wf_induct [OF wf_unifless])
  fix E :: "('f, 'v) equation multiset"
  presume IH: "\<And>E'. \<lbrakk>(E', E) \<in> unifless; unifiable (set_mset E')\<rbrakk> \<Longrightarrow>
    (E', {#}) \<in> unif\<^sup>*"
    and *: "unifiable (set_mset E)"
  show "(E, {#}) \<in> unif\<^sup>*"
  proof (cases "E = {#}")
    assume "E \<noteq> {#}"
    with unifiable_imp_empty_or_unif [OF *]
    obtain E' where "(E, E') \<in> unif" by auto
    with * have "(E', E) \<in> unifless" and "unifiable (set_mset E')"
      by (auto dest: unif_preserves_unifiable)
    from IH [OF this] and \<open>(E, E') \<in> unif\<close>
    show ?thesis by simp
  qed simp
qed simp

lemma unif_rtrancl_empty_imp_unifiable:
  assumes "(E, {#}) \<in> unif\<^sup>*"
  shows "unifiable (set_mset E)"
  using assms
  by (auto simp: unif_rtrancl_UNIF_conv unifiable_def is_mgu_def
           dest!: UNIF_empty_imp_is_mgu_compose)

lemma not_unifiable_imp_not_empty_NF:
  assumes "\<not> unifiable (set_mset E)"
  shows "\<exists>E'. E' \<noteq> {#} \<and> (E, E') \<in> unif\<^sup>!"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then have *: "\<And>E'. (E, E') \<in> unif\<^sup>! \<Longrightarrow> E' = {#}" by auto
  have "SN unif" using wf_converse_unif by (auto simp: SN_iff_wf)
  then obtain E' where "(E, E') \<in> unif\<^sup>!"
    by (metis SN_imp_WN UNIV_I WN_onE)
  with * have "(E, {#}) \<in> unif\<^sup>*" by auto
  from unif_rtrancl_empty_imp_unifiable [OF this] and assms
  show False by contradiction
qed

lemma unif_rtrancl_preserves_unifiable:
  assumes "(E, E') \<in> unif\<^sup>*" and "unifiable (set_mset E)"
  shows "unifiable (set_mset E')"
  using assms by (induct) (auto simp: unif_preserves_unifiable)

text \<open>The inference rules for unification are complete in the
  sense that whenever it is not possible to reduce a set of equations
  @{term E} to the empty set, then @{term E} is not unifiable.\<close>

lemma empty_not_reachable_imp_not_unifiable:
  assumes "(E, {#}) \<notin> unif\<^sup>*"
  shows "\<not> unifiable (set_mset E)"
  using unifiable_imp_empty [of E] and assms by blast

text \<open>It is enough to reach an irreducible set of equations
  to conclude non-unifiability.\<close>
lemma irreducible_reachable_imp_not_unifiable:
  assumes "(E, E') \<in> unif\<^sup>!" and "E' \<noteq> {#}"
  shows "\<not> unifiable (set_mset E)"
proof -
  have "(E, E') \<in> unif\<^sup>*" and "(E', {#}) \<notin> unif\<^sup>*"
    using assms by (auto simp: NF_not_suc)
  moreover with empty_not_reachable_imp_not_unifiable
    have "\<not> unifiable (set_mset E')" by fast
  ultimately show ?thesis
    using unif_rtrancl_preserves_unifiable by fast
qed

end


section \<open>Additions to Separation Algebra Library\<close>
theory Sep_Algebra_Add
imports "Separation_Algebra.Sep_Tactics"
begin

no_notation pred_K ("\<langle>_\<rangle>")
hide_const (open) Separation_Algebra.pure

subsection \<open>Simp-Lemmas for Separation Algebra\<close>

named_theorems sep_algebra_simps \<open>Advanced simplification lemmas for separation algebra\<close>

lemmas [sep_algebra_simps] = sep_conj_exists sep_add_ac
lemmas [simp] = sep_conj_assoc

lemmas sep_conj_c = sep_conj_commute sep_conj_left_commute

lemmas sep_conj_aci = sep_conj_ac sep_conj_empty sep_conj_empty'

subsection \<open>Separation Algebra with a Unique Zero\<close>

class unique_zero_sep_algebra = stronger_sep_algebra +
  assumes unique_zero: "x##x \<Longrightarrow> x=0"
begin
  lemma unique_zero_simps[simp]:
    "a##a \<longleftrightarrow> a=0"
    "a##b \<Longrightarrow> a+b = a \<longleftrightarrow> b=0"
    "a##b \<Longrightarrow> a+b = b \<longleftrightarrow> a=0"
    "a##b \<Longrightarrow> a + b = 0 \<longleftrightarrow> a=0 \<and> b=0"
    apply -
    using local.sep_disj_zero local.unique_zero apply blast
    apply (metis local.sep_add_disjD local.sep_add_zero local.unique_zero)
    apply (metis local.sep_add_disjD local.sep_add_zero_sym local.sep_disj_commute local.unique_zero)
    by (metis local.sep_add_disjD local.sep_add_zero local.sep_disj_zero local.unique_zero)

end

subsection \<open>Standard Instantiations\<close>

instantiation "fun" :: (type,stronger_sep_algebra) stronger_sep_algebra
begin
  definition "f1 ## f2 \<longleftrightarrow> (\<forall>x. f1 x ## f2 x)"
  definition [simp]: "(f1 + f2) x = (f1 x + f2 x)"
  definition [simp]: "0 x \<equiv> 0"

  instance
    apply standard
    unfolding sep_disj_fun_def plus_fun_def zero_fun_def
    apply (auto)
    subgoal
      by (simp add: sep_disj_commute)
    subgoal
      using sep_add_commute by auto
    subgoal
      by (simp add: sep_add_assoc)
    done
end

instance "fun" :: (type,unique_zero_sep_algebra) unique_zero_sep_algebra
  apply standard
  unfolding sep_disj_fun_def plus_fun_def zero_fun_def
  by (metis unique_zero)

lemma disj_fun_upd_iff[simp]:
  "\<lbrakk>f a = 0; g a = 0\<rbrakk> \<Longrightarrow> (f(a:=x) ## g(a:=y)) \<longleftrightarrow> (f ## g \<and> x ## y)"
  unfolding sep_disj_fun_def by force

lemma fun_upd_Z_Z[simp]: "fun_upd 0 i 0 = 0" by auto

lemma sep_disj_fun_updI[sep_algebra_simps, intro]: "\<lbrakk>f##g; a##b\<rbrakk> \<Longrightarrow> f(x:=a) ## g(x:=b)"
  by (simp add: sep_disj_fun_def)

lemma sep_disj_fun_Zupd_eq[sep_algebra_simps]:
  "f##0(x:=y) \<longleftrightarrow> f x ## y"
  "0(x:=y) ## f \<longleftrightarrow> y ## f x"
  by (auto simp add: sep_disj_fun_def)

lemma sep_disj_funD: "f##g \<Longrightarrow> f x ## g x" by (auto simp: sep_disj_fun_def)

lemma merge_fun_singleton: "fun_upd 0 i a + fun_upd 0 i b = fun_upd 0 i (a+b)" by auto

lemma split_fun_upd_0: "fun_upd (a+b) i 0 = fun_upd a i 0 + fun_upd b i 0" by auto

instantiation option :: (stronger_sep_algebra) stronger_sep_algebra begin
  fun sep_disj_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
    "sep_disj None None \<longleftrightarrow> True"
  | "sep_disj None (Some _) \<longleftrightarrow> True"
  | "sep_disj (Some _) None \<longleftrightarrow> True"
  | "sep_disj (Some x) (Some y) \<longleftrightarrow> x##y"

  lemma sep_disj_option_add_simps[simp]:
    "sep_disj None x"
    "sep_disj x None"
    by (cases x; simp)+

  fun plus_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
    "plus None None = None"
  | "plus None (Some x) = Some x"
  | "plus (Some x) None = Some x"
  | "plus (Some x) (Some y) = Some (x+y)"

  lemma plus_option_add_simps[simp]: "plus None x = x" "plus x None = x"
    by (cases x; simp)+

  definition "0 = None"

  instance
    apply standard
    apply (simp_all add: zero_option_def)
    apply (case_tac x; case_tac y; simp add: sep_disj_commute)
    apply (case_tac x; case_tac y; auto simp add: sep_disj_commute sep_add_commute)
    apply (case_tac x; case_tac y; case_tac z; simp add: sep_add_assoc)
    apply (case_tac x; case_tac y; case_tac z; auto dest: sep_disj_addD1)
    (*apply (case_tac x; case_tac y; case_tac z; auto dest: sep_disj_addI1)*)
    done
end

instantiation prod :: (stronger_sep_algebra, stronger_sep_algebra) stronger_sep_algebra
begin
  definition "a##b \<longleftrightarrow> fst a ## fst b \<and> snd a ## snd b"
  definition "a+b = (fst a + fst b, snd a + snd b)"
  definition "0 = (0,0)"

  instance
    apply standard
    unfolding sep_disj_prod_def plus_prod_def zero_prod_def
    by (auto
      simp: sep_add_ac
      intro: sep_disj_commuteI sep_disj_addD1 sep_disj_addI1)
end

lemma sep_disj_prod_lower[sep_algebra_simps]: "(a,b) ## (c,d) \<longleftrightarrow> a##c \<and> b##d"
  by (simp add: sep_disj_prod_def)

lemma plus_prod_lower[sep_algebra_simps]: "(a,b) + (c,d) = (a+c,b+d)"
  by (simp add: plus_prod_def)

instance prod :: (unique_zero_sep_algebra,unique_zero_sep_algebra) unique_zero_sep_algebra
  by standard (auto simp: zero_prod_def sep_algebra_simps)

lemma prod_Z_lower[sep_algebra_simps]:
  "(a,b) = 0 \<longleftrightarrow> a=0 \<and> b=0"
  "0 = (a,b) \<longleftrightarrow> a=0 \<and> b=0"
  by (auto simp: zero_prod_def)

lemma plus_prod_eqI: "(a+b,c+d) = (a,c) + (b,d)" by (simp add: sep_algebra_simps)

lemma fst_Z[simp]: "fst 0 = 0" by (simp add: zero_prod_def)
lemma snd_Z[simp]: "snd 0 = 0" by (simp add: zero_prod_def)

lemma fst_plus[sep_algebra_simps]: "fst (a+b) = fst a + fst b" by (auto simp: plus_prod_def)
lemma snd_plus[sep_algebra_simps]: "snd (a+b) = snd a + snd b" by (auto simp: plus_prod_def)
lemma disj_fstI[sep_algebra_simps]: "a##b \<Longrightarrow> fst a ## fst b" by (auto simp: sep_disj_prod_def)
lemma disj_sndI[sep_algebra_simps]: "a##b \<Longrightarrow> snd a ## snd b" by (auto simp: sep_disj_prod_def)

datatype 'a tsa_opt = ZERO | TRIV (the_tsa: 'a)

instantiation tsa_opt :: (type) unique_zero_sep_algebra begin
  definition sep_disj_tsa_opt :: "'a tsa_opt \<Rightarrow> 'a tsa_opt \<Rightarrow> bool"
    where "a##b \<longleftrightarrow> a=ZERO \<or> b=ZERO"

  definition "a+b \<equiv> (case (a,b) of (ZERO,x) \<Rightarrow> x | (x,ZERO) \<Rightarrow> x)"
  definition "0 = ZERO"

  instance
    apply standard
    by (auto simp: zero_tsa_opt_def sep_disj_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

end

instance tsa_opt :: (type) cancellative_sep_algebra
  apply standard
  by (auto simp: zero_tsa_opt_def sep_disj_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

(* Lowering lemmas. If one side of operation breaks abstraction level,
  the other side is also lowered
*)
lemma TRIV_not_zero[simp]: "TRIV x \<noteq> 0" "0\<noteq>TRIV x" by (auto simp: zero_tsa_opt_def)
lemma TRIV_Z_lower[intro!]:
  "ZERO = 0"
  "0 = ZERO"
  by (auto simp: zero_tsa_opt_def)

lemma triv_Z_lower2[sep_algebra_simps]:
  "x + ZERO = x"
  "ZERO + x = x"
  by (auto simp: zero_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

lemma TRIV_disj_simps[sep_algebra_simps]:
  "TRIV a ## b \<longleftrightarrow> b=ZERO"
  "b ## TRIV a \<longleftrightarrow> b=ZERO"
  by (auto simp: sep_disj_tsa_opt_def)

subsection \<open>Additional Simplifier Setup\<close>

(*
  This may cause trouble on non-eta-normalized terms.
    (\<lambda>s. \<box> s) \<rightarrow> \<lambda>s. s=0
  The next lemma hopefully fixes that.
*)

lemma sep_empty_app[sep_algebra_simps]: "\<box> h \<longleftrightarrow> h=0"
  by (simp add: sep_empty_def)

lemma sep_empty_I[sep_algebra_simps]: "(\<lambda>h. h=0) = \<box>"
  by (simp add: sep_empty_def)

lemma sep_triv_ineqs[simp]:
  "\<box> \<noteq> sep_false"
  "sep_true \<noteq> sep_false"
  "sep_false \<noteq> \<box>"
  "sep_false \<noteq> sep_true"
  by (auto dest: fun_cong)

lemma sep_true_not_empty:
  assumes "(a::'a::sep_algebra) \<noteq> (b::'a)"
  shows "(\<box>::'a\<Rightarrow>bool) \<noteq> sep_true"
  by (metis (mono_tags, lifting) assms sep_empty_I)

subsection \<open>Pure Assertions\<close>

text \<open>The Separation Algebra entry only defines @{term "pred_K \<Phi>"}, which
  makes no constraint on the heap. We define \<open>\<up>\<Phi>\<close>, which requires an empty heap,
  and is more natural when using separation logic with deallocation.
\<close>

definition pred_lift :: "bool \<Rightarrow> 'a::sep_algebra \<Rightarrow> bool" ("\<up>_" [100] 100)
  where "(\<up>\<Phi>) s \<equiv> \<Phi> \<and> \<box> s"

text \<open>Relation between \<open>pred_lift\<close> and \<open>pred_K\<close>. Warning, do not use
  as simp-lemma, as \<open>sep_true\<close> is an abbreviation for \<open>\<langle>True\<rangle>\<close>\<close>
lemma "pred_K \<Phi> = (\<up>\<Phi> ** sep_true)" by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pred_lift_merge_simps[sep_algebra_simps]:
  "(\<up>\<Phi> ** \<up>\<Psi>) = (\<up>(\<Phi>\<and>\<Psi>))"
  "(\<up>\<Phi> ** \<up>\<Psi> ** B) = (\<up>(\<Phi>\<and>\<Psi>) ** B)"
  by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pred_lift_move_front_simps[sep_algebra_simps]:
  "NO_MATCH (\<up>X) A \<Longrightarrow> (A ** \<up>\<Phi> ** B) = (\<up>\<Phi> ** A ** B)"
  "NO_MATCH (\<up>X) A \<Longrightarrow> (A ** \<up>\<Phi>) = (\<up>\<Phi> ** A)"
  by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemmas pred_lift_move_merge_simps = pred_lift_merge_simps pred_lift_move_front_simps

lemma pred_lift_extract_simps:
  "(\<up>\<Phi>) h \<longleftrightarrow> \<Phi> \<and> h=0"
  "(\<up>\<Phi> ** A) h \<longleftrightarrow> \<Phi> \<and> A h"
  by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pure_true_conv[sep_algebra_simps]: "\<up>True = \<box>" by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma pred_lift_false_conv[simp]: "\<up>False = sep_false" by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma pure_assn_eq_conv[simp]: "(\<up>\<Phi>) = (\<up>\<Psi>) \<longleftrightarrow> \<Phi>=\<Psi>"
  by (smt pred_lift_extract_simps(1))

lemmas sep_conj_false_simps =
  pred_lift_false_conv
  sep_conj_false_left sep_conj_false_right

definition sep_is_pure_assn :: "('a::sep_algebra \<Rightarrow> bool) \<Rightarrow> bool" where
  "sep_is_pure_assn A \<equiv> \<forall>s. A s \<longrightarrow> s=0"

definition pure_part :: "('a::sep_algebra \<Rightarrow> bool) \<Rightarrow> bool" where
  "pure_part A \<equiv> Ex A"

lemma pure_partI: "A s \<Longrightarrow> pure_part A" by (auto simp: pure_part_def)

lemma pure_part_pure_eq[simp]: "sep_is_pure_assn A \<Longrightarrow> \<up>pure_part A = A"
  apply (rule ext)
  by (auto simp: sep_is_pure_assn_def pure_part_def pred_lift_def sep_algebra_simps)

lemma pure_part_triv_simps[simp]:
  "\<not>pure_part sep_false"
  "pure_part \<box>"
  by (auto simp: pure_part_def)

lemma pure_part_pure[simp]: "pure_part (\<up>\<Phi>) = \<Phi>"
  by (auto simp: pure_part_def sep_algebra_simps pred_lift_def)

lemma pure_part_split_conj: "pure_part (A**B) \<Longrightarrow> pure_part A \<and> pure_part B"
  by (auto simp: pure_part_def sep_conj_def)

lemma sep_is_pure_lift_pred[simp]: "sep_is_pure_assn (\<up>\<Phi>)"
  by (auto simp: sep_is_pure_assn_def pred_lift_def sep_algebra_simps)

lemma sep_is_pure_assn_false[simp]: "sep_is_pure_assn sep_false" by (auto simp: sep_is_pure_assn_def)
lemma sep_is_pure_assn_empty[simp]: "sep_is_pure_assn \<box>" by (auto simp: sep_is_pure_assn_def sep_algebra_simps)

lemma sep_is_pure_assn_conjI: "sep_is_pure_assn A \<Longrightarrow> sep_is_pure_assn B \<Longrightarrow> sep_is_pure_assn (A**B)"
  by (auto simp: sep_is_pure_assn_def sep_conj_def)

lemma pure_part_pure_conj_eq: "pure_part (\<up>P ** Q) \<longleftrightarrow> P \<and> pure_part Q"
  unfolding pure_part_def by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma and_pure_true: "((A ** F) and ((\<up>\<Phi> ** sep_true) ** F)) s \<longrightarrow> ((\<up>\<Phi> ** A) ** F) s"
  unfolding sep_conj_def pred_lift_def
  by (auto simp: sep_algebra_simps)

subsection \<open>Exact Assertion\<close>

definition EXACT :: "'a::sep_algebra \<Rightarrow> 'a \<Rightarrow> bool" where [simp]: "EXACT h h' \<equiv> h'=h"
lemma strictly_exact_EXACT[simp]: "strictly_exact (EXACT h)"
  unfolding EXACT_def by (auto intro: strictly_exactI)

lemma EXACT_split: "a##b \<Longrightarrow> EXACT (a+b) = (EXACT a ** EXACT b)"
  unfolding EXACT_def sep_conj_def by auto

lemma EXACT_zero[simp]: "EXACT 0 = \<box>" by (auto simp: sep_algebra_simps)

lemma EXACT_eq_iff[simp]: "EXACT a = EXACT b \<longleftrightarrow> a=b"
  unfolding EXACT_def by metis

subsection \<open>List-Sum over Separation Algebra\<close>

(* TODO: Move. Clean up *)

definition "sepsum_list l \<equiv> foldr (+) l (0::_::stronger_sep_algebra)"

lemma sepsum_list_simps[simp]:
  "sepsum_list [] = 0"
  "sepsum_list (x#xs) = x + sepsum_list xs"
  by (auto simp: sepsum_list_def)

context begin

private named_theorems ss

private definition "sep_ldisj1 x ys \<equiv> \<forall>y\<in>List.set ys. x##y"

private lemma sep_ldisj1_simps[ss]:
  "sep_ldisj1 x []"
  "sep_ldisj1 x (y#ys) \<longleftrightarrow> x##y \<and> sep_ldisj1 x ys"
  by (auto simp: sep_ldisj1_def)

private lemma sep_ldisj1_append[ss]: "sep_ldisj1 x (ys\<^sub>1@ys\<^sub>2) \<longleftrightarrow> sep_ldisj1 x ys\<^sub>1 \<and> sep_ldisj1 x ys\<^sub>2"
  by (induction ys\<^sub>1) (auto simp: ss)

private definition "sep_ldisj xs ys \<equiv> \<forall>x\<in>List.set xs. sep_ldisj1 x ys"

private lemma sep_ldisj_simps[ss]:
  "sep_ldisj [] ys"
  "sep_ldisj xs []"
  "sep_ldisj (x#xs) ys \<longleftrightarrow> sep_ldisj1 x ys \<and> sep_ldisj xs ys"
  "sep_ldisj xs (y#ys) \<longleftrightarrow> sep_ldisj1 y xs \<and> sep_ldisj xs ys"
  by (auto simp: sep_ldisj_def sep_ldisj1_def sep_algebra_simps)

private lemma sep_ldisj_append1[ss]: "sep_ldisj (xs\<^sub>1@xs\<^sub>2) ys \<longleftrightarrow> sep_ldisj xs\<^sub>1 ys \<and> sep_ldisj xs\<^sub>2 ys"
  by (induction xs\<^sub>1) (auto simp: ss)

private lemma sep_ldisj_append2[ss]: "sep_ldisj xs (ys\<^sub>1@ys\<^sub>2) \<longleftrightarrow> sep_ldisj xs ys\<^sub>1 \<and> sep_ldisj xs ys\<^sub>2"
  by (induction ys\<^sub>1) (auto simp: ss)

private lemma sep_ldisj_commute[sep_algebra_simps]: "sep_ldisj xs ys \<longleftrightarrow> sep_ldisj ys xs"
  by (force simp: sep_ldisj_def sep_ldisj1_def sep_algebra_simps)

fun sep_distinct :: "_::stronger_sep_algebra list \<Rightarrow> bool" where
  "sep_distinct [] \<longleftrightarrow> True"
| "sep_distinct (x#xs) \<longleftrightarrow> sep_ldisj1 x xs \<and> sep_distinct xs"

declare sep_distinct.simps[simp del, ss add]

private lemma sep_distinct_append_aux[ss]:
  "sep_distinct (xs@ys) \<longleftrightarrow> sep_distinct xs \<and> sep_distinct ys \<and> sep_ldisj xs ys"
  by (induction xs) (auto simp: ss)

private lemma norm_ldisj1[ss]: "sep_distinct ys \<Longrightarrow> sep_ldisj1 x ys \<longleftrightarrow> x ## sepsum_list ys"
  by (induction ys arbitrary: x) (auto simp: ss)

private lemma norm_ldisj[ss]: "sep_distinct xs \<Longrightarrow> sep_distinct ys \<Longrightarrow> sep_ldisj xs ys \<longleftrightarrow> sepsum_list xs ## sepsum_list ys"
  by (induction xs) (auto simp: ss)

lemma sep_distinct_append[simp]:
  "sep_distinct (xs@ys) \<longleftrightarrow> sep_distinct xs \<and> sep_distinct ys \<and> sepsum_list xs ## sepsum_list ys"
  by (auto simp: ss)

lemma sepsum_append[simp]: "sep_distinct (xs@ys) \<Longrightarrow> sepsum_list (xs@ys) = sepsum_list xs + sepsum_list ys"
  by (induction xs) (auto simp: sep_algebra_simps ss)

lemma sep_distinct_simps[simp]:
  "sep_distinct []"
  "sep_distinct (x#xs) \<longleftrightarrow> x ## sepsum_list xs \<and> sep_distinct xs"
  by (auto simp: ss)

end

subsection \<open>Finite Assertion Families\<close>
interpretation sep_folding: folding "\<lambda>i Q. P i ** Q" \<box> for P
  apply unfold_locales
  apply (intro ext)
  apply (simp add: sep.add_ac)
  done

definition "sep_set_img S P \<equiv> \<up>(finite S) ** sep_folding.F P S"

syntax
  "_SEP_SET_IMG"      :: "pttrn => 'a set => ('b \<Rightarrow> bool) => ('b \<Rightarrow> bool)"  ("(3\<Union>*_\<in>_./ _)" [0, 0, 10] 10)

translations
  "\<Union>*x\<in>A. B"   \<rightleftharpoons> "CONST sep_set_img A (\<lambda>x. B)"

print_translation \<open>
  [Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax sep_set_img} @{syntax_const "_SEP_SET_IMG"}]
\<close> \<comment> \<open>to avoid eta-contraction of body\<close>

lemma sep_set_img_infinite[simp]: "infinite I \<Longrightarrow> sep_set_img I P = sep_false"
  unfolding sep_set_img_def by auto

lemma sep_set_img_empty[simp]: "sep_set_img {} P = \<box>"
  and sep_set_img_insert_remove: "sep_set_img (insert x S) P = (P x ** sep_set_img (S-{x}) P)"
  and sep_set_img_insert[simp]: "x\<notin>S \<Longrightarrow> sep_set_img (insert x S) P = (P x ** sep_set_img S P)"
  and sep_set_img_remove: "x\<in>S \<Longrightarrow> sep_set_img S P = (P x ** sep_set_img (S-{x}) P)"
  by (auto
    simp: sep_set_img_def sep_algebra_simps pred_lift_extract_simps sep_folding.insert_remove sep_folding.remove
    del: ext intro!: ext)

lemma sep_set_img_cong:
  assumes [simp]: "I=I'"
  assumes P: "\<And>x. finite I' \<Longrightarrow> x\<in>I' \<Longrightarrow> P x = P' x"
  shows "sep_set_img I P = sep_set_img I' P'"
proof -
  {
    assume "finite I'"
    then have "sep_set_img I' P = sep_set_img I' P'" using P
      by induction auto
  }
  then show ?thesis by (cases "finite I'") auto
qed

lemma sep_set_img_cong_strong[cong]:
  assumes [simp]: "I=I'"
  assumes P: "\<And>x. finite I' =simp=> x\<in>I' =simp=> P x = P' x"
  shows "sep_set_img I P = sep_set_img I' P'"
  using assms
  unfolding simp_implies_def
  by (rule sep_set_img_cong)

lemma sep_set_img_union[simp]:
  assumes "S\<^sub>1\<inter>S\<^sub>2={}"
  shows "sep_set_img (S\<^sub>1\<union>S\<^sub>2) P = (sep_set_img S\<^sub>1 P ** sep_set_img S\<^sub>2 P)"
proof -
  {
    assume "finite S\<^sub>1"
    then have ?thesis using assms
      by (induction S\<^sub>1) auto
  }
  then show ?thesis by (cases "finite S\<^sub>1") auto

qed

lemmas sep_set_img_ins[simp] = sep_set_img_union[where S\<^sub>1="{i}", simplified] for i

lemma sep_set_img_map:
  assumes "inj_on f I"
  shows "(\<Union>*i\<in>f`I. A i) = (\<Union>*i\<in>I. A (f i))"
proof (cases "finite I")
  case True
  thus ?thesis using assms apply (induction I)
    by (auto simp: sep_algebra_simps)
next
  case False thus ?thesis
    using assms
    apply simp
    using finite_image_iff sep_set_img_infinite by blast
qed

lemma sep_set_img_unionI':
  assumes NDUP: "\<And>x. \<lbrakk>x\<in>S\<^sub>2 \<rbrakk> \<Longrightarrow> (P x ** P x) = sep_false"
  assumes P: "(sep_set_img S\<^sub>1 P ** sep_set_img S\<^sub>2 P) s"
  shows "sep_set_img (S\<^sub>1\<union>S\<^sub>2) P s"
proof -

  have A: "(P x ** P x ** F) = sep_false" if "x\<in>S\<^sub>2" for x F
    using assms
    by (simp add: sep.mult_commute sep_conj_left_commute that)

  {
    assume "finite S\<^sub>1"
    then have "?thesis" using P
    proof (induction S\<^sub>1 arbitrary: s)
      case empty
      then show ?case by simp
    next
      case (insert x S\<^sub>1)
      then show ?case
        apply (cases "x\<notin>S\<^sub>2")
        apply (auto simp: sep_set_img_remove sep_set_img_insert_remove sep_algebra_simps sep_conj_impl)
        by (simp add: A sep_conj_left_commute)
    qed
  }
  then show ?thesis using P by (cases "finite S\<^sub>1") auto
qed

lemma sep_set_img_pull_EXS: "(\<Union>*x\<in>I. EXS y. f x y) = (EXS Y. \<Union>*x\<in>I. f x (Y x))"
proof -
  {
    assume "finite I"
    then have ?thesis
      apply (induction I)
      apply simp
      apply (rule ext)
      apply (clarsimp simp: sep_algebra_simps; safe)
      subgoal for x F s xa xb
        apply (rule exI[where x="xb(x:=xa)"])
        apply auto
        by (smt sep_set_img_cong)
      subgoal by auto
      done
  }
  then show ?thesis by (cases "finite I") auto
qed

lemma list_conj_eq_sep_set_img: "distinct xs \<Longrightarrow> (\<And>*map P xs) = sep_set_img (List.set xs) P"
  by (induction xs) auto

lemma sep_is_pure_assn_imgI:
  assumes "\<And>i. i\<in>I \<Longrightarrow> sep_is_pure_assn (f i)"
  shows "sep_is_pure_assn (\<Union>*i\<in>I. f i)"
proof (cases "finite I")
  assume "finite I"
  then show ?thesis using assms
    by (induction I) (auto simp: sep_is_pure_assn_conjI)
qed simp

end


(*
    Authors:    Jose Divasón
                Sebastiaan Joosten
                René Thiemann
                Akihisa Yamada
    License:    BSD
*)

section \<open>Missing lemmas\<close>

text \<open>This theory contains many results that are important but not specific for our development.
      They could be moved to the stardard library and some other AFP entries.\<close>

theory Missing_Lemmas
  imports
    Berlekamp_Zassenhaus.Sublist_Iteration (* for thm upt_append *)
    Berlekamp_Zassenhaus.Square_Free_Int_To_Square_Free_GFp (* for thm large_mod_0 *)
    Algebraic_Numbers.Resultant
    Jordan_Normal_Form.Conjugate
    Jordan_Normal_Form.Missing_VectorSpace
    Jordan_Normal_Form.VS_Connect
    Berlekamp_Zassenhaus.Finite_Field_Factorization_Record_Based (* for transfer rules for thm vec_of_list_Nil *)
    Berlekamp_Zassenhaus.Berlekamp_Hensel (* for unique_factorization_m_factor *)
begin

hide_const(open) module.smult up_ring.monom up_ring.coeff

(**** Could be merged to HOL/Rings.thy ****)

class ordered_semiring_1 = Rings.ordered_semiring_0 + monoid_mult + zero_less_one
begin

subclass semiring_1..

lemma of_nat_ge_zero[intro!]: "of_nat n \<ge> 0"
  using add_right_mono[of _ _ 1] by (induct n, auto)

(* Following lemmas are moved from @{class ordered_idom}. *)
lemma zero_le_power [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> a ^ n"
  by (induct n) simp_all

lemma power_mono: "a \<le> b \<Longrightarrow> 0 \<le> a \<Longrightarrow> a ^ n \<le> b ^ n"
  by (induct n) (auto intro: mult_mono order_trans [of 0 a b])

lemma one_le_power [simp]: "1 \<le> a \<Longrightarrow> 1 \<le> a ^ n"
  using power_mono [of 1 a n] by simp

lemma power_le_one: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ n \<le> 1"
  using power_mono [of a 1 n] by simp

lemma power_gt1_lemma:
  assumes gt1: "1 < a"
  shows "1 < a * a ^ n"
proof -
  from gt1 have "0 \<le> a"
    by (fact order_trans [OF zero_le_one less_imp_le])
  from gt1 have "1 * 1 < a * 1" by simp
  also from gt1 have "\<dots> \<le> a * a ^ n"
    by (simp only: mult_mono \<open>0 \<le> a\<close> one_le_power order_less_imp_le zero_le_one order_refl)
  finally show ?thesis by simp
qed

lemma power_gt1: "1 < a \<Longrightarrow> 1 < a ^ Suc n"
  by (simp add: power_gt1_lemma)

lemma one_less_power [simp]: "1 < a \<Longrightarrow> 0 < n \<Longrightarrow> 1 < a ^ n"
  by (cases n) (simp_all add: power_gt1_lemma)

lemma power_decreasing: "n \<le> N \<Longrightarrow> 0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ N \<le> a ^ n"
proof (induction N)
  case (Suc N)
  then have "a * a^N \<le> 1 * a^n" if "n \<le> N"
    using that by (intro mult_mono) auto
  then show ?case
    using Suc by (auto simp add: le_Suc_eq)
qed (auto)

lemma power_increasing: "n \<le> N \<Longrightarrow> 1 \<le> a \<Longrightarrow> a ^ n \<le> a ^ N"
proof (induction N)
  case (Suc N)
  then have "1 * a^n \<le> a * a^N" if "n \<le> N"
    using that by (intro mult_mono) (auto simp add: order_trans[OF zero_le_one])
  then show ?case
    using Suc by (auto simp add: le_Suc_eq)
qed (auto)

lemma power_Suc_le_self: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ Suc n \<le> a"
  using power_decreasing [of 1 "Suc n" a] by simp

end

subclass (in ordered_idom) ordered_semiring_1 by unfold_locales auto

(**** End of lemmas that could be moved to HOL/Rings.thy ****)

(* missing lemma on logarithms *)
lemma log_prod: assumes "0 < a" "a \<noteq> 1" "\<And> x. x \<in> X \<Longrightarrow> 0 < f x"
  shows "log a (prod f X) = sum (log a o f) X"
  using assms(3)
proof (induct X rule: infinite_finite_induct)
  case (insert x F)
  have "log a (prod f (insert x F)) = log a (f x * prod f F)" using insert by simp
  also have "\<dots> = log a (f x) + log a (prod f F)"
    by (rule log_mult[OF assms(1-2) insert(4) prod_pos], insert insert, auto)
  finally show ?case using insert by auto
qed auto

(* TODO: Jordan_Normal_Form/Missing_Ring.ordered_idom should be redefined *)
subclass (in ordered_idom) zero_less_one by (unfold_locales, auto)
hide_fact Missing_Ring.zero_less_one

(**** The following lemmas could be part of the standard library ****)

instance real :: ordered_semiring_strict by (intro_classes, auto)
instance real :: linordered_idom..

(*This is a generalisation of thm less_1_mult*)
lemma less_1_mult':
  fixes a::"'a::linordered_semidom"
  shows "1 < a \<Longrightarrow> 1 \<le> b \<Longrightarrow> 1 < a * b"
  by (metis le_less less_1_mult mult.right_neutral)

lemma upt_minus_eq_append: "i\<le>j \<Longrightarrow> i\<le>j-k \<Longrightarrow> [i..<j] = [i..<j-k] @ [j-k..<j]"
proof (induct k)
  case (Suc k)
  have hyp: "[i..<j] = [i..<j - k] @ [j - k..<j]" using Suc.hyps Suc.prems by auto
  then show ?case
    by (metis Suc.prems(2) append.simps(1) diff_Suc_less nat_less_le neq0_conv upt_append upt_rec zero_diff)
qed auto

lemma list_trisect: "x < length lst \<Longrightarrow> [0..<length lst] = [0..<x]@x#[Suc x..<length lst]"
  by (induct lst, force, rename_tac a lst, case_tac "x = length lst", auto)

lemma id_imp_bij_betw:
  assumes f: "f : A \<rightarrow> A"
      and ff: "\<And>a. a \<in> A \<Longrightarrow> f (f a) = a"
  shows "bij_betw f A A"
  by (intro bij_betwI[OF f f], simp_all add: ff)

lemma range_subsetI:
  assumes "\<And>x. f x = g (h x)" shows "range f \<subseteq> range g"
  using assms by auto

lemma Gcd_uminus:
  fixes A::"int set"
  assumes "finite A"
  shows "Gcd A = Gcd (uminus ` A)"
  using assms
  by (induct A, auto)

lemma aux_abs_int: fixes c :: int
  assumes "c \<noteq> 0"
  shows "\<bar>x\<bar> \<le> \<bar>x * c\<bar>"
proof -
  have "abs x = abs x * 1" by simp
  also have "\<dots> \<le> abs x * abs c"
    by (rule mult_left_mono, insert assms, auto)
  finally show ?thesis unfolding abs_mult by auto
qed

lemma mod_0_abs_less_imp_0:
  fixes a::int
  assumes a1: "[a = 0] (mod m)"
  and a2: "abs(a)<m"
  shows "a = 0"
proof -
  have "m\<ge>0" using assms by auto
  thus ?thesis
    using assms unfolding cong_def
    using int_mod_pos_eq large_mod_0 zless_imp_add1_zle
      by (metis abs_of_nonneg le_less not_less zabs_less_one_iff zmod_trivial_iff)
qed

(* an intro version of sum_list_0 *)
lemma sum_list_zero:
  assumes "set xs \<subseteq> {0}" shows "sum_list xs = 0"
  using assms by (induct xs, auto)

(* About @{const max} *)
lemma max_idem [simp]: shows "max a a = a" by (simp add: max_def)

lemma hom_max:
  assumes "a \<le> b \<longleftrightarrow> f a \<le> f b"
  shows "f (max a b) = max (f a) (f b)" using assms by (auto simp: max_def)

lemma le_max_self:
  fixes a b :: "'a :: preorder"
  assumes "a \<le> b \<or> b \<le> a" shows "a \<le> max a b" and "b \<le> max a b"
  using assms by (auto simp: max_def)

lemma le_max:
  fixes a b :: "'a :: preorder"
  assumes "c \<le> a \<or> c \<le> b" and "a \<le> b \<or> b \<le> a" shows "c \<le> max a b"
  using assms(1) le_max_self[OF assms(2)] by (auto dest: order_trans)

fun max_list where
  "max_list [] = (THE x. False)" (* more convenient than "undefined" *)
| "max_list [x] = x"
| "max_list (x # y # xs) = max x (max_list (y # xs))"

declare max_list.simps(1) [simp del]
declare max_list.simps(2-3)[code]

lemma max_list_Cons: "max_list (x#xs) = (if xs = [] then x else max x (max_list xs))"
  by (cases xs, auto)

lemma max_list_mem: "xs \<noteq> [] \<Longrightarrow> max_list xs \<in> set xs"
  by (induct xs, auto simp: max_list_Cons max_def)

lemma mem_set_imp_le_max_list:
  fixes xs :: "'a :: preorder list"
  assumes "\<And>a b. a \<in> set xs \<Longrightarrow> b \<in> set xs \<Longrightarrow> a \<le> b \<or> b \<le> a"
      and "a \<in> set xs"
  shows "a \<le> max_list xs"
proof (insert assms, induct xs arbitrary:a)
  case Nil
  with assms show ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "xs = []")
    case False
    have "x \<le> max_list xs \<or> max_list xs \<le> x"
      apply (rule Cons(2)) using max_list_mem[of xs] False by auto
    note 1 = le_max_self[OF this]
    from Cons have "a = x \<or> a \<in> set xs" by auto
    then show ?thesis
    proof (elim disjE)
      assume a: "a = x"
      show ?thesis by (unfold a max_list_Cons, auto simp: False intro!: 1)
    next
      assume "a \<in> set xs"
      then have "a \<le> max_list xs" by (intro Cons, auto)
      with 1 have "a \<le> max x (max_list xs)" by (auto dest: order_trans)
      then show ?thesis by (unfold max_list_Cons, auto simp: False)
    qed
  qed (insert Cons, auto)
qed

lemma le_max_list:
  fixes xs :: "'a :: preorder list"
  assumes ord: "\<And>a b. a \<in> set xs \<Longrightarrow> b \<in> set xs \<Longrightarrow> a \<le> b \<or> b \<le> a"
      and ab: "a \<le> b"
      and b: "b \<in> set xs"
  shows "a \<le> max_list xs"
proof-
  note ab
  also have "b \<le> max_list xs"
    by (rule mem_set_imp_le_max_list, fact ord, fact b)
  finally show ?thesis.
qed

lemma max_list_le:
  fixes xs :: "'a :: preorder list"
  assumes a: "\<And>x. x \<in> set xs \<Longrightarrow> x \<le> a"
      and xs: "xs \<noteq> []"
  shows "max_list xs \<le> a"
  using max_list_mem[OF xs] a by auto

lemma max_list_as_Greatest:
  assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> x \<le> y \<or> y \<le> x"
  shows "max_list xs = (GREATEST a. a \<in> set xs)"
proof (cases "xs = []")
  case True
  then show ?thesis by (unfold Greatest_def, auto simp: max_list.simps(1))
next
  case False
  from assms have 1: "x \<in> set xs \<Longrightarrow> x \<le> max_list xs" for x
    by (auto intro: le_max_list)
  have 2: "max_list xs \<in> set xs" by (fact max_list_mem[OF False])
  have "\<exists>!x. x \<in> set xs \<and> (\<forall>y. y \<in> set xs \<longrightarrow> y \<le> x)" (is "\<exists>!x. ?P x")
  proof (intro ex1I)
    from 1 2
    show "?P (max_list xs)" by auto
  next
    fix x assume 3: "?P x"
    with 1 have "x \<le> max_list xs" by auto
    moreover from 2 3 have "max_list xs \<le> x" by auto
    ultimately show "x = max_list xs" by auto
  qed
  note 3 = theI_unique[OF this,symmetric]
  from 1 2 show ?thesis
    by (unfold Greatest_def Cons 3, auto)
qed

lemma hom_max_list_commute:
  assumes "xs \<noteq> []"
      and "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> h (max x y) = max (h x) (h y)"
  shows "h (max_list xs) = max_list (map h xs)"
  by (insert assms, induct xs, auto simp: max_list_Cons max_list_mem)

(*Efficient rev [i..<j]*)
primrec rev_upt :: "nat \<Rightarrow> nat \<Rightarrow> nat list" ("(1[_>.._])") where
rev_upt_0: "[0>..j] = []" |
rev_upt_Suc: "[(Suc i)>..j] = (if i \<ge> j then i # [i>..j] else [])"

definition rev_upt_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat list" where
  "rev_upt_aux i j js = [i>..j] @ js"

lemma upt_aux_rec [code]:
  "rev_upt_aux i j js = (if j\<ge>i then js else rev_upt_aux i (Suc j) (j#js))"
  by (induct j, auto simp add: rev_upt_aux_def rev_upt_rec)

lemma rev_upt_code[code]: "[i>..j] = rev_upt_aux i j []"
  by(simp add: rev_upt_aux_def)

lemma upt_rev_upt:
  "rev [j>..i] = [i..<j]"
  by (induct j, auto)

lemma rev_upt_upt:
  "rev [i..<j] = [j>..i]"
  by (induct j, auto)

lemma length_rev_upt [simp]: "length [i>..j] = i - j"
  by (induct i) (auto simp add: Suc_diff_le)

lemma nth_rev_upt [simp]: "j + k < i \<Longrightarrow> [i>..j] ! k = i - 1 - k"
proof -
  assume jk_i: "j + k < i"
  have "[i>..j] = rev [j..<i]" using rev_upt_upt by simp
  also have "... ! k = [j..<i] ! (length [j..<i] - 1 - k)"
    using jk_i by (simp add: rev_nth)
  also have "... = [j..<i] ! (i - j - 1 - k)" by auto
  also have "... = j + (i - j - 1 - k)" by (rule nth_upt, insert jk_i, auto)
  finally show ?thesis using jk_i by auto
qed

lemma nth_map_rev_upt:
  assumes i: "i < m-n"
  shows "(map f [m>..n]) ! i = f (m - 1 - i)"
proof -
  have "(map f [m>..n]) ! i = f ([m>..n] ! i)" by (rule nth_map, auto simp add: i)
  also have "... = f (m - 1 - i)"
  proof (rule arg_cong[of _ _ f], rule nth_rev_upt)
    show "n + i < m" using i by linarith
  qed
  finally show ?thesis .
qed

lemma coeff_mult_monom:
 "coeff (p * monom a d) i = (if d \<le> i then a * coeff p (i - d) else 0)"
  using coeff_monom_mult[of a d p] by (simp add: ac_simps)

(**** End of the lemmas which may be part of the standard library ****)

(**** The following lemmas could be moved to Algebraic_Numbers/Resultant.thy ****)
lemma vec_of_poly_0 [simp]: "vec_of_poly 0 = 0\<^sub>v 1" by (auto simp: vec_of_poly_def)

lemma vec_index_vec_of_poly [simp]: "i \<le> degree p \<Longrightarrow> vec_of_poly p $ i = coeff p (degree p - i)"
  by (simp add: vec_of_poly_def Let_def)

lemma poly_of_vec_vec: "poly_of_vec (vec n f) = Poly (rev (map f [0..<n]))"
proof (induct n arbitrary:f)
  case 0
  then show ?case by auto
next
  case (Suc n)
  have "map f [0..<Suc n] = f 0 # map (f \<circ> Suc) [0..<n]" by (simp add: map_upt_Suc del: upt_Suc)
  also have "Poly (rev \<dots>) = Poly (rev (map (f \<circ> Suc) [0..<n])) + monom (f 0) n"
    by (simp add: Poly_snoc smult_monom)
  also have "\<dots> = poly_of_vec (vec n (f \<circ> Suc)) + monom (f 0) n"
    by (fold Suc, simp)
  also have "\<dots> = poly_of_vec (vec (Suc n) f)"
    apply (unfold poly_of_vec_def Let_def dim_vec sum.lessThan_Suc)
    by (auto simp add: Suc_diff_Suc)
  finally show ?case..
qed

lemma sum_list_map_dropWhile0:
  assumes f0: "f 0 = 0"
  shows "sum_list (map f (dropWhile ((=) 0) xs)) = sum_list (map f xs)"
  by (induct xs, auto simp add: f0)

lemma coeffs_poly_of_vec:
  "coeffs (poly_of_vec v) = rev (dropWhile ((=) 0) (list_of_vec v))"
proof-
  obtain n f where v: "v = vec n f" by transfer auto
  show ?thesis by (simp add: v poly_of_vec_vec)
qed

lemma poly_of_vec_vCons:
 "poly_of_vec (vCons a v) = monom a (dim_vec v) + poly_of_vec v" (is "?l = ?r")
  by (auto intro: poly_eqI simp: coeff_poly_of_vec vec_index_vCons)

lemma poly_of_vec_as_Poly: "poly_of_vec v = Poly (rev (list_of_vec v))"
  by (induct v, auto simp:poly_of_vec_vCons Poly_snoc ac_simps)

lemma poly_of_vec_add:
  assumes "dim_vec a = dim_vec b"
  shows "poly_of_vec (a + b) = poly_of_vec a + poly_of_vec b"
  using assms
  by (auto simp add: poly_eq_iff coeff_poly_of_vec)

(*TODO: replace the one in Resultant.thy*)
lemma degree_poly_of_vec_less:
  assumes "0 < dim_vec v" and "dim_vec v \<le> n" shows "degree (poly_of_vec v) < n"
  using degree_poly_of_vec_less assms by (auto dest: less_le_trans)

lemma (in vec_module) poly_of_vec_finsum:
  assumes "f \<in> X \<rightarrow> carrier_vec n"
  shows "poly_of_vec (finsum V f X) = (\<Sum>i\<in>X. poly_of_vec (f i))"
proof (cases "finite X")
  case False then show ?thesis by auto
next
  case True show ?thesis
  proof (insert True assms, induct X rule: finite_induct)
    case IH: (insert a X)
    have [simp]: "f x \<in> carrier_vec n" if x: "x \<in> X" for x
      using x IH.prems unfolding Pi_def by auto
    have [simp]: "f a \<in> carrier_vec n" using IH.prems unfolding Pi_def by auto
    have [simp]: "dim_vec (finsum V f X) = n" by simp
    have [simp]: "dim_vec (f a) = n" by simp
    show ?case
    proof (cases "a \<in> X")
      case True then show ?thesis by (auto simp: insert_absorb IH)
    next
      case False
      then have "(finsum V f (insert a X)) = f a + (finsum V f X)"
        by (auto intro: finsum_insert IH)
      also have "poly_of_vec ... = poly_of_vec (f a) + poly_of_vec (finsum V f X)"
        by (rule poly_of_vec_add, simp)
      also have "... = (\<Sum>i\<in>insert a X. poly_of_vec (f i))"
        using IH False by (subst sum.insert, auto)
      finally show ?thesis .
    qed
  qed auto
qed

(*This function transforms a polynomial to a vector of dimension n*)
definition "vec_of_poly_n p n =
  vec n (\<lambda>i. if i < n - degree p - 1 then 0 else coeff p (n - i - 1))"

(* TODO: make it abbreviation? *)
lemma vec_of_poly_as: "vec_of_poly_n p (Suc (degree p)) = vec_of_poly p"
  by (induct p, auto simp: vec_of_poly_def vec_of_poly_n_def)

lemma vec_of_poly_n_0 [simp]: "vec_of_poly_n p 0 = vNil"
  by (auto simp: vec_of_poly_n_def)

lemma vec_dim_vec_of_poly_n [simp]:
  "dim_vec (vec_of_poly_n p n) = n"
  "vec_of_poly_n p n \<in> carrier_vec n"
  unfolding vec_of_poly_n_def by auto

lemma dim_vec_of_poly [simp]: "dim_vec (vec_of_poly f) = degree f + 1"
  by (simp add: vec_of_poly_as[symmetric])

lemma vec_index_of_poly_n:
  assumes "i < n"
  shows "vec_of_poly_n p n $ i =
    (if i < n - Suc (degree p) then 0 else coeff p (n - i - 1))"
  using assms by (auto simp: vec_of_poly_n_def Let_def)

lemma vec_of_poly_n_pCons[simp]:
  shows "vec_of_poly_n (pCons a p) (Suc n) = vec_of_poly_n p n @\<^sub>v vec_of_list [a]" (is "?l = ?r")
proof (unfold vec_eq_iff, intro conjI allI impI)
  show "dim_vec ?l = dim_vec ?r" by auto
  show "i < dim_vec ?r \<Longrightarrow> ?l $ i = ?r $ i" for i
    by (cases "n - i", auto simp: coeff_pCons less_Suc_eq_le vec_index_of_poly_n)
qed

lemma vec_of_poly_pCons:
  shows "vec_of_poly (pCons a p) =
   (if p = 0 then vec_of_list [a] else vec_of_poly p @\<^sub>v vec_of_list [a])"
  by (cases "degree p", auto simp: vec_of_poly_as[symmetric])

lemma list_of_vec_of_poly [simp]:
  "list_of_vec (vec_of_poly p) = (if p = 0 then [0] else rev (coeffs p))"
  by (induct p, auto simp: vec_of_poly_pCons)

lemma poly_of_vec_of_poly_n:
  assumes p: "degree p<n"
  shows "poly_of_vec (vec_of_poly_n p n) = p"
proof -
  have "vec_of_poly_n p n $ (n - Suc i) = coeff p i" if i: "i < n" for i
  proof -
    have n: "n - Suc i < n" using i by auto
    have "vec_of_poly_n p n $ (n - Suc i) =
      (if n - Suc i < n - Suc (degree p) then 0 else coeff p (n - (n - Suc i) - 1))"
      using vec_index_of_poly_n[OF n, of p] .
    also have "... = coeff p i" using i n le_degree by fastforce
    finally show ?thesis .
  qed
  moreover have "coeff p i = 0" if i2: "i \<ge> n" for i
    by (rule coeff_eq_0, insert i2 p, simp)
  ultimately show ?thesis
  using assms
  unfolding poly_eq_iff
  unfolding coeff_poly_of_vec by auto
qed

lemma vec_of_poly_n0[simp]: "vec_of_poly_n 0 n = 0\<^sub>v n"
  unfolding vec_of_poly_n_def by auto

lemma vec_of_poly_n_add: "vec_of_poly_n (a + b) n = vec_of_poly_n a n + vec_of_poly_n b n"
proof (induct n arbitrary: a b)
  case 0
  then show ?case by auto
next
  case (Suc n)
  then show ?case by (cases a, cases b, auto)
qed

lemma vec_of_poly_n_poly_of_vec:
  assumes n: "dim_vec g = n"
  shows "vec_of_poly_n (poly_of_vec g) n = g"
proof (auto simp add: poly_of_vec_def vec_of_poly_n_def assms vec_eq_iff Let_def)
  have d: "degree (\<Sum>i<n. monom (g $ (n - Suc i)) i) = degree (poly_of_vec g)"
    unfolding poly_of_vec_def Let_def n by auto
  fix i assume i1: "i < n - Suc (degree (\<Sum>i<n. monom (g $ (n - Suc i)) i))"
    and i2: "i < n"
  have i3: "i < n - Suc (degree (poly_of_vec g))"
    using i1 unfolding d by auto
  hence "dim_vec g - Suc i > degree (poly_of_vec g)"
    using n by linarith
  then show "g $ i = 0" using i1 i2 i3
    by (metis (no_types, lifting) Suc_diff_Suc coeff_poly_of_vec diff_Suc_less
        diff_diff_cancel leD le_degree less_imp_le_nat n neq0_conv)
next
  fix i assume "i < n"
  thus "coeff (\<Sum>i<n. monom (g $ (n - Suc i)) i) (n - Suc i) = g $ i"
    by (metis (no_types) Suc_diff_Suc coeff_poly_of_vec diff_diff_cancel
        diff_less_Suc less_imp_le_nat n not_less_eq poly_of_vec_def)
qed

lemma poly_of_vec_scalar_mult:
  assumes "degree b<n"
  shows "poly_of_vec (a \<cdot>\<^sub>v (vec_of_poly_n b n)) = smult a b"
  using assms
  by (auto simp add: poly_eq_iff coeff_poly_of_vec vec_of_poly_n_def coeff_eq_0)

(*TODO: replace the one in Resultant.thy*)
definition vec_of_poly_rev_shifted where
  "vec_of_poly_rev_shifted p n s j \<equiv>
   vec n (\<lambda>i. if i \<le> j \<and> j \<le> s + i then coeff p (s + i - j) else 0)"

lemma vec_of_poly_rev_shifted_dim[simp]: "dim_vec (vec_of_poly_rev_shifted p n s j) = n"
  unfolding vec_of_poly_rev_shifted_def by auto

lemma col_sylvester_sub: (* TODO: from this directly derive col_sylvester *)
  assumes j: "j < m + n"
  shows "col (sylvester_mat_sub m n p q) j =
    vec_of_poly_rev_shifted p n m j @\<^sub>v vec_of_poly_rev_shifted q m n j" (is "?l = ?r")
proof
  show "dim_vec ?l = dim_vec ?r" by simp
  fix i assume "i < dim_vec ?r" then have i: "i < m+n" by auto
  show "?l $ i = ?r $ i"
    unfolding vec_of_poly_rev_shifted_def
    apply (subst index_col) using i apply simp using j apply simp
    apply (subst sylvester_mat_sub_index) using i apply simp using j apply simp
    apply (cases "i < n") using i apply force using i
    apply (auto simp: not_less not_le intro!: coeff_eq_0)
    done
qed

lemma vec_of_poly_rev_shifted_scalar_prod:
  fixes p v
  defines "q \<equiv> poly_of_vec v"
  assumes m: "degree p \<le> m" and n: "dim_vec v = n"
  assumes j: "j < m+n"
  shows "vec_of_poly_rev_shifted p n m (n+m-Suc j) \<bullet> v = coeff (p * q) j" (is "?l = ?r")
proof -
  have id1: "\<And> i. m + i - (n + m - Suc j) = i + Suc j - n"
    using j by auto
  let ?g = "\<lambda> i. if i \<le> n + m - Suc j \<and> n - Suc j \<le> i then coeff p (i + Suc j - n) *  v $ i else 0"
  have "?thesis = ((\<Sum>i = 0..<n. ?g i) =
        (\<Sum>i\<le>j. coeff p i * (if j - i < n then v $ (n - Suc (j - i)) else 0)))" (is "_ = (?l = ?r)")
    unfolding vec_of_poly_rev_shifted_def coeff_mult m scalar_prod_def n q_def
      coeff_poly_of_vec
    by (subst sum.cong, insert id1, auto)
  also have "..."
  proof -
    have "?r = (\<Sum>i\<le>j. (if j - i < n then coeff p i * v $ (n - Suc (j - i)) else 0))" (is "_ = sum ?f _")
      by (rule sum.cong, auto)
    also have "sum ?f {..j} = sum ?f ({i. i \<le> j \<and> j - i < n} \<union> {i. i \<le> j \<and> \<not> j - i < n})"
      (is "_ = sum _ (?R1 \<union> ?R2)")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?f ?R1 + sum ?f ?R2"
      by (subst sum.union_disjoint, auto)
    also have "sum ?f ?R2 = 0"
      by (rule sum.neutral, auto)
    also have "sum ?f ?R1 + 0 = sum (\<lambda> i. coeff p i * v $ (i + n - Suc j)) ?R1"
      (is "_ = sum ?F _")
      by (subst sum.cong, auto simp: ac_simps)
    also have "\<dots> = sum ?F ((?R1 \<inter> {..m}) \<union> (?R1 - {..m}))"
      (is "_ = sum _ (?R \<union> ?R')")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?F ?R + sum ?F ?R'"
      by (subst sum.union_disjoint, auto)
    also have "sum ?F ?R' = 0"
    proof -
      {
        fix x
        assume "x > m"
        with m
        have "?F x = 0" by (subst coeff_eq_0, auto)
      }
      thus ?thesis
        by (subst sum.neutral, auto)
    qed
    finally have r: "?r = sum ?F ?R" by simp

    have "?l = sum ?g ({i. i < n \<and> i \<le> n + m - Suc j \<and> n - Suc j \<le> i}
      \<union> {i. i < n \<and> \<not> (i \<le> n + m - Suc j \<and> n - Suc j \<le> i)})"
      (is "_ = sum _ (?L1 \<union> ?L2)")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?g ?L1 + sum ?g ?L2"
      by (subst sum.union_disjoint, auto)
    also have "sum ?g ?L2 = 0"
      by (rule sum.neutral, auto)
    also have "sum ?g ?L1 + 0 = sum (\<lambda> i. coeff p (i + Suc j - n) * v $ i) ?L1"
      (is "_ = sum ?G _")
      by (subst sum.cong, auto)
    also have "\<dots> = sum ?G (?L1 \<inter> {i. i + Suc j - n \<le> m} \<union> (?L1 - {i. i + Suc j - n \<le> m}))"
      (is "_ = sum _ (?L \<union> ?L')")
      by (subst sum.cong, auto)
    also have "\<dots> = sum ?G ?L + sum ?G ?L'"
      by (subst sum.union_disjoint, auto)
    also have "sum ?G ?L' = 0"
    proof -
      {
        fix x
        assume "x + Suc j - n > m"
        with m
        have "?G x = 0" by (subst coeff_eq_0, auto)
      }
      thus ?thesis
        by (subst sum.neutral, auto)
    qed
    finally have l: "?l = sum ?G ?L" by simp

    let ?bij = "\<lambda> i. i + n - Suc j"
    {
      fix x
      assume x: "j < m + n" "Suc (x + j) - n \<le> m" "x < n" "n - Suc j \<le> x"
      define y where "y = x + Suc j - n"
      from x have "x + Suc j \<ge> n" by auto
      with x have xy: "x = ?bij y" unfolding y_def by auto
      from x have y: "y \<in> ?R" unfolding y_def by auto
      have "x \<in> ?bij ` ?R" unfolding xy using y by blast
    } note tedious = this
    show ?thesis unfolding l r
      by (rule sum.reindex_cong[of ?bij], insert j, auto simp: inj_on_def tedious)
  qed
  finally show ?thesis by simp
qed

lemma sylvester_sub_poly:
  fixes p q :: "'a :: comm_semiring_0 poly"
  assumes m: "degree p \<le> m"
  assumes n: "degree q \<le> n"
  assumes v: "v \<in> carrier_vec (m+n)"
  shows "poly_of_vec ((sylvester_mat_sub m n p q)\<^sup>T *\<^sub>v v) =
    poly_of_vec (vec_first v n) * p + poly_of_vec (vec_last v m) * q" (is "?l = ?r")
proof (rule poly_eqI)
  fix i
  let ?Tv = "(sylvester_mat_sub m n p q)\<^sup>T *\<^sub>v v"
  have dim: "dim_vec (vec_first v n) = n" "dim_vec (vec_last v m) = m" "dim_vec ?Tv = n + m"
    using v by auto
  have if_distrib: "\<And> x y z. (if x then y else (0 :: 'a)) * z = (if x then y * z else 0)"
    by auto
  show "coeff ?l i = coeff ?r i"
  proof (cases "i < m+n")
    case False
      hence i_mn: "i \<ge> m+n"
        and i_n: "\<And>x. x \<le> i \<and> x < n \<longleftrightarrow> x < n"
        and i_m: "\<And>x. x \<le> i \<and> x < m \<longleftrightarrow> x < m" by auto
      have "coeff ?r i =
            (\<Sum> x < n. vec_first v n $ (n - Suc x) * coeff p (i - x)) +
            (\<Sum> x < m. vec_last v m $ (m - Suc x) * coeff q (i - x))"
        (is "_ = sum ?f _ + sum ?g _")
        unfolding coeff_add coeff_mult Let_def
        unfolding coeff_poly_of_vec dim if_distrib
        unfolding atMost_def
        apply(subst sum.inter_filter[symmetric],simp)
        apply(subst sum.inter_filter[symmetric],simp)
        unfolding mem_Collect_eq
        unfolding i_n i_m
        unfolding lessThan_def by simp
      also { fix x assume x: "x < n"
        have "coeff p (i-x) = 0"
          apply(rule coeff_eq_0) using i_mn x m by auto
        hence "?f x = 0" by auto
      } hence "sum ?f {..<n} = 0" by auto
      also { fix x assume x: "x < m"
        have "coeff q (i-x) = 0"
          apply(rule coeff_eq_0) using i_mn x n by auto
        hence "?g x = 0" by auto
      } hence "sum ?g {..<m} = 0" by auto
      finally have "coeff ?r i = 0" by auto
      also from False have "0 = coeff ?l i"
        unfolding coeff_poly_of_vec dim sum.distrib[symmetric] by auto
      finally show ?thesis by auto
    next case True
      hence "coeff ?l i = ((sylvester_mat_sub m n p q)\<^sup>T *\<^sub>v v) $ (n + m - Suc i)"
        unfolding coeff_poly_of_vec dim sum.distrib[symmetric] by auto
      also have "... = coeff (p * poly_of_vec (vec_first v n) + q * poly_of_vec (vec_last v m)) i"
        apply(subst index_mult_mat_vec) using True apply simp
        apply(subst row_transpose) using True apply simp
        apply(subst col_sylvester_sub)
        using True apply simp
        apply(subst vec_first_last_append[of v n m,symmetric]) using v apply(simp add: add.commute)
        apply(subst scalar_prod_append)
        apply (rule carrier_vecI,simp)+
        apply (subst vec_of_poly_rev_shifted_scalar_prod[OF m],simp) using True apply simp
        apply (subst add.commute[of n m])
        apply (subst vec_of_poly_rev_shifted_scalar_prod[OF n]) apply simp using True apply simp
        by simp
      also have "... =
        (\<Sum>x\<le>i. (if x < n then vec_first v n $ (n - Suc x) else 0) * coeff p (i - x)) +
        (\<Sum>x\<le>i. (if x < m then vec_last v m $ (m - Suc x) else 0) * coeff q (i - x))"
        unfolding coeff_poly_of_vec[of "vec_first v n",unfolded dim_vec_first,symmetric]
        unfolding coeff_poly_of_vec[of "vec_last v m",unfolded dim_vec_last,symmetric]
        unfolding coeff_mult[symmetric] by (simp add: mult.commute)
      also have "... = coeff ?r i"
        unfolding coeff_add coeff_mult Let_def
        unfolding coeff_poly_of_vec dim..
      finally show ?thesis.
  qed
qed

(**** End of the lemmas which could be moved to Algebraic_Numbers/Resultant.thy ****)

(**** The following lemmas could be moved to Computational_Algebra/Polynomial.thy ****)

lemma normalize_field [simp]: "normalize (a :: 'a :: {field, semiring_gcd}) = (if a = 0 then 0 else 1)"
  using unit_factor_normalize by fastforce

lemma content_field [simp]: "content (p :: 'a :: {field,semiring_gcd} poly) = (if p = 0 then 0 else 1)"
  by (induct p, auto simp: content_def)

lemma primitive_part_field [simp]: "primitive_part (p :: 'a :: {field,semiring_gcd} poly) = p"
  by (cases "p = 0", auto intro!: primitive_part_prim)

lemma primitive_part_dvd: "primitive_part a dvd a"
  by (metis content_times_primitive_part dvd_def dvd_refl mult_smult_right)

lemma degree_abs [simp]:
  "degree \<bar>p\<bar> = degree p" by (auto simp: abs_poly_def)

lemma degree_gcd1:
  assumes a_not0: "a \<noteq> 0"
  shows "degree (gcd a b) \<le> degree a"
proof -
  let ?g = "gcd a b"
  have gcd_dvd_b: "?g dvd a" by simp
  from this obtain c where a_gc: "a = ?g * c" unfolding dvd_def by auto
  have g_not0: "?g \<noteq>0" using a_not0 a_gc by auto
  have c0: "c \<noteq> 0" using a_not0 a_gc by auto
  have "degree ?g \<le> degree (?g * c)" by (rule degree_mult_right_le[OF c0])
  also have "... = degree a" using a_gc by auto
  finally show ?thesis .
qed

lemma primitive_part_neg [simp]:
  fixes a::"'a :: {factorial_ring_gcd,factorial_semiring_multiplicative} poly"
  shows "primitive_part (-a) = - primitive_part a"
proof -
  have "primitive_part (-a) = primitive_part (smult (-1) a)" by auto
  then show ?thesis unfolding primitive_part_smult
    by (simp add: is_unit_unit_factor)
qed

lemma content_uminus[simp]:
  fixes f::"int poly"
  shows "content (-f) = content f"
proof -
  have "-f = - (smult 1 f)" by auto
  also have "... = smult (-1) f" using smult_minus_left by auto
  finally have "content (-f) = content (smult (-1) f)" by auto
  also have "... = normalize (- 1) * content f" unfolding content_smult ..
  finally show ?thesis by auto
qed

lemma pseudo_mod_monic:
  fixes f g :: "'a::{comm_ring_1,semiring_1_no_zero_divisors} poly"
  defines "r \<equiv> pseudo_mod f g"
  assumes monic_g: "monic g"
  shows "\<exists>q.  f = g * q + r" "r = 0 \<or> degree r < degree g"
proof -
  let ?cg = "coeff g (degree g)"
  let ?cge = "?cg ^ (Suc (degree f) - degree g)"
  define a where "a = ?cge"
  from r_def[unfolded pseudo_mod_def] obtain q where pdm: "pseudo_divmod f g = (q, r)"
    by (cases "pseudo_divmod f g") auto
  have g: "g \<noteq> 0" using monic_g by auto
  from pseudo_divmod[OF g pdm] have id: "smult a f = g * q + r" and "r = 0 \<or> degree r < degree g"
    by (auto simp: a_def)
  have a1: "a = 1" unfolding a_def using monic_g by auto
  hence id2: "f = g * q + r" using id by auto
  show "r = 0 \<or> degree r < degree g" by fact
  from g have "a \<noteq> 0"
    by (auto simp: a_def)
  with id2 show "\<exists>q. f = g * q + r"
    by auto
qed

lemma monic_imp_div_mod_int_poly_degree:
  fixes p :: "'a::{comm_ring_1,semiring_1_no_zero_divisors} poly"
  assumes m: "monic u"
  shows "\<exists>q r. p = q*u + r \<and> (r = 0 \<or> degree r < degree u)"
  using pseudo_mod_monic[OF m] using mult.commute by metis

corollary monic_imp_div_mod_int_poly_degree2:
  fixes p :: "'a::{comm_ring_1,semiring_1_no_zero_divisors} poly"
  assumes m: "monic u" and deg_u: "degree u > 0"
  shows "\<exists>q r. p = q*u + r \<and> (degree r < degree u)"
proof -
  obtain q r where "p = q * u + r" and r: "(r = 0 \<or> degree r < degree u)"
      using monic_imp_div_mod_int_poly_degree[OF m, of p] by auto
    moreover have "degree r < degree u" using deg_u r by auto
  ultimately show ?thesis by auto
qed
(**** End of the lemmas that could be moved to Computational_Algebra/Polynomial.thy ****)

(* To be categorized *)
lemma (in zero_hom) hom_upper_triangular:
  "A \<in> carrier_mat n n \<Longrightarrow> upper_triangular A \<Longrightarrow> upper_triangular (map_mat hom A)"
  by (auto simp: upper_triangular_def)

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

section \<open>The Almost-Full Property\<close>

theory Almost_Full
imports
  "HOL-Library.Sublist"
  "HOL-Library.Ramsey"
  "Regular-Sets.Regexp_Method"
  "Abstract-Rewriting.Seq"
  Least_Enum
  Infinite_Sequences
  Open_Induction.Restricted_Predicates
begin

(*TODO: move*)
lemma le_Suc_eq':
  "x \<le> Suc y \<longleftrightarrow> x = 0 \<or> (\<exists>x'. x = Suc x' \<and> x' \<le> y)"
  by (cases x) auto

lemma ex_leq_Suc:
  "(\<exists>i\<le>Suc j. P i) \<longleftrightarrow> P 0 \<or> (\<exists>i\<le>j. P (Suc i))"
  by (auto simp: le_Suc_eq')

lemma ex_less_Suc:
  "(\<exists>i<Suc j. P i) \<longleftrightarrow> P 0 \<or> (\<exists>i<j. P (Suc i))"
  by (auto simp: less_Suc_eq_0_disj)

subsection \<open>Basic Definitions and Facts\<close>

text \<open>
  An infinite sequence is \emph{good} whenever there are indices @{term "i < j"} such that
  @{term "P (f i) (f j)"}.
\<close>
definition good :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "good P f \<longleftrightarrow> (\<exists>i j. i < j \<and> P (f i) (f j))"

text \<open>A sequence that is not good is called \emph{bad}.\<close>
abbreviation "bad P f \<equiv> \<not> good P f"

lemma goodI:
  "\<lbrakk>i < j; P (f i) (f j)\<rbrakk> \<Longrightarrow> good P f"
by (auto simp: good_def)

lemma goodE [elim]:
  "good P f \<Longrightarrow> (\<And>i j. \<lbrakk>i < j; P (f i) (f j)\<rbrakk> \<Longrightarrow> Q) \<Longrightarrow> Q"
 by (auto simp: good_def)

lemma badE [elim]:
  "bad P f \<Longrightarrow> ((\<And>i j. i < j \<Longrightarrow> \<not> P (f i) (f j)) \<Longrightarrow> Q) \<Longrightarrow> Q"
by (auto simp: good_def)

definition almost_full_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
where
  "almost_full_on P A \<longleftrightarrow> (\<forall>f \<in> SEQ A. good P f)"

lemma almost_full_onI [Pure.intro]:
  "(\<And>f. \<forall>i. f i \<in> A \<Longrightarrow> good P f) \<Longrightarrow> almost_full_on P A"
  unfolding almost_full_on_def by blast

lemma almost_full_onD:
  fixes f :: "nat \<Rightarrow> 'a" and A :: "'a set"
  assumes "almost_full_on P A" and "\<And>i. f i \<in> A"
  obtains i j where "i < j" and "P (f i) (f j)"
  using assms unfolding almost_full_on_def by blast

subsection \<open>An equivalent inductive definition\<close>

inductive af for A
  where
    now: "(\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> P x y) \<Longrightarrow> af A P"
  | later: "(\<And>x. x \<in> A \<Longrightarrow> af A (\<lambda>y z. P y z \<or> P x y)) \<Longrightarrow> af A P"

lemma af_imp_almost_full_on:
  assumes "af A P"
  shows "almost_full_on P A"
proof
  fix f :: "nat \<Rightarrow> 'a" assume "\<forall>i. f i \<in> A"
  with assms obtain i and j where "i < j" and "P (f i) (f j)"
  proof (induct arbitrary: f thesis)
    case (later P)
    define g where [simp]: "g i = f (Suc i)" for i
    have "f 0 \<in> A" and "\<forall>i. g i \<in> A" using later by auto
    then obtain i and j where "i < j" and "P (g i) (g j) \<or> P (f 0) (g i)" using later by blast
    then consider "P (g i) (g j)" | "P (f 0) (g i)" by blast
    then show ?case using \<open>i < j\<close> by (cases) (auto intro: later)
  qed blast
  then show "good P f" by (auto simp: good_def)
qed

lemma af_mono:
  assumes "af A P"
    and "\<forall>x y. x \<in> A \<and> y \<in> A \<and> P x y \<longrightarrow> Q x y"
  shows "af A Q"
  using assms
proof (induct arbitrary: Q)
  case (now P)
  then have "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> Q x y" by blast
  then show ?case by (rule af.now)
next
  case (later P)
  show ?case
  proof (intro af.later [of A Q])
    fix x assume "x \<in> A"
    then show "af A (\<lambda>y z. Q y z \<or> Q x y)"
      using later(3) by (intro later(2) [of x]) auto
  qed
qed

lemma wfp_on_imp_af:
  assumes "wfp_on P A"
  shows "af A (\<lambda>x y. \<not> P y x)"
  using assms by (auto simp: wfp_on_accessible_on_iff intro: accessible_on_imp_af af.later)

lemma af_leq:
  "af UNIV ((\<le>) :: nat \<Rightarrow> nat \<Rightarrow> bool)"
  using wf_less [folded wfP_def wfp_on_UNIV, THEN wfp_on_imp_af] by (simp add: not_less)

definition "NOTAF A P = (SOME x. x \<in> A \<and> \<not> af A (\<lambda>y z. P y z \<or> P x y))"

lemma not_af:
  "\<not> af A P \<Longrightarrow> (\<exists>x y. x \<in> A \<and> y \<in> A \<and> \<not> P x y) \<and> (\<exists>x\<in>A. \<not> af A (\<lambda>y z. P y z \<or> P x y))"
  unfolding af.simps [of A P] by blast

fun F
  where
    "F A P 0 = NOTAF A P"
  | "F A P (Suc i) = (let x = NOTAF A P in F A (\<lambda>y z. P y z \<or> P x y) i)"

lemma almost_full_on_imp_af:
  assumes af: "almost_full_on P A"
  shows "af A P"
proof (rule ccontr)
  assume "\<not> af A P"
  then have *: "F A P n \<in> A \<and>
    \<not> af A (\<lambda>y z. P y z \<or> (\<exists>i\<le>n. P (F A P i) y) \<or> (\<exists>j\<le>n. \<exists>i. i < j \<and> P (F A P i) (F A P j)))" for n
  proof (induct n arbitrary: P)
    case 0
    from \<open>\<not> af A P\<close> have "\<exists>x. x \<in> A \<and> \<not> af A (\<lambda>y z. P y z \<or> P x y)" by (auto intro: af.intros)
    then have "NOTAF A P \<in> A \<and> \<not> af A (\<lambda>y z. P y z \<or> P (NOTAF A P) y)" unfolding NOTAF_def by (rule someI_ex)
    with 0 show ?case by simp
  next
    case (Suc n)
    from \<open>\<not> af A P\<close> have "\<exists>x. x \<in> A \<and> \<not> af A (\<lambda>y z. P y z \<or> P x y)" by (auto intro: af.intros)
    then have "NOTAF A P \<in> A \<and> \<not> af A (\<lambda>y z. P y z \<or> P (NOTAF A P) y)" unfolding NOTAF_def by (rule someI_ex)
    from Suc(1) [OF this [THEN conjunct2]]
    show ?case
      by (fastforce simp: ex_leq_Suc ex_less_Suc elim!: back_subst [where P = "\<lambda>x. \<not> af A x"])
  qed
  then have "F A P \<in> SEQ A" by auto
  from af [unfolded almost_full_on_def, THEN bspec, OF this] and not_af [OF * [THEN conjunct2]]
  show False unfolding good_def by blast
qed

hide_const NOTAF F

lemma almost_full_on_UNIV:
  "almost_full_on (\<lambda>_ _. True) UNIV"
by (auto simp: almost_full_on_def good_def)

lemma almost_full_on_imp_reflp_on:
  assumes "almost_full_on P A"
  shows "reflp_on P A"
using assms by (auto simp: almost_full_on_def reflp_on_def)

lemma almost_full_on_subset:
  "A \<subseteq> B \<Longrightarrow> almost_full_on P B \<Longrightarrow> almost_full_on P A"
by (auto simp: almost_full_on_def)

lemma almost_full_on_mono:
  assumes "A \<subseteq> B" and "\<And>x y. Q x y \<Longrightarrow> P x y"
    and "almost_full_on Q B"
  shows "almost_full_on P A"
  using assms by (metis almost_full_on_def almost_full_on_subset good_def)

text \<open>
  Every sequence over elements of an almost-full set has a homogeneous subsequence.
\<close>
lemma almost_full_on_imp_homogeneous_subseq:
  assumes "almost_full_on P A"
    and "\<forall>i::nat. f i \<in> A"
  shows "\<exists>\<phi>::nat \<Rightarrow> nat. \<forall>i j. i < j \<longrightarrow> \<phi> i < \<phi> j \<and> P (f (\<phi> i)) (f (\<phi> j))"
proof -
  define X where "X = {{i, j} | i j::nat. i < j \<and> P (f i) (f j)}"
  define Y where "Y = - X"
  define h where "h = (\<lambda>Z. if Z \<in> X then 0 else Suc 0)"

  have [iff]: "\<And>x y. h {x, y} = 0 \<longleftrightarrow> {x, y} \<in> X" by (auto simp: h_def)
  have [iff]: "\<And>x y. h {x, y} = Suc 0 \<longleftrightarrow> {x, y} \<in> Y" by (auto simp: h_def Y_def)

  have "\<forall>x\<in>UNIV. \<forall>y\<in>UNIV. x \<noteq> y \<longrightarrow> h {x, y} < 2" by (simp add: h_def)
  from Ramsey2 [OF infinite_UNIV_nat this] obtain I c
    where "infinite I" and "c < 2"
    and *: "\<forall>x\<in>I. \<forall>y\<in>I. x \<noteq> y \<longrightarrow> h {x, y} = c" by blast
  then interpret infinitely_many1 "\<lambda>i. i \<in> I"
    by (unfold_locales) (simp add: infinite_nat_iff_unbounded)

  have "c = 0 \<or> c = 1" using \<open>c < 2\<close> by arith
  then show ?thesis
  proof
    assume [simp]: "c = 0"
    have "\<forall>i j. i < j \<longrightarrow> P (f (enum i)) (f (enum j))"
    proof (intro allI impI)
      fix i j :: nat
      assume "i < j"
      from * and enum_P and enum_less [OF \<open>i < j\<close>] have "{enum i, enum j} \<in> X" by auto
      with enum_less [OF \<open>i < j\<close>]
        show "P (f (enum i)) (f (enum j))" by (auto simp: X_def doubleton_eq_iff)
    qed
    then show ?thesis using enum_less by blast
  next
    assume [simp]: "c = 1"
    have "\<forall>i j. i < j \<longrightarrow> \<not> P (f (enum i)) (f (enum j))"
    proof (intro allI impI)
      fix i j :: nat
      assume "i < j"
      from * and enum_P and enum_less [OF \<open>i < j\<close>] have "{enum i, enum j} \<in> Y" by auto
      with enum_less [OF \<open>i < j\<close>]
        show "\<not> P (f (enum i)) (f (enum j))" by (auto simp: Y_def X_def doubleton_eq_iff)
    qed
    then have "\<not> good P (f \<circ> enum)" by auto
    moreover have "\<forall>i. f (enum i) \<in> A" using assms by auto
    ultimately show ?thesis using \<open>almost_full_on P A\<close> by (simp add: almost_full_on_def)
  qed
qed

text \<open>
  Almost full relations do not admit infinite antichains.
\<close>
lemma almost_full_on_imp_no_antichain_on:
  assumes "almost_full_on P A"
  shows "\<not> antichain_on P f A"
proof
  assume *: "antichain_on P f A"
  then have "\<forall>i. f i \<in> A" by simp
  with assms have "good P f" by (auto simp: almost_full_on_def)
  then obtain i j where "i < j" and "P (f i) (f j)"
    unfolding good_def by auto
  moreover with * have "incomparable P (f i) (f j)" by auto
  ultimately show False by blast
qed

text \<open>
  If the image of a function is almost-full then also its preimage is almost-full.
\<close>
lemma almost_full_on_map:
  assumes "almost_full_on Q B"
    and "h ` A \<subseteq> B"
  shows "almost_full_on (\<lambda>x y. Q (h x) (h y)) A" (is "almost_full_on ?P A")
proof
  fix f
  assume "\<forall>i::nat. f i \<in> A"
  then have "\<And>i. h (f i) \<in> B" using \<open>h ` A \<subseteq> B\<close> by auto
  with \<open>almost_full_on Q B\<close> [unfolded almost_full_on_def, THEN bspec, of "h \<circ> f"]
    show "good ?P f" unfolding good_def comp_def by blast
qed

text \<open>
  The homomorphic image of an almost-full set is almost-full.
\<close>
lemma almost_full_on_hom:
  fixes h :: "'a \<Rightarrow> 'b"
  assumes hom: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A; P x y\<rbrakk> \<Longrightarrow> Q (h x) (h y)"
    and af: "almost_full_on P A"
  shows "almost_full_on Q (h ` A)"
proof
  fix f :: "nat \<Rightarrow> 'b"
  assume "\<forall>i. f i \<in> h ` A"
  then have "\<forall>i. \<exists>x. x \<in> A \<and> f i = h x" by (auto simp: image_def)
  from choice [OF this] obtain g
    where *: "\<forall>i. g i \<in> A \<and> f i = h (g i)" by blast
  show "good Q f"
  proof (rule ccontr)
    assume bad: "bad Q f"
    { fix i j :: nat
      assume "i < j"
      from bad have "\<not> Q (f i) (f j)" using \<open>i < j\<close> by (auto simp: good_def)
      with hom have "\<not> P (g i) (g j)" using * by auto }
    then have "bad P g" by (auto simp: good_def)
    with af and * show False by (auto simp: good_def almost_full_on_def)
  qed
qed

text \<open>
  The monomorphic preimage of an almost-full set is almost-full.
\<close>
lemma almost_full_on_mon:
  assumes mon: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> P x y = Q (h x) (h y)" "bij_betw h A B"
    and af: "almost_full_on Q B"
  shows "almost_full_on P A"
proof
  fix f :: "nat \<Rightarrow> 'a"
  assume *: "\<forall>i. f i \<in> A"
  then have **: "\<forall>i. (h \<circ> f) i \<in> B" using mon by (auto simp: bij_betw_def)
  show "good P f"
  proof (rule ccontr)
    assume bad: "bad P f"
    { fix i j :: nat
      assume "i < j"
      from bad have "\<not> P (f i) (f j)" using \<open>i < j\<close> by (auto simp: good_def)
      with mon have "\<not> Q (h (f i)) (h (f j))"
        using * by (auto simp: bij_betw_def inj_on_def) }
    then have "bad Q (h \<circ> f)" by (auto simp: good_def)
    with af and ** show False by (auto simp: good_def almost_full_on_def)
  qed
qed

text \<open>
  Every total and well-founded relation is almost-full.
\<close>
lemma total_on_and_wfp_on_imp_almost_full_on:
  assumes "total_on P A" and "wfp_on P A"
  shows "almost_full_on P\<^sup>=\<^sup>= A"
proof (rule ccontr)
  assume "\<not> almost_full_on P\<^sup>=\<^sup>= A"
  then obtain f :: "nat \<Rightarrow> 'a" where *: "\<And>i. f i \<in> A"
    and "\<forall>i j. i < j \<longrightarrow> \<not> P\<^sup>=\<^sup>= (f i) (f j)"
    unfolding almost_full_on_def by (auto dest: badE)
  with \<open>total_on P A\<close> have "\<forall>i j. i < j \<longrightarrow> P (f j) (f i)"
    unfolding total_on_def by blast
  then have "\<And>i. P (f (Suc i)) (f i)" by auto
  with \<open>wfp_on P A\<close> and * show False
    unfolding wfp_on_def by blast
qed

lemma Nil_imp_good_list_emb [simp]:
  assumes "f i = []"
  shows "good (list_emb P) f"
proof (rule ccontr)
  assume "bad (list_emb P) f"
  moreover have "(list_emb P) (f i) (f (Suc i))"
    unfolding assms by auto
  ultimately show False
    unfolding good_def by auto
qed

lemma ne_lists:
  assumes "xs \<noteq> []" and "xs \<in> lists A"
  shows "hd xs \<in> A" and "tl xs \<in> lists A"
  using assms by (case_tac [!] xs) simp_all

lemma list_emb_eq_length_induct [consumes 2, case_names Nil Cons]:
  assumes "length xs = length ys"
    and "list_emb P xs ys"
    and "Q [] []"
    and "\<And>x y xs ys. \<lbrakk>P x y; list_emb P xs ys; Q xs ys\<rbrakk> \<Longrightarrow> Q (x#xs) (y#ys)"
  shows "Q xs ys"
  using assms(2, 1, 3-) by (induct) (auto dest: list_emb_length)

lemma list_emb_eq_length_P:
  assumes "length xs = length ys"
    and "list_emb P xs ys"
  shows "\<forall>i<length xs. P (xs ! i) (ys ! i)"
using assms
proof (induct rule: list_emb_eq_length_induct)
  case (Cons x y xs ys)
  show ?case
  proof (intro allI impI)
    fix i assume "i < length (x # xs)"
    with Cons show "P ((x#xs)!i) ((y#ys)!i)"
      by (cases i) simp_all
  qed
qed simp

subsection \<open>Special Case: Finite Sets\<close>

text \<open>
  Every reflexive relation on a finite set is almost-full.
\<close>
lemma finite_almost_full_on:
  assumes finite: "finite A"
    and refl: "reflp_on P A"
  shows "almost_full_on P A"
proof
  fix f :: "nat \<Rightarrow> 'a"
  assume *: "\<forall>i. f i \<in> A"
  let ?I = "UNIV::nat set"
  have "f ` ?I \<subseteq> A" using * by auto
  with finite and finite_subset have 1: "finite (f ` ?I)" by blast
  have "infinite ?I" by auto
  from pigeonhole_infinite [OF this 1]
    obtain k where "infinite {j. f j = f k}" by auto
  then obtain l where "k < l" and "f l = f k"
    unfolding infinite_nat_iff_unbounded by auto
  then have "P (f k) (f l)" using refl and * by (auto simp: reflp_on_def)
  with \<open>k < l\<close> show "good P f" by (auto simp: good_def)
qed

lemma eq_almost_full_on_finite_set:
  assumes "finite A"
  shows "almost_full_on (=) A"
  using finite_almost_full_on [OF assms, of "(=)"]
  by (auto simp: reflp_on_def)

subsection \<open>Further Results\<close>

lemma af_trans_imp_wf:
  assumes "almost_full_on P A"
    and "transp_on P A"
  shows "wfp_on (strict P) A"
  using assms by (intro af_trans_extension_imp_wf)

lemma wf_and_no_antichain_imp_qo_extension_wf:
  assumes wf: "wfp_on (strict P) A"
    and anti: "\<not> (\<exists>f. antichain_on P f A)"
    and subrel: "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y"
    and qo: "qo_on Q A"
  shows "wfp_on (strict Q) A"
proof (rule ccontr)
  have "transp_on (strict Q) A"
    using qo unfolding qo_on_def transp_on_def by blast
  then have *: "transp_on ((strict Q)\<inverse>\<inverse>) A" by (rule transp_on_converse)
  assume "\<not> wfp_on (strict Q) A"
  then obtain f :: "nat \<Rightarrow> 'a" where A: "\<And>i. f i \<in> A"
    and "\<forall>i. strict Q (f (Suc i)) (f i)" unfolding wfp_on_def by blast+
  then have "\<forall>i. f i \<in> A \<and> ((strict Q)\<inverse>\<inverse>) (f i) (f (Suc i))" by auto
  from chain_transp_on_less [OF this *]
    have *: "\<And>i j. i < j \<Longrightarrow> \<not> P (f i) (f j)"
    using subrel and A by blast
  show False
  proof (cases)
    assume "\<exists>k. \<forall>i>k. \<exists>j>i. P (f j) (f i)"
    then obtain k where "\<forall>i>k. \<exists>j>i. P (f j) (f i)" by auto
    from subchain [of k _ f, OF this] obtain g
      where "\<And>i j. i < j \<Longrightarrow> g i < g j"
      and "\<And>i. P (f (g (Suc i))) (f (g i))" by auto
    with * have "\<And>i. strict P (f (g (Suc i))) (f (g i))" by blast
    with wf [unfolded wfp_on_def not_ex, THEN spec, of "\<lambda>i. f (g i)"] and A
      show False by fast
  next
    assume "\<not> (\<exists>k. \<forall>i>k. \<exists>j>i. P (f j) (f i))"
    then have "\<forall>k. \<exists>i>k. \<forall>j>i. \<not> P (f j) (f i)" by auto
    from choice [OF this] obtain h
      where "\<forall>k. h k > k"
      and **: "\<forall>k. (\<forall>j>h k. \<not> P (f j) (f (h k)))" by auto
    define \<phi> where [simp]: "\<phi> = (\<lambda>i. (h ^^ Suc i) 0)"
    have "\<And>i. \<phi> i < \<phi> (Suc i)"
      using \<open>\<forall>k. h k > k\<close> by (induct_tac i) auto
    then have mono: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j" by (metis lift_Suc_mono_less)
    then have "\<forall>i j. i < j \<longrightarrow> \<not> P (f (\<phi> j)) (f (\<phi> i))"
      using ** by auto
    with mono [THEN *]
      have "\<forall>i j. i < j \<longrightarrow> incomparable P (f (\<phi> j)) (f (\<phi> i))" by blast
    moreover have "\<exists>i j. i < j \<and> \<not> incomparable P (f (\<phi> i)) (f (\<phi> j))"
      using anti [unfolded not_ex, THEN spec, of "\<lambda>i. f (\<phi> i)"] and A by blast
    ultimately show False by blast
  qed
qed

lemma every_qo_extension_wf_imp_af:
  assumes ext: "\<forall>Q. (\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y) \<and>
    qo_on Q A \<longrightarrow> wfp_on (strict Q) A"
    and "qo_on P A"
  shows "almost_full_on P A"
proof
  from \<open>qo_on P A\<close>
    have refl: "reflp_on P A"
    and trans: "transp_on P A"
    by (auto intro: qo_on_imp_reflp_on qo_on_imp_transp_on)

  fix f :: "nat \<Rightarrow> 'a"
  assume "\<forall>i. f i \<in> A"
  then have A: "\<And>i. f i \<in> A" ..
  show "good P f"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have bad: "\<forall>i j. i < j \<longrightarrow> \<not> P (f i) (f j)" by (auto simp: good_def)
    then have *: "\<And>i j. P (f i) (f j) \<Longrightarrow> i \<ge> j" by (metis not_le_imp_less)

    define D where [simp]: "D = (\<lambda>x y. \<exists>i. x = f (Suc i) \<and> y = f i)"
    define P' where "P' = restrict_to P A"
    define Q where [simp]: "Q = (sup P' D)\<^sup>*\<^sup>*"

    have **: "\<And>i j. (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+ (f i) (f j) \<Longrightarrow> i > j"
    proof -
      fix i j
      assume "(D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+ (f i) (f j)"
      then show "i > j"
        apply (induct "f i" "f j" arbitrary: j)
        apply (insert A, auto dest!: * simp: P'_def reflp_on_restrict_to_rtranclp [OF refl trans])
        apply (metis "*" dual_order.strict_trans1 less_Suc_eq_le refl reflp_on_def)
        by (metis le_imp_less_Suc less_trans)
    qed

    have "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y" by (auto simp: P'_def)
    moreover have "qo_on Q A" by (auto simp: qo_on_def reflp_on_def transp_on_def)
    ultimately have "wfp_on (strict Q) A"
        using ext [THEN spec, of Q] by blast
    moreover have "\<forall>i. f i \<in> A \<and> strict Q (f (Suc i)) (f i)"
    proof
      fix i
      have "\<not> Q (f i) (f (Suc i))"
      proof
        assume "Q (f i) (f (Suc i))"
        then have "(sup P' D)\<^sup>*\<^sup>* (f i) (f (Suc i))" by auto
        moreover have "(sup P' D)\<^sup>*\<^sup>* = sup (P'\<^sup>*\<^sup>*) (P'\<^sup>*\<^sup>* OO (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+)"
        proof -
          have "\<And>A B. (A \<union> B)\<^sup>* = A\<^sup>* \<union> A\<^sup>* O (B O A\<^sup>*)\<^sup>+" by regexp
          from this [to_pred] show ?thesis by blast
        qed
        ultimately have "sup (P'\<^sup>*\<^sup>*) (P'\<^sup>*\<^sup>* OO (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+) (f i) (f (Suc i))" by simp
        then have "(P'\<^sup>*\<^sup>* OO (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+) (f i) (f (Suc i))" by auto
        then have "Suc i < i"
          using ** apply auto
          by (metis (lifting, mono_tags) less_le relcompp.relcompI tranclp_into_tranclp2)
        then show False by auto
      qed
      with A [of i] show "f i \<in> A \<and> strict Q (f (Suc i)) (f i)" by auto
    qed
    ultimately show False unfolding wfp_on_def by blast
  qed
qed

end