(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_39
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun count :: "Nat => Nat list => Nat" where
  "count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if x y z2 then S (count y ys) else count y ys)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) z = z"
| "t2 (S z2) z = S (t2 z2 z)"

theorem property0 :
  "((t2 (count n (cons2 y (nil2))) (count n xs)) = (count n (cons2 y xs)))"
  find_proof DInd
  apply (induct y arbitrary: n)
   apply auto
  done

theorem property0' :
  "((t2 (count n (cons2 y (nil2))) (count n xs)) = (count n (cons2 y xs)))"
  apply (induct y arbitrary: n)(*alpha-equivalent to "(induct arbitrary: n)"*)
   apply auto
  done

theorem property0'' :
  "((t2 (count n (cons2 y (nil2))) (count n xs)) = (count n (cons2 y xs)))"
  apply (induct xs arbitrary: n)(*not alpha-equivalent to "(induct arbitrary: n)"*)
   apply auto
  done

theorem property0''' :
  "((t2 (count n (cons2 y (nil2))) (count n xs)) = (count n (cons2 y xs)))"
  apply (induct rule: count.induct)
  nitpick
  oops

theorem property0'''' :
  "((t2 (count n (cons2 y (nil2))) (count n xs)) = (count n (cons2 y xs)))"
  apply (induct rule: t2.induct)
  nitpick
  oops

end


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory Order_Instances

imports
  Order_Morphism

begin

section {* Axclass matters *}

text {*

We introduce some useful mechanism for discussing orders at the type level.

*}

notation (zed)
  less_eq  ("\<opleT>") and
  less ("\<opltT>")

interpretation type_po: Order_Locale.partial_order "\<univ>-['a::order]" "\<opleT>-['a::order]"
  apply (insert default_po [of "\<univ>-['a::order]"])
  apply (simp add: default_order_def subset_order_def op2rel_def rel2op_def)
  done

interpretation type_order: Order_Locale.order "\<univ>-['a::linorder]" "\<opleT>-['a::linorder]"
  apply (insert default_order [of "\<univ>-['b::linorder]"])
  apply (simp add: default_order_def subset_order_def op2rel_def rel2op_def)
  done

lemma derefl_eq_less:
  "derefl \<opleT>-['a::order] = \<opltT>"
  apply (intro ext)
  apply (simp add: less_le)
  done

section {* Booleans *}

instance
  bool :: linorder
proof (intro_classes, unfold le_bool_def less_bool_def derefl_def)
  fix
    x::"\<bool>" and
    y::"\<bool>"
  show
      "(x \<Rightarrow> y) \<or> (y \<Rightarrow> x)"
    by (auto)
qed

section {* The unit type *}

instantiation
  unit :: linorder
begin

definition
  less_eq_unit_def: "\<opleT>-[unit] \<defs> (\<olambda> x y \<bullet> True)"

definition
  less_unit_def: "\<opltT>-[unit] \<defs> derefl \<opleT>"

instance
  by (intro_classes, auto simp add: less_eq_unit_def less_unit_def)

end

section {* Products *}

text {*

The natural order on a product of ordered sets
is the conjunction of the component orders.

Actually

*}

definition
  product_order :: "['a orderT, 'b orderT] \<rightarrow> ('a \<times> 'b) orderT"
where
  product_order_def: "product_order BS_leq_d_1 BS_leq_d_2 \<defs> (\<olambda> (x_d_1, x_d_2) (y_d_1, y_d_2) \<bullet> \<^infopa>{:x_d_1:}{:BS_leq_d_1:}{:y_d_1:} \<and> \<^infopa>{:x_d_2:}{:BS_leq_d_2:}{:y_d_2:})"

notation (zed)
  product_order ("\<^prodord>{:_:}{:_:}")

instantiation
  prod :: (ord, ord) ord
begin

definition
  less_eq_prod_def: "\<opleT>-[('a::ord) \<times> ('b::ord)] \<defs> \<^prodord>{:\<opleT>-['a]:}{:\<opleT>-['b]:}"

definition
  less_prod_def: "\<opltT>-[('a::ord) \<times> ('b::ord)] \<defs> derefl \<opleT>"

instance
  by (intro_classes)

end

lemma le_prod_conv:
    "(x_d_1, y_d_1) \<le> (x_d_2, y_d_2) \<Leftrightarrow> x_d_1 \<le> x_d_2 \<and> y_d_1 \<le> y_d_2"
  by (simp add: less_eq_prod_def product_order_def)

text {*

The product order preserves order properties of the component spaces.

*}

lemma product_poI:
  assumes
    a1: "\<^poset>{:X:}{:BS_leq_d_X:}" and a2: "\<^poset>{:Y:}{:BS_leq_d_Y:}"
  shows
    "\<^poset>{:(X \<times> Y):}{:(\<^prodord>{:BS_leq_d_X:}{:BS_leq_d_Y:}):}"
proof (rule partial_orderI)
  from a1 interpret poX: partial_order X BS_leq_d_X
    by (simp_all add: Order_Locale.partial_order_def)
  from a2 interpret poY: partial_order Y BS_leq_d_Y
    by (simp_all add: Order_Locale.partial_order_def)
{
  from a1 a2 have
        "X \<noteq> \<emptyset>" "Y \<noteq> \<emptyset>"
    by (simp_all add: partial_order_def')
  then show
        "X \<times> Y \<noteq> \<emptyset>"
    by (auto)
next
  from a1 a2 have
      "\<^oprel>{:BS_leq_d_X:} \<in> X \<zrel> X" "\<^oprel>{:BS_leq_d_Y:} \<in> Y \<zrel> Y"
    by (simp_all add: partial_order_def')
  then show
      "\<^oprel>{:\<^prodord>{:BS_leq_d_X:}{:BS_leq_d_Y:}:} \<in> (X \<times> Y) \<zrel> (X \<times> Y)"
    apply (msafe(fspace))
    apply (auto simp add: product_order_def op2rel_def eind_def)
    done
next
  fix x
  assume
    b1: "x \<in> X \<times> Y"
  with a1 a2 show
      "(\<^prodord>{:BS_leq_d_X:}{:BS_leq_d_Y:}) x x"
    by (auto simp add: product_order_def
      partial_order_conv reflexive_def reflexive_axioms_def)
next
  fix x y z
  assume
    b1: "x \<in> X \<times> Y \<and> y \<in> X \<times> Y \<and> z \<in> X \<times> Y" and
    b2: "(\<^prodord>{:BS_leq_d_X:}{:BS_leq_d_Y:}) x y" and
    b3: "(\<^prodord>{:BS_leq_d_X:}{:BS_leq_d_Y:}) y z"
  then show
      "(\<^prodord>{:BS_leq_d_X:}{:BS_leq_d_Y:}) x z"
    apply (auto simp add: product_order_def)
    apply (rule poX.trans [simplified, rule_format], mauto(inference))
    apply (rule poY.trans [simplified, rule_format], mauto(inference))
    done
(*J: note needed mauto(inference) here! *)
next
  fix x y
  assume
    b1: "x \<in> X \<times> Y \<and> y \<in> X \<times> Y" and
    b2: "(\<^prodord>{:BS_leq_d_X:}{:BS_leq_d_Y:}) x y" and
    b3: "(\<^prodord>{:BS_leq_d_X:}{:BS_leq_d_Y:}) y x"
  then show
      "x = y"
    apply (auto simp add: product_order_def)
    apply (rule poX.antisym [simplified, rule_format], msafe(inference))
    apply (rule poY.antisym [simplified, rule_format], msafe(inference))
    done
}
qed

lemma UNIV_prod:
    "\<univ>-['a \<times> 'b] = \<univ>-['a] \<times> \<univ>-['b]"
  by (auto)

instance
  prod :: (order, order) order
  apply (rule order_classI)
  apply (simp only: less_eq_prod_def UNIV_prod)
  apply (rule product_poI)
  apply (rule order_classD)
  apply (rule order_classD)
  apply (simp add: less_prod_def derefl_def)
  done

section {* Operator spaces *}

definition
  op_carrier :: "'b set \<rightarrow> ('a \<rightarrow> 'b) set"
where
  op_carrier_def: "op_carrier X \<defs> { f | range f \<subseteq> X }"

definition
  op_order :: "'b orderT \<rightarrow> ('a \<rightarrow> 'b) orderT"
where
  op_order_def: "op_order BS_leq \<defs> (\<olambda> f g \<bullet> (\<forall> a \<bullet> \<^infopa>{:f a:}{:BS_leq:}{:g a:}))"

syntax (zed)
  "_Order_Instances\<ZZ>op_carrier" :: "[type, logic] \<rightarrow> logic" ("\<^opset>{:_:}{:_:}")
  "_Order_Instances\<ZZ>op_order" :: "[type, logic] \<rightarrow> logic" ("\<^opord>{:_:}{:_:}")

translations
  "\<^opset>{:'a:}{:X:}" \<rightharpoonup> "(CONST Order_Instances.op_carrier X)::('a \<rightarrow> _) set"
  "\<^opord>{:'a:}{:BS_leq:}" \<rightharpoonup> "(CONST Order_Instances.op_order BS_leq)::('a \<rightarrow> _) orderT"

lemma (in partial_order) operator_poI:
    "\<^poset>{:\<^opset>{:'b:}{:X:}:}{:\<^opord>{:'b:}{:(op \<preceq>):}:}"
proof (rule partial_orderI)
  from non_empty show
      "\<^opset>{:'b:}{:X:} \<noteq> \<emptyset>"
    by (auto simp add: op_carrier_def)
next
  from rel show
      "\<^oprel>{:\<^opord>{:'b:}{:(op \<preceq>):}:} \<in> \<^opset>{:'b:}{:X:} \<zrel>\<^opset>{:'b:}{:X:}"
    by (auto simp add: rel_def op2rel_def op_carrier_def op_order_def eind_def)
next
  fix f
  assume
    "f \<in> \<^opset>{:'b:}{:X:}"
  with refl
  show
      "\<^infopa>{:f:}{:\<^opord>{:'b:}{:(op \<preceq>):}:}{:f:}"
    by (auto simp add: op_carrier_def op_order_def)
next
  fix f g h
  assume
      "f \<in> \<^opset>{:'b:}{:X:} \<and> g \<in> \<^opset>{:'b:}{:X:} \<and> h \<in> \<^opset>{:'b:}{:X:}" and
      "\<^infopa>{:f:}{:\<^opord>{:'b:}{:(op \<preceq>):}:}{:g:}" "\<^infopa>{:g:}{:\<^opord>{:'b:}{:(op \<preceq>):}:}{:h:}"
  then show
      "\<^infopa>{:f:}{:\<^opord>{:'b:}{:(op \<preceq>):}:}{:h:}"
    apply (auto simp add: op_carrier_def op_order_def)
    apply (rule transD)
    apply (auto)
    done
next
  fix f g
  assume
      "f \<in> \<^opset>{:'b:}{:X:} \<and> g \<in> \<^opset>{:'b:}{:X:}" and
      "\<^infopa>{:f:}{:\<^opord>{:'b:}{:(op \<preceq>):}:}{:g:}" "\<^infopa>{:g:}{:\<^opord>{:'b:}{:(op \<preceq>):}:}{:f:}"
  then show
      "f = g"
    apply (intro ext)
    apply (auto simp add: op_carrier_def op_order_def)
    apply (rule antisymD)
    apply (auto)
    done
qed

lemma UNIV_op:
    "\<univ>-['a \<rightarrow> 'b] = \<^opset>{:'a:}{:\<univ>-['b]:}"
  by (auto simp add: op_carrier_def)

lemma le_fun_conv:
    "f \<le> g \<Leftrightarrow> (\<forall> x \<bullet> f x \<le> g x)"
  by (auto simp add: le_fun_def op_order_def)

lemma fun_le:
    "f \<le> g \<turnstile> f x \<le> g x"
  by (auto simp add: le_fun_def op_order_def)

section {* Power sets *}

text {*

The power set of any set forms a partial order under the subset relation.

*}

definition
  pow_subset :: "'a set \<rightarrow> ['a set, 'a set] \<rightarrow> \<bool>"
where
  pow_subset_def: "pow_subset X A B \<defs> A \<subseteq> X \<and> B \<subseteq> X \<and> A \<subseteq> B"

syntax (xsymbols output)
  "_Order_Instances\<ZZ>pow_subset" :: "[logic, logic, logic] \<rightarrow> logic" ("_/ \<subseteq>\<^bsub>_\<^esub> _" [50, 1000, 51] 50)

syntax (zed)
  "_Order_Instances\<ZZ>pow_subset" :: "[logic, logic, logic] \<rightarrow> logic" ("_ \<^powsub>{:_:} _" [50, 1000, 51] 50)

translations
  "_Order_Instances\<ZZ>pow_subset A X B" \<rightleftharpoons> "(CONST Order_Instances.pow_subset) X A B"

interpretation pow_po: Order_Locale.partial_order "\<pset> X" "pow_subset X"
  apply (intro_locales)
  apply (simp_all add: carrier_def setrel_axioms_def reflexive_axioms_def transitive_axioms_def antisymmetric_axioms_def)
  apply (msafe(inference))
proof -
  show "\<pset> X \<noteq> \<emptyset>"
    by (auto)
next
  show "\<^oprel>{:pow_subset X:} \<in> \<pset> X \<zrel> \<pset> X"
    by (auto simp add: pow_subset_def op2rel_def rel_def)
next
  fix A
  assume
    b1: "A \<subseteq> X"
  then show
      "A \<^powsub>{:X:} A"
    by (auto simp add: pow_subset_def)
next
  fix A B C
  assume
    b1: "A \<subseteq> X" "B \<subseteq> X" "C \<subseteq> X" and
    b2: "A \<^powsub>{:X:} B" "B \<^powsub>{:X:} C"
  then show
      "A \<^powsub>{:X:} C"
    by (auto simp add: pow_subset_def)
next
  fix A B
  assume
    b1: "A \<subseteq> X" "B \<subseteq> X" and
    b2: "A \<^powsub>{:X:} B" "B \<^powsub>{:X:} A"
  then show
      "A = B"
    by (auto simp add: pow_subset_def)
qed

section {* Dual spaces *}

text {*

The ordering on the dual space is the reverse of the ordering on the
original space.

*}

definition
  dual_carrier :: "'a set \<rightarrow> 'a dual set"
where
  dual_carrier_def: "dual_carrier X \<defs> { x | x \<in> X \<bullet> \<^adual>{:x:} }"

definition
  dual_order :: "'a orderT \<rightarrow> 'a dual orderT"
where
  dual_order_def: "dual_order BS_leq \<defs> (\<olambda> a b \<bullet> \<^infopa>{:\<^rdual>{:b:}:}{:BS_leq:}{:\<^rdual>{:a:}:})"

notation (xsymbols output)
  dual_carrier ("_\<^isup>\<circ>" [999] 1000) and
  dual_order ("_\<^isup>\<circ>" [999] 1000)

notation (zed)
  dual_carrier ("_\<dualset>" [999] 1000) and
  dual_order ("_\<dualord>" [999] 1000)

lemma (in partial_order) dual_poI:
  "\<^poset>{:X\<dualset>:}{:(op \<preceq>)\<dualord>:}"
proof (rule partial_orderI)
  from non_empty show "X\<dualset> \<noteq> \<emptyset>"
    by (auto simp add: dual_carrier_def)
next
  show "\<^oprel>{:(op \<preceq>)\<dualord>:} \<in> X\<dualset> \<zrel> X\<dualset>"
    apply (auto dest: relD1 relD2 simp add: rel_def op2rel_def dual_carrier_def dual_order_def type_definition.Rep_inverse [TDINST dual])
    apply (intro exI conjI)
    apply (rule type_definition.Rep_inverse [TDINST dual, symmetric])
    apply (rule relD2)
    apply (assumption)
    apply (intro exI conjI)
    apply (rule type_definition.Rep_inverse [TDINST dual, symmetric])
    apply (rule relD1)
    apply (assumption)
    done
next
  fix a
  assume
      "a \<in> X\<dualset>"
  with refl show
      "\<^infopa>{:a:}{:(op \<preceq>)\<dualord>:}{:a:}"
    by (auto simp add: dual_carrier_def dual_order_def Abs_dual_inverse2)
next
  fix a b c
  assume "a \<in> X\<dualset> \<and> b \<in> X\<dualset> \<and> c \<in> X\<dualset>" and
    "\<^infopa>{:a:}{:(op \<preceq>)\<dualord>:}{:b:}" "\<^infopa>{:b:}{:(op \<preceq>)\<dualord>:}{:c:}"
  then show "\<^infopa>{:a:}{:(op \<preceq>)\<dualord>:}{:c:}"
    apply (auto simp add: dual_carrier_def dual_order_def Abs_dual_inverse2)
    apply (rule transD)
    apply (assumption+)
    done
next
  fix a b
  assume
      "a \<in> X\<dualset> \<and> b \<in> X\<dualset>" and
      "\<^infopa>{:a:}{:(op \<preceq>)\<dualord>:}{:b:}" "\<^infopa>{:b:}{:(op \<preceq>)\<dualord>:}{:a:}"
  then show
      "a = b"
    apply (auto simp add: dual_carrier_def dual_order_def Abs_dual_inverse2 Abs_dual_inject Abs_dual)
    apply (rule antisymD)
    apply (assumption+)
    done
qed

instantiation
  dual :: (ord) ord
begin

definition
  less_eq_dual_def: "\<opleT>-[('a::ord) dual] \<defs> (op \<le>)\<dualord>"

definition
  less_dual_def: "\<opltT>-[('a::ord) dual] \<defs> derefl (op \<le>)"

instance
  by (intro_classes)

end

lemma less_eq_dual_conv:
    "a \<le> b \<Leftrightarrow> \<^rdual>{:b:} \<le> \<^rdual>{:a:}"
  by (simp add: less_eq_dual_def dual_order_def)

text {*

The dual of an order is an order.

*}

lemma UNIV_dual:
    "\<univ> = \<univ>\<dualset>"
  apply (auto simp add: dual_carrier_def)
  apply (rule exI)
  apply (rule Rep_dual_inverse [symmetric])
  done

instance
  dual :: (order) order
  apply (rule order_classI)
  apply (simp add: less_eq_dual_def UNIV_dual)
  apply (rule partial_order.dual_poI)
  apply (rule order_classD)
  apply (simp add: less_dual_def derefl_def)
  done

text {*

The dual ordering induces the reverse order on the original type.

*}

lemma less_dual_conv:
    "(a::('a::order) dual) < b \<Leftrightarrow> \<^rdual>{:b:} < \<^rdual>{:a:}"
  by (auto simp add: less_dual_def less_eq_dual_conv dual_order_def derefl_def Abs_dual_inverse2 Abs_dual_inject Abs_dual order_less_le Rep_dual_inject)

lemma less_eq_dual_conv2:
    "\<^adual>{:(a::'a::order):} \<le> \<^adual>{:b:} \<Leftrightarrow> b \<le> a"
  by (simp add: less_eq_dual_def dual_order_def Abs_dual_inverse2)

lemma less_dual_conv2:
    "\<^adual>{:(a::'a::order):} < \<^adual>{:b:} \<Leftrightarrow> b < a"
  by (auto simp add: less_dual_def less_eq_dual_conv2 dual_order_def derefl_def Abs_dual_inverse2 Abs_dual_inject Abs_dual order_less_le)

definition
  dual_fun :: "('a \<rightarrow> 'b) \<rightarrow> ('a dual \<rightarrow> 'b)"
where
  dual_fun_def [simp]: "dual_fun \<defs> (\<olambda> f a \<bullet> (f \<^rdual>{:a:}))"

definition
  amono :: "(('a::order) \<rightarrow> ('b::order)) \<rightarrow> \<bool>"
where
  amono_def: "amono f \<defs> mono (dual_fun f)"

lemma amonoI:
  assumes
    a1: "(\<And> A B \<bullet> B \<le> A \<turnstile> f A \<le> f B)"
  shows
      "amono f"
  apply (unfold amono_def)
  apply (rule monoI)
  apply (simp add: le_fun_def ge_def)
  apply (rule a1)
  apply (simp add: less_eq_dual_def dual_order_def)
  done

lemma amonoI':
  assumes
    a1: "(\<And> A B \<bullet> B \<le> A \<turnstile> f A \<le> f B)"
  shows
      "amono f"
  apply (rule amonoI)
  apply (rule a1)
  apply (assumption)
  done

lemma amonoD:
  assumes
    a1: "amono f" and
    a2: "B \<le> A"
  shows
      "f A \<le> f B"
proof -
  from a2 have
    b1:"\<^adual>{:A:} \<le> \<^adual>{:B:}"
    by (simp add: less_eq_dual_def dual_order_def Abs_dual_inverse2)
  from monoD [OF a1 [unfolded amono_def] b1] show
      ?thesis
    by (simp add: Abs_dual_inverse2)
qed

lemma amonoD':
  assumes
    a1: "amono f" and
    a2: "B \<le> A"
  shows
      "f A \<le> f B"
  apply (rule amonoD [OF a1])
  using a1 a2
  apply (simp)
  done

lemma amono_mono_comp:
  assumes
    a1: "amono f" and
    a2: "mono g"
  shows
      "amono (f \<circ> g)"
  using a1 a2
  by (auto intro!: amonoI dest!: monoD amonoD)

lemma mono_amono_comp:
  assumes
    a1: "mono f" and
    a2: "amono g"
  shows
      "amono (f \<circ> g)"
  using a1 a2
  by (auto intro!: amonoI dest!: monoD amonoD)

lemma amono_amono_comp:
  assumes
    a1: "amono f" and
    a2: "amono g"
  shows
      "mono (f \<circ> g)"
  using a1 a2
  by (auto intro!: monoI dest!: amonoD)

lemma (in order) dual_orderI:
    "\<^order>{:X\<dualset>:}{:(op \<preceq>)\<dualord>:}"
  apply (simp add: order_conva)
  apply (msafe(inference))
  apply (rule dual_poI)
  apply (simp add: dual_order_def dual_carrier_def)
  apply (msafe(inference))
  apply (simp add: Abs_dual_inverse2)
  apply (rule linD)
  apply (msafe(inference))
  done

instance
  dual :: (linorder) linorder
  apply (rule linorder_classI)
  apply (simp add: less_eq_dual_def UNIV_dual)
  apply (rule order.dual_orderI)
  apply (rule linorder_classD)
  apply (simp add: less_dual_def derefl_def)
  done

section {* The identity order *}

lemma id_poI:
    "X \<noteq> \<emptyset> \<turnstile> \<^poset>{:X:}{:(\<^relop>{:(\<zid> X):}):}"
  apply (insert id_in_relI [of X])
  apply (rule partial_orderI)
  apply (simp_all add:  op2rel_def rel2op_def rel_id_def eind_def)
  done

definition
  extend_ord :: "['a set, ['a, 'a] \<rightarrow> \<bool>] \<rightarrow>  (['a, 'a] \<rightarrow> \<bool>)"
where
  extend_ord_def: "extend_ord Y BS_leq \<defs> \<^relop>{:\<^oprel>{:BS_leq:} \<union> \<zid> Y:}"

notation (zed)
  extend_ord ("\<extord>{:_:}{:_:}")

lemma (in partial_order) extend_ord_conv:
  assumes
    a1: "X \<subseteq> Y"
  shows
      "\<^infop>{:x:}{:\<extord>{:Y:}{:(op \<preceq>):}:}{:y:}
      \<Leftrightarrow> x \<in> Y \<and> x \<notin> X \<and> y = x \<or> x \<in> X \<and> y \<in> X \<and> \<^infop>{:x:}{:(op \<preceq>):}{:y:}"
proof -
  from rel reflD
  show
      ?thesis
    apply (msafe(fspace))
    apply (simp add: extend_ord_def op2rel_def rel2op_def rel_id_def)
    apply (auto simp add: eind_def)
    done
qed

lemma id_ext_poI:
  assumes
    a1: "\<^poset>{:X:}{:BS_leq:}" and
    a2: "X \<subseteq> Y"
  shows
      "\<^poset>{:Y:}{:\<extord>{:Y:}{:BS_leq:}:}"
proof -
  from a1 interpret partial_order "X" "BS_leq"
    by (simp_all add: Order_Locale.partial_order_def)
  show
      ?thesis
  proof (rule partial_orderI)
    from non_empty a2 show
        "Y \<noteq> \<emptyset>"
      by (auto)
  next
    from rel a2 show
        "\<^oprel>{:\<extord>{:Y:}{:BS_leq:}:} \<in> Y \<zrel> Y"
      apply (msafe(fspace))
      apply (auto simp add: extend_ord_def op2rel_def rel2op_def rel_id_def eind_def)
      done
  next
    fix y
    assume
      b1: "y \<in> Y"
    with a2 show
        "\<^infop>{:y:}{:\<extord>{:Y:}{:BS_leq:}:}{:y:}"
      by (auto simp add: extend_ord_def op2rel_def rel2op_def rel_id_def eind_def)
  next
    fix x y z
    assume
      b1: "x \<in> Y \<and> y \<in> Y \<and> z \<in> Y" and
      b2: "\<^infop>{:x:}{:\<extord>{:Y:}{:BS_leq:}:}{:y:}" and
      b3: "\<^infop>{:y:}{:\<extord>{:Y:}{:BS_leq:}:}{:z:}"
    with a2 show
        "\<^infop>{:x:}{:\<extord>{:Y:}{:BS_leq:}:}{:z:}"
      apply (auto simp add: extend_ord_conv)
      apply (rule transD, assumption+)
      apply (rule transD, assumption+)
      done
  next
    fix x y
    assume
      b1: "x \<in> Y \<and> y \<in> Y" and
      b2: "\<^infop>{:x:}{:\<extord>{:Y:}{:BS_leq:}:}{:y:}" and
      b3: "\<^infop>{:y:}{:\<extord>{:Y:}{:BS_leq:}:}{:x:}"
     with a2 show
        "x = y"
      apply (auto simp add: extend_ord_conv)
      apply (rule antisymD, assumption+)
      done
  qed
qed

section {* Subset order on relational graphs *}

definition
  rel_subset :: "['a set, 'b set ] \<rightarrow> ['a \<leftrightarrow> 'b, 'a \<leftrightarrow> 'b] \<rightarrow> \<bool>"
where
  rel_subset_def: "rel_subset X Y \<defs> pow_subset (X \<times> Y)"

syntax (xsymbols output)
  "_Order_Instances\<ZZ>rel_subset" :: "[logic, logic, logic, logic] \<rightarrow> logic" ("_ \<subseteq>\<^bsub>_ \<leftrightarrow> _\<^esub> _" [50, 1000, 1000, 51] 50)

syntax (zed)
  "_Order_Instances\<ZZ>rel_subset" :: "[logic, logic, logic, logic] \<rightarrow> logic" ("_ \<^relsub>{:_:}{:_:} _")

translations
  "_Order_Instances\<ZZ>rel_subset r X Y s" \<rightleftharpoons> "CONST Order_Instances.rel_subset X Y r s"

interpretation rel_po: Order_Locale.partial_order "X \<zrel> Y" "rel_subset X Y"
  apply (intro_locales)
  apply (simp_all add: rel_subset_def rel_def)
  apply (simp_all only:
          carrier_def setrel_axioms_def reflexive_axioms_def
          transitive_axioms_def antisymmetric_axioms_def)
  apply (msafe(inference))
  apply (rule pow_po.non_empty)
  apply (rule pow_po.rel)
  apply (rule pow_po.reflD, assumption)
  apply (rule pow_po.transD, assumption+)
  apply (rule pow_po.antisymD, assumption+)
  done

section {* Result order on functional graphs *}

definition
  res_le :: "[['b, 'b] \<rightarrow> \<bool>, 'a \<leftrightarrow> 'b, 'a \<leftrightarrow> 'b] \<rightarrow> \<bool>"
where
  res_le_def: "res_le r f g \<defs> functional f \<and> functional g \<and> (\<forall> x | x \<in> \<zdom> g \<bullet> x \<in> \<zdom> f \<and> \<^infop>{:f\<cdot>x:}{:r:}{:g\<cdot>x:})"

definition
  def_res_le :: "['a \<leftrightarrow> ('b::ord), 'a \<leftrightarrow> 'b] \<rightarrow> \<bool>"
where
  def_res_le_def: "def_res_le f g \<defs> res_le (op \<le>) f g"

notation (zed)
  res_le ("\<^resle>{:_:}") and
  def_res_le ("_ \<dresle> _" [50,51] 50)

lemma def_res_le_conv:
    "f \<dresle> g \<Leftrightarrow> functional f \<and> functional g \<and> (\<forall> x | x \<in> \<zdom> g \<bullet> x \<in> \<zdom> f \<and> f\<cdot>x \<le> g\<cdot>x)"
  by (simp add: def_res_le_def res_le_def)

lemma res_le_def':
    "\<^infop>{:f:}{:\<^resle>{:r:}:}{:g:}
    \<Leftrightarrow> functional f \<and> functional g \<and>
        (\<forall> x y | (x \<mapsto> y) \<in> g \<bullet> (\<exists> y' | (x \<mapsto> y') \<in> f \<bullet> \<^infop>{:y':}{:r:}{:y:}))"
  apply (unfold res_le_def)
  apply (mauto(wind))
  proof-
    fix x
    assume
       b1: "functional f" and
       b2: "functional g"
    have "(x \<in> \<zdom> g \<Rightarrow> x \<in> \<zdom> f \<and> r (f\<cdot>x) (g\<cdot>x)) = (\<forall> y \<bullet>  (x \<mapsto> y) \<in> g \<Rightarrow> x \<in> \<zdom> f \<and> r (f\<cdot>x) (g\<cdot>x))"
    by (simp add: Domain_iff)
    also have
    "... = (\<forall> y \<bullet> (x, y) \<in> g \<Rightarrow> (\<exists> y' \<bullet> (x, y') \<in> f \<and> r y' y))"
      apply (mauto(wind))
      apply (simp add: Domain_iff)
      apply (subst ex_simps')
      apply (mauto(wind))
    proof -
      fix y y'
      assume
        b3: "(x \<mapsto> y) \<in> g" and
        b4: "(x \<mapsto> y') \<in> f"
      with b1 b2 show
          "\<^infop>{:f\<cdot>x:}{:r:}{:g\<cdot>x:} \<Leftrightarrow> \<^infop>{:y':}{:r:}{:y:}"
        by (simp add: functional_beta)
    qed
    finally show
      "(x \<in> \<zdom> g
        \<Rightarrow> x \<in> \<zdom> f \<and> r (f\<cdot>x) (g\<cdot>x)) = (\<forall> y \<bullet> (x \<mapsto> y) \<in> g \<Rightarrow> (\<exists> y' \<bullet> r y' y \<and> (x \<mapsto> y') \<in> f))"
    by (auto)
  qed

lemma functional_poI:
  assumes
    a1: "\<^poset>{:\<univ>:}{:BS_leq:}"
  shows
      "\<^poset>{:{f::'a \<leftrightarrow> 'b | functional f}:}{:\<^resle>{:BS_leq:}:}"
  apply (rule partial_orderI)
  apply (simp_all)
proof (msafe(inference))
  show
      "(\<exists> f::'a \<leftrightarrow> 'b \<bullet> functional f)"
    apply (witness "\<glambda> (y::'a) \<bullet> \<arb>-['b]")
    apply (auto simp add: glambda_functional glambda_ran)
    done
next
  show
      "\<^oprel>{:\<^resle>{:BS_leq:}:} \<in> {f | functional f} \<zrel> {f | functional f}"
    apply (msafe(fspace))
    apply (auto simp add: op2rel_def res_le_def)
    done
next
  fix f::"'a \<leftrightarrow> 'b"
  assume
    b1: "functional f"
  with a1 show
      "\<^infop>{:f:}{:\<^resle>{:BS_leq:}:}{:f:}"
    by (simp add: res_le_def partial_order_def')
next
  fix f::"'a \<leftrightarrow> 'b"
  assume
    b1: "functional f"
  fix g::"'a \<leftrightarrow> 'b"
  assume
    b2: "functional g"
  fix h::"'a \<leftrightarrow> 'b"
  assume
    b3: "functional h"
  assume
    b4: "\<^infop>{:f:}{:\<^resle>{:BS_leq:}:}{:g:}" and
    b5: "\<^infop>{:g:}{:\<^resle>{:BS_leq:}:}{:h:}"
  show
      "\<^infop>{:f:}{:\<^resle>{:BS_leq:}:}{:h:}"
    apply (simp add: res_le_def b1 b3)
    apply (msafe(inference))
  proof -
    fix x
    assume
      c1: "x \<in> \<zdom> h"
    with b4 b5 show
        "x \<in> \<zdom> f"
      by (simp add: res_le_def)
    from a1 c1 b4 b5 show
        "\<^infop>{:f\<cdot>x:}{:BS_leq:}{:h\<cdot>x:}"
      apply (intro transitive.transD [of "\<univ>" "BS_leq" "f\<cdot>x" "g\<cdot>x" "h\<cdot>x"])
      apply (auto simp add: partial_order_conv res_le_def)
      done
  qed
next
  fix f::"'a \<leftrightarrow> 'b"
  assume
    b1: "functional f"
  fix g::"'a \<leftrightarrow> 'b"
  assume
    b2: "functional g"
  assume
    b3: "\<^infop>{:f:}{:\<^resle>{:BS_leq:}:}{:g:}" and
    b4: "\<^infop>{:g:}{:\<^resle>{:BS_leq:}:}{:f:}"
  show
      "f = g"
    apply (rule functional_eqI)
    apply (rule b1, rule b2)
  proof -
    from b3 b4 show
      c1: "\<zdom> f = \<zdom> g"
      by (auto simp add: res_le_def)
    fix x
    assume
        "x \<in> \<zdom> f"
    with a1 b3 b4 c1 show
        "f\<cdot>x = g\<cdot>x"
      apply (intro antisymmetric.antisymD [of "\<univ>" "BS_leq" "f\<cdot>x" "g\<cdot>x"])
      apply (simp_all add: partial_order_conv res_le_def)
      done
  qed
qed

lemma pfun_poI:
  fixes
    X::"'a set" and
    Y::"'b set"
  assumes
    a1: "\<^poset>{:Y:}{:BS_leq:}"
  shows
      "\<^poset>{:(X \<zpfun> Y):}{:(\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}):}"
proof -
  from a1 interpret a1: partial_order "Y" "BS_leq"
    by (simp_all add: Order_Locale.partial_order_def)
  show
      ?thesis
  proof (rule partial_orderI, msafe(inference))
    show
        "X \<zpfun> Y \<noteq> \<emptyset>"
      apply (simp add: fun_space_defs)
      apply (witness "\<emptyset>-['a \<times> 'b]")
      apply (auto)
      done
  next
    show
        "\<^oprel>{:\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}:} \<in> (X \<zpfun> Y) \<zrel> (X \<zpfun> Y)"
      apply (msafe(fspace))
      apply (auto simp add: op2rel_def rel2op_def subset_order_def subset_def)
      done
  next
    fix f
    assume
      c1: "f \<in> X \<zpfun> Y"
    then show
        "\<^infop>{:f:}{:\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}:}{:f:}"
      apply (simp add: res_le_def op2rel_def rel2op_def subset_order_def)
      apply (msafe(inference))
      apply (msafe(fspace))
    proof -
      fix x
      assume
          "x \<in> \<zdom> f"
      with c1 have
          "f\<cdot>x \<in> Y" by (auto)
      with a1.refl show
          "\<^infop>{:f\<cdot>x:}{:BS_leq:}{:f\<cdot>x:}"
        by (auto)
    qed
  next
    fix f g h
    assume
      c1: "f \<in> X \<zpfun> Y" " g \<in> X \<zpfun> Y" "h \<in> X \<zpfun> Y" and
      c2: "\<^infop>{:f:}{:\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}:}{:g:}" and
      c3: "\<^infop>{:g:}{:\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}:}{:h:}"
    from c1 show
        "\<^infop>{:f:}{:\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}:}{:h:}"
      apply (simp add: res_le_def op2rel_def rel2op_def subset_order_def)
      apply (msafe(inference))
      apply (msafe(fspace))
    proof -
      fix x
      assume
        d1: "x \<in> \<zdom> h"
      with c3 have
        d2: "x \<in> \<zdom> g"
        by (simp add: res_le_def op2rel_def rel2op_def subset_order_def)
      with c2 show
        d3: "x \<in> \<zdom> f"
        by (simp add: res_le_def op2rel_def rel2op_def subset_order_def)
      from c2 d2 d3 have
        d4: "\<^infop>{:f\<cdot>x:}{:BS_leq:}{:g\<cdot>x:}"
        by (auto simp add: res_le_def op2rel_def rel2op_def subset_order_def)
      from c3 d1 d2 have
        d5: "\<^infop>{:g\<cdot>x:}{:BS_leq:}{:h\<cdot>x:}"
        by (auto simp add: res_le_def op2rel_def rel2op_def subset_order_def)
      from d4 d5 show
          "\<^infop>{:f\<cdot>x:}{:BS_leq:}{:h\<cdot>x:}"
        by (rule a1.transD)
    qed
  next
    fix f g
    assume
      c1: "f \<in> X \<zpfun> Y" "g \<in> X \<zpfun> Y" and
      c2: "\<^infop>{:f:}{:\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}:}{:g:}" and
      c3: "\<^infop>{:g:}{:\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}:}{:f:}"
    show
        "f = g"
      apply (rule functional_eqI)
      apply (rule c1 [THEN dr_pfunD1])
      apply (rule c1 [THEN dr_pfunD1])
    proof -
      from c2 c3 show
        d1: "\<zdom> f = \<zdom> g"
        by (auto simp add: res_le_def op2rel_def rel2op_def subset_order_def)
      fix x
      assume
        d2: "x \<in> \<zdom> f"
      from d2 c2 d1 have
        d3: "\<^infop>{:f\<cdot>x:}{:BS_leq:}{:g\<cdot>x:}"
        by (auto simp add: res_le_def op2rel_def rel2op_def subset_order_def)
      from d2 c3 d1 have
        d4: "\<^infop>{:g\<cdot>x:}{:BS_leq:}{:f\<cdot>x:}"
        by (auto simp add: res_le_def op2rel_def rel2op_def subset_order_def)
      from d3 d4 show
          "f\<cdot>x = g\<cdot>x"
        by (rule a1.antisymD)
    qed
  qed
qed

text {*

The result order specialises nicely to total functions.

*}

definition
  tfun_order :: "['a set, 'b set, ['b, 'b] \<rightarrow> \<bool>] \<rightarrow> (['a \<leftrightarrow> 'b, 'a \<leftrightarrow> 'b] \<rightarrow> \<bool>)"
where
  tfun_order_def:
    "tfun_order X Y BS_leq_d_Y
    \<defs> (\<olambda> f g \<bullet>
        \<lch> f, g \<chIn> X \<ztfun> Y \<rch> \<and>
        (\<forall> x | x \<in> X \<bullet> \<^infopa>{:f\<cdot>x:}{:BS_leq_d_Y:}{:g\<cdot>x:}))"

lemma tfun_res_le:
    "tfun_order X Y BS_leq = \<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<ztfun> Y):}"
  apply (auto simp add: tfun_order_def op2rel_def rel2op_def subset_order_def fun_eq_def res_le_def)
  apply (mauto(fspace))
  apply (auto)
  done

lemma tfun_poI:
  assumes
    a1: "\<^poset>{:Y:}{:BS_leq:}"
  shows
      "\<^poset>{:(X \<ztfun> Y):}{:(tfun_order X Y BS_leq):}"
proof -
  from a1 interpret a1: Order_Locale.partial_order "Y" "BS_leq"
    by (simp_all add: Order_Locale.partial_order_def)
  from a1 interpret
    b1: Order_Locale.partial_order "X \<zpfun> Y" "\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}"
    by (rule pfun_poI)
  interpret
    b2: Order_Locale.sub_partial_order
          "X \<zpfun> Y" "\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}" "X \<ztfun> Y"
  proof (unfold_locales)
    from a1.non_empty obtain y where
        "y \<in> Y"
      by (auto)
    then show
        "X \<ztfun> Y \<noteq> \<emptyset>"
      apply (simp add: nempty_conv)
      apply (witness "(\<glambda> x | x \<in> X \<bullet> y)")
      apply (rule glambda_tfun)
      apply (auto)
      done
    show "X \<ztfun> Y \<subseteq> X \<zpfun> Y"
      by (auto)
  qed
  have
      "\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<ztfun> Y):}
      = \<^subord>{:\<^subord>{:\<^resle>{:BS_leq:}:}{:(X \<zpfun> Y):}:}{:(X \<ztfun> Y):}"
    by (auto simp add: op2rel_def rel2op_def subset_order_def fun_eq_def)
  then show
      ?thesis
    apply (simp add: tfun_res_le)
    apply (rule b2.Y_poI)
    done
qed

section {* Strings *}

fun
  find_ind_raw :: "'a \<rightarrow> \<nat> \<rightarrow> 'a list \<rightarrow> \<nat> option"
where
  "find_ind_raw a n (x#xs) = \<if> a = x \<then> Some n \<else> find_ind_raw a (n+1) xs \<fi>"
| "find_ind_raw a n [] = None"

definition
  find_ind :: "'a \<rightarrow> 'a list \<rightarrow> \<nat> option"
where
  "find_ind a = find_ind_raw a 0"

lemma find_ind_raw_bound1:
  "(\<forall> n m \<bullet> find_ind_raw x n X = Some m \<Rightarrow> n \<le> m)"
  apply (induct "X")
  apply (simp)
proof -
  fix
    a X
  assume
    b1 [rule_format]: "(\<forall> n m \<bullet> find_ind_raw x n X = Some m \<Rightarrow> n \<le> m)"
  show
    "(\<forall> n m \<bullet> find_ind_raw x n (a#X) = Some m \<Rightarrow> n \<le> m)"
    apply (cases "x = a")
    apply (simp)
    apply (auto)
    apply (rule order_trans)
    apply (rule less_imp_le [OF lessI])
    apply (rule b1)
    apply (assumption)
    done
qed

lemma find_ind_raw_bound2:
  "(\<forall> n m \<bullet> Some m = find_ind_raw x n X \<Rightarrow> n \<le> m)"
  by (auto intro!: find_ind_raw_bound1 [rule_format])

lemmas
  find_ind_raw_bound = find_ind_raw_bound1 [rule_format] find_ind_raw_bound2 [rule_format]

lemma find_ind_raw_dom [rule_format]:
  "(\<forall> n \<bullet> find_ind_raw x n X \<noteq> None \<Leftrightarrow> x \<in> set X)"
  apply (induct "X")
  apply (auto)
  done

lemma find_ind_dom:
  "find_ind x X \<noteq> None \<Leftrightarrow> x \<in> set X"
  by (simp only: find_ind_def find_ind_raw_dom)

lemma find_ind_raw_inj [rule_format]:
  "(\<forall> n x | x \<in> set X \<bullet> (\<forall> y | y \<in> set X \<bullet> find_ind_raw x n X = find_ind_raw y n X \<Leftrightarrow> x = y))"
  apply (induct "X")
  apply (simp)
  apply (mauto(inference))
proof -
  fix
    a X n x y
  assume
    b1: "(\<forall> n x | x \<in> set X \<bullet> (\<forall> y | y \<in> set X \<bullet> find_ind_raw x n X = find_ind_raw y n X \<Leftrightarrow> x = y))" and
    b2: "x \<in> set (a#X)" "y \<in> set (a#X)" and
    b3: "find_ind_raw x n (a # X) = find_ind_raw y n (a # X)"
  from b3 show
    "x = y"
    apply (multi_cases "x = a" "y = a")
    using b1 [rule_format] b2
    apply (auto dest: find_ind_raw_bound)
    done
qed

context
  enum

begin

definition
  enum_ord :: "'a \<rightarrow> 'a \<rightarrow> \<bool>"
where
  "enum_ord x y \<Leftrightarrow> the (find_ind x enum) \<le> the (find_ind y enum)"

lemma enum_ord_linear:
  "\<^order>{:\<univ>-['a]:}{:enum_ord:}"
  apply (intro orderI)
  apply (auto simp add: enum_ord_def find_ind_def rel_def)
proof -
  fix
    x y
  assume
    b1: "the (find_ind_raw y 0 enum) = the (find_ind_raw x 0 enum)"
  with in_enum [of "x"] in_enum [of "y"] have
    b2: "(find_ind_raw y 0 enum) = (find_ind_raw x 0 enum)"
    by (auto simp add: find_ind_dom [symmetric] find_ind_def)
  show
    "x = y"
    apply (rule find_ind_raw_inj [THEN iffD1])
    using in_enum [of "x"] in_enum [of "y"] b2 [symmetric]
    apply (auto)
    done
qed

end

instantiation
  nibble :: ord

begin

definition
  less_eq_nibble_def: "\<opleT>-[nibble] \<defs> enum_ord"

definition
  less_nibble_def: "\<opltT>-[nibble] \<defs> derefl \<opleT>"

instance
  by (intro_classes)

end

instance
  nibble :: linorder
  apply (rule linorder_classI)
  apply (auto simp add: enum_ord_linear less_eq_nibble_def less_nibble_def)
  done

instantiation char :: ord

begin

definition
  less_eq_char_def: "\<opleT>-[char] \<defs> enum_ord"

definition
  less_char_def: "\<opltT>-[char] \<defs> derefl \<opleT>"

instance
  by (intro_classes)

end

instance
  char :: linorder
  apply (rule linorder_classI)
  apply (auto simp add: enum_ord_linear less_eq_char_def less_char_def)
  done

context
  ord

begin

fun
  lex_ord :: "['a list, 'a list] \<rightarrow> \<bool>"
where
  "lex_ord [] [] \<Leftrightarrow> \<True>"
| "lex_ord [] (y#Y) \<Leftrightarrow> \<True>"
| "lex_ord (x#X) [] \<Leftrightarrow> \<False>"
| "lex_ord (x#X) (y#Y) \<Leftrightarrow> x < y \<or> x = y \<and> lex_ord X Y"

end

lemma lex_ord_poI:
  "\<^poset>{:\<univ>-[(('a::order) list)]:}{:lex_ord:}"
  apply (intro partial_order_intros)
  apply (auto simp add: rel_def)
proof -
  fix
    x :: "'a list"
  show
    "lex_ord x x"
    apply (induct "x")
    apply (auto)
    done
next
  fix
    x :: "'a list" and
    y :: "'a list"
  assume
    b1: "lex_ord x y" "lex_ord y x"
  have
    "(\<forall> y \<bullet> lex_ord x y \<and> lex_ord y x \<Rightarrow> x = y)" (is "(\<forall> y \<bullet> ?P x y)")
    apply (induct "x")
    apply (intro allI)
  proof -
    fix
      y :: "'a list"
    show
      "lex_ord [] y \<and> lex_ord y [] \<Rightarrow> [] = y"
      apply (cases "y")
      apply (auto)
      done
  next
    apply_end (rule allI)
    fix
      a :: "'a" and
      x :: "'a list" and
      y :: "'a list"
    assume
      c1 [rule_format]: "(\<forall> y \<bullet> lex_ord x y \<and> lex_ord y x \<Rightarrow> x = y)"
    show
      "lex_ord (a#x) y \<and> lex_ord y (a#x) \<Rightarrow> (a#x) = y"
      apply (cases "y")
      apply (simp)
      apply (msafe(inference))
      apply (auto intro: c1 simp add: less_le)
      done
  qed
  with b1 show
    "x = y"
    by (auto)
next
  fix
    x :: "'a list" and
    y :: "'a list" and
    z :: "'a list"
  assume
    b1: "lex_ord x y" "lex_ord y z"
  have
    "(\<forall> y z \<bullet> lex_ord x y \<and> lex_ord y z \<Rightarrow> lex_ord x z)" (is "(\<forall> y z \<bullet> ?P x y z)")
    apply (induct "x")
    apply (intro allI)
  proof -
    fix
      y :: "'a list" and
      z :: "'a list"
    show
      "?P [] y z"
      apply (multi_cases "y" "z")
      apply (auto)
      done
  next
    apply_end (intro allI)
    fix
      a :: "'a" and
      x :: "'a list" and
      y :: "'a list" and
      z :: "'a list"
    assume
      c1 [rule_format]: "(\<forall> y z \<bullet> ?P x y z)"
    show
      "?P (a#x) y z"
      apply (multi_cases "y" "z")
      apply (auto)
      apply (mauto(inference) melim!: notE mintro: less_trans c1)
      done
  qed
  with b1 show
    "lex_ord x z"
    by (auto)
qed

lemma lex_ord_orderI:
  "\<^order>{:\<univ>-[('a::linorder) list]:}{:lex_ord:}"
  apply (rule partial_order.orderIa)
  apply (rule lex_ord_poI)
  apply (simp)
proof -
  fix
    x :: "'a list" and
    y :: "'a list"
  have
    "(\<forall> y \<bullet> lex_ord x y \<or> lex_ord y x)"
    apply (induct "x")
    apply (rule allI)
  proof -
    fix
      y :: "'a list"
    show
      "lex_ord [] y \<or> lex_ord y []"
      apply (cases "y")
      apply (auto)
      done
  next
    apply_end (rule allI)
    fix
      a :: "'a" and
      x :: "'a list" and
      y :: "'a list"
    assume
      c1 [rule_format]: "(\<forall> y \<bullet> lex_ord x y \<or> lex_ord y x)"
    show
      "lex_ord (a#x) y \<or> lex_ord y (a#x)"
      apply (cases "y")
      apply (simp)
      using c1
      apply (auto)
      done
  qed
  then show
    "lex_ord x y \<or> lex_ord y x"
    by (auto)
qed

instantiation String.literal :: ord

begin

definition
  less_eq_literal_def: "\<opleT>-[String.literal] = induce_ord explode lex_ord"

definition
  less_literal_def: "\<opltT>-[String.literal] = derefl \<opleT>"

instance
  by (intro_classes)

end

instance
  String.literal :: linorder
proof (rule epi_typedefs_linorder_classI [OF _ lex_ord_orderI less_eq_literal_def less_literal_def])
   interpret
     litTD: type_definition explode STR \<univ>
     by (rule type_definition_literal)
   show
     "epi_type_definition explode STR"
     apply (rule epi_type_definition.intro)
     apply (rule surjI)
     apply (auto intro: litTD.Abs_inverse litTD.Rep_inverse)
     done
qed

end


theory Chapter9_1
imports "HOL-IMP.Types"
begin

text\<open>
\section*{Chapter 9}

\exercise
Reformulate the inductive predicates \ @{prop"\<Gamma> \<turnstile> a : \<tau>"},
\ @{prop"\<Gamma> \<turnstile> (b::bexp)"} \
and \ \mbox{@{prop"\<Gamma> \<turnstile> (c::com)"}} \ as three recursive functions
\<close>

fun atype :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty option" where
  "atype _ (Ic i) = Some Ity" |
  "atype _ (Rc r) = Some Rty" |
  "atype \<Gamma> (V x) = Some (\<Gamma> x)" |
  "atype \<Gamma> (Plus a1 a2) = (if
    atype \<Gamma> a1 = atype \<Gamma> a2
    then (atype \<Gamma> a1)
    else None)"

fun bok :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" where
  "bok _ (Bc v) = True" |
  "bok \<Gamma> (Not b) = bok \<Gamma> b" |
  "bok \<Gamma> (And b1 b2) \<longleftrightarrow> bok \<Gamma> b1 \<and> bok \<Gamma> b2" |
  "bok \<Gamma> (Less a1 a2) \<longleftrightarrow> atype \<Gamma> a1 = atype \<Gamma> a2 \<and> atype \<Gamma> a1 \<noteq> None"

fun cok :: "tyenv \<Rightarrow> com \<Rightarrow> bool" where
  "cok \<Gamma> SKIP = True" |
  "cok \<Gamma> (x ::= a) \<longleftrightarrow> atype \<Gamma> a = Some (\<Gamma> x)" |
  "cok \<Gamma> (c1;; c2) \<longleftrightarrow> cok \<Gamma> c1 \<and> cok \<Gamma> c2" |
  "cok \<Gamma> (IF b THEN c1 ELSE c2) \<longleftrightarrow> bok \<Gamma> b \<and> cok \<Gamma> c1 \<and> cok \<Gamma> c2" |
  "cok \<Gamma> (WHILE b DO c) \<longleftrightarrow> bok \<Gamma> b \<and> cok \<Gamma> c"

text\<open> and prove \<close>

lemma atyping_atype: "(\<Gamma> \<turnstile> a : \<tau>) = (atype \<Gamma> a = Some \<tau>)"
  by (induct a) auto

lemma btyping_bok: "(\<Gamma> \<turnstile> b) = bok \<Gamma> b"
  by (induct b) (auto iff add: atyping_atype)

lemma ctyping_cok: "(\<Gamma> \<turnstile> c) = cok \<Gamma> c"
  by (induct c) (auto iff add: atyping_atype btyping_bok)

text\<open>
\endexercise

\exercise
Modify the evaluation and typing of @{typ aexp} by allowing @{typ int}s to be coerced
to @{typ real}s with the predefined coercion function
\noquotes{@{term[source] "real_of_int :: int \<Rightarrow> real"}} where necessary.
Now every @{typ aexp} has a value. Define an evaluation function:
\<close>

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (Ic i) _ = Iv i" |
  "aval (Rc r) _ = Rv r" |
  "aval (V x) s = s x" |
  "aval (Plus a1 a2) s = (case
    (aval a1 s, aval a2 s) of
    (Iv i1, Iv i2) \<Rightarrow> Iv (i1 + i2) |
    (Iv i, Rv r) \<Rightarrow> Rv (i + r) |
    (Rv r, Iv i) \<Rightarrow> Rv (r + i) |
    (Rv r1, Rv r2) \<Rightarrow> Rv (r1 + r2))"

text\<open>
Similarly, every @{typ aexp} has a type.
Define a function that computes the type of an @{typ aexp}
\<close>

fun atyp :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty" where
  "atyp _ (Ic i) = Ity" |
  "atyp _ (Rc r) = Rty" |
  "atyp \<Gamma> (V x) = \<Gamma> x" |
  "atyp \<Gamma> (Plus a1 a2) = (if
    atyp \<Gamma> a1 = Ity
    then atyp \<Gamma> a2
    else Rty)"

text\<open> and prove that it computes the correct type: \<close>

lemma  "\<Gamma> \<turnstile> s \<Longrightarrow> atyp \<Gamma> a = type (aval a s)"
  unfolding styping_def
  by (induct a) (auto split: val.split)

text\<open>
Note that Isabelle inserts the coercion @{typ real} automatically.
For example, if you write @{term "Rv(i+r)"} where @{text"i :: int"} and
@{text "r :: real"} then it becomes @{term "Rv(real i + x)"}.
\endexercise
\bigskip

For the following two exercises copy theory @{short_theory "Types"} and modify it as required.

\begin{exercise}
Add a @{text REPEAT} loop (see Exercise~\ref{exe:IMP:REPEAT}) to the typed version of IMP
and update the type soundness proof.
\end{exercise}

\begin{exercise}
Modify the typed version of IMP as follows. Values are now either integers or booleans.
Thus variables can have boolean values too. Merge the two expressions types
@{typ aexp} and @{typ bexp} into one new type @{text exp} of expressions
that has the constructors of both types (of course without real constants).
Combine @{const taval} and @{const tbval} into one evaluation predicate
@{text "eval :: exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"}. Similarly combine the two typing predicates
into one: @{text "\<Gamma> \<turnstile> e : \<tau>"} where @{text "e :: exp"} and the IMP-type @{text \<tau>} can
be one of @{text Ity} or @{text Bty}.
Adjust the small-step semantics and the type soundness proof.
\end{exercise}
\<close>

end


(*
  File:         PAC_More_Poly.thy
  Author:       Mathias Fleury, Daniela Kaufmann, JKU
  Maintainer:   Mathias Fleury, JKU
*)
theory PAC_More_Poly
  imports "HOL-Library.Poly_Mapping" "HOL-Algebra.Polynomials" "Polynomials.MPoly_Type_Class"
  "HOL-Algebra.Module" "HOL-Library.Countable_Set"
begin

section \<open>Overview\<close>

text \<open>

One solution to check circuit of multipliers is to use algebraic method, like producing proofs on
polynomials.  We are here interested in checking PAC proofs on the Boolean ring. The idea is the
following: each variable represents an input or the output of a gate and we want to prove the
bitwise multiplication of the input bits yields the output, namely the bitwise representation of the
multiplication of the input (modulo \<^term>\<open>(2::nat)^n\<close> where \<^term>\<open>n::nat\<close> is the number of bits of the
circuit).

Algebraic proof systems typically reason over polynomials in a ring $\set K[X]$,
where the variables $X$ represent Boolean values.
The aim of an algebraic proof is to derive whether a polynomial $f$ can be derived from a given set of polynomials
$G = \{g_1,\dots,g_l\} \subseteq \set K[X]$ together with the Boolean value constraints
$B(X) = \{x^2_i-x_i \mid x_i \in X\}$. In algebraic terms this means to show that the polynomial \<^latex>\<open>\(f \in \langle G \cup B(X)\rangle\)\<close>.

In our setting we set $\set K = \set Z$ and we treat the Boolean value constraints implicitly, i.e.,
we consider proofs in the ring \<^latex>\<open>\(\set Z[X]/\langle B(X)\rangle\)\<close> to admit shorter proofs

The checker takes as input 3 files:
  \<^enum> an input file containing all polynomials that are initially present;
  \<^enum> a target (or specification) polynomial ;
  \<^enum> a ``proof'' file to check that contains the proof in PAC format that shows that the specification
  is in the ideal generated by the polynomials present initially.

Each step of the proof is either an addition of two polynomials previously derived, a multiplication
from a previously derived polynomial and an arbitrary polynomial, and the deletion a derived
polynomial.

One restriction on the proofs compared to generic PAC proofs is that \<^term>\<open>(x::nat)^2 = x\<close> in the
Boolean ring we are considering.

The checker can produce two outputs: valid (meaning that each derived polynomial in the proof has
been correctly derived and the specification polynomial was also derived at some point [either in
the proof or as input]) or invalid (without proven information what went wrong).

The development is organised as follows:
  \<^item> \<^file>\<open>PAC_Specification.thy\<close> (this file) contains the specification as described above on ideals
  without any peculiarities on the PAC proof format
  \<^item> \<^file>\<open>PAC_Checker_Specification.thy\<close> specialises to the PAC format and enters the nondeterminism
  monad to prepare the subsequent refinements.
  \<^item> \<^file>\<open>PAC_Checker.thy\<close> contains the refined version where polynomials are represented as lists.
  \<^item> \<^file>\<open>PAC_Checker_Synthesis.thy\<close> contains the efficient implementation with imperative data
  structure like a hash set.
  \<^item> \<^file>\<open>PAC_Checker_MLton.thy\<close> contains the code generation and the command to compile the file with
  the ML compiler MLton.

Here is an example of a proof and an input file (taken from the appendix of our FMCAD
paper~\<^cite>\<open>"KaufmannFleuryBiere-FMCAD20"\<close>, available at \<^url>\<open>http://fmv.jku.at/pacheck_pasteque\<close>):
\<^verbatim>\<open>
<res.input>      <res.proof>
 1 x*y;           3  = fz, -z+1;
 2 y*z-y-z+1;     4  *  3,  y-1, -fz*y+fz-y*z+y+z-1;
                  5  +  2,    4, -fz*y+fz;
                  2  d;
                  4  d;
<res.target>      6  *  1,   fz, fz*x*y;
 -x*z+x;          1  d;
                  7  *  5,    x, -fz*x*y+fz*x;
                  8  +  6,    7, fz*x;
                  9  *  3,    x, -fz*x-x*z+x;
                 10  +  8,    9, -x*z+x;
\<close>

Each line starts with a number that is used to index the (conclusion) polynomial. In the proof,
there are four kind of steps:
  \<^enum> \<^verbatim>\<open>3 = fz, -z+1;\<close> is an extension that introduces a new variable (in this case \<^verbatim>\<open>fz\<close>);
  \<^enum> \<^verbatim>\<open>4  *  3,  y-1, -fz*y+fz-y*z+y+z-1;\<close> is a multiplication of the existing polynomial with
  index 3 by the arbitrary polynomial \<^verbatim>\<open>y-1\<close> and generates the new polynomial
  \<^verbatim>\<open>-fz*y+fz-y*z+y+z-1\<close> with index 4;
  \<^enum> \<^verbatim>\<open>5  +  2,    4, -fz*y+fz;\<close> is an addition of the existing polynomials with
  index 2 and 4 and generates the new polynomial \<^verbatim>\<open>-fz*y+fz\<close> with index 5;
  \<^enum> \<^verbatim>\<open>1  d;\<close> deletes the polynomial with index 1 and it cannot be reused in subsequent steps.

Remark that unlike DRAT checker, we do forward checking and check every derived polynomial. The
target polynomial can also be part of the input file.
\<close>

section \<open>Libraries\<close>

subsection \<open>More Polynomials\<close>

text \<open>

  Here are more theorems on polynomials. Most of these facts are
  extremely trivial and should probably be generalised and moved to
  the Isabelle distribution.
\<close>

lemma Const\<^sub>0_add:
  \<open>Const\<^sub>0 (a + b) = Const\<^sub>0 a + Const\<^sub>0 b\<close>
  by transfer
   (simp add: Const\<^sub>0_def single_add)

lemma Const_mult:
  \<open>Const (a * b) = Const a * Const b\<close>
  by transfer (simp add: Const\<^sub>0_def times_monomial_monomial)

lemma Const\<^sub>0_mult:
  \<open>Const\<^sub>0 (a * b) = Const\<^sub>0 a * Const\<^sub>0 b\<close>
  by transfer (simp add: Const\<^sub>0_def times_monomial_monomial)

lemma Const0[simp]:
  \<open>Const 0 = 0\<close>
  by transfer (simp add: Const\<^sub>0_def)

lemma (in -) Const_uminus[simp]:
  \<open>Const (-n) = - Const n\<close>
  by transfer (auto simp: Const\<^sub>0_def monomial_uminus)

lemma Const_add:
  \<open>Const (a + b) = Const a + Const b\<close>
  by transfer (simp add: Const\<^sub>0_def single_add)

instance mpoly :: (comm_semiring_1) comm_semiring_1
  by standard

lemma degree_uminus[simp]:
  \<open>degree (-A) x' = degree A x'\<close>
  by (auto simp: degree_def uminus_mpoly.rep_eq)

lemma degree_sum_notin:
  \<open>x' \<notin> vars B \<Longrightarrow> degree (A + B) x' = degree A x'\<close>
  apply (auto simp: degree_def)
  apply (rule arg_cong[of _ _ Max])
  apply standard+
  apply (auto simp: plus_mpoly.rep_eq UN_I UnE image_iff in_keys_iff subsetD vars_def lookup_add
    dest: keys_add intro: in_keys_plusI1 cong: ball_cong_simp)
  done

lemma degree_notin_vars:
  \<open>x \<notin> (vars B) \<Longrightarrow> degree (B :: 'a :: {monoid_add} mpoly) x = 0\<close>
  using degree_sum_notin[of x B 0]
  by auto

lemma not_in_vars_coeff0:
  \<open>x \<notin> vars p \<Longrightarrow> MPoly_Type.coeff p (monomial (Suc 0) x) = 0\<close>
  by (subst not_not[symmetric], subst coeff_keys[symmetric])
    (auto simp: vars_def)

lemma keys_add':
  "p \<in> keys (f + g) \<Longrightarrow> p \<in> keys f \<union> keys g"
  by transfer auto

lemma keys_mapping_sum_add:
  \<open>finite A \<Longrightarrow> keys (mapping_of (\<Sum>v \<in> A. f v)) \<subseteq> \<Union>(keys ` mapping_of ` f ` UNIV)\<close>
  by (induction A rule: finite_induct)
   (auto simp add: zero_mpoly.rep_eq plus_mpoly.rep_eq
     keys_plus_ninv_comm_monoid_add dest: keys_add')

lemma vars_sum_vars_union:
  fixes f :: \<open>int mpoly \<Rightarrow> int mpoly\<close>
  assumes \<open>finite {v. f v \<noteq> 0}\<close>
  shows \<open>vars (\<Sum>v | f v \<noteq> 0. f v * v) \<subseteq> \<Union>(vars ` {v. f v \<noteq> 0}) \<union> \<Union>(vars ` f ` {v. f v \<noteq> 0})\<close>
    (is \<open>?A \<subseteq> ?B\<close>)
proof
  fix p
  assume \<open>p \<in> vars (\<Sum>v | f v \<noteq> 0. f v * v)\<close>
  then obtain x where \<open>x \<in> keys (mapping_of (\<Sum>v | f v \<noteq> 0. f v * v))\<close> and
    p: \<open>p \<in> keys x\<close>
    by (auto simp: vars_def times_mpoly.rep_eq simp del: keys_mult)
  then have \<open>x \<in> (\<Union>x. keys (mapping_of (f x) * mapping_of x))\<close>
    using keys_mapping_sum_add[of \<open>{v. f v \<noteq> 0}\<close> \<open>\<lambda>x. f x * x\<close>] assms
    by (auto simp: vars_def times_mpoly.rep_eq)
  then have \<open>x \<in> (\<Union>x. {a+b| a b. a \<in> keys (mapping_of (f x)) \<and> b \<in> keys (mapping_of x)})\<close>
    using Union_mono[OF ] keys_mult by fast
  then show \<open>p \<in> ?B\<close>
    using p by (force simp: vars_def zero_mpoly.rep_eq dest!: keys_add')
qed

lemma vars_in_right_only:
  "x \<in> vars q \<Longrightarrow> x \<notin> vars p \<Longrightarrow> x \<in> vars (p+q)"
  unfolding  vars_def keys_def plus_mpoly.rep_eq lookup_plus_fun
  apply clarify
  subgoal for xa
    by (auto simp: vars_def keys_def plus_mpoly.rep_eq
      lookup_plus_fun intro!: exI[of _ xa] dest!: spec[of _ xa])
  done

lemma [simp]:
  \<open>vars 0 = {}\<close>
  by (simp add: vars_def zero_mpoly.rep_eq)

lemma vars_Un_nointer:
  \<open>keys (mapping_of p) \<inter>  keys (mapping_of q) = {} \<Longrightarrow> vars (p + q) = vars p \<union> vars q\<close>
  by (auto simp: vars_def plus_mpoly.rep_eq simp flip: More_MPoly_Type.keys_add dest!: keys_add')

lemmas [simp] = zero_mpoly.rep_eq

lemma polynomial_sum_monoms:
  fixes p :: \<open>'a :: {comm_monoid_add,cancel_comm_monoid_add} mpoly\<close>
  shows
     \<open>p = (\<Sum>x\<in>keys (mapping_of p). MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
     \<open>keys (mapping_of p) \<subseteq> I \<Longrightarrow> finite I \<Longrightarrow> p = (\<Sum>x\<in>I. MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
proof -
  define J where \<open>J \<equiv> keys (mapping_of p)\<close>
  define a where \<open>a x \<equiv> coeff p x\<close> for x
  have \<open>finite (keys (mapping_of p))\<close>
    by auto
  have \<open>p = (\<Sum>x\<in>I. MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
    if \<open>finite I\<close> and \<open>keys (mapping_of p) \<subseteq> I\<close>
    for I
    using that
    unfolding a_def
   proof (induction I arbitrary: p rule: finite_induct)
      case empty
      then have \<open>p = 0\<close>
        using empty coeff_all_0 coeff_keys by blast
      then show ?case using empty by (auto simp: zero_mpoly.rep_eq)
    next
      case (insert x F) note fin = this(1) and xF = this(2) and IH = this(3) and
        incl = this(4)
      let ?p = \<open>p - MPoly_Type.monom x (MPoly_Type.coeff p x)\<close>
      have H: \<open>\<And>xa. x \<notin> F \<Longrightarrow> xa \<in> F \<Longrightarrow>
        MPoly_Type.monom xa (MPoly_Type.coeff (p - MPoly_Type.monom x (MPoly_Type.coeff p x)) xa) =
         MPoly_Type.monom xa (MPoly_Type.coeff p xa)\<close>
        by (metis (mono_tags, opaque_lifting) add_diff_cancel_right' remove_term_coeff
          remove_term_sum when_def)
      have \<open>?p = (\<Sum>xa\<in>F. MPoly_Type.monom xa (MPoly_Type.coeff ?p xa))\<close>
        apply (rule IH)
        using incl apply -
        by standard (smt (verit) Diff_iff Diff_insert_absorb add_diff_cancel_right'
          remove_term_keys remove_term_sum subsetD xF)
      also have \<open>... = (\<Sum>xa\<in>F. MPoly_Type.monom xa (MPoly_Type.coeff p xa))\<close>
        by (use xF in \<open>auto intro!: sum.cong simp: H\<close>)
      finally show ?case
        apply (subst (asm) remove_term_sum[of x p, symmetric])
        apply (subst remove_term_sum[of x p, symmetric])
        using xF fin by (auto simp: ac_simps)
    qed
    from this[of I] this[of J] show
     \<open>p = (\<Sum>x\<in>keys (mapping_of p). MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
     \<open>keys (mapping_of p) \<subseteq> I \<Longrightarrow> finite I \<Longrightarrow> p = (\<Sum>x\<in>I. MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
     by (auto simp: J_def)
qed

lemma vars_mult_monom:
  fixes p :: \<open>int mpoly\<close>
  shows \<open>vars (p * (monom (monomial (Suc 0) x') 1)) = (if p = 0 then {} else insert x' (vars p))\<close>
proof -

  let ?v = \<open>monom (monomial (Suc 0) x') 1\<close>
  have
    p: \<open>p = (\<Sum>x\<in>keys (mapping_of p). MPoly_Type.monom x (MPoly_Type.coeff p x))\<close> (is \<open>_ = (\<Sum>x \<in> ?I. ?f x)\<close>)
    using polynomial_sum_monoms(1)[of p] .
  have pv: \<open>p * ?v = (\<Sum>x \<in> ?I. ?f x * ?v)\<close>
    by (subst p) (auto simp:  field_simps sum_distrib_left)
  define I where \<open>I \<equiv> ?I\<close>
  have in_keysD: \<open>x \<in> keys (mapping_of (\<Sum>x\<in>I. MPoly_Type.monom x (h x)))  \<Longrightarrow> x \<in> I\<close>
   if \<open>finite I\<close> for I and h :: \<open>_ \<Rightarrow> int\<close> and x
   using that by (induction rule: finite_induct)
    (force simp: monom.rep_eq empty_iff insert_iff keys_single coeff_monom
     simp: coeff_keys simp flip: coeff_add
     simp del: coeff_add)+
  have in_keys: \<open>keys (mapping_of (\<Sum>x\<in>I. MPoly_Type.monom x (h x))) = (\<Union>x \<in> I. (if h x  = 0 then {} else {x}))\<close>
   if \<open>finite I\<close> for I and h :: \<open>_ \<Rightarrow> int\<close> and x
   supply in_keysD[dest]
   using that by (induction rule: finite_induct)
     (auto simp: plus_mpoly.rep_eq MPoly_Type_Class.keys_plus_eqI)

  have H[simp]: \<open>vars ((\<Sum>x\<in>I. MPoly_Type.monom x (h x))) = (\<Union>x\<in>I. (if h x  = 0 then {} else keys x))\<close>
   if \<open>finite I\<close> for I and h :: \<open>_ \<Rightarrow> int\<close>
   using that by (auto simp: vars_def in_keys)

  have sums: \<open>(\<Sum>x\<in>I.
        MPoly_Type.monom (x + a') (c x)) =
       (\<Sum>x\<in> (\<lambda>x. x + a') ` I.
        MPoly_Type.monom x (c (x - a')))\<close>
    if \<open>finite I\<close> for I a' c q
    using that apply (induction rule: finite_induct)
    subgoal by auto
    subgoal
      unfolding image_insert by (subst sum.insert) auto
    done
  have non_zero_keysEx: \<open>p \<noteq> 0 \<Longrightarrow> \<exists>a. a \<in> keys (mapping_of p)\<close> for p :: \<open>int mpoly\<close>
     using mapping_of_inject by (fastforce simp add: ex_in_conv)
  have \<open>finite I\<close> \<open>keys (mapping_of p) \<subseteq> I\<close>
    unfolding I_def by auto
  then show
    \<open>vars (p * (monom (monomial (Suc 0) x') 1)) = (if p = 0 then {} else insert x' (vars p))\<close>
    apply (subst pv, subst I_def[symmetric], subst mult_monom)
    apply (auto simp: mult_monom sums I_def)
    using Poly_Mapping.keys_add vars_def apply fastforce
     apply (auto dest!: non_zero_keysEx)
     apply (rule_tac x= \<open>a + monomial (Suc 0) x'\<close> in bexI)
      apply (auto simp: coeff_keys)
     apply (simp add: in_keys_iff lookup_add)
    apply (auto simp: vars_def)
    apply (rule_tac x= \<open>xa + monomial (Suc 0) x'\<close> in bexI)
     apply (auto simp: coeff_keys)
    apply (simp add: in_keys_iff lookup_add)
    done
qed

  term \<open>(x', u, lookup u x', A)\<close>
lemma in_mapping_mult_single:
  \<open>x \<in> (\<lambda>x. lookup x x') ` keys (A * (Var\<^sub>0 x' :: (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b :: {monoid_mult,zero_neq_one,semiring_0})) \<longleftrightarrow>
  x > 0 \<and> x - 1 \<in> (\<lambda>x. lookup x x') ` keys (A)\<close>
  apply (standard+; clarify)
  subgoal
    apply (auto  elim!: in_keys_timesE simp: lookup_add)
    apply (auto simp: keys_def lookup_times_monomial_right Var\<^sub>0_def lookup_single image_iff)
    done
  subgoal
    apply (auto  elim!: in_keys_timesE simp: lookup_add)
    apply (auto simp: keys_def lookup_times_monomial_right Var\<^sub>0_def lookup_single image_iff)
    done
  subgoal for  xa
    apply (auto  elim!: in_keys_timesE simp: lookup_add)
    apply (auto simp: keys_def lookup_times_monomial_right Var\<^sub>0_def lookup_single image_iff lookup_add
      intro!: exI[of _ \<open>xa + Poly_Mapping.single x' 1\<close>])
    done
  done

lemma Max_Suc_Suc_Max:
  \<open>finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> Max (insert 0 (Suc ` A)) =
    Suc (Max (insert 0 A))\<close>
  by (induction rule: finite_induct)
   (auto simp: hom_Max_commute)

lemma [simp]:
  \<open>keys (Var\<^sub>0 x' :: ('a \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b :: {zero_neq_one}) = {Poly_Mapping.single x' 1}\<close>
  by (auto simp: Var\<^sub>0_def)

lemma degree_mult_Var:
  \<open>degree (A * Var x') x' = (if A = 0 then 0 else Suc (degree A x'))\<close> for A :: \<open>int mpoly\<close>
proof -
  have [simp]: \<open>A \<noteq> 0 \<Longrightarrow>
    Max (insert 0 ((\<lambda>x. Suc (lookup x x')) ` keys (mapping_of A))) =
    Max (insert (Suc 0) ((\<lambda>x. Suc (lookup x x')) ` keys (mapping_of A)))\<close>
    unfolding image_image[of Suc \<open>\<lambda>x. lookup x x'\<close>, symmetric] image_insert[symmetric]
    by (subst Max_Suc_Suc_Max, use mapping_of_inject in fastforce, use mapping_of_inject in fastforce)+
      (simp add: Max.hom_commute)
  have \<open>A \<noteq> 0 \<Longrightarrow>
    Max (insert 0
    ((\<lambda>x. lookup x x') `
    keys (mapping_of A * mapping_of (Var x')))) =
    Suc (Max (insert 0 ((\<lambda>m. lookup m x') ` keys (mapping_of A))))\<close>
    by (subst arg_cong[of _ \<open>insert 0
      (Suc ` ((\<lambda>x. lookup x x') ` keys (mapping_of A)))\<close> Max])
     (auto simp: image_image Var.rep_eq lookup_plus_fun in_mapping_mult_single
      hom_Max_commute Max_Suc_Suc_Max
      elim!: in_keys_timesE  split: if_splits)
  then show ?thesis
    by (auto simp: degree_def times_mpoly.rep_eq
      intro!: arg_cong[of _ \<open>insert 0
      (Suc ` ((\<lambda>x. lookup x x') ` keys (mapping_of A)))\<close> Max])
qed

lemma degree_mult_Var':
  \<open>degree (Var x' * A) x' = (if A = 0 then 0 else Suc (degree A x'))\<close> for A :: \<open>int mpoly\<close>
 by (simp add: degree_mult_Var semiring_normalization_rules(7))

lemma degree_times_le:
  \<open>degree (A * B) x \<le> degree A x + degree B x\<close>
  by (auto simp: degree_def times_mpoly.rep_eq
       max_def lookup_add add_mono
    dest!: set_rev_mp[OF _ Poly_Mapping.keys_add]
    elim!: in_keys_timesE)

lemma monomial_inj:
  "monomial c s = monomial (d::'b::zero_neq_one) t \<longleftrightarrow> (c = 0 \<and> d = 0) \<or> (c = d \<and> s = t)"
  by (fastforce simp add: monomial_inj Poly_Mapping.single_def
    poly_mapping.Abs_poly_mapping_inject when_def fun_eq_iff
    cong: if_cong
    split: if_splits)

lemma MPoly_monomial_power':
  \<open>MPoly (monomial 1 x') ^ (n+1) =  MPoly (monomial (1) (((\<lambda>x. x + x') ^^ n) x'))\<close>
  by (induction n)
   (auto simp: times_mpoly.abs_eq mult_single ac_simps)

lemma MPoly_monomial_power:
  \<open>n > 0 \<Longrightarrow> MPoly (monomial 1 x') ^ (n) =  MPoly (monomial (1) (((\<lambda>x. x + x') ^^ (n - 1)) x'))\<close>
  using MPoly_monomial_power'[of _ \<open>n-1\<close>]
  by auto

lemma vars_uminus[simp]:
  \<open>vars (-p) = vars p\<close>
  by (auto simp: vars_def uminus_mpoly.rep_eq)

lemma coeff_uminus[simp]:
  \<open>MPoly_Type.coeff (-p) x = -MPoly_Type.coeff p x\<close>
  by (auto simp: coeff_def uminus_mpoly.rep_eq)

definition decrease_key::"'a \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::{monoid_add, minus,one}) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b)" where
  "decrease_key k0 f = Abs_poly_mapping (\<lambda>k. if k = k0 \<and> lookup f k \<noteq> 0 then lookup f k - 1 else lookup f k)"

lemma remove_key_lookup:
  "lookup (decrease_key k0 f) k = (if k = k0 \<and> lookup f k \<noteq> 0 then lookup f k - 1 else lookup f k)"
  unfolding decrease_key_def using finite_subset apply simp
  apply (subst lookup_Abs_poly_mapping)
  apply (auto intro: finite_subset[of _ \<open>{x. lookup f x \<noteq> 0}\<close>])
  apply (subst lookup_Abs_poly_mapping)
  apply (auto intro: finite_subset[of _ \<open>{x. lookup f x \<noteq> 0}\<close>])
  done

lemma polynomial_split_on_var:
  fixes p :: \<open>'a :: {comm_monoid_add,cancel_comm_monoid_add,semiring_0,comm_semiring_1} mpoly\<close>
  obtains q r where
    \<open>p = monom (monomial (Suc 0) x') 1 * q + r\<close> and
    \<open>x' \<notin> vars r\<close>
proof -
  have [simp]: \<open>{x \<in> keys (mapping_of p). x' \<in> keys x} \<union>
        {x \<in> keys (mapping_of p). x' \<notin> keys x} = keys (mapping_of p)\<close>
    by auto
  have
    \<open>p = (\<Sum>x\<in>keys (mapping_of p). MPoly_Type.monom x (MPoly_Type.coeff p x))\<close> (is \<open>_ = (\<Sum>x \<in> ?I. ?f x)\<close>)
    using polynomial_sum_monoms(1)[of p] .
  also have \<open>... = (\<Sum>x\<in> {x \<in> ?I. x' \<in> keys x}. ?f x) + (\<Sum>x\<in> {x \<in> ?I. x' \<notin> keys x}. ?f x)\<close> (is \<open>_ = ?pX + ?qX\<close>)
    by (subst comm_monoid_add_class.sum.union_disjoint[symmetric]) auto
  finally have 1: \<open>p = ?pX + ?qX\<close> .
  have H: \<open>0 < lookup x x' \<Longrightarrow> (\<lambda>k. (if x' = k then Suc 0 else 0) +
          (if k = x' \<and> 0 < lookup x k then lookup x k - 1
           else lookup x k)) = lookup x\<close> for x x'
    by auto
  have [simp]: \<open>finite {x. 0 < (Suc 0 when x' = x)}\<close> for x' :: nat and x
    by (smt (verit) bounded_nat_set_is_finite lessI mem_Collect_eq neq0_conv when_cong when_neq_zero)
  have H: \<open>x' \<in> keys x \<Longrightarrow> monomial (Suc 0) x' + Abs_poly_mapping (\<lambda>k. if k = x' \<and> 0 < lookup x k then lookup x k - 1 else lookup x k) = x\<close>
    for x and x' :: nat
    apply (simp only: keys_def single.abs_eq)
    apply (subst plus_poly_mapping.abs_eq)
    by (auto simp: eq_onp_def when_def H
        intro!: finite_subset[of \<open>{xa. (xa = x' \<and> 0 < lookup x xa \<longrightarrow> Suc 0 < lookup x x') \<and>
           (xa \<noteq> x' \<longrightarrow> 0 < lookup x xa)}\<close> \<open>{xa. 0 < lookup x xa}\<close>])

  have [simp]: \<open>x' \<in> keys x \<Longrightarrow>
        MPoly_Type.monom (monomial (Suc 0) x' + decrease_key x' x) n =
        MPoly_Type.monom x n\<close> for x n and x'
    apply (subst mpoly.mapping_of_inject[symmetric], subst poly_mapping.lookup_inject[symmetric])
    unfolding mapping_of_monom lookup_single
    apply (auto intro!: ext simp: decrease_key_def when_def H)
    done
  have pX: \<open>?pX = monom (monomial (Suc 0) x') 1 * (\<Sum>x\<in> {x \<in> ?I. x' \<in> keys x}. MPoly_Type.monom (decrease_key x' x) (MPoly_Type.coeff p x))\<close>
    (is \<open>_ = _ * ?pX'\<close>)
    by (subst sum_distrib_left, subst mult_monom)
     (auto intro!: sum.cong)
  have \<open>x' \<notin> vars ?qX\<close>
    using vars_setsum[of \<open>{x. x \<in> keys (mapping_of p) \<and> x' \<notin> keys x}\<close> \<open>?f\<close>]
    by (auto dest!: vars_monom_subset[unfolded subset_eq Ball_def, rule_format])
  then show ?thesis
    using that[of ?pX' ?qX]
    unfolding pX[symmetric] 1[symmetric]
    by blast
qed

lemma polynomial_split_on_var2:
  fixes p :: \<open>int mpoly\<close>
  assumes \<open>x' \<notin> vars s\<close>
  obtains q r where
    \<open>p = (monom (monomial (Suc 0) x') 1 - s) * q + r\<close> and
    \<open>x' \<notin> vars r\<close>
proof -
  have eq[simp]: \<open>monom (monomial (Suc 0) x') 1 = Var x'\<close>
    by (simp add: Var.abs_eq Var\<^sub>0_def monom.abs_eq)
  have \<open>\<forall>m \<le> n. \<forall>P::int mpoly. degree P x' < m \<longrightarrow> (\<exists>A B. P = (Var x' - s) * A + B \<and> x' \<notin> vars B)\<close> for n
  proof (induction n)
    case 0
    then show ?case by auto
  next
    case (Suc n)
    then have IH: \<open>m\<le>n \<Longrightarrow> MPoly_Type.degree P x' < m \<Longrightarrow>
              (\<exists>A B. P = (Var x' - s) * A + B \<and> x' \<notin> vars B)\<close> for m P
      by fast
    show ?case
    proof (intro allI impI)
     fix m and P :: \<open>int mpoly\<close>
     assume \<open>m \<le> Suc n\<close> and deg: \<open>MPoly_Type.degree P x' < m\<close>
     consider
       \<open>m \<le> n\<close> |
       \<open>m = Suc n\<close>
       using \<open>m \<le> Suc n\<close> by linarith
     then show \<open>\<exists>A B. P = (Var x' - s) * A + B \<and> x' \<notin> vars B\<close>
     proof cases
       case 1
       then show \<open>?thesis\<close>
         using Suc deg by blast
     next
       case [simp]: 2
       obtain A B where
         P: \<open>P = Var x' * A + B\<close> and
         \<open>x' \<notin> vars B\<close>
         using polynomial_split_on_var[of P x'] unfolding eq by blast
       have P': \<open>P = (Var x' - s) * A + (s * A + B)\<close>
         by (auto simp: field_simps P)
       have \<open>A = 0 \<or> degree (s * A) x' < degree P x'\<close>
         using deg \<open>x' \<notin> vars B\<close> \<open>x' \<notin> vars s\<close> degree_times_le[of s A x'] deg
         unfolding P
         by (auto simp: degree_sum_notin degree_mult_Var' degree_mult_Var degree_notin_vars
           split: if_splits)
       then obtain A' B' where
         sA: \<open>s*A = (Var x' - s) * A' + B'\<close> and
         \<open>x' \<notin> vars B'\<close>
         using IH[of \<open>m-1\<close> \<open>s*A\<close>] deg \<open>x' \<notin> vars B\<close> that[of 0 0]
         by (cases \<open>0 < n\<close>) (auto dest!: vars_in_right_only)
       have \<open>P = (Var x' - s) * (A + A') + (B' + B)\<close>
         unfolding P' sA by (auto simp: field_simps)
       moreover have \<open>x' \<notin> vars (B' + B)\<close>
         using \<open>x' \<notin> vars B'\<close>  \<open>x' \<notin> vars B\<close>
         by (meson UnE subset_iff vars_add)
       ultimately show ?thesis
         by fast
     qed
   qed
  qed
  then show ?thesis
    using that unfolding eq
    by blast
qed

lemma finit_whenI[intro]:
  \<open>finite  {x. (0 :: nat) < (y x)} \<Longrightarrow> finite {x. 0 < (y x when x \<noteq> x')}\<close>
  apply (rule finite_subset)
    defer apply assumption
  apply (auto simp: when_def)
  done

lemma polynomial_split_on_var_diff_sq2:
 fixes p :: \<open>int mpoly\<close>
  obtains q r s where
    \<open>p = monom (monomial (Suc 0) x') 1 * q + r + s * (monom (monomial (Suc 0) x') 1^2 - monom (monomial (Suc 0) x') 1)\<close> and
    \<open>x' \<notin> vars r\<close> and
    \<open>x' \<notin> vars q\<close>
proof -
  let ?v = \<open>monom (monomial (Suc 0) x') 1 :: int mpoly\<close>
  have H: \<open>n < m \<Longrightarrow> n > 0 \<Longrightarrow> \<exists>q. ?v^n = ?v + q * (?v^2 - ?v)\<close> for n m :: nat
  proof (induction m arbitrary: n)
    case 0
    then show ?case by auto
  next
    case (Suc m n) note IH = this(1-)
    consider
      \<open>n < m\<close> |
      \<open>m = n\<close> \<open>n > 1\<close> |
      \<open>n = 1\<close>
      using IH
      by (cases \<open>n < m\<close>; cases n) auto
    then show ?case
    proof cases
      case 1
      then show ?thesis using IH by auto
    next
      case 2
      have eq: \<open>?v^(n) = ((?v :: int mpoly) ^ (n-2)) * (?v^2-?v) + ?v^(n-1)\<close>
        using 2 by (auto simp: field_simps power_eq_if
          ideal.scale_right_diff_distrib)
      obtain q where
        q: \<open>?v^(n-1) = ?v + q * (?v^2 - ?v)\<close>
        using IH(1)[of \<open>n-1\<close>] 2
        by auto
      show ?thesis
        using q unfolding eq
        by (auto intro!: exI[of _ \<open>?v ^ (n - 2) + q\<close>] simp: distrib_right)
    next
      case 3
      then show \<open>?thesis\<close>
        by auto
    qed
  qed
  have H: \<open>n>0 \<Longrightarrow> \<exists>q. ?v^n = ?v + q * (?v^2-?v)\<close> for n
    using H[of n \<open>n+1\<close>]
    by auto
  obtain qr :: \<open>nat \<Rightarrow> int mpoly\<close> where
     qr: \<open>n > 0 \<Longrightarrow> ?v^n = ?v + qr n * (?v^2-?v)\<close> for n
   using H by metis
  have vn: \<open>(if lookup x x' = 0 then 1 else Var x' ^ lookup x x') =
    (if lookup x x' = 0 then 1 else ?v) + (if lookup x x' = 0 then 0 else 1) * qr (lookup x x') * (?v^2-?v)\<close> for x
    by (simp add: qr[symmetric] Var_def Var\<^sub>0_def monom.abs_eq[symmetric] cong: if_cong)

  have q: \<open>p = (\<Sum>x\<in>keys (mapping_of p). MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
    by (rule polynomial_sum_monoms(1)[of p])
  have [simp]:
    \<open>lookup x x' = 0 \<Longrightarrow>
    Abs_poly_mapping (\<lambda>k. lookup x k when k \<noteq> x') = x\<close> for x
    by (cases x, auto simp: poly_mapping.Abs_poly_mapping_inject)
      (auto intro!: ext simp: when_def)
  have [simp]: \<open>finite {x. 0 < (a when x' = x)}\<close> for a :: nat
    by (metis (no_types, lifting) infinite_nat_iff_unbounded less_not_refl lookup_single lookup_single_not_eq mem_Collect_eq)

  have [simp]: \<open>((\<lambda>x. x + monomial (Suc 0) x') ^^ (n))
     (monomial (Suc 0) x') = Abs_poly_mapping (\<lambda>k. (if k = x' then n+1 else 0))\<close> for n
    by (induction n)
     (auto simp: single_def Abs_poly_mapping_inject plus_poly_mapping.abs_eq eq_onp_def cong:if_cong)
  have [simp]: \<open>0 < lookup x x' \<Longrightarrow>
    Abs_poly_mapping (\<lambda>k. lookup x k when k \<noteq> x') +
    Abs_poly_mapping (\<lambda>k. if k = x' then lookup x x' - Suc 0 + 1 else 0) =
    x\<close> for x
    apply (cases x, auto simp: poly_mapping.Abs_poly_mapping_inject plus_poly_mapping.abs_eq eq_onp_def)
    apply (subst plus_poly_mapping.abs_eq)
    apply (auto simp: poly_mapping.Abs_poly_mapping_inject plus_poly_mapping.abs_eq eq_onp_def)
    apply (subst Abs_poly_mapping_inject)
    apply auto
    done
  define f where
    \<open>f x = (MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x)) *
      (if lookup x x' = 0 then 1 else Var x' ^ (lookup x x'))\<close> for x
  have f_alt_def: \<open>f x = MPoly_Type.monom x (MPoly_Type.coeff p x)\<close> for x
    by (auto simp: f_def monom_def remove_key_def Var_def MPoly_monomial_power Var\<^sub>0_def
      mpoly.MPoly_inject monomial_inj times_mpoly.abs_eq
      times_mpoly.abs_eq mult_single)
  have p: \<open>p = (\<Sum>x\<in>keys (mapping_of p).
       MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x) *
       (if lookup x x' = 0 then 1 else ?v)) +
          (\<Sum>x\<in>keys (mapping_of p).
       MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x) *
       (if lookup x x' = 0 then 0
        else 1) * qr (lookup x x')) *
             (?v\<^sup>2 - ?v)\<close>
    (is \<open>_ = ?a + ?v2v\<close>)
    apply (subst q)
    unfolding f_alt_def[symmetric, abs_def] f_def vn semiring_class.distrib_left
      comm_semiring_1_class.semiring_normalization_rules(18) semiring_0_class.sum_distrib_right
    by (simp add: semiring_class.distrib_left
      sum.distrib)

  have I: \<open>keys (mapping_of p) = {x \<in> keys (mapping_of p). lookup x x' = 0} \<union> {x \<in> keys (mapping_of p). lookup x x' \<noteq> 0}\<close>
    by auto

  have \<open>p = (\<Sum>x | x \<in> keys (mapping_of p) \<and> lookup x x' = 0.
       MPoly_Type.monom x (MPoly_Type.coeff p x)) +
    (\<Sum>x | x \<in> keys (mapping_of p) \<and> lookup x x' \<noteq> 0.
       MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x)) *
       (MPoly_Type.monom (monomial (Suc 0) x') 1) +
     (\<Sum>x | x \<in> keys (mapping_of p) \<and> lookup x x' \<noteq> 0.
        MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x) *
        qr (lookup x x')) *
             (?v\<^sup>2 - ?v)\<close>
    (is \<open>p = ?A + ?B * _ + ?C * _\<close>)
    unfolding semiring_0_class.sum_distrib_right[of _ _ \<open>(MPoly_Type.monom (monomial (Suc 0) x') 1)\<close>]
    apply (subst p)
    apply (subst (2)I)
    apply (subst I)
    apply (subst comm_monoid_add_class.sum.union_disjoint)
    apply auto[3]
    apply (subst comm_monoid_add_class.sum.union_disjoint)
    apply auto[3]
    apply (subst (4) sum.cong[OF refl, of _ _ \<open>\<lambda>x. MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x) *
        qr (lookup x x')\<close>])
    apply (auto; fail)
    apply (subst (3) sum.cong[OF refl, of _ _ \<open>\<lambda>x. 0\<close>])
    apply (auto; fail)
    apply (subst (2) sum.cong[OF refl, of _ _ \<open>\<lambda>x. MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x) *
       (MPoly_Type.monom (monomial (Suc 0) x') 1)\<close>])
    apply (auto; fail)
    apply (subst (1) sum.cong[OF refl, of _ _ \<open>\<lambda>x. MPoly_Type.monom x (MPoly_Type.coeff p x)\<close>])
    by (auto simp: f_def simp flip: f_alt_def)

  moreover have \<open>x' \<notin> vars ?A\<close>
    using vars_setsum[of \<open>{x \<in> keys (mapping_of p). lookup x x' = 0}\<close>
      \<open>\<lambda>x. MPoly_Type.monom x (MPoly_Type.coeff p x)\<close>]
    apply auto
    apply (drule set_rev_mp, assumption)
    apply (auto dest!: lookup_eq_zero_in_keys_contradict)
    by (meson lookup_eq_zero_in_keys_contradict subsetD vars_monom_subset)
  moreover have \<open>x' \<notin> vars ?B\<close>
    using vars_setsum[of \<open>{x \<in> keys (mapping_of p). lookup x x' \<noteq> 0}\<close>
      \<open>\<lambda>x. MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x)\<close>]
    apply auto
    apply (drule set_rev_mp, assumption)
    apply (auto dest!: lookup_eq_zero_in_keys_contradict)
    apply (drule subsetD[OF vars_monom_subset])
    apply (auto simp: remove_key_keys[symmetric])
    done
  ultimately show ?thesis apply -
    apply (rule that[of ?B ?A ?C])
    apply (auto simp: ac_simps)
    done
qed

lemma polynomial_decomp_alien_var:
  fixes q A b :: \<open>int mpoly\<close>
  assumes
    q: \<open>q = A * (monom (monomial (Suc 0) x') 1) + b\<close> and
    x: \<open>x' \<notin> vars q\<close> \<open>x' \<notin> vars b\<close>
  shows
    \<open>A = 0\<close> and
    \<open>q = b\<close>
proof -
  let ?A = \<open>A * (monom (monomial (Suc 0) x') 1)\<close>
  have \<open>?A = q - b\<close>
    using arg_cong[OF q, of \<open>\<lambda>a. a - b\<close>]
    by auto
  moreover have \<open>x' \<notin> vars (q - b)\<close>
    using x vars_in_right_only
    by fastforce
  ultimately have \<open>x' \<notin> vars (?A)\<close>
    by simp
  then have \<open>?A = 0\<close>
    by (auto simp: vars_mult_monom split: if_splits)
  moreover have \<open>?A = 0 \<Longrightarrow> A = 0\<close>
    by (metis empty_not_insert mult_zero_left vars_mult_monom)
  ultimately show \<open>A = 0\<close>
    by blast
  then show \<open>q = b\<close>
    using q by auto
qed

lemma polynomial_decomp_alien_var2:
  fixes q A b :: \<open>int mpoly\<close>
  assumes
    q: \<open>q = A * (monom (monomial (Suc 0) x') 1 + p) + b\<close> and
    x: \<open>x' \<notin> vars q\<close> \<open>x' \<notin> vars b\<close> \<open>x' \<notin> vars p\<close>
  shows
    \<open>A = 0\<close> and
    \<open>q = b\<close>
proof -
  let ?x = \<open>monom (monomial (Suc 0) x') 1\<close>
  have x'[simp]: \<open>?x = Var x'\<close>
    by (simp add: Var.abs_eq Var\<^sub>0_def monom.abs_eq)
  have \<open>\<exists>n Ax A'. A = ?x * Ax + A' \<and> x' \<notin> vars A' \<and> degree Ax x' = n\<close>
    using polynomial_split_on_var[of A x'] by metis
  from wellorder_class.exists_least_iff[THEN iffD1, OF this] obtain Ax A' n where
    A: \<open>A = Ax * ?x + A'\<close> and
    \<open>x' \<notin> vars A'\<close> and
    n: \<open>MPoly_Type.degree Ax x' = n\<close> and
    H: \<open>\<And>m Ax A'. m < n \<longrightarrow>
                   A \<noteq> Ax * MPoly_Type.monom (monomial (Suc 0) x') 1 + A' \<or>
                   x' \<in> vars A' \<or> MPoly_Type.degree Ax x' \<noteq> m\<close>
    unfolding wellorder_class.exists_least_iff[of \<open>\<lambda>n. \<exists>Ax A'. A = Ax * ?x + A' \<and> x' \<notin> vars A' \<and>
      degree Ax x' = n\<close>]
    by (auto simp: field_simps)

  have \<open>q = (A + Ax * p) * monom (monomial (Suc 0) x') 1 + (p * A' + b)\<close>
    unfolding q A by (auto simp: field_simps)
  moreover have \<open>x' \<notin> vars q\<close> \<open>x' \<notin> vars (p * A' + b)\<close>
    using x \<open>x' \<notin> vars A'\<close>
    by (smt (verit) UnE add.assoc add.commute calculation subset_iff vars_in_right_only vars_mult)+
  ultimately have \<open>A + Ax * p = 0\<close> \<open>q = p * A' + b\<close>
    by (rule polynomial_decomp_alien_var)+

  have A': \<open>A' = -Ax * ?x - Ax * p\<close>
    using \<open>A + Ax * p = 0\<close> unfolding A
    by (metis (no_types, lifting) add_uminus_conv_diff eq_neg_iff_add_eq_0 minus_add_cancel
        mult_minus_left)

  have \<open>A = - (Ax * p)\<close>
    using A unfolding A'
    apply auto
    done

  obtain Axx Ax' where
    Ax: \<open>Ax = ?x * Axx + Ax'\<close> and
    \<open>x' \<notin> vars Ax'\<close>
    using polynomial_split_on_var[of Ax x'] by metis

  have \<open>A = ?x * (- Axx * p) + (- Ax' * p)\<close>
    unfolding \<open>A = - (Ax * p)\<close> Ax
    by (auto simp: field_simps)

  moreover have \<open>x' \<notin> vars (-Ax' * p)\<close>
    using \<open>x' \<notin> vars Ax'\<close> by (metis (no_types, opaque_lifting) UnE add.right_neutral
      add_minus_cancel assms(4) subsetD vars_in_right_only vars_mult)
   moreover have \<open>Axx \<noteq> 0 \<Longrightarrow> MPoly_Type.degree (- Axx * p) x' < degree Ax x'\<close>
     using degree_times_le[of Axx p x'] x
     by (auto simp: Ax degree_sum_notin \<open>x' \<notin> vars Ax'\<close> degree_mult_Var'
       degree_notin_vars)
   ultimately have [simp]: \<open>Axx = 0\<close>
     using H[of \<open>MPoly_Type.degree (- Axx * p) x'\<close> \<open>- Axx * p\<close> \<open>- Ax' * p\<close>]
     by (auto simp: n)
  then have [simp]: \<open>Ax' = Ax\<close>
    using Ax by auto

  show \<open>A = 0\<close>
    using A \<open>A = - (Ax * p)\<close> \<open>x' \<notin> vars (- Ax' * p)\<close> \<open>x' \<notin> vars A'\<close> polynomial_decomp_alien_var(1) by force
  then show \<open>q = b\<close>
    using q by auto
qed

lemma vars_unE: \<open>x \<in> vars (a * b) \<Longrightarrow> (x \<in> vars a \<Longrightarrow> thesis) \<Longrightarrow> (x \<in> vars b \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
   using vars_mult[of a b] by auto

lemma in_keys_minusI1:
  assumes "t \<in> keys p" and "t \<notin> keys q"
  shows "t \<in> keys (p - q)"
  using assms unfolding in_keys_iff lookup_minus by simp

lemma in_keys_minusI2:
  fixes t :: \<open>'a\<close> and q :: \<open>'a \<Rightarrow>\<^sub>0 'b :: {cancel_comm_monoid_add,group_add}\<close>
  assumes "t \<in> keys q" and "t \<notin> keys p"
  shows "t \<in> keys (p - q)"
  using assms unfolding in_keys_iff lookup_minus by simp

lemma in_vars_addE:
  \<open>x \<in> vars (p + q) \<Longrightarrow> (x \<in> vars p \<Longrightarrow> thesis) \<Longrightarrow> (x \<in> vars q \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
  by (meson UnE in_mono vars_add)

lemma lookup_monomial_If:
  \<open>lookup (monomial v k) = (\<lambda>k'. if k = k' then v else 0)\<close>
  by (intro ext) (auto simp: lookup_single_not_eq)

lemma vars_mult_Var:
  \<open>vars (Var x * p) = (if p = 0 then {} else insert x (vars p))\<close> for p :: \<open>int mpoly\<close>
proof -
  have \<open>p \<noteq> 0 \<Longrightarrow>
    \<exists>xa. (\<exists>k. xa = monomial (Suc 0) x + k) \<and>
         lookup (mapping_of p) (xa - monomial (Suc 0) x) \<noteq> 0 \<and>
         0 < lookup xa x\<close>
   by (metis (no_types, opaque_lifting) One_nat_def ab_semigroup_add_class.add.commute
     add_diff_cancel_right' aux lookup_add lookup_single_eq mapping_of_inject
     neq0_conv one_neq_zero plus_eq_zero_2 zero_mpoly.rep_eq)
  then show ?thesis
    apply (auto simp: vars_def times_mpoly.rep_eq Var.rep_eq
    elim!: in_keys_timesE dest: keys_add')
    apply (auto simp: keys_def lookup_times_monomial_left Var.rep_eq Var\<^sub>0_def adds_def
      lookup_add eq_diff_eq'[symmetric])
    done
qed

lemma keys_mult_monomial:
  \<open>keys (monomial (n :: int) k * mapping_of a) = (if n = 0 then {} else ((+) k) ` keys (mapping_of a))\<close>
proof -
  have [simp]: \<open>(\<Sum>aa. (if k = aa then n else 0) *
               (\<Sum>q. lookup (mapping_of a) q when k + xa = aa + q)) =
        (\<Sum>aa. (if k = aa then n * (\<Sum>q. lookup (mapping_of a) q when k + xa = aa + q) else 0))\<close>
      for xa
    by (smt (verit) Sum_any.cong mult_not_zero)
  show ?thesis
    apply (auto simp: vars_def times_mpoly.rep_eq Const.rep_eq times_poly_mapping.rep_eq
      Const\<^sub>0_def elim!: in_keys_timesE split: if_splits)
    apply (auto simp: lookup_monomial_If prod_fun_def
      keys_def times_poly_mapping.rep_eq)
    done
qed

lemma vars_mult_Const:
  \<open>vars (Const n * a) = (if n = 0 then {} else vars a)\<close> for a :: \<open>int mpoly\<close>
  by (auto simp: vars_def times_mpoly.rep_eq Const.rep_eq keys_mult_monomial
    Const\<^sub>0_def elim!: in_keys_timesE split: if_splits)

lemma coeff_minus: "coeff p m - coeff q m = coeff (p-q) m"
  by (simp add: coeff_def lookup_minus minus_mpoly.rep_eq)

lemma Const_1_eq_1: \<open>Const (1 :: int) = (1 :: int mpoly)\<close>
  by (simp add: Const.abs_eq Const\<^sub>0_one one_mpoly.abs_eq)

lemma [simp]:
  \<open>vars (1 :: int mpoly) = {}\<close>
  by (auto simp: vars_def one_mpoly.rep_eq Const_1_eq_1)

subsection \<open>More Ideals\<close>

lemma
  fixes A :: \<open>(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_ring_1) set\<close>
  assumes \<open>p \<in> ideal A\<close>
  shows \<open>p * q \<in> ideal A\<close>
  by (metis assms ideal.span_scale semiring_normalization_rules(7))

text \<open>The following theorem is very close to @{thm ideal.span_insert}, except that it
is more useful if we need to take an element of \<^term>\<open>More_Modules.ideal (insert a S)\<close>.\<close>
lemma ideal_insert':
  \<open>More_Modules.ideal (insert a S) = {y. \<exists>x k. y = x + k * a \<and> x \<in> More_Modules.ideal S}\<close>
    apply (auto simp: ideal.span_insert
      intro: exI[of _ \<open>_ - k * a\<close>])
   apply (rule_tac x = \<open>x - k * a\<close> in exI)
   apply auto
   apply (rule_tac x = \<open>k\<close> in exI)
   apply auto
   done

lemma ideal_mult_right_in:
  \<open>a \<in> ideal A \<Longrightarrow> a * b \<in> More_Modules.ideal A\<close>
  by (metis ideal.span_scale mult.commute)

lemma ideal_mult_right_in2:
  \<open>a \<in> ideal A \<Longrightarrow> b * a \<in> More_Modules.ideal A\<close>
  by (metis ideal.span_scale)

lemma [simp]: \<open>vars (Var x :: 'a :: {zero_neq_one} mpoly) = {x}\<close>
  by (auto simp: vars_def Var.rep_eq  Var\<^sub>0_def)

lemma vars_minus_Var_subset:
  \<open>vars (p' - Var x :: 'a :: {ab_group_add,one,zero_neq_one} mpoly) \<subseteq>  \<V> \<Longrightarrow> vars p' \<subseteq> insert x \<V>\<close>
  using vars_add[of \<open>p' - Var x\<close> \<open>Var x\<close>]
  by auto

lemma vars_add_Var_subset:
  \<open>vars (p' + Var x :: 'a :: {ab_group_add,one,zero_neq_one} mpoly) \<subseteq>  \<V> \<Longrightarrow> vars p' \<subseteq> insert x \<V>\<close>
  using vars_add[of \<open>p' + Var x\<close> \<open>-Var x\<close>]
  by auto

lemma coeff_monomila_in_varsD:
  \<open>coeff p (monomial (Suc 0) x) \<noteq> 0 \<Longrightarrow> x \<in> vars (p :: int mpoly)\<close>
  by (auto simp: coeff_def vars_def keys_def
    intro!: exI[of _ \<open>monomial (Suc 0) x\<close>])

lemma coeff_MPoly_monomial[simp]:
  \<open>(MPoly_Type.coeff (MPoly (monomial a m)) m) = a\<close>
  by (metis MPoly_Type.coeff_def lookup_single_eq monom.abs_eq monom.rep_eq)

end